This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/pl/checker.yap
vsc e5f4633c39 This commit was generated by cvs2svn to compensate for changes in r4,
which included commits to RCS files with non-trunk default branches.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@5 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2001-04-09 19:54:03 +00:00

264 lines
7.5 KiB
Prolog

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: checker.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: style checker Prolog *
* *
*************************************************************************/
%
% A Small style checker for YAP
:- op(1150, fx, multifile).
style_check(V) :- var(V), !, fail.
style_check(all) :- '$syntax_check_mode'(_,on),
'$syntax_check_single_var'(_,on),
'$syntax_check_discontiguous'(_,on),
'$syntax_check_multiple'(_,on).
style_check(single_var) :- '$syntax_check_mode'(_,on),
'$syntax_check_single_var'(_,on).
style_check(discontiguous) :- '$syntax_check_mode'(_,on),
'$syntax_check_discontiguous'(_,on).
style_check(multiple) :- '$syntax_check_mode'(_,on),
'$syntax_check_multiple'(_,on).
style_check([]).
style_check([H|T]) :- style_check(H), style_check(T).
no_style_check(V) :- var(V), !, fail.
no_style_check(all) :- $syntax_check_mode(_,off),
'$syntax_check_single_var'(_,off),
'$syntax_check_discontiguous'(_,off),
'$syntax_check_multiple'(_,off).
no_style_check(single_var) :- '$syntax_check_mode'(_,off),
'$syntax_check_single_var'(_,off).
no_style_check(discontiguous) :- '$syntax_check_mode'(_,off),
'$syntax_check_discontiguous'(_,off).
no_style_check(multiple) :- '$syntax_check_mode'(_,on),
'$syntax_check_multiple'(_,off).
no_style_check([]).
no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
'$syntax_check_mode'(O,N) :-
'$values'('$syntaxcheckflag',O,N).
'$syntax_check_single_var'(O,N) :-
'$values'('$syntaxchecksinglevar',O,N).
'$syntax_check_discontiguous'(O,N) :-
'$values'('$syntaxcheckdiscontiguous',O,N).
'$syntax_check_multiple'(O,N) :-
'$values'('$syntaxcheckmultiple',O,N).
'$check_term'(T,_) :-
'$get_value'('$syntaxcheckdiscontiguous',on),
'$xtract_head'(T,_,F,A),
'$handle_discontiguous'(F,A), fail.
'$check_term'(T,_) :-
'$get_value'('$syntaxcheckmultiple',on),
'$xtract_head'(T,_,F,A),
'$handle_multiple'(F,A), fail.
'$check_term'(T,VL) :-
'$get_value'('$syntaxchecksinglevar',on),
( '$chk_binding_vars'(T),
'$sv_list'(VL,Sv) ->
'$sv_warning'(Sv,T) ), fail.
'$check_term'(_,_).
'$chk_binding_vars'(V) :- var(V), !, V = '$V'(_).
'$chk_binding_vars'('$V'(off)) :- !.
'$chk_binding_vars'(A) :- primitive(A), !.
'$chk_binding_vars'(S) :- S =.. [_|L],
'$chk_bind_in_struct'(L).
'$chk_bind_in_struct'([]).
'$chk_bind_in_struct'([H|T]) :-
'$chk_binding_vars'(H),
'$chk_bind_in_struct'(T).
'$sv_list'([],[]).
'$sv_list'([[[95|_]|_]|T],L) :-
'$sv_list'(T,L).
'$sv_list'([[Name|'$V'(V)]|T],[Name|L]) :- var(V), !,
'$sv_list'(T,L).
'$sv_list'([_|T],L) :-
'$sv_list'(T,L).
$sv_warning([],_) :- !.
$sv_warning(SVs,T) :-
'$xtract_head'(T,H,Name,Arity),
write(user_error,'[ Warning: singleton variable '),
'$write_svs'(SVs),
write(user_error,' in '),
write(user_error,Name/Arity),
write(user_error,' (line '),
'$start_line'(LN), write(user_error,LN),
write(user_error,', clause '),
( '$get_value'('$consulting',false),
'$first_clause_in_file'(Name,Arity) ->
ClN = 1 ;
'$number_of_clauses'(H,ClN0),
ClN is ClN0+1
),
write(user_error,ClN),
write(user_error,') ]'),
nl(user_error).
'$xtract_head'((H:-_),H,Name,Arity) :- !,
functor(H,Name,Arity).
'$xtract_head'((H,_),H1,Name,Arity) :- !,
'$xtract_head'(H,H1,Name,Arity).
'$xtract_head'((H-->_),HL,Name,Arity) :- !,
'$xtract_head'(H,H1,Name,A1),
Arity is A1+2,
functor(HL,Name,Arity).
'$xtract_head'(H,H,Name,Arity) :-
functor(H,Name,Arity).
'$write_svs'([H]) :- !, write(user_error,' '), '$write_svs1'([H]).
'$write_svs'(SVs) :- write(user_error,'s '), '$write_svs1'(SVs).
'$write_svs1'([H]) :- !,
'$write_str_in_stderr'(H).
'$write_svs1'([H|T]) :-
'$write_str_in_stderr'(H),
write(user_error,','),
'$write_svs1'(T).
'$write_str_in_stderr'([]).
'$write_str_in_stderr'([C|T]) :-
put(user_error,C),
'$write_str_in_stderr'(T).
'$handle_discontiguous'(F,A) :-
'$current_module'(M),
'$recorded'('$discontiguous_defs','$df'(F,A,M),_), !.
'$handle_discontiguous'(F,A) :-
'$in_this_file_before'(F,A),
write(user_error,'[ Warning: discontiguous definition of '),
write(user_error,F/A), write(user_error,' (line '),
'$start_line'(LN), write(user_error,LN),
write(user_error,') ]'),
nl(user_error).
'$handle_multiple'(F,A) :-
\+ '$first_clause_in_file'(F,A), !.
'$handle_multiple'(F,A) :-
'$get_value'('$consulting',true), !.
'$handle_multiple'(F,A) :-
'$recorded'('$predicate_defs','$predicate_defs'(F,A,Fil),_), !,
'$multiple_has_been_defined'(Fil,F/A), !.
'$handle_multiple'(F,A) :-
( '$recorded'('$reconsulting',Fil,_) -> true ),
'$recorda'('$predicate_defs','$predicate_defs'(F,A,Fil),_).
'$multiple_has_been_defined'(_,F/A) :-
'$is_multifile'(F,A), !.
'$multiple_has_been_defined'(Fil,P) :-
'$recorded'('$reconsulting',F,_), !,
'$test_if_well_reconsulting'(F,Fil,P).
'$test_if_well_reconsulting'(F,F,_) :- !.
'$test_if_well_reconsulting'(_,Fil,P) :-
write(user_error,'[ Warning: predicate '),
write(user_error,P), write(user_error,' already defined in '),
write(user_error,Fil), write(user_error,' (line '),
'$start_line'(LN), write(user_error,LN),
write(user_error,') ]'),
nl(user_error).
'$multifile'(V) :- var(V), !,
throw(error(instantiation_error,multifile(V))).
'$multifile'((X,Y)) :- '$multifile'(X), '$multifile'(Y).
'$multifile'(Mod:PredSpec) :- !,
( '$current_module'(Mod) ->
'$multifile'(PredSpec)
;
'$mod_switch'(Mod,'$multifile'(PredSpec))
).
'$multifile'(N/A) :-
'$get_value'('$consulting_file',F),
'$current_module'(M),
'$recordzifnot'('$multifile_defs','$defined'(F,N,A,M),_),
fail.
'$multifile'(N/A) :-
'$is_multifile'(N,A), !.
'$multifile'(N/A) :- !,
'$new_multifile'(N,A).
'$multifile'(P) :-
throw(error(type_error(predicate_indicator,P),multifile(P))).
'$discontiguous'(V) :- var(V), !,
throw(error(instantiation_error,discontiguous(V))).
'$discontiguous'((X,Y)) :- !,
'$discontiguous'(X),
'$discontiguous'(Y).
'$discontiguous'(M:A) :- !,
'$mod_switch'(M,'$discontiguous'(A)).
'$discontiguous'(N/A) :- !,
'$current_module'(M),
( '$recordzifnot'('$discontiguous_defs','$df'(N,A,M),_) ->
true
;
true
).
'$discontiguous'(P) :-
throw(error(type_error(predicate_indicator,P),discontiguous(P))).
%
% did we declare multifile properly?
%
'$check_multifile_pred'(Hd, _) :-
functor(Hd,Na,Ar),
'$get_value'('$consulting_file',F),
'$current_module'(M),
'$recorded'('$multifile_defs','$defined'(F,Na,Ar,M),_), !.
% oops, we did not.
'$check_multifile_pred'(Hd, Fl) :-
% so this is not a multi-file predicate any longer.
functor(Hd,Na,Ar),
NFl is \(16'040000 ) /\ Fl,
'$flags'(Hd,Fl,NFl),
'$current_module'(M),
'$clear_multifile_pred'(Na,Ar,M),
'$warn_mfile'(Na,Ar).
'$warn_mfile'(F,A) :-
write(user_error,'[ Warning: predicate '),
write(user_error,F/A), write(user_error,' was a multifile predicate '),
write(user_error,' (line '),
'$start_line'(LN), write(user_error,LN),
write(user_error,') ]'),
nl(user_error).
'$clear_multifile_pred'(Na,Ar,M) :-
'$recorded'('$multifile_defs','$defined'(_,Na,Ar,M),R),
erase(R),
fail.
'$clear_multifile_pred'(Na,Ar,M) :-
'$recorded'('$multifile'(_,_,_),'$mf'(Na,Ar,M,_,_),R),
erase(R),
fail.
'$clear_multifile_pred'(Na,Ar,M) :-
'$recorded'('$multifile_dynamic'(_,_,_),'$mf'(Na,Ar,M,_,_),R),
erase(R),
fail.
'$clear_multifile_pred'(_,_,_).