fix checker to use read for singleton variables, instead of always computing
them.
This commit is contained in:
Vítor Santos Costa
parent
605e68c80d
commit
f1951777b7
@ -1998,7 +1998,6 @@ static void expand_consult( void )
|
||||
LOCAL_ConsultLow = new_cl;
|
||||
}
|
||||
|
||||
/* p was already locked */
|
||||
static int
|
||||
not_was_reconsulted(PredEntry *p, Term t, int mode)
|
||||
{
|
||||
@ -6458,7 +6457,6 @@ p_nth_instance( USES_REGS1 )
|
||||
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
Yap_InitCdMgr(void)
|
||||
{
|
||||
|
||||
72
C/iopreds.c
72
C/iopreds.c
@ -553,6 +553,7 @@ Yap_read_term(term_t t0, IOSTREAM *inp_stream, struct read_data_t *rd)
|
||||
} else {
|
||||
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
|
||||
rd->varnames = 0;
|
||||
rd->singles = 0;
|
||||
return Yap_unify_constant( Yap_GetFromSlot( t0 PASS_REGS), MkAtomTerm (AtomEof));
|
||||
}
|
||||
}
|
||||
@ -636,7 +637,6 @@ Yap_read_term(term_t t0, IOSTREAM *inp_stream, struct read_data_t *rd)
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
if (rd->variables) {
|
||||
while (TRUE) {
|
||||
CELL *old_H = HR;
|
||||
@ -680,9 +680,16 @@ Yap_read_term(term_t t0, IOSTREAM *inp_stream, struct read_data_t *rd)
|
||||
TR = old_TR;
|
||||
}
|
||||
}
|
||||
if (!Yap_unify(v, Yap_GetFromSlot( rd->singles PASS_REGS)))
|
||||
if (rd->singles == 1) {
|
||||
if (IsPairTerm(v))
|
||||
rd->singles = Yap_InitSlot( v PASS_REGS);
|
||||
else
|
||||
rd->singles = FALSE;
|
||||
} else if (rd->singles) {
|
||||
if (!Yap_unify( rd->singles, Yap_GetFromSlot( v PASS_REGS )))
|
||||
return FALSE;
|
||||
}
|
||||
}
|
||||
Yap_clean_tokenizer(tokstart, LOCAL_VarTable, LOCAL_AnonVarTable, LOCAL_Comments);
|
||||
return TRUE;
|
||||
}
|
||||
@ -871,6 +878,65 @@ p_float_format( USES_REGS1 )
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
|
||||
static Int
|
||||
p_style_checker( USES_REGS1 )
|
||||
{
|
||||
Term t = Deref( ARG1 );
|
||||
LD_FROM_REGS
|
||||
|
||||
if (IsVarTerm(t)) {
|
||||
Term t = TermNil;
|
||||
if ( debugstatus.styleCheck & LONGATOM_CHECK) {
|
||||
t = MkPairTerm( MkAtomTerm(AtomAtom), t );
|
||||
}
|
||||
if ( debugstatus.styleCheck & SINGLETON_CHECK) {
|
||||
t = MkPairTerm( MkAtomTerm(AtomSingleton), t );
|
||||
}
|
||||
if ( debugstatus.styleCheck & MULTITON_CHECK) {
|
||||
t = MkPairTerm( MkAtomTerm(AtomVarBranches), t );
|
||||
}
|
||||
if ( debugstatus.styleCheck & DISCONTIGUOUS_STYLE) {
|
||||
t = MkPairTerm( MkAtomTerm(AtomDiscontiguous), t );
|
||||
}
|
||||
if ( debugstatus.styleCheck & NOEFFECT_CHECK) {
|
||||
t = MkPairTerm( MkAtomTerm(AtomNoEffect), t );
|
||||
}
|
||||
if ( debugstatus.styleCheck & CHARSET_CHECK) {
|
||||
t = MkPairTerm( MkAtomTerm(AtomCharset), t );
|
||||
}
|
||||
if ( debugstatus.styleCheck & MULTIPLE_CHECK) {
|
||||
t = MkPairTerm( MkAtomTerm(AtomMultiple), t );
|
||||
}
|
||||
} else {
|
||||
while (IsPairTerm(t)) {
|
||||
Term h = HeadOfTerm( t );
|
||||
t = TailOfTerm( t );
|
||||
|
||||
if (IsAtomTerm(h)) {
|
||||
Atom at = AtomOfTerm( h );
|
||||
if (at == AtomAtom) debugstatus.styleCheck |= LONGATOM_CHECK;
|
||||
else if (at == AtomSingleton) debugstatus.styleCheck |= SINGLETON_CHECK;
|
||||
else if (at == AtomVarBranches) debugstatus.styleCheck |= MULTITON_CHECK;
|
||||
else if (at == AtomDiscontiguous) debugstatus.styleCheck |= DISCONTIGUOUS_STYLE;
|
||||
else if (at == AtomNoEffect) debugstatus.styleCheck |= NOEFFECT_CHECK;
|
||||
else if (at == AtomCharset) debugstatus.styleCheck |= CHARSET_CHECK;
|
||||
else if (at == AtomMultiple) debugstatus.styleCheck |= MULTIPLE_CHECK;
|
||||
} else {
|
||||
Atom at = AtomOfTerm( ArgOfTerm( 1, h ) );
|
||||
if (at == AtomAtom) debugstatus.styleCheck |= LONGATOM_CHECK;
|
||||
else if (at == AtomSingleton) debugstatus.styleCheck &= ~SINGLETON_CHECK;
|
||||
else if (at == AtomVarBranches) debugstatus.styleCheck &= ~MULTITON_CHECK;
|
||||
else if (at == AtomDiscontiguous) debugstatus.styleCheck &= ~DISCONTIGUOUS_STYLE;
|
||||
else if (at == AtomNoEffect) debugstatus.styleCheck &= ~NOEFFECT_CHECK;
|
||||
else if (at == AtomMultiple) debugstatus.styleCheck &= ~MULTIPLE_CHECK;
|
||||
}
|
||||
}
|
||||
}
|
||||
return TRUE;
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
Yap_InitBackIO (void)
|
||||
{
|
||||
@ -915,5 +981,5 @@ Yap_InitIOPreds(void)
|
||||
// Yap_InitCPred ("stream_select", 3, p_stream_select, SafePredFlag|SyncPredFlag);
|
||||
#endif
|
||||
Yap_InitCPred ("$float_format", 1, p_float_format, SafePredFlag|SyncPredFlag);
|
||||
|
||||
Yap_InitCPred ("$style_checker", 1, p_style_checker, SyncPredFlag);
|
||||
}
|
||||
|
||||
@ -120,8 +120,9 @@ LookupModule(Term a )
|
||||
ModEntry *me;
|
||||
|
||||
/* prolog module */
|
||||
if (a == 0)
|
||||
if (a == 0) {
|
||||
return GetModuleEntry(AtomProlog);
|
||||
}
|
||||
at = AtomOfTerm(a);
|
||||
me = GetModuleEntry(at);
|
||||
return me;
|
||||
|
||||
@ -146,7 +146,7 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
|
||||
// if (!worker_id) return;
|
||||
LOCK(Yap_heap_regs->low_level_trace_lock);
|
||||
sc = Yap_heap_regs;
|
||||
//if (vsc_count == 54) jmp_deb(1);
|
||||
if (vsc_count == 161862) jmp_deb(1);
|
||||
// Sfprintf(stderr,"B=%p ", B);
|
||||
#ifdef THREADS
|
||||
LOCAL_ThreadHandle.thread_inst_count++;
|
||||
|
||||
@ -50,6 +50,7 @@
|
||||
AtomCharsio = Yap_LookupAtom("charsio");
|
||||
AtomCharacter = Yap_LookupAtom("character");
|
||||
AtomCharacterCode = Yap_LookupAtom("character_code");
|
||||
AtomCharset = Yap_LookupAtom("charset");
|
||||
AtomCleanCall = Yap_FullLookupAtom("$clean_call");
|
||||
AtomColomn = Yap_LookupAtom(":");
|
||||
AtomCodeSpace = Yap_LookupAtom("code_space");
|
||||
@ -81,6 +82,7 @@
|
||||
AtomDefault = Yap_LookupAtom("default");
|
||||
AtomDevNull = Yap_LookupAtom("/dev/null");
|
||||
AtomDiff = Yap_LookupAtom("\\=");
|
||||
AtomDiscontiguous = Yap_LookupAtom("discontiguous");
|
||||
AtomDollar = Yap_FullLookupAtom("$");
|
||||
AtomDoLogUpdClause = Yap_FullLookupAtom("$do_log_upd_clause");
|
||||
AtomDoLogUpdClause0 = Yap_FullLookupAtom("$do_log_upd_clause0");
|
||||
@ -183,6 +185,7 @@
|
||||
AtomModify = Yap_LookupAtom("modify");
|
||||
AtomMost = Yap_LookupAtom("most");
|
||||
AtomMultiFile = Yap_FullLookupAtom("$mf");
|
||||
AtomMultiple = Yap_FullLookupAtom("multiple");
|
||||
AtomMutable = Yap_LookupAtom("mutable");
|
||||
AtomMutableVariable = Yap_FullLookupAtom("$mutable_variable");
|
||||
AtomMyddasDB = Yap_FullLookupAtom("$myddas_db");
|
||||
@ -195,6 +198,7 @@
|
||||
AtomNb = Yap_LookupAtom("nb");
|
||||
AtomNbTerm = Yap_LookupAtom("nb_term");
|
||||
AtomNew = Yap_LookupAtom("new");
|
||||
AtomNoEffect = Yap_LookupAtom("no_effect");
|
||||
AtomNoMemory = Yap_LookupAtom("no_memory");
|
||||
AtomNone = Yap_LookupAtom("none");
|
||||
AtomNonEmptyList = Yap_LookupAtom("non_empty_list");
|
||||
@ -282,6 +286,7 @@
|
||||
AtomSigUsr2 = Yap_LookupAtom("sig_usr2");
|
||||
AtomSigVTAlarm = Yap_LookupAtom("sig_vtalarm");
|
||||
AtomSigWakeUp = Yap_LookupAtom("sig_wake_up");
|
||||
AtomSingleton = Yap_LookupAtom("singleton");
|
||||
AtomSlash = Yap_LookupAtom("/");
|
||||
AtomSocket = Yap_LookupAtom("socket");
|
||||
AtomSourceSink = Yap_LookupAtom("source_sink");
|
||||
@ -335,6 +340,7 @@
|
||||
AtomUserOut = Yap_LookupAtom("user_output");
|
||||
AtomVBar = Yap_LookupAtom("|");
|
||||
AtomVar = Yap_FullLookupAtom("$VAR");
|
||||
AtomVarBranches = Yap_LookupAtom("var_branches");
|
||||
AtomHiddenVar = Yap_FullLookupAtom("$V");
|
||||
AtomVariable = Yap_LookupAtom("variable");
|
||||
AtomVersionNumber = Yap_FullLookupAtom("$version_name");
|
||||
|
||||
@ -127,8 +127,6 @@ typedef int Char; /* char that can pass EOF */
|
||||
#define source_char_no (LD->read_source.position.charno)
|
||||
#define source_byte_no (LD->read_source.position.byteno)
|
||||
|
||||
#define debugstatus (LD->_debugstatus)
|
||||
|
||||
#if SIZE_DOUBLE==SIZEOF_INT_P
|
||||
#define WORDS_PER_DOUBLE 1
|
||||
#else
|
||||
@ -319,10 +317,6 @@ typedef struct
|
||||
word culprit; /* for CVT_nocode/CVT_nochar */
|
||||
} CVT_result;
|
||||
|
||||
#define MAXNEWLINES 5 /* maximum # of newlines in atom */
|
||||
|
||||
#define LONGATOM_CHECK 0x01 /* read/1: error on intptr_t atoms */
|
||||
|
||||
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
Operator types. NOTE: if you change OP_*, check operatorTypeToAtom()!
|
||||
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
|
||||
@ -467,6 +461,7 @@ extern int fileerrors;
|
||||
|
||||
extern int ttymode;
|
||||
|
||||
|
||||
#define CHARESCAPE_FEATURE 0x00001 /* handle \ in atoms */
|
||||
#define GC_FEATURE 0x00002 /* do GC */
|
||||
#define TRACE_GC_FEATURE 0x00004 /* verbose gc */
|
||||
|
||||
@ -258,6 +258,22 @@ typedef struct initialise_handle * InitialiseHandle;
|
||||
extern unsigned int
|
||||
getUnknownModule(module_t m);
|
||||
|
||||
/* keep in sync with style_name/1 in boot/prims.pl */
|
||||
|
||||
#define LONGATOM_CHECK 0x0001 /* read/1: error on intptr_t atoms */
|
||||
#define SINGLETON_CHECK 0x0002 /* read/1: check singleton vars */
|
||||
#define MULTITON_CHECK 0x0004 /* read/1: check multiton vars */
|
||||
#define DISCONTIGUOUS_STYLE 0x0008 /* warn on discontiguous predicates */
|
||||
#define DYNAMIC_STYLE 0x0010 /* warn on assert/retract active */
|
||||
#define CHARSET_CHECK 0x0020 /* warn on unquoted characters */
|
||||
#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 MAXNEWLINES 5 /* maximum # of newlines in atom */
|
||||
|
||||
#define debugstatus (LD->_debugstatus)
|
||||
|
||||
#define truePrologFlag(flag) true(&LD->prolog_flag.mask, flag)
|
||||
#define setPrologFlagMask(flag) set(&LD->prolog_flag.mask, flag)
|
||||
#define clearPrologFlagMask(flag) clear(&LD->prolog_flag.mask, flag)
|
||||
|
||||
@ -50,6 +50,7 @@
|
||||
AtomCharsio = AtomAdjust(AtomCharsio);
|
||||
AtomCharacter = AtomAdjust(AtomCharacter);
|
||||
AtomCharacterCode = AtomAdjust(AtomCharacterCode);
|
||||
AtomCharset = AtomAdjust(AtomCharset);
|
||||
AtomCleanCall = AtomAdjust(AtomCleanCall);
|
||||
AtomColomn = AtomAdjust(AtomColomn);
|
||||
AtomCodeSpace = AtomAdjust(AtomCodeSpace);
|
||||
@ -81,6 +82,7 @@
|
||||
AtomDefault = AtomAdjust(AtomDefault);
|
||||
AtomDevNull = AtomAdjust(AtomDevNull);
|
||||
AtomDiff = AtomAdjust(AtomDiff);
|
||||
AtomDiscontiguous = AtomAdjust(AtomDiscontiguous);
|
||||
AtomDollar = AtomAdjust(AtomDollar);
|
||||
AtomDoLogUpdClause = AtomAdjust(AtomDoLogUpdClause);
|
||||
AtomDoLogUpdClause0 = AtomAdjust(AtomDoLogUpdClause0);
|
||||
@ -183,6 +185,7 @@
|
||||
AtomModify = AtomAdjust(AtomModify);
|
||||
AtomMost = AtomAdjust(AtomMost);
|
||||
AtomMultiFile = AtomAdjust(AtomMultiFile);
|
||||
AtomMultiple = AtomAdjust(AtomMultiple);
|
||||
AtomMutable = AtomAdjust(AtomMutable);
|
||||
AtomMutableVariable = AtomAdjust(AtomMutableVariable);
|
||||
AtomMyddasDB = AtomAdjust(AtomMyddasDB);
|
||||
@ -195,6 +198,7 @@
|
||||
AtomNb = AtomAdjust(AtomNb);
|
||||
AtomNbTerm = AtomAdjust(AtomNbTerm);
|
||||
AtomNew = AtomAdjust(AtomNew);
|
||||
AtomNoEffect = AtomAdjust(AtomNoEffect);
|
||||
AtomNoMemory = AtomAdjust(AtomNoMemory);
|
||||
AtomNone = AtomAdjust(AtomNone);
|
||||
AtomNonEmptyList = AtomAdjust(AtomNonEmptyList);
|
||||
@ -282,6 +286,7 @@
|
||||
AtomSigUsr2 = AtomAdjust(AtomSigUsr2);
|
||||
AtomSigVTAlarm = AtomAdjust(AtomSigVTAlarm);
|
||||
AtomSigWakeUp = AtomAdjust(AtomSigWakeUp);
|
||||
AtomSingleton = AtomAdjust(AtomSingleton);
|
||||
AtomSlash = AtomAdjust(AtomSlash);
|
||||
AtomSocket = AtomAdjust(AtomSocket);
|
||||
AtomSourceSink = AtomAdjust(AtomSourceSink);
|
||||
@ -335,6 +340,7 @@
|
||||
AtomUserOut = AtomAdjust(AtomUserOut);
|
||||
AtomVBar = AtomAdjust(AtomVBar);
|
||||
AtomVar = AtomAdjust(AtomVar);
|
||||
AtomVarBranches = AtomAdjust(AtomVarBranches);
|
||||
AtomHiddenVar = AtomAdjust(AtomHiddenVar);
|
||||
AtomVariable = AtomAdjust(AtomVariable);
|
||||
AtomVersionNumber = AtomAdjust(AtomVersionNumber);
|
||||
|
||||
12
H/tatoms.h
12
H/tatoms.h
@ -98,6 +98,8 @@
|
||||
#define AtomCharacter Yap_heap_regs->AtomCharacter_
|
||||
Atom AtomCharacterCode_;
|
||||
#define AtomCharacterCode Yap_heap_regs->AtomCharacterCode_
|
||||
Atom AtomCharset_;
|
||||
#define AtomCharset Yap_heap_regs->AtomCharset_
|
||||
Atom AtomCleanCall_;
|
||||
#define AtomCleanCall Yap_heap_regs->AtomCleanCall_
|
||||
Atom AtomColomn_;
|
||||
@ -160,6 +162,8 @@
|
||||
#define AtomDevNull Yap_heap_regs->AtomDevNull_
|
||||
Atom AtomDiff_;
|
||||
#define AtomDiff Yap_heap_regs->AtomDiff_
|
||||
Atom AtomDiscontiguous_;
|
||||
#define AtomDiscontiguous Yap_heap_regs->AtomDiscontiguous_
|
||||
Atom AtomDollar_;
|
||||
#define AtomDollar Yap_heap_regs->AtomDollar_
|
||||
Atom AtomDoLogUpdClause_;
|
||||
@ -364,6 +368,8 @@
|
||||
#define AtomMost Yap_heap_regs->AtomMost_
|
||||
Atom AtomMultiFile_;
|
||||
#define AtomMultiFile Yap_heap_regs->AtomMultiFile_
|
||||
Atom AtomMultiple_;
|
||||
#define AtomMultiple Yap_heap_regs->AtomMultiple_
|
||||
Atom AtomMutable_;
|
||||
#define AtomMutable Yap_heap_regs->AtomMutable_
|
||||
Atom AtomMutableVariable_;
|
||||
@ -388,6 +394,8 @@
|
||||
#define AtomNbTerm Yap_heap_regs->AtomNbTerm_
|
||||
Atom AtomNew_;
|
||||
#define AtomNew Yap_heap_regs->AtomNew_
|
||||
Atom AtomNoEffect_;
|
||||
#define AtomNoEffect Yap_heap_regs->AtomNoEffect_
|
||||
Atom AtomNoMemory_;
|
||||
#define AtomNoMemory Yap_heap_regs->AtomNoMemory_
|
||||
Atom AtomNone_;
|
||||
@ -562,6 +570,8 @@
|
||||
#define AtomSigVTAlarm Yap_heap_regs->AtomSigVTAlarm_
|
||||
Atom AtomSigWakeUp_;
|
||||
#define AtomSigWakeUp Yap_heap_regs->AtomSigWakeUp_
|
||||
Atom AtomSingleton_;
|
||||
#define AtomSingleton Yap_heap_regs->AtomSingleton_
|
||||
Atom AtomSlash_;
|
||||
#define AtomSlash Yap_heap_regs->AtomSlash_
|
||||
Atom AtomSocket_;
|
||||
@ -668,6 +678,8 @@
|
||||
#define AtomVBar Yap_heap_regs->AtomVBar_
|
||||
Atom AtomVar_;
|
||||
#define AtomVar Yap_heap_regs->AtomVar_
|
||||
Atom AtomVarBranches_;
|
||||
#define AtomVarBranches Yap_heap_regs->AtomVarBranches_
|
||||
Atom AtomHiddenVar_;
|
||||
#define AtomHiddenVar Yap_heap_regs->AtomHiddenVar_
|
||||
Atom AtomVariable_;
|
||||
|
||||
@ -55,6 +55,7 @@ A Char N "char"
|
||||
A Charsio N "charsio"
|
||||
A Character N "character"
|
||||
A CharacterCode N "character_code"
|
||||
A Charset N "charset"
|
||||
A CleanCall F "$clean_call"
|
||||
A Colomn N ":"
|
||||
A CodeSpace N "code_space"
|
||||
@ -86,6 +87,7 @@ A Dec10 N "dec10"
|
||||
A Default N "default"
|
||||
A DevNull N "/dev/null"
|
||||
A Diff N "\\="
|
||||
A Discontiguous N "discontiguous"
|
||||
A Dollar F "$"
|
||||
A DoLogUpdClause F "$do_log_upd_clause"
|
||||
A DoLogUpdClause0 F "$do_log_upd_clause0"
|
||||
@ -188,6 +190,7 @@ A Minus N "-"
|
||||
A Modify N "modify"
|
||||
A Most N "most"
|
||||
A MultiFile F "$mf"
|
||||
A Multiple F "multiple"
|
||||
A Mutable N "mutable"
|
||||
A MutableVariable F "$mutable_variable"
|
||||
A MyddasDB F "$myddas_db"
|
||||
@ -200,6 +203,7 @@ A Nan N "nan"
|
||||
A Nb N "nb"
|
||||
A NbTerm N "nb_term"
|
||||
A New N "new"
|
||||
A NoEffect N "no_effect"
|
||||
A NoMemory N "no_memory"
|
||||
A None N "none"
|
||||
A NonEmptyList N "non_empty_list"
|
||||
@ -287,6 +291,7 @@ A SigUsr1 N "sig_usr1"
|
||||
A SigUsr2 N "sig_usr2"
|
||||
A SigVTAlarm N "sig_vtalarm"
|
||||
A SigWakeUp N "sig_wake_up"
|
||||
A Singleton N "singleton"
|
||||
A Slash N "/"
|
||||
A Socket N "socket"
|
||||
A SourceSink N "source_sink"
|
||||
@ -340,6 +345,7 @@ A UserIn N "user_input"
|
||||
A UserOut N "user_output"
|
||||
A VBar N "|"
|
||||
A Var F "$VAR"
|
||||
A VarBranches N "var_branches"
|
||||
A HiddenVar F "$V"
|
||||
A Variable N "variable"
|
||||
A VersionNumber F "$version_name"
|
||||
|
||||
142
os/pl-read.c
142
os/pl-read.c
@ -126,6 +126,21 @@ reportReadError(ReadData rd)
|
||||
}
|
||||
|
||||
|
||||
/* static int */
|
||||
/* reportSingletons(ReadData rd, singletons, Atom amod, Atom aname, UInt arity) */
|
||||
/* { */
|
||||
/* printMessage(ATOM_warning, PL_FUNCTOR_CHARS, */
|
||||
/* "singletons", 2, */
|
||||
/* PL_TERM, singletons, */
|
||||
/* PL_TERM, mod, */
|
||||
/* PL_FUNCTOR_divide2, */
|
||||
/* PL_ATOM, name, */
|
||||
/* PL_INT, arity); */
|
||||
|
||||
/* return FALSE; */
|
||||
/* } */
|
||||
|
||||
|
||||
/********************************
|
||||
* RAW READING *
|
||||
*********************************/
|
||||
@ -953,7 +968,6 @@ callCommentHook(term_t comments, term_t tpos, term_t term)
|
||||
|
||||
PL_close_query(qid);
|
||||
}
|
||||
|
||||
PL_discard_foreign_frame(fid);
|
||||
}
|
||||
}
|
||||
@ -1075,6 +1089,126 @@ unify_read_term_position(term_t tpos ARG_LD)
|
||||
}
|
||||
}
|
||||
|
||||
/** read_clause(+Stream:stream, -Clause:clause, +Options:list)
|
||||
|
||||
Options:
|
||||
* variable_names(-Names)
|
||||
* process_comment(+Boolean)
|
||||
* comments(-List)
|
||||
* syntax_errors(+Atom)
|
||||
* term_position(-Position)
|
||||
* subterm_positions(-Layout)
|
||||
*/
|
||||
|
||||
static const opt_spec read_clause_options[] =
|
||||
{ { ATOM_variable_names, OPT_TERM },
|
||||
{ ATOM_term_position, OPT_TERM },
|
||||
{ ATOM_subterm_positions, OPT_TERM },
|
||||
{ ATOM_process_comment, OPT_BOOL },
|
||||
{ ATOM_comments, OPT_TERM },
|
||||
{ ATOM_syntax_errors, OPT_ATOM },
|
||||
{ NULL_ATOM, 0 }
|
||||
};
|
||||
|
||||
|
||||
static int
|
||||
read_clause(IOSTREAM *s, term_t term, term_t options ARG_LD)
|
||||
{ read_data rd;
|
||||
int rval;
|
||||
fid_t fid;
|
||||
term_t tpos = 0;
|
||||
term_t comments = 0;
|
||||
term_t opt_comments = 0;
|
||||
int process_comment;
|
||||
atom_t syntax_errors = ATOM_dec10;
|
||||
|
||||
{
|
||||
OPCODE ophook = PredCommentHook->OpcodeOfPred;
|
||||
if (ophook == UNDEF_OPCODE || ophook == FAIL_OPCODE)
|
||||
process_comment = FALSE;
|
||||
else
|
||||
process_comment = TRUE;
|
||||
}
|
||||
if ( !(fid=PL_open_foreign_frame()) )
|
||||
return FALSE;
|
||||
|
||||
retry:
|
||||
init_read_data(&rd, s PASS_LD);
|
||||
|
||||
if ( options &&
|
||||
!scan_options(options, 0, ATOM_read_option, read_clause_options,
|
||||
&rd.varnames,
|
||||
&tpos,
|
||||
&rd.subtpos,
|
||||
&process_comment,
|
||||
&opt_comments,
|
||||
&syntax_errors) )
|
||||
{ PL_close_foreign_frame(fid);
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
if ( opt_comments )
|
||||
{ comments = PL_new_term_ref();
|
||||
} else if ( process_comment )
|
||||
{ if ( !tpos )
|
||||
tpos = PL_new_term_ref();
|
||||
comments = PL_new_term_ref();
|
||||
}
|
||||
|
||||
REGS_FROM_LD
|
||||
rd.module = Yap_GetModuleEntry( LOCAL_SourceModule );
|
||||
if ( comments )
|
||||
rd.comments = PL_copy_term_ref(comments);
|
||||
rd.on_error = syntax_errors;
|
||||
rd.singles = rd.styleCheck & SINGLETON_CHECK ? 1 : 0;
|
||||
if ( (rval=read_term(term, &rd PASS_LD)) &&
|
||||
(!tpos || (rval=unify_read_term_position(tpos PASS_LD))) )
|
||||
{
|
||||
if (rd.singles) {
|
||||
// warning, singletons([X=_A],f(X,Y,Z), pos).
|
||||
printMessage(ATOM_warning,
|
||||
PL_FUNCTOR_CHARS, "singletons", 3,
|
||||
PL_TERM, rd.singles,
|
||||
PL_TERM, term,
|
||||
PL_TERM, tpos );
|
||||
}
|
||||
if ( rd.comments &&
|
||||
(rval = PL_unify_nil(rd.comments)) )
|
||||
{ if ( opt_comments )
|
||||
rval = PL_unify(opt_comments, comments);
|
||||
else if ( !PL_get_nil(comments) )
|
||||
callCommentHook(comments, tpos, term);
|
||||
} else
|
||||
{ if ( rd.has_exception && reportReadError(&rd) )
|
||||
{ PL_rewind_foreign_frame(fid);
|
||||
free_read_data(&rd);
|
||||
goto retry;
|
||||
}
|
||||
}
|
||||
}
|
||||
free_read_data(&rd);
|
||||
|
||||
return rval;
|
||||
}
|
||||
|
||||
|
||||
static
|
||||
PRED_IMPL("read_clause", 3, read_clause, 0)
|
||||
{ PRED_LD
|
||||
int rc;
|
||||
IOSTREAM *s;
|
||||
|
||||
if ( !getTextInputStream(A1, &s) )
|
||||
return FALSE;
|
||||
rc = read_clause(s, A2, A3 PASS_LD);
|
||||
if ( Sferror(s) )
|
||||
return streamStatus(s);
|
||||
else
|
||||
PL_release_stream(s);
|
||||
|
||||
return rc;
|
||||
}
|
||||
|
||||
|
||||
word
|
||||
pl_raw_read(term_t term)
|
||||
@ -1174,8 +1308,9 @@ retry:
|
||||
{ if ( !setDoubleQuotes(dq, &rd.flags) )
|
||||
return FALSE;
|
||||
}
|
||||
if ( rd.singles && PL_get_atom(rd.singles, &w) && w == ATOM_warning )
|
||||
rd.singles = TRUE;
|
||||
if ( rd.singles && PL_get_atom(rd.singles, &w) && w == ATOM_warning)
|
||||
rd.singles = 1;
|
||||
|
||||
if ( comments )
|
||||
rd.comments = PL_copy_term_ref(comments);
|
||||
|
||||
@ -1355,6 +1490,7 @@ PL_chars_to_term(const char *s, term_t t)
|
||||
BeginPredDefs(read)
|
||||
PRED_DEF("read_term", 3, read_term, PL_FA_ISO)
|
||||
PRED_DEF("read_term", 2, read_term, PL_FA_ISO)
|
||||
PRED_DEF("read_clause", 3, read_clause, 0)
|
||||
PRED_DEF("atom_to_term", 3, atom_to_term, 0)
|
||||
PRED_DEF("term_to_atom", 2, term_to_atom, 0)
|
||||
#ifdef O_QUASIQUOTATIONS
|
||||
|
||||
12
pl/boot.yap
12
pl/boot.yap
@ -1187,17 +1187,7 @@ bootstrap(F) :-
|
||||
!.
|
||||
|
||||
'$enter_command'(Stream,Mod,Status) :-
|
||||
read_term(Stream, Command, [module(Mod), variable_names(Vars), term_position(Pos), syntax_errors(dec10), process_comment(true), singletons( Singletons ) ]),
|
||||
( Singletons == []
|
||||
->
|
||||
true
|
||||
;
|
||||
get_value('$syntaxchecksinglevar',on)
|
||||
->
|
||||
'$sv_warning'(Singletons, Command )
|
||||
;
|
||||
true
|
||||
),
|
||||
read_clause(Stream, Command, [variable_names(Vars), term_position(Pos), syntax_errors(dec10) ]),
|
||||
'$command'(Command,Vars,Pos,Status).
|
||||
|
||||
'$abort_loop'(Stream) :-
|
||||
|
||||
123
pl/checker.yap
123
pl/checker.yap
@ -62,7 +62,7 @@
|
||||
* *
|
||||
*************************************************************************/
|
||||
|
||||
:- system_module( '$_checker', [no_style_check/1,
|
||||
:- system_module( style_checker, [no_style_check/1,
|
||||
style_check/1], ['$check_term'/5,
|
||||
'$init_style_check'/1,
|
||||
'$sv_warning'/2,
|
||||
@ -76,40 +76,84 @@
|
||||
:- 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).
|
||||
style_check(V) :-
|
||||
style_check_(V), !.
|
||||
style_check(V) :-
|
||||
\+atom(V), \+ list(V), V \= + _, V \= + _, !,
|
||||
'$do_error'( type_error('+|-|?(Flag)', V), style_check(V) ).
|
||||
style_check(V) :-
|
||||
\+atom(V), \+ list(V), V \= + _, V \= + _, !,
|
||||
'$do_error'( domain_error(style_name(Flag), V), style_check(V) ).
|
||||
|
||||
|
||||
style_check_(all) :-
|
||||
'$style_checker'( [ singleton, discontiguous, multiple ] ).
|
||||
style_check_(single_var) :-
|
||||
'$style_checker'( [ singleton ] ).
|
||||
style_check_(singleton) :-
|
||||
'$style_checker'( [ singleton ] ).
|
||||
style_check_(+single_var) :-
|
||||
'$style_checker'( [ singleton ] ).
|
||||
style_check_(+singleton) :-
|
||||
'$style_checker'( [ singleton ] ).
|
||||
style_check_(-single_var) :-
|
||||
'$style_checker'( [ -singleton ] ).
|
||||
style_check_(-singleton) :-
|
||||
'$style_checker'( [ -singleton ] ).
|
||||
style_check_(discontiguous) :-
|
||||
'$style_checker'( [ discontiguous ] ).
|
||||
style_check_(+discontiguous) :-
|
||||
'$style_checker'( [ discontiguous ] ).
|
||||
style_check_(-discontiguous) :-
|
||||
'$style_checker'( [ -discontiguous ] ).
|
||||
style_check_(multiple) :-
|
||||
'$style_checker'( [ multiple ] ).
|
||||
style_check_(+multiple) :-
|
||||
'$style_checker'( [ multiple ] ).
|
||||
style_check_(-multiple) :-
|
||||
'$style_checker'( [ -multiple ] ).
|
||||
style_check_(no_effect) :-
|
||||
'$style_checker'( [ no_effect ] ).
|
||||
style_check_(+no_effect) :-
|
||||
'$style_checker'( [ no_effect ] ).
|
||||
style_check_(-no_effect) :-
|
||||
'$style_checker'( [ -no_effect ] ).
|
||||
style_check_(var_branches) :-
|
||||
'$style_checker'( [ var_branches ] ).
|
||||
style_check_(+var_branches) :-
|
||||
'$style_checker'( [ var_branches ] ).
|
||||
style_check_(-var_branches) :-
|
||||
'$style_checker'( [ -var_branches ] ).
|
||||
style_check_(atom) :-
|
||||
'$style_checker'( [ atom ] ).
|
||||
style_check_(+atom) :-
|
||||
'$style_checker'( [ atom ] ).
|
||||
style_check_(-atom) :-
|
||||
'$style_checker'( [ -atom ] ).
|
||||
style_check_(charset) :-
|
||||
'$style_checker'( [ charset ] ).
|
||||
style_check_(+charset) :-
|
||||
'$style_checker'( [ charset ] ).
|
||||
style_check_(-charset) :-
|
||||
'$style_checker'( [ -charset ] ).
|
||||
style_check_('?'(Info) ) :-
|
||||
'$style_checker '( [ L ] ),
|
||||
lists:member( Style, [ singleton, discontiguous, multiple ] ),
|
||||
( lists:member(Style, L ) -> Info = +Style ; Info = -Style ).
|
||||
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).
|
||||
'$style_checker'( [ -singleton, -discontiguous, -multiple ] ).
|
||||
no_style_check(-single_var) :-
|
||||
'$style_checker'( [ -singleton ] ).
|
||||
no_style_check(-singleton) :-
|
||||
'$style_checker'( [ -singleton ] ).
|
||||
no_style_check(-discontiguous) :-
|
||||
'$stylechecker'( [ -discontiguous ] ).
|
||||
no_style_check(-multiple) :-
|
||||
'$style_checker'( [ -multiple ] ).
|
||||
no_style_check([]).
|
||||
no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
|
||||
|
||||
@ -183,21 +227,6 @@ no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
|
||||
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),_), !,
|
||||
|
||||
@ -155,11 +155,13 @@ system_message(no_match(P)) -->
|
||||
[ 'No matching predicate for ~w.' - [P] ].
|
||||
system_message(leash([A|B])) -->
|
||||
[ 'Leashing set to ~w.' - [[A|B]] ].
|
||||
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(singletons(SVs,P,W)) -->
|
||||
[ 'Singleton variable~*c ~s in ~q, starting at line ~d' - [NVs, 0's, SVsL, I, L] ], % '
|
||||
{ svs(SVs,SVsL,[]),
|
||||
( SVs = [_] -> NVs = 0 ; NVs = 1 ),
|
||||
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)) -->
|
||||
@ -581,3 +583,16 @@ prefix(debug(_), '% ', user_error).
|
||||
prefix(information, '% ', user_error).
|
||||
|
||||
|
||||
clause_to_indicator(T, M:Name/Arity) :-
|
||||
strip_module(T, M, T1),
|
||||
pred_arity( T1, 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).
|
||||
|
||||
|
||||
Reference in New Issue
Block a user