From 1369057cc4b5293a35da66fd45f64c48dfc0a4f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Mon, 13 Dec 2010 19:13:33 +0000 Subject: [PATCH] fix style checker to be more self-contained. --- C/cdmgr.c | 78 -------------------------- pl/boot.yap | 6 +- pl/checker.yap | 144 +++++++++++++++++++++++++++++++----------------- pl/consult.yap | 1 + pl/messages.yap | 8 +-- 5 files changed, 100 insertions(+), 137 deletions(-) diff --git a/C/cdmgr.c b/C/cdmgr.c index b8c7cd038..46cc99f1e 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -507,8 +507,6 @@ STATIC_PROTO(Int p_new_multifile, (void)); STATIC_PROTO(Int p_is_multifile, (void)); STATIC_PROTO(Int p_optimizer_on, (void)); STATIC_PROTO(Int p_optimizer_off, (void)); -STATIC_PROTO(Int p_in_this_f_before, (void)); -STATIC_PROTO(Int p_first_cl_in_f, (void)); STATIC_PROTO(Int p_is_dynamic, (void)); STATIC_PROTO(Int p_kill_dynamic, (void)); STATIC_PROTO(Int p_compile_mode, (void)); @@ -2431,80 +2429,6 @@ Yap_add_logupd_clause(PredEntry *pe, LogUpdClause *cl, int mode) { } } -static Int -p_in_this_f_before(void) -{ /* '$in_this_file_before'(N,A,M) */ - unsigned int arity; - Atom at; - Term t; - register consult_obj *fp; - Prop p0; - Term mod; - - if (IsVarTerm(t = Deref(ARG1)) || !IsAtomTerm(t)) - return (FALSE); - else - at = AtomOfTerm(t); - if (IsVarTerm(t = Deref(ARG2)) || !IsIntTerm(t)) - return (FALSE); - else - arity = IntOfTerm(t); - if (IsVarTerm(mod = Deref(ARG3)) || !IsAtomTerm(mod)) - return FALSE; - if (arity) - p0 = PredPropByFunc(Yap_MkFunctor(at, arity), mod); - else - p0 = PredPropByAtom(at, mod); - if (!ConsultSp || ConsultSp == ConsultBase || LastAssertedPred == RepPredProp(p0) || (fp = ConsultSp)->p == p0) - return FALSE; - else - fp++; - for (; fp < ConsultBase; ++fp) - if (fp->p == p0) - break; - if (fp != ConsultBase) - return TRUE; - else - return FALSE; -} - -static Int -p_first_cl_in_f(void) -{ /* '$first_cl_in_file'(+N,+Ar,+Mod) */ - unsigned int arity; - Atom at; - Term t; - register consult_obj *fp; - Prop p0; - Term mod; - - - if (IsVarTerm(t = Deref(ARG1)) || !IsAtomTerm(t)) - return (FALSE); - else - at = AtomOfTerm(t); - if (IsVarTerm(t = Deref(ARG2)) || !IsIntTerm(t)) - return (FALSE); - else - arity = IntOfTerm(t); - if (IsVarTerm(mod = Deref(ARG3)) || !IsAtomTerm(mod)) - return (FALSE); - if (arity) - p0 = PredPropByFunc(Yap_MkFunctor(at, arity),mod); - else - p0 = PredPropByAtom(at, mod); - if (LastAssertedPred == RepPredProp(p0)) - return FALSE; - if (!ConsultSp) - return FALSE; - for (fp = ConsultSp; fp < ConsultBase; ++fp) - if (fp->p == p0) - break; - if (fp != ConsultBase) - return FALSE; - return TRUE; -} - #if EMACS /* @@ -5732,8 +5656,6 @@ Yap_InitCdMgr(void) Yap_InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses, SyncPredFlag|HiddenPredFlag); Yap_InitCPred("$optimizer_off", 0, p_optimizer_off, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred("$kill_dynamic", 2, p_kill_dynamic, SafePredFlag|SyncPredFlag|HiddenPredFlag); - Yap_InitCPred("$in_this_file_before", 3, p_in_this_f_before, SafePredFlag|HiddenPredFlag); - Yap_InitCPred("$first_clause_in_file", 3, p_first_cl_in_f, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$new_multifile", 3, p_new_multifile, SafePredFlag|SyncPredFlag|HiddenPredFlag); Yap_InitCPred("$is_multifile", 2, p_is_multifile, TestPredFlag | SafePredFlag|HiddenPredFlag); Yap_InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag|SyncPredFlag|HiddenPredFlag); diff --git a/pl/boot.yap b/pl/boot.yap index bbe4e19a3..eac15a1b2 100755 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -461,14 +461,14 @@ true :- true. '$$compile'(G1, G0, N, HeadMod). '$prepare_term'(G, V, Pos, G0, G1, BodyMod, SourceMod, Source) :- - '$precompile_term'(G, G0, G1, BodyMod, SourceMod), ( get_value('$syntaxcheckflag',on) -> - '$check_term'(G0, V, Pos, Source, BodyMod) + '$check_term'(Source, V, Pos, BodyMod) ; true - ). + ), + '$precompile_term'(G, G0, G1, BodyMod, SourceMod). % process an input clause '$$compile'(G, G0, L, Mod) :- diff --git a/pl/checker.yap b/pl/checker.yap index 3405c2b17..ac23cb0f2 100644 --- a/pl/checker.yap +++ b/pl/checker.yap @@ -106,7 +106,6 @@ 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). @@ -119,55 +118,78 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$syntax_check_multiple'(O,N) :- '$values'('$syntaxcheckmultiple',O,N). +% reset current state of style checker. +'$init_style_check'(File) :- + recorded('$predicate_defs','$predicate_defs'(_,_,_,File),R), + erase(R), + fail. +'$init_style_check'(_). -'$check_term'(T,_,P,_Source,M) :- +% 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), - '$handle_discontiguous'(F,A,NM), fail. -'$check_term'(T,_,P,_Source,M) :- + % 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,VL,P,_Source,_) :- - get_value('$syntaxchecksinglevar',on), - ( '$chk_binding_vars'(T), - '$sv_list'(VL,Sv) - -> - '$sv_warning'(Sv,T) - ), fail. -'$check_term'(_,_,_,_,_). + '$handle_multiple'(F,A,NM), + fail. +'$check_term'(T,_,_,M) :- + once(( + get_value('$syntaxcheckdiscontiguous',on) + ; + get_value('$syntaxcheckmultiple',on) + )), + recorded('$reconsulting',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'(_,_,_,_). -'$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). +% +% 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). -'$chk_bind_in_struct'([]). -'$chk_bind_in_struct'([H|T]) :- - '$chk_binding_vars'(H), - '$chk_bind_in_struct'(T). +'$ground_vars'([]). +'$ground_vars'(ground.V2L) :- + '$ground_vars'(V2L). '$sv_list'([],[]). '$sv_list'([[[95|_]|_]|T],L) :- '$sv_list'(T,L). -'$sv_list'([[Name|'$V'(V)]|T],[Name|L]) :- var(V), !, +'$sv_list'([_|V].T,L) :- nonvar(V), !, '$sv_list'(T,L). -'$sv_list'([_|T],L) :- +'$sv_list'([Name|_].T, Name.L) :- '$sv_list'(T,L). -'$sv_warning'([],_) :- !. -'$sv_warning'(SVs,T) :- +'$sv_warning'([], _) :- !. +'$sv_warning'(SVs, T) :- '$current_module'(OM), - '$xtract_head'(T,OM,M,H,Name,Arity), - ( nb_getval('$consulting',false), - '$first_clause_in_file'(Name,Arity, OM) -> - ClN = 1 ; - '$number_of_clauses'(H,M,ClN0), - ClN is ClN0+1 - ), - print_message(warning,singletons(SVs,(M:Name/Arity),ClN)). + '$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) :- !, @@ -183,36 +205,54 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T). '$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),_), !. + recorded('$discontiguous_defs','$df'(F,A,M),_), !, + fail. '$handle_discontiguous'(F,A,M) :- functor(Head, F, A), - '$is_multifile'(Head, M), !. + '$is_multifile'(Head, M), !, + fail. '$handle_discontiguous'(F,A,M) :- - '$in_this_file_before'(F,A,M), - print_message(warning,clauses_not_together((M:F/A))). + 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) :- - \+ '$first_clause_in_file'(F,A,M), !. -'$handle_multiple'(_,_,_) :- - nb_getval('$consulting',true), !. + 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) :- - recorded('$predicate_defs','$predicate_defs'(F,A,M,Fil),_), !, - '$multiple_has_been_defined'(Fil, F/A, M), !. -'$handle_multiple'(F,A,M) :- - ( recorded('$reconsulting',Fil,_) -> true ), - recorda('$predicate_defs','$predicate_defs'(F,A,M,Fil),_). + 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) :- - recorded('$reconsulting',F,_), !, - '$test_if_well_reconsulting'(F,Fil,M:P). - -'$test_if_well_reconsulting'(F,F,_) :- !. -'$test_if_well_reconsulting'(_,Fil,P) :- - print_message(warning,defined_elsewhere(P,Fil)). + print_message(warning,defined_elsewhere(M:P,Fil)). '$multifile'(V, _) :- var(V), !, '$do_error'(instantiation_error,multifile(V)). diff --git a/pl/consult.yap b/pl/consult.yap index 598c56f53..adbf17b64 100755 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -252,6 +252,7 @@ use_module(M,F,Is) :- '$access_yap_flags'(18,GenerateDebug), '$consult_infolevel'(InfLevel), '$comp_mode'(OldCompMode, CompMode), + ( get_value('$syntaxcheckflag',on) -> '$init_style_check'(File) ; true ), recorda('$initialisation','$',_), ( Reconsult = reconsult -> '$start_reconsulting'(File), diff --git a/pl/messages.yap b/pl/messages.yap index a3f7dbbec..9adc30ca4 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -129,10 +129,10 @@ system_message(leash([A|B])) --> [ 'Leashing set to ~w.' - [[A|B]] ]. system_message(existence_error(prolog_flag,F)) --> [ 'Prolog Flag ~w: new Prolog flags must be created using create_prolog_flag/3.' - [F] ]. -system_message(singletons([SV],P,CLN)) --> - [ 'Singleton variable ~s in ~q, clause ~d.' - [SV,P,CLN] ]. -system_message(singletons(SVs,P,CLN)) --> - [ 'Singleton variables ~s in ~q, clause ~d.' - [SVsL, P, CLN] ], +system_message(singletons([SV],P)) --> + [ 'Singleton variable ~s in ~q.' - [SV,P] ]. +system_message(singletons(SVs,P)) --> + [ 'Singleton variables ~s in ~q.' - [SVsL, P] ], { svs(SVs,SVsL,[]) }. system_message(trace_command(-1)) --> [ 'EOF is not a valid debugger command.' ].