This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/C/utilpreds.c
2003-10-28 16:20:44 +00:00

1715 lines
36 KiB
C

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: utilpreds.c *
* Last rev: 4/03/88 *
* mods: *
* comments: new utility predicates for YAP *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "@(#)utilpreds.c 1.3";
#endif
#include "Yap.h"
#include "Yatom.h"
#include "Heap.h"
#include "yapio.h"
#include "eval.h"
typedef struct {
Term old_var;
Term new_var;
} *vcell;
STATIC_PROTO(int copy_complex_term, (CELL *, CELL *, CELL *, CELL *));
STATIC_PROTO(CELL vars_in_complex_term, (CELL *, CELL *));
STATIC_PROTO(Int p_non_singletons_in_term, (void));
STATIC_PROTO(CELL non_singletons_in_complex_term, (CELL *, CELL *));
STATIC_PROTO(Int p_variables_in_term, (void));
STATIC_PROTO(Int ground_complex_term, (CELL *, CELL *));
STATIC_PROTO(Int p_ground, (void));
STATIC_PROTO(Int p_copy_term, (void));
STATIC_PROTO(Int var_in_complex_term, (CELL *, CELL *, Term));
#ifdef DEBUG
STATIC_PROTO(Int p_force_trail_expansion, (void));
#endif /* DEBUG */
static inline void
clean_tr(tr_fr_ptr TR0) {
if (TR != TR0) {
do {
Term p = TrailTerm(--TR);
RESET_VARIABLE(p);
} while (TR != TR0);
}
}
static int
copy_complex_term(register CELL *pt0, register CELL *pt0_end, CELL *ptf, CELL *HLow)
{
CELL **to_visit = (CELL **)(HeapTop + sizeof(CELL));
tr_fr_ptr TR0 = TR;
CELL *HB0 = HB;
#ifdef COROUTINING
CELL *dvars = NULL;
#endif
HB = HLow;
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++ pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, copy_term_unk);
copy_term_nvar:
{
if (IsPairTerm(d0)) {
CELL *ap2 = RepPair(d0);
if (ap2 >= HB && ap2 < H) {
/* If this is newer than the current term, just reuse */
*ptf++ = d0;
continue;
}
*ptf = AbsPair(H);
ptf++;
#ifdef RATIONAL_TREES
if (to_visit + 4 >= (CELL **)Yap_GlobalBase) {
goto heap_overflow;
}
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = ptf;
to_visit[3] = (CELL *)*pt0;
/* fool the system into thinking we had a variable there */
*pt0 = AbsPair(H);
to_visit += 4;
#else
if (pt0 < pt0_end) {
if (to_visit + 3 >= (CELL **)Yap_GlobalBase) {
goto heap_overflow;
}
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = ptf;
to_visit += 3;
}
#endif
pt0 = ap2 - 1;
pt0_end = ap2 + 1;
ptf = H;
H += 2;
if (H > ASP - 2048) {
goto overflow;
}
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
if (ap2 >= HB && ap2 < H) {
/* If this is newer than the current term, just reuse */
*ptf++ = d0;
continue;
}
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
{
*ptf++ = d0; /* you can just copy other extensions. */
}
continue;
}
*ptf = AbsAppl(H);
ptf++;
/* store the terms to visit */
#ifdef RATIONAL_TREES
if (to_visit + 4 >= (CELL **)Yap_GlobalBase) {
goto heap_overflow;
}
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = ptf;
to_visit[3] = (CELL *)*pt0;
/* fool the system into thinking we had a variable there */
*pt0 = AbsAppl(H);
to_visit += 4;
#else
if (pt0 < pt0_end) {
if (to_visit + 3 >= (CELL **)Yap_GlobalBase) {
goto heap_overflow;
}
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = ptf;
to_visit += 3;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
/* store the functor for the new term */
H[0] = (CELL)f;
ptf = H+1;
H += 1+d0;
if (H > ASP - 2048) {
goto overflow;
}
} else {
/* just copy atoms or integers */
*ptf++ = d0;
}
continue;
}
derefa_body(d0, ptd0, copy_term_unk, copy_term_nvar);
if (ptd0 >= HLow && ptd0 < H) {
/* we have already found this cell */
*ptf++ = (CELL) ptd0;
} else {
#if COROUTINING
if (IsAttachedTerm((CELL)ptd0)) {
/* if unbound, call the standard copy term routine */
CELL **bp[1];
tr_fr_ptr CurTR;
if (ptd0 >= dvars) {
*ptf++ = (CELL) ptd0;
} else {
if (dvars == NULL) {
dvars = (CELL *)Yap_ReadTimedVar(DelayedVars);
}
bp[0] = to_visit;
CurTR = TR;
HB = HB0;
if (!attas[ExtFromCell(ptd0)].copy_term_op(ptd0, bp, ptf)) {
goto overflow;
}
to_visit = bp[0];
HB = HLow;
if (CurTR != TR) {
/* Problem here is that the attached routine might
* have changed the list of suspended goals and stored
* new entries in the trail. This should be quite
* rare, so for simplicity we just swap cells from
* bottom and top of Trail, not nice but not worth
* complicating everything else.
*/
CELL *pt1 = (CELL *)TR0;
CELL *pt2 = (CELL *)CurTR;
while (pt2 < (CELL *)TR) {
CELL o = *pt1;
pt1++;
pt2++;
pt1[-1] = pt2[-1];
pt2[-1] = o;
}
TR0 = (tr_fr_ptr)pt1;
}
ptf++;
Bind_Global(ptd0, ptf[-1]);
}
} else {
#endif
/* first time we met this term */
RESET_VARIABLE(ptf);
Bind_Global(ptd0, (CELL)ptf);
ptf++;
#ifdef COROUTINING
}
#endif
}
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
#ifdef RATIONAL_TREES
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
ptf = to_visit[2];
*pt0 = (CELL)to_visit[3];
#else
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
ptf = to_visit[2];
#endif
goto loop;
}
/* restore our nice, friendly, term to its original state */
HB = HB0;
clean_tr(TR0);
return(0);
overflow:
/* oops, we're in trouble */
H = HLow;
/* we've done it */
/* restore our nice, friendly, term to its original state */
HB = HB0;
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
ptf = to_visit[2];
*pt0 = (CELL)to_visit[3];
}
#endif
clean_tr(TR0);
return(-1);
heap_overflow:
/* oops, we're in trouble */
H = HLow;
/* we've done it */
/* restore our nice, friendly, term to its original state */
HB = HB0;
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
ptf = to_visit[2];
*pt0 = (CELL)to_visit[3];
}
#endif
clean_tr(TR0);
return(-2);
}
static Term
CopyTerm(Term inp) {
Term t = Deref(inp);
if (IsVarTerm(t)) {
#if COROUTINING
if (IsAttachedTerm(t)) {
CELL *Hi;
int res;
restart_attached:
*H = t;
Hi = H+1;
H += 2;
if ((res = copy_complex_term(Hi-2, Hi-1, Hi, Hi)) < 0) {
ARG1 = t;
if (res == -1) { /* handle overflow */
if (!Yap_gc(2, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_attached;
} else { /* handle overflow */
if (!Yap_growheap(FALSE, 0)) {
Yap_Error(SYSTEM_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_attached;
}
}
return(Hi[0]);
}
#endif
return(MkVarTerm());
} else if (IsPrimitiveTerm(t)) {
return(t);
} else if (IsPairTerm(t)) {
Term tf;
CELL *ap;
CELL *Hi;
restart_list:
ap = RepPair(t);
Hi = H;
tf = AbsPair(H);
H += 2;
{
int res;
if ((res = copy_complex_term(ap-1, ap+1, Hi, Hi)) < 0) {
ARG1 = t;
if (res == -1) { /* handle overflow */
if (!Yap_gc(2, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_list;
} else { /* handle overflow */
if (!Yap_growheap(FALSE, 0)) {
Yap_Error(SYSTEM_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_list;
}
}
}
return(tf);
} else {
Functor f = FunctorOfTerm(t);
Term tf;
CELL *HB0;
CELL *ap;
restart_appl:
f = FunctorOfTerm(t);
HB0 = H;
ap = RepAppl(t);
tf = AbsAppl(H);
H[0] = (CELL)f;
H += 1+ArityOfFunctor(f);
{
int res;
if ((res = copy_complex_term(ap, ap+ArityOfFunctor(f), HB0+1, HB0)) < 0) {
ARG1 = t;
if (res == -1) {
if (!Yap_gc(2, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_appl;
} else { /* handle overflow */
if (!Yap_growheap(FALSE, 0)) {
Yap_Error(SYSTEM_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_appl;
}
}
}
return(tf);
}
}
Term
Yap_CopyTerm(Term inp) {
return CopyTerm(inp);
}
static Int
p_copy_term(void) /* copy term t to a new instance */
{
return(Yap_unify(ARG2,CopyTerm(ARG1)));
}
static int copy_complex_term_no_delays(register CELL *pt0, register CELL *pt0_end, CELL *ptf, CELL *HLow)
{
CELL **to_visit = (CELL **)(HeapTop + sizeof(CELL));
tr_fr_ptr TR0 = TR;
CELL *HB0 = HB;
HB = HLow;
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++ pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, copy_term_unk);
copy_term_nvar:
{
if (IsPairTerm(d0)) {
CELL *ap2 = RepPair(d0);
if (ap2 >= HB && ap2 < H) {
/* If this is newer than the current term, just reuse */
*ptf++ = d0;
continue;
}
*ptf = AbsPair(H);
ptf++;
#ifdef RATIONAL_TREES
if (to_visit + 4 >= (CELL **)Yap_GlobalBase) {
goto heap_overflow;
}
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = ptf;
to_visit[3] = (CELL *)*pt0;
/* fool the system into thinking we had a variable there */
*pt0 = AbsPair(H);
to_visit += 4;
#else
if (pt0 < pt0_end) {
if (to_visit + 3 >= (CELL **)Yap_GlobalBase) {
goto heap_overflow;
}
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = ptf;
to_visit += 3;
}
#endif
pt0 = ap2 - 1;
pt0_end = ap2 + 1;
ptf = H;
H += 2;
if (H > ENV - 2048) {
goto overflow;
}
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
if (ap2 >= HB && ap2 < H) {
/* If this is newer than the current term, just reuse */
*ptf++ = d0;
continue;
}
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
*ptf++ = d0; /* you can just copy other extensions. */
continue;
}
*ptf = AbsAppl(H);
ptf++;
/* store the terms to visit */
#ifdef RATIONAL_TREES
if (to_visit + 4 >= (CELL **)Yap_GlobalBase) {
goto heap_overflow;
}
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = ptf;
to_visit[3] = (CELL *)*pt0;
/* fool the system into thinking we had a variable there */
*pt0 = AbsAppl(H);
to_visit += 4;
#else
if (to_visit + 3 >= (CELL **)Yap_GlobalBase) {
goto heap_overflow;
}
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = ptf;
to_visit += 3;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
/* store the functor for the new term */
H[0] = (CELL)f;
ptf = H+1;
H += 1+d0;
if (H > ENV - 2048) {
goto overflow;
}
} else {
/* just copy atoms or integers */
*ptf++ = d0;
}
continue;
}
derefa_body(d0, ptd0, copy_term_unk, copy_term_nvar);
if (ptd0 >= HLow && ptd0 < H) {
/* we have already found this cell */
*ptf++ = (CELL) ptd0;
} else {
/* first time we met this term */
RESET_VARIABLE(ptf);
Bind_Global(ptd0, (CELL)ptf);
ptf++;
}
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
#ifdef RATIONAL_TREES
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
ptf = to_visit[2];
*pt0 = (CELL)to_visit[3];
#else
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
ptf = to_visit[2];
#endif
goto loop;
}
/* we've done it */
/* restore our nice, friendly, term to its original state */
HB = HB0;
clean_tr(TR0);
return(0);
overflow:
/* oops, we're in trouble */
H = HLow;
/* we've done it */
/* restore our nice, friendly, term to its original state */
HB = HB0;
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
ptf = to_visit[2];
*pt0 = (CELL)to_visit[3];
}
#endif
clean_tr(TR0);
return(-1);
heap_overflow:
/* oops, we're in trouble */
H = HLow;
/* we've done it */
/* restore our nice, friendly, term to its original state */
HB = HB0;
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
ptf = to_visit[2];
*pt0 = (CELL)to_visit[3];
}
#endif
clean_tr(TR0);
return(-2);
}
static Term
CopyTermNoDelays(Term inp) {
Term t = Deref(inp);
int res;
if (IsVarTerm(t)) {
return(MkVarTerm());
} else if (IsPrimitiveTerm(t)) {
return(t);
} else if (IsPairTerm(t)) {
Term tf;
CELL *ap, *Hi;
restart_list:
Hi = H;
ap = RepPair(t);
tf = AbsPair(H);
H += 2;
res = copy_complex_term_no_delays(ap-1, ap+1, H-2, H-2);
if (res) {
if (res == -1) { /* handle overflow */
if (!Yap_gc(2, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_list;
} else { /* handle overflow */
if (!Yap_growheap(FALSE, 0)) {
Yap_Error(SYSTEM_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_list;
}
}
return(tf);
} else {
Functor f;
Term tf;
CELL *HB0;
CELL *ap;
restart_appl:
f = FunctorOfTerm(t);
HB0 = H;
ap = RepAppl(t);
tf = AbsAppl(H);
H[0] = (CELL)f;
H += 1+ArityOfFunctor(f);
res = copy_complex_term_no_delays(ap, ap+ArityOfFunctor(f), HB0+1, HB0);
if (res) {
if (res == -1) {
if (!Yap_gc(2, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_appl;
} else { /* handle overflow */
if (!Yap_growheap(FALSE, 0)) {
Yap_Error(SYSTEM_ERROR, TermNil, Yap_ErrorMessage);
return(FALSE);
}
t = Deref(ARG1);
goto restart_appl;
}
}
return(tf);
}
}
static Int
p_copy_term_no_delays(void) /* copy term t to a new instance */
{
return(Yap_unify(ARG2,CopyTermNoDelays(ARG1)));
}
static Term vars_in_complex_term(register CELL *pt0, register CELL *pt0_end)
{
register CELL **to_visit = (CELL **)(HeapTop + sizeof(CELL));
register tr_fr_ptr TR0 = TR;
CELL *InitialH = H;
CELL output = AbsPair(H);
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++ pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, vars_in_term_unk);
vars_in_term_nvar:
{
if (IsPairTerm(d0)) {
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
continue;
}
/* store the terms to visit */
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
}
continue;
}
derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar);
/* do or pt2 are unbound */
*ptd0 = TermNil;
/* leave an empty slot to fill in later */
H[1] = AbsPair(H+2);
H += 2;
H[-2] = (CELL)ptd0;
/* next make sure noone will see this as a variable again */
TrailTerm(TR++) = (CELL)ptd0;
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
#ifdef RATIONAL_TREES
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
#else
to_visit -= 2;
pt0 = to_visit[0];
pt0_end = to_visit[1];
#endif
goto loop;
}
clean_tr(TR0);
if (H != InitialH) {
/* close the list */
Term t2 = Deref(ARG2);
if (IsVarTerm(t2)) {
RESET_VARIABLE(H-1);
Yap_unify((CELL)(H-1),ARG2);
} else {
H[-1] = t2; /* don't need to trail */
}
return(output);
} else {
return(ARG2);
}
}
static Int
p_variables_in_term(void) /* variables in term t */
{
Term t = Deref(ARG1);
Term out;
if (IsVarTerm(t)) {
out = AbsPair(H);
H += 2;
RESET_VARIABLE(H-2);
RESET_VARIABLE(H-1);
Yap_unify((CELL)(H-2),ARG1);
Yap_unify((CELL)(H-1),ARG2);
} else if (IsPrimitiveTerm(t))
out = ARG2;
else if (IsPairTerm(t)) {
out = vars_in_complex_term(RepPair(t)-1,
RepPair(t)+1);
}
else {
Functor f = FunctorOfTerm(t);
out = vars_in_complex_term(RepAppl(t),
RepAppl(t)+
ArityOfFunctor(f));
}
return(Yap_unify(ARG3,out));
}
static Term non_singletons_in_complex_term(register CELL *pt0, register CELL *pt0_end)
{
register CELL **to_visit = (CELL **)(HeapTop + sizeof(CELL));
register tr_fr_ptr TR0 = TR;
CELL *InitialH = H;
CELL output = AbsPair(H);
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++ pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, vars_in_term_unk);
vars_in_term_nvar:
{
if (IsPairTerm(d0)) {
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
continue;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
} else if (d0 == TermFoundVar) {
CELL *pt2 = pt0;
while(IsVarTerm(*pt2))
pt2 = (CELL *)(*pt2);
H[1] = AbsPair(H+2);
H += 2;
H[-2] = (CELL)pt2;
*pt2 = TermReFoundVar;
}
continue;
}
derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar);
/* do or pt2 are unbound */
*ptd0 = TermFoundVar;
/* next make sure we can recover the variable again */
TrailTerm(TR++) = (CELL)ptd0;
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
#ifdef RATIONAL_TREES
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
#else
to_visit -= 2;
pt0 = to_visit[0];
pt0_end = to_visit[1];
#endif
goto loop;
}
clean_tr(TR0);
if (H != InitialH) {
/* close the list */
RESET_VARIABLE(H-1);
Yap_unify((CELL)(H-1),ARG2);
return(output);
} else {
return(ARG2);
}
}
static Int
p_non_singletons_in_term(void) /* non_singletons in term t */
{
Term t = Deref(ARG1);
Term out;
if (IsVarTerm(t)) {
out = MkPairTerm(t,ARG2);
} else if (IsPrimitiveTerm(t))
out = ARG2;
else if (IsPairTerm(t)) {
out = non_singletons_in_complex_term(RepPair(t)-1,
RepPair(t)+1);
}
else out = non_singletons_in_complex_term(RepAppl(t),
RepAppl(t)+
ArityOfFunctor(FunctorOfTerm(t)));
return(Yap_unify(ARG3,out));
}
static Int ground_complex_term(register CELL *pt0, register CELL *pt0_end)
{
register CELL **to_visit = (CELL **)(HeapTop + sizeof(CELL));
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, vars_in_term_unk);
vars_in_term_nvar:
{
if (IsPairTerm(d0)) {
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
continue;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
}
continue;
}
derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar);
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
}
#endif
return(FALSE);
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
#ifdef RATIONAL_TREES
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
#else
to_visit -= 2;
pt0 = to_visit[0];
pt0_end = to_visit[1];
#endif
goto loop;
}
return(TRUE);
}
static Int
p_ground(void) /* ground(+T) */
{
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
return(FALSE);
} else if (IsPrimitiveTerm(t)) {
return(TRUE);
} else if (IsPairTerm(t)) {
return(ground_complex_term(RepPair(t)-1,
RepPair(t)+1));
} else {
Functor fun = FunctorOfTerm(t);
if (IsExtensionFunctor(fun))
return(TRUE);
else return(ground_complex_term(RepAppl(t),
RepAppl(t)+
ArityOfFunctor(fun)));
}
}
static Int var_in_complex_term(register CELL *pt0,
register CELL *pt0_end,
Term v)
{
register CELL **to_visit = (CELL **)(HeapTop + sizeof(CELL));
register tr_fr_ptr TR0 = TR;
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++ pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, var_in_term_unk);
var_in_term_nvar:
{
if (IsPairTerm(d0)) {
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
continue;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
}
continue;
}
deref_body(d0, ptd0, var_in_term_unk, var_in_term_nvar);
if ((CELL)ptd0 == v) { /* we found it */
clean_tr(TR0);
return(TRUE);
}
/* do or pt2 are unbound */
*ptd0 = TermNil;
/* next make sure noone will see this as a variable again */
TrailTerm(TR++) = (CELL)ptd0;
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)(HeapTop + sizeof(CELL))) {
#ifdef RATIONAL_TREES
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
#else
to_visit -= 2;
pt0 = to_visit[0];
pt0_end = to_visit[1];
#endif
goto loop;
}
clean_tr(TR0);
return(FALSE);
}
static Int
var_in_term(Term v, Term t) /* variables in term t */
{
if (IsVarTerm(t)) {
return(v == t);
} else if (IsPrimitiveTerm(t)) {
return(FALSE);
} else if (IsPairTerm(t)) {
return(var_in_complex_term(RepPair(t)-1,
RepPair(t)+1, v));
}
else return(var_in_complex_term(RepAppl(t),
RepAppl(t)+
ArityOfFunctor(FunctorOfTerm(t)),v));
}
static Int
p_var_in_term(void)
{
return(var_in_term(Deref(ARG2), Deref(ARG1)));
}
/* The code for TermHash was originally contributed by Gertjen Van Noor */
/* This code with max_depth == -1 will loop for infinite trees */
#define GvNht ((UInt *)H)
#define HASHADD(T) (GvNht[k]+=(T), k=(k<2 ? k+1 : 0))
static Int TermHash(Term t1, Int depth_lim, Int k)
{
Int i;
if (IsVarTerm(t1)) {
return(-1);
} else if (IsAtomTerm(t1)) {
register char *s = AtomName(AtomOfTerm(t1));
for (i=0; s[i]; i++)
HASHADD(s[i]);
return(k);
} else if (IsPairTerm(t1)) {
HASHADD('.');
depth_lim--;
if (depth_lim == 0) return(TRUE);
k = TermHash(HeadOfTerm(t1),depth_lim,k);
if (k < 0) return(-1);
k = TermHash(TailOfTerm(t1),depth_lim,k);
return(k);
} else if (IsIntTerm(t1)) {
HASHADD(IntOfTerm(t1));
return(k);
} else {
Functor f = FunctorOfTerm(t1);
if (IsExtensionFunctor(f)) {
if (f == FunctorDouble) {
Int *iptr = (Int *)(RepAppl(t1)+1);
int i;
for (i = 0; i < sizeof(Float) / sizeof(CELL); i++) {
HASHADD(*iptr++);
}
return(k);
} else if (f == FunctorLongInt) {
HASHADD(LongIntOfTerm(t1));
return(k);
} else if (f == FunctorDBRef) {
HASHADD((Int)DBRefOfTerm(t1));
return(k);
/* should never happen */
} else {
return(-1);
}
} else {
int ar = ArityOfFunctor(FunctorOfTerm(t1));
int res = TRUE;
register char *s = AtomName(NameOfFunctor(f));
depth_lim--;
if (depth_lim == 0) return(TRUE);
for (i=0; s[i]; i++)
HASHADD(s[i]);
for (i=1; i<=ar && res; i++) {
k = TermHash(ArgOfTerm(i,t1),depth_lim,k);
if (k == -1 ) return(-1);
}
return(k);
}
}
}
static Int
GvNTermHash(void)
{
unsigned int i1,i2,i3;
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
Term t3 = Deref(ARG3);
Term result;
Int size, depth;
if (IsVarTerm(t2)) {
Yap_Error(INSTANTIATION_ERROR,t2,"term_hash/4");
return(FALSE);
}
if (!IsIntegerTerm(t2)) {
Yap_Error(TYPE_ERROR_INTEGER,t2,"term_hash/4");
return(FALSE);
}
depth = IntegerOfTerm(t2);
if (depth == 0) {
if (IsVarTerm(t1)) return(TRUE);
return(Yap_unify(ARG4,MkIntTerm(0)));
}
if (IsVarTerm(t3)) {
Yap_Error(INSTANTIATION_ERROR,t3,"term_hash/4");
return(FALSE);
}
if (!IsIntegerTerm(t3)) {
Yap_Error(TYPE_ERROR_INTEGER,t3,"term_hash/4");
return(FALSE);
}
size = IntegerOfTerm(t3);
GvNht[0] = 0;
GvNht[1] = 0;
GvNht[2] = 0;
if (TermHash(t1,depth,0) == -1) return(TRUE);
i1 = GvNht[0];
i2 = GvNht[1];
i3 = GvNht[2];
i2 ^= i3; i1 ^= i2; i1 = (((i3 << 7) + i2) << 7) + i1;
result = MkIntegerTerm(i1 % size);
return(Yap_unify(ARG4,result));
}
static int variant_complex(register CELL *pt0, register CELL *pt0_end, register
CELL *pt1)
{
tr_fr_ptr OLDTR = TR;
register CELL **to_visit = (CELL **)ASP;
/* make sure that unification always forces trailing */
HBREG = H;
loop:
while (pt0 < pt0_end) {
register CELL d0, d1;
++ pt0;
++ pt1;
d0 = Derefa(pt0);
d1 = Derefa(pt1);
if (IsVarTerm(d0)) {
if (IsVarTerm(d1)) {
/* bind the two variables to a new term */
Term key = MkDBRefTerm((DBRef)H);
*H++ = (CELL)FunctorDBRef;
Bind_Global(VarOfTerm(d0), key);
if (d0 != d1) {
Bind_Global(VarOfTerm(d1), key);
}
continue;
} else {
goto fail;
}
} else if (IsVarTerm(d1)) {
goto fail;
} else {
if (d0 == d1) continue;
else if (IsAtomOrIntTerm(d0)) {
goto fail;
} else if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
goto fail;
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
to_visit -= 4;
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit -= 3;
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
pt1 = RepPair(d1) - 1;
continue;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2, *ap3;
if (!IsApplTerm(d1)) {
goto fail;
} else {
/* store the terms to visit */
Functor f2;
ap2 = RepAppl(d0);
ap3 = RepAppl(d1);
f = (Functor)(*ap2);
f2 = (Functor)(*ap3);
if (f != f2)
goto fail;
if (IsExtensionFunctor(f)) {
if (!unify_extension(f, d0, ap2, d1))
goto fail;
continue;
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
to_visit -= 4;
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit -= 3;
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt1 = ap3;
continue;
}
}
}
}
/* Do we still have compound terms to visit */
if (to_visit < (CELL **)ASP) {
#ifdef RATIONAL_TREES
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
to_visit += 4;
#else
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
to_visit += 3;
#endif
goto loop;
}
H = HBREG;
/* untrail all bindings made by variant */
while (TR != (tr_fr_ptr)OLDTR) {
CELL *pt1 = (CELL *) TrailTerm(--TR);
RESET_VARIABLE(pt1);
}
HBREG = B->cp_h;
return(TRUE);
fail:
/* failure */
H = HBREG;
#ifdef RATIONAL_TREES
while (to_visit < (CELL **)ASP) {
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
to_visit += 4;
}
#endif
/* untrail all bindings made by variant */
while (TR != (tr_fr_ptr)OLDTR) {
CELL *pt1 = (CELL *) TrailTerm(--TR);
RESET_VARIABLE(pt1);
}
HBREG = B->cp_h;
return(FALSE);
}
static Int
p_variant(void) /* variant terms t1 and t2 */
{
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
if (t1 == t2)
return (TRUE);
if (IsVarTerm(t1)) {
if (IsVarTerm(t2))
return(TRUE);
return(FALSE);
} else if (IsVarTerm(t2))
return(FALSE);
if (IsAtomOrIntTerm(t1)) {
return(t1 == t2);
}
if (IsPairTerm(t1)) {
if (IsPairTerm(t2)) {
return(variant_complex(RepPair(t1)-1,
RepPair(t1)+1,
RepPair(t2)-1));
}
else return (FALSE);
}
if (!IsApplTerm(t2)) return(FALSE);
{
Functor f1 = FunctorOfTerm(t1);
if (f1 != FunctorOfTerm(t2)) return(FALSE);
if (IsExtensionFunctor(f1)) {
return(unify_extension(f1, t1, RepAppl(t1), t2));
}
return(variant_complex(RepAppl(t1),
RepAppl(t1)+ArityOfFunctor(f1),
RepAppl(t2)));
}
}
static int subsumes_complex(register CELL *pt0, register CELL *pt0_end, register
CELL *pt1)
{
register CELL **to_visit = (CELL **)ASP;
CELL *OLDH = H;
loop:
while (pt0 < pt0_end) {
register CELL d0, d1;
++ pt0;
++ pt1;
d0 = Derefa(pt0);
d1 = Derefa(pt1);
if (IsVarTerm(d0)) {
if (IsVarTerm(d1)) {
/* bind the two variables to a new term */
Term key = MkDBRefTerm((DBRef)H);
Bind_Global(VarOfTerm(d0), d1);
H[0] = (CELL)FunctorDBRef;
H[1] = d1;
H += 2;
Bind_Global(VarOfTerm(d1), key);
continue;
} else {
if (IsApplTerm(d1) && RepAppl(d1) >= OLDH && RepAppl(d1) < H) {
/* we are binding to a new variable; */
Bind_Global(VarOfTerm(d0),(CELL)pt1);
} else {
Bind_Global(VarOfTerm(d0), d1);
}
}
} else if (IsVarTerm(d1)) {
goto fail;
} else {
if (d0 == d1) continue;
else if (IsAtomOrIntTerm(d0)) {
goto fail;
} else if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
goto fail;
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
to_visit -= 4;
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit -= 3;
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
pt1 = RepPair(d1) - 1;
continue;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2, *ap3;
if (!IsApplTerm(d1)) {
goto fail;
} else {
/* store the terms to visit */
Functor f2;
ap2 = RepAppl(d0);
ap3 = RepAppl(d1);
f = (Functor)(*ap2);
f2 = (Functor)(*ap3);
if (f != f2)
goto fail;
if (IsExtensionFunctor(f)) {
if (!unify_extension(f, d0, ap2, d1))
goto fail;
continue;
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
to_visit -= 4;
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit -= 3;
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt1 = ap3;
continue;
}
}
}
}
/* Do we still have compound terms to visit */
if (to_visit < (CELL **)ASP) {
#ifdef RATIONAL_TREES
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
to_visit += 4;
#else
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
to_visit += 3;
#endif
goto loop;
}
while (H > OLDH) {
H -= 2;
RESET_VARIABLE(VarOfTerm(H[1]));
}
return(TRUE);
fail:
#ifdef RATIONAL_TREES
while (to_visit < (CELL **)ASP) {
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
to_visit += 4;
}
#endif
return(FALSE);
}
static Int
p_subsumes(void) /* subsumes terms t1 and t2 */
{
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
if (t1 == t2)
return (TRUE);
if (IsVarTerm(t1)) {
Bind(VarOfTerm(t1), t2);
return(TRUE);
} else if (IsVarTerm(t2))
return(FALSE);
if (IsAtomOrIntTerm(t1)) {
return(t1 == t2);
}
if (IsPairTerm(t1)) {
if (IsPairTerm(t2)) {
return(subsumes_complex(RepPair(t1)-1,
RepPair(t1)+1,
RepPair(t2)-1));
}
else return (FALSE);
} else {
Functor f1;
if (!IsApplTerm(t2)) return(FALSE);
f1 = FunctorOfTerm(t1);
if (f1 != FunctorOfTerm(t2))
return(FALSE);
if (IsExtensionFunctor(f1)) {
return(unify_extension(f1, t1, RepAppl(t1), t2));
}
return(subsumes_complex(RepAppl(t1),
RepAppl(t1)+ArityOfFunctor(f1),
RepAppl(t2)));
}
}
#ifdef DEBUG
static Int
p_force_trail_expansion()
{
Int i = IntOfTerm(Deref(ARG1))*1024, j = 0;
tr_fr_ptr OTR = TR;
for (j = 0; j < i; j++) {
TrailTerm(TR) = 0;
TR++;
}
TR = OTR;
return(TRUE);
}
static Int
camacho_dum(void)
{
Term t1, t2;
int max = 3;
/* build output list */
t1 = MkAtomTerm(Yap_LookupAtom("[]"));
t2 = MkPairTerm(MkIntegerTerm(max), t1);
return(Yap_unify(t2, ARG1));
}
#endif /* DEBUG */
void Yap_InitUtilCPreds(void)
{
Yap_InitCPred("copy_term", 2, p_copy_term, 0);
Yap_InitCPred("$copy_term_but_not_constraints", 2, p_copy_term_no_delays, 0);
Yap_InitCPred("ground", 1, p_ground, SafePredFlag);
Yap_InitCPred("$variables_in_term", 3, p_variables_in_term, SafePredFlag);
Yap_InitCPred("variable_in_term", 2, p_var_in_term, SafePredFlag);
Yap_InitCPred("$non_singletons_in_term", 3, p_non_singletons_in_term, SafePredFlag);
Yap_InitCPred("term_hash", 4, GvNTermHash, SafePredFlag);
Yap_InitCPred("variant", 2, p_variant, SafePredFlag);
Yap_InitCPred("subsumes", 2, p_subsumes, SafePredFlag);
#ifdef DEBUG
Yap_InitCPred("$force_trail_expansion", 1, p_force_trail_expansion, SafePredFlag);
Yap_InitCPred("dum", 1, camacho_dum, SafePredFlag);
#endif
}