diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

fix style_check to be called at parse-time and not cause eexcution overheads.

Browse Source
This commit is contained in:
Vítor Santos Costa 2014-04-24 08:26:31 +01:00
parent 6591b5429c
commit d8f4a77f47
13 changed files with 200 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
C/cdmgr.c
View File

@ -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);

3
H/Yapproto.h
View File

@ -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 *);

1
H/Yatom.h
View File

@ -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 */

3
H/iatoms.h
View File

@ -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);

2
H/pl-shared.h
View File

@ -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)

3
H/ratoms.h
View File

@ -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);

6
H/tatoms.h
View File

@ -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_;

3
misc/ATOMS
View File

@ -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

18
os/pl-read.c
View File

@ -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 )

125
pl/checker.yap
View File

@ -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)).

29
pl/flags.yap
View File

@ -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

10
pl/messages.yap
View File

@ -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)) -->

9
pl/preddecls.yap
View File

@ -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)).