changes to support extended foreign interface (include slots, new exception

handling for C-code, and several fixes to calling foreign code).


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@470 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

C/absmi.c

@@ -332,6 +332,13 @@ absmi(int inp)
 #endif /* OS_HANDLES_TR_OVERFLOW */
 
       BOp(Ystop, e);
+      if (Y > (CELL *) B) {
+	ASP = (CELL *) B;
+      }
+      else {
+	ASP = Y;
+      }
+      *--ASP = MkIntTerm(0);
       saveregs();
 #if PUSH_REGS
       restore_absmi_regs(old_regs);
@@ -343,6 +350,13 @@ absmi(int inp)
       ENDBOp();
 
       BOp(Nstop, e);
+      if (Y > (CELL *) B) {
+	ASP = (CELL *) B;
+      }
+      else {
+	ASP = Y;
+      }
+      *--ASP = MkIntTerm(0);
       saveregs();
 #if PUSH_REGS
       restore_absmi_regs(old_regs);
@@ -5730,6 +5744,8 @@ absmi(int inp)
       else {
 	ASP = (CELL *) (((char *) Y) + PREG->u.sla.s);
       }
+      /* for slots to work */
+      *--ASP = MkIntTerm(0);
 #endif /* FROZEN_STACKS */
 #ifdef LOW_LEVEL_TRACER
       if (do_low_level_trace)
@@ -7843,11 +7859,6 @@ absmi(int inp)
 #else
       pt0 = (choiceptr)(LCL0-IntOfTerm(d0));
 #endif
-      if (TopB != NULL && YOUNGER_CP(TopB,pt0)) {  
-	pt0 = TopB;
-	if (DelayedB == NULL || YOUNGER_CP(pt0,DelayedB))
-	  DelayedB = pt0;
-      }
       /* find where to cut to */
       if (SHOULD_CUT_UP_TO(B,pt0)) {
 	/* Wow, we're gonna cut!!! */
@@ -7896,11 +7907,6 @@ absmi(int inp)
 #else
       pt1 = (choiceptr)(LCL0-IntOfTerm(d0));
 #endif
-      if (TopB != NULL && YOUNGER_CP(TopB,pt1)) {  
-	pt1 = TopB;
-	if (DelayedB == NULL || YOUNGER_CP(pt1,DelayedB))
-	  DelayedB = pt1;
-      }
       if (SHOULD_CUT_UP_TO(B,pt1)) {
 	/* Wow, we're gonna cut!!! */
 #ifdef YAPOR
@@ -11660,11 +11666,6 @@ absmi(int inp)
 	    choiceptr pt0;
 
 	    pt0 = (choiceptr)(ENV[E_CB]);
-	    if (TopB != NULL && YOUNGER_CP(TopB,pt0)) {  
-	      pt0 = TopB;
-	      if (DelayedB == NULL || YOUNGER_CP(pt0,DelayedB))
-		DelayedB = pt0;
-	    }
 	    /* find where to cut to */
 	    if (SHOULD_CUT_UP_TO(B,pt0)) {
 #ifdef YAPOR
@@ -11801,11 +11802,6 @@ absmi(int inp)
 	    choiceptr pt0;
 
 	    pt0 = (choiceptr)(ENV[E_CB]);
-	    if (TopB != NULL && YOUNGER_CP(TopB,pt0)) {  
-	      pt0 = TopB;
-	      if (DelayedB == NULL || YOUNGER_CP(pt0,DelayedB))
-		DelayedB = pt0;
-	    }
 	    /* find where to cut to */
 	    if (SHOULD_CUT_UP_TO(B,pt0)) {
 #ifdef YAPOR

C/c_interface.c

@@ -59,6 +59,7 @@ X_API Atom    STD_PROTO(YapLookupAtom,(char *));
 X_API Atom    STD_PROTO(YapFullLookupAtom,(char *));
 X_API char   *STD_PROTO(YapAtomName,(Atom));
 X_API Term    STD_PROTO(YapMkPairTerm,(Term,Term));
+X_API Term    STD_PROTO(YapMkNewPairTerm,(void));
 X_API Term    STD_PROTO(YapHeadOfTerm,(Term));
 X_API Term    STD_PROTO(YapTailOfTerm,(Term));
 X_API Term    STD_PROTO(YapMkApplTerm,(Functor,unsigned int,Term *));
@@ -87,7 +88,9 @@ X_API Term    STD_PROTO(YapBufferToAtomList, (char *));
 X_API void    STD_PROTO(YapError,(char *));
 X_API int     STD_PROTO(YapRunGoal,(Term));
 X_API int     STD_PROTO(YapRestartGoal,(void));
+X_API int     STD_PROTO(YapGoalHasException,(Term *));
 X_API int     STD_PROTO(YapContinueGoal,(void));
+X_API void    STD_PROTO(YapPruneGoal,(void));
 X_API void    STD_PROTO(YapInitConsult,(int, char *));
 X_API void    STD_PROTO(YapEndConsult,(void));
 X_API Term    STD_PROTO(YapRead, (int (*)(void)));
@@ -102,7 +105,10 @@ X_API void    STD_PROTO(YapSetOutputMessage, (void));
 X_API int     STD_PROTO(YapStreamToFileNo, (Term));
 X_API void    STD_PROTO(YapCloseAllOpenStreams,(void));
 X_API Term    STD_PROTO(YapOpenStream,(void *, char *, Term, int));
-X_API Term   *STD_PROTO(YapNewSlots,(int));
+X_API long    STD_PROTO(YapNewSlots,(int));
+X_API Term    STD_PROTO(YapGetFromSlot,(long));
+X_API Term   *STD_PROTO(YapAddressFromSlot,(long));
+X_API void    STD_PROTO(YapPutInSlot,(long, Term));
 X_API void    STD_PROTO(YapRecoverSlots,(int));
 X_API void    STD_PROTO(YapThrow,(Term));
 X_API int     STD_PROTO(YapLookupModule,(Term));
@@ -111,6 +117,20 @@ X_API void    STD_PROTO(YapHalt,(int));
 X_API Term   *STD_PROTO(YapTopOfLocalStack,(void));
 X_API void   *STD_PROTO(YapPredicate,(Atom,Int,Int));
 X_API void    STD_PROTO(YapPredicateInfo,(void *,Atom *,Int *,Int *));
+X_API Int     STD_PROTO(YapCurrentModule,(void));
+
+static int (*do_getf)(void);
+
+static int do_yap_getc(int streamno) {
+  return(do_getf());
+}
+
+static void (*do_putcf)(int);
+
+static int do_yap_putc(int streamno,int ch) {
+  do_putcf(ch);
+  return(ch);
+}
 
 X_API Term
 YapA(int i)
@@ -270,6 +290,18 @@ YapMkPairTerm(Term t1, Term t2)
   return(t);
 }
 
+X_API Term
+YapMkNewPairTerm()
+{
+  Term t; 
+  BACKUP_H();
+
+  t = MkNewPairTerm();
+  
+  RECOVER_H();
+  return(t);
+}
+
 X_API Term 
 YapHeadOfTerm(Term t)
 {
@@ -398,10 +430,19 @@ X_API Int
 YapCallProlog(Term t)
 {
   Int out;
+  SMALLUNSGN mod = CurrentModule;
   BACKUP_MACHINE_REGS();
 
-  out = execute_goal(t, 0, CurrentModule);
+  while (!IsVarTerm(t) &&
-
+      IsApplTerm(t) &&
+      FunctorOfTerm(t) == FunctorModule) {
+    Term tmod = ArgOfTerm(1,t);
+    if (IsVarTerm(tmod)) return(FALSE);
+    if (!IsAtomTerm(tmod)) return(FALSE);
+    mod = LookupModule(tmod);
+    t = ArgOfTerm(2,t);
+  }
+  out = execute_goal(t, 0, mod);
   RECOVER_MACHINE_REGS();
   return(out);
 }
@@ -504,14 +545,23 @@ YapError(char *buf)
   Error(SYSTEM_ERROR,TermNil,buf);
 }
 
+static void myputc (int ch)
+{
+  putc(ch,stderr);
+}
+
+static Term told;
+static int counter=0;
+
 X_API int
 YapRunGoal(Term t)
 {
   int out;
   BACKUP_MACHINE_REGS();
 
-  InitYaamRegs();
+  do_putcf = myputc;
   out = RunTopGoal(t);
+  told = t;
 
   RECOVER_MACHINE_REGS();
   return(out);
@@ -524,7 +574,12 @@ YapRestartGoal(void)
   BACKUP_MACHINE_REGS();
 
   P = (yamop *)FAILCODE;
+  do_putcf = myputc;
   out = exec_absmi(TRUE);
+  if (out == FALSE) {
+    /* cleanup */
+    trust_last();
+  }
 
   RECOVER_MACHINE_REGS();
   return(out);
@@ -542,6 +597,31 @@ YapContinueGoal(void)
   return(out);
 }
 
+X_API void
+YapPruneGoal(void)
+{
+  BACKUP_B();
+
+  while (B->cp_ap != NOCODE) {
+    B = B->cp_b;
+  }
+
+  RECOVER_B();
+}
+
+X_API int
+YapGoalHasException(Term *t)
+{
+  int out = FALSE;
+  BACKUP_MACHINE_REGS();
+  if (EX) {
+    *t = EX;
+    out = TRUE;
+  }
+  RECOVER_MACHINE_REGS();
+  return(out);
+}
+
 X_API void
 YapInitConsult(int mode, char *filename)
 {
@@ -565,12 +645,6 @@ YapEndConsult(void)
   RECOVER_MACHINE_REGS();
 }
 
-static int (*do_getf)(void);
-
-static int do_yap_getc(int streamno) {
-  return(do_getf());
-}
-
 X_API Term
 YapRead(int (*mygetc)(void))
 {
@@ -595,13 +669,6 @@ YapRead(int (*mygetc)(void))
   return(t);
 }
 
-static void (*do_putcf)(int);
-
-static int do_yap_putc(int streamno,int ch) {
-  do_putcf(ch);
-  return(ch);
-}
-
 X_API void
 YapWrite(Term t, void (*myputc)(int), int flags)
 {
@@ -847,19 +914,43 @@ YapOpenStream(void *fh, char *name, Term nm, int flags)
   return retv;
 }
 
-X_API Term *
+X_API long
 YapNewSlots(int n)
 {
-  Term *slot;
+  Int old_slots = IntOfTerm(ASP[0]), oldn = n;
-  ASP -= n;
+  while (n > 0) {
-  slot = ASP;
+    RESET_VARIABLE(ASP);
-  return(slot);
+    ASP--;
+    n--;
+  }
+  ASP[0] = MkIntTerm(old_slots+oldn);
+  return((ASP+1)-LCL0);
 }
 
 X_API void
 YapRecoverSlots(int n)
 {
+  Int old_slots = IntOfTerm(ASP[0]);
   ASP += n;
+  ASP[0] = MkIntTerm(old_slots-n);
+}
+
+X_API Term
+YapGetFromSlot(long slot)
+{
+  return(Deref(LCL0[slot]));
+}
+
+X_API Term *
+YapAddressFromSlot(long slot)
+{
+  return(LCL0+slot);
+}
+
+X_API void
+YapPutInSlot(long slot, Term t)
+{
+  LCL0[slot] = t;
 }
 
 X_API void
@@ -918,3 +1009,9 @@ YapPredicateInfo(void *p, Atom* a, Int* arity, Int* m)
   }
   *m = pd->ModuleOfPred;
 } 
+
+X_API Int
+YapCurrentModule(void)
+{
+  return(CurrentModule);
+} 

C/dbase.c

@@ -3287,8 +3287,8 @@ MyEraseClause(Clause *clau)
   }
   if ( P == clau->ClCode) {
     yamop   *nextto;
-    P = (yamop *)(RTRYCODE);
+    P = RTRYCODE;
-    nextto = (yamop *)RTRYCODE;
+    nextto = RTRYCODE;
     nextto->u.ld.d = clau->ClCode->u.ld.d;
     nextto->u.ld.s = clau->ClCode->u.ld.s;
     nextto->u.ld.p = clau->ClCode->u.ld.p;
@@ -3305,7 +3305,7 @@ MyEraseClause(Clause *clau)
   if (DBREF_IN_USE(ref))
     return;
   if ( P == clau->ClCode ) {
-    yamop *np = (yamop *)RTRYCODE;
+    yamop *np = RTRYCODE;
     /* make it the next alternative */
     np->u.ld.d = (CODEADDR)find_next_clause((DBRef)(NEXTOP(P,ld)->u.sla.l2));
     if (np->u.ld.d == NULL)

C/exec.c

@@ -229,8 +229,8 @@ do_execute(Term t, SMALLUNSGN mod)
     if (pen->PredFlags & MetaPredFlag) {
       if (f == FunctorModule) {
 	Term tmod = ArgOfTerm(1,t);
-	if (!IsVarTerm(tmod) && IsAtomTerm(tmod) &&
+	if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
-	    mod == LookupModule(tmod)) {
+	  mod = LookupModule(tmod);
 	  t = ArgOfTerm(2,t);
 	  goto restart_exec;
 	}
@@ -337,8 +337,8 @@ p_execute_within(void)
       if (pen->PredFlags & MetaPredFlag) {
 	if (f == FunctorModule) {
 	  Term tmod = ArgOfTerm(1,t);
-	  if (!IsVarTerm(tmod) && IsAtomTerm(tmod) &&
+	  if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
-	      mod == LookupModule(tmod)) {
+	    mod = LookupModule(tmod);
 	    t = ArgOfTerm(2,t);
 	    goto restart_exec;
 	  }
@@ -371,11 +371,6 @@ p_execute_within(void)
     if (a == AtomTrue || a == AtomOtherwise)
       return(TRUE);
     else if (a == AtomCut) {
-      if (TopB != NULL && YOUNGER_CP(TopB,cut_pt)) {  
-	cut_pt = TopB;
-	if (DelayedB == NULL || YOUNGER_CP(cut_pt,DelayedB))
-	  DelayedB = cut_pt;
-      }
       /* find where to cut to */
       if (SHOULD_CUT_UP_TO(B,cut_pt)) {
 #ifdef YAPOR
@@ -470,11 +465,6 @@ p_execute_within2(void)
       choiceptr pt0;
 
       pt0 = (choiceptr)(ENV[E_CB]);
-      if (TopB != NULL && YOUNGER_CP(TopB,pt0)) {  
-	pt0 = TopB;
-	if (DelayedB == NULL || YOUNGER_CP(pt0,DelayedB))
-	  DelayedB = pt0;
-      }
       /* find where to cut to */
       if (SHOULD_CUT_UP_TO(B,pt0)) {
 #ifdef YAPOR
@@ -796,8 +786,8 @@ p_at_execute(void)
       return(FALSE);
     if (f == FunctorModule) {
       Term tmod = ArgOfTerm(1,t);
-      if (!IsVarTerm(tmod) && IsAtomTerm(tmod) &&
+      if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
-	  mod == LookupModule(tmod)) {
+	mod = LookupModule(tmod);
 	t = ArgOfTerm(2,t);
 	goto restart_exec;
       }
@@ -880,6 +870,7 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
   /* create an initial pseudo environment so that when garbage
      collection is going up in the environment chain it doesn't get
      confused */
+  EX = 0L;
   YENV = ASP;
   YENV[E_CP] = (CELL)P;
   YENV[E_CB] = (CELL)B;
@@ -890,15 +881,8 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
   ENV = YENV;
   ASP -= EnvSizeInCells;
   /* and now create a pseudo choicepoint for much the same reasons */
-  CP = (yamop *) YESCODE;
+  /* CP = YESCODE; */
-  /* this is an hack to save the arguments */
+  /* keep a place where you can inform you had an exception */
-  {
-    CELL *pt1 = XREGS+1+args_to_save;
-
-    while (pt1 > XREGS+1)
-      *--ASP = *--pt1;
-  }
-  *--ASP = MkIntTerm(args_to_save+1);
   { 
     int i;
     for (i = 0; i < arity; i++) {
@@ -915,7 +899,7 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
   B->cp_h     = H;
   B->cp_tr    = TR;
   B->cp_cp    = CP;
-  B->cp_ap    = (yamop *) NOCODE;
+  B->cp_ap    = NOCODE;
   B->cp_env   = ENV;
   B->cp_b     = saved_b;
 #ifdef DEPTH_LIMIT
@@ -935,7 +919,6 @@ do_goal(CODEADDR CodeAdr, int arity, CELL *pt, int args_to_save, int top)
   YENV[E_CB] = Unsigned (B);
   P = (yamop *) CodeAdr;
   S = CellPtr (RepPredProp (PredPropByFunc (MkFunctor(AtomCall, 1),0)));	/* A1 mishaps */
-  TopB = B;
 
   return(exec_absmi(top));
 }
@@ -953,14 +936,8 @@ execute_goal(Term t, int nargs, SMALLUNSGN mod)
   /* preserve the current restart environment */
   /* visualc*/
   /* just keep the difference because of possible garbage collections */
-  Int MyOldTopB = LCL0-(CELL *)TopB;
-  Int MyOldDelayedB = LCL0-(CELL *)DelayedB;
-  choiceptr OldTopB, OldDelayedB;
 
 
-  DelayedB = NULL;
-  /* forget we have a DelayedB to do, this is not a problem for the embedded computation to solve */
-
   saved_p = P;
   saved_cp = CP;
   
@@ -1015,105 +992,32 @@ execute_goal(Term t, int nargs, SMALLUNSGN mod)
 #endif /* TABLING */
     /* find out where we have the old arguments */
     old_B = ((choiceptr)(ENV-(EnvSizeInCells+nargs+1)))-1;
-    {
-      int i;
-      for (i=1; i<= nargs; i++) {
-#if MIN_ARRAY == 0
-	XREGS[i] = old_B->cp_args[i];
-#else
-	XREGS[i] = old_B->cp_last.cp_args[i];
-#endif
-      }
-    }
     CP   = saved_cp;
     P    = saved_p;
     ASP  = ENV;
-    ENV  = (CELL *)(ENV[E_E]);
+    *--ASP = MkIntTerm(0);
 #ifdef DEPTH_LIMIT
     DEPTH= ENV[E_DEPTH];
 #endif
+    ENV  = (CELL *)(ENV[E_E]);
     /* we have failed, and usually we would backtrack to this B,
        trouble is, we may also have a delayed cut to do */
-    OldTopB = (choiceptr)(LCL0-MyOldTopB);
+    if (B != NULL)
-    OldDelayedB = (choiceptr)(LCL0-MyOldDelayedB);
-    if (DelayedB != NULL) {
-      if (YOUNGER_CP(B,DelayedB)) {
-	/* we have a delayed cut to do */
-	if (YOUNGER_CP(OldTopB,DelayedB)) {
-	  /* and this delayed cut is to before the c-code that actually called us */
-	  B = OldTopB;
-#ifdef TABLING
-	  abolish_incomplete_subgoals(B);
-#endif /* TABLING */
-	  /* did we have a cut which was cutting more than our current cut? */
-	  if (OldDelayedB != NULL && YOUNGER_CP(DelayedB,OldDelayedB))
-	    DelayedB = OldDelayedB;
-	} else {
-	  /* just cut back to where we should cut */
-	  B = DelayedB;
-#ifdef TABLING
-	  abolish_incomplete_subgoals(B);
-#endif /* TABLING */
-	  DelayedB = OldDelayedB;
-	}
-      }
-    } else {
-      DelayedB = OldDelayedB;
-    }
-    TopB = OldTopB;
       HB   = B->cp_h;
     YENV = ENV;
     return(TRUE);
   } else if (out == 0) {
     ASP  = B->cp_env;
-    {
-      int i;
-      for (i=1; i<= nargs; i++) {
-#if MIN_ARRAY==0
-	XREGS[i] = B->cp_args[i];
-#else
-	XREGS[i] = B->cp_last.cp_args[i];
-#endif
-      }
-    }
     P    = saved_p;
     CP   = saved_cp;
     H    = B->cp_h;
 #ifdef DEPTH_LIMIT
     DEPTH= B->cp_depth;
 #endif
-    YENV = ENV  = (CELL *)((B->cp_env)[E_E]);
+    YENV= ASP = B->cp_env;
+    ENV  = (CELL *)((B->cp_env)[E_E]);
     B    = B->cp_b;
     SET_BB(B);
-    /* we have failed, and usually we would backtrack to this B,
-       trouble is, we may also have a delayed cut to do */
-    OldTopB = (choiceptr)(LCL0-MyOldTopB);
-    OldDelayedB = (choiceptr)(LCL0-MyOldDelayedB);
-    if (DelayedB != NULL) {
-      if (YOUNGER_CP(B,DelayedB)) {
-	/* we have a delayed cut to do */
-	if (YOUNGER_CP(OldTopB,DelayedB)) {
-	  /* and this delayed cut is to before the c-code that actually called us */
-	  B = OldTopB;
-#ifdef TABLING
-	  abolish_incomplete_subgoals(B);
-#endif /* TABLING */
-	  /* did we have a cut which was cutting more than our current cut? */
-	  if (OldDelayedB != NULL && YOUNGER_CP(DelayedB,OldDelayedB))
-	    DelayedB = OldDelayedB;
-	} else {
-	  /* just cut back to where we should cut */
-	  B = DelayedB;
-#ifdef TABLING
-	  abolish_incomplete_subgoals(B);
-#endif /* TABLING */
-	  DelayedB = OldDelayedB;
-	}
-      }
-    } else {
-      DelayedB = OldDelayedB;
-    }
-    TopB = OldTopB;
     HB = PROTECT_FROZEN_H(B);
     return(FALSE);
   } else {
@@ -1122,6 +1026,25 @@ execute_goal(Term t, int nargs, SMALLUNSGN mod)
   }
 }
 
+void
+trust_last(void)
+{
+  ASP  = B->cp_env;
+  P    = (yamop *)(B->cp_env[E_CP]);
+  CP   = B->cp_cp;
+  H    = B->cp_h;
+#ifdef DEPTH_LIMIT
+  DEPTH= B->cp_depth;
+#endif
+  YENV= ASP = B->cp_env;
+  ENV  = (CELL *)((B->cp_env)[E_E]);
+  B    = B->cp_b;
+  if (B) {
+    SET_BB(B);
+    HB = PROTECT_FROZEN_H(B);
+  }
+}
+
 int
 RunTopGoal(Term t)
 {
@@ -1130,7 +1053,9 @@ RunTopGoal(Term t)
   PredEntry *ppe;
   CELL *pt;
   UInt arity;
+  SMALLUNSGN mod = CurrentModule;
 
+ restart_runtopgoal:
   if (IsAtomTerm(t)) {
     Atom a = AtomOfTerm(t);
     pt = NULL;
@@ -1143,6 +1068,14 @@ RunTopGoal(Term t)
       Error(TYPE_ERROR_CALLABLE,t,"call/1");
       return(FALSE);
     }
+    if (f == FunctorModule) {
+      Term tmod = ArgOfTerm(1,t);
+      if (!IsVarTerm(tmod) && IsAtomTerm(tmod)) {
+	mod = LookupModule(tmod);
+	t = ArgOfTerm(2,t);
+	goto restart_runtopgoal;
+      }
+    }
     /* I cannot use the standard macro here because
        otherwise I would dereference the argument and
        might skip a svar */
@@ -1168,7 +1101,6 @@ RunTopGoal(Term t)
       return(FALSE);
     }
   CodeAdr = ppe->CodeOfPred;
-  READ_UNLOCK(ppe->PRWLock);
   if (TrailTop - HeapTop < 2048) {
     PrologMode = BootMode;
     Error(SYSTEM_ERROR,TermNil,
@@ -1238,11 +1170,6 @@ p_restore_regs2(void)
 #else
   pt0 = (choiceptr)(LCL0-IntOfTerm(d0));
 #endif
-  if (TopB != NULL && YOUNGER_CP(TopB,pt0)) {  
-    if (DelayedB == NULL || YOUNGER_CP(DelayedB,pt0))
-      DelayedB = pt0;
-    pt0 = TopB;
-  }
   /* find where to cut to */
   if (pt0 > B) {
     /* Wow, we're gonna cut!!! */
@@ -1287,16 +1214,18 @@ JumpToEnv(Term t) {
     while (B != NULL && B->cp_ap != pos) {
       /* we are already doing a catch */
       if (B->cp_ap == (yamop *)(PredHandleThrow->LastClause)) {
-	if (DelayedB == NULL || YOUNGER_CP(B,DelayedB))
-	  DelayedB = B;
 	P = (yamop *)FAILCODE;
 	if (first_func != NULL) {
 	  B = first_func;
 	}
 	return(FALSE);
       }
-      if (B->cp_ap == (yamop *) NOCODE && first_func == NULL)
+      if (B->cp_ap == NOCODE) {
-	first_func = B;
+	/* up to the C-code to deal with this! */
+	B->cp_h = H;
+	EX = t;
+	return(FALSE);
+      }
       B = B->cp_b;
     }
     /* uncaught throw */
@@ -1322,8 +1251,6 @@ JumpToEnv(Term t) {
   /* I could backtrack here, but it is easier to leave the unwinding
      to the emulator */
   B->cp_a3 = t;
-  if (DelayedB == NULL || YOUNGER_CP(B,DelayedB))
-    DelayedB = B;
   P = (yamop *)FAILCODE;
   if (first_func != NULL) {
     B = first_func;

C/grow.c

@@ -120,10 +120,6 @@ SetHeapRegs(void)
   H = PtoGloAdjust(H);
   HB = PtoGloAdjust(HB);
   B = ChoicePtrAdjust(B);
-  if (TopB != NULL)
-    TopB = ChoicePtrAdjust(TopB);
-  if (DelayedB != NULL)
-    DelayedB = ChoicePtrAdjust(DelayedB);
 #ifdef TABLING
   B_FZ = ChoicePtrAdjust(B_FZ);
   BB = ChoicePtrAdjust(BB);
@@ -168,10 +164,6 @@ SetStackRegs(void)
   ASP = PtoLocAdjust(ASP);
   LCL0 = PtoLocAdjust(LCL0);
   B = ChoicePtrAdjust(B);
-  if (TopB != NULL)
-    TopB = ChoicePtrAdjust(TopB);
-  if (DelayedB != NULL)
-    DelayedB = ChoicePtrAdjust(DelayedB);
 #ifdef TABLING
   B_FZ = ChoicePtrAdjust(B_FZ);
   BB = ChoicePtrAdjust(BB);

C/heapgc.c

@@ -1307,6 +1307,18 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
 #endif
 
 
+static void
+mark_slots(CELL *ptr)
+{
+  Int ns = IntOfTerm(*ptr);
+  ptr++;
+  while (ns > 0) {
+    mark_external_reference(ptr);
+    ptr++;
+    ns--;
+  }
+}
+
 static void 
 mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
 {
@@ -1452,9 +1464,9 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
       /* extended choice point */
       switch (opnum) {
       case _Nstop:
+	mark_slots(gc_B->cp_env);
 	if (gc_B->cp_b != NULL) {
-	  
+	  nargs = 0;
-	  nargs = IntOfTerm(gc_B->cp_a1);
 	  break;
 	} else {
 	  /* this is the last choice point, the work is done  ;-) */
@@ -1977,6 +1989,25 @@ sweep_environments(CELL_PTR gc_ENV, OPREG size, CELL *pvbmap)
   }
 }
 
+static void
+sweep_slots(CELL *ptr)
+{
+  Int ns = IntOfTerm(*ptr);
+  ptr++;
+  while (ns > 0) {
+    CELL cp_cell = *ptr;
+    if (MARKED(cp_cell)) {
+      UNMARK(ptr);
+      if (HEAP_PTR(cp_cell)) {
+	into_relocation_chain(ptr, GET_NEXT(cp_cell));
+      }
+    }
+    ptr++;
+    ns--;
+  }
+}
+
+
 /*
  * insert cells of each choicepoint & its chain of environments which point
  * to heap objects into relocation chains 
@@ -2021,21 +2052,8 @@ sweep_choicepoints(choiceptr gc_B)
       sweep_environments(gc_B->cp_env,
 			 EnvSizeInCells,
 			 NULL);
+      sweep_slots(gc_B->cp_env);
       if (gc_B->cp_b != NULL) {
-	register CELL_PTR saved_reg;
-	
-	/* for each saved register */
-	for (saved_reg = &gc_B->cp_a1;
-	     saved_reg < &gc_B->cp_a1 + IntOfTerm(gc_B->cp_a1);
-	     saved_reg++) {
-	  CELL cp_cell = *saved_reg;
-	  if (MARKED(cp_cell)) {
-	    UNMARK(saved_reg);
-	    if (HEAP_PTR(cp_cell)) {
-	      into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
-	    }
-	  }
-	}
 	break;
       } else
 	return;

C/init.c

@@ -809,16 +809,11 @@ InitCodes(void)
   heap_regs->env_for_yes_code.s = -Signed(RealEnvSize);
   heap_regs->env_for_yes_code.l = NULL;
   heap_regs->env_for_yes_code.l2 = NULL;
-  heap_regs->yescode = opcode(_Ystop);
+  heap_regs->yescode.opc = opcode(_Ystop);
   heap_regs->undef_op = opcode(_undef_p);
   heap_regs->index_op = opcode(_index_pred);
 
-#ifdef YAPOR
   heap_regs->nocode.opc = opcode(_Nstop);
-  INIT_YAMOP_LTT(&(heap_regs->nocode), 1);
-#else
-  heap_regs->nocode = opcode(_Nstop);
-#endif /* YAPOR */
 
   ((yamop *)(&heap_regs->rtrycode))->opc = opcode(_retry_and_mark);
   ((yamop *)(&heap_regs->rtrycode))->u.ld.s = 0;
@@ -1089,7 +1084,7 @@ InitYaamRegs(void)
    *must* be created since for the garbage collector to work */
   B = NULL;
   ENV = NULL;
-  P = CP = (yamop *)YESCODE;
+  P = CP = YESCODE;
 #ifdef DEPTH_LIMIT
   DEPTH = RESET_DEPTH();
 #endif
@@ -1103,7 +1098,9 @@ InitYaamRegs(void)
   TR = TR_FZ = TR_BASE;
 #endif /* FROZEN_STACKS */
   CreepFlag = CalculateStackGap();
-
+  EX = 0L;
+  /* for slots to work */
+  *--ASP = MkIntTerm(0);
 }
 
 

C/iopreds.c

@@ -2661,6 +2661,12 @@ static Int
 p_write (void)
 {				/* '$write'(+Flags,?Term) */
   plwrite (ARG2, Stream[c_output_stream].stream_putc, (int) IntOfTerm (Deref (ARG1)));
+  if (EX != 0L) {
+    Term ball = EX;
+    EX = 0L;
+    JumpToEnv(ball);
+    return(FALSE);
+  }
   return (TRUE);
 }
 
@@ -2675,6 +2681,12 @@ p_write2 (void)
   }
   plwrite (ARG3, Stream[c_output_stream].stream_putc, (int) IntOfTerm (Deref (ARG2)));
   c_output_stream = old_output_stream;
+  if (EX != 0L) {
+    Term ball = EX;
+    EX = 0L;
+    JumpToEnv(ball);
+    return(FALSE);
+  }
   return (TRUE);
 }
 
@@ -4239,6 +4251,13 @@ format(Term tail, Term args, int sno)
 	      arghd = HeadOfTerm (args);
 	      args = TailOfTerm (args);
 	      plwrite (arghd, format_putc, (int) 12);
+	      if (EX != 0L) {
+		Term ball = EX;
+		EX = 0L;
+		FreeAtomSpace(format_base);
+		JumpToEnv(ball);
+		return(FALSE);
+	      }
 	      break;
 	    case 'q':
 	      if (size_args) {

C/other.c

@@ -34,6 +34,18 @@ MkPairTerm(Term head, Term tail)
 }
 
 
+Term 
+MkNewPairTerm(void)
+{
+  register CELL  *p = H;
+
+  RESET_VARIABLE(H);
+  RESET_VARIABLE(H+1);
+  H+=2;
+  return (AbsPair(p));
+}
+
+
 Term 
 MkApplTerm(Functor f, unsigned int n, register Term *a)	
      /* build compound term with functor f and n

C/tracer.c

@@ -112,7 +112,7 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
   /*  extern int gc_calls; */
 
   vsc_count++;
-  if (vsc_count < 618000) return;
+  /* if (vsc_count < 618000) return; */
   /*  if (vsc_count == 656) {
     printf("Here I go\n");
   }

C/unify.c

@@ -1679,11 +1679,6 @@ p_cut_by( void)
 #else
   pt0 = (choiceptr)(LCL0-IntOfTerm(d0));
 #endif
-  if (TopB != NULL && YOUNGER_CP(TopB,pt0)) {  
-    if (DelayedB == NULL || YOUNGER_CP(DelayedB,pt0))
-      DelayedB = pt0;
-    pt0 = TopB;
-  }
   /* find where to cut to */
   if (pt0 > B) {
     /* Wow, we're gonna cut!!! */

C/write.c

@@ -359,6 +359,8 @@ writeTerm(Term t, int p, int depth, int rinfixarg)
     putAtom(LookupAtom("..."));
     return;
   }
+  if (EX != 0)
+    return;
   t = Deref(t);
   if (IsVarTerm(t)) {
     write_var((CELL *)t);
@@ -386,9 +388,15 @@ writeTerm(Term t, int p, int depth, int rinfixarg)
 
     if (Use_portray) {
       Term targs[1];
+      Term old_EX = 0L;
+
       targs[0] = t;
       PutValue(AtomPortray, MkAtomTerm(AtomNil));
+      if (EX != 0L) old_EX = EX;
+      *--ASP = MkIntTerm(0);
       execute_goal(MkApplTerm(FunctorPortray, 1, targs), 0, 1);
+      if (old_EX != 0L) EX = old_EX;
+      Use_portray = TRUE;
       Use_portray = TRUE;
       if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
 	return;
@@ -463,11 +471,15 @@ writeTerm(Term t, int p, int depth, int rinfixarg)
 #endif
     if (Use_portray) {
       Term targs[1];
+      Term old_EX = 0L;
       targs[0] = t;
       PutValue(AtomPortray, MkAtomTerm(AtomNil));
+      if (EX != 0L) old_EX = EX;
+      *--ASP = MkIntTerm(0);
       execute_goal(MkApplTerm(FunctorPortray, 1, targs),0, 1);
+      if (old_EX != 0L) EX = old_EX;
       Use_portray = TRUE;
-      if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue))
+      if (GetValue(AtomPortray) == MkAtomTerm(AtomTrue) || EX != 0L)
 	return;
     }
     if (!Ignore_ops &&

H/Heap.h

@@ -10,7 +10,7 @@
 * File:		Heap.h         						 *
 * mods:									 *
 * comments:	Heap Init Structure					 *
-* version:      $Id: Heap.h,v 1.24 2002-02-26 15:51:54 vsc Exp $	 *
+* version:      $Id: Heap.h,v 1.25 2002-05-14 18:24:33 vsc Exp $	 *
 *************************************************************************/
 
 /* information that can be stored in Code Space */
@@ -80,15 +80,9 @@ typedef struct various_codes {
     struct pred_entry *p;
     struct pred_entry *p0;
   } env_for_yes_code; /* sla */
-  OPCODE yescode;
+  yamop yescode;
-#ifdef YAPOR
   yamop nocode;
   yamop rtrycode;
-#else
-  OPCODE nocode;
-  /* yamop rtrycode; problem: we would have to publish yamop */
-  CELL rtrycode[4];
-#endif /* YAPOR */
   struct {
     OPREG arity;
     CODEADDR clause;
@@ -317,10 +311,10 @@ typedef struct various_codes {
 #define  FAILCODE                 ((CODEADDR)&(heap_regs->failcode       ))
 #define  FAILCODE                 ((CODEADDR)&(heap_regs->failcode       ))
 #define  TRUSTFAILCODE            ((CODEADDR)&(heap_regs->trustfailcode  ))
-#define  YESCODE                  ((CODEADDR)&(heap_regs->yescode        ))
+#define  YESCODE                  (&(heap_regs->yescode                  ))
-#define  NOCODE                   ((CODEADDR)&(heap_regs->nocode         ))
+#define  NOCODE                   (&(heap_regs->nocode                   ))
-#define  RTRYCODE                 ((CODEADDR)&(heap_regs->rtrycode       ))
+#define  RTRYCODE                 (&(heap_regs->rtrycode                 ))
-#define  DUMMYCODE                ((CODEADDR)&(heap_regs->dummycode      ))
+#define  DUMMYCODE                (&(heap_regs->dummycode                ))
 #define  CLAUSECODE               (&(heap_regs->clausecode               ))
 #define  INVISIBLECHAIN           heap_regs->invisiblechain
 #define  max_depth                (&(heap_regs->maxdepth   	         ))

H/Regs.h

@@ -10,7 +10,7 @@
 * File:		Regs.h							 *
 * mods:									 *
 * comments:	YAP abstract machine registers				 *
-* version:      $Id: Regs.h,v 1.14 2002-03-08 06:33:16 vsc Exp $	 *
+* version:      $Id: Regs.h,v 1.15 2002-05-14 18:24:33 vsc Exp $	 *
 *************************************************************************/
 
 
@@ -84,9 +84,8 @@ typedef struct
     ADDR   HeapPlus_;		/* 11 To avoid collisions with HeapTop        */
     tr_fr_ptr MyTR_;		/* 12                                         */
 /* visualc*/
-    choiceptr   TopB_;		/* 17 Top up to where we can cut to           */
-    choiceptr   DelayedB_;	/* 17 Cut Still To be Done                    */
     CELL   FlipFlop_;		/* 18                                         */
+    CELL   EX_;	    	        /* 18                                         */
 #ifdef COROUTINING
     Term  DelayedVars_;         /* maximum number of attributed variables     */
 #endif
@@ -628,6 +627,7 @@ EXTERN inline void restore_B(void) {
 #define TopB      REGS.TopB_
 #define DelayedB  REGS.DelayedB_
 #define FlipFlop  REGS.FlipFlop_
+#define EX        REGS.EX_
 #define DEPTH	  REGS.DEPTH_
 #if (defined(YAPOR) && defined(SBA)) || defined(TABLING)
 #define H_FZ          REGS.H_FZ_

H/Yapproto.h

@@ -10,7 +10,7 @@
 * File:		Yap.proto						 *
 * mods:									 *
 * comments:	Function declarations for YAP				 *
-* version:      $Id: Yapproto.h,v 1.16 2002-05-06 15:33:04 vsc Exp $	 *
+* version:      $Id: Yapproto.h,v 1.17 2002-05-14 18:24:33 vsc Exp $	 *
 *************************************************************************/
 
 /* prototype file for Yap */
@@ -43,6 +43,7 @@ Functor	STD_PROTO(UnlockedMkFunctor,(AtomEntry *,unsigned int));
 Functor	STD_PROTO(MkFunctor,(Atom,unsigned int));
 void	STD_PROTO(MkFunctorWithAddress,(Atom,unsigned int,FunctorEntry *));
 Term	STD_PROTO(MkPairTerm,(Term,Term));
+Term	STD_PROTO(MkNewPairTerm,(void));
 void	STD_PROTO(PutValue,(Atom,Term));
 void	STD_PROTO(ReleaseAtom,(Atom));
 Term	STD_PROTO(StringToList,(char *));
@@ -155,6 +156,7 @@ Int	STD_PROTO(JumpToEnv,(Term));
 int	STD_PROTO(RunTopGoal,(Term));
 Int	STD_PROTO(execute_goal,(Term, int, SMALLUNSGN));
 int	STD_PROTO(exec_absmi,(int));
+void	STD_PROTO(trust_last,(void));
 
 
 /* grow.c */

docs/yap.tex

@@ -4672,21 +4672,23 @@ both static and dynamic predicates.
 @findex assert_static/1
 @snindex assert_static/1
 @cnindex assert_static/1
- Adds clause @var{C} to a static procedure.
+ Adds clause @var{C} to a static procedure. Asserting a static clause
+for a predicate while choice-points for the predicate are availabe has
+undefined results.
 
 @item asserta_static(+@var{C})
 @findex asserta_static/1
 @snindex asserta_static/1
 @cnindex asserta_static/1
- Adds clause @var{C} to the beginning of a static procedure. Note that
+ Adds clause @var{C} to the beginning of a static procedure. 
-the operation may fail if pointers to the procedure are in the stacks.
 
 @item assertz_static(+@var{C})
 @findex assertz_static/1
 @snindex assertz_static/1
 @cnindex assertz_static/1
- Adds clause @var{C} to the end of a static procedure. Note that
+ Adds clause @var{C} to the end of a static procedure.  Asserting a
-the operation may fail if pointers to the procedure are in the stacks.
+static clause for a predicate while choice-points for the predicate are
+availabe has undefined results.
 
 @end table
 

include/c_interface.h

@@ -235,6 +235,15 @@ static Term (*YapIMkPairTerm)() = YapMkPairTerm;
 #define MkPairTerm(T1,T2) YapMkPairTerm(T1,T2)
 #endif
 
+/*    Term  MkNewPairTerm(void) */
+extern X_API Term PROTO(YapMkNewPairTerm,(void));
+#ifdef IndirectCalls
+static Term (*YapIMkNewPairTerm)() = YapMkNewPairTerm;
+#define MkNewPairTerm() (*YapIMkNewPairTerm)()
+#else
+#define MkNewPairTerm() YapMkNewPairTerm()
+#endif
+
 /*    Term  HeadOfTerm(Term)  */
 extern X_API Term PROTO(YapHeadOfTerm,(Term));
 #ifdef IndirectCalls
@@ -355,9 +364,9 @@ static void (*YapIUserBackCPredicate)() = UserBackCPredicate;
 #endif
 
 /*  void CallProlog(Term t) */
-extern X_API void PROTO(YapCallProlog,(Term t));
+extern X_API Int PROTO(YapCallProlog,(Term t));
 #ifdef IndirectCalls
-static void (*YapICallProlog)() = YapCallProlog;
+static Int (*YapICallProlog)() = YapCallProlog;
 #define CallProlog(t) (*YapICallProlog)(t)
 #else
 #define CallProlog(t) YapCallProlog(t)
@@ -420,6 +429,20 @@ static int (YapIContinueGoal)() = YapContinueGoal;
 #define YapContinueGoal() (*YapIContinueGoal)()
 #endif
 
+/*  void YapPruneGoal(void) */
+extern X_API void PROTO(YapPruneGoal,(void));
+#ifdef IndirectCalls
+static void (YapIPruneGoal)() = YapPruneGoal;
+#define YapPruneGoal() (*YapIPruneGoal)()
+#endif
+
+/*  int YapGoalHasException(void) */
+extern X_API int PROTO(YapGoalHasException,(Term *));
+#ifdef IndirectCalls
+static int (YapIGoalHasException)(TP) = YapGoalHasException;
+#define YapGoalHasException(TP) (*YapIGoalHasException)(TP)
+#endif
+
 /*  int YapReset(void) */
 extern X_API void PROTO(YapReset,(void));
 #ifdef IndirectCalls
@@ -592,12 +615,33 @@ static Term (*YapIOpenStream)() = YapOpenStream;
 #endif
 
 /*  Term  *YapNewSlots()  */
-extern X_API Term *PROTO(YapNewSlots,(int));
+extern X_API long PROTO(YapNewSlots,(int));
 #ifdef IndirectCalls
-static Term *(*YapINewSlots)(N) = YapNewSlots;
+static long (*YapINewSlots)(N) = YapNewSlots;
 #define YapNewSlots(N) (*YapINewSlots)(N)
 #endif
 
+/*  Term  YapGetFromSlots(t)  */
+extern X_API Term PROTO(YapGetFromSlot,(long));
+#ifdef IndirectCalls
+static Term (*YapIGetFromSlot)(N) = YapGetFromSlot;
+#define YapGetFromSlot(N) (*YapIGetFromSlot)(N)
+#endif
+
+/*  Term  YapAddressFromSlots(t)  */
+extern X_API Term *PROTO(YapAddressFromSlot,(long));
+#ifdef IndirectCalls
+static Term *(*YapIAddressFromSlot)(N) = YapAddressFromSlot;
+#define YapAddressFromSlot(N) (*YapIAddressFromSlot)(N)
+#endif
+
+/*  Term  YapPutInSlots(t)  */
+extern X_API void PROTO(YapPutInSlot,(long, Term));
+#ifdef IndirectCalls
+static void (*YapIPutInSlot)(N,T) = YapPutInSlot;
+#define YapPutInSlot(N,T) (*YapIPutInSlot)(N,T)
+#endif
+
 /*  void  YapRecoverSlots()  */
 extern X_API void PROTO(YapRecoverSlots,(int));
 #ifdef IndirectCalls
@@ -655,5 +699,13 @@ static void (*YapIPredicateInfo)(P,N,A,M) = YapPredicateInfo;
 #endif
 
 
+/*  int  YapPredicate()  */
+extern X_API int  PROTO(YapCurrentModule,(void));
+#ifdef IndirectCalls
+static int (*YapICurrentModule)() = YapCurrentModule;
+#define YapCurrentModule() (*YapICurrentModule)()
+#endif
+
+
 #define InitCPred(N,A,F)  UserCPredicate(N,F,A)
 

misc/yap.def

@@ -24,6 +24,7 @@ YapLookupAtom
 YapFullLookupAtom
 YapAtomName
 YapMkPairTerm
+YapMkNewPairTerm
 YapHeadOfTerm
 YapTailOfTerm
 YapMkApplTerm
@@ -48,6 +49,8 @@ YapBufferToAtomList
 YapError
 YapRunGoal
 YapContinueGoal
+YapPruneGoal
+YapGoalHasException
 YapRead
 YapCompileClause
 YapInit
@@ -65,6 +68,9 @@ YapStreamToFileNo
 YapCloseAllOpenStreams
 YapOpenStream
 YapNewSlots
+YapGetFromSlot
+YapAddressFromSlot
+YapPutInSlot
 YapRecoverSlots
 YapThrow
 YapLookupModule
@@ -72,4 +78,5 @@ YapModuleName
 YapHalt
 YapTopOfLocalStack
 YapPredicate
+YapCurrentModule
 

pl/init.yap

@@ -22,7 +22,7 @@
 % so that the user will get a redefining system predicate
 otherwise.
 fail :- fail.
-false :- false.
+false :- fail.
 !.
 (:- G) :- '$execute'(G), !.
 '$$!'(CP) :- '$cut_by'(CP).
@@ -121,7 +121,6 @@ system_mode(verbose,off) :- '$set_value'('$verbose',off).
 
 :- module(user).
 
-
 :- multifile goal_expansion/3.
 
 :- dynamic_predicate(goal_expansion/3, logical).