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.
vsc e5f4633c39 This commit was generated by cvs2svn to compensate for changes in r4,
which included commits to RCS files with non-trunk default branches.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@5 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2001-04-09 19:54:03 +00:00

1745 lines
38 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: unify.c *
* Last rev: *
* mods: *
* comments: Unification and other auxiliary routines for absmi *
* *
*************************************************************************/
#include "absmi.h"
STATIC_PROTO(Int OCUnify_complex, (register CELL *, register CELL *, register CELL *));
STATIC_PROTO(int OCUnify, (register CELL, register CELL));
STATIC_PROTO(Int p_ocunify, (void));
#ifdef THREADED_CODE
STATIC_PROTO(int rtable_hash_op, (OPCODE));
STATIC_PROTO(void InitReverseLookupOpcode, (void));
#endif
STATIC_PROTO(Int p_atom, (void));
STATIC_PROTO(Int p_atomic, (void));
STATIC_PROTO(Int p_integer, (void));
STATIC_PROTO(Int p_nonvar, (void));
STATIC_PROTO(Int p_number, (void));
STATIC_PROTO(Int p_var, (void));
STATIC_PROTO(Int p_db_ref, (void));
STATIC_PROTO(Int p_primitive, (void));
STATIC_PROTO(Int p_compound, (void));
STATIC_PROTO(Int p_float, (void));
STATIC_PROTO(Int p_equal, (void));
STATIC_PROTO(Int p_dif, (void));
STATIC_PROTO(Int p_eq, (void));
STATIC_PROTO(Int p_arg, (void));
STATIC_PROTO(Int p_functor, (void));
static int
rational_tree_loop(CELL *pt0, CELL *pt0_end, CELL **to_visit0)
{
CELL **to_visit = to_visit0;
loop:
while (pt0 < pt0_end) {
register CELL *ptd0 = ++pt0;
register CELL d0;
pt0 = ptd0;
d0 = *ptd0;
deref_head(d0, rtree_loop_unk);
rtree_loop_nvar:
{
if (d0 == TermFoundVar)
goto cufail;
if (IsPairTerm(d0)) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)d0;
to_visit += 3;
*pt0 = TermFoundVar;
pt0_end = (pt0 = RepPair(d0) - 1) + 2;
continue;
}
if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor) (*ap2);
/* compare functors */
if (IsExtensionFunctor(f)) {
continue;
}
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)d0;
to_visit += 3;
*pt0 = TermFoundVar;
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
continue;
}
continue;
}
derefa_body(d0, ptd0, rtree_loop_unk, rtree_loop_nvar);
}
/* Do we still have compound terms to visit */
if (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
goto loop;
}
return (FALSE);
cufail:
#ifdef RATIONAL_TREES
/* we found an infinite term */
while (to_visit > to_visit) {
CELL *pt0;
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
}
#endif
return (TRUE);
}
static inline int
rational_tree(Term d0) {
if (IsPairTerm(d0)) {
CELL *pt0 = RepPair(d0);
CELL **to_visit = (CELL **)H;
return(rational_tree_loop(pt0-1, pt0+1, to_visit));
} else if (IsApplTerm(d0)) {
CELL *pt0 = RepAppl(d0);
Functor f = (Functor)(*pt0);
CELL **to_visit = (CELL **)H;
return(rational_tree_loop(pt0, pt0+ArityOfFunctor(f), to_visit));
} else
return(FALSE);
}
static Int
OCUnify_complex(register CELL *pt0, register CELL *pt0_end,
register CELL *pt1
)
{
register CELL **to_visit = (CELL **) H;
#if SHADOW_HB
register CELL *HBREG = HB;
#endif
loop:
while (pt0 < pt0_end) {
register CELL *ptd0 = ++pt0;
register CELL d0 = *ptd0;
++pt1;
deref_head(d0, unify_comp_unk);
unify_comp_nvar:
{
register CELL *ptd1 = pt1;
register CELL d1 = *ptd1;
deref_head(d1, unify_comp_nvar_unk);
unify_comp_nvar_nvar:
if (d0 == d1) {
if (rational_tree_loop(pt0-1, pt0, to_visit))
goto cufail;
continue;
} if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
goto cufail;
}
/* now link the two structures so that no one else will */
/* come here */
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
/* we want unification of rational trees to fail */
to_visit[3] = (CELL *)d0;
to_visit[4] = (CELL *)d1;
to_visit += 5;
*pt0 = TermFoundVar;
*pt1 = TermFoundVar;
pt0_end = (pt0 = RepPair(d0) - 1) + 2;
pt0_end = RepPair(d0) + 1;
pt1 = RepPair(d1) - 1;
continue;
}
else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2, *ap3;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor) (*ap2);
if (!IsApplTerm(d1)) {
goto cufail;
}
ap3 = RepAppl(d1);
/* compare functors */
if (f != (Functor) *ap3) {
goto cufail;
}
if (IsExtensionFunctor(f)) {
switch((CELL)f) {
case (CELL)FunctorDBRef:
if (d0 == d1) continue;
goto cufail;
case (CELL)FunctorLongInt:
if (ap2[1] == ap3[1]) continue;
goto cufail;
case (CELL)FunctorDouble:
if (FloatOfTerm(d0) == FloatOfTerm(d1)) continue;
goto cufail;
#ifdef USE_GMP
case (CELL)FunctorBigInt:
if (mpz_cmp(BigIntOfTerm(d0),BigIntOfTerm(d1)) == 0) continue;
goto cufail;
#endif /* USE_GMP */
default:
goto cufail;
}
}
/* now link the two structures so that no one else will */
/* come here */
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)d0;
to_visit[4] = (CELL *)d1;
to_visit += 5;
*pt0 = TermFoundVar;
*pt1 = TermFoundVar;
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt1 = ap3;
continue;
} else {
if (d0 == d1)
continue;
else goto cufail;
}
derefa_body(d1, ptd1, unify_comp_nvar_unk, unify_comp_nvar_nvar);
/* d1 and pt2 have the unbound value, whereas d0 is bound */
BIND_GLOBAL(ptd1, d0, bind_ocunify1);
#ifdef COROUTINING
DO_TRAIL(ptd1, d0);
if (ptd1 < H0) WakeUp(ptd1);
bind_ocunify1:
#endif
if (rational_tree_loop(ptd1-1, ptd1, to_visit))
goto cufail;
continue;
}
derefa_body(d0, ptd0, unify_comp_unk, unify_comp_nvar);
{
register CELL d1;
register CELL *ptd1 = NULL;
d1 = *(ptd1 = pt1);
/* pt2 is unbound */
deref_head(d1, unify_comp_var_unk);
unify_comp_var_nvar:
/* pt2 is unbound and d1 is bound */
BIND_GLOBAL(ptd0, d1, bind_ocunify2);
#ifdef COROUTINING
DO_TRAIL(ptd0, d1);
if (ptd0 < H0) WakeUp(ptd0);
bind_ocunify2:
#endif
if (rational_tree_loop(ptd0-1, ptd0, to_visit))
goto cufail;
continue;
derefa_body(d1, ptd1, unify_comp_var_unk, unify_comp_var_nvar);
/* ptd0 and ptd1 are unbound */
UnifyGlobalCells(ptd0, ptd1);
}
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **) H) {
to_visit -= 5;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
*pt1 = (CELL)to_visit[4];
goto loop;
}
/* successful exit */
return (TRUE);
cufail:
/* failure */
while (to_visit > (CELL **) H) {
CELL *pt0;
to_visit -= 5;
pt0 = to_visit[0];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
*pt1 = (CELL)to_visit[4];
}
/* failure */
return (FALSE);
#if SHADOW_REGS
#if defined(B) || defined(TR)
#undef REGS
#endif /* defined(B) || defined(TR) */
#endif
}
static int
OCUnify(register CELL d0, register CELL d1)
{
register CELL *pt0, *pt1;
#if SHADOW_HB
register CELL *HBREG = HB;
#endif
deref_head(d0, oc_unify_unk);
oc_unify_nvar:
/* d0 is bound */
deref_head(d1, oc_unify_nvar_unk);
oc_unify_nvar_nvar:
if (d0 == d1) {
if (rational_tree(d0))
return(FALSE);
return(TRUE);
}
/* both arguments are bound */
if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
return (FALSE);
}
pt0 = RepPair(d0);
pt1 = RepPair(d1);
return (OCUnify_complex(pt0 - 1, pt0 + 1, pt1 - 1));
}
else if (IsApplTerm(d0)) {
if (!IsApplTerm(d1))
return (FALSE);
pt0 = RepAppl(d0);
d0 = *pt0;
pt1 = RepAppl(d1);
d1 = *pt1;
if (d0 != d1) {
return (FALSE);
} else {
if (IsExtensionFunctor((Functor)d0)) {
switch(d0) {
case (CELL)FunctorDBRef:
return(pt0 == pt1);
case (CELL)FunctorLongInt:
return(pt0[1] == pt1[1]);
case (CELL)FunctorDouble:
return(FloatOfTerm(AbsAppl(pt0)) == FloatOfTerm(AbsAppl(pt1)));
#ifdef USE_GMP
case (CELL)FunctorBigInt:
return(mpz_cmp(BigIntOfTerm(AbsAppl(pt0)),BigIntOfTerm(AbsAppl(pt0))) == 0);
#endif /* USE_GMP */
default:
return(FALSE);
}
}
return (OCUnify_complex(pt0, pt0 + ArityOfFunctor((Functor) d0),
pt1));
}
} else {
return(FALSE);
}
deref_body(d1, pt1, oc_unify_nvar_unk, oc_unify_nvar_nvar);
/* d0 is bound and d1 is unbound */
BIND(pt1, d0, bind_ocunify4);
#ifdef COROUTINING
DO_TRAIL(pt1, d0);
if (pt1 < H0) WakeUp(pt1);
bind_ocunify4:
#endif
if (rational_tree(d0))
return(FALSE);
return (TRUE);
deref_body(d0, pt0, oc_unify_unk, oc_unify_nvar);
/* pt0 is unbound */
deref_head(d1, oc_unify_var_unk);
oc_unify_var_nvar:
/* pt0 is unbound and d1 is bound */
BIND(pt0, d1, bind_ocunify5);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) WakeUp(pt0);
bind_ocunify5:
#endif
if (rational_tree(d1))
return(FALSE);
return (TRUE);
deref_body(d1, pt1, oc_unify_var_unk, oc_unify_var_nvar);
/* d0 and pt1 are unbound */
UnifyCells(pt0, pt1, uc1, uc2);
#ifdef COROUTINING
uc1:
DO_TRAIL(pt0, (CELL)pt1);
if (pt0 < H0) WakeUp(pt0);
#endif
return (TRUE);
#ifdef COROUTINING
uc2:
DO_TRAIL(pt1, (CELL)pt0);
if (pt1 < H0) {
WakeUp(pt1);
}
#endif
return (TRUE);
}
static Int
p_ocunify(void)
{
return(OCUnify(ARG1,ARG2));
}
static Int
p_cyclic(void)
{
Term t = Deref(ARG1);
if (IsVarTerm(t))
return(FALSE);
return(rational_tree(t));
}
static Int
p_acyclic(void)
{
Term t = Deref(ARG1);
if (IsVarTerm(t))
return(TRUE);
return(!rational_tree(t));
}
int
IUnify_complex(CELL *pt0, CELL *pt0_end, CELL *pt1)
{
#if SHADOW_REGS
#if defined(B) || defined(TR)
register REGSTORE *regp = &REGS;
#define REGS (*regp)
#endif /* defined(B) || defined(TR) || defined(HB) */
#endif
#if SHADOW_HB
register CELL *HBREG = HB;
#endif /* SHADOW_HB */
CELL **to_visit = (CELL **)H;
loop:
while (pt0 < pt0_end) {
register CELL *ptd0 = pt0+1;
register CELL d0;
++pt1;
pt0 = ptd0;
d0 = *ptd0;
deref_head(d0, unify_comp_unk);
unify_comp_nvar:
{
register CELL *ptd1 = pt1;
register CELL d1 = *ptd1;
deref_head(d1, unify_comp_nvar_unk);
unify_comp_nvar_nvar:
if (d0 == d1)
continue;
if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
goto cufail;
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)d0;
to_visit += 4;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
pt0_end = (pt0 = RepPair(d0) - 1) + 2;
pt1 = RepPair(d1) - 1;
continue;
}
if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2, *ap3;
if (!IsApplTerm(d1)) {
goto cufail;
}
/* store the terms to visit */
ap2 = RepAppl(d0);
ap3 = RepAppl(d1);
f = (Functor) (*ap2);
/* compare functors */
if (f != (Functor) *ap3)
goto cufail;
if (IsExtensionFunctor(f)) {
if (unify_extension(f, d0, ap2, d1))
continue;
goto cufail;
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)d0;
to_visit += 4;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt1 = ap3;
continue;
}
goto cufail;
derefa_body(d1, ptd1, unify_comp_nvar_unk, unify_comp_nvar_nvar);
/* d1 and pt2 have the unbound value, whereas d0 is bound */
BIND_GLOBALCELL(ptd1, d0);
}
derefa_body(d0, ptd0, unify_comp_unk, unify_comp_nvar);
/* first arg var */
{
register CELL d1;
register CELL *ptd1;
ptd1 = pt1;
d1 = ptd1[0];
/* pt2 is unbound */
deref_head(d1, unify_comp_var_unk);
unify_comp_var_nvar:
/* pt2 is unbound and d1 is bound */
BIND_GLOBALCELL(ptd0, d1);
derefa_body(d1, ptd1, unify_comp_var_unk, unify_comp_var_nvar);
/* ptd0 and ptd1 are unbound */
UnifyGlobalCells(ptd0, ptd1);
}
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **) H) {
#ifdef RATIONAL_TREES
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
#else
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
#endif
goto loop;
}
return (TRUE);
cufail:
#ifdef RATIONAL_TREES
/* failure */
while (to_visit > (CELL **) H) {
CELL *pt0;
to_visit -= 4;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[3];
}
#endif
return (FALSE);
#if SHADOW_REGS
#if defined(B) || defined(TR)
#undef REGS
#endif /* defined(B) || defined(TR) */
#endif
}
int
IUnify(register CELL d0, register CELL d1)
{
#if SHADOW_REGS
#if defined(B) || defined(TR)
register REGSTORE *regp = &REGS;
#define REGS (*regp)
#endif /* defined(B) || defined(TR) */
#endif
#if SHADOW_HB
register CELL *HBREG = HB;
#endif
register CELL *pt0, *pt1;
deref_head(d0, unify_unk);
unify_nvar:
/* d0 is bound */
deref_head(d1, unify_nvar_unk);
unify_nvar_nvar:
/* both arguments are bound */
if (d0 == d1)
return (TRUE);
if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
return (FALSE);
}
pt0 = RepPair(d0);
pt1 = RepPair(d1);
return (IUnify_complex(pt0 - 1, pt0 + 1, pt1 - 1));
}
else if (IsApplTerm(d0)) {
pt0 = RepAppl(d0);
d0 = *pt0;
if (!IsApplTerm(d1))
return (FALSE);
pt1 = RepAppl(d1);
d1 = *pt1;
if (d0 != d1) {
return (FALSE);
} else {
if (IsExtensionFunctor((Functor)d0)) {
switch(d0) {
case (CELL)FunctorDBRef:
return(pt0 == pt1);
case (CELL)FunctorLongInt:
return(pt0[1] == pt1[1]);
case (CELL)FunctorDouble:
return(FloatOfTerm(AbsAppl(pt0)) == FloatOfTerm(AbsAppl(pt1)));
#ifdef USE_GMP
case (CELL)FunctorBigInt:
return(mpz_cmp(BigIntOfTerm(AbsAppl(pt0)),BigIntOfTerm(AbsAppl(pt0))) == 0);
#endif /* USE_GMP */
default:
return(FALSE);
}
}
return (IUnify_complex(pt0, pt0 + ArityOfFunctor((Functor) d0),
pt1));
}
} else {
return (FALSE);
}
deref_body(d1, pt1, unify_nvar_unk, unify_nvar_nvar);
/* d0 is bound and d1 is unbound */
BIND(pt1, d0, bind_unify3);
#ifdef COROUTINING
DO_TRAIL(pt1, d0);
if (pt1 < H0) WakeUp(pt1);
bind_unify3:
#endif
return (TRUE);
deref_body(d0, pt0, unify_unk, unify_nvar);
/* pt0 is unbound */
deref_head(d1, unify_var_unk);
unify_var_nvar:
/* pt0 is unbound and d1 is bound */
BIND(pt0, d1, bind_unify4);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) WakeUp(pt0);
bind_unify4:
#endif
return (TRUE);
#if TRAILING_REQUIRES_BRANCH
unify_var_nvar_trail:
DO_TRAIL(pt0);
return (TRUE);
#endif
deref_body(d1, pt1, unify_var_unk, unify_var_nvar);
/* d0 and pt1 are unbound */
UnifyCells(pt0, pt1, uc1, uc2);
#ifdef COROUTINING
DO_TRAIL(pt0, (CELL)pt1);
if (pt0 < H0) WakeUp(pt0);
uc1:
#endif
return (TRUE);
#ifdef COROUTINING
uc2:
DO_TRAIL(pt1, (CELL)pt0);
if (pt1 < H0) {
WakeUp(pt1);
}
return (TRUE);
#endif
#if SHADOW_REGS
#if defined(B) || defined(TR)
#undef REGS
#endif /* defined(B) || defined(TR) */
#endif
}
/**********************************************************************
* *
* Conversion from Label to Op *
* *
**********************************************************************/
#if USE_THREADED_CODE
static inline int
rtable_hash_op(OPCODE opc, int hash_mask) {
return((((CELL)opc) >> 3) & hash_mask);
}
#define OP_HASH_SIZE 2048
/* mask a hash table that allows for fast reverse translation from
instruction address to corresponding opcode */
static void
InitReverseLookupOpcode(void)
{
opentry *opeptr;
op_numbers i;
/* 2 K should be OK */
int hash_size_mask = OP_HASH_SIZE-1;
if (OP_RTABLE == NULL)
OP_RTABLE = (opentry *)AllocCodeSpace(OP_HASH_SIZE*sizeof(struct opcode_tab_entry));
if (OP_RTABLE == NULL) {
Error(FATAL_ERROR, TermNil,
"Couldn't obtain space for the reverse translation opcode table");
}
opeptr = OP_RTABLE;
/* clear up table */
{
int j;
for (j=0; j<=OP_HASH_SIZE; j++) {
opeptr[j].opc = NIL;
opeptr[j].opnum = _Ystop;
}
}
opeptr = OP_RTABLE;
opeptr[rtable_hash_op(opcode(_Ystop),hash_size_mask)].opc
= opcode(_Ystop);
/* now place entries */
for (i = _std_top; i > _Ystop; i--) {
OPCODE opc = opcode(i);
int j = rtable_hash_op(opc,hash_size_mask);
while (opeptr[j].opc != NIL) {
if (++j > hash_size_mask)
j = 0;
}
/* clear entry, no conflict */
opeptr[j].opnum = i;
opeptr[j].opc = opc;
}
}
/* given an opcode find the corresponding opnumber. This should make
switches on ops a much easier operation */
op_numbers
op_from_opcode(OPCODE opc)
{
int j = rtable_hash_op(opc,OP_HASH_SIZE-1);
while (OP_RTABLE[j].opc != opc) {
if (j == OP_HASH_SIZE-1)
j = 0;
else
j++;
}
return(OP_RTABLE[j].opnum);
}
#else
op_numbers
op_from_opcode(OPCODE opc)
{
return((op_numbers)opc);
}
#endif
/**********************************************************************
* *
* Conversion from Op to Label *
* *
**********************************************************************/
int
iequ_complex(register CELL *pt0, register CELL *pt0_end,
register CELL *pt1
)
{
register CELL **to_visit = (CELL **) H;
#ifdef RATIONAL_TREES
register CELL *visited = AuxSp;
#endif
loop:
while (pt0 < pt0_end) {
register CELL *ptd0 = ++pt0;
register CELL d0 = *ptd0;
++pt1;
deref_head(d0, eq_comp_unk);
eq_comp_nvar:
{
register CELL *ptd1 = pt1;
register CELL d1 = *ptd1;
deref_head(d1, eq_comp_nvar_unk);
eq_comp_nvar_nvar:
if (d0 == d1)
continue;
else if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
UNWIND_CUNIF();
return (FALSE);
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
if (d0 > d1) {
visited -= 2;
visited[0] = (CELL) pt0;
visited[1] = *pt0;
*pt0 = d1;
}
else {
visited -= 2;
visited[0] = (CELL) pt1;
visited[1] = *pt1;
*pt1 = d0;
}
#endif
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
pt0_end = (pt0 = RepPair(d0) - 1) + 2;
pt0_end = RepPair(d0) + 1;
pt1 = RepPair(d1) - 1;
continue;
}
else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2, *ap3;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor) (*ap2);
if (IsExtensionFunctor(f)) {
switch ((CELL)f) {
case (CELL)FunctorDBRef:
if (d0 == d1) continue;
UNWIND_CUNIF();
return (FALSE);
case (CELL)FunctorLongInt:
if (IsLongIntTerm(d1) && (Int)(ap2[1]) == LongIntOfTerm(d1)) continue;
UNWIND_CUNIF();
return (FALSE);
case (CELL)FunctorDouble:
if (IsFloatTerm(d1) && FloatOfTerm(d0) == FloatOfTerm(d1)) continue;
UNWIND_CUNIF();
return (FALSE);
#ifdef USE_GMP
case (CELL)FunctorBigInt:
if (IsBigIntTerm(d1) && mpz_cmp((MP_INT *)(ap2+1),BigIntOfTerm(d1)) == 0) continue;
UNWIND_CUNIF();
return (FALSE);
#endif /* USE_GMP */
default:
break;
}
}
if (!IsApplTerm(d1)) {
UNWIND_CUNIF();
return (FALSE);
}
ap3 = RepAppl(d1);
/* compare functors */
if (f != (Functor) *ap3) {
UNWIND_CUNIF();
return (FALSE);
}
#ifdef RATIONAL_TREES
/* now link the two structures so that no one else will */
/* come here */
if (d0 > d1) {
visited -= 2;
visited[0] = (CELL) pt0;
visited[1] = *pt0;
*pt0 = d1;
}
else {
visited -= 2;
visited[0] = (CELL) pt1;
visited[1] = *pt1;
*pt1 = d0;
}
#endif
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt1 = ap3;
continue;
} else {
UNWIND_CUNIF();
return (FALSE);
}
derefa_body(d1, ptd1, eq_comp_nvar_unk, eq_comp_nvar_nvar);
/* d1 and pt2 have the unbound value, whereas d0 is bound */
UNWIND_CUNIF();
return (FALSE);
}
derefa_body(d0, ptd0, eq_comp_unk, eq_comp_nvar);
{
register CELL d1;
register CELL *ptd1;
d1 = *( ptd1 = pt1);
/* pt2 is unbound */
deref_head(d1, eq_comp_var_unk);
eq_comp_var_nvar:
/* pt2 is unbound and d1 is bound */
UNWIND_CUNIF();
return (FALSE);
derefa_body(d1, ptd1, eq_comp_var_unk, eq_comp_var_nvar);
/* pt2 and pt3 are unbound */
if (ptd0 == ptd1)
continue;
UNWIND_CUNIF();
return (FALSE);
}
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **) H) {
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
goto loop;
}
/* successful exit */
UNWIND_CUNIF();
return (TRUE);
}
static Int
p_atom(void)
{ /* atom(?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, atom_unk);
atom_nvar:
if (IsAtomTerm(d0)) {
return(TRUE);
}
else {
return(FALSE);
}
BEGP(pt0);
deref_body(d0, pt0, atom_unk, atom_nvar);
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_atomic(void)
{ /* atomic(?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, atomic_unk);
atomic_nvar:
if (IsAtomicTerm(d0)) {
return(TRUE);
}
else {
return(FALSE);
}
BEGP(pt0);
deref_body(d0, pt0, atomic_unk, atomic_nvar);
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_integer(void)
{ /* integer(?,?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, integer_unk);
integer_nvar:
if (IsIntegerTerm(d0)) {
return(TRUE);
}
else {
return(FALSE);
}
BEGP(pt0);
deref_body(d0, pt0, integer_unk, integer_nvar);
ENDP(pt0);
return(FALSE);
ENDD(d0);
}
static Int
p_number(void)
{ /* number(?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, number_unk);
number_nvar:
if (IsNumTerm(d0)) {
return(TRUE);
}
else {
return(FALSE);
}
BEGP(pt0);
deref_body(d0, pt0, number_unk, number_nvar);
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_db_ref(void)
{ /* db_reference(?,?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, db_ref_unk);
db_ref_nvar:
if (IsDBRefTerm(d0)) {
return(TRUE);
}
else {
return(FALSE);
}
BEGP(pt0);
deref_body(d0, pt0, db_ref_unk, db_ref_nvar);
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_primitive(void)
{ /* primitive(?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, primitive_unk);
primitive_nvar:
if (IsPrimitiveTerm(d0)) {
return(TRUE);
}
else {
return(FALSE);
}
BEGP(pt0);
deref_body(d0, pt0, primitive_unk, primitive_nvar);
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_float(void)
{ /* float(?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, float_unk);
float_nvar:
if (IsFloatTerm(d0)) {
return(TRUE);
}
else {
return(FALSE);
}
BEGP(pt0);
deref_body(d0, pt0, float_unk, float_nvar);
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_compound(void)
{ /* compound(?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, compound_unk);
compound_nvar:
if (IsPairTerm(d0)) {
return(TRUE);
}
else if (IsApplTerm(d0)) {
if (IsExtensionFunctor(FunctorOfTerm(d0))) {
return(FALSE);
}
return(TRUE);
}
else {
return(FALSE);
}
BEGP(pt0);
deref_body(d0, pt0, compound_unk, compound_nvar);
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_nonvar(void)
{ /* nonvar(?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, nonvar_unk);
nonvar_nvar:
return(TRUE);
BEGP(pt0);
deref_body(d0, pt0, nonvar_unk, nonvar_nvar);
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_var(void)
{ /* var(?) */
BEGD(d0);
d0 = ARG1;
deref_head(d0, var_unk);
var_nvar:
return(FALSE);
BEGP(pt0);
deref_body(d0, pt0, var_unk, var_nvar);
return(TRUE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_equal(void)
{ /* ?=? */
return(IUnify(ARG1, ARG2));
}
static Int
p_eq(void)
{ /* ? == ? */
BEGD(d0);
d0 = ARG1;
deref_head(d0, p_eq_unk1);
p_eq_nvar1:
/* first argument is bound */
BEGD(d1);
d1 = ARG2;
deref_head(d1, p_eq_nvar1_unk2);
p_eq_nvar1_nvar2:
/* both arguments are bound */
if (d0 == d1) {
return(TRUE);
}
if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
return(FALSE);
}
return(iequ_complex(RepPair(d0)-1, RepPair(d0)+1,RepPair(d1)-1));
}
if (IsApplTerm(d0)) {
Functor f0 = FunctorOfTerm(d0);
Functor f1;
if (!IsApplTerm(d1)) {
return(FALSE);
}
f1 = FunctorOfTerm(d1);
if (f0 != f1) {
return(FALSE);
}
return(iequ_complex(RepAppl(d0), RepAppl(d0)+ArityOfFunctor(f0), RepAppl(d1)));
}
return(FALSE);
BEGP(pt0);
deref_body(d1, pt0, p_eq_nvar1_unk2, p_eq_nvar1_nvar2);
ENDP(pt0);
/* first argument is bound */
/* second argument is unbound */
/* I don't need to worry about co-routining because an
unbound variable may never be == to a constrained variable!! */
return(FALSE);
ENDD(d1);
BEGP(pt0);
deref_body(d0, pt0, p_eq_unk1, p_eq_nvar1);
BEGD(d1);
d1 = ARG2;
deref_head(d1, p_eq_var1_unk2);
p_eq_var1_nvar2:
/* I don't need to worry about co-routining because an
unbound variable may never be == to a constrained variable!! */
return(FALSE);
BEGP(pt1);
deref_body(d1, pt1, p_eq_var1_unk2, p_eq_var1_nvar2);
/* first argument is unbound */
/* second argument is unbound */
return(pt1 == pt0);
ENDP(pt1);
ENDD(d1);
ENDP(pt0);
ENDD(d0);
}
static Int
p_dif(void)
{ /* ? \= ? */
#if SHADOW_HB
register CELL *HBREG = HB;
#endif
BEGD(d0);
BEGD(d1);
d0 = ARG1;
deref_head(d0, dif_unk1);
dif_nvar1:
/* first argument is bound */
d1 = ARG2;
deref_head(d1, dif_nvar1_unk2);
dif_nvar1_nvar2:
/* both arguments are bound */
if (d0 == d1) {
return(FALSE);
}
if (IsAtomOrIntTerm(d0) || IsAtomOrIntTerm(d1)) {
return(TRUE);
}
{
#ifdef COROUTINING
/*
* We may wake up goals during our attempt to unify the
* two terms. If we are adding to the tail of a list of
* woken goals that should be ok, but otherwise we need
* to restore WokenGoals to its previous value.
*/
CELL OldWokenGoals = ReadTimedVar(WokenGoals);
#endif
/* We will have to look inside compound terms */
BEGP(pt0);
/* store the old value of TR for clearing bindings */
pt0 = (CELL *)TR;
BEGCHO(pt1);
pt1 = B;
/* make B and HB point to H to guarantee all bindings will
* be trailed
*/
HBREG = H;
B = (choiceptr) H;
save_hb();
if (IUnify(d0, d1) == TRUE) {
/* restore B, no need to restore HB */
B = pt1;
return(FALSE);
}
B = pt1;
/* restore B, and later HB */
ENDCHO(pt1);
BEGP(pt1);
/* untrail all bindings made by IUnify */
while (TR != (tr_fr_ptr)pt0) {
pt1 = (CELL *) TrailTerm(--TR);
RESET_VARIABLE(pt1);
}
HBREG = B->cp_h;
ENDP(pt1);
}
#ifdef COROUTINING
/* now restore Woken Goals to its old value */
UpdateTimedVar(WokenGoals, OldWokenGoals);
#endif
return(TRUE);
ENDP(pt0);
BEGP(pt0);
deref_body(d0, pt0, dif_unk1, dif_nvar1);
ENDP(pt0);
/* first argument is unbound */
return(FALSE);
BEGP(pt0);
deref_body(d1, pt0, dif_nvar1_unk2, dif_nvar1_nvar2);
ENDP(pt0);
/* second argument is unbound */
return(FALSE);
ENDD(d1);
ENDD(d0);
}
static Int
p_arg(void)
{ /* arg(?,?,?) */
#if SHADOW_HB
register CELL *HBREG = HB;
#endif
BEGD(d0);
d0 = ARG1;
deref_head(d0, arg_arg1_unk);
arg_arg1_nvar:
/* ARG1 is ok! */
if (IsIntTerm(d0))
d0 = IntOfTerm(d0);
else if (IsLongIntTerm(d0)) {
d0 = LongIntOfTerm(d0);
} else {
Error(TYPE_ERROR_INTEGER,d0,"arg 1 of arg/3");
return(FALSE);
}
/* d0 now got the argument we want */
BEGD(d1);
d1 = ARG2;
deref_head(d1, arg_arg2_unk);
arg_arg2_nvar:
/* d1 now got the structure we want to fetch the argument
* from */
if (IsApplTerm(d1)) {
BEGP(pt0);
pt0 = RepAppl(d1);
d1 = *pt0;
if (IsExtensionFunctor((Functor) d1)) {
return(FALSE);
}
save_hb();
if ((Int)d0 <= 0 ||
d0 > ArityOfFunctor((Functor) d1) ||
IUnify((CELL)(pt0+d0), ARG3) == FALSE) {
/* don't complain here for Prolog compatibility
if ((Int)d0 <= 0) {
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,
MkIntegerTerm(d0),"arg 1 of arg/3");
}
*/
return(FALSE);
}
return(TRUE);
ENDP(pt0);
}
else if (IsPairTerm(d1)) {
BEGP(pt0);
pt0 = RepPair(d1);
if (d0 == 1) {
save_hb();
if (IUnify((CELL)pt0, ARG3) == FALSE) {
return(FALSE);
}
return(TRUE);
}
else if (d0 == 2) {
save_hb();
if (IUnify((CELL)(pt0+1), ARG3) == FALSE) {
return(FALSE);
}
return(TRUE);
}
else {
if ((Int)d0 < 0)
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,
MkIntegerTerm(d0),"arg 1 of arg/3");
return(FALSE);
}
ENDP(pt0);
}
else {
Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3");
return(FALSE);
}
BEGP(pt0);
deref_body(d1, pt0, arg_arg2_unk, arg_arg2_nvar);
Error(INSTANTIATION_ERROR,(CELL)pt0,"arg 2 of arg/3");;
ENDP(pt0);
return(FALSE);
ENDD(d1);
BEGP(pt0);
deref_body(d0, pt0, arg_arg1_unk, arg_arg1_nvar);
Error(INSTANTIATION_ERROR,(CELL)pt0,"arg 1 of arg/3");;
ENDP(pt0);
return(FALSE);
ENDD(d0);
}
static Int
p_functor(void) /* functor(?,?,?) */
{
#if SHADOW_HB
register CELL *HBREG;
#endif
restart:
#if SHADOW_HB
HBREG = HB;
#endif
BEGD(d0);
d0 = ARG1;
deref_head(d0, func_unk);
func_nvar:
/* A1 is bound */
BEGD(d1);
if (IsApplTerm(d0)) {
d1 = *RepAppl(d0);
if (IsExtensionFunctor((Functor) d1)) {
if (d1 == (CELL)FunctorDouble) {
d1 = MkIntTerm(0);
} else if (d1 == (CELL)FunctorLongInt) {
d1 = MkIntTerm(0);
} else
return(FALSE);
} else {
d0 = MkAtomTerm(NameOfFunctor((Functor) d1));
d1 = MkIntTerm(ArityOfFunctor((Functor) d1));
}
}
else if (IsPairTerm(d0)) {
d0 = TermDot;
d1 = MkIntTerm(2);
}
else {
d1 = MkIntTerm(0);
}
/* d1 and d0 now have the two arguments */
/* let's go and bind them */
{
register CELL arity = d1;
d1 = ARG2;
deref_head(d1, func_nvar_unk);
func_nvar_nvar:
/* A2 was bound */
if (d0 != d1) {
return(FALSE);
}
/* have to buffer ENDP and label */
d0 = arity;
goto func_bind_x3;
BEGP(pt0);
deref_body(d1, pt0, func_nvar_unk, func_nvar_nvar);
/* A2 is a variable, go and bind it */
BIND(pt0, d0, bind_func_nvar_var);
#ifdef COROUTINING
DO_TRAIL(pt0, d0);
if (pt0 < H0) WakeUp(pt0);
bind_func_nvar_var:
#endif
/* have to buffer ENDP and label */
d0 = arity;
ENDP(pt0);
/* now let's process A3 */
func_bind_x3:
d1 = ARG3;
deref_head(d1, func_nvar3_unk);
func_nvar3_nvar:
/* A3 was bound */
if (d0 != d1) {
return(FALSE);
}
/* Done */
return(TRUE);
BEGP(pt0);
deref_body(d1, pt0, func_nvar3_unk, func_nvar3_nvar);
/* A3 is a variable, go and bind it */
BIND(pt0, d0, bind_func_nvar3_var);
/* Done */
#ifdef COROUTINING
DO_TRAIL(pt0, d0);
if (pt0 < H0) WakeUp(pt0);
bind_func_nvar3_var:
#endif
return(TRUE);
ENDP(pt0);
}
ENDD(d1);
BEGP(pt0);
deref_body(d0, pt0, func_unk, func_nvar);
/* A1 is a variable */
/* We have to build the structure */
d0 = ARG2;
deref_head(d0, func_var_2unk);
func_var_2nvar:
/* we do, let's get the third argument */
BEGD(d1);
d1 = ARG3;
deref_head(d1, func_var_3unk);
func_var_3nvar:
/* Uuuff, the second and third argument are bound */
if (IsIntTerm(d1))
d1 = IntOfTerm(d1);
else {
Error(TYPE_ERROR_INTEGER,ARG3,"functor/3");
return(FALSE);
}
if (!IsAtomicTerm(d0)) {
Error(TYPE_ERROR_ATOMIC,d0,"functor/3");
return(FALSE);
}
/* We made it!!!!! we got in d0 the name, in d1 the arity and
* in pt0 the variable to bind it to. */
if (d0 == TermDot && d1 == 2) {
RESET_VARIABLE(H);
RESET_VARIABLE(H+1);
d0 = AbsPair(H);
H += 2;
}
else if ((Int)d1 > 0) {
/* now let's build a compound term */
if (!IsAtomTerm(d0)) {
Error(TYPE_ERROR_ATOM,d0,"functor/3");
return(FALSE);
}
BEGP(pt1);
if (!IsAtomTerm(d0)) {
return(FALSE);
}
else
d0 = (CELL) MkFunctor(AtomOfTerm(d0), (Int) d1);
pt1 = H;
*pt1++ = d0;
d0 = AbsAppl(H);
if (pt1+d1 > ENV - CreepFlag) {
gc(3, ENV, P);
goto restart;
}
while (d1-- > 0) {
RESET_VARIABLE(pt1);
pt1++;
}
/* done building the term */
H = pt1;
ENDP(pt1);
} else if ((Int)d1 < 0) {
Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,MkIntegerTerm(d1),"functor/3");
return(FALSE);
}
/* else if arity is 0 just pass d0 through */
/* Ding, ding, we made it */
BIND(pt0, d0, bind_func_var_3nvar);
#ifdef COROUTINING
DO_TRAIL(pt0, d0);
if (pt0 < H0) WakeUp(pt0);
bind_func_var_3nvar:
#endif
return(TRUE);
BEGP(pt1);
deref_body(d1, pt1, func_var_3unk, func_var_3nvar);
Error(INSTANTIATION_ERROR,(CELL)pt1,"functor/3");
ENDP(pt1);
/* Oops, third argument was unbound */
return(FALSE);
ENDD(d1);
BEGP(pt1);
deref_body(d0, pt1, func_var_2unk, func_var_2nvar);
Error(INSTANTIATION_ERROR,(CELL)pt1,"functor/3");
ENDP(pt1);
/* Oops, second argument was unbound too */
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_cut_by( void)
{
BEGD(d0);
d0 = ARG1;
deref_head(d0, cutby_x_unk);
cutby_x_nvar:
#if SBA
if (!IsIntegerTerm(d0)) {
#else
if (!IsIntTerm(d0)) {
#endif
return(FALSE);
}
BEGCHO(pt0);
#if SBA
pt0 = (choiceptr)IntegerOfTerm(d0);
#else
pt0 = (choiceptr)(LCL0-IntOfTerm(d0));
#endif
if (TopB != NULL && YOUNGER_CP(TopB,pt0)) {
if (DelayedB == NULL || YOUNGER_CP(DelayedB,pt0))
DelayedB = pt0;
pt0 = TopB;
}
/* find where to cut to */
if (pt0 > B) {
/* Wow, we're gonna cut!!! */
#ifdef YAPOR
CUT_prune_to(pt0);
#else
B = pt0;
#endif /* YAPOR */
#ifdef TABLING
abolish_incomplete_subgoals(B);
#endif /* TABLING */
HB = B->cp_h;
/* trim_trail();*/
}
ENDCHO(pt0);
return(TRUE);
BEGP(pt0);
deref_body(d0, pt0, cutby_x_unk, cutby_x_nvar);
/* never cut to a variable */
/* Abort */
return(FALSE);
ENDP(pt0);
ENDD(d0);
}
static Int
p_erroneous_call(void)
{
Error(SYSTEM_ERROR, TermNil, "bad call to internal built-in");
return(FALSE);
}
void
InitUnify(void)
{
InitCPred("unify_with_occurs_check", 2, p_ocunify, SafePredFlag);
InitCPred("cyclic_term", 1, p_cyclic, SafePredFlag|TestPredFlag);
InitCPred("acyclic_term", 1, p_acyclic, SafePredFlag|TestPredFlag);
InitAsmPred("$$cut_by", 1, _cut_by, p_cut_by, SafePredFlag | BasicPredFlag);
InitAsmPred("atom", 1, _atom, p_atom, SafePredFlag | BasicPredFlag);
InitAsmPred("atomic", 1, _atomic, p_atomic, SafePredFlag | BasicPredFlag);
InitAsmPred("integer", 1, _integer, p_integer, SafePredFlag | BasicPredFlag);
InitAsmPred("nonvar", 1, _nonvar, p_nonvar, SafePredFlag | BasicPredFlag);
InitAsmPred("number", 1, _number, p_number, SafePredFlag | BasicPredFlag);
InitAsmPred("var", 1, _var, p_var, SafePredFlag | BasicPredFlag);
InitAsmPred("db_reference", 1, _db_ref, p_db_ref, SafePredFlag | BasicPredFlag);
InitAsmPred("primitive", 1, _primitive, p_primitive, SafePredFlag | BasicPredFlag);
InitAsmPred("compound", 1, _compound, p_compound, SafePredFlag | BasicPredFlag);
InitAsmPred("float", 1, _float, p_float, SafePredFlag | BasicPredFlag);
InitAsmPred("=", 2, _equal, p_equal, SafePredFlag | BasicPredFlag);
InitAsmPred("\\=", 2, _dif, p_dif, SafePredFlag | BasicPredFlag);
InitAsmPred("==", 2, _eq, p_eq, SafePredFlag | BasicPredFlag);
InitAsmPred("arg", 3, _arg, p_arg, SafePredFlag | BasicPredFlag);
InitAsmPred("functor", 3, _functor, p_functor, SafePredFlag | BasicPredFlag);
InitAsmPred("$plus", 3, _plus, p_erroneous_call, SafePredFlag | BasicPredFlag);
InitAsmPred("$minus", 3, _minus, p_erroneous_call, SafePredFlag | BasicPredFlag);
InitAsmPred("$times", 3, _times, p_erroneous_call, SafePredFlag | BasicPredFlag);
InitAsmPred("$div", 3, _div, p_erroneous_call, SafePredFlag | BasicPredFlag);
InitAsmPred("$and", 3, _and, p_erroneous_call, SafePredFlag | BasicPredFlag);
InitAsmPred("$or", 3, _or, p_erroneous_call, SafePredFlag | BasicPredFlag);
InitAsmPred("$sll", 3, _sll, p_erroneous_call, SafePredFlag | BasicPredFlag);
InitAsmPred("$slr", 3, _slr, p_erroneous_call, SafePredFlag | BasicPredFlag);
}
void
InitAbsmi(void)
{
/* initialise access to abstract machine instructions */
#if USE_THREADED_CODE
absmi(1);
InitReverseLookupOpcode();
#endif
}