yap-6.3/pl/checker.yap

/*************************************************************************
*									 *
*	 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						 *
* comments:	style checker for Prolog				 *
*									 *
* Last rev:     $Date: 2008-03-31 22:56:22 $,$Author: vsc $						 *
* $Log: not supported by cvs2svn $
* Revision 1.23  2007/11/26 23:43:09  vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
* Revision 1.22  2006/11/17 12:10:46  vsc
* style_checker was failing on DCGs
*
* Revision 1.21  2006/03/24 16:26:31  vsc
* code review
*
* Revision 1.20  2005/11/05 23:56:10  vsc
* should have meta-predicate definitions for calls,
*   multifile and discontiguous.
* have discontiguous as a builtin, not just as a
*   declaration.
*
* Revision 1.19  2005/10/28 17:38:50  vsc
* sveral updates
*
* Revision 1.18  2005/04/20 20:06:11  vsc
* try to improve error handling and warnings from within consults.
*
* Revision 1.17  2005/04/20 04:08:20  vsc
* fix warnings
*
* Revision 1.16  2005/01/13 05:47:27  vsc
* lgamma broke arithmetic optimisation
* integer_y has type y
* pass original source to checker (and maybe even use option in parser)
* use warning mechanism for checker messages.
*
* Revision 1.15  2004/06/29 19:12:01  vsc
* fix checker messages
*
* Revision 1.14  2004/06/29 19:04:46  vsc
* fix multithreaded version
* include new version of Ricardo's profiler
* new predicat atomic_concat
* allow multithreaded-debugging
* small fixes
*
* Revision 1.13  2004/03/19 11:35:42  vsc
* trim_trail for default machine
* be more aggressive about try-retry-trust chains.
*    - handle cases where block starts with a wait
*    - don't use _killed instructions, just let the thing rot by itself.
*                                                                  *
*									 *
*************************************************************************/

%
% A Small style checker for YAP

:- op(1150, fx, multifile).

style_check(V) :- var(V), !, fail.
style_check(all) :-
	'$syntax_check_single_var'(_,on),
	'$syntax_check_discontiguous'(_,on),
	'$syntax_check_multiple'(_,on).
style_check(single_var) :-
	'$syntax_check_single_var'(_,on).
style_check(singleton) :-
	style_check(single_var).
style_check(-single_var) :-
	no_style_check(single_var).
style_check(-singleton) :-
	no_style_check(single_var).
style_check(discontiguous) :-
	'$syntax_check_discontiguous'(_,on).
style_check(-discontiguous) :-
	no_style_check(discontiguous).
style_check(multiple) :-
	'$syntax_check_multiple'(_,on).
style_check(-multiple) :-
	no_style_check(multiple).
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_single_var'(_,off),
	'$syntax_check_discontiguous'(_,off),
	'$syntax_check_multiple'(_,off).
no_style_check(single_var) :-
	'$syntax_check_single_var'(_,off).
no_style_check(discontiguous) :-
	'$syntax_check_discontiguous'(_,off).
no_style_check(multiple) :-
	'$syntax_check_multiple'(_,off).
no_style_check([]).
no_style_check([H|T]) :- no_style_check(H), no_style_check(T).


'$syntax_check_single_var'(O,N) :- 
	'$values'('$syntaxchecksinglevar',O,N),
	'$checking_on'.

'$syntax_check_discontiguous'(O,N) :- 
	'$values'('$syntaxcheckdiscontiguous',O,N),
	'$checking_on'.

'$syntax_check_multiple'(O,N) :- 
	'$values'('$syntaxcheckmultiple',O,N),
	'$checking_on'.

%
% cases where you need to check a clause
%
'$checking_on' :-
	( 
	  get_value('$syntaxchecksinglevar',on)
	;
	  get_value('$syntaxcheckdiscontiguous',on)
	;
	  get_value('$syntaxcheckmultiple',on)
	), !,
	set_value('$syntaxcheckflag',on).
'$checking_on' :-
	set_value('$syntaxcheckflag',off).

% reset current state of style checker.
'$init_style_check'(File) :-
	recorded('$predicate_defs','$predicate_defs'(_,_,_,File),R),
	erase(R),
	fail.
'$init_style_check'(_).

% style checker proper..
'$check_term'(T, _, VL,P,_) :-
	get_value('$syntaxchecksinglevar',on),
	'$singletons_in_clause'(T, VL, Sv),
	Sv = [_|_],
	'$sv_warning'(Sv,T),
         fail.
'$check_term'(_, T, _,P,M) :-
	get_value('$syntaxcheckdiscontiguous',on),
	'$xtract_head'(T,M,NM,_,F,A),
	% should always fail
	'$handle_discontiguous'(F,A,NM),
	fail.
'$check_term'(_, T,_,P,M) :-
	get_value('$syntaxcheckmultiple',on),
	'$xtract_head'(T,M,NM,_,F,A),
	'$handle_multiple'(F,A,NM), 
	fail.
'$check_term'(_, T,_,_,M) :-
	( 
	    get_value('$syntaxcheckdiscontiguous',on)
	->
	       true
	;
	    get_value('$syntaxcheckmultiple',on)
	),
	nb_getval('$consulting_file',File),
	'$xtract_head'(T,M,NM,_,F,A),
	\+ (
	    % allow duplicates if we are not the last predicate to have
	    % been asserted.
	    once(recorded('$predicate_defs','$predicate_defs'(F0,A0,M0,File),_)),
	    F0 = F, A0 = A, M0 = NM
	),
	recorda('$predicate_defs','$predicate_defs'(F,A,NM,File),_),
	fail.
'$check_term'(_,_,_,_,_).

%
% output a list of singleton variables...
%
'$singletons_in_clause'(T, VL, Sv) :-
        % first check which variables are not singleton
	'$non_singletons_in_term'(T, [], V2L),
        % bound them
	'$ground_vars'(V2L),
        % the remainder which do not start by _ are our target! 
	'$sv_list'(VL, Sv).

'$ground_vars'([]).
'$ground_vars'([ground|V2L]) :-
	'$ground_vars'(V2L).

'$sv_list'([],[]).
'$sv_list'([(_=V)|T],L) :- nonvar(V), !,
	'$sv_list'(T,L).
'$sv_list'([(X=_)|T], L) :-
	atom_concat('_',_,X), !,
	'$sv_list'(T,L).
'$sv_list'([(Name=_)|T], [Name|L]) :-
	'$sv_list'(T,L).

'$sv_warning'([], _) :- !.
'$sv_warning'(SVs, T) :-
	'$current_module'(OM),
	'$xtract_head'(T, OM, M, H, Name, Arity),
	print_message(warning,singletons(SVs,(M:Name/Arity))).

'$xtract_head'(V,M,M,V,call,1) :- var(V), !.
'$xtract_head'((H:-_),OM,M,NH,Name,Arity) :- !,
        '$xtract_head'(H,OM,M,NH,Name,Arity).
'$xtract_head'((H,_),OM,M,H1,Name,Arity) :- !,
	'$xtract_head'(H,OM,M,H1,Name,Arity).
'$xtract_head'((H-->_),OM,M,HL,Name,Arity) :- !,
	'$xtract_head'(H,M,OM,_,Name,A1),
	Arity is A1+2,
	functor(HL,Name,Arity).
'$xtract_head'(M:H,_,NM,NH,Name,Arity) :- !,
	'$xtract_head'(H,M,NM,NH,Name,Arity).
'$xtract_head'(H,M,M,H,Name,Arity) :-
	functor(H,Name,Arity).

% check if a predicate is discontiguous.
'$handle_discontiguous'(F,A,M) :-
	recorded('$discontiguous_defs','$df'(F,A,M),_), !,
	fail.
'$handle_discontiguous'(F,A,M) :-
	functor(Head, F, A),
	'$is_multifile'(Head, M), !,
	fail.
'$handle_discontiguous'((:-),1,_) :- !,
	fail.
'$handle_discontiguous'(F,A,M) :-
	nb_getval('$consulting_file', FileName),
	% we have been there before
	once(recorded('$predicate_defs','$predicate_defs'(F, A, M, FileName),_)),
	% and we are not 
	\+ (
	    % the last predicate to have been asserted
	    once(recorded('$predicate_defs','$predicate_defs'(F0,A0,M0,FileName),_)),
	    F0 = F, A0 = A, M0 = M
	),
	print_message(warning,clauses_not_together((M:F/A))),
        fail.

% never complain the second time
'$handle_multiple'(F,A,M) :-
	nb_getval('$consulting_file', FileName),
	recorded('$predicate_defs','$predicate_defs'(F,A,M,FileName),_), !.
% first time we have a definition
'$handle_multiple'(F,A,M) :-
	nb_getval('$consulting_file', FileName0),
	recorded('$predicate_defs','$predicate_defs'(F,A,M,FileName),_),
	FileName \= FileName0,
	'$multiple_has_been_defined'(FileName, F/A, M), !.

% be careful about these cases.
% consult does not count
'$multiple_has_been_defined'(_, _, _) :-
	nb_getval('$consulting',true), !.	
% multifile does not count
'$multiple_has_been_defined'(_, F/A, M) :-
	functor(S, F, A),
	'$is_multifile'(S, M), !.
'$multiple_has_been_defined'(Fil,F/A,M) :-
	% first, clean up all definitions in other files
	% don't forget, we just removed everything.
	recorded('$predicate_defs','$predicate_defs'(F,A,M,FileName),R),
	erase(R),
	fail.
'$multiple_has_been_defined'(Fil,P,M) :-
	print_message(warning,defined_elsewhere(M:P,Fil)).

multifile(P) :-
	'$current_module'(OM),
	'$multifile'(P, M).

'$multifile'(V, _) :- var(V), !,
	'$do_error'(instantiation_error,multifile(V)).
'$multifile'((X,Y), M) :- !, '$multifile'(X, M), '$multifile'(Y, M).
'$multifile'(Mod:PredSpec, _) :- !,
	'$multifile'(PredSpec, Mod).
'$multifile'(N//A, M) :- !,
	integer(A),
	A1 is A+2,
	'$multifile'(N/A1, M).
'$multifile'(N/A, M) :-
	'$add_multifile'(N,A,M),
	fail.
'$multifile'(N/A, M) :-
         functor(S,N,A),
	'$is_multifile'(S, M), !.
'$multifile'(N/A, M) :- !,
	'$new_multifile'(N,A,M).
'$multifile'([H|T], M) :- !,
	'$multifile'(H,M),
	'$multifile'(T,M).
'$multifile'(P, M) :-
	'$do_error'(type_error(predicate_indicator,P),multifile(M:P)).

discontiguous(V) :-
	var(V), !,
	'$do_error'(instantiation_error,discontiguous(V)).
discontiguous(M:F) :- !,
	'$discontiguous'(F,M).
discontiguous(F) :-
	'$current_module'(M),
	'$discontiguous'(F,M).

'$discontiguous'(V,M) :- var(V), !,
	'$do_error'(instantiation_error,M:discontiguous(V)).
'$discontiguous'((X,Y),M) :- !,
	'$discontiguous'(X,M),
	'$discontiguous'(Y,M).
'$discontiguous'(M:A,_) :- !,
	'$discontiguous'(A,M).
'$discontiguous'(N//A1, M) :- !,
	integer(A1), !,
	A is A1+2,
	'$discontiguous'(N/A, M).
'$discontiguous'(N/A, M) :- !,
	( recordzifnot('$discontiguous_defs','$df'(N,A,M),_) ->
	    true
	;
	    true
	).
'$discontiguous'(P,M) :-
	'$do_error'(type_error(predicate_indicator,P),M:discontiguous(P)).

%
% did we declare multifile properly?
%
'$check_multifile_pred'(Hd, M, _) :-
	functor(Hd,Na,Ar),
	nb_getval('$consulting_file',F),
	recorded('$multifile_defs','$defined'(F,Na,Ar,M),_), !.
% oops, we did not.
'$check_multifile_pred'(Hd, M, Fl) :-
	% so this is not a multi-file predicate any longer.
	functor(Hd,Na,Ar),
	NFl is \(0x20000000) /\ Fl,
	'$flags'(Hd,M,Fl,NFl),
	'$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).