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

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

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

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

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

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)

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

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

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

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 )

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

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),
+	style_check(all),
-	'$syntax_check_single_var'(_,on),
-	'$syntax_check_discontiguous'(_,on),
-	'$syntax_check_multiple'(_,on),
 	fileerrors,
 	'$transl_to_on_off'(X1,on),
 	% CHAR_CONVERSION

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

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),_) ->
+	'$new_discontiguous'(N,A,M).
-	    true
-	;
-	    true
-	).
 '$discontiguous'(P,M) :-
 	'$do_error'(type_error(predicate_indicator,P),M:discontiguous(P)).