printwarning

H/iatoms.h

@@ -229,6 +229,7 @@
   AtomPortray = Yap_FullLookupAtom("$portray");
   AtomPredicateIndicator = Yap_LookupAtom("predicate_indicator");
   AtomPrimitive = Yap_LookupAtom("primitive");
+  AtomPrintMessage = Yap_LookupAtom("print_message");
   AtomPrivateProcedure = Yap_LookupAtom("private_procedure");
   AtomProcedure = Yap_LookupAtom("procedure");
   AtomProfile = Yap_FullLookupAtom("$profile");
@@ -425,6 +426,7 @@
   FunctorPermissionError = Yap_MkFunctor(AtomPermissionError,3);
   FunctorPlus = Yap_MkFunctor(AtomPlus,2);
   FunctorPortray = Yap_MkFunctor(AtomPortray,1);
+  FunctorPrintMessage = Yap_MkFunctor(AtomPrintMessage,2);
   FunctorPrologConstraint = Yap_MkFunctor(AtomProlog,2);
   FunctorQuery = Yap_MkFunctor(AtomQuery,1);
   FunctorRecordedWithKey = Yap_MkFunctor(AtomRecordedWithKey,6);

H/pl-global.h

@@ -393,6 +393,8 @@ typedef struct PL_local_data {
   } gmp;
 #endif
 
+  int in_print_message;
+
   struct regstore_t *reg_cache;         /* pointer to YAP registers */
 
 #ifdef O_LOCALE

H/pl-incl.h

@@ -276,6 +276,7 @@ users foreign language code.
 		*       Error		         *
 		*********************************/
 
+#define isDefinedProcedure(pred) TRUE // TBD
 #include "pl-error.h"
 
 		/********************************
@@ -568,7 +569,6 @@ extern int PL_unify_atomic(term_t t, PL_atomic_t a);
 extern int _PL_unify_atomic(term_t t, PL_atomic_t a);
 extern int _PL_unify_string(term_t t, word w);
 
-
 extern IOSTREAM **			/* provide access to Suser_input, */
   _PL_streams(void);			/* Suser_output and Suser_error */
 

H/ratoms.h

@@ -229,6 +229,7 @@
   AtomPortray = AtomAdjust(AtomPortray);
   AtomPredicateIndicator = AtomAdjust(AtomPredicateIndicator);
   AtomPrimitive = AtomAdjust(AtomPrimitive);
+  AtomPrintMessage = AtomAdjust(AtomPrintMessage);
   AtomPrivateProcedure = AtomAdjust(AtomPrivateProcedure);
   AtomProcedure = AtomAdjust(AtomProcedure);
   AtomProfile = AtomAdjust(AtomProfile);
@@ -425,6 +426,7 @@
   FunctorPermissionError = FuncAdjust(FunctorPermissionError);
   FunctorPlus = FuncAdjust(FunctorPlus);
   FunctorPortray = FuncAdjust(FunctorPortray);
+  FunctorPrintMessage = FuncAdjust(FunctorPrintMessage);
   FunctorPrologConstraint = FuncAdjust(FunctorPrologConstraint);
   FunctorQuery = FuncAdjust(FunctorQuery);
   FunctorRecordedWithKey = FuncAdjust(FunctorRecordedWithKey);

H/tatoms.h

@@ -456,6 +456,8 @@
 #define AtomPredicateIndicator Yap_heap_regs->AtomPredicateIndicator_
   Atom AtomPrimitive_;
 #define AtomPrimitive Yap_heap_regs->AtomPrimitive_
+  Atom AtomPrintMessage_;
+#define AtomPrintMessage Yap_heap_regs->AtomPrintMessage_
   Atom AtomPrivateProcedure_;
 #define AtomPrivateProcedure Yap_heap_regs->AtomPrivateProcedure_
   Atom AtomProcedure_;
@@ -848,6 +850,8 @@
 #define FunctorPlus Yap_heap_regs->FunctorPlus_
   Functor FunctorPortray_;
 #define FunctorPortray Yap_heap_regs->FunctorPortray_
+  Functor FunctorPrintMessage_;
+#define FunctorPrintMessage Yap_heap_regs->FunctorPrintMessage_
   Functor FunctorPrologConstraint_;
 #define FunctorPrologConstraint Yap_heap_regs->FunctorPrologConstraint_
   Functor FunctorQuery_;

library/dialect/swi/fli/swi.c

@@ -52,6 +52,10 @@
 
 #include "swi.h"
 
+#include "pl-error.h"
+
+extern int		PL_unify_termv(term_t l, va_list args);
+
 extern X_API Atom YAP_AtomFromSWIAtom(atom_t at);
 extern X_API atom_t YAP_SWIAtomFromAtom(Atom at);
 
@@ -1454,10 +1458,9 @@ typedef struct {
 
 /* SWI: int PL_unify_term(term_t ?t1, term_t ?t2)
    YAP long int  YAP_Unify(YAP_Term* a, Term* b) */
-X_API int PL_unify_term(term_t l,...)
+int PL_unify_termv(term_t l, va_list ap)
 {
   CACHE_REGS
-  va_list ap;
   int type, res;
   int nels = 1;
   int depth = 1;
@@ -1471,7 +1474,6 @@ X_API int PL_unify_term(term_t l,...)
       return FALSE;
     }
   }
-  va_start (ap, l);
   pt = a;
   while (depth > 0) {
     while (nels > 0) {
@@ -1673,12 +1675,25 @@ X_API int PL_unify_term(term_t l,...)
       nels = stack[depth-1].nels;
     }
   }
-  va_end (ap);
   res = Yap_unify(Yap_GetFromSlot(l PASS_REGS),a[0]);
   RECOVER_MACHINE_REGS();
   return res;
 }
 
+
+int
+PL_unify_term(term_t t, ...)
+{ va_list args;
+  int rval;
+
+  va_start(args, t);
+  rval = PL_unify_termv(t, args);
+  va_end(args);
+
+  return rval;
+}
+
+
 /* end PL_unify_* functions =============================*/
 
 /* SWI: void PL_register_atom(atom_t atom) */
@@ -2209,7 +2224,6 @@ PL_close_foreign_frame(fid_t f)
 {
   CACHE_REGS
   choiceptr cp_b = (choiceptr)(LCL0-(UInt)f);
-  CELL *old_slots;
   LOCAL_CurSlot = IntOfTerm(cp_b->cp_a1);
   B = cp_b->cp_b;
   CP = cp_b->cp_cp;

library/dialect/swi/fli/swi.h

@@ -1,47 +1,6 @@
 void Yap_swi_install(void);
 void Yap_install_blobs(void);
 
-/* Required by PL_error */
-#define ERR_NO_ERROR		0
-#define ERR_INSTANTIATION	1	/* void */
-#define ERR_TYPE		2	/* atom_t expected, term_t value */
-#define ERR_DOMAIN		3	/* atom_t domain, term_t value */
-#define ERR_REPRESENTATION	4	/* atom_t what */
-#define ERR_MODIFY_STATIC_PROC	5	/* predicate_t proc */
-#define ERR_EVALUATION		6	/* atom_t what */
-#define ERR_AR_TYPE		7	/* atom_t expected, Number value */
-#define ERR_NOT_EVALUABLE	8	/* functor_t func */
-#define ERR_DIV_BY_ZERO		9	/* void */
-#define ERR_FAILED	       10	/* predicate_t proc */
-#define ERR_FILE_OPERATION     11	/* atom_t action, atom_t type, term_t */
-#define ERR_PERMISSION	       12	/* atom_t type, atom_t op, term_t obj*/
-#define ERR_NOT_IMPLEMENTED 13	/* const char *what */
-#define ERR_EXISTENCE	       14	/* atom_t type, term_t obj */
-#define ERR_STREAM_OP	       15	/* atom_t action, term_t obj */
-#define ERR_RESOURCE	       16	/* atom_t resource */
-#define ERR_NOMEM	       17	/* void */
-#define ERR_SYSCALL	       18	/* void */
-#define ERR_SHELL_FAILED       19	/* term_t command */
-#define ERR_SHELL_SIGNALLED    20	/* term_t command, int signal */
-#define ERR_AR_UNDEF	       21	/* void */
-#define ERR_AR_OVERFLOW	       22	/* void */
-#define ERR_AR_UNDERFLOW       23	/* void */
-#define ERR_UNDEFINED_PROC     24	/* Definition def */
-#define ERR_SIGNALLED	       25	/* int sig, char *name */
-#define ERR_CLOSED_STREAM      26	/* IOSTREAM * */
-#define ERR_BUSY	       27	/* mutexes */
-#define ERR_PERMISSION_PROC    28	/* op, type, Definition */
-#define ERR_DDE_OP	       29	/* op, error */
-#define ERR_SYNTAX	       30	/* what */
-#define ERR_SHARED_OBJECT_OP   31	/* op, error */
-#define ERR_TIMEOUT	       32	/* op, object */
-#define ERR_NOT_IMPLEMENTED_PROC 33	/* name, arity */
-#define ERR_FORMAT	       34	/* message */
-#define ERR_FORMAT_ARG	       35	/* seq, term */
-#define ERR_OCCURS_CHECK       36	/* Word, Word */
-#define ERR_CHARS_TYPE	       37	/* char *, term */
-#define ERR_MUST_BE_VAR	       38	/* int argn, term_t term */
-
 typedef struct open_query_struct {
   int open;
   int state;
@@ -127,3 +86,4 @@ SWIFunctorToFunctor(functor_t f)
   return (Functor)f;
 }
 
+#define isDefinedProcedure(pred) TRUE // TBD

misc/ATOMS

@@ -234,6 +234,7 @@ A	Pointer			N	"pointer"
 A	Portray			F	"$portray"
 A	PredicateIndicator	N	"predicate_indicator"
 A	Primitive		N	"primitive"
+A	PrintMessage		N	"print_message"
 A	PrivateProcedure	N	"private_procedure"
 A	Procedure		N	"procedure"
 A	Profile			F	"$profile"
@@ -430,6 +431,7 @@ F	Or			Semic		2
 F	PermissionError		PermissionError	3
 F	Plus			Plus		2
 F	Portray			Portray		1
+F	PrintMessage		PrintMessage	2
 F	PrologConstraint	Prolog		2
 F	Query			Query		1
 F	RecordedWithKey		RecordedWithKey	6

os/pl-error.c

@@ -7,12 +7,7 @@
 #endif
 
 void			fatalError(const char *fm, ...) {exit(1);}
-int			printMessage(atom_t severity, ...) {
+int			printMessage(atom_t severity, ...);
-#if DEBUG 
-  fprintf(stderr,"calling printMessage: not implemented\n");
-#endif
-  return 0;
-}
 
 		 /*******************************
 		 *    ERROR-CHECKING *_get()	*
@@ -312,6 +307,59 @@ notImplemented(char *name, int arity)
 { return (word)PL_error(NULL, 0, NULL, ERR_NOT_IMPLEMENTED_PROC, name, arity);
 }
 
+/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+printMessage(atom_t severity, ...)
+
+Calls print_message(severity, term), where  ...   are  arguments  as for
+PL_unify_term(). This predicate saves possible   pending  exceptions and
+restores them to make the call from B_THROW possible.
+- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
+
+#define OK_RECURSIVE 10
+
+int
+printMessage(atom_t severity, ...)
+{ GET_LD
+    //wakeup_state wstate;
+  term_t av;
+  predicate_t pred = RepPredProp(PredPropByFunc(FunctorPrintMessage,PROLOG_MODULE)); //PROCEDURE_print_message2;
+  va_list args;
+  int rc;
+
+  if ( ++LD->in_print_message >= OK_RECURSIVE*3 )
+    fatalError("printMessage(): recursive call\n");
+  /*  if ( !saveWakeup(&wstate, TRUE PASS_LD) )
+  { LD->in_print_message--;
+    return FALSE;
+  }
+  */
+
+  av = PL_new_term_refs(2);
+  va_start(args, severity);
+  PL_put_atom(av+0, severity);
+  rc = PL_unify_termv(av+1, args);
+  va_end(args);
+
+  if ( rc )
+    { if ( isDefinedProcedure(pred)  && LD->in_print_message <= OK_RECURSIVE )
+    { rc = PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_CATCH_EXCEPTION,
+			     pred, av);
+    } else if ( LD->in_print_message <= OK_RECURSIVE*2 )
+    { Sfprintf(Serror, "Message: ");
+      rc = PL_write_term(Serror, av+1, 1200, 0);
+      Sfprintf(Serror, "\n");
+    } else				/* in_print_message == 2 */
+    { Sfprintf(Serror, "printMessage(): recursive call\n");
+    }
+  }
+
+  /* restoreWakeup(&wstate PASS_LD); */
+  LD->in_print_message--;
+
+  return rc;
+}
+
+
 int PL_error(const char *pred, int arity, const char *msg, PL_error_code id, ...)
 {
   GET_LD

os/pl-read.c

@@ -1243,6 +1243,11 @@ retry:
     return FALSE;
   }
 
+#ifdef O_QUASIQUOTATIONS
+  if ( rval)
+    rval = parse_quasi_quotations(&rd PASS_LD);
+#endif
+
   if ( rval )
   { if ( tpos )
       rval = unify_read_term_position(tpos PASS_LD);