From f1951777b7da271f3e2ad21517c840af796cf53d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Wed, 23 Apr 2014 21:39:32 +0100 Subject: [PATCH] fix checker to use read for singleton variables, instead of always computing them. --- C/cdmgr.c | 2 - C/iopreds.c | 74 ++++++++++++++++++++++-- C/modules.c | 3 +- C/tracer.c | 2 +- H/iatoms.h | 6 ++ H/pl-incl.h | 7 +-- H/pl-shared.h | 16 ++++++ H/ratoms.h | 6 ++ H/tatoms.h | 12 ++++ misc/ATOMS | 6 ++ os/pl-read.c | 146 ++++++++++++++++++++++++++++++++++++++++++++++-- pl/boot.yap | 12 +--- pl/checker.yap | 123 ++++++++++++++++++++++++---------------- pl/messages.yap | 25 +++++++-- 14 files changed, 358 insertions(+), 82 deletions(-) diff --git a/C/cdmgr.c b/C/cdmgr.c index 5a1e0de03..e23c8ade7 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -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) { diff --git a/C/iopreds.c b/C/iopreds.c index 305ace4a8..fdd148fe7 100755 --- a/C/iopreds.c +++ b/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,8 +680,15 @@ 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))) - return FALSE; + 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); } diff --git a/C/modules.c b/C/modules.c index 7a441c7f8..27d16502e 100644 --- a/C/modules.c +++ b/C/modules.c @@ -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; diff --git a/C/tracer.c b/C/tracer.c index f0ff4ecf3..13dcf2eeb 100755 --- a/C/tracer.c +++ b/C/tracer.c @@ -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++; diff --git a/H/iatoms.h b/H/iatoms.h index 6102b7d8a..8a4dcde66 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -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"); diff --git a/H/pl-incl.h b/H/pl-incl.h index 55a44a7db..81e05be18 100755 --- a/H/pl-incl.h +++ b/H/pl-incl.h @@ -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 */ diff --git a/H/pl-shared.h b/H/pl-shared.h index 83c02b726..e156199cd 100755 --- a/H/pl-shared.h +++ b/H/pl-shared.h @@ -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) diff --git a/H/ratoms.h b/H/ratoms.h index 216126cc0..b6d236910 100644 --- a/H/ratoms.h +++ b/H/ratoms.h @@ -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); diff --git a/H/tatoms.h b/H/tatoms.h index 2c400fffd..7c7b3f06d 100644 --- a/H/tatoms.h +++ b/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_; diff --git a/misc/ATOMS b/misc/ATOMS index 98feea28c..f7719f8bf 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -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" diff --git a/os/pl-read.c b/os/pl-read.c index 648b0c123..3ad3a776c 100644 --- a/os/pl-read.c +++ b/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 * *********************************/ @@ -945,15 +960,14 @@ callCommentHook(term_t comments, term_t tpos, term_t term) PL_put_term(av+2, term); if ( (qid = PL_open_query(NULL, PL_Q_NODEBUG|PL_Q_CATCH_EXCEPTION, - (predicate_t)PredCommentHook, av)) ) + (predicate_t)PredCommentHook, av)) ) { term_t ex; if ( !PL_next_solution(qid) && (ex=PL_exception(qid)) ) - printMessage(ATOM_error, PL_TERM, ex); + printMessage(ATOM_error, PL_TERM, ex); 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 diff --git a/pl/boot.yap b/pl/boot.yap index a3e28d8a1..fdedd5502 100755 --- a/pl/boot.yap +++ b/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) :- diff --git a/pl/checker.yap b/pl/checker.yap index de1df3232..3ac5db55b 100644 --- a/pl/checker.yap +++ b/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),_), !, diff --git a/pl/messages.yap b/pl/messages.yap index bcc05f818..a533568f8 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -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). +