From d8f4a77f47cbb2674e62012c8ff26ecd69c92eaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Thu, 24 Apr 2014 08:26:31 +0100 Subject: [PATCH] fix style_check to be called at parse-time and not cause eexcution overheads. --- C/cdmgr.c | 126 +++++++++++++++++++++++++++++++++++++++++++++++ H/Yapproto.h | 3 ++ H/Yatom.h | 1 + H/iatoms.h | 3 ++ H/pl-shared.h | 2 +- H/ratoms.h | 3 ++ H/tatoms.h | 6 +++ misc/ATOMS | 3 ++ os/pl-read.c | 18 +++++++ pl/checker.yap | 125 +--------------------------------------------- pl/flags.yap | 29 ++++++++--- pl/messages.yap | 10 ++++ pl/preddecls.yap | 9 ++-- 13 files changed, 200 insertions(+), 138 deletions(-) diff --git a/C/cdmgr.c b/C/cdmgr.c index 2754ff0af..6182248b3 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -2064,6 +2064,79 @@ addcl_permission_error(AtomEntry *ap, Int Arity, int in_use) } } +PredEntry * Yap_PredFromClause( Term t USES_REGS ) +{ + Term cmod = LOCAL_SourceModule; + UInt extra_arity = 0; + + if (IsVarTerm( t )) return NULL; + while (IsApplTerm(t)) { + Functor f = FunctorOfTerm(t); + if (f == FunctorModule) { + // module + cmod = ArgOfTerm( 1, t ); + if (!IsAtomTerm(cmod)) + return NULL; + t = ArgOfTerm( 2, t ); + } else if ( f == FunctorAssert ) { + t = ArgOfTerm(1, t); + } else if ( f == FunctorDoubleArrow ) { + extra_arity = 2; + t = ArgOfTerm(1, t); + } else if ( f == FunctorQuery || + f == FunctorAssert1) { + // directives + return NULL; + } else { + if (extra_arity) { + f = Yap_MkFunctor(NameOfFunctor(f), ArityOfFunctor(f)+2); + } + return RepPredProp(Yap_GetPredPropByFunc(f, cmod)); + } + } + if (IsAtomTerm( t )) { + if (extra_arity) { + Functor f = Yap_MkFunctor(AtomOfTerm(t), 2); + return RepPredProp(Yap_GetPredPropByFunc(f, cmod)); + } + return + RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t), cmod)); + } + // ints, lists + return NULL; +} + +int +Yap_discontiguous( PredEntry *ap USES_REGS ) +{ + register consult_obj *fp; + + if (ap->ExtraPredFlags & DiscontiguousPredFlag) + return FALSE; + if (!LOCAL_ConsultSp) { + return FALSE; + } + if (ap == LOCAL_LastAssertedPred) + return FALSE; + if (ap->cs.p_code.NOfClauses) { + for (fp = LOCAL_ConsultSp; fp < LOCAL_ConsultBase; ++fp) + if (fp->p == AbsPredProp(ap)) + return TRUE; + } + return FALSE; +} + +int +Yap_multiple( PredEntry *ap USES_REGS ) +{ + if (ap->PredFlags & MultiFileFlag) + return FALSE; + if (ap == LOCAL_LastAssertedPred) + return FALSE; + return + ap->cs.p_code.NOfClauses > 0 && + Yap_ConsultingFile( PASS_REGS1 ) != ap->src.OwnerFile; +} static int is_fact(Term t) @@ -3036,6 +3109,57 @@ p_is_multifile( USES_REGS1 ) return(out); } +static Int +p_new_discontiguous( USES_REGS1 ) +{ /* '$new_discontiguous'(+N,+Ar,+Mod) */ + Atom at; + int arity; + PredEntry *pe; + Term t = Deref(ARG1); + Term mod = Deref(ARG3); + + if (IsVarTerm(t)) + return (FALSE); + if (IsAtomTerm(t)) + at = AtomOfTerm(t); + else + return (FALSE); + t = Deref(ARG2); + if (IsVarTerm(t)) + return (FALSE); + if (IsIntTerm(t)) + arity = IntOfTerm(t); + else + return FALSE; + if (arity == 0) + pe = RepPredProp(PredPropByAtom(at, mod)); + else + pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity),mod)); + PELOCK(26,pe); + pe->ExtraPredFlags |= DiscontiguousPredFlag; + /* mutifile-predicates are weird, they do not seat really on the default module */ + if (pe->ModuleOfPred == PROLOG_MODULE) + pe->ModuleOfPred = TermProlog; + UNLOCKPE(43,pe); + return (TRUE); +} + + +static Int +p_is_discontiguous( USES_REGS1 ) +{ /* '$is_multifile'(+S,+Mod) */ + PredEntry *pe; + Int out; + + pe = get_pred(Deref(ARG1), Deref(ARG2), "discontiguous"); + if (EndOfPAEntr(pe)) + return FALSE; + PELOCK(27,pe); + out = (pe->ExtraPredFlags & DiscontiguousPredFlag); + UNLOCKPE(44,pe); + return(out); +} + static Int p_is_log_updatable( USES_REGS1 ) { /* '$is_dynamic'(+P) */ @@ -6493,6 +6617,8 @@ Yap_InitCdMgr(void) Yap_InitCPred("$kill_dynamic", 2, p_kill_dynamic, SafePredFlag|SyncPredFlag); Yap_InitCPred("$new_multifile", 3, p_new_multifile, SafePredFlag|SyncPredFlag); Yap_InitCPred("$is_multifile", 2, p_is_multifile, TestPredFlag | SafePredFlag); + Yap_InitCPred("$new_discontiguous", 3, p_new_discontiguous, SafePredFlag|SyncPredFlag); + Yap_InitCPred("$is_discontiguous", 2, p_is_discontiguous, TestPredFlag | SafePredFlag); Yap_InitCPred("$is_no_trace", 2, p_is_no_trace, TestPredFlag | SafePredFlag); Yap_InitCPred("$set_no_trace", 2, p_set_no_trace, TestPredFlag | SafePredFlag); Yap_InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag|SyncPredFlag); diff --git a/H/Yapproto.h b/H/Yapproto.h index b081fc3bf..8386b562c 100755 --- a/H/Yapproto.h +++ b/H/Yapproto.h @@ -121,6 +121,9 @@ Term Yap_all_calls(void); Atom Yap_ConsultingFile( USES_REGS1 ); struct pred_entry *Yap_PredForChoicePt(choiceptr); void Yap_InitCdMgr(void); +struct pred_entry * Yap_PredFromClause( Term t USES_REGS ); +int Yap_discontiguous(struct pred_entry *ap USES_REGS ); +int Yap_multiple(struct pred_entry *ap USES_REGS ); void Yap_init_consult(int, char *); void Yap_end_consult(void); void Yap_Abolish(struct pred_entry *); diff --git a/H/Yatom.h b/H/Yatom.h index 9669f728d..f9ebac1ca 100755 --- a/H/Yatom.h +++ b/H/Yatom.h @@ -655,6 +655,7 @@ don;t forget to also add in qly.h */ typedef enum { + DiscontiguousPredFlag = ((UInt)0x00000010 << EXTRA_FLAG_BASE), /* predicates whose clauses may be all-over the place.. */ SysExportPredFlag = ((UInt)0x00000008 << EXTRA_FLAG_BASE), /* reuse export list to prolog module. */ NoDebugPredFlag = ((UInt)0x00000004 << EXTRA_FLAG_BASE), /* cannot trace this preducate */ NoTracePredFlag = ((UInt)0x00000002 << EXTRA_FLAG_BASE), /* cannot trace this preducate */ diff --git a/H/iatoms.h b/H/iatoms.h index 8a4dcde66..ebfab56a8 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -19,6 +19,7 @@ AtomArrayOverflow = Yap_LookupAtom("array_overflow"); AtomArrayType = Yap_LookupAtom("array_type"); AtomArrow = Yap_LookupAtom("->"); + AtomDoubleArrow = Yap_LookupAtom("-->"); AtomAssert = Yap_LookupAtom(":-"); AtomEmptyBrackets = Yap_LookupAtom("()"); AtomEmptySquareBrackets = Yap_LookupAtom("[]"); @@ -356,6 +357,8 @@ FunctorArg = Yap_MkFunctor(AtomArg,3); FunctorArrayEntry = Yap_MkFunctor(AtomArrayAccess,3); FunctorArrow = Yap_MkFunctor(AtomArrow,2); + FunctorDoubleArrow = Yap_MkFunctor(AtomDoubleArrow,2); + FunctorAssert1 = Yap_MkFunctor(AtomAssert,1); FunctorAssert = Yap_MkFunctor(AtomAssert,2); FunctorAtFoundOne = Yap_MkFunctor(AtomFoundVar,2); FunctorAtom = Yap_MkFunctor(AtomAtom,1); diff --git a/H/pl-shared.h b/H/pl-shared.h index 0968992db..4dce58ee9 100755 --- a/H/pl-shared.h +++ b/H/pl-shared.h @@ -269,7 +269,7 @@ getUnknownModule(module_t m); #define SEMSINGLETON_CHECK 0x0040 /* Semantic singleton checking */ #define NOEFFECT_CHECK 0x0080 /* Check for meaningless statements */ #define VARBRANCH_CHECK 0x0100 /* warn on unbalanced variables */ -#define MULTIPLE_CHECK 0x0100 /* warn on multiple file definitions for a predicate */ +#define MULTIPLE_CHECK 0x0200 /* warn on multiple file definitions for a predicate */ #define MAXNEWLINES 5 /* maximum # of newlines in atom */ #define debugstatus (LD->_debugstatus) diff --git a/H/ratoms.h b/H/ratoms.h index b6d236910..d95d1d4e0 100644 --- a/H/ratoms.h +++ b/H/ratoms.h @@ -19,6 +19,7 @@ AtomArrayOverflow = AtomAdjust(AtomArrayOverflow); AtomArrayType = AtomAdjust(AtomArrayType); AtomArrow = AtomAdjust(AtomArrow); + AtomDoubleArrow = AtomAdjust(AtomDoubleArrow); AtomAssert = AtomAdjust(AtomAssert); AtomEmptyBrackets = AtomAdjust(AtomEmptyBrackets); AtomEmptySquareBrackets = AtomAdjust(AtomEmptySquareBrackets); @@ -356,6 +357,8 @@ FunctorArg = FuncAdjust(FunctorArg); FunctorArrayEntry = FuncAdjust(FunctorArrayEntry); FunctorArrow = FuncAdjust(FunctorArrow); + FunctorDoubleArrow = FuncAdjust(FunctorDoubleArrow); + FunctorAssert1 = FuncAdjust(FunctorAssert1); FunctorAssert = FuncAdjust(FunctorAssert); FunctorAtFoundOne = FuncAdjust(FunctorAtFoundOne); FunctorAtom = FuncAdjust(FunctorAtom); diff --git a/H/tatoms.h b/H/tatoms.h index 7c7b3f06d..24b99eaf4 100644 --- a/H/tatoms.h +++ b/H/tatoms.h @@ -36,6 +36,8 @@ #define AtomArrayType Yap_heap_regs->AtomArrayType_ Atom AtomArrow_; #define AtomArrow Yap_heap_regs->AtomArrow_ + Atom AtomDoubleArrow_; +#define AtomDoubleArrow Yap_heap_regs->AtomDoubleArrow_ Atom AtomAssert_; #define AtomAssert Yap_heap_regs->AtomAssert_ Atom AtomEmptyBrackets_; @@ -710,6 +712,10 @@ #define FunctorArrayEntry Yap_heap_regs->FunctorArrayEntry_ Functor FunctorArrow_; #define FunctorArrow Yap_heap_regs->FunctorArrow_ + Functor FunctorDoubleArrow_; +#define FunctorDoubleArrow Yap_heap_regs->FunctorDoubleArrow_ + Functor FunctorAssert1_; +#define FunctorAssert1 Yap_heap_regs->FunctorAssert1_ Functor FunctorAssert_; #define FunctorAssert Yap_heap_regs->FunctorAssert_ Functor FunctorAtFoundOne_; diff --git a/misc/ATOMS b/misc/ATOMS index f7719f8bf..6c70026b2 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -24,6 +24,7 @@ A ArrayAccess F "$array_arg" A ArrayOverflow N "array_overflow" A ArrayType N "array_type" A Arrow N "->" +A DoubleArrow N "-->" A Assert N ":-" A EmptyBrackets N "()" A EmptySquareBrackets N "[]" @@ -361,6 +362,8 @@ F AltNot AltNot 1 F Arg Arg 3 F ArrayEntry ArrayAccess 3 F Arrow Arrow 2 +F DoubleArrow DoubleArrow 2 +F Assert1 Assert 1 F Assert Assert 2 F AtFoundOne FoundVar 2 F Atom Atom 1 diff --git a/os/pl-read.c b/os/pl-read.c index 3ad3a776c..37a894066 100644 --- a/os/pl-read.c +++ b/os/pl-read.c @@ -1164,6 +1164,8 @@ retry: if ( (rval=read_term(term, &rd PASS_LD)) && (!tpos || (rval=unify_read_term_position(tpos PASS_LD))) ) { + PredEntry *ap; + if (rd.singles) { // warning, singletons([X=_A],f(X,Y,Z), pos). printMessage(ATOM_warning, @@ -1172,6 +1174,22 @@ retry: PL_TERM, term, PL_TERM, tpos ); } + ap = Yap_PredFromClause( Yap_GetFromSlot(term PASS_REGS) PASS_REGS); + if (rd.styleCheck & (DISCONTIGUOUS_STYLE|MULTIPLE_CHECK) && ap != NULL ) { + if ( rd.styleCheck & (DISCONTIGUOUS_STYLE) && Yap_discontiguous( ap PASS_REGS) ) { + printMessage(ATOM_warning, + PL_FUNCTOR_CHARS, "discontiguous", 2, + PL_TERM, term, + PL_TERM, tpos ); + } + if ( rd.styleCheck & (MULTIPLE_CHECK) && Yap_multiple( ap PASS_REGS) ) { + printMessage(ATOM_warning, + PL_FUNCTOR_CHARS, "multiple", 3, + PL_TERM, term, + PL_TERM, tpos, + PL_ATOM, YAP_SWIAtomFromAtom(ap->src.OwnerFile) ); + } + } if ( rd.comments && (rval = PL_unify_nil(rd.comments)) ) { if ( opt_comments ) diff --git a/pl/checker.yap b/pl/checker.yap index 3ac5db55b..925544e1c 100644 --- a/pl/checker.yap +++ b/pl/checker.yap @@ -73,7 +73,7 @@ % % A Small style checker for YAP -:- op(1150, fx, multifile). +:- op(1150, fx, [multifile,discontiguous]). style_check(V) :- var(V), !, fail. style_check(V) :- @@ -157,126 +157,3 @@ no_style_check(-multiple) :- 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'(_,_,_,_,_). - -% 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)). - - - diff --git a/pl/flags.yap b/pl/flags.yap index 95e2cf05b..d01a1e9d5 100755 --- a/pl/flags.yap +++ b/pl/flags.yap @@ -318,7 +318,13 @@ yap_flag(language,X) :- yap_flag(discontiguous_warnings,X) :- var(X), !, - '$syntax_check_discontiguous'(on,_). + style_check(?(Disc)), + ( Disc = +discontiguous, + `X = on + ; + Disc = -discontiguous, + `X = off + ), !. yap_flag(discontiguous_warnings,X) :- '$transl_to_on_off'(_,X), !, (X == on -> @@ -331,7 +337,13 @@ yap_flag(discontiguous_warnings,X) :- yap_flag(redefine_warnings,X) :- var(X), !, - '$syntax_check_multiple'(X,X). + style_check(?(Disc)), + ( Disc = +multiple, + `X = on + ; + Disc = -multiple, + `X = off + ), !. yap_flag(redefine_warnings,X) :- '$transl_to_on_off'(_,X), !, (X == on -> @@ -368,7 +380,13 @@ yap_flag(open_expands_filename,Expand) :- yap_flag(single_var_warnings,X) :- var(X), !, - '$syntax_check_single_var'(X,X). + style_check(?(Disc)), + ( Disc = +singletons, + `X = on + ; + Disc = -singletons, + `X = off + ), !. yap_flag(single_var_warnings,X) :- '$transl_to_on_off'(_,X), !, (X == on -> @@ -612,10 +630,7 @@ yap_flag(max_threads,X) :- unknown(_,error). '$adjust_language'(iso) :- '$switch_log_upd'(1), - '$syntax_check_mode'(_,on), - '$syntax_check_single_var'(_,on), - '$syntax_check_discontiguous'(_,on), - '$syntax_check_multiple'(_,on), + style_check(all), fileerrors, '$transl_to_on_off'(X1,on), % CHAR_CONVERSION diff --git a/pl/messages.yap b/pl/messages.yap index a533568f8..72431fffc 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -162,6 +162,16 @@ system_message(singletons(SVs,P,W)) --> clause_to_indicator(P, I), stream_position_data( line_count, W, L) }. +system_message(multiple(P,W,F)) --> + [ 'Redefinition: clause at line ~d redefines ~w from file ~a' - [L, I, F] ], % ' + { clause_to_indicator(P, I), + stream_position_data( line_count, W, L) + }. +system_message(discontiguous(P,W)) --> + [ 'Discontiguous clause for ~w at line ~d' - [I, L] ], % ' + { clause_to_indicator(P, I), + stream_position_data( line_count, W, L) + }. system_message(trace_command(-1)) --> [ 'EOF is not a valid debugger command.' ]. system_message(trace_command(C)) --> diff --git a/pl/preddecls.yap b/pl/preddecls.yap index e90a7abd9..7582c775e 100644 --- a/pl/preddecls.yap +++ b/pl/preddecls.yap @@ -17,7 +17,8 @@ :- system_module( '$_preddecls', [(discontiguous)/1, (dynamic)/1, - (multifile)/1], ['$check_multifile_pred'/3, + (multifile)/1, + (discontiguous)/1], ['$check_multifile_pred'/3, '$discontiguous'/2, '$dynamic'/2]). @@ -126,11 +127,7 @@ discontiguous(F) :- A is A1+2, '$discontiguous'(N/A, M). '$discontiguous'(N/A, M) :- !, - ( recordzifnot('$discontiguous_defs','$df'(N,A,M),_) -> - true - ; - true - ). + '$new_discontiguous'(N,A,M). '$discontiguous'(P,M) :- '$do_error'(type_error(predicate_indicator,P),M:discontiguous(P)).