1745 lines
38 KiB
C
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 = ®S;
|
|
|
|
#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 = ®S;
|
|
|
|
#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
|
|
}
|
|
|