fixes for export_term and friends.

C/c_interface.c

@@ -558,11 +558,22 @@ X_API YAP_tag_t STD_PROTO(YAP_TagOfTerm,(Term));
 X_API size_t   STD_PROTO(YAP_ExportTerm,(Term, char *, size_t));
 X_API Term     STD_PROTO(YAP_ImportTerm,(char *));
 
+static UInt
+current_arity(void)
+{
+ if (P && PREVOP(P,Osbpp)->opc == Yap_opcode(_call_usercpred)) {
+    return PREVOP(P,Osbpp)->u.Osbpp.p->ArityOfPE;
+  } else {
+    return 0;
+  }
+}
+
 static int
-dogc( USES_REGS1 )
+dogc( int extra_args, Term *tp USES_REGS )
 {
   UInt arity;
   yamop *nextpc;
+  int i;
 
   if (P && PREVOP(P,Osbpp)->opc == Yap_opcode(_call_usercpred)) {
     arity = PREVOP(P,Osbpp)->u.Osbpp.p->ArityOfPE;
@@ -571,9 +582,15 @@ dogc( USES_REGS1 )
     arity = 0;
     nextpc = CP;
   }
-  if (!Yap_gc(arity, ENV, nextpc)) {
+  for (i=0; i < extra_args; i++) {
+    XREGS[arity+i+1] = tp[i];
+  }
+  if (!Yap_gc(arity+extra_args, ENV, nextpc)) {
     return FALSE;
   }
+  for (i=0; i < extra_args; i++) {
+     tp[i] = XREGS[arity+i+1];
+  }
   return TRUE;
 }
 
@@ -973,7 +990,7 @@ YAP_MkPairTerm(Term t1, Term t2)
     Int sl1 = Yap_InitSlot(t1 PASS_REGS);
     Int sl2 = Yap_InitSlot(t2 PASS_REGS);
     RECOVER_H();
-    if (!dogc( PASS_REGS1 )) {
+    if (!dogc( 0, NULL PASS_REGS )) {
       return TermNil;
     }
     BACKUP_H();
@@ -998,7 +1015,7 @@ YAP_MkListFromTerms(Term *ta, Int sz)
   while (H+sz*2 > ASP-1024) {
     Int sl1 = Yap_InitSlot((CELL)ta PASS_REGS);
     RECOVER_H();
-    if (!dogc( PASS_REGS1 )) {
+    if (!dogc( 0, NULL PASS_REGS )) {
       return TermNil;
     }
     BACKUP_H();
@@ -2026,7 +2043,7 @@ YAP_ReadBuffer(char *s, Term *tp)
   while ((t = Yap_StringToTerm(s,tp)) == 0L) {
     if (LOCAL_ErrorMessage) {
       if (!strcmp(LOCAL_ErrorMessage,"Stack Overflow")) {
-	if (!dogc( PASS_REGS1 )) {
+	if (!dogc( 0, NULL PASS_REGS )) {
 	  *tp = MkAtomTerm(Yap_LookupAtom(LOCAL_ErrorMessage));
 	  LOCAL_ErrorMessage = NULL;
 	  RECOVER_H();
@@ -3555,7 +3572,7 @@ YAP_FloatsToList(double *dblp, size_t sz)
       /* we are in trouble */
       LOCAL_OpenArray =  (CELL *)dblp;
     }
-    if (!dogc( PASS_REGS1 )) {
+    if (!dogc( 0, NULL PASS_REGS )) {
       RECOVER_H();
       return 0L;
     }
@@ -3583,7 +3600,7 @@ YAP_OpenList(int n)
   BACKUP_H();
 
   while (H+2*n > ASP-1024) {
-    if (!dogc( PASS_REGS1 )) {
+    if (!dogc( 0, NULL PASS_REGS )) {
       RECOVER_H();
       return FALSE;
     }
@@ -3988,9 +4005,13 @@ YAP_IsNumberedVariable(Term t) {
 
 X_API size_t
 YAP_ExportTerm(Term inp, char * buf, size_t len) {
+  size_t res;
   if (!len)
     return 0;
-  return Yap_ExportTerm(inp, buf, len);
+  if ((res = Yap_ExportTerm(inp, buf, len, current_arity())) < 0) {
+    exit(1);
+  }
+  return res;
 }
 
 X_API Term

C/utilpreds.c

@@ -1171,7 +1171,7 @@ CELL *CellDifH(CELL *hptr, CELL *hlow)
 #define AdjustSizeAtom(X)	((char *)(((CELL)X+7) & (CELL)(-8)))
 
 static inline 
-Atom export_atom(Atom at, char **hpp, size_t len)
+Atom export_atom(Atom at, char **hpp, char *buf, size_t len)
 {				 
   char *ptr, *p0;
   size_t sz;
@@ -1197,21 +1197,22 @@ Atom export_atom(Atom at, char **hpp, size_t len)
     *hpp = ptr+(sz+1);
   }
   ptr += sz;
-  return (Atom)p0;
+  return (Atom)(p0-buf);
 }
 
 static inline 
-Functor export_functor(Functor f, char **hpp, size_t len)
+Functor export_functor(Functor f, char **hpp, char *buf, size_t len)
 {
   CELL *hptr = (UInt *)AdjustSizeAtom(*hpp);
   UInt arity = ArityOfFunctor(f);
   if (2*sizeof(CELL) >= len)
-    return (Functor)NULL;
+    return NULL;
   hptr[0] = arity;
   *hpp = (char *)(hptr+1);
-  if (!export_atom(NameOfFunctor(f), hpp, len))
+  if (!export_atom(NameOfFunctor(f), hpp, buf, len))
-    return 0L;
+    return NULL;
-  return (Functor)hptr;
+  /* increment so that it cannot be mistaken with a standard functor */
+  return (Functor)(((char *)hptr-buf)+1);
 }
 
 #define export_derefa_body(D,A,LabelUnk,LabelNonVar)                \
@@ -1229,7 +1230,7 @@ export_term_to_buffer(Term inpt, char *buf, char *bptr, CELL *t0 , CELL *tf, siz
 {
   char *td = bptr;
   CELL *bf = (CELL *)buf;
-  if (buf + len < (char *)(td + (tf-t0)))
+  if (buf + len < (char *)((CELL *)td + (tf-t0)))
     return FALSE;
   memcpy((void *)td, (void *)t0, (tf-t0)* sizeof(CELL));
   bf[0] = (td-buf);
@@ -1246,7 +1247,7 @@ export_complex_term(Term tf, CELL *pt0, CELL *pt0_end, char * buf, size_t len0,
   CELL *HB0 = HB;
   tr_fr_ptr TR0 = TR;
   int ground = TRUE;
-  char *bptr = buf+ 3*sizeof(CELL), *bptr_end;
+  char *bptr = buf+ 3*sizeof(CELL);
   size_t len = len0;
 
   HB = HLow;
@@ -1368,14 +1369,14 @@ export_complex_term(Term tf, CELL *pt0, CELL *pt0_end, char * buf, size_t len0,
 	if (H > ASP - 2048) {
 	  goto overflow;
 	}
-	ptf[-1] = (CELL)export_functor(f, &bptr, len);
+	ptf[-1] = (CELL)export_functor(f, &bptr, buf, len);
 	len = len0 - (bptr-buf);
 	if (H > ASP - 2048) {
 	  goto overflow;
 	}
       } else {
 	if (IsAtomTerm(d0)) {
-	  *ptf = MkAtomTerm(export_atom(AtomOfTerm(d0), &bptr, len));
+	  *ptf = MkAtomTerm(export_atom(AtomOfTerm(d0), &bptr, buf, len));
 	  ptf++;
 	  len = len0 - (bptr-buf);
 	} else {
@@ -1508,24 +1509,27 @@ static size_t
 ExportTerm(Term inp, char * buf, size_t len, UInt arity, int newattvs USES_REGS) {
   Term t = Deref(inp);
   tr_fr_ptr TR0 = TR;
-  size_t res;
+  size_t res = 0;
   CELL *Hi;
 
- restart:
+  do {
-  Hi = H;
+    if ((Int)res < 0) {
-  if ((res = export_complex_term(inp, &t-1, &t, buf, len, newattvs, Hi, Hi PASS_REGS)) < 0) {
       H = Hi;
+      TR = TR0;
       if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L)
-      return FALSE;
+	return res;
-    goto restart;
     }
+    Hi = H;
+    TR0 = TR;
+    res = export_complex_term(inp, &t-1, &t, buf, len, newattvs, Hi, Hi PASS_REGS);
+  } while ((Int)res < 0);
   return res;
 }
  
 size_t
-Yap_ExportTerm(Term inp, char * buf, size_t len) {
+Yap_ExportTerm(Term inp, char * buf, size_t len, UInt arity) {
   CACHE_REGS
-  return ExportTerm(inp, buf, len, 0, TRUE PASS_REGS);
+  return ExportTerm(inp, buf, len, arity, TRUE PASS_REGS);
 }
 
 
@@ -1536,9 +1540,9 @@ ShiftPtr(CELL t, char *base)
 }
 
 static Atom
-AddAtom(Atom t)
+AddAtom(Atom t, char *buf)
 {
-  char *s = (char *)t;
+  char *s = buf+(UInt)t;
   if (!*s) {
     return Yap_LookupAtom(s+1);
   } else {
@@ -1548,71 +1552,68 @@ AddAtom(Atom t)
 }
 
 static UInt
-FetchFunctor(CELL *pt)
+FetchFunctor(CELL *pt, char *buf)
 {
-  CELL *ptr = (CELL *)(*pt); 
+  CELL *ptr = (CELL *)(buf+(*pt-1)); 
   // do arity first
-  UInt arity = *ptr;
+  UInt arity = *ptr++;
-  char *name;
+  Atom name, at;
   // and then an atom
-  ++ptr;
+  ptr = (CELL *)AdjustSizeAtom((char*)ptr);
-  name = (char *)ptr;
+  name = (Atom)((char *)ptr-buf);
-  name = AdjustSizeAtom(name);
+  at = AddAtom(name, buf);
-  *pt = (CELL)Yap_MkFunctor(AddAtom((Atom)name), arity);
+  *pt = (CELL)Yap_MkFunctor(at, arity);
   return arity;
 }
 
 
-static CELL *import_compound(CELL *hp, char *abase, CELL *amax);
+static CELL *import_compound(CELL *hp, char *abase, char *buf, CELL *amax);
-static CELL *import_pair(CELL *hp, char *abase, CELL *amax);
+static CELL *import_pair(CELL *hp, char *abase, char *buf, CELL *amax);
 
 static CELL *
-import_arg(CELL *hp, char *abase, CELL *amax)
+import_arg(CELL *hp, char *abase, char *buf, CELL *amax)
 {
   Term t = *hp;
-    fprintf(stderr,"t = %lx\n", t);
   if (IsVarTerm(t)) {
     hp[0] = (CELL)ShiftPtr(t, abase);
   } else if (IsAtomTerm(t)) {
-    hp[0] = MkAtomTerm(AddAtom(AtomOfTerm(t)));
+    hp[0] = MkAtomTerm(AddAtom(AtomOfTerm(t), buf));
   } else if (IsPairTerm(t)) {
-    fprintf(stderr,"amax = %p newp=%p\n", amax, RepPair(t));
     CELL *newp = ShiftPtr((CELL)RepPair(t), abase);
     hp[0] = AbsPair(newp);
     if (newp > amax) {
-      amax = import_pair(newp, abase, newp);
+      amax = import_pair(newp, abase, buf, newp);
     }
   } else if (IsApplTerm(t)) {
-    fprintf(stderr,"amax = %p newp=%p\n", amax, RepAppl(t));
     CELL *newp = ShiftPtr((CELL)RepAppl(t), abase);
     hp[0] = AbsAppl(newp);
     if (newp > amax) {
-      amax = import_compound(newp, abase, newp);
+      amax = import_compound(newp, abase, buf, newp);
     }
   }
   return amax;
 }
 
 static CELL *
-import_compound(CELL *hp, char *abase, CELL *amax)
+import_compound(CELL *hp, char *abase, char *buf, CELL *amax)
 {
   Functor f = (Functor)*hp;
   UInt ar, i;
 
-  if (IsExtensionFunctor(f))
+  if (!((CELL)f & 1) && IsExtensionFunctor(f))
     return amax;
-  ar = FetchFunctor(hp);
+  ar = FetchFunctor(hp, buf);
   for (i=1; i<=ar; i++) {
-    amax = import_arg(hp+i, abase, amax);
+    amax = import_arg(hp+i, abase, buf, amax);
   }    
   return amax;
 }
 
 static CELL *
-import_pair(CELL *hp, char *abase, CELL *amax)
+import_pair(CELL *hp, char *abase, char *buf, CELL *amax)
 {
-  amax = import_arg(hp, abase, amax);
+  amax = import_arg(hp, abase, buf, amax);
-  amax = import_arg(hp+1, abase, amax);
+  amax = import_arg(hp+1, abase, buf, amax);
   return amax;
 }
 
@@ -1638,10 +1639,10 @@ Yap_ImportTerm(char * buf) {
   memcpy(H, buf+bc[0], sizeof(CELL)*sz);
   if (IsApplTerm(tinp)) {
     tret = AbsAppl(H);
-    import_compound(H, (char *)H, H);
+    import_compound(H, (char *)H, buf, H);
   } else {
     tret = AbsPair(H);
-    import_pair(H, (char *)H, H);
+    import_pair(H, (char *)H, buf, H);
   }
   H += sz;
   return tret;
@@ -1656,7 +1657,7 @@ static char export_debug_buf[2048];
 static Int
 p_export_term( USES_REGS1 )
 {
-  Yap_ExportTerm(ARG1, export_debug_buf, 2048);
+  Yap_ExportTerm(ARG1, export_debug_buf, 2048, 1);
   return TRUE;
 }
 

H/Yapproto.h

@@ -389,7 +389,7 @@ void	STD_PROTO(Yap_InitUserBacks,(void));
 /* utilpreds.c */
 Term	STD_PROTO(Yap_CopyTerm,(Term));
 int	STD_PROTO(Yap_Variant,(Term, Term));
-size_t	STD_PROTO(Yap_ExportTerm,(Term, char *, size_t));
+size_t	STD_PROTO(Yap_ExportTerm,(Term, char *, size_t, UInt));
 Term	STD_PROTO(Yap_ImportTerm,(char *));
 int	STD_PROTO(Yap_IsListTerm,(Term));
 Term	STD_PROTO(Yap_CopyTermNoShare,(Term));

library/dialect/swi/fli/swi.c

@@ -1853,7 +1853,7 @@ PL_record_external
   while(TRUE) {
     if (!(s = Yap_AllocCodeSpace(len)))
       return NULL;
-    if ((nsz = Yap_ExportTerm(t, s, len))) {
+    if ((nsz = Yap_ExportTerm(t, s, len, 0))) {
       *sz = nsz;
       return s;
     } else {