1 /*************************************************************************
2 * *
3 * YAP Prolog *
4 * *
5 * Yap Prolog was developed at NCCUP - Universidade do Porto *
6 * *
7 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8 * *
9 **************************************************************************
10 * *
11 * File: utilpreds.c *
12 * Last rev: 4/03/88 *
13 * mods: *
14 * comments: new utility predicates for YAP *
15 * *
16 *************************************************************************/
17 #ifdef SCCS
18 static char SccsId[] = "@(#)utilpreds.c 1.3";
19 #endif
20
21 #include "Yap.h"
22 #include "clause.h"
23 #include "YapHeap.h"
24 #include "yapio.h"
25 #include "eval.h"
26 #include "attvar.h"
27 #ifdef HAVE_STRING_H
28 #include "string.h"
29 #endif
30
31 typedef struct {
32 Term old_var;
33 Term new_var;
34 } *vcell;
35
36
37 STATIC_PROTO(int copy_complex_term, (CELL *, CELL *, int, int, CELL *, CELL *));
38 STATIC_PROTO(CELL vars_in_complex_term, (CELL *, CELL *, Term));
39 STATIC_PROTO(Int p_non_singletons_in_term, (void));
40 STATIC_PROTO(CELL non_singletons_in_complex_term, (CELL *, CELL *));
41 STATIC_PROTO(Int p_variables_in_term, (void));
42 STATIC_PROTO(Int ground_complex_term, (CELL *, CELL *));
43 STATIC_PROTO(Int p_ground, (void));
44 STATIC_PROTO(Int p_copy_term, (void));
45 STATIC_PROTO(Int var_in_complex_term, (CELL *, CELL *, Term));
46
47 #ifdef DEBUG
48 STATIC_PROTO(Int p_force_trail_expansion, (void));
49 #endif /* DEBUG */
50
51 static inline void
clean_tr(tr_fr_ptr TR0)52 clean_tr(tr_fr_ptr TR0) {
53 if (TR != TR0) {
54 do {
55 Term p = TrailTerm(--TR);
56 RESET_VARIABLE(p);
57 } while (TR != TR0);
58 }
59 }
60
61 static inline void
clean_dirty_tr(tr_fr_ptr TR0)62 clean_dirty_tr(tr_fr_ptr TR0) {
63 if (TR != TR0) {
64 tr_fr_ptr pt = TR0;
65
66 do {
67 Term p = TrailTerm(pt++);
68 RESET_VARIABLE(p);
69 } while (pt != TR);
70 TR = TR0;
71 }
72 }
73
74 static UInt
big2arena_sz(CELL * arena_base)75 big2arena_sz(CELL *arena_base)
76 {
77 return ((MP_INT*)(arena_base+2))->_mp_alloc + (sizeof(MP_INT) + sizeof(Functor)+2*sizeof(CELL))/sizeof(CELL);
78 }
79
80 /* pointer to top of an arena */
81 static inline CELL *
ArenaLimit(Term arena)82 ArenaLimit(Term arena)
83 {
84 CELL *arena_base = RepAppl(arena);
85 UInt sz = big2arena_sz(arena_base);
86 return arena_base+sz;
87 }
88
89 /* pointer to top of an arena */
90 static inline CELL *
ArenaPt(Term arena)91 ArenaPt(Term arena)
92 {
93 return (CELL *)RepAppl(arena);
94 }
95
96 static int
copy_complex_term(CELL * pt0,CELL * pt0_end,int share,int newattvs,CELL * ptf,CELL * HLow)97 copy_complex_term(CELL *pt0, CELL *pt0_end, int share, int newattvs, CELL *ptf, CELL *HLow)
98 {
99
100 struct cp_frame *to_visit0, *to_visit = (struct cp_frame *)Yap_PreAllocCodeSpace();
101 CELL *HB0 = HB;
102 tr_fr_ptr TR0 = TR;
103 int ground = TRUE;
104 #ifdef COROUTINING
105 CELL *dvarsmin = NULL, *dvarsmax=NULL;
106 #endif
107
108 HB = HLow;
109 to_visit0 = to_visit;
110 loop:
111 while (pt0 < pt0_end) {
112 register CELL d0;
113 register CELL *ptd0;
114 ++ pt0;
115 ptd0 = pt0;
116 d0 = *ptd0;
117 deref_head(d0, copy_term_unk);
118 copy_term_nvar:
119 {
120 if (IsPairTerm(d0)) {
121 CELL *ap2 = RepPair(d0);
122 if (ap2 >= HB && ap2 < H) {
123 /* If this is newer than the current term, just reuse */
124 *ptf++ = d0;
125 continue;
126 }
127 *ptf = AbsPair(H);
128 ptf++;
129 #ifdef RATIONAL_TREES
130 if (to_visit+1 >= (struct cp_frame *)AuxSp) {
131 goto heap_overflow;
132 }
133 to_visit->start_cp = pt0;
134 to_visit->end_cp = pt0_end;
135 to_visit->to = ptf;
136 to_visit->oldv = *pt0;
137 to_visit->ground = ground;
138 /* fool the system into thinking we had a variable there */
139 *pt0 = AbsPair(H);
140 to_visit ++;
141 #else
142 if (pt0 < pt0_end) {
143 if (to_visit+1 >= (struct cp_frame *)AuxSp) {
144 goto heap_overflow;
145 }
146 to_visit->start_cp = pt0;
147 to_visit->end_cp = pt0_end;
148 to_visit->to = ptf;
149 to_visit->ground = ground;
150 to_visit ++;
151 }
152 #endif
153 ground = TRUE;
154 pt0 = ap2 - 1;
155 pt0_end = ap2 + 1;
156 ptf = H;
157 H += 2;
158 if (H > ASP - 2048) {
159 goto overflow;
160 }
161 } else if (IsApplTerm(d0)) {
162 register Functor f;
163 register CELL *ap2;
164 /* store the terms to visit */
165 ap2 = RepAppl(d0);
166 if (ap2 >= HB && ap2 <= H) {
167 /* If this is newer than the current term, just reuse */
168 *ptf++ = d0;
169 continue;
170 }
171 f = (Functor)(*ap2);
172
173 if (IsExtensionFunctor(f)) {
174 #if defined(YAPOR) || defined(THREADS)
175 if (f == FunctorDBRef) {
176 DBRef entryref = DBRefOfTerm(d0);
177 if (entryref->Flags & LogUpdMask) {
178 LogUpdClause *luclause = (LogUpdClause *)entryref;
179 PELOCK(100,luclause->ClPred);
180 UNLOCK(luclause->ClPred->PELock);
181 } else {
182 LOCK(entryref->lock);
183 TRAIL_REF(entryref); /* So that fail will erase it */
184 INC_DBREF_COUNT(entryref);
185 UNLOCK(entryref->lock);
186 }
187 *ptf++ = d0; /* you can just copy other extensions. */
188 } else
189 #endif
190 if (!share) {
191 UInt sz;
192
193 *ptf++ = AbsAppl(H); /* you can just copy other extensions. */
194 /* make sure to copy floats */
195 if (f== FunctorDouble) {
196 sz = sizeof(Float)/sizeof(CELL)+2;
197 } else if (f== FunctorLongInt) {
198 sz = 3;
199 } else {
200 CELL *pt = ap2+1;
201 sz = 2+sizeof(MP_INT)+(((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
202 }
203 if (H+sz > ASP - 2048) {
204 goto overflow;
205 }
206 memcpy((void *)H, (void *)ap2, sz*sizeof(CELL));
207 H += sz;
208 } else {
209 *ptf++ = d0; /* you can just copy other extensions. */
210 }
211 continue;
212 }
213 *ptf = AbsAppl(H);
214 ptf++;
215 /* store the terms to visit */
216 #ifdef RATIONAL_TREES
217 if (to_visit+1 >= (struct cp_frame *)AuxSp) {
218 goto heap_overflow;
219 }
220 to_visit->start_cp = pt0;
221 to_visit->end_cp = pt0_end;
222 to_visit->to = ptf;
223 to_visit->oldv = *pt0;
224 to_visit->ground = ground;
225 /* fool the system into thinking we had a variable there */
226 *pt0 = AbsAppl(H);
227 to_visit ++;
228 #else
229 if (pt0 < pt0_end) {
230 if (to_visit+1 >= (struct cp_frame *)AuxSp) {
231 goto heap_overflow;
232 }
233 to_visit->start_cp = pt0;
234 to_visit->end_cp = pt0_end;
235 to_visit->to = ptf;
236 to_visit->ground = ground;
237 to_visit ++;
238 }
239 #endif
240 ground = (f != FunctorMutable);
241 d0 = ArityOfFunctor(f);
242 pt0 = ap2;
243 pt0_end = ap2 + d0;
244 /* store the functor for the new term */
245 H[0] = (CELL)f;
246 ptf = H+1;
247 H += 1+d0;
248 if (H > ASP - 2048) {
249 goto overflow;
250 }
251 } else {
252 /* just copy atoms or integers */
253 *ptf++ = d0;
254 }
255 continue;
256 }
257
258 derefa_body(d0, ptd0, copy_term_unk, copy_term_nvar);
259 ground = FALSE;
260 if (ptd0 >= HLow && ptd0 < H) {
261 /* we have already found this cell */
262 *ptf++ = (CELL) ptd0;
263 } else {
264 #if COROUTINING
265 if (newattvs && IsAttachedTerm((CELL)ptd0)) {
266 /* if unbound, call the standard copy term routine */
267 struct cp_frame *bp;
268
269 if (IN_BETWEEN(dvarsmin, ptd0, dvarsmax)) {
270 *ptf++ = (CELL) ptd0;
271 } else {
272 CELL new;
273 /* ugly hack to ensure we have enough space for our new attributed variables */
274 CELL *max = ArenaLimit(GlobalArena);
275 CELL *base = ArenaPt(GlobalArena);
276
277 if (base+2*sizeof(attvar_record)/sizeof(CELL) > max-1024) {
278 goto arena_overflow;
279 }
280 bp = to_visit;
281 if (!attas[ExtFromCell(ptd0)].copy_term_op(ptd0, &bp, ptf)) {
282 goto overflow;
283 }
284 to_visit = bp;
285 new = *ptf;
286 Bind(ptd0, new);
287 if (dvarsmin == NULL) {
288 dvarsmin = CellPtr(new);
289 } else {
290 *dvarsmax = (CELL)(CellPtr(new)+1);
291 }
292 dvarsmax = CellPtr(new)+1;
293 ptf++;
294 }
295 } else {
296 #endif
297 /* first time we met this term */
298 RESET_VARIABLE(ptf);
299 if (TR > (tr_fr_ptr)Yap_TrailTop - 256) {
300 /* Trail overflow */
301 if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
302 goto trail_overflow;
303 }
304 }
305 Bind(ptd0, (CELL)ptf);
306 ptf++;
307 #ifdef COROUTINING
308 }
309 #endif
310 }
311 }
312 /* Do we still have compound terms to visit */
313 if (to_visit > to_visit0) {
314 to_visit --;
315 if (ground && share) {
316 CELL old = to_visit->oldv;
317 CELL *newp = to_visit->to-1;
318 CELL new = *newp;
319
320 *newp = old;
321 if (IsApplTerm(new))
322 H = RepAppl(new);
323 else
324 H = RepPair(new);
325 }
326 pt0 = to_visit->start_cp;
327 pt0_end = to_visit->end_cp;
328 ptf = to_visit->to;
329 #ifdef RATIONAL_TREES
330 *pt0 = to_visit->oldv;
331 #endif
332 ground = (ground && to_visit->ground);
333 goto loop;
334 }
335
336 /* restore our nice, friendly, term to its original state */
337 clean_dirty_tr(TR0);
338 close_attvar_chain(dvarsmin, dvarsmax);
339 HB = HB0;
340 return ground;
341
342 overflow:
343 /* oops, we're in trouble */
344 H = HLow;
345 /* we've done it */
346 /* restore our nice, friendly, term to its original state */
347 HB = HB0;
348 #ifdef RATIONAL_TREES
349 while (to_visit > to_visit0) {
350 to_visit --;
351 pt0 = to_visit->start_cp;
352 pt0_end = to_visit->end_cp;
353 ptf = to_visit->to;
354 *pt0 = to_visit->oldv;
355 }
356 #endif
357 reset_trail(TR0);
358 /* follow chain of multi-assigned variables */
359 reset_attvars(dvarsmin, dvarsmax);
360 return -1;
361
362 trail_overflow:
363 /* oops, we're in trouble */
364 H = HLow;
365 /* we've done it */
366 /* restore our nice, friendly, term to its original state */
367 HB = HB0;
368 #ifdef RATIONAL_TREES
369 while (to_visit > to_visit0) {
370 to_visit --;
371 pt0 = to_visit->start_cp;
372 pt0_end = to_visit->end_cp;
373 ptf = to_visit->to;
374 *pt0 = to_visit->oldv;
375 }
376 #endif
377 {
378 tr_fr_ptr oTR = TR;
379 reset_trail(TR0);
380 reset_attvars(dvarsmin, dvarsmax);
381 if (!Yap_growtrail((oTR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
382 return -4;
383 }
384 return -2;
385 }
386
387 heap_overflow:
388 /* oops, we're in trouble */
389 H = HLow;
390 /* we've done it */
391 /* restore our nice, friendly, term to its original state */
392 HB = HB0;
393 #ifdef RATIONAL_TREES
394 while (to_visit > to_visit0) {
395 to_visit --;
396 pt0 = to_visit->start_cp;
397 pt0_end = to_visit->end_cp;
398 ptf = to_visit->to;
399 *pt0 = to_visit->oldv;
400 }
401 #endif
402 reset_trail(TR0);
403 reset_attvars(dvarsmin, dvarsmax);
404 Yap_Error_Size = (ADDR)AuxSp-(ADDR)to_visit0;
405 return -3;
406
407 arena_overflow:
408 /* oops, we're in trouble */
409 H = HLow;
410 /* we've done it */
411 /* restore our nice, friendly, term to its original state */
412 HB = HB0;
413 #ifdef RATIONAL_TREES
414 while (to_visit > to_visit0) {
415 to_visit --;
416 pt0 = to_visit->start_cp;
417 pt0_end = to_visit->end_cp;
418 ptf = to_visit->to;
419 *pt0 = to_visit->oldv;
420 }
421 #endif
422 reset_trail(TR0);
423 reset_attvars(dvarsmin, dvarsmax);
424 Yap_Error_Size = (ADDR)AuxSp-(ADDR)to_visit0;
425 return -5;
426 }
427
428
429 static Term
handle_cp_overflow(int res,tr_fr_ptr TR0,UInt arity,Term t)430 handle_cp_overflow(int res, tr_fr_ptr TR0, UInt arity, Term t)
431 {
432 XREGS[arity+1] = t;
433 switch(res) {
434 case -1:
435 if (!Yap_gcl((ASP-H)*sizeof(CELL), arity+1, ENV, gc_P(P,CP))) {
436 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
437 return 0L;
438 }
439 return Deref(XREGS[arity+1]);
440 case -2:
441 return Deref(XREGS[arity+1]);
442 case -3:
443 {
444 UInt size = Yap_Error_Size;
445 Yap_Error_Size = 0L;
446 if (size > 4*1024*1024)
447 size = 4*1024*1024;
448 if (!Yap_ExpandPreAllocCodeSpace(size, NULL, TRUE)) {
449 Yap_Error(OUT_OF_AUXSPACE_ERROR, TermNil, Yap_ErrorMessage);
450 return 0L;
451 }
452 }
453 return Deref(XREGS[arity+1]);
454 case -4:
455 if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), FALSE)) {
456 Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, Yap_ErrorMessage);
457 return 0L;
458 }
459 return Deref(XREGS[arity+1]);
460 case -5:
461 if (!Yap_GrowGlobalArena(64 *1024)) {
462 Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
463 return 0L;
464 }
465 return Deref(XREGS[arity+1]);
466 default:
467 return 0L;
468 }
469 }
470
471 static Term
CopyTerm(Term inp,UInt arity,int share,int newattvs)472 CopyTerm(Term inp, UInt arity, int share, int newattvs) {
473 Term t = Deref(inp);
474 tr_fr_ptr TR0 = TR;
475
476 if (IsVarTerm(t)) {
477 #if COROUTINING
478 if (newattvs && IsAttachedTerm(t)) {
479 CELL *Hi;
480 int res;
481 restart_attached:
482
483 *H = t;
484 Hi = H+1;
485 H += 2;
486 if ((res = copy_complex_term(Hi-2, Hi-1, share, newattvs, Hi, Hi)) < 0) {
487 H = Hi-1;
488 if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L)
489 return FALSE;
490 goto restart_attached;
491 }
492 return Hi[0];
493 }
494 #endif
495 return MkVarTerm();
496 } else if (IsPrimitiveTerm(t)) {
497 return t;
498 } else if (IsPairTerm(t)) {
499 Term tf;
500 CELL *ap;
501 CELL *Hi;
502
503 restart_list:
504 ap = RepPair(t);
505 Hi = H;
506 tf = AbsPair(H);
507 H += 2;
508 {
509 int res;
510 if ((res = copy_complex_term(ap-1, ap+1, share, newattvs, Hi, Hi)) < 0) {
511 H = Hi;
512 if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L)
513 return FALSE;
514 goto restart_list;
515 } else if (res && share) {
516 H = Hi;
517 return t;
518 }
519 }
520 return tf;
521 } else {
522 Functor f = FunctorOfTerm(t);
523 Term tf;
524 CELL *HB0;
525 CELL *ap;
526
527 restart_appl:
528 f = FunctorOfTerm(t);
529 HB0 = H;
530 ap = RepAppl(t);
531 tf = AbsAppl(H);
532 H[0] = (CELL)f;
533 H += 1+ArityOfFunctor(f);
534 if (H > ASP-128) {
535 H = HB0;
536 if ((t = handle_cp_overflow(-1, TR0, arity, t))== 0L)
537 return FALSE;
538 goto restart_appl;
539 } else {
540 int res;
541
542 if ((res = copy_complex_term(ap, ap+ArityOfFunctor(f), share, newattvs, HB0+1, HB0)) < 0) {
543 H = HB0;
544 if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L)
545 return FALSE;
546 goto restart_appl;
547 } else if (res && share && FunctorOfTerm(t) != FunctorMutable) {
548 H = HB0;
549 return t;
550 }
551 }
552 return tf;
553 }
554 }
555
556 Term
Yap_CopyTerm(Term inp)557 Yap_CopyTerm(Term inp) {
558 return CopyTerm(inp, 0, TRUE, TRUE);
559 }
560
561 Term
Yap_CopyTermNoShare(Term inp)562 Yap_CopyTermNoShare(Term inp) {
563 return CopyTerm(inp, 0, FALSE, FALSE);
564 }
565
566 static Int
p_copy_term(void)567 p_copy_term(void) /* copy term t to a new instance */
568 {
569 Term t = CopyTerm(ARG1, 2, TRUE, TRUE);
570 if (t == 0L)
571 return FALSE;
572 /* be careful, there may be a stack shift here */
573 return Yap_unify(ARG2,t);
574 }
575
576 static Int
p_duplicate_term(void)577 p_duplicate_term(void) /* copy term t to a new instance */
578 {
579 Term t = CopyTerm(ARG1, 2, FALSE, TRUE);
580 if (t == 0L)
581 return FALSE;
582 /* be careful, there may be a stack shift here */
583 return Yap_unify(ARG2,t);
584 }
585
586 static Int
p_copy_term_no_delays(void)587 p_copy_term_no_delays(void) /* copy term t to a new instance */
588 {
589 Term t = CopyTerm(ARG1, 2, TRUE, FALSE);
590 if (t == 0L) {
591 return FALSE;
592 }
593 /* be careful, there may be a stack shift here */
594 return(Yap_unify(ARG2,t));
595 }
596
597 /*
598 FAST EXPORT ROUTINE. Export a Prolog term to something like:
599
600 CELL 0: offset for start of term
601 CELL 1: size of actual term (to be copied to stack)
602 CELL 2: the original term (just for reference)
603
604 Atoms and functors:
605 - atoms are either:
606 0 and a char *string
607 -1 and a wchar_t *string
608 - functors are a CELL with arity and a string.
609
610 Compiled Term.
611
612 */
613
614 static inline
CellDifH(CELL * hptr,CELL * hlow)615 CELL *CellDifH(CELL *hptr, CELL *hlow)
616 {
617 return (CELL *)((char *)hptr-(char *)hlow);
618 }
619
620 #define AdjustSizeAtom(X) ((char *)(((CELL)X+7) & (CELL)(-8)))
621
622 static inline
export_atom(Atom at,char ** hpp,size_t len)623 Atom export_atom(Atom at, char **hpp, size_t len)
624 {
625 char *ptr, *p0;
626 size_t sz;
627
628 ptr = *hpp;
629 ptr = AdjustSizeAtom(ptr);
630
631 p0 = ptr;
632 if (IsWideAtom(at)) {
633 wchar_t *wptr = (wchar_t *)ptr;
634 *wptr++ = -1;
635 sz = wcslen(RepAtom(at)->WStrOfAE);
636 if (sizeof(wchar_t)*(sz+1) >= len)
637 return (Atom)NULL;
638 wcsncpy(wptr, RepAtom(at)->WStrOfAE, len);
639 *hpp = (char *)(wptr+(sz+1));
640 } else {
641 *ptr++ = 0;
642 sz = strlen(RepAtom(at)->StrOfAE);
643 if (sz +1 >= len)
644 return (Atom)NULL;
645 strcpy(ptr, RepAtom(at)->StrOfAE);
646 *hpp = ptr+(sz+1);
647 }
648 ptr += sz;
649 return (Atom)p0;
650 }
651
652 static inline
export_functor(Functor f,char ** hpp,size_t len)653 Functor export_functor(Functor f, char **hpp, size_t len)
654 {
655 CELL *hptr = (UInt *)AdjustSizeAtom(*hpp);
656 UInt arity = ArityOfFunctor(f);
657 if (2*sizeof(CELL) >= len)
658 return (Functor)NULL;
659 hptr[0] = arity;
660 *hpp = (char *)(hptr+1);
661 if (!export_atom(NameOfFunctor(f), hpp, len))
662 return 0L;
663 return (Functor)hptr;
664 }
665
666 #define export_derefa_body(D,A,LabelUnk,LabelNonVar) \
667 do { \
668 if ((CELL *)(D) < CellDifH(H,HLow)) { (A) = (CELL *)(D); break; } \
669 (A) = (CELL *)(D); \
670 (D) = *(CELL *)(D); \
671 if(!IsVarTerm(D)) goto LabelNonVar; \
672 LabelUnk: ; \
673 } while (Unsigned(A) != (D))
674
675
676 static int
export_term_to_buffer(Term inpt,char * buf,char * bptr,CELL * t0,CELL * tf,size_t len)677 export_term_to_buffer(Term inpt, char *buf, char *bptr, CELL *t0 , CELL *tf, size_t len)
678 {
679 char *td = bptr;
680 CELL *bf = (CELL *)buf;
681 if (buf + len < (char *)(td + (tf-t0)))
682 return FALSE;
683 memcpy((void *)td, (void *)t0, (tf-t0)* sizeof(CELL));
684 bf[0] = (td-buf);
685 bf[1] = (tf-t0);
686 bf[2] = inpt;
687 return bf[0]+sizeof(CELL)*bf[1];
688 }
689
690
691 static int
export_complex_term(Term tf,CELL * pt0,CELL * pt0_end,char * buf,size_t len0,int newattvs,CELL * ptf,CELL * HLow)692 export_complex_term(Term tf, CELL *pt0, CELL *pt0_end, char * buf, size_t len0, int newattvs, CELL *ptf, CELL *HLow)
693 {
694
695 struct cp_frame *to_visit0, *to_visit = (struct cp_frame *)Yap_PreAllocCodeSpace();
696 CELL *HB0 = HB;
697 tr_fr_ptr TR0 = TR;
698 int ground = TRUE;
699 #ifdef COROUTINING
700 CELL *dvarsmin = NULL, *dvarsmax=NULL;
701 #endif
702 char *bptr = buf+ 3*sizeof(CELL);
703 size_t len = len0;
704
705 HB = HLow;
706 to_visit0 = to_visit;
707 loop:
708 while (pt0 < pt0_end) {
709 register CELL d0;
710 register CELL *ptd0;
711 ++ pt0;
712 ptd0 = pt0;
713 d0 = *ptd0;
714 deref_head(d0, export_term_unk);
715 export_term_nvar:
716 {
717 if (IsPairTerm(d0)) {
718 CELL *ap2 = RepPair(d0);
719 if (ap2 < CellDifH(H,HLow)) {
720 /* If this is newer than the current term, just reuse */
721 *ptf++ = d0;
722 continue;
723 }
724 *ptf = AbsPair(CellDifH(H,HLow));
725 ptf++;
726 #ifdef RATIONAL_TREES
727 if (to_visit+1 >= (struct cp_frame *)AuxSp) {
728 goto heap_overflow;
729 }
730 to_visit->start_cp = pt0;
731 to_visit->end_cp = pt0_end;
732 to_visit->to = ptf;
733 to_visit->oldv = *pt0;
734 to_visit->ground = ground;
735 /* fool the system into thinking we had a variable there */
736 *pt0 = AbsPair(CellDifH(H,HLow));
737 to_visit ++;
738 #else
739 if (pt0 < pt0_end) {
740 if (to_visit+1 >= (struct cp_frame *)AuxSp) {
741 goto heap_overflow;
742 }
743 to_visit->start_cp = pt0;
744 to_visit->end_cp = pt0_end;
745 to_visit->to = ptf;
746 to_visit->ground = ground;
747 to_visit ++;
748 }
749 #endif
750 pt0 = ap2 - 1;
751 pt0_end = ap2 + 1;
752 ptf = H;
753 H += 2;
754 if (H > ASP - 2048) {
755 goto overflow;
756 }
757 } else if (IsApplTerm(d0)) {
758 register Functor f;
759 register CELL *ap2;
760 /* store the terms to visit */
761 ap2 = RepAppl(d0);
762 if (ap2 < CellDifH(H,HLow)) {
763 /* If this is newer than the current term, just reuse */
764 *ptf++ = d0;
765 continue;
766 }
767 f = (Functor)(*ap2);
768
769 *ptf++ = AbsAppl(CellDifH(H,HLow));
770 if (IsExtensionFunctor(f)) {
771 UInt sz;
772
773 /* make sure to export floats */
774 if (f== FunctorDouble) {
775 sz = sizeof(Float)/sizeof(CELL)+2;
776 } else if (f== FunctorLongInt) {
777 sz = 3;
778 } else {
779 CELL *pt = ap2+1;
780 sz = 2+sizeof(MP_INT)+(((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
781 }
782 if (H+sz > ASP - 2048) {
783 goto overflow;
784 }
785 memcpy((void *)H, (void *)ap2, sz*sizeof(CELL));
786 H += sz;
787 continue;
788 }
789 /* store the terms to visit */
790 #ifdef RATIONAL_TREES
791 if (to_visit+1 >= (struct cp_frame *)AuxSp) {
792 goto heap_overflow;
793 }
794 to_visit->start_cp = pt0;
795 to_visit->end_cp = pt0_end;
796 to_visit->to = ptf;
797 to_visit->oldv = *pt0;
798 to_visit->ground = ground;
799 /* fool the system into thinking we had a variable there */
800 *pt0 = AbsAppl(H);
801 to_visit ++;
802 #else
803 if (pt0 < pt0_end) {
804 if (to_visit+1 >= (struct cp_frame *)AuxSp) {
805 goto heap_overflow;
806 }
807 to_visit->start_cp = pt0;
808 to_visit->end_cp = pt0_end;
809 to_visit->to = ptf;
810 to_visit->ground = ground;
811 to_visit ++;
812 }
813 #endif
814 ground = (f != FunctorMutable);
815 d0 = ArityOfFunctor(f);
816 pt0 = ap2;
817 pt0_end = ap2 + d0;
818 /* store the functor for the new term */
819 ptf = H+1;
820 H += 1+d0;
821 if (H > ASP - 2048) {
822 goto overflow;
823 }
824 ptf[-1] = (CELL)export_functor(f, &bptr, len);
825 len = len0 - (bptr-buf);
826 if (H > ASP - 2048) {
827 goto overflow;
828 }
829 } else {
830 if (IsAtomTerm(d0)) {
831 *ptf = MkAtomTerm(export_atom(AtomOfTerm(d0), &bptr, len));
832 ptf++;
833 len = len0 - (bptr-buf);
834 } else {
835 *ptf++ = d0;
836 }
837 }
838 continue;
839 }
840
841 export_derefa_body(d0, ptd0, export_term_unk, export_term_nvar);
842 ground = FALSE;
843 if (ptd0 < CellDifH(H,HLow)) {
844 /* we have already found this cell */
845 *ptf++ = (CELL) ptd0;
846 } else {
847 #if COROUTINING
848 if (newattvs && IsAttachedTerm((CELL)ptd0) && FALSE) {
849 /* if unbound, call the standard export term routine */
850 struct cp_frame *bp;
851
852 if (IN_BETWEEN(dvarsmin, ptd0, dvarsmax)) {
853 *ptf++ = (CELL) ptd0;
854 } else {
855 CELL new;
856
857 bp = to_visit;
858 if (!attas[ExtFromCell(ptd0)].copy_term_op(ptd0, &bp, ptf)) {
859 goto overflow;
860 }
861 to_visit = bp;
862 new = *ptf;
863 Bind(ptd0, new);
864 if (dvarsmin == NULL) {
865 dvarsmin = CellPtr(new);
866 } else {
867 *dvarsmax = (CELL)(CellPtr(new)+1);
868 }
869 dvarsmax = CellPtr(new)+1;
870 ptf++;
871 }
872 } else {
873 #endif
874 /* first time we met this term */
875 *ptf = (CELL)CellDifH(ptf,HLow);
876 if (TR > (tr_fr_ptr)Yap_TrailTop - 256) {
877 /* Trail overflow */
878 if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
879 goto trail_overflow;
880 }
881 }
882 Bind(ptd0, (CELL)ptf);
883 ptf++;
884 #ifdef COROUTINING
885 }
886 #endif
887 }
888 }
889 /* Do we still have compound terms to visit */
890 if (to_visit > to_visit0) {
891 to_visit --;
892 pt0 = to_visit->start_cp;
893 pt0_end = to_visit->end_cp;
894 ptf = to_visit->to;
895 #ifdef RATIONAL_TREES
896 *pt0 = to_visit->oldv;
897 #endif
898 ground = (ground && to_visit->ground);
899 goto loop;
900 }
901
902 /* restore our nice, friendly, term to its original state */
903 clean_dirty_tr(TR0);
904 close_attvar_chain(dvarsmin, dvarsmax);
905 HB = HB0;
906 return export_term_to_buffer(tf, buf, bptr, HLow, H, len0);
907
908 overflow:
909 /* oops, we're in trouble */
910 H = HLow;
911 /* we've done it */
912 /* restore our nice, friendly, term to its original state */
913 HB = HB0;
914 #ifdef RATIONAL_TREES
915 while (to_visit > to_visit0) {
916 to_visit --;
917 pt0 = to_visit->start_cp;
918 pt0_end = to_visit->end_cp;
919 ptf = to_visit->to;
920 *pt0 = to_visit->oldv;
921 }
922 #endif
923 reset_trail(TR0);
924 /* follow chain of multi-assigned variables */
925 reset_attvars(dvarsmin, dvarsmax);
926 return -1;
927
928 trail_overflow:
929 /* oops, we're in trouble */
930 H = HLow;
931 /* we've done it */
932 /* restore our nice, friendly, term to its original state */
933 HB = HB0;
934 #ifdef RATIONAL_TREES
935 while (to_visit > to_visit0) {
936 to_visit --;
937 pt0 = to_visit->start_cp;
938 pt0_end = to_visit->end_cp;
939 ptf = to_visit->to;
940 *pt0 = to_visit->oldv;
941 }
942 #endif
943 {
944 tr_fr_ptr oTR = TR;
945 reset_trail(TR0);
946 reset_attvars(dvarsmin, dvarsmax);
947 if (!Yap_growtrail((oTR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
948 return -4;
949 }
950 return -2;
951 }
952
953 heap_overflow:
954 /* oops, we're in trouble */
955 H = HLow;
956 /* we've done it */
957 /* restore our nice, friendly, term to its original state */
958 HB = HB0;
959 #ifdef RATIONAL_TREES
960 while (to_visit > to_visit0) {
961 to_visit --;
962 pt0 = to_visit->start_cp;
963 pt0_end = to_visit->end_cp;
964 ptf = to_visit->to;
965 *pt0 = to_visit->oldv;
966 }
967 #endif
968 reset_trail(TR0);
969 reset_attvars(dvarsmin, dvarsmax);
970 Yap_Error_Size = (ADDR)AuxSp-(ADDR)to_visit0;
971 return -3;
972 }
973
974 static int
ExportTerm(Term inp,char * buf,size_t len,UInt arity,int newattvs)975 ExportTerm(Term inp, char * buf, size_t len, UInt arity, int newattvs) {
976 Term t = Deref(inp);
977 tr_fr_ptr TR0 = TR;
978 int res;
979 CELL *Hi;
980
981 restart:
982 Hi = H;
983 if ((res = export_complex_term(inp, &t-1, &t, buf, len, newattvs, Hi, Hi)) < 0) {
984 H = Hi;
985 if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L)
986 return FALSE;
987 goto restart;
988 }
989 return res;
990 }
991
992 int
Yap_ExportTerm(Term inp,char * buf,size_t len)993 Yap_ExportTerm(Term inp, char * buf, size_t len) {
994 return ExportTerm(inp, buf, len, 0, TRUE);
995 }
996
997
998 static CELL *
ShiftPtr(CELL t,char * base)999 ShiftPtr(CELL t, char *base)
1000 {
1001 return (CELL *)(base+t);
1002 }
1003
1004 static Atom
AddAtom(Atom t)1005 AddAtom(Atom t)
1006 {
1007 char *s = (char *)t;
1008 if (!*s) {
1009 return Yap_LookupAtom(s+1);
1010 } else {
1011 wchar_t *w = (wchar_t *)s;
1012 return Yap_LookupWideAtom(w+1);
1013 }
1014 }
1015
1016 static UInt
FetchFunctor(CELL * pt)1017 FetchFunctor(CELL *pt)
1018 {
1019 CELL *ptr = (CELL *)(*pt);
1020 // do arity first
1021 UInt arity = *ptr;
1022 char *name;
1023 // and then an atom
1024 ++ptr;
1025 name = (char *)ptr;
1026 name = AdjustSizeAtom(name);
1027 *pt = (CELL)Yap_MkFunctor(AddAtom((Atom)name), arity);
1028 return arity;
1029 }
1030
1031
1032 static CELL *import_compound(CELL *hp, char *abase, CELL *amax);
1033 static CELL *import_pair(CELL *hp, char *abase, CELL *amax);
1034
1035 static CELL *
import_arg(CELL * hp,char * abase,CELL * amax)1036 import_arg(CELL *hp, char *abase, CELL *amax)
1037 {
1038 Term t = *hp;
1039 if (IsVarTerm(t)) {
1040 hp[0] = (CELL)ShiftPtr(t, abase);
1041 } else if (IsAtomTerm(t)) {
1042 hp[0] = MkAtomTerm(AddAtom(AtomOfTerm(t)));
1043 } else if (IsPairTerm(t)) {
1044 CELL *newp = ShiftPtr((CELL)RepPair(t), abase);
1045 hp[0] = AbsPair(newp);
1046 if (newp > amax) {
1047 amax = import_pair(newp, abase, newp);
1048 }
1049 } else {
1050 CELL *newp = ShiftPtr((CELL)RepAppl(t), abase);
1051 hp[0] = AbsAppl(newp);
1052 if (newp > amax) {
1053 amax = import_compound(newp, abase, newp);
1054 }
1055 }
1056 return amax;
1057 }
1058
1059 static CELL *
import_compound(CELL * hp,char * abase,CELL * amax)1060 import_compound(CELL *hp, char *abase, CELL *amax)
1061 {
1062 Functor f = (Functor)*hp;
1063 UInt ar, i;
1064
1065 if (IsExtensionFunctor(f))
1066 return amax;
1067 ar = FetchFunctor(hp);
1068 for (i=1; i<=ar; i++) {
1069 amax = import_arg(hp+i, abase, amax);
1070 }
1071 return amax;
1072 }
1073
1074 static CELL *
import_pair(CELL * hp,char * abase,CELL * amax)1075 import_pair(CELL *hp, char *abase, CELL *amax)
1076 {
1077 amax = import_arg(hp, abase, amax);
1078 amax = import_arg(hp+1, abase, amax);
1079 return amax;
1080 }
1081
1082 Term
Yap_ImportTerm(char * buf)1083 Yap_ImportTerm(char * buf) {
1084 CELL *bc = (CELL *)buf;
1085 size_t sz = bc[1];
1086 Term tinp, tret;
1087
1088 tinp = bc[2];
1089 if (IsVarTerm(tinp))
1090 return MkVarTerm();
1091 if (IsAtomOrIntTerm(tinp)) {
1092 if (IsAtomTerm(tinp)) {
1093 char *pt = AdjustSizeAtom((char *)(bc+3));
1094 return MkAtomTerm(Yap_LookupAtom(pt));
1095 } else
1096 return tinp;
1097 }
1098 if (H + sz > ASP)
1099 return (Term)0;
1100 memcpy(H, buf+bc[0], sizeof(CELL)*sz);
1101 if (IsApplTerm(tinp)) {
1102 tret = AbsAppl(H);
1103 import_compound(H, (char *)H, H);
1104 } else {
1105 tret = AbsPair(H);
1106 import_pair(H, (char *)H, H);
1107 }
1108 H += sz;
1109 return tret;
1110 }
1111
1112 #define DEBUG_IMPORT 1
1113
1114 #if DEBUG_IMPORT
1115
1116 static char export_debug_buf[2048];
1117
1118 static Int
p_export_term(void)1119 p_export_term(void)
1120 {
1121 Yap_ExportTerm(ARG1, export_debug_buf, 2048);
1122 return TRUE;
1123 }
1124
1125 static Int
p_import_term(void)1126 p_import_term(void)
1127 {
1128 return Yap_unify(ARG1,Yap_ImportTerm(export_debug_buf));
1129 }
1130 #endif
1131
1132
vars_in_complex_term(register CELL * pt0,register CELL * pt0_end,Term inp)1133 static Term vars_in_complex_term(register CELL *pt0, register CELL *pt0_end, Term inp)
1134 {
1135
1136 register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
1137 register tr_fr_ptr TR0 = TR;
1138 CELL *InitialH = H;
1139 CELL output = AbsPair(H);
1140
1141 to_visit0 = to_visit;
1142 loop:
1143 while (pt0 < pt0_end) {
1144 register CELL d0;
1145 register CELL *ptd0;
1146 ++ pt0;
1147 ptd0 = pt0;
1148 d0 = *ptd0;
1149 deref_head(d0, vars_in_term_unk);
1150 vars_in_term_nvar:
1151 {
1152 if (IsPairTerm(d0)) {
1153 if (to_visit + 1024 >= (CELL **)AuxSp) {
1154 goto aux_overflow;
1155 }
1156 #ifdef RATIONAL_TREES
1157 to_visit[0] = pt0;
1158 to_visit[1] = pt0_end;
1159 to_visit[2] = (CELL *)*pt0;
1160 to_visit += 3;
1161 *pt0 = TermNil;
1162 #else
1163 if (pt0 < pt0_end) {
1164 to_visit[0] = pt0;
1165 to_visit[1] = pt0_end;
1166 to_visit += 2;
1167 }
1168 #endif
1169 pt0 = RepPair(d0) - 1;
1170 pt0_end = RepPair(d0) + 1;
1171 } else if (IsApplTerm(d0)) {
1172 register Functor f;
1173 register CELL *ap2;
1174 /* store the terms to visit */
1175 ap2 = RepAppl(d0);
1176 f = (Functor)(*ap2);
1177 if (IsExtensionFunctor(f)) {
1178 continue;
1179 }
1180 /* store the terms to visit */
1181 if (to_visit + 1024 >= (CELL **)AuxSp) {
1182 goto aux_overflow;
1183 }
1184 #ifdef RATIONAL_TREES
1185 to_visit[0] = pt0;
1186 to_visit[1] = pt0_end;
1187 to_visit[2] = (CELL *)*pt0;
1188 to_visit += 3;
1189 *pt0 = TermNil;
1190 #else
1191 if (pt0 < pt0_end) {
1192 to_visit[0] = pt0;
1193 to_visit[1] = pt0_end;
1194 to_visit += 2;
1195 }
1196 #endif
1197 d0 = ArityOfFunctor(f);
1198 pt0 = ap2;
1199 pt0_end = ap2 + d0;
1200 }
1201 continue;
1202 }
1203
1204
1205 derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar);
1206 /* do or pt2 are unbound */
1207 *ptd0 = TermNil;
1208 /* leave an empty slot to fill in later */
1209 if (H+1024 > ASP) {
1210 goto global_overflow;
1211 }
1212 H[1] = AbsPair(H+2);
1213 H += 2;
1214 H[-2] = (CELL)ptd0;
1215 /* next make sure noone will see this as a variable again */
1216 if (TR > (tr_fr_ptr)Yap_TrailTop - 256) {
1217 /* Trail overflow */
1218 if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
1219 goto trail_overflow;
1220 }
1221 }
1222 TrailTerm(TR++) = (CELL)ptd0;
1223 }
1224 /* Do we still have compound terms to visit */
1225 if (to_visit > to_visit0) {
1226 #ifdef RATIONAL_TREES
1227 to_visit -= 3;
1228 pt0 = to_visit[0];
1229 pt0_end = to_visit[1];
1230 *pt0 = (CELL)to_visit[2];
1231 #else
1232 to_visit -= 2;
1233 pt0 = to_visit[0];
1234 pt0_end = to_visit[1];
1235 #endif
1236 goto loop;
1237 }
1238
1239 clean_tr(TR0);
1240 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1241 if (H != InitialH) {
1242 /* close the list */
1243 Term t2 = Deref(inp);
1244 if (IsVarTerm(t2)) {
1245 RESET_VARIABLE(H-1);
1246 Yap_unify((CELL)(H-1),ARG2);
1247 } else {
1248 H[-1] = t2; /* don't need to trail */
1249 }
1250 return(output);
1251 } else {
1252 return(inp);
1253 }
1254
1255 trail_overflow:
1256 #ifdef RATIONAL_TREES
1257 while (to_visit > to_visit0) {
1258 to_visit -= 3;
1259 pt0 = to_visit[0];
1260 *pt0 = (CELL)to_visit[2];
1261 }
1262 #endif
1263 Yap_Error_TYPE = OUT_OF_TRAIL_ERROR;
1264 Yap_Error_Size = (TR-TR0)*sizeof(tr_fr_ptr *);
1265 clean_tr(TR0);
1266 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1267 H = InitialH;
1268 return 0L;
1269
1270 aux_overflow:
1271 Yap_Error_Size = (to_visit-to_visit0)*sizeof(CELL **);
1272 #ifdef RATIONAL_TREES
1273 while (to_visit > to_visit0) {
1274 to_visit -= 3;
1275 pt0 = to_visit[0];
1276 *pt0 = (CELL)to_visit[2];
1277 }
1278 #endif
1279 Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
1280 clean_tr(TR0);
1281 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1282 H = InitialH;
1283 return 0L;
1284
1285 global_overflow:
1286 #ifdef RATIONAL_TREES
1287 while (to_visit > to_visit0) {
1288 to_visit -= 3;
1289 pt0 = to_visit[0];
1290 *pt0 = (CELL)to_visit[2];
1291 }
1292 #endif
1293 clean_tr(TR0);
1294 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1295 H = InitialH;
1296 Yap_Error_TYPE = OUT_OF_STACK_ERROR;
1297 Yap_Error_Size = (ASP-H)*sizeof(CELL);
1298 return 0L;
1299
1300 }
1301
1302 static int
expand_vts(void)1303 expand_vts(void)
1304 {
1305 UInt expand = Yap_Error_Size;
1306 yap_error_number yap_errno = Yap_Error_TYPE;
1307
1308 Yap_Error_Size = 0;
1309 Yap_Error_TYPE = YAP_NO_ERROR;
1310 if (yap_errno == OUT_OF_TRAIL_ERROR) {
1311 /* Trail overflow */
1312 if (!Yap_growtrail(expand, FALSE)) {
1313 return FALSE;
1314 }
1315 } else if (yap_errno == OUT_OF_AUXSPACE_ERROR) {
1316 /* Aux space overflow */
1317 if (expand > 4*1024*1024)
1318 expand = 4*1024*1024;
1319 if (!Yap_ExpandPreAllocCodeSpace(expand, NULL, TRUE)) {
1320 return FALSE;
1321 }
1322 } else {
1323 if (!Yap_gcl(expand, 3, ENV, gc_P(P,CP))) {
1324 Yap_Error(OUT_OF_STACK_ERROR, TermNil, "in term_variables");
1325 return FALSE;
1326 }
1327 }
1328 return TRUE;
1329 }
1330
1331 static Int
p_variables_in_term(void)1332 p_variables_in_term(void) /* variables in term t */
1333 {
1334 Term out, inp;
1335 int count;
1336
1337
1338 restart:
1339 count = 0;
1340 inp = Deref(ARG2);
1341 while (!IsVarTerm(inp) && IsPairTerm(inp)) {
1342 Term t = HeadOfTerm(inp);
1343 if (IsVarTerm(t)) {
1344 CELL *ptr = VarOfTerm(t);
1345 *ptr = TermFoundVar;
1346 TrailTerm(TR++) = t;
1347 count++;
1348 if (TR > (tr_fr_ptr)Yap_TrailTop - 256) {
1349 clean_tr(TR-count);
1350 if (!Yap_growtrail(count*sizeof(tr_fr_ptr *), FALSE)) {
1351 return FALSE;
1352 }
1353 goto restart;
1354 }
1355 }
1356 inp = TailOfTerm(inp);
1357 }
1358 do {
1359 Term t = Deref(ARG1);
1360 if (IsVarTerm(t)) {
1361 out = AbsPair(H);
1362 H += 2;
1363 RESET_VARIABLE(H-2);
1364 RESET_VARIABLE(H-1);
1365 Yap_unify((CELL)(H-2),ARG1);
1366 Yap_unify((CELL)(H-1),ARG2);
1367 } else if (IsPrimitiveTerm(t))
1368 out = ARG2;
1369 else if (IsPairTerm(t)) {
1370 out = vars_in_complex_term(RepPair(t)-1,
1371 RepPair(t)+1, ARG2);
1372 }
1373 else {
1374 Functor f = FunctorOfTerm(t);
1375 out = vars_in_complex_term(RepAppl(t),
1376 RepAppl(t)+
1377 ArityOfFunctor(f), ARG2);
1378 }
1379 if (out == 0L) {
1380 if (!expand_vts())
1381 return FALSE;
1382 }
1383 } while (out == 0L);
1384 clean_tr(TR-count);
1385 return Yap_unify(ARG3,out);
1386 }
1387
1388
1389 static Int
p_term_variables(void)1390 p_term_variables(void) /* variables in term t */
1391 {
1392 Term out;
1393
1394 do {
1395 Term t = Deref(ARG1);
1396 if (IsVarTerm(t)) {
1397 Term out = Yap_MkNewPairTerm();
1398 return
1399 Yap_unify(t,HeadOfTerm(out)) &&
1400 Yap_unify(TermNil, TailOfTerm(out)) &&
1401 Yap_unify(out, ARG2);
1402 } else if (IsPrimitiveTerm(t)) {
1403 return Yap_unify(TermNil, ARG2);
1404 } else if (IsPairTerm(t)) {
1405 out = vars_in_complex_term(RepPair(t)-1,
1406 RepPair(t)+1, TermNil);
1407 }
1408 else {
1409 Functor f = FunctorOfTerm(t);
1410 out = vars_in_complex_term(RepAppl(t),
1411 RepAppl(t)+
1412 ArityOfFunctor(f), TermNil);
1413 }
1414 if (out == 0L) {
1415 if (!expand_vts())
1416 return FALSE;
1417 }
1418 } while (out == 0L);
1419 return Yap_unify(ARG2,out);
1420 }
1421
attvars_in_complex_term(register CELL * pt0,register CELL * pt0_end,Term inp)1422 static Term attvars_in_complex_term(register CELL *pt0, register CELL *pt0_end, Term inp)
1423 {
1424
1425 register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
1426 register tr_fr_ptr TR0 = TR;
1427 CELL *InitialH = H;
1428 CELL output = AbsPair(H);
1429
1430 to_visit0 = to_visit;
1431 loop:
1432 while (pt0 < pt0_end) {
1433 register CELL d0;
1434 register CELL *ptd0;
1435 ++ pt0;
1436 ptd0 = pt0;
1437 d0 = *ptd0;
1438 deref_head(d0, attvars_in_term_unk);
1439 attvars_in_term_nvar:
1440 {
1441 if (IsPairTerm(d0)) {
1442 if (to_visit + 1024 >= (CELL **)AuxSp) {
1443 goto aux_overflow;
1444 }
1445 #ifdef RATIONAL_TREES
1446 to_visit[0] = pt0;
1447 to_visit[1] = pt0_end;
1448 to_visit[2] = (CELL *)*pt0;
1449 to_visit += 3;
1450 *pt0 = TermNil;
1451 #else
1452 if (pt0 < pt0_end) {
1453 to_visit[0] = pt0;
1454 to_visit[1] = pt0_end;
1455 to_visit += 2;
1456 }
1457 #endif
1458 pt0 = RepPair(d0) - 1;
1459 pt0_end = RepPair(d0) + 1;
1460 } else if (IsApplTerm(d0)) {
1461 register Functor f;
1462 register CELL *ap2;
1463 /* store the terms to visit */
1464 ap2 = RepAppl(d0);
1465 f = (Functor)(*ap2);
1466 if (IsExtensionFunctor(f)) {
1467 continue;
1468 }
1469 /* store the terms to visit */
1470 if (to_visit + 1024 >= (CELL **)AuxSp) {
1471 goto aux_overflow;
1472 }
1473 #ifdef RATIONAL_TREES
1474 to_visit[0] = pt0;
1475 to_visit[1] = pt0_end;
1476 to_visit[2] = (CELL *)*pt0;
1477 to_visit += 3;
1478 *pt0 = TermNil;
1479 #else
1480 if (pt0 < pt0_end) {
1481 to_visit[0] = pt0;
1482 to_visit[1] = pt0_end;
1483 to_visit += 2;
1484 }
1485 #endif
1486 d0 = ArityOfFunctor(f);
1487 pt0 = ap2;
1488 pt0_end = ap2 + d0;
1489 }
1490 continue;
1491 }
1492
1493
1494 derefa_body(d0, ptd0, attvars_in_term_unk, attvars_in_term_nvar);
1495 if (IsAttVar(ptd0)) {
1496 /* do or pt2 are unbound */
1497 *ptd0 = TermNil;
1498 /* next make sure noone will see this as a variable again */
1499 if (TR > (tr_fr_ptr)Yap_TrailTop - 256) {
1500 /* Trail overflow */
1501 if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
1502 goto trail_overflow;
1503 }
1504 }
1505 TrailTerm(TR++) = (CELL)ptd0;
1506 /* leave an empty slot to fill in later */
1507 if (H+1024 > ASP) {
1508 goto global_overflow;
1509 }
1510 H[1] = AbsPair(H+2);
1511 H += 2;
1512 H[-2] = (CELL)ptd0;
1513 /* store the terms to visit */
1514 if (to_visit + 1024 >= (CELL **)AuxSp) {
1515 goto aux_overflow;
1516 }
1517 #ifdef RATIONAL_TREES
1518 to_visit[0] = pt0;
1519 to_visit[1] = pt0_end;
1520 to_visit[2] = (CELL *)*pt0;
1521 to_visit += 3;
1522 *pt0 = TermNil;
1523 #else
1524 if (pt0 < pt0_end) {
1525 to_visit[0] = pt0;
1526 to_visit[1] = pt0_end;
1527 to_visit += 2;
1528 }
1529 #endif
1530 pt0 = &RepAttVar(ptd0)->Value;
1531 pt0_end = &RepAttVar(ptd0)->Atts;
1532 }
1533 }
1534 /* Do we still have compound terms to visit */
1535 if (to_visit > to_visit0) {
1536 #ifdef RATIONAL_TREES
1537 to_visit -= 3;
1538 pt0 = to_visit[0];
1539 pt0_end = to_visit[1];
1540 *pt0 = (CELL)to_visit[2];
1541 #else
1542 to_visit -= 2;
1543 pt0 = to_visit[0];
1544 pt0_end = to_visit[1];
1545 #endif
1546 goto loop;
1547 }
1548
1549 clean_tr(TR0);
1550 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1551 if (H != InitialH) {
1552 /* close the list */
1553 Term t2 = Deref(inp);
1554 if (IsVarTerm(t2)) {
1555 RESET_VARIABLE(H-1);
1556 Yap_unify((CELL)(H-1),ARG2);
1557 } else {
1558 H[-1] = t2; /* don't need to trail */
1559 }
1560 return(output);
1561 } else {
1562 return(inp);
1563 }
1564
1565 trail_overflow:
1566 #ifdef RATIONAL_TREES
1567 while (to_visit > to_visit0) {
1568 to_visit -= 3;
1569 pt0 = to_visit[0];
1570 *pt0 = (CELL)to_visit[2];
1571 }
1572 #endif
1573 Yap_Error_TYPE = OUT_OF_TRAIL_ERROR;
1574 Yap_Error_Size = (TR-TR0)*sizeof(tr_fr_ptr *);
1575 clean_tr(TR0);
1576 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1577 H = InitialH;
1578 return 0L;
1579
1580 aux_overflow:
1581 Yap_Error_Size = (to_visit-to_visit0)*sizeof(CELL **);
1582 #ifdef RATIONAL_TREES
1583 while (to_visit > to_visit0) {
1584 to_visit -= 3;
1585 pt0 = to_visit[0];
1586 *pt0 = (CELL)to_visit[2];
1587 }
1588 #endif
1589 Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
1590 clean_tr(TR0);
1591 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1592 H = InitialH;
1593 return 0L;
1594
1595 global_overflow:
1596 #ifdef RATIONAL_TREES
1597 while (to_visit > to_visit0) {
1598 to_visit -= 3;
1599 pt0 = to_visit[0];
1600 *pt0 = (CELL)to_visit[2];
1601 }
1602 #endif
1603 clean_tr(TR0);
1604 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1605 H = InitialH;
1606 Yap_Error_TYPE = OUT_OF_STACK_ERROR;
1607 Yap_Error_Size = (ASP-H)*sizeof(CELL);
1608 return 0L;
1609
1610 }
1611
1612 static Int
p_term_attvars(void)1613 p_term_attvars(void) /* variables in term t */
1614 {
1615 Term out;
1616
1617 do {
1618 Term t = Deref(ARG1);
1619 if (IsVarTerm(t)) {
1620 out = attvars_in_complex_term(VarOfTerm(t)-1,
1621 VarOfTerm(t)+1, TermNil);
1622 } else if (IsPrimitiveTerm(t)) {
1623 return Yap_unify(TermNil, ARG2);
1624 } else if (IsPairTerm(t)) {
1625 out = attvars_in_complex_term(RepPair(t)-1,
1626 RepPair(t)+1, TermNil);
1627 }
1628 else {
1629 Functor f = FunctorOfTerm(t);
1630 out = attvars_in_complex_term(RepAppl(t),
1631 RepAppl(t)+
1632 ArityOfFunctor(f), TermNil);
1633 }
1634 if (out == 0L) {
1635 if (!expand_vts())
1636 return FALSE;
1637 }
1638 } while (out == 0L);
1639 return Yap_unify(ARG2,out);
1640 }
1641
1642 static Int
p_term_variables3(void)1643 p_term_variables3(void) /* variables in term t */
1644 {
1645 Term out;
1646
1647 do {
1648 Term t = Deref(ARG1);
1649 if (IsVarTerm(t)) {
1650 Term out = Yap_MkNewPairTerm();
1651 return
1652 Yap_unify(t,HeadOfTerm(out)) &&
1653 Yap_unify(ARG3, TailOfTerm(out)) &&
1654 Yap_unify(out, ARG2);
1655 } else if (IsPrimitiveTerm(t)) {
1656 return Yap_unify(ARG2, ARG3);
1657 } else if (IsPairTerm(t)) {
1658 out = vars_in_complex_term(RepPair(t)-1,
1659 RepPair(t)+1, ARG3);
1660 }
1661 else {
1662 Functor f = FunctorOfTerm(t);
1663 out = vars_in_complex_term(RepAppl(t),
1664 RepAppl(t)+
1665 ArityOfFunctor(f), ARG3);
1666 }
1667 if (out == 0L) {
1668 if (!expand_vts())
1669 return FALSE;
1670 }
1671 } while (out == 0L);
1672
1673 return Yap_unify(ARG2,out);
1674 }
1675
1676
vars_within_complex_term(register CELL * pt0,register CELL * pt0_end,Term inp)1677 static Term vars_within_complex_term(register CELL *pt0, register CELL *pt0_end, Term inp)
1678 {
1679
1680 register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
1681 register tr_fr_ptr TR0 = TR;
1682 CELL *InitialH = H;
1683 CELL output = AbsPair(H);
1684
1685 to_visit0 = to_visit;
1686 while (!IsVarTerm(inp) && IsPairTerm(inp)) {
1687 Term t = HeadOfTerm(inp);
1688 if (IsVarTerm(t)) {
1689 CELL *ptr = VarOfTerm(t);
1690 *ptr = TermFoundVar;
1691 TrailTerm(TR++) = t;
1692 if (TR > (tr_fr_ptr)Yap_TrailTop - 256) {
1693 if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
1694 goto trail_overflow;
1695 }
1696 }
1697 }
1698 inp = TailOfTerm(inp);
1699 }
1700 loop:
1701 while (pt0 < pt0_end) {
1702 register CELL d0;
1703 register CELL *ptd0;
1704 ++ pt0;
1705 ptd0 = pt0;
1706 d0 = *ptd0;
1707 deref_head(d0, vars_within_term_unk);
1708 vars_within_term_nvar:
1709 {
1710 if (IsPairTerm(d0)) {
1711 if (to_visit + 1024 >= (CELL **)AuxSp) {
1712 goto aux_overflow;
1713 }
1714 #ifdef RATIONAL_TREES
1715 to_visit[0] = pt0;
1716 to_visit[1] = pt0_end;
1717 to_visit[2] = (CELL *)*pt0;
1718 to_visit += 3;
1719 *pt0 = TermNil;
1720 #else
1721 if (pt0 < pt0_end) {
1722 to_visit[0] = pt0;
1723 to_visit[1] = pt0_end;
1724 to_visit += 2;
1725 }
1726 #endif
1727 pt0 = RepPair(d0) - 1;
1728 pt0_end = RepPair(d0) + 1;
1729 } else if (IsApplTerm(d0)) {
1730 register Functor f;
1731 register CELL *ap2;
1732 /* store the terms to visit */
1733 ap2 = RepAppl(d0);
1734 f = (Functor)(*ap2);
1735 if (IsExtensionFunctor(f)) {
1736 continue;
1737 }
1738 /* store the terms to visit */
1739 if (to_visit + 1024 >= (CELL **)AuxSp) {
1740 goto aux_overflow;
1741 }
1742 #ifdef RATIONAL_TREES
1743 to_visit[0] = pt0;
1744 to_visit[1] = pt0_end;
1745 to_visit[2] = (CELL *)*pt0;
1746 to_visit += 3;
1747 *pt0 = TermNil;
1748 #else
1749 if (pt0 < pt0_end) {
1750 to_visit[0] = pt0;
1751 to_visit[1] = pt0_end;
1752 to_visit += 2;
1753 }
1754 #endif
1755 d0 = ArityOfFunctor(f);
1756 pt0 = ap2;
1757 pt0_end = ap2 + d0;
1758 } else if (d0 == TermFoundVar) {
1759 /* leave an empty slot to fill in later */
1760 if (H+1024 > ASP) {
1761 goto global_overflow;
1762 }
1763 H[1] = AbsPair(H+2);
1764 H += 2;
1765 H[-2] = (CELL)ptd0;
1766 *ptd0 = TermNil;
1767 }
1768 continue;
1769 }
1770
1771 derefa_body(d0, ptd0, vars_within_term_unk, vars_within_term_nvar);
1772 }
1773 /* Do we still have compound terms to visit */
1774 if (to_visit > to_visit0) {
1775 #ifdef RATIONAL_TREES
1776 to_visit -= 3;
1777 pt0 = to_visit[0];
1778 pt0_end = to_visit[1];
1779 *pt0 = (CELL)to_visit[2];
1780 #else
1781 to_visit -= 2;
1782 pt0 = to_visit[0];
1783 pt0_end = to_visit[1];
1784 #endif
1785 goto loop;
1786 }
1787
1788 clean_tr(TR0);
1789 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1790 if (H != InitialH) {
1791 H[-1] = TermNil;
1792 return output;
1793 } else {
1794 return TermNil;
1795 }
1796
1797 trail_overflow:
1798 #ifdef RATIONAL_TREES
1799 while (to_visit > to_visit0) {
1800 to_visit -= 3;
1801 pt0 = to_visit[0];
1802 *pt0 = (CELL)to_visit[2];
1803 }
1804 #endif
1805 Yap_Error_TYPE = OUT_OF_TRAIL_ERROR;
1806 Yap_Error_Size = (TR-TR0)*sizeof(tr_fr_ptr *);
1807 clean_tr(TR0);
1808 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1809 H = InitialH;
1810 return 0L;
1811
1812 aux_overflow:
1813 Yap_Error_Size = (to_visit-to_visit0)*sizeof(CELL **);
1814 #ifdef RATIONAL_TREES
1815 while (to_visit > to_visit0) {
1816 to_visit -= 3;
1817 pt0 = to_visit[0];
1818 *pt0 = (CELL)to_visit[2];
1819 }
1820 #endif
1821 Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
1822 clean_tr(TR0);
1823 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1824 H = InitialH;
1825 return 0L;
1826
1827 global_overflow:
1828 #ifdef RATIONAL_TREES
1829 while (to_visit > to_visit0) {
1830 to_visit -= 3;
1831 pt0 = to_visit[0];
1832 *pt0 = (CELL)to_visit[2];
1833 }
1834 #endif
1835 clean_tr(TR0);
1836 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1837 H = InitialH;
1838 Yap_Error_TYPE = OUT_OF_STACK_ERROR;
1839 Yap_Error_Size = (ASP-H)*sizeof(CELL);
1840 return 0L;
1841
1842 }
1843
1844 static Int
p_variables_within_term(void)1845 p_variables_within_term(void) /* variables within term t */
1846 {
1847 Term out;
1848
1849 do {
1850 Term t = Deref(ARG2);
1851 if (IsVarTerm(t)) {
1852 out = vars_within_complex_term(VarOfTerm(t)-1,
1853 VarOfTerm(t), Deref(ARG1));
1854
1855 } else if (IsPrimitiveTerm(t))
1856 out = TermNil;
1857 else if (IsPairTerm(t)) {
1858 out = vars_within_complex_term(RepPair(t)-1,
1859 RepPair(t)+1, Deref(ARG1));
1860 }
1861 else {
1862 Functor f = FunctorOfTerm(t);
1863 out = vars_within_complex_term(RepAppl(t),
1864 RepAppl(t)+
1865 ArityOfFunctor(f), Deref(ARG1));
1866 }
1867 if (out == 0L) {
1868 if (!expand_vts())
1869 return FALSE;
1870 }
1871 } while (out == 0L);
1872 return Yap_unify(ARG3,out);
1873 }
1874
new_vars_in_complex_term(register CELL * pt0,register CELL * pt0_end,Term inp)1875 static Term new_vars_in_complex_term(register CELL *pt0, register CELL *pt0_end, Term inp)
1876 {
1877 register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
1878 register tr_fr_ptr TR0 = TR;
1879 CELL *InitialH = H;
1880 CELL output = AbsPair(H);
1881
1882 to_visit0 = to_visit;
1883 while (!IsVarTerm(inp) && IsPairTerm(inp)) {
1884 Term t = HeadOfTerm(inp);
1885 if (IsVarTerm(t)) {
1886 CELL *ptr = VarOfTerm(t);
1887 *ptr = TermFoundVar;
1888 TrailTerm(TR++) = t;
1889 if (TR > (tr_fr_ptr)Yap_TrailTop - 256) {
1890 if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
1891 goto trail_overflow;
1892 }
1893 }
1894 }
1895 inp = TailOfTerm(inp);
1896 }
1897 loop:
1898 while (pt0 < pt0_end) {
1899 register CELL d0;
1900 register CELL *ptd0;
1901 ++ pt0;
1902 ptd0 = pt0;
1903 d0 = *ptd0;
1904 deref_head(d0, vars_within_term_unk);
1905 vars_within_term_nvar:
1906 {
1907 if (IsPairTerm(d0)) {
1908 if (to_visit + 1024 >= (CELL **)AuxSp) {
1909 goto aux_overflow;
1910 }
1911 #ifdef RATIONAL_TREES
1912 to_visit[0] = pt0;
1913 to_visit[1] = pt0_end;
1914 to_visit[2] = (CELL *)*pt0;
1915 to_visit += 3;
1916 *pt0 = TermNil;
1917 #else
1918 if (pt0 < pt0_end) {
1919 to_visit[0] = pt0;
1920 to_visit[1] = pt0_end;
1921 to_visit += 2;
1922 }
1923 #endif
1924 pt0 = RepPair(d0) - 1;
1925 pt0_end = RepPair(d0) + 1;
1926 } else if (IsApplTerm(d0)) {
1927 register Functor f;
1928 register CELL *ap2;
1929 /* store the terms to visit */
1930 ap2 = RepAppl(d0);
1931 f = (Functor)(*ap2);
1932 if (IsExtensionFunctor(f)) {
1933 continue;
1934 }
1935 /* store the terms to visit */
1936 if (to_visit + 1024 >= (CELL **)AuxSp) {
1937 goto aux_overflow;
1938 }
1939 #ifdef RATIONAL_TREES
1940 to_visit[0] = pt0;
1941 to_visit[1] = pt0_end;
1942 to_visit[2] = (CELL *)*pt0;
1943 to_visit += 3;
1944 *pt0 = TermNil;
1945 #else
1946 if (pt0 < pt0_end) {
1947 to_visit[0] = pt0;
1948 to_visit[1] = pt0_end;
1949 to_visit += 2;
1950 }
1951 #endif
1952 d0 = ArityOfFunctor(f);
1953 pt0 = ap2;
1954 pt0_end = ap2 + d0;
1955 }
1956 continue;
1957 }
1958
1959 derefa_body(d0, ptd0, vars_within_term_unk, vars_within_term_nvar);
1960 /* do or pt2 are unbound */
1961 *ptd0 = TermNil;
1962 /* leave an empty slot to fill in later */
1963 if (H+1024 > ASP) {
1964 goto global_overflow;
1965 }
1966 H[1] = AbsPair(H+2);
1967 H += 2;
1968 H[-2] = (CELL)ptd0;
1969 /* next make sure noone will see this as a variable again */
1970 if (TR > (tr_fr_ptr)Yap_TrailTop - 256) {
1971 /* Trail overflow */
1972 if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
1973 goto trail_overflow;
1974 }
1975 }
1976 TrailTerm(TR++) = (CELL)ptd0;
1977 }
1978 /* Do we still have compound terms to visit */
1979 if (to_visit > to_visit0) {
1980 #ifdef RATIONAL_TREES
1981 to_visit -= 3;
1982 pt0 = to_visit[0];
1983 pt0_end = to_visit[1];
1984 *pt0 = (CELL)to_visit[2];
1985 #else
1986 to_visit -= 2;
1987 pt0 = to_visit[0];
1988 pt0_end = to_visit[1];
1989 #endif
1990 goto loop;
1991 }
1992
1993 clean_tr(TR0);
1994 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
1995 if (H != InitialH) {
1996 H[-1] = TermNil;
1997 return output;
1998 } else {
1999 return TermNil;
2000 }
2001
2002 trail_overflow:
2003 #ifdef RATIONAL_TREES
2004 while (to_visit > to_visit0) {
2005 to_visit -= 3;
2006 pt0 = to_visit[0];
2007 *pt0 = (CELL)to_visit[2];
2008 }
2009 #endif
2010 Yap_Error_TYPE = OUT_OF_TRAIL_ERROR;
2011 Yap_Error_Size = (TR-TR0)*sizeof(tr_fr_ptr *);
2012 clean_tr(TR0);
2013 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
2014 H = InitialH;
2015 return 0L;
2016
2017 aux_overflow:
2018 Yap_Error_Size = (to_visit-to_visit0)*sizeof(CELL **);
2019 #ifdef RATIONAL_TREES
2020 while (to_visit > to_visit0) {
2021 to_visit -= 3;
2022 pt0 = to_visit[0];
2023 *pt0 = (CELL)to_visit[2];
2024 }
2025 #endif
2026 Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
2027 clean_tr(TR0);
2028 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
2029 H = InitialH;
2030 return 0L;
2031
2032 global_overflow:
2033 #ifdef RATIONAL_TREES
2034 while (to_visit > to_visit0) {
2035 to_visit -= 3;
2036 pt0 = to_visit[0];
2037 *pt0 = (CELL)to_visit[2];
2038 }
2039 #endif
2040 clean_tr(TR0);
2041 Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
2042 H = InitialH;
2043 Yap_Error_TYPE = OUT_OF_STACK_ERROR;
2044 Yap_Error_Size = (ASP-H)*sizeof(CELL);
2045 return 0L;
2046
2047 }
2048
2049 static Int
p_new_variables_in_term(void)2050 p_new_variables_in_term(void) /* variables within term t */
2051 {
2052 Term out;
2053
2054 do {
2055 Term t = Deref(ARG2);
2056 if (IsVarTerm(t)) {
2057 out = new_vars_in_complex_term(VarOfTerm(t)-1,
2058 VarOfTerm(t), Deref(ARG1));
2059
2060 } else if (IsPrimitiveTerm(t))
2061 out = TermNil;
2062 else if (IsPairTerm(t)) {
2063 out = new_vars_in_complex_term(RepPair(t)-1,
2064 RepPair(t)+1, Deref(ARG1));
2065 }
2066 else {
2067 Functor f = FunctorOfTerm(t);
2068 out = new_vars_in_complex_term(RepAppl(t),
2069 RepAppl(t)+
2070 ArityOfFunctor(f), Deref(ARG1));
2071 }
2072 if (out == 0L) {
2073 if (!expand_vts())
2074 return FALSE;
2075 }
2076 } while (out == 0L);
2077 return Yap_unify(ARG3,out);
2078 }
2079
non_singletons_in_complex_term(register CELL * pt0,register CELL * pt0_end)2080 static Term non_singletons_in_complex_term(register CELL *pt0, register CELL *pt0_end)
2081 {
2082
2083 register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
2084 register tr_fr_ptr TR0 = TR;
2085 CELL *InitialH = H;
2086 CELL output = AbsPair(H);
2087
2088 to_visit0 = to_visit;
2089 loop:
2090 while (pt0 < pt0_end) {
2091 register CELL d0;
2092 register CELL *ptd0;
2093 ++ pt0;
2094 ptd0 = pt0;
2095 d0 = *ptd0;
2096 deref_head(d0, vars_in_term_unk);
2097 vars_in_term_nvar:
2098 {
2099 if (IsPairTerm(d0)) {
2100 if (to_visit + 1024 >= (CELL **)AuxSp) {
2101 goto aux_overflow;
2102 }
2103 #ifdef RATIONAL_TREES
2104 to_visit[0] = pt0;
2105 to_visit[1] = pt0_end;
2106 to_visit[2] = (CELL *)*pt0;
2107 to_visit += 3;
2108 *pt0 = TermNil;
2109 #else
2110 if (pt0 < pt0_end) {
2111 to_visit[0] = pt0;
2112 to_visit[1] = pt0_end;
2113 to_visit += 2;
2114 }
2115 #endif
2116 pt0 = RepPair(d0) - 1;
2117 pt0_end = RepPair(d0) + 1;
2118 } else if (IsApplTerm(d0)) {
2119 register Functor f;
2120 register CELL *ap2;
2121 /* store the terms to visit */
2122 ap2 = RepAppl(d0);
2123 f = (Functor)(*ap2);
2124
2125 if (IsExtensionFunctor(f)) {
2126
2127 continue;
2128 }
2129 if (to_visit + 1024 >= (CELL **)AuxSp) {
2130 goto aux_overflow;
2131 }
2132 #ifdef RATIONAL_TREES
2133 to_visit[0] = pt0;
2134 to_visit[1] = pt0_end;
2135 to_visit[2] = (CELL *)*pt0;
2136 to_visit += 3;
2137 *pt0 = TermNil;
2138 #else
2139 /* store the terms to visit */
2140 if (pt0 < pt0_end) {
2141 to_visit[0] = pt0;
2142 to_visit[1] = pt0_end;
2143 to_visit += 2;
2144 }
2145 #endif
2146 d0 = ArityOfFunctor(f);
2147 pt0 = ap2;
2148 pt0_end = ap2 + d0;
2149 } else if (d0 == TermFoundVar) {
2150 CELL *pt2 = pt0;
2151 while(IsVarTerm(*pt2))
2152 pt2 = (CELL *)(*pt2);
2153 H[1] = AbsPair(H+2);
2154 H += 2;
2155 H[-2] = (CELL)pt2;
2156 *pt2 = TermReFoundVar;
2157 }
2158 continue;
2159 }
2160
2161
2162 derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar);
2163 /* do or pt2 are unbound */
2164 *ptd0 = TermFoundVar;
2165 /* next make sure we can recover the variable again */
2166 TrailTerm(TR++) = (CELL)ptd0;
2167 }
2168 /* Do we still have compound terms to visit */
2169 if (to_visit > to_visit0) {
2170 #ifdef RATIONAL_TREES
2171 to_visit -= 3;
2172 pt0 = to_visit[0];
2173 pt0_end = to_visit[1];
2174 *pt0 = (CELL)to_visit[2];
2175 #else
2176 to_visit -= 2;
2177 pt0 = to_visit[0];
2178 pt0_end = to_visit[1];
2179 #endif
2180 goto loop;
2181 }
2182
2183 clean_tr(TR0);
2184 if (H != InitialH) {
2185 /* close the list */
2186 RESET_VARIABLE(H-1);
2187 Yap_unify((CELL)(H-1),ARG2);
2188 return output;
2189 } else {
2190 return ARG2;
2191 }
2192
2193 aux_overflow:
2194 #ifdef RATIONAL_TREES
2195 while (to_visit > to_visit0) {
2196 to_visit -= 3;
2197 pt0 = to_visit[0];
2198 *pt0 = (CELL)to_visit[2];
2199 }
2200 #endif
2201 clean_tr(TR0);
2202 if (H != InitialH) {
2203 /* close the list */
2204 RESET_VARIABLE(H-1);
2205 }
2206 return 0L;
2207 }
2208
2209 static Int
p_non_singletons_in_term(void)2210 p_non_singletons_in_term(void) /* non_singletons in term t */
2211 {
2212 Term t;
2213 Term out;
2214
2215 while (TRUE) {
2216 t = Deref(ARG1);
2217 if (IsVarTerm(t)) {
2218 out = MkPairTerm(t,ARG2);
2219 } else if (IsPrimitiveTerm(t)) {
2220 out = ARG2;
2221 } else if (IsPairTerm(t)) {
2222 out = non_singletons_in_complex_term(RepPair(t)-1,
2223 RepPair(t)+1);
2224 } else {
2225 out = non_singletons_in_complex_term(RepAppl(t),
2226 RepAppl(t)+
2227 ArityOfFunctor(FunctorOfTerm(t)));
2228 }
2229 if (out != 0L) {
2230 return Yap_unify(ARG3,out);
2231 } else {
2232 if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
2233 Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "overflow in singletons");
2234 return FALSE;
2235 }
2236 }
2237 }
2238 }
2239
ground_complex_term(register CELL * pt0,register CELL * pt0_end)2240 static Int ground_complex_term(register CELL *pt0, register CELL *pt0_end)
2241 {
2242
2243 register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
2244
2245 to_visit0 = to_visit;
2246 loop:
2247 while (pt0 < pt0_end) {
2248 register CELL d0;
2249 register CELL *ptd0;
2250
2251 ++pt0;
2252 ptd0 = pt0;
2253 d0 = *ptd0;
2254 deref_head(d0, vars_in_term_unk);
2255 vars_in_term_nvar:
2256 {
2257 if (IsPairTerm(d0)) {
2258 if (to_visit + 1024 >= (CELL **)AuxSp) {
2259 goto aux_overflow;
2260 }
2261 #ifdef RATIONAL_TREES
2262 to_visit[0] = pt0;
2263 to_visit[1] = pt0_end;
2264 to_visit[2] = (CELL *)*pt0;
2265 to_visit += 3;
2266 *pt0 = TermNil;
2267 #else
2268 if (pt0 < pt0_end) {
2269 to_visit[0] = pt0;
2270 to_visit[1] = pt0_end;
2271 to_visit += 2;
2272 }
2273 #endif
2274 pt0 = RepPair(d0) - 1;
2275 pt0_end = RepPair(d0) + 1;
2276 } else if (IsApplTerm(d0)) {
2277 register Functor f;
2278 register CELL *ap2;
2279 /* store the terms to visit */
2280 ap2 = RepAppl(d0);
2281 f = (Functor)(*ap2);
2282
2283 if (IsExtensionFunctor(f)) {
2284 continue;
2285 }
2286 if (to_visit + 1024 >= (CELL **)AuxSp) {
2287 goto aux_overflow;
2288 }
2289 #ifdef RATIONAL_TREES
2290 to_visit[0] = pt0;
2291 to_visit[1] = pt0_end;
2292 to_visit[2] = (CELL *)*pt0;
2293 to_visit += 3;
2294 *pt0 = TermNil;
2295 #else
2296 /* store the terms to visit */
2297 if (pt0 < pt0_end) {
2298 to_visit[0] = pt0;
2299 to_visit[1] = pt0_end;
2300 to_visit += 2;
2301 }
2302 #endif
2303 d0 = ArityOfFunctor(f);
2304 pt0 = ap2;
2305 pt0_end = ap2 + d0;
2306 }
2307 continue;
2308 }
2309
2310
2311 derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar);
2312 #ifdef RATIONAL_TREES
2313 while (to_visit > to_visit0) {
2314 to_visit -= 3;
2315 pt0 = to_visit[0];
2316 pt0_end = to_visit[1];
2317 *pt0 = (CELL)to_visit[2];
2318 }
2319 #endif
2320 return FALSE;
2321 }
2322 /* Do we still have compound terms to visit */
2323 if (to_visit > to_visit0) {
2324 #ifdef RATIONAL_TREES
2325 to_visit -= 3;
2326 pt0 = to_visit[0];
2327 pt0_end = to_visit[1];
2328 *pt0 = (CELL)to_visit[2];
2329 #else
2330 to_visit -= 2;
2331 pt0 = to_visit[0];
2332 pt0_end = to_visit[1];
2333 #endif
2334 goto loop;
2335 }
2336 return TRUE;
2337
2338 aux_overflow:
2339 /* unwind stack */
2340 #ifdef RATIONAL_TREES
2341 while (to_visit > to_visit0) {
2342 to_visit -= 3;
2343 pt0 = to_visit[0];
2344 *pt0 = (CELL)to_visit[2];
2345 }
2346 #endif
2347 return -1;
2348 }
2349
Yap_IsGroundTerm(Term t)2350 int Yap_IsGroundTerm(Term t)
2351 {
2352 while (TRUE) {
2353 Int out;
2354
2355 if (IsVarTerm(t)) {
2356 return FALSE;
2357 } else if (IsPrimitiveTerm(t)) {
2358 return TRUE;
2359 } else if (IsPairTerm(t)) {
2360 if ((out =ground_complex_term(RepPair(t)-1,
2361 RepPair(t)+1)) >= 0) {
2362 return out;
2363 }
2364 } else {
2365 Functor fun = FunctorOfTerm(t);
2366
2367 if (IsExtensionFunctor(fun))
2368 return TRUE;
2369 else if ((out = ground_complex_term(RepAppl(t),
2370 RepAppl(t)+
2371 ArityOfFunctor(fun))) >= 0) {
2372 return out;
2373 }
2374 }
2375 if (out < 0) {
2376 if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
2377 Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "overflow in ground");
2378 return FALSE;
2379 }
2380 }
2381 }
2382 }
2383
2384 static Int
p_ground(void)2385 p_ground(void) /* ground(+T) */
2386 {
2387 return Yap_IsGroundTerm(Deref(ARG1));
2388 }
2389
2390 static int
SizeOfExtension(Term t)2391 SizeOfExtension(Term t)
2392 {
2393 Functor f = FunctorOfTerm(t);
2394 if (f== FunctorDouble) {
2395 return 2 + sizeof(Float)/sizeof(CELL);
2396 }
2397 if (f== FunctorLongInt) {
2398 return 2 + sizeof(Float)/sizeof(CELL);
2399 }
2400 if (f== FunctorDBRef) {
2401 return 0;
2402 }
2403 if (f== FunctorBigInt) {
2404 CELL *pt = RepAppl(t)+2;
2405 return 3+sizeof(MP_INT)+(((MP_INT *)(pt))->_mp_alloc*sizeof(mp_limb_t));
2406 }
2407 return 0;
2408 }
2409
2410
sz_ground_complex_term(register CELL * pt0,register CELL * pt0_end,int ground)2411 static Int sz_ground_complex_term(register CELL *pt0, register CELL *pt0_end, int ground)
2412 {
2413
2414 register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
2415 Int sz = 0;
2416
2417 to_visit0 = to_visit;
2418 loop:
2419 while (pt0 < pt0_end) {
2420 register CELL d0;
2421 register CELL *ptd0;
2422
2423 ++pt0;
2424 ptd0 = pt0;
2425 d0 = *ptd0;
2426 deref_head(d0, vars_in_term_unk);
2427 vars_in_term_nvar:
2428 {
2429 if (IsPairTerm(d0)) {
2430 sz += 2;
2431 if (to_visit + 1024 >= (CELL **)AuxSp) {
2432 goto aux_overflow;
2433 }
2434 #ifdef RATIONAL_TREES
2435 to_visit[0] = pt0;
2436 to_visit[1] = pt0_end;
2437 to_visit[2] = (CELL *)*pt0;
2438 to_visit += 3;
2439 *pt0 = TermNil;
2440 #else
2441 if (pt0 < pt0_end) {
2442 to_visit[0] = pt0;
2443 to_visit[1] = pt0_end;
2444 to_visit += 2;
2445 }
2446 #endif
2447 pt0 = RepPair(d0) - 1;
2448 pt0_end = RepPair(d0) + 1;
2449 } else if (IsApplTerm(d0)) {
2450 register Functor f;
2451 register CELL *ap2;
2452 /* store the terms to visit */
2453 ap2 = RepAppl(d0);
2454 f = (Functor)(*ap2);
2455
2456 if (IsExtensionFunctor(f)) {
2457 sz += SizeOfExtension(d0);
2458 continue;
2459 }
2460 if (to_visit + 1024 >= (CELL **)AuxSp) {
2461 goto aux_overflow;
2462 }
2463 #ifdef RATIONAL_TREES
2464 to_visit[0] = pt0;
2465 to_visit[1] = pt0_end;
2466 to_visit[2] = (CELL *)*pt0;
2467 to_visit += 3;
2468 *pt0 = TermNil;
2469 #else
2470 /* store the terms to visit */
2471 if (pt0 < pt0_end) {
2472 to_visit[0] = pt0;
2473 to_visit[1] = pt0_end;
2474 to_visit += 2;
2475 }
2476 #endif
2477 d0 = ArityOfFunctor(f);
2478 sz += (1+d0);
2479 pt0 = ap2;
2480 pt0_end = ap2 + d0;
2481 }
2482 continue;
2483 }
2484
2485
2486 derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar);
2487 if (!ground)
2488 continue;
2489 #ifdef RATIONAL_TREES
2490 while (to_visit > to_visit0) {
2491 to_visit -= 3;
2492 pt0 = to_visit[0];
2493 pt0_end = to_visit[1];
2494 *pt0 = (CELL)to_visit[2];
2495 }
2496 #endif
2497 return 0;
2498 }
2499 /* Do we still have compound terms to visit */
2500 if (to_visit > to_visit0) {
2501 #ifdef RATIONAL_TREES
2502 to_visit -= 3;
2503 pt0 = to_visit[0];
2504 pt0_end = to_visit[1];
2505 *pt0 = (CELL)to_visit[2];
2506 #else
2507 to_visit -= 2;
2508 pt0 = to_visit[0];
2509 pt0_end = to_visit[1];
2510 #endif
2511 goto loop;
2512 }
2513 return sz;
2514
2515 aux_overflow:
2516 /* unwind stack */
2517 #ifdef RATIONAL_TREES
2518 while (to_visit > to_visit0) {
2519 to_visit -= 3;
2520 pt0 = to_visit[0];
2521 *pt0 = (CELL)to_visit[2];
2522 }
2523 #endif
2524 return -1;
2525 }
2526
2527 int
Yap_SizeGroundTerm(Term t,int ground)2528 Yap_SizeGroundTerm(Term t, int ground)
2529 {
2530 if (IsVarTerm(t)) {
2531 if (!ground)
2532 return 1;
2533 return 0;
2534 } else if (IsPrimitiveTerm(t)) {
2535 return 1;
2536 } else if (IsPairTerm(t)) {
2537 int sz = sz_ground_complex_term(RepPair(t)-1, RepPair(t)+1, ground);
2538 if (sz <= 0)
2539 return sz;
2540 return sz+2;
2541 } else {
2542 int sz = 0;
2543 Functor fun = FunctorOfTerm(t);
2544
2545 if (IsExtensionFunctor(fun))
2546 return 1+ SizeOfExtension(t);
2547
2548 sz = sz_ground_complex_term(RepAppl(t),
2549 RepAppl(t)+
2550 ArityOfFunctor(fun),
2551 ground);
2552 if (sz <= 0)
2553 return sz;
2554 return 1+ArityOfFunctor(fun)+sz;
2555 }
2556 }
2557
var_in_complex_term(register CELL * pt0,register CELL * pt0_end,Term v)2558 static Int var_in_complex_term(register CELL *pt0,
2559 register CELL *pt0_end,
2560 Term v)
2561 {
2562
2563 register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
2564 register tr_fr_ptr TR0 = TR;
2565
2566 to_visit0 = to_visit;
2567 loop:
2568 while (pt0 < pt0_end) {
2569 register CELL d0;
2570 register CELL *ptd0;
2571 ++ pt0;
2572 ptd0 = pt0;
2573 d0 = *ptd0;
2574 deref_head(d0, var_in_term_unk);
2575 var_in_term_nvar:
2576 {
2577 if (IsPairTerm(d0)) {
2578 if (to_visit + 1024 >= (CELL **)AuxSp) {
2579 goto aux_overflow;
2580 }
2581 #ifdef RATIONAL_TREES
2582 to_visit[0] = pt0;
2583 to_visit[1] = pt0_end;
2584 to_visit[2] = (CELL *)*pt0;
2585 to_visit += 3;
2586 *pt0 = TermNil;
2587 #else
2588 if (pt0 < pt0_end) {
2589 to_visit[0] = pt0;
2590 to_visit[1] = pt0_end;
2591 to_visit += 2;
2592 }
2593 #endif
2594 pt0 = RepPair(d0) - 1;
2595 pt0_end = RepPair(d0) + 1;
2596 continue;
2597 } else if (IsApplTerm(d0)) {
2598 register Functor f;
2599 register CELL *ap2;
2600 /* store the terms to visit */
2601 ap2 = RepAppl(d0);
2602 f = (Functor)(*ap2);
2603
2604 if (IsExtensionFunctor(f)) {
2605
2606 continue;
2607 }
2608 if (to_visit + 1024 >= (CELL **)AuxSp) {
2609 goto aux_overflow;
2610 }
2611 #ifdef RATIONAL_TREES
2612 to_visit[0] = pt0;
2613 to_visit[1] = pt0_end;
2614 to_visit[2] = (CELL *)*pt0;
2615 to_visit += 3;
2616 *pt0 = TermNil;
2617 #else
2618 /* store the terms to visit */
2619 if (pt0 < pt0_end) {
2620 to_visit[0] = pt0;
2621 to_visit[1] = pt0_end;
2622 to_visit += 2;
2623 }
2624 #endif
2625 d0 = ArityOfFunctor(f);
2626 pt0 = ap2;
2627 pt0_end = ap2 + d0;
2628 }
2629 continue;
2630 }
2631
2632
2633 deref_body(d0, ptd0, var_in_term_unk, var_in_term_nvar);
2634 if ((CELL)ptd0 == v) { /* we found it */
2635 #ifdef RATIONAL_TREES
2636 while (to_visit > to_visit0) {
2637 to_visit -= 3;
2638 pt0 = to_visit[0];
2639 *pt0 = (CELL)to_visit[2];
2640 }
2641 #endif
2642 clean_tr(TR0);
2643 return(TRUE);
2644 }
2645 /* do or pt2 are unbound */
2646 *ptd0 = TermNil;
2647 /* next make sure noone will see this as a variable again */
2648 TrailTerm(TR++) = (CELL)ptd0;
2649 }
2650 /* Do we still have compound terms to visit */
2651 if (to_visit > to_visit0) {
2652 #ifdef RATIONAL_TREES
2653 to_visit -= 3;
2654 pt0 = to_visit[0];
2655 pt0_end = to_visit[1];
2656 *pt0 = (CELL)to_visit[2];
2657 #else
2658 to_visit -= 2;
2659 pt0 = to_visit[0];
2660 pt0_end = to_visit[1];
2661 #endif
2662 goto loop;
2663 }
2664 #ifdef RATIONAL_TREES
2665 while (to_visit > to_visit0) {
2666 to_visit -= 3;
2667 pt0 = to_visit[0];
2668 *pt0 = (CELL)to_visit[2];
2669 }
2670 #endif
2671 clean_tr(TR0);
2672 return FALSE;
2673
2674
2675 aux_overflow:
2676 /* unwind stack */
2677 #ifdef RATIONAL_TREES
2678 while (to_visit > to_visit0) {
2679 to_visit -= 3;
2680 pt0 = to_visit[0];
2681 *pt0 = (CELL)to_visit[2];
2682 }
2683 #endif
2684 return -1;
2685 }
2686
2687 static Int
var_in_term(Term v,Term t)2688 var_in_term(Term v, Term t) /* variables in term t */
2689 {
2690
2691 if (IsVarTerm(t)) {
2692 return(v == t);
2693 } else if (IsPrimitiveTerm(t)) {
2694 return(FALSE);
2695 } else if (IsPairTerm(t)) {
2696 return(var_in_complex_term(RepPair(t)-1,
2697 RepPair(t)+1, v));
2698 }
2699 else return(var_in_complex_term(RepAppl(t),
2700 RepAppl(t)+
2701 ArityOfFunctor(FunctorOfTerm(t)),v));
2702 }
2703
2704 static Int
p_var_in_term(void)2705 p_var_in_term(void)
2706 {
2707 return(var_in_term(Deref(ARG2), Deref(ARG1)));
2708 }
2709
2710 /* The code for TermHash was originally contributed by Gertjen Van Noor */
2711
2712 /* This code with max_depth == -1 will loop for infinite trees */
2713
2714
2715 //-----------------------------------------------------------------------------
2716 // MurmurHash2, by Austin Appleby
2717
2718 // Note - This code makes a few assumptions about how your machine behaves -
2719
2720 // 1. We can read a 4-byte value from any address without crashing
2721 // 2. sizeof(int) == 4
2722
2723 // And it has a few limitations -
2724
2725 // 1. It will not work incrementally.
2726 // 2. It will not produce the same results on little-endian and big-endian
2727 // machines.
2728
2729 static unsigned int
MurmurHashNeutral2(const void * key,int len,unsigned int seed)2730 MurmurHashNeutral2 ( const void * key, int len, unsigned int seed )
2731 {
2732 const unsigned int m = 0x5bd1e995;
2733 const int r = 24;
2734
2735 unsigned int h = seed ^ len;
2736
2737 const unsigned char * data = (const unsigned char *)key;
2738
2739 while(len >= 4)
2740 {
2741 unsigned int k;
2742
2743 k = data[0];
2744 k |= data[1] << 8;
2745 k |= data[2] << 16;
2746 k |= data[3] << 24;
2747
2748 k *= m;
2749 k ^= k >> r;
2750 k *= m;
2751
2752 h *= m;
2753 h ^= k;
2754
2755 data += 4;
2756 len -= 4;
2757 }
2758
2759 switch(len)
2760 {
2761 case 3: h ^= data[2] << 16;
2762 case 2: h ^= data[1] << 8;
2763 case 1: h ^= data[0];
2764 h *= m;
2765 };
2766
2767 h ^= h >> 13;
2768 h *= m;
2769 h ^= h >> 15;
2770
2771 return h;
2772 }
2773
2774 static CELL *
AddAtomToHash(CELL * st,Atom at)2775 AddAtomToHash(CELL *st, Atom at)
2776 {
2777 unsigned int len;
2778 CELL * start;
2779
2780 if (IsWideAtom(at)) {
2781 wchar_t *c = RepAtom(at)->WStrOfAE;
2782 int ulen = wcslen(c);
2783 len = ulen*sizeof(wchar_t);
2784 if (len % CellSize == 0) {
2785 len /= CellSize;
2786 } else {
2787 len /= CellSize;
2788 len++;
2789 }
2790 st[len-1] = 0L;
2791 wcsncpy((wchar_t *)st, c, ulen);
2792 } else {
2793 char *c = RepAtom(at)->StrOfAE;
2794 int ulen = strlen(c);
2795 /* fix hashing over empty atom */
2796 if (!ulen) {
2797 return st;
2798 }
2799 start = (CELL *)c;
2800 if (ulen % CellSize == 0) {
2801 len = ulen/CellSize;
2802 } else {
2803 len = ulen/CellSize;
2804 len++;
2805 }
2806 st[len-1] = 0L;
2807 strncpy((char *)st, c, ulen);
2808 }
2809 return st+len;
2810 }
2811
2812 static CELL *
hash_complex_term(register CELL * pt0,register CELL * pt0_end,Int depth,CELL * st,int variant)2813 hash_complex_term(register CELL *pt0,
2814 register CELL *pt0_end,
2815 Int depth,
2816 CELL *st,
2817 int variant)
2818 {
2819 register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
2820
2821 to_visit0 = to_visit;
2822 loop:
2823 while (pt0 < pt0_end) {
2824 register CELL d0;
2825 register CELL *ptd0;
2826 ++ pt0;
2827 ptd0 = pt0;
2828 d0 = *ptd0;
2829 deref_head(d0, hash_complex_unk);
2830 hash_complex_nvar:
2831 {
2832 if (st + 1024 >= ASP) {
2833 goto global_overflow;
2834 }
2835 if (IsAtomOrIntTerm(d0)) {
2836 if (d0 != TermFoundVar) {
2837 if (IsAtomTerm(d0)) {
2838 st = AddAtomToHash(st, AtomOfTerm(d0));
2839 } else {
2840 *st++ = IntOfTerm(d0);
2841 }
2842 }
2843 continue;
2844 } else if (IsPairTerm(d0)) {
2845 st = AddAtomToHash(st, AtomDot);
2846 if (depth == 1)
2847 continue;
2848 if (to_visit + 1024 >= (CELL **)AuxSp) {
2849 goto aux_overflow;
2850 }
2851 #ifdef RATIONAL_TREES
2852 to_visit[0] = pt0;
2853 to_visit[1] = pt0_end;
2854 to_visit[2] = (CELL *)*pt0;
2855 to_visit[3] = (CELL *)(depth--);
2856 to_visit += 4;
2857 *pt0 = TermFoundVar;
2858 #else
2859 if (pt0 < pt0_end) {
2860 to_visit[0] = pt0;
2861 to_visit[1] = pt0_end;
2862 to_visit[2] = (CELL *)(depth--);
2863 to_visit += 3;
2864 }
2865 #endif
2866 pt0 = RepPair(d0) - 1;
2867 pt0_end = RepPair(d0) + 1;
2868 continue;
2869 } else if (IsApplTerm(d0)) {
2870 register Functor f;
2871 register CELL *ap2;
2872 /* store the terms to visit */
2873 ap2 = RepAppl(d0);
2874 f = (Functor)(*ap2);
2875
2876 if (IsExtensionFunctor(f)) {
2877 CELL fc = (CELL)f;
2878
2879 switch(fc) {
2880
2881 case (CELL)FunctorDBRef:
2882 *st++ = fc;
2883 break;
2884 case (CELL)FunctorLongInt:
2885 *st++ = LongIntOfTerm(d0);
2886 break;
2887 #ifdef USE_GMP
2888 case (CELL)FunctorBigInt:
2889 {
2890 CELL *pt = RepAppl(d0);
2891 Int sz =
2892 sizeof(MP_INT)+1+
2893 (((MP_INT *)(pt+2))->_mp_alloc*sizeof(mp_limb_t));
2894
2895 if (st + (1024 + sz/CellSize) >= ASP) {
2896 goto global_overflow;
2897 }
2898 /* then the actual number */
2899 memcpy((void *)(st+1), (void *)(pt+1), sz);
2900 st = st+sz/CellSize;
2901 }
2902 break;
2903 #endif
2904 case (CELL)FunctorDouble:
2905 {
2906 CELL *pt = RepAppl(d0);
2907 *st++ = pt[1];
2908 #if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
2909 *st++ = pt[2];
2910 #endif
2911 break;
2912 }
2913 }
2914 continue;
2915 }
2916 st = AddAtomToHash(st, NameOfFunctor(f));
2917 if (depth == 1)
2918 continue;
2919 if (to_visit + 1024 >= (CELL **)AuxSp) {
2920 goto aux_overflow;
2921 }
2922 #ifdef RATIONAL_TREES
2923 to_visit[0] = pt0;
2924 to_visit[1] = pt0_end;
2925 to_visit[2] = (CELL *)*pt0;
2926 to_visit[3] = (CELL *)(depth--);
2927 to_visit += 4;
2928 *pt0 = TermFoundVar;
2929 #else
2930 /* store the terms to visit */
2931 if (pt0 < pt0_end) {
2932 to_visit[0] = pt0;
2933 to_visit[1] = pt0_end;
2934 to_visit[2] = depth--;
2935 to_visit += 3;
2936 }
2937 #endif
2938 d0 = ArityOfFunctor(f);
2939 pt0 = ap2;
2940 pt0_end = ap2 + d0;
2941 }
2942 continue;
2943 }
2944
2945
2946 deref_body(d0, ptd0, hash_complex_unk, hash_complex_nvar);
2947 if (!variant)
2948 return NULL;
2949 else
2950 continue;
2951 }
2952 /* Do we still have compound terms to visit */
2953 if (to_visit > to_visit0) {
2954 #ifdef RATIONAL_TREES
2955 to_visit -= 4;
2956 pt0 = to_visit[0];
2957 pt0_end = to_visit[1];
2958 *pt0 = (CELL)to_visit[2];
2959 depth = (CELL)to_visit[3];
2960 #else
2961 to_visit -= 3;
2962 pt0 = to_visit[0];
2963 pt0_end = to_visit[1];
2964 depth = (CELL)to_visit[2];
2965 #endif
2966 goto loop;
2967 }
2968 return st;
2969
2970 aux_overflow:
2971 /* unwind stack */
2972 #ifdef RATIONAL_TREES
2973 while (to_visit > to_visit0) {
2974 to_visit -= 4;
2975 pt0 = to_visit[0];
2976 *pt0 = (CELL)to_visit[2];
2977 }
2978 #endif
2979 return (CELL *)-1;
2980
2981 global_overflow:
2982 /* unwind stack */
2983 #ifdef RATIONAL_TREES
2984 while (to_visit > to_visit0) {
2985 to_visit -= 4;
2986 pt0 = to_visit[0];
2987 *pt0 = (CELL)to_visit[2];
2988 }
2989 #endif
2990 return (CELL *) -2;
2991 }
2992
2993 Int
Yap_TermHash(Term t,Int size,Int depth,int variant)2994 Yap_TermHash(Term t, Int size, Int depth, int variant)
2995 {
2996 unsigned int i1;
2997 Term t1 = Deref(t);
2998
2999 while (TRUE) {
3000 CELL *ar = hash_complex_term(&t1-1, &t1, depth, H, FALSE);
3001 if (ar == (CELL *)-1) {
3002 if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
3003 Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "overflow in term_hash");
3004 return FALSE;
3005 }
3006 t1 = Deref(ARG1);
3007 } else if(ar == (CELL *)-2) {
3008 if (!Yap_gcl((ASP-H)*sizeof(CELL), 0, ENV, gc_P(P,CP))) {
3009 Yap_Error(OUT_OF_STACK_ERROR, TermNil, "in term_hash");
3010 return FALSE;
3011 }
3012 t1 = Deref(ARG1);
3013 } else if (ar == NULL) {
3014 return FALSE;
3015 } else {
3016 i1 = MurmurHashNeutral2((const void *)H, CellSize*(ar-H),0x1a3be34a);
3017 break;
3018 }
3019 }
3020 /* got the seed and hash from SWI-Prolog */
3021 return i1 % size;
3022 }
3023
3024 static Int
p_term_hash(void)3025 p_term_hash(void)
3026 {
3027 unsigned int i1;
3028 Term t1 = Deref(ARG1);
3029 Term t2 = Deref(ARG2);
3030 Term t3 = Deref(ARG3);
3031 Term result;
3032 Int size, depth;
3033
3034 if (IsVarTerm(t2)) {
3035 Yap_Error(INSTANTIATION_ERROR,t2,"term_hash/4");
3036 return(FALSE);
3037 }
3038 if (!IsIntegerTerm(t2)) {
3039 Yap_Error(TYPE_ERROR_INTEGER,t2,"term_hash/4");
3040 return(FALSE);
3041 }
3042 depth = IntegerOfTerm(t2);
3043 if (depth == 0) {
3044 if (IsVarTerm(t1)) return(TRUE);
3045 return(Yap_unify(ARG4,MkIntTerm(0)));
3046 }
3047 if (IsVarTerm(t3)) {
3048 Yap_Error(INSTANTIATION_ERROR,t3,"term_hash/4");
3049 return(FALSE);
3050 }
3051 if (!IsIntegerTerm(t3)) {
3052 Yap_Error(TYPE_ERROR_INTEGER,t3,"term_hash/4");
3053 return(FALSE);
3054 }
3055 size = IntegerOfTerm(t3);
3056 while (TRUE) {
3057 CELL *ar = hash_complex_term(&t1-1, &t1, depth, H, FALSE);
3058 if (ar == (CELL *)-1) {
3059 if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
3060 Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "overflow in term_hash");
3061 return FALSE;
3062 }
3063 t1 = Deref(ARG1);
3064 } else if(ar == (CELL *)-2) {
3065 if (!Yap_gcl((ASP-H)*sizeof(CELL), 4, ENV, gc_P(P,CP))) {
3066 Yap_Error(OUT_OF_STACK_ERROR, TermNil, "in term_hash");
3067 return FALSE;
3068 }
3069 t1 = Deref(ARG1);
3070 } else if (ar == NULL) {
3071 return FALSE;
3072 } else {
3073 i1 = MurmurHashNeutral2((const void *)H, CellSize*(ar-H),0x1a3be34a);
3074 break;
3075 }
3076 }
3077 /* got the seed and hash from SWI-Prolog */
3078 result = MkIntegerTerm(i1 % size);
3079 return Yap_unify(ARG4,result);
3080 }
3081
3082 static Int
p_instantiated_term_hash(void)3083 p_instantiated_term_hash(void)
3084 {
3085 unsigned int i1;
3086 Term t1 = Deref(ARG1);
3087 Term t2 = Deref(ARG2);
3088 Term t3 = Deref(ARG3);
3089 Term result;
3090 Int size, depth;
3091
3092 if (IsVarTerm(t2)) {
3093 Yap_Error(INSTANTIATION_ERROR,t2,"term_hash/4");
3094 return(FALSE);
3095 }
3096 if (!IsIntegerTerm(t2)) {
3097 Yap_Error(TYPE_ERROR_INTEGER,t2,"term_hash/4");
3098 return(FALSE);
3099 }
3100 depth = IntegerOfTerm(t2);
3101 if (depth == 0) {
3102 if (IsVarTerm(t1)) return(TRUE);
3103 return(Yap_unify(ARG4,MkIntTerm(0)));
3104 }
3105 if (IsVarTerm(t3)) {
3106 Yap_Error(INSTANTIATION_ERROR,t3,"term_hash/4");
3107 return(FALSE);
3108 }
3109 if (!IsIntegerTerm(t3)) {
3110 Yap_Error(TYPE_ERROR_INTEGER,t3,"term_hash/4");
3111 return(FALSE);
3112 }
3113 size = IntegerOfTerm(t3);
3114 while (TRUE) {
3115 CELL *ar = hash_complex_term(&t1-1, &t1, depth, H, TRUE);
3116 if (ar == (CELL *)-1) {
3117 if (!Yap_ExpandPreAllocCodeSpace(0, NULL, TRUE)) {
3118 Yap_Error(OUT_OF_AUXSPACE_ERROR, ARG1, "overflow in term_hash");
3119 return FALSE;
3120 }
3121 t1 = Deref(ARG1);
3122 } else if(ar == (CELL *)-2) {
3123 if (!Yap_gcl((ASP-H)*sizeof(CELL), 4, ENV, gc_P(P,CP))) {
3124 Yap_Error(OUT_OF_STACK_ERROR, TermNil, "in term_hash");
3125 return FALSE;
3126 }
3127 t1 = Deref(ARG1);
3128 } else if (ar == NULL) {
3129 return FALSE;
3130 } else {
3131 i1 = MurmurHashNeutral2((const void *)H, CellSize*(ar-H),0x1a3be34a);
3132 break;
3133 }
3134 }
3135 /* got the seed and hash from SWI-Prolog */
3136 result = MkIntegerTerm(i1 % size);
3137 return Yap_unify(ARG4,result);
3138 }
3139
variant_complex(register CELL * pt0,register CELL * pt0_end,register CELL * pt1)3140 static int variant_complex(register CELL *pt0, register CELL *pt0_end, register
3141 CELL *pt1)
3142 {
3143 tr_fr_ptr OLDTR = TR;
3144 register CELL **to_visit = (CELL **)ASP;
3145 /* make sure that unification always forces trailing */
3146 HBREG = H;
3147
3148
3149 loop:
3150 while (pt0 < pt0_end) {
3151 register CELL d0, d1;
3152 ++ pt0;
3153 ++ pt1;
3154 d0 = Derefa(pt0);
3155 d1 = Derefa(pt1);
3156 if (IsVarTerm(d0)) {
3157 if (IsVarTerm(d1)) {
3158 CELL *pt0 = VarOfTerm(d0);
3159 CELL *pt1 = VarOfTerm(d1);
3160 if (pt0 >= HBREG || pt1 >= HBREG) {
3161 /* one of the variables has been found before */
3162 if (VarOfTerm(d0)+1 == VarOfTerm(d1)) continue;
3163 goto fail;
3164 } else {
3165 /* two new occurrences of the same variable */
3166 Term n0 = MkVarTerm(), n1 = MkVarTerm();
3167 Bind_Global(VarOfTerm(d0), n0);
3168 Bind_Global(VarOfTerm(d1), n1);
3169 }
3170 continue;
3171 } else {
3172 goto fail;
3173 }
3174 } else if (IsVarTerm(d1)) {
3175 goto fail;
3176 } else {
3177 if (d0 == d1) continue;
3178 else if (IsAtomOrIntTerm(d0)) {
3179 goto fail;
3180 } else if (IsPairTerm(d0)) {
3181 if (!IsPairTerm(d1)) {
3182 goto fail;
3183 }
3184 #ifdef RATIONAL_TREES
3185 /* now link the two structures so that no one else will */
3186 /* come here */
3187 to_visit -= 4;
3188 if ((CELL *)to_visit < H+1024)
3189 goto out_of_stack;
3190 to_visit[0] = pt0;
3191 to_visit[1] = pt0_end;
3192 to_visit[2] = pt1;
3193 to_visit[3] = (CELL *)*pt0;
3194 *pt0 = d1;
3195 #else
3196 /* store the terms to visit */
3197 if (pt0 < pt0_end) {
3198 to_visit -= 3;
3199 if ((CELL *)to_visit < H+1024)
3200 goto out_of_stack;
3201 to_visit[0] = pt0;
3202 to_visit[1] = pt0_end;
3203 to_visit[2] = pt1;
3204 }
3205 #endif
3206 pt0 = RepPair(d0) - 1;
3207 pt0_end = RepPair(d0) + 1;
3208 pt1 = RepPair(d1) - 1;
3209 continue;
3210 } else if (IsApplTerm(d0)) {
3211 register Functor f;
3212 register CELL *ap2, *ap3;
3213 if (!IsApplTerm(d1)) {
3214 goto fail;
3215 } else {
3216 /* store the terms to visit */
3217 Functor f2;
3218 ap2 = RepAppl(d0);
3219 ap3 = RepAppl(d1);
3220 f = (Functor)(*ap2);
3221 f2 = (Functor)(*ap3);
3222 if (f != f2)
3223 goto fail;
3224 if (IsExtensionFunctor(f)) {
3225 if (!unify_extension(f, d0, ap2, d1))
3226 goto fail;
3227 continue;
3228 }
3229 #ifdef RATIONAL_TREES
3230 /* now link the two structures so that no one else will */
3231 /* come here */
3232 to_visit -= 4;
3233 if ((CELL *)to_visit < H+1024)
3234 goto out_of_stack;
3235 to_visit[0] = pt0;
3236 to_visit[1] = pt0_end;
3237 to_visit[2] = pt1;
3238 to_visit[3] = (CELL *)*pt0;
3239 *pt0 = d1;
3240 #else
3241 /* store the terms to visit */
3242 if (pt0 < pt0_end) {
3243 to_visit -= 3;
3244 if ((CELL *)to_visit < H+1024)
3245 goto out_of_stack;
3246 to_visit[0] = pt0;
3247 to_visit[1] = pt0_end;
3248 to_visit[2] = pt1;
3249 }
3250 #endif
3251 d0 = ArityOfFunctor(f);
3252 pt0 = ap2;
3253 pt0_end = ap2 + d0;
3254 pt1 = ap3;
3255 continue;
3256 }
3257 }
3258 }
3259 }
3260 /* Do we still have compound terms to visit */
3261 if (to_visit < (CELL **)ASP) {
3262 #ifdef RATIONAL_TREES
3263 pt0 = to_visit[0];
3264 pt0_end = to_visit[1];
3265 pt1 = to_visit[2];
3266 *pt0 = (CELL)to_visit[3];
3267 to_visit += 4;
3268 #else
3269 pt0 = to_visit[0];
3270 pt0_end = to_visit[1];
3271 pt1 = to_visit[2];
3272 to_visit += 3;
3273 #endif
3274 goto loop;
3275 }
3276
3277 H = HBREG;
3278 /* untrail all bindings made by variant */
3279 while (TR != (tr_fr_ptr)OLDTR) {
3280 CELL *pt1 = (CELL *) TrailTerm(--TR);
3281 RESET_VARIABLE(pt1);
3282 }
3283 HBREG = B->cp_h;
3284 return TRUE;
3285
3286 out_of_stack:
3287 H = HBREG;
3288 /* untrail all bindings made by variant */
3289 #ifdef RATIONAL_TREES
3290 while (to_visit < (CELL **)ASP) {
3291 pt0 = to_visit[0];
3292 pt0_end = to_visit[1];
3293 pt1 = to_visit[2];
3294 *pt0 = (CELL)to_visit[3];
3295 to_visit += 4;
3296 }
3297 #endif
3298 while (TR != (tr_fr_ptr)OLDTR) {
3299 CELL *pt1 = (CELL *) TrailTerm(--TR);
3300 RESET_VARIABLE(pt1);
3301 }
3302 HBREG = B->cp_h;
3303 return -1;
3304
3305
3306 fail:
3307 /* failure */
3308 H = HBREG;
3309 #ifdef RATIONAL_TREES
3310 while (to_visit < (CELL **)ASP) {
3311 pt0 = to_visit[0];
3312 pt0_end = to_visit[1];
3313 pt1 = to_visit[2];
3314 *pt0 = (CELL)to_visit[3];
3315 to_visit += 4;
3316 }
3317 #endif
3318 /* untrail all bindings made by variant */
3319 while (TR != (tr_fr_ptr)OLDTR) {
3320 CELL *pt1 = (CELL *) TrailTerm(--TR);
3321 RESET_VARIABLE(pt1);
3322 }
3323 HBREG = B->cp_h;
3324 return FALSE;
3325 }
3326
3327 static int
is_variant(Term t1,Term t2,int parity)3328 is_variant(Term t1, Term t2, int parity)
3329 {
3330 int out;
3331
3332 if (t1 == t2)
3333 return (TRUE);
3334 if (IsVarTerm(t1)) {
3335 if (IsVarTerm(t2))
3336 return(TRUE);
3337 return(FALSE);
3338 } else if (IsVarTerm(t2))
3339 return(FALSE);
3340 if (IsAtomOrIntTerm(t1)) {
3341 return(t1 == t2);
3342 }
3343 if (IsPairTerm(t1)) {
3344 if (IsPairTerm(t2)) {
3345 out = variant_complex(RepPair(t1)-1,
3346 RepPair(t1)+1,
3347 RepPair(t2)-1);
3348 if (out < 0) goto error;
3349 return out;
3350 }
3351 else return (FALSE);
3352 }
3353 if (!IsApplTerm(t2)) {
3354 return FALSE;
3355 } else {
3356 Functor f1 = FunctorOfTerm(t1);
3357
3358 if (f1 != FunctorOfTerm(t2)) return(FALSE);
3359 if (IsExtensionFunctor(f1)) {
3360 return(unify_extension(f1, t1, RepAppl(t1), t2));
3361 }
3362 out = variant_complex(RepAppl(t1),
3363 RepAppl(t1)+ArityOfFunctor(f1),
3364 RepAppl(t2));
3365 if (out < 0) goto error;
3366 return out;
3367 }
3368 error:
3369 if (out == -1) {
3370 if (!Yap_gcl((ASP-H)*sizeof(CELL), parity, ENV, gc_P(P,CP))) {
3371 Yap_Error(OUT_OF_STACK_ERROR, TermNil, "in variant");
3372 return FALSE;
3373 }
3374 return is_variant(t1, t2, parity);
3375 }
3376 return FALSE;
3377 }
3378
3379 int
Yap_Variant(Term t1,Term t2)3380 Yap_Variant(Term t1, Term t2)
3381 {
3382 return is_variant(t1, t2, 0);
3383 }
3384
3385 static Int
p_variant(void)3386 p_variant(void) /* variant terms t1 and t2 */
3387 {
3388 return is_variant(Deref(ARG1), Deref(ARG2), 2);
3389 }
3390
3391
subsumes_complex(register CELL * pt0,register CELL * pt0_end,register CELL * pt1)3392 static int subsumes_complex(register CELL *pt0, register CELL *pt0_end, register
3393 CELL *pt1)
3394 {
3395 register CELL **to_visit = (CELL **)ASP;
3396 tr_fr_ptr OLDTR = TR, new_tr;
3397 UInt write_mode = TRUE;
3398
3399
3400 HBREG = H;
3401 loop:
3402 while (pt0 < pt0_end) {
3403 register CELL d0, d1;
3404 Int our_write_mode = write_mode;
3405
3406 ++ pt0;
3407 ++ pt1;
3408 /* this is a version of Derefa that checks whether we are trying to
3409 do something evil */
3410 {
3411 CELL *npt0 = pt0;
3412
3413 restart_d0:
3414 if (npt0 >= HBREG) {
3415 our_write_mode = FALSE;
3416 }
3417 d0 = *npt0;
3418 if (IsVarTerm(d0) &&
3419 d0 != (CELL)npt0
3420 ) {
3421 npt0 = (CELL *)d0;
3422 goto restart_d0;
3423 }
3424 }
3425 {
3426 CELL *npt1 = pt1;
3427
3428 restart_d1:
3429 d1 = *npt1;
3430 if (IsVarTerm(d1)
3431 && d1 != (CELL)npt1
3432 ) {
3433 /* never dereference through a variable from the left-side */
3434 if (npt1 >= HBREG) {
3435 goto fail;
3436 } else {
3437 npt1 = (CELL *)d1;
3438 goto restart_d1;
3439 }
3440 }
3441 }
3442 if (IsVarTerm(d0)) {
3443 if (our_write_mode) {
3444 /* generate a new binding */
3445 CELL *pt0 = VarOfTerm(d0);
3446 Term new = MkVarTerm();
3447
3448 Bind_Global(pt0, new);
3449 if (d0 != d1) { /* avoid loops */
3450 Bind_Global(VarOfTerm(new), d1);
3451 if (Yap_rational_tree_loop(VarOfTerm(new)-1,VarOfTerm(new),(CELL **)AuxSp,(CELL **)AuxBase))
3452 goto fail;
3453 }
3454 } else {
3455 if (d0 == d1) continue;
3456 goto fail;
3457 }
3458 continue;
3459 } else if (IsVarTerm(d1)) {
3460 goto fail;
3461 } else {
3462 if (d0 == d1) continue;
3463 else if (IsAtomOrIntTerm(d0)) {
3464 goto fail;
3465 } else if (IsPairTerm(d0)) {
3466 if (!IsPairTerm(d1)) {
3467 goto fail;
3468 }
3469 #ifdef RATIONAL_TREES
3470 /* now link the two structures so that no one else will */
3471 /* come here */
3472 to_visit -= 5;
3473 to_visit[0] = pt0;
3474 to_visit[1] = pt0_end;
3475 to_visit[2] = pt1;
3476 to_visit[3] = (CELL *)*pt0;
3477 to_visit[4] = (CELL *)write_mode;
3478 *pt0 = d1;
3479 #else
3480 /* store the terms to visit */
3481 if (pt0 < pt0_end) {
3482 to_visit -= 4;
3483 to_visit[0] = pt0;
3484 to_visit[1] = pt0_end;
3485 to_visit[2] = pt1;
3486 to_visit[3] = (CELL *)write_mode;
3487 }
3488 #endif
3489 write_mode = our_write_mode;
3490 pt0 = RepPair(d0) - 1;
3491 pt0_end = RepPair(d0) + 1;
3492 pt1 = RepPair(d1) - 1;
3493 continue;
3494 } else if (IsApplTerm(d0)) {
3495 register Functor f;
3496 register CELL *ap2, *ap3;
3497 if (!IsApplTerm(d1)) {
3498 goto fail;
3499 } else {
3500 /* store the terms to visit */
3501 Functor f2;
3502 ap2 = RepAppl(d0);
3503 ap3 = RepAppl(d1);
3504 f = (Functor)(*ap2);
3505 f2 = (Functor)(*ap3);
3506 if (f != f2)
3507 goto fail;
3508 if (IsExtensionFunctor(f)) {
3509 if (!unify_extension(f, d0, ap2, d1))
3510 goto fail;
3511 continue;
3512 }
3513 #ifdef RATIONAL_TREES
3514 /* now link the two structures so that no one else will */
3515 /* come here */
3516 to_visit -= 5;
3517 to_visit[0] = pt0;
3518 to_visit[1] = pt0_end;
3519 to_visit[2] = pt1;
3520 to_visit[3] = (CELL *)*pt0;
3521 to_visit[4] = (CELL *)write_mode;
3522 *pt0 = d1;
3523 #else
3524 /* store the terms to visit */
3525 if (pt0 < pt0_end) {
3526 to_visit -= 4;
3527 to_visit[0] = pt0;
3528 to_visit[1] = pt0_end;
3529 to_visit[2] = pt1;
3530 to_visit[3] = (CELL *)write_mode;
3531 }
3532 #endif
3533 write_mode = our_write_mode;
3534 d0 = ArityOfFunctor(f);
3535 pt0 = ap2;
3536 pt0_end = ap2 + d0;
3537 pt1 = ap3;
3538 continue;
3539 }
3540 }
3541 }
3542 }
3543 /* Do we still have compound terms to visit */
3544 if (to_visit < (CELL **)ASP) {
3545 #ifdef RATIONAL_TREES
3546 pt0 = to_visit[0];
3547 pt0_end = to_visit[1];
3548 pt1 = to_visit[2];
3549 *pt0 = (CELL)to_visit[3];
3550 write_mode = (Int)to_visit[ 4];
3551 to_visit += 5;
3552 #else
3553 pt0 = to_visit[0];
3554 pt0_end = to_visit[1];
3555 pt1 = to_visit[2];
3556 write_mode = (UInt)to_visit[3];
3557 to_visit += 4;
3558 #endif
3559 goto loop;
3560 }
3561
3562 H = HBREG;
3563 /* get rid of intermediate variables */
3564 new_tr = TR;
3565 while (TR != OLDTR) {
3566 /* cell we bound */
3567 CELL *pt1 = (CELL *) TrailTerm(--TR);
3568 /* cell we created */
3569 CELL *npt1 = (CELL *)*pt1;
3570 /* shorten the chain */
3571 if (IsVarTerm(*pt1) && IsUnboundVar(pt1)) {
3572 RESET_VARIABLE(pt1);
3573 } else {
3574 *pt1 = *npt1;
3575 }
3576 }
3577 TR = new_tr;
3578 HBREG = B->cp_h;
3579 return TRUE;
3580
3581 fail:
3582 H = HBREG;
3583 #ifdef RATIONAL_TREES
3584 while (to_visit < (CELL **)ASP) {
3585 pt0 = to_visit[0];
3586 pt0_end = to_visit[1];
3587 pt1 = to_visit[2];
3588 *pt0 = (CELL)to_visit[3];
3589 to_visit += 5;
3590 }
3591 #endif
3592 /* untrail all bindings made by variant */
3593 while (TR != (tr_fr_ptr)OLDTR) {
3594 CELL *pt1 = (CELL *) TrailTerm(--TR);
3595 RESET_VARIABLE(pt1);
3596 }
3597 HBREG = B->cp_h;
3598 return FALSE;
3599 }
3600
3601 static Int
p_subsumes(void)3602 p_subsumes(void) /* subsumes terms t1 and t2 */
3603 {
3604 Term t1 = Deref(ARG1);
3605 Term t2 = Deref(ARG2);
3606
3607 if (t1 == t2)
3608 return (TRUE);
3609 if (IsVarTerm(t1)) {
3610 Bind(VarOfTerm(t1), t2);
3611 if (Yap_rational_tree_loop(VarOfTerm(t1)-1,VarOfTerm(t1),(CELL **)AuxSp,(CELL **)AuxBase))
3612 return FALSE;
3613 return TRUE;
3614 } else if (IsVarTerm(t2))
3615 return(FALSE);
3616 if (IsAtomOrIntTerm(t1)) {
3617 return(t1 == t2);
3618 }
3619 if (IsPairTerm(t1)) {
3620 if (IsPairTerm(t2)) {
3621 return(subsumes_complex(RepPair(t1)-1,
3622 RepPair(t1)+1,
3623 RepPair(t2)-1));
3624 }
3625 else return (FALSE);
3626 } else {
3627 Functor f1;
3628
3629 if (!IsApplTerm(t2)) return(FALSE);
3630 f1 = FunctorOfTerm(t1);
3631 if (f1 != FunctorOfTerm(t2))
3632 return(FALSE);
3633 if (IsExtensionFunctor(f1)) {
3634 return(unify_extension(f1, t1, RepAppl(t1), t2));
3635 }
3636 return(subsumes_complex(RepAppl(t1),
3637 RepAppl(t1)+ArityOfFunctor(f1),
3638 RepAppl(t2)));
3639 }
3640 }
3641
3642 #ifdef DEBUG
3643 static Int
p_force_trail_expansion()3644 p_force_trail_expansion()
3645 {
3646 Int i = IntOfTerm(Deref(ARG1))*1024, j = 0;
3647 tr_fr_ptr OTR = TR;
3648
3649 for (j = 0; j < i; j++) {
3650 TrailTerm(TR) = 0;
3651 TR++;
3652 }
3653 TR = OTR;
3654
3655 return(TRUE);
3656 }
3657
3658 static Int
camacho_dum(void)3659 camacho_dum(void)
3660 {
3661 Term t1, t2;
3662 int max = 3;
3663
3664 /* build output list */
3665
3666 t1 = TermNil;
3667 t2 = MkPairTerm(MkIntegerTerm(max), t1);
3668
3669 return(Yap_unify(t2, ARG1));
3670 }
3671
3672
3673
3674 #endif /* DEBUG */
3675
3676 int
Yap_IsListTerm(Term t)3677 Yap_IsListTerm(Term t)
3678 {
3679 while (!IsVarTerm(t) && IsPairTerm(t)) {
3680 t = TailOfTerm(t);
3681 }
3682 return t == TermNil;
3683 }
3684
3685 static Int
p_is_list(void)3686 p_is_list(void)
3687 {
3688 return Yap_IsListTerm(Deref(ARG1));
3689 }
3690
3691
3692
Yap_InitUtilCPreds(void)3693 void Yap_InitUtilCPreds(void)
3694 {
3695 Term cm = CurrentModule;
3696 Yap_InitCPred("copy_term", 2, p_copy_term, 0);
3697 Yap_InitCPred("duplicate_term", 2, p_duplicate_term, 0);
3698 Yap_InitCPred("copy_term_nat", 2, p_copy_term_no_delays, 0);
3699 Yap_InitCPred("ground", 1, p_ground, SafePredFlag);
3700 Yap_InitCPred("$variables_in_term", 3, p_variables_in_term, HiddenPredFlag);
3701 Yap_InitCPred("$non_singletons_in_term", 3, p_non_singletons_in_term, HiddenPredFlag);
3702 Yap_InitCPred("term_variables", 2, p_term_variables, 0);
3703 Yap_InitCPred("term_variables", 3, p_term_variables3, 0);
3704 Yap_InitCPred("term_attvars", 2, p_term_attvars, 0);
3705 Yap_InitCPred("is_list", 1, p_is_list, SafePredFlag);
3706 Yap_InitCPred("=@=", 2, p_variant, 0);
3707 #ifdef DEBUG_IMPORT
3708 Yap_InitCPred("import_term", 1, p_import_term, 0);
3709 Yap_InitCPred("export_term", 1, p_export_term, 0);
3710 #endif
3711 CurrentModule = TERMS_MODULE;
3712 Yap_InitCPred("variable_in_term", 2, p_var_in_term, 0);
3713 Yap_InitCPred("term_hash", 4, p_term_hash, 0);
3714 Yap_InitCPred("instantiated_term_hash", 4, p_instantiated_term_hash, 0);
3715 Yap_InitCPred("variant", 2, p_variant, 0);
3716 Yap_InitCPred("subsumes", 2, p_subsumes, 0);
3717 Yap_InitCPred("variables_within_term", 3, p_variables_within_term, 0);
3718 Yap_InitCPred("new_variables_in_term", 3, p_new_variables_in_term, 0);
3719 CurrentModule = cm;
3720 #ifdef DEBUG
3721 Yap_InitCPred("$force_trail_expansion", 1, p_force_trail_expansion, SafePredFlag|HiddenPredFlag);
3722 Yap_InitCPred("dum", 1, camacho_dum, SafePredFlag);
3723 #endif
3724 }
3725
3726