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
Vitor Santos Costa cc84cd8cb5 check for mistypes
2014-04-06 17:05:17 +01:00

246 lines
7.0 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 *
* 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, _,P,M) :-
get_value('$syntaxcheckdiscontiguous',on),
strip_module(T, M, T1),
'$pred_arity'( T1, Name, Arity ),
% should always fail
'$handle_discontiguous'(Name, Arity, M),
fail.
'$check_term'(_, T,_,P,M) :-
get_value('$syntaxcheckmultiple',on),
strip_module(T, M, T1),
'$pred_arity'( T1, Name, Arity ),
'$handle_multiple'( Name , Arity, M),
fail.
'$check_term'(_, T,_,_,M) :-
(
get_value('$syntaxcheckdiscontiguous',on)
->
true
;
get_value('$syntaxcheckmultiple',on)
),
source_location( File, _ ),
strip_module(T, M, T1),
'$pred_arity'( T1, Name, Arity ),
\+ (
% 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'(_,_,_,_,_).
'$sv_warning'([], _) :- !.
'$sv_warning'(SVs, T) :-
strip_module(T, M, T1),
'$pred_arity'( T1, Name, Arity ),
print_message(warning,singletons(SVs,(M:Name/Arity))).
'$pred_arity'(V,M,M,V,call,1) :- var(V), !.
'$pred_arity'((H:-_),Name,Arity) :- !,
functor(H,Name,Arity).
'$pred_arity'((H-->_),Name,Arity) :- !,
functor(HL,Name,1),
Arity is A1+2.
'$pred_arity'(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) :-
source_location( 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) :-
source_location(FileName, _),
recorded('$predicate_defs','$predicate_defs'(F,A,M,FileName),_), !.
% first time we have a definition
'$handle_multiple'(F,A,M) :-
source_location(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_file', _, fail), !.
% 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)).