diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' of ssh://yap.git.sourceforge.net/gitroot/yap/yap-6.3

Browse Source
This commit is contained in:
Vítor Santos Costa 2011-11-04 02:48:28 +00:00
commit 3dbae0cb94
52 changed files with 4187 additions and 649 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
C/absmi.c
View File

@ -2267,23 +2267,6 @@ Yap_absmi(int inp)
prune((choiceptr)YREG[E_CB]);
setregs();
PREG = NEXTOP(NEXTOP(NEXTOP(PREG, s),Osbpp),l);
#ifdef FROZEN_STACKS
{
choiceptr top_b = PROTECT_FROZEN_B(B);
#ifdef YAPOR_SBA
if (ENV > (CELL *) top_b || ENV < H) YREG = (CELL *) top_b;
#else
if (ENV > (CELL *) top_b) YREG = (CELL *) top_b;
#endif /* YAPOR_SBA */
else YREG = (CELL *)((CELL)ENV + ENV_Size(CPREG));
}
#else
if (ENV > (CELL *)B) {
YREG = (CELL *)B;
} else {
YREG = (CELL *) ((CELL) ENV + ENV_Size(CPREG));
}
#endif
GONext();
ENDOp();

2
C/adtdefs.c
View File

@ -115,7 +115,7 @@ SearchInInvisible(char *atom)
READ_LOCK(INVISIBLECHAIN.AERWLock);
chain = RepAtom(INVISIBLECHAIN.Entry);
while (!EndOfPAEntr(chain) && strcmp(chain->StrOfAE, atom) != 0) {
while (!EndOfPAEntr(chain) && strcmp(chain->StrOfAE, atom)) {
chain = RepAtom(chain->NextOfAE);
}
READ_UNLOCK(INVISIBLECHAIN.AERWLock);

120
C/c_interface.c
View File

@ -384,12 +384,14 @@ X_API Bool STD_PROTO(YAP_IsNonVarTerm,(Term));
X_API Bool STD_PROTO(YAP_IsIntTerm,(Term));
X_API Bool STD_PROTO(YAP_IsLongIntTerm,(Term));
X_API Bool STD_PROTO(YAP_IsBigNumTerm,(Term));
X_API Bool STD_PROTO(YAP_IsNumberTerm,(Term));
X_API Bool STD_PROTO(YAP_IsRationalTerm,(Term));
X_API Bool STD_PROTO(YAP_IsFloatTerm,(Term));
X_API Bool STD_PROTO(YAP_IsDbRefTerm,(Term));
X_API Bool STD_PROTO(YAP_IsAtomTerm,(Term));
X_API Bool STD_PROTO(YAP_IsPairTerm,(Term));
X_API Bool STD_PROTO(YAP_IsApplTerm,(Term));
X_API Bool STD_PROTO(YAP_IsCompoundTerm,(Term));
X_API Bool STD_PROTO(YAP_IsExternalDataInStackTerm,(Term));
X_API Bool STD_PROTO(YAP_IsOpaqueObjectTerm,(Term, int));
X_API Term STD_PROTO(YAP_MkIntTerm,(Int));
@ -425,7 +427,9 @@ X_API Int STD_PROTO(YAP_ArityOfFunctor,(Functor));
X_API void *STD_PROTO(YAP_ExtraSpace,(void));
X_API void STD_PROTO(YAP_cut_up,(void));
X_API Int STD_PROTO(YAP_Unify,(Term,Term));
X_API int STD_PROTO(YAP_Unifiable,(Term,Term));
X_API int STD_PROTO(YAP_Reset,(void));
X_API Int STD_PROTO(YAP_ListLength,(Term));
X_API Int STD_PROTO(YAP_Init,(YAP_init_args *));
X_API Int STD_PROTO(YAP_FastInit,(char *));
X_API PredEntry *STD_PROTO(YAP_FunctorToPred,(Functor));
@ -513,6 +517,7 @@ X_API int STD_PROTO(YAP_ThreadDestroyEngine,(int));
X_API Term STD_PROTO(YAP_MkBlobTerm,(unsigned int));
X_API void *STD_PROTO(YAP_BlobOfTerm,(Term));
X_API Term STD_PROTO(YAP_TermNil,(void));
X_API int STD_PROTO(YAP_IsTermNil,(Term));
X_API int STD_PROTO(YAP_AtomGetHold,(Atom));
X_API int STD_PROTO(YAP_AtomReleaseHold,(Atom));
X_API Agc_hook STD_PROTO(YAP_AGCRegisterHook,(Agc_hook));
@ -529,6 +534,9 @@ X_API void *STD_PROTO(YAP_Record,(Term));
X_API Term STD_PROTO(YAP_Recorded,(void *));
X_API int STD_PROTO(YAP_Erase,(void *));
X_API int STD_PROTO(YAP_Variant,(Term, Term));
X_API Int STD_PROTO(YAP_NumberVars,(Term, Int));
X_API Term STD_PROTO(YAP_UnNumberVars,(Term));
X_API int STD_PROTO(YAP_IsNumberedVariable,(Term));
X_API int STD_PROTO(YAP_ExactlyEqual,(Term, Term));
X_API Int STD_PROTO(YAP_TermHash,(Term, Int, Int, int));
X_API void STD_PROTO(YAP_signal,(int));
@ -544,6 +552,7 @@ X_API int STD_PROTO(YAP_NewOpaqueType,(void *));
X_API Term STD_PROTO(YAP_NewOpaqueObject,(int, size_t));
X_API void *STD_PROTO(YAP_OpaqueObjectFromTerm,(Term));
X_API int STD_PROTO(YAP_Argv,(char *** argvp));
X_API YAP_tag_t STD_PROTO(YAP_TagOfTerm,(Term));
static int
dogc( USES_REGS1 )
@ -600,6 +609,12 @@ YAP_IsIntTerm(Term t)
return IsIntegerTerm(t);
}
X_API Bool
YAP_IsNumberTerm(Term t)
{
return IsIntegerTerm(t) || IsIntTerm(t) || IsFloatTerm(t) || IsBigIntTerm(t);
}
X_API Bool
YAP_IsLongIntTerm(Term t)
{
@ -680,6 +695,13 @@ YAP_IsApplTerm(Term t)
return (IsApplTerm(t) && !IsExtensionFunctor(FunctorOfTerm(t)));
}
X_API Bool
YAP_IsCompoundTerm(Term t)
{
return (IsApplTerm(t) && !IsExtensionFunctor(FunctorOfTerm(t))) ||
IsPairTerm(t);
}
X_API Term
YAP_MkIntTerm(Int n)
@ -1179,6 +1201,18 @@ YAP_Unify(Term t1, Term t2)
return out;
}
X_API int
YAP_Unifiable(Term t1, Term t2)
{
int out;
BACKUP_MACHINE_REGS();
out = Yap_Unifiable(t1, t2);
RECOVER_MACHINE_REGS();
return out;
}
/* == */
X_API int
YAP_ExactlyEqual(Term t1, Term t2)
@ -3416,6 +3450,12 @@ YAP_TermNil(void)
return TermNil;
}
X_API int
YAP_IsTermNil(Term t)
{
return t == TermNil;
}
X_API int
YAP_AtomGetHold(Atom at)
{
@ -3781,7 +3821,6 @@ YAP_OpInfo(Atom at, Term module, int opkind, int *yap_type, int *prio)
return 1;
}
int
YAP_Argv(char ***argvp)
{
@ -3790,3 +3829,82 @@ YAP_Argv(char ***argvp)
}
return GLOBAL_argc;
}
YAP_tag_t
YAP_TagOfTerm(Term t)
{
if (IsVarTerm(t)) {
CELL *pt = VarOfTerm(t);
if (IsUnboundVar(pt)) {
if (IsAttVar(pt))
return YAP_TAG_ATT;
return YAP_TAG_UNBOUND;
}
return YAP_TAG_REF;
}
if (IsPairTerm(t))
return YAP_TAG_PAIR;
if (IsAtomOrIntTerm(t)) {
if (IsAtomTerm(t))
return YAP_TAG_ATOM;
return YAP_TAG_INT;
} else {
Functor f = FunctorOfTerm(t);
if (IsExtensionFunctor(f)) {
if (f == FunctorDBRef) {
return YAP_TAG_DBREF;
}
if (f == FunctorLongInt) {
return YAP_TAG_LONG_INT;
}
if (f == FunctorBigInt) {
big_blob_type bt = RepAppl(t)[1];
switch (bt) {
case BIG_INT:
return YAP_TAG_BIG_INT;
case BIG_RATIONAL:
return YAP_TAG_RATIONAL;
default:
return YAP_TAG_OPAQUE;
}
}
}
return YAP_TAG_APPL;
}
}
int YAP_BPROLOG_exception;
Term YAP_BPROLOG_curr_toam_status;
Int
YAP_ListLength(Term t) {
Int l = 0;
while (TRUE) {
if (IsVarTerm(t)) return -1;
if (t == TermNil)
return l;
if (!IsPairTerm(t))
return -1;
l++;
t = TailOfTerm(t);
}
}
Int
YAP_NumberVars(Term t, Int nbv) {
return Yap_NumberVars(t, nbv);
}
Term
YAP_UnNumberVars(Term t) {
return Yap_UnNumberTerm(t);
}
int
YAP_IsNumberedVariable(Term t) {
return IsApplTerm(t) &&
FunctorOfTerm(t) == FunctorVar &&
IsIntegerTerm(ArgOfTerm(1,t));
}

7
C/cmppreds.c
View File

@ -317,8 +317,9 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */
return 1;
return -1;
} else {
if (IsIntTerm(t2))
if (IsIntTerm(t2)) {
return IntOfTerm(t1) - IntOfTerm(t2);
}
if (IsFloatTerm(t2)) {
return 1;
}
@ -441,9 +442,9 @@ compare(Term t1, Term t2) /* compare terms t1 and t2 */
}
}
int Yap_compare_terms(CELL d0, CELL d1)
Int Yap_compare_terms(Term d0, Term d1)
{
return (compare(Deref(d0),Deref(d1)));
return compare(Deref(d0),Deref(d1));
}
static Int

53
C/eval.c
View File

@ -34,7 +34,54 @@ static char SccsId[] = "%W% %G%";
#include <unistd.h>
#endif
static Term Eval(Term t1 USES_REGS);
static Term
get_matrix_element(Term t1, Term t2 USES_REGS)
{
if (!IsPairTerm(t2)) {
if (t2 == MkAtomTerm(AtomLength)) {
Int sz = 1;
while (IsApplTerm(t1)) {
Functor f = FunctorOfTerm(t1);
if (NameOfFunctor(f) != AtomNil) {
return MkIntegerTerm(sz);
}
sz *= ArityOfFunctor(f);
t1 = ArgOfTerm(1, t1);
}
return MkIntegerTerm(sz);
}
Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]");
return FALSE;
}
while (IsPairTerm(t2)) {
Int indx;
Term indxt = Eval(HeadOfTerm(t2) PASS_REGS);
if (!IsIntegerTerm(indxt)) {
Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]");
return FALSE;
}
indx = IntegerOfTerm(indxt);
if (!IsApplTerm(t1)) {
Yap_ArithError(TYPE_ERROR_EVALUABLE, t1, "X is Y^[A]");
return FALSE;
} else {
Functor f = FunctorOfTerm(t1);
if (ArityOfFunctor(f) < indx) {
Yap_ArithError(TYPE_ERROR_EVALUABLE, t1, "X is Y^[A]");
return FALSE;
}
}
t1 = ArgOfTerm(indx, t1);
t2 = TailOfTerm(t2);
}
if (t2 != TermNil) {
Yap_ArithError(TYPE_ERROR_EVALUABLE, t2, "X is Y^[A]");
return FALSE;
}
return Eval(t1 PASS_REGS);
}
static Term
Eval(Term t USES_REGS)
@ -77,6 +124,12 @@ Eval(Term t USES_REGS)
"functor %s/%d for arithmetic expression",
RepAtom(name)->StrOfAE,n);
}
if (p->FOfEE == op_power && p->ArityOfEE == 2) {
t2 = ArgOfTerm(2, t);
if (IsPairTerm(t2)) {
return get_matrix_element(ArgOfTerm(1, t), t2 PASS_REGS);
}
}
*RepAppl(t) = (CELL)AtomFoundVar;
t1 = Eval(ArgOfTerm(1,t) PASS_REGS);
if (t1 == 0L) {

3
C/init.c
View File

@ -409,6 +409,9 @@ Yap_InitCPred(char *Name, unsigned long int Arity, CPredicate code, UInt flags)
Functor f = NULL;
while (atom == NIL) {
if (flags & UserCPredFlag)
atom = Yap_LookupAtom(Name);
else
atom = Yap_FullLookupAtom(Name);
if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while initialising %s", Name);

22
C/load_dl.c
View File

@ -25,6 +25,28 @@
#include <string.h>
#include <stdio.h>
typedef void (*prismf)(void);
/* only works for dlls */
int
Yap_CallFunctionByName(const char *thing_string);
int
Yap_CallFunctionByName(const char *thing_string)
{
void * handle = dlopen(NULL, RTLD_LAZY | RTLD_NOLOAD);
// you could do RTLD_NOW as well. shouldn't matter
if (!handle) {
CACHE_REGS
Yap_Error(SYSTEM_ERROR, ARG1, "Dynamic linking on main module : %s\n", dlerror());
}
prismf * addr = (prismf *)dlsym(handle, thing_string);
fprintf(stderr, "%s is at %p\n", thing_string, addr);
if (addr)
(*addr)();
return TRUE;
}
/*
* YAP_FindExecutable(argv[0]) should be called on yap initialization to
* locate the executable of Yap

2
C/pl-yap.c
View File

@ -619,7 +619,7 @@ currentOperator(Module m, atom_t name, int kind, int *type, int *priority)
int
numberVars(term_t t, nv_options *opts, int n ARG_LD) {
return 0;
return Yap_NumberVars(YAP_GetFromSlot(t), n);
}
/*******************************

4
C/sort.c
View File

@ -267,14 +267,14 @@ Int compact_mergesort(CELL *pt, Int size, int my_p)
while (pt_left < end_pt_left && pt_right < end_pt_right) {
/* if the element to the left is larger than the one to the right */
Int cmp = Yap_compare_terms(pt_left[0], pt_right[0]);
if (cmp < 0) {
if (cmp < (Int)0) {
/* copy the one to the left */
pt[0] = pt_left[0];
/* and avance the two pointers */
pt += 2;
size ++;
pt_left += 2;
} else if (cmp == 0) {
} else if (cmp == (Int)0) {
/* otherwise, just skip one of them, anyone */
pt_left += 2;
} else {

56
C/unify.c
View File

@ -605,11 +605,13 @@ InitReverseLookupOpcode(void)
}
#endif
#define UnifiableGlobalCells(a, b) \
#define UnifyAndTrailGlobalCells(a, b) \
if((a) > (b)) { \
Bind_Global_NonAtt((a),(CELL)(b)); \
*(a) = (CELL)(b); \
DO_TRAIL((a), (CELL)(b)); \
} else if((a) < (b)){ \
Bind_Global_NonAtt((b),(CELL) (a)); \
*(b) = (CELL)(a); \
DO_TRAIL((b), (CELL)(a)); \
}
static int
@ -736,7 +738,8 @@ loop:
derefa_body(d1, ptd1, unifiable_comp_nvar_unk, unifiable_comp_nvar_nvar);
/* d1 and pt2 have the unbound value, whereas d0 is bound */
Bind(ptd1, d0);
*(ptd1) = d0;
DO_TRAIL(ptd1, d0);
continue;
}
@ -752,12 +755,13 @@ loop:
deref_head(d1, unifiable_comp_var_unk);
unifiable_comp_var_nvar:
/* pt2 is unbound and d1 is bound */
Bind(ptd0, d1);
*ptd0 = d1;
DO_TRAIL(ptd0, d1);
continue;
derefa_body(d1, ptd1, unifiable_comp_var_unk, unifiable_comp_var_nvar);
/* ptd0 and ptd1 are unbound */
UnifiableGlobalCells(ptd0, ptd1);
UnifyAndTrailGlobalCells(ptd0, ptd1);
}
}
/* Do we still have compound terms to visit */
@ -879,7 +883,8 @@ unifiable_nvar_nvar:
deref_body(d1, pt1, unifiable_nvar_unk, unifiable_nvar_nvar);
/* d0 is bound and d1 is unbound */
Bind(pt1, d0);
*(pt1) = d0;
DO_TRAIL(pt1, d0);
return (TRUE);
deref_body(d0, pt0, unifiable_unk, unifiable_nvar);
@ -887,18 +892,13 @@ unifiable_nvar_nvar:
deref_head(d1, unifiable_var_unk);
unifiable_var_nvar:
/* pt0 is unbound and d1 is bound */
Bind(pt0, d1);
*pt0 = d1;
DO_TRAIL(pt0, d1);
return TRUE;
#if TRAILING_REQUIRES_BRANCH
unifiable_var_nvar_trail:
DO_TRAIL(pt0);
return TRUE;
#endif
deref_body(d1, pt1, unifiable_var_unk, unifiable_var_nvar);
/* d0 and pt1 are unbound */
UnifyCells(pt0, pt1);
UnifyAndTrailCells(pt0, pt1);
return (TRUE);
#if THREADS
#undef Yap_REGS
@ -914,13 +914,13 @@ unifiable_var_nvar_trail:
static Int
p_unifiable( USES_REGS1 )
{
tr_fr_ptr trp;
tr_fr_ptr trp, trp0 = TR;
Term tf = TermNil;
if (!unifiable(ARG1,ARG2)) {
return FALSE;
}
trp = TR;
while (trp != B->cp_tr) {
while (trp != trp0) {
Term t[2];
--trp;
t[0] = TrailTerm(trp);
@ -931,6 +931,26 @@ p_unifiable( USES_REGS1 )
return Yap_unify(ARG3, tf);
}
int
Yap_Unifiable( Term d0, Term d1 )
{
CACHE_REGS
tr_fr_ptr trp, trp0 = TR;
if (!unifiable(d0,d1)) {
return FALSE;
}
trp = TR;
while (trp != trp0) {
Term t;
--trp;
t = TrailTerm(trp);
RESET_VARIABLE(t);
}
return TRUE;
}
void
Yap_InitUnify(void)
{
@ -940,7 +960,7 @@ Yap_InitUnify(void)
Yap_InitCPred("acyclic_term", 1, p_acyclic, SafePredFlag|TestPredFlag);
CurrentModule = TERMS_MODULE;
Yap_InitCPred("cyclic_term", 1, p_cyclic, SafePredFlag|TestPredFlag);
Yap_InitCPred("protected_unifiable", 3, p_unifiable, 0);
Yap_InitCPred("unifiable", 3, p_unifiable, 0);
CurrentModule = cm;
}

528
C/utilpreds.c
View File

@ -1836,7 +1836,7 @@ static Term vars_in_complex_term(register CELL *pt0, register CELL *pt0_end, Ter
}
static int
expand_vts( USES_REGS1 )
expand_vts( int args USES_REGS )
{
UInt expand = LOCAL_Error_Size;
yap_error_number yap_errno = LOCAL_Error_TYPE;
@ -1913,7 +1913,7 @@ p_variables_in_term( USES_REGS1 ) /* variables in term t */
ArityOfFunctor(f), ARG2 PASS_REGS);
}
if (out == 0L) {
if (!expand_vts( PASS_REGS1 ))
if (!expand_vts( 3 PASS_REGS ))
return FALSE;
}
} while (out == 0L);
@ -1948,7 +1948,7 @@ p_term_variables( USES_REGS1 ) /* variables in term t */
ArityOfFunctor(f), TermNil PASS_REGS);
}
if (out == 0L) {
if (!expand_vts( PASS_REGS1 ))
if (!expand_vts( 3 PASS_REGS ))
return FALSE;
}
} while (out == 0L);
@ -2168,7 +2168,7 @@ p_term_attvars( USES_REGS1 ) /* variables in term t */
ArityOfFunctor(f), TermNil PASS_REGS);
}
if (out == 0L) {
if (!expand_vts( PASS_REGS1 ))
if (!expand_vts( 3 PASS_REGS ))
return FALSE;
}
} while (out == 0L);
@ -2201,7 +2201,7 @@ p_term_variables3( USES_REGS1 ) /* variables in term t */
ArityOfFunctor(f), ARG3 PASS_REGS);
}
if (out == 0L) {
if (!expand_vts( PASS_REGS1 ))
if (!expand_vts( 3 PASS_REGS ))
return FALSE;
}
} while (out == 0L);
@ -2401,7 +2401,7 @@ p_variables_within_term( USES_REGS1 ) /* variables within term t */
ArityOfFunctor(f), Deref(ARG1) PASS_REGS);
}
if (out == 0L) {
if (!expand_vts( PASS_REGS1 ))
if (!expand_vts( 3 PASS_REGS ))
return FALSE;
}
} while (out == 0L);
@ -2606,7 +2606,7 @@ p_new_variables_in_term( USES_REGS1 ) /* variables within term t */
ArityOfFunctor(f), Deref(ARG1) PASS_REGS);
}
if (out == 0L) {
if (!expand_vts( PASS_REGS1 ))
if (!expand_vts( 3 PASS_REGS ))
return FALSE;
}
} while (out == 0L);
@ -4210,8 +4210,520 @@ p_is_list( USES_REGS1 )
return Yap_IsListTerm(Deref(ARG1));
}
static Term
numbervar(Int id)
{
Term ts[1];
ts[0] = MkIntegerTerm(id);
return Yap_MkApplTerm(FunctorVar, 1, ts);
}
static Int numbervars_in_complex_term(register CELL *pt0, register CELL *pt0_end, Int numbv USES_REGS)
{
register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
register tr_fr_ptr TR0 = TR;
CELL *InitialH = H;
to_visit0 = to_visit;
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)) {
if (to_visit + 1024 >= (CELL **)AuxSp) {
goto aux_overflow;
}
#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 */
if (to_visit + 1024 >= (CELL **)AuxSp) {
goto aux_overflow;
}
#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 = numbervar(numbv++);
/* leave an empty slot to fill in later */
if (H+1024 > ASP) {
goto global_overflow;
}
/* next make sure noone will see this as a variable again */
if (TR > (tr_fr_ptr)LOCAL_TrailTop - 256) {
/* Trail overflow */
if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) {
goto trail_overflow;
}
}
TrailTerm(TR++) = (CELL)ptd0;
}
/* Do we still have compound terms to visit */
if (to_visit > to_visit0) {
#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;
}
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
return numbv;
trail_overflow:
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
}
#endif
LOCAL_Error_TYPE = OUT_OF_TRAIL_ERROR;
LOCAL_Error_Size = (TR-TR0)*sizeof(tr_fr_ptr *);
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
H = InitialH;
return -1;
aux_overflow:
LOCAL_Error_Size = (to_visit-to_visit0)*sizeof(CELL **);
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
}
#endif
LOCAL_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
H = InitialH;
return -1;
global_overflow:
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
}
#endif
clean_tr(TR0 PASS_REGS);
Yap_ReleasePreAllocCodeSpace((ADDR)to_visit0);
H = InitialH;
LOCAL_Error_TYPE = OUT_OF_STACK_ERROR;
LOCAL_Error_Size = (ASP-H)*sizeof(CELL);
return -1;
}
Int
Yap_NumberVars( Term inp, Int numbv ) /* numbervariables in term t */
{
CACHE_REGS
Int out;
Term t;
restart:
t = Deref(inp);
if (IsVarTerm(t)) {
CELL *ptd0 = VarOfTerm(t);
*ptd0 = numbervar(numbv);
TrailTerm(TR++) = (CELL)ptd0;
return numbv+1;
} else if (IsPrimitiveTerm(t)) {
return numbv;
} else if (IsPairTerm(t)) {
out = numbervars_in_complex_term(RepPair(t)-1,
RepPair(t)+1, numbv PASS_REGS);
} else {
Functor f = FunctorOfTerm(t);
out = numbervars_in_complex_term(RepAppl(t),
RepAppl(t)+
ArityOfFunctor(f), numbv PASS_REGS);
}
if (out < 0) {
if (!expand_vts( 3 PASS_REGS ))
return FALSE;
goto restart;
}
return out;
}
static Int
p_numbervars(void)
{
Term t2 = Deref(ARG2);
Int out;
if (IsVarTerm(t2)) {
Yap_Error(INSTANTIATION_ERROR,t2,"numbervars/3");
return FALSE;
}
if (!IsIntegerTerm(t2)) {
Yap_Error(TYPE_ERROR_INTEGER,t2,"term_hash/4");
return(FALSE);
}
if ((out = Yap_NumberVars(ARG1, IntegerOfTerm(t2))) < 0)
return FALSE;
return Yap_unify(ARG3, MkIntegerTerm(out));
}
static int
unnumber_complex_term(CELL *pt0, CELL *pt0_end, CELL *ptf, CELL *HLow USES_REGS)
{
struct cp_frame *to_visit0, *to_visit = (struct cp_frame *)Yap_PreAllocCodeSpace();
CELL *HB0 = HB;
tr_fr_ptr TR0 = TR;
int ground = TRUE;
Int max = -1;
HB = HLow;
to_visit0 = to_visit;
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++ pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, unnumber_term_unk);
unnumber_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+1 >= (struct cp_frame *)AuxSp) {
goto heap_overflow;
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->oldv = *pt0;
to_visit->ground = ground;
/* fool the system into thinking we had a variable there */
*pt0 = AbsPair(H);
to_visit ++;
#else
if (pt0 < pt0_end) {
if (to_visit+1 >= (struct cp_frame *)AuxSp) {
goto heap_overflow;
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->ground = ground;
to_visit ++;
}
#endif
ground = TRUE;
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 unnumber other extensions. */
continue;
}
if (f == FunctorVar) {
Int id = IntegerOfTerm(ap2[1]);
ground = FALSE;
if (id < -1) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, "unnumber vars cannot cope with VAR(-%d)", id);
return 0L;
}
if (id <= max) {
if (ASP-(max+1) <= H) {
goto overflow;
}
/* we found this before */
*ptf++ = ASP[-id-1];
continue;
}
max = id;
if (ASP-(max+1) <= H) {
goto overflow;
}
/* new variable */
RESET_VARIABLE(ptf);
ASP[-id-1] = (CELL)ptf;
ptf++;
continue;
}
*ptf = AbsAppl(H);
ptf++;
/* store the terms to visit */
#ifdef RATIONAL_TREES
if (to_visit+1 >= (struct cp_frame *)AuxSp) {
goto heap_overflow;
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->oldv = *pt0;
to_visit->ground = ground;
/* fool the system into thinking we had a variable there */
*pt0 = AbsAppl(H);
to_visit ++;
#else
if (pt0 < pt0_end) {
if (to_visit+1 >= (struct cp_frame *)AuxSp) {
goto heap_overflow;
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->ground = ground;
to_visit ++;
}
#endif
ground = (f != FunctorMutable);
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 unnumber atoms or integers */
*ptf++ = d0;
}
continue;
}
derefa_body(d0, ptd0, unnumber_term_unk, unnumber_term_nvar);
ground = FALSE;
*ptf++ = (CELL) ptd0;
}
/* Do we still have compound terms to visit */
if (to_visit > to_visit0) {
to_visit --;
if (ground) {
CELL old = to_visit->oldv;
CELL *newp = to_visit->to-1;
CELL new = *newp;
*newp = old;
if (IsApplTerm(new))
H = RepAppl(new);
else
H = RepPair(new);
}
pt0 = to_visit->start_cp;
pt0_end = to_visit->end_cp;
ptf = to_visit->to;
#ifdef RATIONAL_TREES
*pt0 = to_visit->oldv;
#endif
ground = (ground && to_visit->ground);
goto loop;
}
/* restore our nice, friendly, term to its original state */
clean_dirty_tr(TR0 PASS_REGS);
HB = HB0;
return ground;
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 > to_visit0) {
to_visit --;
pt0 = to_visit->start_cp;
pt0_end = to_visit->end_cp;
ptf = to_visit->to;
*pt0 = to_visit->oldv;
}
#endif
reset_trail(TR0);
/* follow chain of multi-assigned variables */
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 > to_visit0) {
to_visit --;
pt0 = to_visit->start_cp;
pt0_end = to_visit->end_cp;
ptf = to_visit->to;
*pt0 = to_visit->oldv;
}
#endif
reset_trail(TR0);
LOCAL_Error_Size = (ADDR)AuxSp-(ADDR)to_visit0;
return -3;
}
static Term
UnnumberTerm(Term inp, UInt arity USES_REGS) {
Term t = Deref(inp);
tr_fr_ptr TR0 = TR;
if (IsVarTerm(t)) {
return inp;
} 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 = unnumber_complex_term(ap-1, ap+1, Hi, Hi PASS_REGS)) < 0) {
H = Hi;
if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L)
return FALSE;
goto restart_list;
} else if (res) {
H = Hi;
return t;
}
}
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);
if (H > ASP-128) {
H = HB0;
if ((t = handle_cp_overflow(-1, TR0, arity, t))== 0L)
return FALSE;
goto restart_appl;
} else {
int res;
if ((res = unnumber_complex_term(ap, ap+ArityOfFunctor(f), HB0+1, HB0 PASS_REGS)) < 0) {
H = HB0;
if ((t = handle_cp_overflow(res, TR0, arity, t))== 0L)
return FALSE;
goto restart_appl;
} else if (res && FunctorOfTerm(t) != FunctorMutable) {
H = HB0;
return t;
}
}
return tf;
}
}
Term
Yap_UnNumberTerm(Term inp) {
CACHE_REGS
return UnnumberTerm(inp, 0 PASS_REGS);
}
static int
p_unnumbervars(void) {
return Yap_unify(Yap_UnNumberTerm(ARG1), ARG2);
}
void Yap_InitUtilCPreds(void)
{
CACHE_REGS
@ -4233,6 +4745,8 @@ void Yap_InitUtilCPreds(void)
Yap_InitCPred("import_term", 1, p_import_term, 0);
Yap_InitCPred("export_term", 1, p_export_term, 0);
#endif
Yap_InitCPred("numbervars", 3, p_numbervars, 0);
Yap_InitCPred("unnumbervars", 2, p_unnumbervars, 0);
CurrentModule = TERMS_MODULE;
Yap_InitCPred("variable_in_term", 2, p_var_in_term, 0);
Yap_InitCPred("term_hash", 4, p_term_hash, 0);

32
H/TermExt.h
View File

@ -58,13 +58,19 @@ blob_type;
#define FunctorDouble ((Functor)(double_e))
#define EndSpecials (double_e+sizeof(Functor *))
inline EXTERN int IsAttVar (CELL *pt);
inline EXTERN int
IsAttVar (CELL *pt)
{
#ifdef _YAP_NOT_INSTALLED_
CACHE_REGS
return (pt)[-1] == (CELL)attvar_e && pt < H;
return (pt)[-1] == (CELL)attvar_e
&& pt < H;
#else
return (pt)[-1] == (CELL)attvar_e;
#endif
}
inline EXTERN int GlobalIsAttVar (CELL *pt);
@ -142,6 +148,8 @@ exts;
#endif
#ifdef _YAP_NOT_INSTALLED_
/* make sure that these data structures are the first thing to be allocated
in the heap when we start the system */
#ifdef THREADS
@ -171,6 +179,7 @@ inline EXTERN Float STD_PROTO (CpFloatUnaligned, (CELL *));
#if SIZEOF_DOUBLE == SIZEOF_LONG_INT
inline EXTERN Term MkFloatTerm (Float);
inline EXTERN Term
@ -246,7 +255,6 @@ MkFloatTerm (Float dbl)
}
inline EXTERN Float FloatOfTerm (Term t);
inline EXTERN Float
@ -264,6 +272,14 @@ FloatOfTerm (Term t)
#endif
#endif
Term STD_PROTO (Yap_MkBlobStringTerm, (const char *, size_t len));
Term STD_PROTO (Yap_MkBlobWideStringTerm, (const wchar_t *, size_t len));
char *STD_PROTO (Yap_BlobStringOfTerm, (Term));
wchar_t *STD_PROTO (Yap_BlobWideStringOfTerm, (Term));
char *STD_PROTO (Yap_BlobStringOfTermAndLength, (Term, size_t *));
#endif /* YAP_NOT_INSTALLED */
inline EXTERN int IsFloatTerm (Term);
@ -278,6 +294,7 @@ IsFloatTerm (Term t)
/* extern Functor FunctorLongInt; */
#ifdef _YAP_NOT_INSTALLED_
inline EXTERN Term MkLongIntTerm (Int);
inline EXTERN Term
@ -291,6 +308,8 @@ MkLongIntTerm (Int i)
return AbsAppl(H - 3);
}
#endif
inline EXTERN Int LongIntOfTerm (Term t);
inline EXTERN Int
@ -402,12 +421,6 @@ typedef struct string_struct {
UInt len;
} blob_string_t;
Term STD_PROTO (Yap_MkBlobStringTerm, (const char *, size_t len));
Term STD_PROTO (Yap_MkBlobWideStringTerm, (const wchar_t *, size_t len));
char *STD_PROTO (Yap_BlobStringOfTerm, (Term));
wchar_t *STD_PROTO (Yap_BlobWideStringOfTerm, (Term));
char *STD_PROTO (Yap_BlobStringOfTermAndLength, (Term, size_t *));
inline EXTERN int IsBlobStringTerm (Term);
inline EXTERN int
@ -591,6 +604,8 @@ IsAttachedTerm (Term t)
#endif
#ifdef _YAP_NOT_INSTALLED_
inline EXTERN int STD_PROTO (unify_extension, (Functor, CELL, CELL *, CELL));
EXTERN int STD_PROTO (unify_extension, (Functor, CELL, CELL *, CELL));
@ -664,3 +679,4 @@ CELL Yap_Double_key(Term t)
return Yap_DoubleP_key(RepAppl(t)+1);
}
#endif

517
H/Yap.h
View File

@ -7,7 +7,7 @@
* *
**************************************************************************
* *
* File: Yap.h.m4 *
* File: Yap.h *
* mods: *
* comments: main header file for YAP *
* version: $Id: Yap.h,v 1.38 2008-06-18 10:02:27 vsc Exp $ *
@ -120,6 +120,15 @@
#define DUMMY_FILLER_FOR_ABS_TYPE int dummy;
#endif /* HAVE_GCC */
#ifdef THREADS
#if USE_PTHREAD_LOCKING
#ifndef _XOPEN_SOURCE
#define _XOPEN_SOURCE 600
#endif /* !_XOPEN_SOURCE */
#endif /* USE_PTHREAD_LOCKING */
#include <pthread.h>
#endif /* THREADS */
#ifndef ADTDEFS_C
#define EXTERN static
#else
@ -134,109 +143,9 @@
/* null pointer */
#define NIL 0
/* Basic types */
/* defines integer types Int and UInt (unsigned) with the same size as a ptr
** and integer types Short and UShort with half the size of a ptr */
#ifdef THREADS
#if USE_PTHREAD_LOCKING
#ifndef _XOPEN_SOURCE
#define _XOPEN_SOURCE 600
#endif /* !_XOPEN_SOURCE */
#endif /* USE_PTHREAD_LOCKING */
#include <pthread.h>
#endif /* THREADS */
#if SIZEOF_INT_P==4
#if SIZEOF_INT==4
/* */ typedef int Int;
/* */ typedef unsigned int UInt;
#define Int_FORMAT "%d"
#define UInt_FORMAT "%u"
#elif SIZEOF_LONG_INT==4
/* */ typedef long int Int;
/* */ typedef unsigned long int UInt;
#define Int_FORMAT "%ld"
#define UInt_FORMAT "%lu"
#else
#error Yap require integer types of the same size as a pointer
#endif
#if SIZEOF_SHORT_INT==2
/* */ typedef short int Short;
/* */ typedef unsigned short int UShort;
#else
# error Yap requires integer types half the size of a pointer
#endif
#elif SIZEOF_INT_P==8
#if SIZEOF_INT==8
/* */ typedef int Int;
/* */ typedef unsigned int UInt;
#define Int_FORMAT "%d"
#define UInt_FORMAT "%u"
#elif SIZEOF_LONG_INT==8
/* */ typedef long int Int;
/* */ typedef unsigned long int UInt;
#define Int_FORMAT "%ld"
#define UInt_FORMAT "%lu"
# elif SIZEOF_LONG_LONG_INT==8
/* */ typedef long long int Int;
/* */ typedef unsigned long long int UInt;
#define Int_FORMAT "%I64d"
#define UInt_FORMAT "%I64u"
# else
# error Yap requires integer types of the same size as a pointer
# endif
# if SIZEOF_SHORT_INT==4
/* */ typedef short int Short;
/* */ typedef unsigned short int UShort;
# elif SIZEOF_INT==4
/* */ typedef int Short;
/* */ typedef unsigned int UShort;
# else
# error Yap requires integer types half the size of a pointer
# endif
#else
# error Yap requires pointers of size 4 or 8
#endif
/* */ typedef double Float;
#if SIZEOF_INT<SIZEOF_INT_P
#define SHORT_INTS 1
#else
#define SHORT_INTS 0
#endif
#ifdef __GNUC__
typedef long long int YAP_LONG_LONG;
typedef unsigned long long int YAP_ULONG_LONG;
#else
typedef long int YAP_LONG_LONG;
typedef unsigned long int YAP_ULONG_LONG;
#endif
#include "YapTerm.h"
#if HAVE_SIGPROF && (defined(__linux__) || defined(__APPLE__))
#define LOW_PROF 1
@ -284,12 +193,6 @@ typedef unsigned long int YAP_ULONG_LONG;
#ifndef SHORT_ADDRESSES
# define LONG_ADDRESSES 1
#else
# define LONG_ADDRESSES 0
#endif
#ifndef ALIGN_LONGS
#define ALIGN_LONGS 1
#endif
@ -300,15 +203,6 @@ typedef unsigned long int YAP_ULONG_LONG;
#define M1 ((CELL)(1024*1024))
#define M2 ((CELL)(2048*1024))
/*************************************************************************************************
basic data types
*************************************************************************************************/
typedef UInt CELL;
typedef UShort BITS16;
typedef Short SBITS16;
typedef UInt BITS32;
#if ALIGN_LONGS
typedef CELL SFLAGS;
#else
@ -319,19 +213,10 @@ typedef char *ADDR;
typedef CELL OFFSET;
typedef unsigned char *CODEADDR;
#define WordSize sizeof(BITS16)
#define CellSize sizeof(CELL)
#define SmallSize sizeof(SMALLUNSGN)
#define ALIGN_YAPTYPE(X,TYPE) (((CELL)(X)+(sizeof(TYPE)-1)) & ~(sizeof(TYPE)-1))
/*************************************************************************************************
type casting macros
*************************************************************************************************/
#define TermPtr(V) ((Term *) (V))
#define Addr(V) ((ADDR) (V))
#define Unsigned(V) ((CELL) (V))
#define Signed(V) ((Int) (V))
#define CodePtr(V) ((CODEADDR)(V))
#define CellPtr(V) ((CELL *)(V))
@ -340,13 +225,6 @@ typedef unsigned char *CODEADDR;
#define SmallPtr(V) ((SMALLUNSGN *)(V))
#define WordPtr(V) ((BITS16 *)(V))
#define DisplPtr(V) ((DISPREG *)(V))
#define TermPtr(V) ((Term *) (V))
/*************************************************************************************************
Abstract Type Definitions for YAPProlog
*************************************************************************************************/
typedef CELL Term;
#if !defined(YAPOR) && !defined(THREADS)
#include <nolocks.h>
@ -631,123 +509,7 @@ typedef enum
#include "Yapproto.h"
/***********************************************************************/
/*
absrectype Term = Int + Float + Atom + Pair + Appl + Ref + Var
with AbsAppl(t) : *CELL -> Term
and RepAppl(t) : Term -> *CELL
and AbsPair(t) : *CELL -> Term
and RepPair(t) : Term -> *CELL
and IsIntTerm(t) = ...
and IsAtomTerm(t) = ...
and IsVarTerm(t) = ...
and IsPairTerm(t) = ...
and IsApplTerm(t) = ...
and IsFloatTerm(t) = ...
and IsRefTerm(t) = ...
and IsNonVarTerm(t) = ! IsVar(t)
and IsNumterm(t) = IsIntTerm(t) || IsFloatTerm(t)
and IsAtomicTerm(t) = IsNumTerm(t) || IsAtomTerm(t)
and IsPrimitiveTerm(t) = IsAtomicTerm(t) || IsRefTerm(t)
and MkIntTerm(n) = ...
and MkFloatTerm(f) = ...
and MkAtomTerm(a) = ...
and MkVarTerm(r) = ...
and MkApplTerm(f,n,args) = ...
and MkPairTerm(hd,tl) = ...
and MkRefTerm(R) = ...
and PtrOfTerm(t) : Term -> CELL * = ...
and IntOfTerm(t) : Term -> int = ...
and FloatOfTerm(t) : Term -> flt = ...
and AtomOfTerm(t) : Term -> Atom = ...
and VarOfTerm(t) : Term -> *Term = ....
and HeadOfTerm(t) : Term -> Term = ...
and TailOfTerm(t) : Term -> Term = ...
and FunctorOfTerm(t) : Term -> Functor = ...
and ArgOfTerm(i,t) : Term -> Term= ...
and RefOfTerm(t) : Term -> DBRef = ...
*/
/*
YAP can use several different tag schemes, according to the kind of
machine we are experimenting with.
*/
#if LONG_ADDRESSES && defined(OLD_TAG_SCHEME)
#include "Tags_32bits.h"
#endif /* LONG_ADDRESSES && defined(OLD_TAG_SCHEME) */
/* AIX will by default place mmaped segments at 0x30000000. This is
incompatible with the high tag scheme. Linux-ELF also does not like
if you place things in the lower addresses (power to the libc people).
*/
#if defined(__APPLE__)
/* mmap on __APPLE__ is not the greatest idea. It overwrites memory allocated by malloc */
#undef USE_DL_MALLOC
#ifndef USE_SYSTEM_MALLOC
#define USE_SYSTEM_MALLOC 1
#endif
#elif (defined(_AIX) || (defined(__APPLE__) && !defined(__LP64__)) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(__POWERPC__) || defined(__linux__) || defined(IN_SECOND_QUADRANT) || defined(__CYGWIN__)) || defined(__NetBSD__) || defined(__DragonFly__)
#define USE_LOW32_TAGS 1
#endif
#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS)
#include "Tags_32Ops.h"
#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) */
#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && defined(USE_LOW32_TAGS)
#include "Tags_32LowTag.h"
#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) */
#if LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME)
#include "Tags_64bits.h"
#endif /* LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) */
#if !LONG_ADDRESSES
#include "Tags_24bits.h"
#endif /* !LONG_ADDRESSES */
#ifdef TAG_LOW_BITS_32
#if !GC_NO_TAGS
#define MBIT 0x80000000
#define RBIT 0x40000000
#if IN_SECOND_QUADRANT
#define INVERT_RBIT 1 /* RBIT is 1 by default */
#endif
#endif /* !GC_NO_TAGS */
#else
#if !GC_NO_TAGS
#if defined(YAPOR_SBA) && defined(__linux__)
#define MBIT /* 0x20000000 */ MKTAG(0x1,0) /* mark bit */
#else
#define RBIT /* 0x20000000 */ MKTAG(0x1,0) /* relocation chain bit */
#define MBIT /* 0x40000000 */ MKTAG(0x2,0) /* mark bit */
#endif
#endif /* !GC_NO_TAGS */
#endif
#include "YapTags.h"
#define TermSize sizeof(Term)
@ -771,259 +533,6 @@ extern ADDR Yap_HeapBase;
extern int Yap_output_msg;
#endif
/*************************************************************************************************
???
*************************************************************************************************/
#define MkVarTerm() MkVarTerm__( PASS_REGS1 )
#define MkPairTerm(A,B) MkPairTerm__( A, B PASS_REGS )
/*************************************************************************************************
applies to unbound variables
*************************************************************************************************/
inline EXTERN Term *VarOfTerm (Term t);
inline EXTERN Term *
VarOfTerm (Term t)
{
return (Term *) (t);
}
#ifdef YAPOR_SBA
inline EXTERN Term MkVarTerm__ ( USES_REGS1 );
inline EXTERN Term
MkVarTerm__ ( USES_REGS1 )
{
return (Term) ((*H = 0, H++));
}
inline EXTERN int IsUnboundVar (Term *);
inline EXTERN int
IsUnboundVar (Term * t)
{
return (int) (*(t) == 0);
}
#else
inline EXTERN Term MkVarTerm__ ( USES_REGS1 );
inline EXTERN Term
MkVarTerm__ ( USES_REGS1 )
{
return (Term) ((*H = (CELL) H, H++));
}
inline EXTERN int IsUnboundVar (Term *);
inline EXTERN int
IsUnboundVar (Term * t)
{
return (int) (*(t) == (Term) (t));
}
#endif
inline EXTERN CELL *PtrOfTerm (Term);
inline EXTERN CELL *
PtrOfTerm (Term t)
{
return (CELL *) (*(CELL *) (t));
}
inline EXTERN Functor FunctorOfTerm (Term);
inline EXTERN Functor
FunctorOfTerm (Term t)
{
return (Functor) (*RepAppl (t));
}
#if USE_LOW32_TAGS
inline EXTERN Term MkAtomTerm (Atom);
inline EXTERN Term
MkAtomTerm (Atom a)
{
return (Term) (AtomTag | (CELL) (a));
}
inline EXTERN Atom AtomOfTerm (Term t);
inline EXTERN Atom
AtomOfTerm (Term t)
{
return (Atom) ((~AtomTag & (CELL) (t)));
}
#else
inline EXTERN Term MkAtomTerm (Atom);
inline EXTERN Term
MkAtomTerm (Atom a)
{
return (Term) (TAGGEDA ((CELL)AtomTag, (CELL) (a)));
}
inline EXTERN Atom AtomOfTerm (Term t);
inline EXTERN Atom
AtomOfTerm (Term t)
{
return (Atom) (NonTagPart (t));
}
#endif
inline EXTERN int IsAtomTerm (Term);
inline EXTERN int
IsAtomTerm (Term t)
{
return (int) (CHKTAG ((t), AtomTag));
}
inline EXTERN Term MkIntTerm (Int);
inline EXTERN Term
MkIntTerm (Int n)
{
return (Term) (TAGGED (NumberTag, (n)));
}
/*
A constant to subtract or add to a well-known term, we assume no
overflow problems are possible
*/
inline EXTERN Term MkIntConstant (Int);
inline EXTERN Term
MkIntConstant (Int n)
{
return (Term) (NONTAGGED (NumberTag, (n)));
}
inline EXTERN int IsIntTerm (Term);
inline EXTERN int
IsIntTerm (Term t)
{
return (int) (CHKTAG ((t), NumberTag));
}
EXTERN inline Term STD_PROTO (MkPairTerm__, (Term, Term CACHE_TYPE) );
EXTERN inline Term
MkPairTerm__ (Term head, Term tail USES_REGS)
{
register CELL *p = H;
H[0] = head;
H[1] = tail;
H += 2;
return (AbsPair (p));
}
/* Needed to handle numbers:
these two macros are fundamental in the integer/float conversions */
#ifdef M_WILLIAMS
#define IntInBnd(X) (TRUE)
#else
#ifdef TAGS_FAST_OPS
#define IntInBnd(X) (Unsigned( ( (Int)(X) >> (32-7) ) + 1) <= 1)
#else
#define IntInBnd(X) ( (X) < MAX_ABS_INT && \
(X) > -MAX_ABS_INT-1L )
#endif
#endif
#ifdef C_PROLOG
#define FlIsInt(X) ( (X) == (Int)(X) && IntInBnd((X)) )
#else
#define FlIsInt(X) ( FALSE )
#endif
/*
There are two types of functors:
o Special functors mark special terms
on the heap that should be seen as constants.
o Standard functors mark normal applications.
*/
#include "TermExt.h"
#define IsAccessFunc(func) ((func) == FunctorAccess)
inline EXTERN Term MkIntegerTerm (Int);
inline EXTERN Term
MkIntegerTerm (Int n)
{
return (Term) (IntInBnd (n) ? MkIntTerm (n) : MkLongIntTerm (n));
}
inline EXTERN int IsIntegerTerm (Term);
inline EXTERN int
IsIntegerTerm (Term t)
{
return (int) (IsIntTerm (t) || IsLongIntTerm (t));
}
inline EXTERN Int IntegerOfTerm (Term);
inline EXTERN Int
IntegerOfTerm (Term t)
{
return (Int) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t));
}
/*************************************************************************************************
variables concerned with atoms table
*************************************************************************************************/

398
H/YapTags.h Normal file
View File

@ -0,0 +1,398 @@
/*************************************************************************
* *
* YAP Prolog %W% %G% *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: YapTags.h *
* mods: *
* comments: Term Operations for YAP *
* version: $Id: Yap.h,v 1.38 2008-06-18 10:02:27 vsc Exp $ *
*************************************************************************/
#ifndef EXTERN
#define EXTERN extern
#endif
#ifndef SHORT_ADDRESSES
# define LONG_ADDRESSES 1
#else
# define LONG_ADDRESSES 0
#endif
/***********************************************************************/
/*
absrectype Term = Int + Float + Atom + Pair + Appl + Ref + Var
with AbsAppl(t) : *CELL -> Term
and RepAppl(t) : Term -> *CELL
and AbsPair(t) : *CELL -> Term
and RepPair(t) : Term -> *CELL
and IsIntTerm(t) = ...
and IsAtomTerm(t) = ...
and IsVarTerm(t) = ...
and IsPairTerm(t) = ...
and IsApplTerm(t) = ...
and IsFloatTerm(t) = ...
and IsRefTerm(t) = ...
and IsNonVarTerm(t) = ! IsVar(t)
and IsNumterm(t) = IsIntTerm(t) || IsFloatTerm(t)
and IsAtomicTerm(t) = IsNumTerm(t) || IsAtomTerm(t)
and IsPrimitiveTerm(t) = IsAtomicTerm(t) || IsRefTerm(t)
and MkIntTerm(n) = ...
and MkFloatTerm(f) = ...
and MkAtomTerm(a) = ...
and MkVarTerm(r) = ...
and MkApplTerm(f,n,args) = ...
and MkPairTerm(hd,tl) = ...
and MkRefTerm(R) = ...
and PtrOfTerm(t) : Term -> CELL * = ...
and IntOfTerm(t) : Term -> int = ...
and FloatOfTerm(t) : Term -> flt = ...
and AtomOfTerm(t) : Term -> Atom = ...
and VarOfTerm(t) : Term -> *Term = ....
and HeadOfTerm(t) : Term -> Term = ...
and TailOfTerm(t) : Term -> Term = ...
and FunctorOfTerm(t) : Term -> Functor = ...
and ArgOfTerm(i,t) : Term -> Term= ...
and RefOfTerm(t) : Term -> DBRef = ...
*/
/*
YAP can use several different tag schemes, according to the kind of
machine we are experimenting with.
*/
#if LONG_ADDRESSES && defined(OLD_TAG_SCHEME)
#include "Tags_32bits.h"
#endif /* LONG_ADDRESSES && defined(OLD_TAG_SCHEME) */
/* AIX will by default place mmaped segments at 0x30000000. This is
incompatible with the high tag scheme. Linux-ELF also does not like
if you place things in the lower addresses (power to the libc people).
*/
#if defined(__APPLE__)
/* mmap on __APPLE__ is not the greatest idea. It overwrites memory allocated by malloc */
#undef USE_DL_MALLOC
#ifndef USE_SYSTEM_MALLOC
#define USE_SYSTEM_MALLOC 1
#endif
#elif (defined(_AIX) || (defined(__APPLE__) && !defined(__LP64__)) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(__POWERPC__) || defined(__linux__) || defined(IN_SECOND_QUADRANT) || defined(__CYGWIN__)) || defined(__NetBSD__) || defined(__DragonFly__)
#define USE_LOW32_TAGS 1
#endif
#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS)
#include "Tags_32Ops.h"
#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) && !defined(USE_LOW32_TAGS) */
#if LONG_ADDRESSES && SIZEOF_INT_P==4 && !defined(OLD_TAG_SCHEME) && defined(USE_LOW32_TAGS)
#include "Tags_32LowTag.h"
#endif /* LONG_ADDRESSES && !defined(OLD_TAG_SCHEME) */
#if LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME)
#include "Tags_64bits.h"
#endif /* LONG_ADDRESSES && SIZEOF_INT_P==8 && !defined(OLD_TAG_SCHEME) */
#if !LONG_ADDRESSES
#include "Tags_24bits.h"
#endif /* !LONG_ADDRESSES */
#ifdef TAG_LOW_BITS_32
#if !GC_NO_TAGS
#define MBIT 0x80000000
#define RBIT 0x40000000
#if IN_SECOND_QUADRANT
#define INVERT_RBIT 1 /* RBIT is 1 by default */
#endif
#endif /* !GC_NO_TAGS */
#else
#if !GC_NO_TAGS
#if defined(YAPOR_SBA) && defined(__linux__)
#define MBIT /* 0x20000000 */ MKTAG(0x1,0) /* mark bit */
#else
#define RBIT /* 0x20000000 */ MKTAG(0x1,0) /* relocation chain bit */
#define MBIT /* 0x40000000 */ MKTAG(0x2,0) /* mark bit */
#endif
#endif /* !GC_NO_TAGS */
#endif
/*************************************************************************************************
???
*************************************************************************************************/
#define MkVarTerm() MkVarTerm__( PASS_REGS1 )
#define MkPairTerm(A,B) MkPairTerm__( A, B PASS_REGS )
/*************************************************************************************************
applies to unbound variables
*************************************************************************************************/
inline EXTERN Term *VarOfTerm (Term t);
inline EXTERN Term *
VarOfTerm (Term t)
{
return (Term *) (t);
}
#ifdef YAPOR_SBA
inline EXTERN Term MkVarTerm__ ( USES_REGS1 );
inline EXTERN Term
MkVarTerm__ ( USES_REGS1 )
{
return (Term) ((*H = 0, H++));
}
inline EXTERN int IsUnboundVar (Term *);
inline EXTERN int
IsUnboundVar (Term * t)
{
return (int) (*(t) == 0);
}
#else
#ifdef _YAP_NOT_INSTALLED_
inline EXTERN Term MkVarTerm__ ( USES_REGS1 );
inline EXTERN Term
MkVarTerm__ ( USES_REGS1 )
{
return (Term) ((*H = (CELL) H, H++));
}
#endif
inline EXTERN int IsUnboundVar (Term *);
inline EXTERN int
IsUnboundVar (Term * t)
{
return (int) (*(t) == (Term) (t));
}
#endif
inline EXTERN CELL *PtrOfTerm (Term);
inline EXTERN CELL *
PtrOfTerm (Term t)
{
return (CELL *) (*(CELL *) (t));
}
inline EXTERN Functor FunctorOfTerm (Term);
inline EXTERN Functor
FunctorOfTerm (Term t)
{
return (Functor) (*RepAppl (t));
}
#if USE_LOW32_TAGS
inline EXTERN Term MkAtomTerm (Atom);
inline EXTERN Term
MkAtomTerm (Atom a)
{
return (Term) (AtomTag | (CELL) (a));
}
inline EXTERN Atom AtomOfTerm (Term t);
inline EXTERN Atom
AtomOfTerm (Term t)
{
return (Atom) ((~AtomTag & (CELL) (t)));
}
#else
inline EXTERN Term MkAtomTerm (Atom);
inline EXTERN Term
MkAtomTerm (Atom a)
{
return (Term) (TAGGEDA ((CELL)AtomTag, (CELL) (a)));
}
inline EXTERN Atom AtomOfTerm (Term t);
inline EXTERN Atom
AtomOfTerm (Term t)
{
return (Atom) (NonTagPart (t));
}
#endif
inline EXTERN int IsAtomTerm (Term);
inline EXTERN int
IsAtomTerm (Term t)
{
return (int) (CHKTAG ((t), AtomTag));
}
inline EXTERN Term MkIntTerm (Int);
inline EXTERN Term
MkIntTerm (Int n)
{
return (Term) (TAGGED (NumberTag, (n)));
}
/*
A constant to subtract or add to a well-known term, we assume no
overflow problems are possible
*/
inline EXTERN Term MkIntConstant (Int);
inline EXTERN Term
MkIntConstant (Int n)
{
return (Term) (NONTAGGED (NumberTag, (n)));
}
inline EXTERN int IsIntTerm (Term);
inline EXTERN int
IsIntTerm (Term t)
{
return (int) (CHKTAG ((t), NumberTag));
}
#ifdef _YAP_NOT_INSTALLED_
EXTERN inline Term STD_PROTO (MkPairTerm__, (Term, Term CACHE_TYPE) );
EXTERN inline Term
MkPairTerm__ (Term head, Term tail USES_REGS)
{
register CELL *p = H;
H[0] = head;
H[1] = tail;
H += 2;
return (AbsPair (p));
}
#endif
/* Needed to handle numbers:
these two macros are fundamental in the integer/float conversions */
#ifdef M_WILLIAMS
#define IntInBnd(X) (TRUE)
#else
#ifdef TAGS_FAST_OPS
#define IntInBnd(X) (Unsigned( ( (Int)(X) >> (32-7) ) + 1) <= 1)
#else
#define IntInBnd(X) ( (X) < MAX_ABS_INT && \
(X) > -MAX_ABS_INT-1L )
#endif
#endif
#ifdef C_PROLOG
#define FlIsInt(X) ( (X) == (Int)(X) && IntInBnd((X)) )
#else
#define FlIsInt(X) ( FALSE )
#endif
/*
There are two types of functors:
o Special functors mark special terms
on the heap that should be seen as constants.
o Standard functors mark normal applications.
*/
#include "TermExt.h"
#define IsAccessFunc(func) ((func) == FunctorAccess)
#ifdef _YAP_NOT_INSTALLED_
inline EXTERN Term MkIntegerTerm (Int);
inline EXTERN Term
MkIntegerTerm (Int n)
{
return (Term) (IntInBnd (n) ? MkIntTerm (n) : MkLongIntTerm (n));
}
#endif
inline EXTERN int IsIntegerTerm (Term);
inline EXTERN int
IsIntegerTerm (Term t)
{
return (int) (IsIntTerm (t) || IsLongIntTerm (t));
}
inline EXTERN Int IntegerOfTerm (Term);
inline EXTERN Int
IntegerOfTerm (Term t)
{
return (Int) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t));
}

5
H/Yapproto.h
View File

@ -140,7 +140,7 @@ void STD_PROTO(Yap_AssertzClause,(struct pred_entry *, yamop *));
/* cmppreds.c */
int STD_PROTO(Yap_compare_terms,(Term,Term));
Int STD_PROTO(Yap_compare_terms,(Term,Term));
void STD_PROTO(Yap_InitCmpPreds,(void));
/* compiler.c */
@ -379,6 +379,7 @@ int STD_PROTO(Yap_rational_tree_loop, (CELL *, CELL *, CELL **, CELL **
void STD_PROTO(Yap_InitAbsmi,(void));
void STD_PROTO(Yap_InitUnify,(void));
void STD_PROTO(Yap_TrimTrail,(void));
int STD_PROTO(Yap_Unifiable,(Term d0, Term d1));
int STD_PROTO(Yap_IUnify,(register CELL d0,register CELL d1));
/* userpreds.c */
@ -396,6 +397,8 @@ int STD_PROTO(Yap_SizeGroundTerm,(Term, int));
int STD_PROTO(Yap_IsGroundTerm,(Term));
void STD_PROTO(Yap_InitUtilCPreds,(void));
Int STD_PROTO(Yap_TermHash,(Term, Int, Int, int));
Int STD_PROTO(Yap_NumberVars,(Term, Int));
Term STD_PROTO(Yap_UnNumberTerm,(Term));
/* yap.c */

13
H/absmi.h
View File

@ -1583,3 +1583,16 @@ void SET_ASP__(CELL *yreg, Int sz USES_REGS) {
#define INITIALIZE_PERMVAR(PTR, V) *(PTR) = (V)
#endif
/* l1: bind a, l2 bind b, l3 no binding */
#define UnifyAndTrailCells(a, b) \
if((a) > (b)) { \
if ((a) < H) { *(a) = (CELL)(b); DO_TRAIL((a),(CELL)(b)); } \
else if ((b) <= H) { *(a) =(CELL)(b); DO_TRAIL((a),(CELL)(b));} \
else { *(b) = (CELL)(a); DO_TRAIL((b),(CELL)(a)); } \
} else if((a) < (b)){ \
if ((b) <= H) { *(b) = (CELL)(a); DO_TRAIL((b),(CELL)(a)); } \
else if ((a) <= H) { *(b) = (CELL) (a); DO_TRAIL((b),(CELL)(a));} \
else { *(a) = (CELL) (b); DO_TRAIL((a),(CELL)(b));} \
}

1
H/iatoms.h
View File

@ -150,6 +150,7 @@
AtomLT = Yap_LookupAtom("<");
AtomLastExecuteWithin = Yap_FullLookupAtom("$last_execute_within");
AtomLeash = Yap_FullLookupAtom("$leash");
AtomLength = Yap_FullLookupAtom("length");
AtomList = Yap_LookupAtom("list");
AtomLive = Yap_FullLookupAtom("$live");
AtomLoadAnswers = Yap_LookupAtom("load_answers");

3
H/pl-yap.h
View File

@ -124,6 +124,9 @@ void PL_license(const char *license, const char *module);
#define isVar(A) YAP_IsVarTerm((A))
#define valReal(w) YAP_FloatOfTerm((w))
#define valFloat(w) YAP_FloatOfTerm((w))
#ifdef AtomLength /* there is another AtomLength in the system */
#undef AtomLength
#endif
#define AtomLength(w) YAP_AtomNameLength(w)
#define atomValue(atom) YAP_AtomFromSWIAtom(atom)
#define atomFromTerm(term) YAP_SWIAtomFromAtom(YAP_AtomOfTerm(term))

1
H/ratoms.h
View File

@ -150,6 +150,7 @@
AtomLT = AtomAdjust(AtomLT);
AtomLastExecuteWithin = AtomAdjust(AtomLastExecuteWithin);
AtomLeash = AtomAdjust(AtomLeash);
AtomLength = AtomAdjust(AtomLength);
AtomList = AtomAdjust(AtomList);
AtomLive = AtomAdjust(AtomLive);
AtomLoadAnswers = AtomAdjust(AtomLoadAnswers);

2
H/tatoms.h
View File

@ -298,6 +298,8 @@
#define AtomLastExecuteWithin Yap_heap_regs->AtomLastExecuteWithin_
Atom AtomLeash_;
#define AtomLeash Yap_heap_regs->AtomLeash_
Atom AtomLength_;
#define AtomLength Yap_heap_regs->AtomLength_
Atom AtomList_;
#define AtomList Yap_heap_regs->AtomList_
Atom AtomLive_;

28
Makefile.in
View File

@ -115,6 +115,16 @@ INTERFACE_HEADERS = \
$(srcdir)/include/yap_structs.h \
$(srcdir)/include/YapInterface.h \
$(srcdir)/include/SWI-Prolog.h \
$(srcdir)/H/TermExt.h \
$(srcdir)/H/YapTags.h \
$(srcdir)/H/Tags_32bits.h \
$(srcdir)/H/Tags_32Ops.h \
$(srcdir)/H/Tags_32LowTag.h \
$(srcdir)/H/Tags_64bits.h \
$(srcdir)/H/Tags_24bits.h \
$(srcdir)/H/YapTerm.h \
$(srcdir)/include/YapRegs.h \
$(srcdir)/library/dialect/bprolog/fli/bprolog.h \
$(srcdir)/os/SWI-Stream.h
IOLIB_HEADERS=$(srcdir)/os/pl-buffer.h \
@ -135,13 +145,7 @@ IOLIB_HEADERS=$(srcdir)/os/pl-buffer.h \
$(srcdir)/H/pl-yap.h @ENABLE_WINCONSOLE@ $(srcdir)/os/windows/dirent.h $(srcdir)/os/windows/utf8.h $(srcdir)/os/windows/utf8.c $(srcdir)/os/windows/uxnt.h $(srcdir)/os/windows/mswchar.h $(srcdir)/os/windows/popen.c
HEADERS = \
$(srcdir)/H/TermExt.h \
$(srcdir)/H/Atoms.h \
$(srcdir)/H/Tags_32bits.h \
$(srcdir)/H/Tags_32Ops.h \
$(srcdir)/H/Tags_32LowTag.h \
$(srcdir)/H/Tags_64bits.h \
$(srcdir)/H/Tags_24bits.h \
$(srcdir)/H/sshift.h \
$(srcdir)/H/Yap.h \
$(srcdir)/H/Yatom.h \
@ -406,7 +410,7 @@ all: parms.h startup.yss @ENABLE_WINCONSOLE@ pl-yap@EXEC_SUFFIX@
Makefile: $(srcdir)/Makefile.in
$(srcdir)/H/Yap.h: config.h
$(srcdir)/H/Yap.h: config.h YapTermConfig.h $(srcdir)/H/YapTags.h
config.h: parms.h
@ -774,10 +778,12 @@ install_unix: startup.yss libYap.a
@ENABLE_JPL@ @INSTALL_DLLS@ (cd packages/jpl; $(MAKE) install)
#@ENABLE_JPL@ @INSTALL_DLLS@ (cd packages/pyswip; $(MAKE) install)
mkdir -p $(DESTDIR)$(INCLUDEDIR)
$(INSTALL) $(HEADERS) $(DESTDIR)$(INCLUDEDIR)
mkdir -p $(DESTDIR)$(INCLUDEDIR)/src
$(INSTALL) $(HEADERS) $(DESTDIR)$(INCLUDEDIR)/src
for h in $(INTERFACE_HEADERS); do $(INSTALL) $$h $(DESTDIR)$(INCLUDEDIR); done
$(INSTALL) config.h $(DESTDIR)$(INCLUDEDIR)/config.h
$(INSTALL) parms.h $(DESTDIR)$(INCLUDEDIR)/parms.h
$(INSTALL) config.h $(DESTDIR)$(INCLUDEDIR)/src/config.h
$(INSTALL) parms.h $(DESTDIR)$(INCLUDEDIR)/src/parms.h
$(INSTALL) YapTermConfig.h $(DESTDIR)$(INCLUDEDIR)
@ENABLE_CPLINT@ (cd packages/cplint; $(MAKE) install)
@ENABLE_CPLINT@ (cd packages/cplint/approx/simplecuddLPADs; $(MAKE) install)
@ENABLE_CUDD@ (cd packages/ProbLog/simplecudd; $(MAKE) install)
@ -859,7 +865,7 @@ TAGS: $(C_SOURCES) $(PL_SOURCES) $(HEADERS)
depend: $(HEADERS) $(C_SOURCES)
-@if test "$(GCC)" = yes; then\
$(CC) -MM $(CFLAGS) -I$(srcdir) -I$(srcdir)/include -I$(srcdir)/os $(C_SOURCES) >> Makefile;\
$(CC) -MM $(CFLAGS) -D__YAP_NOT_INSTALLED__=1 -I$(srcdir) -I$(srcdir)/include -I$(srcdir)/os $(C_SOURCES) >> Makefile;\
else\
makedepend -f - -- $(CFLAGS) -I$(srcdir)/include -- $(C_SOURCES) |\
sed 's|.*/\([^:]*\):|\1:|' >> Makefile ;\

2
OPTYap/opt.config.h
View File

@ -16,7 +16,7 @@
/************************************************************************
** General Configuration Parameters **
************************************************************************/
#define MODE_DIRECTED_TABLING
/******************************************************************************************
** use shared pages memory alloc scheme for OPTYap data structures? (optional) **
******************************************************************************************/

142
OPTYap/opt.preds.c
View File

@ -39,6 +39,9 @@ static Int p_wake_choice_point( USES_REGS1 );
static Int p_abolish_frozen_choice_points_until( USES_REGS1 );
static Int p_abolish_frozen_choice_points_all( USES_REGS1 );
static Int p_table( USES_REGS1 );
#ifdef MODE_DIRECTED_TABLING
static Int p_table_mode_directed( USES_REGS1 );
#endif /*MODE_DIRECTED_TABLING*/
static Int p_tabling_mode( USES_REGS1 );
static Int p_abolish_table( USES_REGS1 );
static Int p_abolish_all_tables( USES_REGS1 );
@ -122,6 +125,9 @@ void Yap_init_optyap_preds(void) {
Yap_InitCPred("abolish_frozen_choice_points", 1, p_abolish_frozen_choice_points_until, SafePredFlag|SyncPredFlag);
Yap_InitCPred("abolish_frozen_choice_points", 0, p_abolish_frozen_choice_points_all, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$c_table", 2, p_table, SafePredFlag|SyncPredFlag|HiddenPredFlag);
#ifdef MODE_DIRECTED_TABLING
Yap_InitCPred("$c_table_mode_directed", 3, p_table_mode_directed, SafePredFlag|SyncPredFlag|HiddenPredFlag);
#endif /*MODE_DIRECTED_TABLING*/
Yap_InitCPred("$c_tabling_mode", 3, p_tabling_mode, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$c_abolish_table", 2, p_abolish_table, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("abolish_all_tables", 0, p_abolish_all_tables, SafePredFlag|SyncPredFlag);
@ -221,11 +227,147 @@ static Int p_table( USES_REGS1 ) {
if (pe->cs.p_code.FirstClause)
return (FALSE); /* predicate already compiled */
pe->PredFlags |= TabledPredFlag;
#ifdef MODE_DIRECTED_TABLING
new_table_entry(tab_ent, pe, at, arity, NULL);
#else
new_table_entry(tab_ent, pe, at, arity);
#endif /*MODE_DIRECTED_TABLING*/
pe->TableOfPred = tab_ent;
return (TRUE);
}
#ifdef MODE_DIRECTED_TABLING
static Int p_table_mode_directed( USES_REGS1 ) {
Term mod, t, list;
PredEntry *pe;
Atom at;
int arity;
tab_ent_ptr tab_ent;
mod = Deref(ARG1);
t = Deref(ARG2);
list = ARG3;
Functor f = FunctorOfTerm(t);
arity=ArityOfFunctor(f);
int* aux;
int* vec;
int i=0,n_index=0,n_agreg=0,n_nindex=0,n_all=0,n_last=0;
ALLOC_BLOCK(vec,arity*sizeof(int),int);
ALLOC_BLOCK(aux,arity*sizeof(int),int);
while(IsPairTerm(list)){
char *str_val = &RepAtom(AtomOfTerm(HeadOfTerm(list)))->StrOfAE;
//printf("----2 %s %d\n",str_val,i);
if(! strcmp(str_val ,"index")){
vec[i] = MODE_DIRECTED_INDEX;
n_index++;
}
else if (! strcmp(str_val ,"all")){
vec[i] = MODE_DIRECTED_ALL;
n_all++;
}
else if(!strcmp(str_val,"last")){
vec[i] = MODE_DIRECTED_LAST;
n_last++;
}
else if(!strcmp(str_val,"min")){
vec[i] = MODE_DIRECTED_MIN;
n_agreg++;
}
else if(!strcmp(str_val,"max")){
vec[i] = MODE_DIRECTED_MAX;
n_agreg++;
}
else if(!strcmp(str_val,"first")){
vec[i] = MODE_DIRECTED_NINDEX;
}
list=TailOfTerm(list);
i++;
}
n_nindex = n_index + n_agreg + n_all + n_last;
n_last = n_index + n_agreg + n_all;
n_all = n_index + n_agreg;
n_agreg = n_index;
n_index = 0;
for(i = 0;i < arity; i++){
if(vec[i]==MODE_DIRECTED_MAX){
aux[n_agreg]= i << MODE_DIRECTED_TAGBITS;
aux[n_agreg]= aux[n_agreg] + MODE_DIRECTED_MAX;
n_agreg++;
}
else if(vec[i]==MODE_DIRECTED_MIN){
aux[n_agreg]= i << MODE_DIRECTED_TAGBITS;
aux[n_agreg]= aux[n_agreg] + MODE_DIRECTED_MIN;
n_agreg++;
}
else if(vec[i]==MODE_DIRECTED_INDEX){
aux[n_index]= i << MODE_DIRECTED_TAGBITS;
aux[n_index]= aux[n_index] + MODE_DIRECTED_INDEX;
n_index++;
}
else if(vec[i]==MODE_DIRECTED_NINDEX){
aux[n_nindex]= i << MODE_DIRECTED_TAGBITS;
aux[n_nindex]= aux[n_nindex] + MODE_DIRECTED_NINDEX;
n_nindex++;
}
else if(vec[i]==MODE_DIRECTED_ALL){
aux[n_all]= i << MODE_DIRECTED_TAGBITS;
aux[n_all]= aux[n_all] + MODE_DIRECTED_ALL;
n_all++;
}
else if(vec[i]==MODE_DIRECTED_LAST){
aux[n_last]= i << MODE_DIRECTED_TAGBITS;
aux[n_last]= aux[n_last] + MODE_DIRECTED_LAST;
n_last++;
}
}
/*
i=0;
while(i < arity){
printf("aux[%d] %p \n",i,aux[i]);
i ++;
}
*/
if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
pe = RepPredProp(PredPropByAtom(at, mod));
arity = 0;
} else if (IsApplTerm(t)) {
at = NameOfFunctor(FunctorOfTerm(t));
pe = RepPredProp(PredPropByFunc(FunctorOfTerm(t), mod));
arity = ArityOfFunctor(FunctorOfTerm(t));
} else
return (FALSE);
if (pe->PredFlags & TabledPredFlag)
return (TRUE); /* predicate already tabled */
if (pe->cs.p_code.FirstClause)
return (FALSE); /* predicate already compiled */
pe->PredFlags |= TabledPredFlag;
new_table_entry(tab_ent, pe, at, arity, aux);
pe->TableOfPred = tab_ent;
return (TRUE);
}
#endif /*MODE_DIRECTED_TABLING*/
static Int p_tabling_mode( USES_REGS1 ) {
Term mod, t, tvalue;

46
OPTYap/tab.insts.i
View File

@ -869,6 +869,10 @@
LOCK(SgFr_lock(sg_fr));
#endif /* TABLE_LOCK_LEVEL */
ans_node = answer_search(sg_fr, subs_ptr);
#ifdef MODE_DIRECTED_TABLING
if(ans_node == NULL)
goto fail;
#endif /*MODE_DIRECTED_TABLING*/
#if defined(TABLE_LOCK_AT_NODE_LEVEL)
LOCK(TrNode_lock(ans_node));
#elif defined(TABLE_LOCK_AT_WRITE_LEVEL)
@ -1103,9 +1107,19 @@
dep_fr = CONS_CP(B)->cp_dep_fr;
LOCK(DepFr_lock(dep_fr));
ans_node = DepFr_last_answer(dep_fr);
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr aux_ans_node = ans_node;
do {
ans_node=TrNode_child(ans_node);
} while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node));
if (ans_node){
TrNode_child(aux_ans_node)=ans_node;
#else
if (TrNode_child(ans_node)) {
/* unconsumed answer */
ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node);
#endif /*MODE_DIRECTED_TABLING*/
DepFr_last_answer(dep_fr) = ans_node;
UNLOCK(DepFr_lock(dep_fr));
consume_answer_and_procceed(dep_fr, ans_node);
}
@ -1150,9 +1164,18 @@
while (YOUNGER_CP(DepFr_cons_cp(dep_fr), chain_cp)) {
LOCK(DepFr_lock(dep_fr));
ans_node = DepFr_last_answer(dep_fr);
if (TrNode_child(ans_node)) {
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr aux_ans_node = ans_node;
do {
ans_node=TrNode_child(ans_node);
} while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node));
if (ans_node){
TrNode_child(aux_ans_node)=ans_node;
#else
if (TrNode_child(ans_node))
/* dependency frame with unconsumed answers */
ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node);
#endif /*MODE_DIRECTED_TABLING*/
#ifdef YAPOR
if (YOUNGER_CP(DepFr_backchain_cp(dep_fr), top_chain_cp))
#endif /* YAPOR */
@ -1392,9 +1415,18 @@
while (YOUNGER_CP(DepFr_cons_cp(dep_fr), B)) {
LOCK(DepFr_lock(dep_fr));
ans_node = DepFr_last_answer(dep_fr);
if (TrNode_child(ans_node)) {
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr aux_ans_node = ans_node;
do {
ans_node=TrNode_child(ans_node);
} while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node));
if (ans_node){
TrNode_child(aux_ans_node)=ans_node;
#else
if (TrNode_child(ans_node))
/* dependency frame with unconsumed answers */
ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node);
#endif /*MODE_DIRECTED_TABLING*/
if (B->cp_ap) {
#ifdef YAPOR
if (YOUNGER_CP(DepFr_backchain_cp(dep_fr), B))
@ -1549,8 +1581,18 @@
LOCK_OR_FRAME(LOCAL_top_or_fr);
LOCK(DepFr_lock(LOCAL_top_dep_fr));
ans_node = DepFr_last_answer(LOCAL_top_dep_fr);
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr aux_ans_node = ans_node;
do {
ans_node=TrNode_child(ans_node);
} while(ans_node != NULL && IS_INVALID_ANSWER_LEAF_NODE(ans_node));
if (ans_node){
TrNode_child(aux_ans_node)=ans_node;
#else
if (TrNode_child(ans_node)) {
/* unconsumed answer */
ans_node = DepFr_last_answer(dep_fr) = TrNode_child(ans_node);
#endif /*MODE_DIRECTED_TABLING*/
UNLOCK_OR_FRAME(LOCAL_top_or_fr);
ans_node = DepFr_last_answer(LOCAL_top_dep_fr) = TrNode_child(ans_node);
UNLOCK(DepFr_lock(LOCAL_top_dep_fr));

85
OPTYap/tab.macros.h
View File

@ -269,6 +269,36 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
#define TrNode_init_lock_field(NODE)
#endif /* TABLE_LOCK_AT_NODE_LEVEL */
#ifdef MODE_DIRECTED_TABLING
#define new_table_entry(TAB_ENT, PRED_ENTRY, ATOM, ARITY, MODE_DIRECTED_ARRAY)\
{ register sg_node_ptr sg_node; \
new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL); \
ALLOC_TABLE_ENTRY(TAB_ENT); \
TabEnt_init_lock_field(TAB_ENT); \
TabEnt_pe(TAB_ENT) = PRED_ENTRY; \
TabEnt_atom(TAB_ENT) = ATOM; \
TabEnt_arity(TAB_ENT) = ARITY; \
TabEnt_flags(TAB_ENT) = 0; \
SetMode_Batched(TabEnt_flags(TAB_ENT)); \
SetMode_ExecAnswers(TabEnt_flags(TAB_ENT)); \
SetMode_LocalTrie(TabEnt_flags(TAB_ENT)); \
TabEnt_mode(TAB_ENT) = TabEnt_flags(TAB_ENT); \
if (IsMode_Local(yap_flags[TABLING_MODE_FLAG])) \
SetMode_Local(TabEnt_mode(TAB_ENT)); \
if (IsMode_LoadAnswers(yap_flags[TABLING_MODE_FLAG])) \
SetMode_LoadAnswers(TabEnt_mode(TAB_ENT)); \
if (IsMode_GlobalTrie(yap_flags[TABLING_MODE_FLAG])) \
SetMode_GlobalTrie(TabEnt_mode(TAB_ENT)); \
TabEnt_subgoal_trie(TAB_ENT) = sg_node; \
TabEnt_hash_chain(TAB_ENT) = NULL; \
TabEnt_next(TAB_ENT) = GLOBAL_root_tab_ent; \
GLOBAL_root_tab_ent = TAB_ENT; \
TabEnt_mode_directed_array(TAB_ENT) = MODE_DIRECTED_ARRAY; \
}
#else
#define new_table_entry(TAB_ENT, PRED_ENTRY, ATOM, ARITY) \
{ register sg_node_ptr sg_node; \
new_subgoal_trie_node(sg_node, 0, NULL, NULL, NULL); \
@ -294,6 +324,25 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
GLOBAL_root_tab_ent = TAB_ENT; \
}
#endif /*MODE_DIRECTED_TABLING*/
#ifdef MODE_DIRECTED_TABLING
#define new_subgoal_frame(SG_FR, CODE, N_VARS_OPERATOR_ARRAY) \
{ register ans_node_ptr ans_node; \
new_answer_trie_node(ans_node, 0,N_VARS_OPERATOR_ARRAY, NULL, NULL, NULL); \
ALLOC_SUBGOAL_FRAME(SG_FR); \
INIT_LOCK(SgFr_lock(SG_FR)); \
SgFr_code(SG_FR) = CODE; \
SgFr_state(SG_FR) = ready; \
SgFr_hash_chain(SG_FR) = NULL; \
SgFr_answer_trie(SG_FR) = ans_node; \
SgFr_first_answer(SG_FR) = NULL; \
SgFr_last_answer(SG_FR) = NULL; \
SgFr_del_node(SG_FR) = NULL; \
}
#else
#define new_subgoal_frame(SG_FR, CODE) \
{ register ans_node_ptr ans_node; \
new_answer_trie_node(ans_node, 0, 0, NULL, NULL, NULL); \
@ -306,6 +355,8 @@ static inline tg_sol_fr_ptr CUT_prune_tg_solution_frames(tg_sol_fr_ptr, int);
SgFr_first_answer(SG_FR) = NULL; \
SgFr_last_answer(SG_FR) = NULL; \
}
#endif /*MODE_DIRECTED_TABLING*/
#define init_subgoal_frame(SG_FR) \
{ SgFr_init_yapor_fields(SG_FR); \
SgFr_state(SG_FR) = evaluating; \
@ -482,6 +533,40 @@ static inline void adjust_freeze_registers(void) {
static inline void mark_as_completed(sg_fr_ptr sg_fr) {
LOCK(SgFr_lock(sg_fr));
#ifdef MODE_DIRECTED_TABLING
//printf("complete\n");
ans_node_ptr answer, valid_answer, elim_answer;
answer = SgFr_first_answer(sg_fr);
while(answer && IS_INVALID_ANSWER_LEAF_NODE(answer))
answer = TrNode_child(answer);
SgFr_first_answer(sg_fr) = answer;
valid_answer = answer;
if(answer!= NULL)
answer = TrNode_child(valid_answer);
while(answer != NULL){
if (!IS_INVALID_ANSWER_LEAF_NODE(answer)){
TrNode_child(valid_answer) = answer;
valid_answer = answer;
}
answer = TrNode_child(answer);
}
//TrNode_child(valid_answer) = NULL;
SgFr_last_answer(sg_fr) = valid_answer;
elim_answer = SgFr_del_node(sg_fr);
while(elim_answer){
answer= TrNode_next(elim_answer);
FREE_ANSWER_TRIE_NODE(elim_answer);
elim_answer = answer;
}
#endif /*MODE_DIRECTED_TABLING*/
SgFr_state(sg_fr) = complete;
UNLOCK(SgFr_lock(sg_fr));
return;

56
OPTYap/tab.structs.h
View File

@ -30,6 +30,9 @@ typedef struct table_entry {
short execution_mode; /* combines yap_flags with pred_flags */
struct subgoal_trie_node *subgoal_trie;
struct subgoal_trie_hash *hash_chain;
#ifdef MODE_DIRECTED_TABLING
int* mode_directed_array;
#endif /*MODE_DIRECTED_TABLING*/
struct table_entry *next;
} *tab_ent_ptr;
@ -41,6 +44,9 @@ typedef struct table_entry {
#define TabEnt_mode(X) ((X)->execution_mode)
#define TabEnt_subgoal_trie(X) ((X)->subgoal_trie)
#define TabEnt_hash_chain(X) ((X)->hash_chain)
#ifdef MODE_DIRECTED_TABLING
#define TabEnt_mode_directed_array(X) ((X)->mode_directed_array)
#endif /*MODE_DIRECTED_TABLING*/
#define TabEnt_next(X) ((X)->next)
@ -91,7 +97,9 @@ typedef struct global_trie_node {
#define TrNode_sg_fr(X) ((X)->child)
#define TrNode_next(X) ((X)->next)
#define TrNode_lock(X) ((X)->lock)
#ifdef MODE_DIRECTED_TABLING
#define TrNode_mode_directed_array(X) ((X)->entry)
#endif /*MODE_DIRECTED_TABLING */
/***********************************************************************
@ -116,6 +124,9 @@ typedef struct answer_trie_hash {
struct answer_trie_node **buckets;
int number_of_nodes;
struct answer_trie_hash *next;
#ifdef MODE_DIRECTED_TABLING
struct answer_trie_hash *previous;
#endif /*MODE_DIRECTED_TABLING*/
} *ans_hash_ptr;
typedef struct global_trie_hash {
@ -137,7 +148,9 @@ typedef struct global_trie_hash {
#define Hash_bucket(X,N) ((X)->buckets + N)
#define Hash_num_nodes(X) ((X)->number_of_nodes)
#define Hash_next(X) ((X)->next)
#ifdef MODE_DIRECTED_TABLING
#define Hash_previous(X) ((X)->previous)
#endif /*MODE_DIRECTED_TABLING*/
/************************************************************************
@ -219,6 +232,9 @@ typedef struct subgoal_frame {
struct subgoal_frame *previous;
#endif /* LIMIT_TABLING */
struct subgoal_frame *next;
#ifdef MODE_DIRECTED_TABLING
struct answer_trie_node *del_node;
#endif /*MODE_DIRECTED_TABLING*/
} *sg_fr_ptr;
#define SgFr_lock(X) ((X)->lock)
@ -236,7 +252,9 @@ typedef struct subgoal_frame {
#define SgFr_try_answer(X) ((X)->try_answer)
#define SgFr_previous(X) ((X)->previous)
#define SgFr_next(X) ((X)->next)
#ifdef MODE_DIRECTED_TABLING
#define SgFr_del_node(X) ((X)->del_node)
#endif /*MODE_DIRECTED_TABLING*/
/**************************************************************************************************
SgFr_lock: spin-lock to modify the frame fields.
@ -351,3 +369,35 @@ typedef struct suspension_frame {
#define SuspFr_trail_start(X) ((X)->trail_block.block_start)
#define SuspFr_trail_size(X) ((X)->trail_block.block_size)
#define SuspFr_next(X) ((X)->next)
/* ---------------------------- **
** MODE_DIRECTED_TABLING flags **
** ---------------------------- */
#ifdef MODE_DIRECTED_TABLING
#define MODE_DIRECTED_TAGBITS 4
/*indexing*/
#define MODE_DIRECTED_INDEX 6
#define MODE_DIRECTED_NINDEX 1
#define MODE_DIRECTED_ALL 2
/*agregation*/
#define MODE_DIRECTED_MAX 3
#define MODE_DIRECTED_MIN 4
#define MODE_DIRECTED_SUM 5
#define MODE_DIRECTED_LAST 0
/* Macros */
#define MODE_DIRECTED_index(X) ((X) >> MODE_DIRECTED_TAGBITS)
#define MODE_DIRECTED_n_vars(X) ((X) >> MODE_DIRECTED_TAGBITS)
#define MODE_DIRECTED_operator(X) ((((X) >> MODE_DIRECTED_TAGBITS) << MODE_DIRECTED_TAGBITS) ^ (X))
#define TAG_AS_INVALID_ANSWER_LEAF_NODE(NODE,SG_FR) TrNode_parent(NODE) = (ans_node_ptr)((unsigned long int)TrNode_parent(NODE) | 0x2); \
TrNode_next(NODE) = SgFr_del_node(SG_FR);\
SgFr_del_node(SG_FR) = NODE
#define IS_INVALID_ANSWER_LEAF_NODE(NODE) ((unsigned long int)TrNode_parent(NODE) & 0x2)
#endif /*MODE_DIRECTED_TABLING*/

511
OPTYap/tab.tries.c
View File

@ -21,6 +21,9 @@
#include "YapHeap.h"
#include "tab.macros.h"
#ifdef MODE_DIRECTED_TABLING
static inline ans_node_ptr answer_search_loop2(sg_fr_ptr, ans_node_ptr, Term, int *,int);
#endif /*MODE_DIRECTED_TABLING*/
static inline sg_node_ptr subgoal_trie_check_insert_entry(tab_ent_ptr, sg_node_ptr, Term);
static inline sg_node_ptr subgoal_trie_check_insert_gt_entry(tab_ent_ptr, sg_node_ptr, Term);
static inline ans_node_ptr answer_trie_check_insert_entry(sg_fr_ptr, ans_node_ptr, Term, int);
@ -29,7 +32,6 @@ static inline gt_node_ptr global_trie_check_insert_entry(gt_node_ptr, Term);
#ifdef GLOBAL_TRIE_FOR_SUBTERMS
static inline gt_node_ptr global_trie_check_insert_gt_entry(gt_node_ptr, Term);
#endif /* GLOBAL_TRIE_FOR_SUBTERMS */
static inline sg_node_ptr subgoal_search_loop(tab_ent_ptr, sg_node_ptr, Term, int *, CELL **);
static inline sg_node_ptr subgoal_search_terms_loop(tab_ent_ptr, sg_node_ptr, Term, int *, CELL **);
static inline ans_node_ptr answer_search_loop(sg_fr_ptr, ans_node_ptr, Term, int *);
@ -60,6 +62,7 @@ static void free_global_trie_branch(gt_node_ptr, int);
static void free_global_trie_branch(gt_node_ptr);
#endif /* GLOBAL_TRIE_FOR_SUBTERMS */
static void traverse_subgoal_trie(sg_node_ptr, char *, int, int *, int, int);
static void traverse_answer_trie(ans_node_ptr, char *, int, int *, int, int, int);
static void traverse_global_trie(gt_node_ptr, char *, int, int *, int, int);
@ -67,7 +70,446 @@ static void traverse_global_trie_for_term(gt_node_ptr, char *, int *, int *, int
static inline void traverse_trie_node(Term, char *, int *, int *, int *, int);
static inline void traverse_update_arity(char *, int *, int *);
//----------------------------------------------------------------------------------
#ifdef MODE_DIRECTED_TABLING
//#define INCLUDE_ANSWER_TRIE_CHECK_INSERT
//#define INCLUDE_ANSWER_SEARCH_LOOP
#define ANSWER_CHECK_INSERT_ENTRY(SG_FR, NODE, ENTRY, INSTR) \
NODE = answer_trie_check_insert_entry(SG_FR, NODE, ENTRY, INSTR)
void invalidate_answer(ans_node_ptr node,sg_fr_ptr sg_fr) {
if(node == NULL)
return;
if(IS_ANSWER_LEAF_NODE(node)){
TAG_AS_INVALID_ANSWER_LEAF_NODE(node,sg_fr);
return;
}
if( IS_ANSWER_TRIE_HASH(node)){
ans_hash_ptr hash;
ans_node_ptr *bucket, *last_bucket, *first_bucket;
hash = (ans_hash_ptr) node;
first_bucket = bucket = Hash_buckets(hash);
last_bucket = bucket + Hash_num_buckets(hash);
do {
invalidate_answer(*bucket,sg_fr);
} while (++bucket != last_bucket);
Hash_next(Hash_previous(hash)) = Hash_next(hash);
FREE_HASH_BUCKETS(first_bucket);
FREE_ANSWER_TRIE_HASH(hash);
}
else{
if (! IS_ANSWER_LEAF_NODE(node))
invalidate_answer(TrNode_child(node),sg_fr);
if (TrNode_next(node))
invalidate_answer(TrNode_next(node),sg_fr);
FREE_ANSWER_TRIE_NODE(node);
return;
}
}
static inline ans_node_ptr answer_search_loop2(sg_fr_ptr sg_fr, ans_node_ptr current_node, Term t, int *vars_arity_ptr,int mode) {
CACHE_REGS
#ifdef MODE_GLOBAL_TRIE_LOOP
gt_node_ptr current_node = GLOBAL_root_gt;
#endif /* MODE_GLOBAL_TRIE_LOOP */
int vars_arity = *vars_arity_ptr;
#if ! defined(MODE_GLOBAL_TRIE_LOOP) || ! defined(GLOBAL_TRIE_FOR_SUBTERMS)
CELL *stack_terms = (CELL *) LOCAL_TrailTop;
#endif /* ! MODE_GLOBAL_TRIE_LOOP || ! GLOBAL_TRIE_FOR_SUBTERMS */
CELL *stack_vars_base = (CELL *) TR;
#define stack_terms_limit (stack_vars_base + vars_arity)
#ifdef TRIE_COMPACT_PAIRS
int in_pair = 0;
#else
#define in_pair 0
#endif /* TRIE_COMPACT_PAIRS */
#ifdef MODE_DIRECTED_TABLING
ans_node_ptr child_node;
Term child_term;
#endif /*MODE_DIRECTED_TABLING*/
AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 1); /* + 1 because initially we stiil haven't done any STACK_POP_DOWN */
STACK_PUSH_UP(NULL, stack_terms);
#if defined(MODE_GLOBAL_TRIE_LOOP)
/* for the global trie, it is safe to skip the IsVarTerm() and IsAtomOrIntTerm() tests in the first iteration */
goto answer_search_loop_non_atomic;
#endif /* MODE_GLOBAL_TRIE_LOOP */
if(mode == MODE_DIRECTED_NINDEX && TrNode_child(current_node))
return NULL;
if(mode == MODE_DIRECTED_LAST && TrNode_child(current_node)){
invalidate_answer(TrNode_child(current_node),sg_fr);
TrNode_child(current_node) = NULL;
}
do {
if (IsVarTerm(t)) {
t = Deref(t);
if (IsTableVarTerm(t)) {
t = MakeTableVarTerm(VarIndexOfTerm(t));
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair);
} else {
if (vars_arity == MAX_TABLE_VARS)
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: MAX_TABLE_VARS exceeded");
stack_vars_base[vars_arity] = t;
*((CELL *)t) = GLOBAL_table_var_enumerator(vars_arity);
t = MakeTableVarTerm(vars_arity);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair);
vars_arity = vars_arity + 1;
}
#ifdef TRIE_COMPACT_PAIRS
in_pair = 0;
#endif /* TRIE_COMPACT_PAIRS */
} else if (IsAtomOrIntTerm(t)) {
#ifdef MODE_DIRECTED_TABLING
child_node = TrNode_child(current_node);
if(child_node && IsIntTerm(t) && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){
Int it = IntOfTerm(t);
if(IsIntTerm(TrNode_entry(child_node))){
child_term = TrNode_entry(child_node);
Int tt = IntOfTerm(child_term);
if((mode == MODE_DIRECTED_MIN && it < tt ) || (mode == MODE_DIRECTED_MAX && it > tt) ){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair);
}
else if((mode == MODE_DIRECTED_MIN && it > tt) || (mode == MODE_DIRECTED_MAX && it < tt) ){
return NULL;
}
else if (it == tt){
current_node = TrNode_child(current_node);
}
}
if(IsApplTerm(TrNode_entry(child_node))){
if(RepAppl(TrNode_entry(child_node))==FunctorLongInt){
Int tt = TrNode_entry(TrNode_child(child_node));
if((mode == MODE_DIRECTED_MIN && it < tt ) || (mode == MODE_DIRECTED_MAX && it > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair);
}
else if(it == tt){
current_node = TrNode_child(TrNode_child(child_node));
}
else if((mode == MODE_DIRECTED_MIN && it > tt) || (mode == MODE_DIRECTED_MAX && it < tt) )
return NULL;
}
else if(RepAppl(TrNode_entry(child_node))==FunctorDouble){
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} u;
u.t_dbl[0] = TrNode_entry(TrNode_child(child_node));
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
u.t_dbl[1] = TrNode_entry(TrNode_child(TrNode_child(child_node)));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
if((mode == MODE_DIRECTED_MIN && it < u.dbl ) || (mode == MODE_DIRECTED_MAX && it > u.dbl)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair);
}
else if(it == u.dbl){
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
current_node = TrNode_child(TrNode_child(TrNode_child(child_node)));
#else
current_node = TrNode_child(TrNode_child(child_node));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
}
else if((mode == MODE_DIRECTED_MIN && it > u.dbl) || (mode == MODE_DIRECTED_MAX && it < u.dbl))
return NULL;
}
}
}
else
#endif /*MODE_DIRECTED_TABLING*/
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_atom + in_pair);
#ifdef TRIE_COMPACT_PAIRS
in_pair = 0;
#endif /* TRIE_COMPACT_PAIRS */
#ifdef MODE_TERMS_LOOP
} else {
gt_node_ptr entry_node;
#ifdef GLOBAL_TRIE_FOR_SUBTERMS
entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms);
#else
entry_node = answer_search_global_trie_loop(t, &vars_arity);
#endif /* GLOBAL_TRIE_FOR_SUBTERMS */
current_node = answer_trie_check_insert_gt_entry(sg_fr, current_node, (Term) entry_node, _trie_retry_gterm + in_pair);
#else /* ! MODE_TERMS_LOOP */
} else
#if defined(MODE_GLOBAL_TRIE_LOOP)
/* for the global trie, it is safe to start here in the first iteration */
answer_search_loop_non_atomic:
#endif /* MODE_GLOBAL_TRIE_LOOP */
#ifdef TRIE_COMPACT_PAIRS
if (IsPairTerm(t)) {
CELL *aux_pair = RepPair(t);
if (aux_pair == PairTermMark) {
t = STACK_POP_DOWN(stack_terms);
if (IsPairTerm(t)) {
aux_pair = RepPair(t);
t = Deref(aux_pair[1]);
if (t == TermNil) {
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndList, _trie_retry_pair);
} else {
/* AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 2); */
/* AUX_STACK_CHECK_EXPAND is not necessary here because the situation of pushing **
** up 3 terms has already initially checked for the CompactPairInit term */
STACK_PUSH_UP(t, stack_terms);
STACK_PUSH_UP(AbsPair(PairTermMark), stack_terms);
in_pair = 4;
}
STACK_PUSH_UP(Deref(aux_pair[0]), stack_terms);
} else {
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndTerm, _trie_retry_null);
STACK_PUSH_UP(t, stack_terms);
}
#if defined(MODE_GLOBAL_TRIE_LOOP) && defined(GLOBAL_TRIE_FOR_SUBTERMS)
} else if (current_node != GLOBAL_root_gt) {
gt_node_ptr entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms);
current_node = global_trie_check_insert_gt_entry(current_node, (Term) entry_node);
#endif /* MODE_GLOBAL_TRIE_LOOP && GLOBAL_TRIE_FOR_SUBTERMS */
} else {
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairInit, _trie_retry_null + in_pair);
t = Deref(aux_pair[1]);
if (t == TermNil) {
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, CompactPairEndList, _trie_retry_pair);
in_pair = 0;
} else {
AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 2);
STACK_PUSH_UP(t, stack_terms);
STACK_PUSH_UP(AbsPair(PairTermMark), stack_terms);
in_pair = 4;
}
STACK_PUSH_UP(Deref(aux_pair[0]), stack_terms);
}
#if defined(MODE_GLOBAL_TRIE_LOOP) && defined(GLOBAL_TRIE_FOR_SUBTERMS)
} else if (current_node != GLOBAL_root_gt) {
gt_node_ptr entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms);
current_node = global_trie_check_insert_gt_entry(current_node, (Term) entry_node);
#endif /* MODE_GLOBAL_TRIE_LOOP && GLOBAL_TRIE_FOR_SUBTERMS */
#else /* ! TRIE_COMPACT_PAIRS */
#if defined(MODE_GLOBAL_TRIE_LOOP) && defined(GLOBAL_TRIE_FOR_SUBTERMS)
if (current_node != GLOBAL_root_gt) {
gt_node_ptr entry_node = answer_search_global_trie_terms_loop(t, &vars_arity, stack_terms);
current_node = global_trie_check_insert_gt_entry(current_node, (Term) entry_node);
} else
#endif /* MODE_GLOBAL_TRIE_LOOP && GLOBAL_TRIE_FOR_SUBTERMS */
if (IsPairTerm(t)) {
CELL *aux_pair = RepPair(t);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsPair(NULL), _trie_retry_pair);
AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + 1);
STACK_PUSH_UP(Deref(aux_pair[1]), stack_terms);
STACK_PUSH_UP(Deref(aux_pair[0]), stack_terms);
#endif /* TRIE_COMPACT_PAIRS */
} else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
if (f == FunctorDouble) {
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} u;
u.dbl = FloatOfTerm(t);
#ifdef MODE_DIRECTED_TABLING
child_node = TrNode_child(current_node);
if(child_node && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){
if(IsApplTerm(TrNode_entry(child_node))){
if(RepAppl(TrNode_entry(child_node))==FunctorLongInt){
Int tt = TrNode_entry(TrNode_child(child_node));
if(( mode == MODE_DIRECTED_MIN && u.dbl < tt) || ( mode == MODE_DIRECTED_MAX && u.dbl > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double);
}
else if(tt == u.dbl){
current_node = TrNode_child(TrNode_child(child_node));
}
else if(( mode == MODE_DIRECTED_MIN && u.dbl > tt) || ( mode == MODE_DIRECTED_MAX && u.dbl < tt))
return NULL;
}
else if(RepAppl(TrNode_entry(child_node))==FunctorDouble){
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} ans_u;
ans_u.t_dbl[0] = TrNode_entry(TrNode_child(child_node));
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ans_u.t_dbl[1] = TrNode_entry(TrNode_child(TrNode_child(child_node)));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
if(( mode == MODE_DIRECTED_MIN && u.dbl < ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && u.dbl > ans_u.dbl)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double);
}
else if(ans_u.dbl == u.dbl){
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
current_node = TrNode_child(TrNode_child(TrNode_child(child_node)));
#else
current_node = TrNode_child(TrNode_child(child_node));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
}
else if(( mode == MODE_DIRECTED_MIN && u.dbl > ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && u.dbl < ans_u.dbl))
return NULL;
}
}
else if(IsIntTerm(TrNode_entry(child_node))){
Int tt = IntOfTerm(child_node);
if(( mode == MODE_DIRECTED_MIN && u.dbl < tt) || ( mode == MODE_DIRECTED_MAX && u.dbl > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double);
}
else if(IntOfTerm(child_node) == u.dbl){
current_node = TrNode_child(TrNode_child(child_node));
}
else if(( mode == MODE_DIRECTED_MIN && u.dbl > tt) || ( mode == MODE_DIRECTED_MAX && u.dbl < tt))
return NULL;
}
}
else {
#endif /*MODE_DIRECTED_TABLING*/
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[1], _trie_retry_extension);
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, u.t_dbl[0], _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_double);
#ifdef MODE_DIRECTED_TABLING
}
#endif /*MODE_DIRECTED_TABLING*/
} else if (f == FunctorLongInt) {
Int li = LongIntOfTerm (t);
child_node = TrNode_child(current_node);
#ifdef MODE_DIRECTED_TABLING
if(child_node && (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)){
if(IsApplTerm(TrNode_entry(child_node))){
if(RepAppl(TrNode_entry(child_node))==FunctorLongInt){
Int tt = TrNode_entry(TrNode_child(child_node));
if(( mode == MODE_DIRECTED_MIN && li < tt) || ( mode == MODE_DIRECTED_MAX && li > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint);
}
else if(li == tt){
current_node = TrNode_child(TrNode_child(child_node));
}
else if(( mode == MODE_DIRECTED_MIN && li > tt) || ( mode == MODE_DIRECTED_MAX && li < tt))
return NULL;
}
else if(RepAppl(TrNode_entry(child_node))==FunctorDouble){
union {
Term t_dbl[sizeof(Float)/sizeof(Term)];
Float dbl;
} ans_u;
ans_u.t_dbl[0] = TrNode_entry(TrNode_child(child_node));
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
ans_u.t_dbl[1] = TrNode_entry(TrNode_child(TrNode_child(child_node)));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
if(( mode == MODE_DIRECTED_MIN && li < ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && li > ans_u.dbl)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint);
}
else if(ans_u.dbl == li){
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
current_node = TrNode_child(TrNode_child(TrNode_child(child_node)));
#else
current_node = TrNode_child(TrNode_child(child_node));
#endif /* SIZEOF_DOUBLE x SIZEOF_INT_P */
}
else if(( mode == MODE_DIRECTED_MIN && li > ans_u.dbl) || ( mode == MODE_DIRECTED_MAX && li < ans_u.dbl))
return NULL;
}
}
else if(IsIntTerm(TrNode_entry(child_node))){
Int tt = IntOfTerm(child_node);
if(( mode == MODE_DIRECTED_MIN && li < tt) || ( mode == MODE_DIRECTED_MAX && li > tt)){
invalidate_answer(child_node,sg_fr);
TrNode_child(current_node) = NULL;
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint);
}
else if(li == tt){
current_node = TrNode_child(TrNode_child(child_node));
}
else if(( mode == MODE_DIRECTED_MIN && li > tt) || ( mode == MODE_DIRECTED_MAX && li < tt))
return NULL;
}
}else{
#endif /*MODE_DIRECTED_TABLING*/
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_null + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, li, _trie_retry_extension);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_longint);
#ifdef MODE_DIRECTED_TABLING
}
#endif/*MODE_DIRECTED_TABLING*/
} else if (f == FunctorDBRef) {
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorDBRef");
} else if (f == FunctorBigInt) {
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unsupported type tag FunctorBigInt");
} else {
int i;
CELL *aux_appl = RepAppl(t);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, AbsAppl((Term *)f), _trie_retry_appl + in_pair);
AUX_STACK_CHECK_EXPAND(stack_terms, stack_terms_limit + ArityOfFunctor(f) - 1);
for (i = ArityOfFunctor(f); i >= 1; i--)
STACK_PUSH_UP(Deref(aux_appl[i]), stack_terms);
}
#ifdef TRIE_COMPACT_PAIRS
in_pair = 0;
#endif /* TRIE_COMPACT_PAIRS */
} else {
Yap_Error(INTERNAL_ERROR, TermNil, "answer_search_loop: unknown type tag");
#endif /* MODE_TERMS_LOOP */
}
t = STACK_POP_DOWN(stack_terms);
} while (t);
*vars_arity_ptr = vars_arity;
return current_node;
#undef stack_terms_limit
#ifndef TRIE_COMPACT_PAIRS
#undef in_pair
#endif /* TRIE_COMPACT_PAIRS */
}
//#undef INCLUDE_ANSWER_TRIE_CHECK_INSERT
//#undef INCLUDE_ANSWER_SEARCH_LOOP
#endif /* MODE_DIRECTED_TABLING*/
//-----------------------------------------------------------------------------------------------------------------
/*******************************
** Structs & Macros **
*******************************/
@ -971,6 +1413,7 @@ static inline void traverse_update_arity(char *str, int *str_index_ptr, int *ari
*******************************/
sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) {
// printf("subgoal_search\n");
CACHE_REGS
CELL *stack_vars;
int i, subs_arity, pred_arity;
@ -987,12 +1430,41 @@ sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) {
LOCK(TabEnt_lock(tab_ent));
#endif /* TABLE_LOCK_LEVEL */
#ifdef MODE_DIRECTED_TABLING
int* mode_directed_array = TabEnt_mode_directed_array(tab_ent);
int* n_vars_operator_array = NULL;
int j, old_subs_arity=0;
if(mode_directed_array)
ALLOC_BLOCK(n_vars_operator_array,pred_arity*sizeof(int),int);
// ALLOC_BLOCK(number_vars,sizeof(int),int);
//for(i=0;i<pred_arity;i++)
// printf("sub_search %p\n",mode_directed_array[i]);
#endif /*MODE_DIRECTED_TABLING*/
if (IsMode_GlobalTrie(TabEnt_mode(tab_ent))) {
for (i = 1; i <= pred_arity; i++)
current_sg_node = subgoal_search_terms_loop(tab_ent, current_sg_node, Deref(XREGS[i]), &subs_arity, &stack_vars);
} else {
for (i = 1; i <= pred_arity; i++)
for (i = 1; i <= pred_arity; i++){
#ifdef MODE_DIRECTED_TABLING
if(mode_directed_array){
j = MODE_DIRECTED_index(mode_directed_array[i-1])+1;
}
else
j = i;
current_sg_node = subgoal_search_loop(tab_ent, current_sg_node, Deref(XREGS[j]), &subs_arity, &stack_vars);
if(mode_directed_array){
n_vars_operator_array[i-1] = subs_arity - old_subs_arity;
//printf("vars %d\n", subs_arity);
old_subs_arity = subs_arity;
n_vars_operator_array[i-1] = (n_vars_operator_array[i-1]<< MODE_DIRECTED_TAGBITS) + MODE_DIRECTED_operator(mode_directed_array[i-1]);
}
#else
current_sg_node = subgoal_search_loop(tab_ent, current_sg_node, Deref(XREGS[i]), &subs_arity, &stack_vars);
#endif /*MODE_DIRECTED_TABLING*/
}
}
STACK_PUSH_UP(subs_arity, stack_vars);
@ -1002,6 +1474,8 @@ sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) {
Term t = STACK_POP_DOWN(stack_vars);
RESET_VARIABLE(t);
}
// for(i=0;i<pred_arity;i++)
//printf("2sub_search %p\n",n_vars_operator_array[i]);
#if defined(TABLE_LOCK_AT_NODE_LEVEL)
LOCK(TrNode_lock(current_sg_node));
@ -1010,7 +1484,9 @@ sg_fr_ptr subgoal_search(yamop *preg, CELL **Yaddr) {
#endif /* TABLE_LOCK_LEVEL */
if (TrNode_sg_fr(current_sg_node) == NULL) {
/* new tabled subgoal */
new_subgoal_frame(sg_fr, preg);
#ifdef MODE_DIRECTED_TABLING
new_subgoal_frame(sg_fr, preg,n_vars_operator_array);
#endif /*MODE_DIRECTED_TABLING*/
TrNode_sg_fr(current_sg_node) = (sg_node_ptr) sg_fr;
TAG_AS_SUBGOAL_LEAF_NODE(current_sg_node);
} else {
@ -1042,6 +1518,14 @@ ans_node_ptr answer_search(sg_fr_ptr sg_fr, CELL *subs_ptr) {
vars_arity = 0;
current_ans_node = SgFr_answer_trie(sg_fr);
#ifdef MODE_DIRECTED_TABLING
int* n_vars_operator_array = TrNode_mode_directed_array(current_ans_node);
int j=0,n_vars=0, mode=-1;
// for(i=0;i<3;i++)
//printf("sub_search %p\n",n_vars_operator_array[i]);
#endif /*MODE_DIRECTED_TABLING*/
if (IsMode_GlobalTrie(TabEnt_mode(SgFr_tab_ent(sg_fr)))) {
for (i = subs_arity; i >= 1; i--) {
TABLING_ERROR_CHECKING(answer search, IsNonVarTerm(subs_ptr[i]));
@ -1050,7 +1534,26 @@ ans_node_ptr answer_search(sg_fr_ptr sg_fr, CELL *subs_ptr) {
} else {
for (i = subs_arity; i >= 1; i--) {
TABLING_ERROR_CHECKING(answer search, IsNonVarTerm(subs_ptr[i]));
#ifdef MODE_DIRECTED_TABLING
if(n_vars_operator_array){
while(!MODE_DIRECTED_n_vars(n_vars_operator_array[j]))
j++;
if(!(n_vars < MODE_DIRECTED_n_vars(n_vars_operator_array[j]))){
j++;
while(!MODE_DIRECTED_n_vars(n_vars_operator_array[j]))
j++;
n_vars = 0;
}
mode = MODE_DIRECTED_operator(n_vars_operator_array[j]);
//printf("operador %d\n",mode);
n_vars++;
}
current_ans_node = answer_search_loop2(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity, mode);
if(current_ans_node == NULL)
break;
#else
current_ans_node = answer_search_loop(sg_fr, current_ans_node, Deref(subs_ptr[i]), &vars_arity);
#endif /*MODE_DIRECTED_TABLING*/
}
}
@ -1392,4 +1895,6 @@ void show_global_trie(int show_mode, IOSTREAM *out) {
}
return;
}
#endif /* TABLING */

2
OPTYap/tab.tries.i
View File

@ -1068,7 +1068,7 @@ static inline ans_node_ptr answer_search_loop(sg_fr_ptr sg_fr, ans_node_ptr curr
stack_vars_base[vars_arity] = t;
*((CELL *)t) = GLOBAL_table_var_enumerator(vars_arity);
t = MakeTableVarTerm(vars_arity);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_var + in_pair);
ANSWER_CHECK_INSERT_ENTRY(sg_fr, current_node, t, _trie_retry_val + in_pair);
vars_arity = vars_arity + 1;
}
#ifdef TRIE_COMPACT_PAIRS

9
YapTermConfig.h.in Normal file
View File

@ -0,0 +1,9 @@
/* Define sizes of some basic types */
#undef SIZEOF_INT_P
#undef SIZEOF_INT
#undef SIZEOF_SHORT_INT
#undef SIZEOF_LONG_INT
#undef SIZEOF_LONG_LONG_INT
#undef SIZEOF_FLOAT
#undef SIZEOF_DOUBLE

9
config.h.in
View File

@ -135,14 +135,7 @@
/* Define byte order */
#undef WORDS_BIGENDIAN
/* Define sizes of some basic types */
#undef SIZEOF_INT_P
#undef SIZEOF_INT
#undef SIZEOF_SHORT_INT
#undef SIZEOF_LONG_INT
#undef SIZEOF_LONG_LONG_INT
#undef SIZEOF_FLOAT
#undef SIZEOF_DOUBLE
#include "YapTermConfig.h"
/* Define representation of floats */
/* only one of the following shoud be set */

3
configure vendored
View File

@ -2607,6 +2607,8 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
ac_config_headers="$ac_config_headers config.h"
ac_config_headers="$ac_config_headers YapTermConfig.h"
mycflags="$CFLAGS"
@ -10865,6 +10867,7 @@ for ac_config_target in $ac_config_targets
do
case $ac_config_target in
"config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;;
"YapTermConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS YapTermConfig.h" ;;
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
"GPL/Makefile") CONFIG_FILES="$CONFIG_FILES GPL/Makefile" ;;
"library/Makefile") CONFIG_FILES="$CONFIG_FILES library/Makefile" ;;

1
configure.in
View File

@ -45,6 +45,7 @@ dnl EXTRA_LIBS_FOR_SWIDLLS= libs that are required when lding a SWI so
AC_INIT(console/yap.c)
AC_CONFIG_HEADER(config.h)
AC_CONFIG_HEADER(YapTermConfig.h)
dnl store the environment's compilation flags
mycflags="$CFLAGS"

56
docs/yap.tex
View File

@ -3272,6 +3272,12 @@ compound term.
Instantiates each variable in term @var{T} to a term of the form:
@code{'$VAR'(@var{I})}, with @var{I} increasing from @var{N1} to @var{Nn}.
@item unnumbervars(@var{T},+@var{NT})
@findex unnumbervars/2
@syindex unnumbervars/2
@cnindex unnumbervars/2
Replace every @code{'$VAR'(@var{I})} by a free variable.
@item ground(@var{T})
@findex ground/1
@syindex ground/1
@ -16171,6 +16177,7 @@ The user can create a new uninstantiated variable using the primitive
@findex YAP_IsAtomTerm (C-Interface function)
@findex YAP_IsPairTerm (C-Interface function)
@findex YAP_IsApplTerm (C-Interface function)
@findex YAP_IsCompoundTerm (C-Interface function)
The following primitives can be used to discriminate among the different types
of non-variable terms:
@example
@ -16180,8 +16187,30 @@ of non-variable terms:
YAP_Bool YAP_IsAtomTerm(YAP_Term @var{t})
YAP_Bool YAP_IsPairTerm(YAP_Term @var{t})
YAP_Bool YAP_IsApplTerm(YAP_Term @var{t})
YAP_Bool YAP_IsCompoundTerm(YAP_Term @var{t})
@end example
The next primitive gives the type of a Prolog term:
@example
YAP_tag_t YAP_TagOfTerm(YAP_Term @var{t})
@end example
The set of possible values is an enumerated type, with the following values:
@table @i
@item @code{YAP_TAG_ATT}: an attributed variable
@item @code{YAP_TAG_UNBOUND}: an unbound variable
@item @code{YAP_TAG_REF}: a reference to a term
@item @code{YAP_TAG_PAIR}: a list
@item @code{YAP_TAG_ATOM}: an atom
@item @code{YAP_TAG_INT}: a small integer
@item @code{YAP_TAG_LONG_INT}: a word sized integer
@item @code{YAP_TAG_BIG_INT}: a very large integer
@item @code{YAP_TAG_RATIONAL}: a rational number
@item @code{YAP_TAG_FLOAT}: a floating point number
@item @code{YAP_TAG_OPAQUE}: an opaque term
@item @code{YAP_TAG_APPL}: a compound term
@end table
Next, we mention the primitives that allow one to destruct and construct
terms. All the above primitives ensure that their result is
@i{dereferenced}, i.e. that it is not a pointer to another term.
@ -16567,14 +16596,14 @@ lead to a crash.
The following functions are often required to compare terms.
@findex YAP_ExactlyEqual (C-Interface function)
The first function succeeds if two terms are actually the same term, as
Succeed if two terms are actually the same term, as in
@code{==/2}:
@example
int YAP_ExactlyEqual(YAP_Term t1, YAP_Term t2)
@end example
@noindent
The second function succeeds if two terms are variant terms, and returns
The next function succeeds if two terms are variant terms, and returns
0 otherwise, as
@code{=@=/2}:
@example
@ -16582,6 +16611,29 @@ The second function succeeds if two terms are variant terms, and returns
@end example
@noindent
The next functions deal with numbering variables in terms:
@example
int YAP_NumberVars(YAP_Term t, YAP_Int first_number)
YAP_Term YAP_UnNumberVars(YAP_Term t)
int YAP_IsNumberedVariable(YAP_Term t)
@end example
@noindent
The next one returns the length of a well-formed list @var{t}, or
@code{-1} otherwise:
@example
Int YAP_ListLength(YAP_Term t)
@end example
@noindent
Last, this function succeeds if two terms are unifiable:
@code{=@=/2}:
@example
int YAP_Unifiable(YAP_Term t1, YAP_Term t2)
@end example
@noindent
The second function computes a hash function for a term, as in
@code{term_hash/4}.
@example

19
include/YapInterface.h
View File

@ -109,6 +109,9 @@ extern X_API YAP_Bool PROTO(YAP_IsRationalTerm,(YAP_Term));
/* YAP_Bool IsFloatTerm(YAP_Term) */
extern X_API YAP_Bool PROTO(YAP_IsFloatTerm,(YAP_Term));
/* YAP_Bool IsNumberTerm(YAP_Term) */
extern X_API YAP_Bool PROTO(YAP_IsNumberTerm,(YAP_Term));
/* YAP_Bool IsDbRefTerm(YAP_Term) */
extern X_API YAP_Bool PROTO(YAP_IsDbRefTerm,(YAP_Term));
@ -121,6 +124,9 @@ extern X_API YAP_Bool PROTO(YAP_IsPairTerm,(YAP_Term));
/* YAP_Bool IsApplTerm(YAP_Term) */
extern X_API YAP_Bool PROTO(YAP_IsApplTerm,(YAP_Term));
/* YAP_Bool IsCompoundTerm(YAP_Term) */
extern X_API YAP_Bool PROTO(YAP_IsCompoundTerm,(YAP_Term));
/* Term MkIntTerm(YAP_Int) */
extern X_API YAP_Term PROTO(YAP_MkIntTerm,(YAP_Int));
@ -190,6 +196,8 @@ extern X_API int PROTO(YAP_SkipList,(YAP_Term *, YAP_Term **));
/* Term TailOfTerm(Term) */
extern X_API YAP_Term PROTO(YAP_TermNil,(void));
extern X_API int PROTO(YAP_IsTermNil,(YAP_Term));
/* YAP_Term MkApplTerm(YAP_Functor f, unsigned int n, YAP_Term[] args) */
extern X_API YAP_Term PROTO(YAP_MkApplTerm,(YAP_Functor,unsigned int,YAP_Term *));
@ -235,6 +243,9 @@ extern X_API void PROTO(YAP_UserCPredicateWithArgs,(CONST char *, YAP_Bool (*)(v
arity, int extra) */
extern X_API void PROTO(YAP_UserBackCPredicate,(CONST char *, YAP_Bool (*)(void), YAP_Bool (*)(void), YAP_Arity, unsigned int));
/* YAP_Int YAP_ListLength(YAP_Term t) */
extern X_API YAP_Int PROTO(YAP_ListLength,(YAP_Term));
/* void UserBackCPredicate(char *name, int *init(), int *cont(), int *cut(), int
arity, int extra) */
extern X_API void PROTO(YAP_UserBackCutCPredicate,(CONST char *, YAP_Bool (*)(void), YAP_Bool (*)(void), YAP_Bool (*)(void), YAP_Arity, unsigned int));
@ -308,7 +319,7 @@ extern X_API void PROTO(YAP_Error,(int, YAP_Term, CONST char *, ...));
extern X_API YAP_Term PROTO(YAP_Read,(void *));
/* void YAP_Write(YAP_Term,void (*)(int),int) */
extern X_API void PROTO(YAP_Write,(YAP_Term,void (*)(int),int));
extern X_API void PROTO(YAP_Write,(YAP_Term,void *,int));
/* void YAP_WriteBufffer(YAP_Term,char *,unsgined int,int) */
extern X_API void PROTO(YAP_WriteBuffer,(YAP_Term,char *,unsigned int,int));
@ -532,6 +543,10 @@ extern X_API int PROTO(YAP_Erase,(void *));
/* term utilities */
extern X_API int PROTO(YAP_Variant,(YAP_Term,YAP_Term));
extern X_API YAP_Int PROTO(YAP_NumberVars,(YAP_Term,YAP_Int));
extern X_API YAP_Term PROTO(YAP_UnNumberVars,(YAP_Term));
extern X_API int PROTO(YAP_IsNumberedVariable,(YAP_Term));
extern X_API int PROTO(YAP_Unifiable,(YAP_Term,YAP_Term));
extern X_API int PROTO(YAP_ExactlyEqual,(YAP_Term,YAP_Term));
extern X_API YAP_Int PROTO(YAP_TermHash,(YAP_Term, YAP_Int, YAP_Int, int));
@ -568,6 +583,8 @@ extern X_API void *PROTO(YAP_OpaqueObjectFromTerm,(YAP_Term));
extern X_API int *PROTO(YAP_Argv,(char ***));
extern X_API YAP_tag_t PROTO(YAP_TagOfTerm,(YAP_Term));
#define YAP_InitCPred(N,A,F) YAP_UserCPredicate(N,F,A)
__END_DECLS

28
include/YapRegs.h Normal file
View File

@ -0,0 +1,28 @@
#ifndef YAP_REGS_H
#define YAP_REGS_H 1
#if defined(TABLING) || defined(YAPOR_SBA)
typedef struct trail_frame {
Term term;
CELL value;
} *tr_fr_ptr;
#define TrailTerm(X) ((X)->term)
#else
typedef Term *tr_fr_ptr;
#define TrailTerm(X) ((X)->term)
#endif
typedef void *choiceptr;
typedef void *yamop;
typedef char *ADDR;
#define RESET_VARIABLE(X) (*(X) = (CELL)(X))
#include "src/Regs.h"
#endif

16
include/yap_structs.h
View File

@ -95,6 +95,22 @@ typedef double YAP_Float;
#endif
typedef enum {
YAP_TAG_ATT = 0x1,
YAP_TAG_UNBOUND = 0x2,
YAP_TAG_REF = 0x4,
YAP_TAG_PAIR = 0x8,
YAP_TAG_ATOM = 0x10,
YAP_TAG_INT = 0x20,
YAP_TAG_LONG_INT = 0x40,
YAP_TAG_BIG_INT = 0x80,
YAP_TAG_RATIONAL = 0x100,
YAP_TAG_FLOAT = 0x200,
YAP_TAG_OPAQUE = 0x400,
YAP_TAG_APPL = 0x800,
YAP_TAG_DBREF = 0x1000
} YAP_tag_t;
#define YAP_BOOT_FROM_PROLOG 0
#define YAP_BOOT_FROM_SAVED_CODE 1
#define YAP_BOOT_FROM_SAVED_STACKS 2

10
library/Makefile.in
View File

@ -91,6 +91,7 @@ MYDDAS_PROGRAMS= $(srcdir)/MYDDAS/myddas.ypp \
DIALECT_PROGRAMS= \
$(srcdir)/dialect/commons.yap \
$(srcdir)/dialect/bprolog.yap \
$(srcdir)/dialect/hprolog.yap \
$(srcdir)/dialect/swi.yap
@ -98,13 +99,22 @@ DIALECT_SWI= \
$(srcdir)/dialect/swi/INDEX.pl \
$(srcdir)/dialect/swi/listing.pl
DIALECT_BP= \
$(srcdir)/dialect/bprolog/actionrules.pl \
$(srcdir)/dialect/bprolog/arrays.yap \
$(srcdir)/dialect/bprolog/compile_foreach.pl \
$(srcdir)/dialect/bprolog/foreach.pl \
$(srcdir)/dialect/bprolog/hashtable.yap
install: $(PROGRAMS) install_myddas
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/dialect
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/dialect/swi
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/dialect/bprolog
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap; done
for p in $(DIALECT_PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/dialect; done
for p in $(DIALECT_SWI); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/dialect/swi; done
for p in $(DIALECT_BP); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/dialect/bprolog; done
install_myddas: $(MYDDAS_PROGRAMS)
count=`echo "$(YAP_EXTRAS)" | grep MYDDAS | wc -l`; \

71
library/bhash.yap
View File

@ -1,3 +1,5 @@
%% -*- Prolog -*-
/*
This code implements hash-arrays.
@ -17,7 +19,13 @@ It relies on dynamic array code.
b_hash_update/3,
b_hash_update/4,
b_hash_insert_new/4,
b_hash_insert/4
b_hash_insert/4,
b_hash_size/2,
b_hash_code/2,
is_b_hash/1,
b_hash_to_list/2,
b_hash_values_to_list/2,
b_hash_keys_to_list/2
]).
:- use_module(library(terms), [ term_hash/4 ]).
@ -27,6 +35,9 @@ It relies on dynamic array code.
array_default_size(2048).
is_b_hash(V) :- var(V), !, fail.
is_b_hash(hash(_,_,_,_,_)).
b_hash_new(hash(Keys, Vals, Size, N, _, _)) :-
array_default_size(Size),
array(Keys, Size),
@ -43,6 +54,8 @@ b_hash_new(hash(Keys,Vals, Size, N, HashF, CmpF), Size, HashF, CmpF) :-
array(Vals, Size),
create_mutable(0, N).
b_hash_size(hash(_, _, Size, _, _, _), Size).
b_hash_lookup(Key, Val, hash(Keys, Vals, Size, _, F, CmpF)):-
hash_f(Key, Size, Index, F),
fetch_key(Keys, Index, Size, Key, CmpF, ActualIndex),
@ -122,17 +135,29 @@ add_element(Keys, Index, Size, N, Vals, Key, NewVal, Hash, NewHash) :-
get_mutable(NEls, N),
NN is NEls+1,
update_mutable(NN, N),
array_element(Keys, Index, Key),
update_mutable(NN, N),
array_element(Vals, Index, Mutable),
create_mutable(NewVal, Mutable),
(
NN > Size/3
->
expand_array(Hash, NewHash)
;
Hash = NewHash
),
array_element(Keys, Index, Key),
update_mutable(NN, N),
array_element(Vals, Index, Mutable),
create_mutable(NewVal, Mutable).
).
expand_array(Hash, NewHash) :-
Hash == NewHash, !,
Hash = hash(Keys, Vals, Size, _X, F, _CmpF),
new_size(Size, NewSize),
array(NewKeys, NewSize),
array(NewVals, NewSize),
copy_hash_table(Size, Keys, Vals, F, NewSize, NewKeys, NewVals),
/* overwrite in place */
setarg(1, Hash, NewKeys),
setarg(2, Hash, NewVals),
setarg(3, Hash, NewSize).
expand_array(Hash, hash(NewKeys, NewVals, NewSize, X, F, CmpF)) :-
Hash = hash(Keys, Vals, Size, X, F, CmpF),
@ -188,3 +213,37 @@ cmp_f(F, A, B) :-
cmp_f(F, A, B) :-
call(F, A, B).
b_hash_to_list(hash(Keys, Vals, _, _, _, _), LKeyVals) :-
Keys =.. (_.LKs),
Vals =.. (_.LVs),
mklistpairs(LKs, LVs, LKeyVals).
b_hash_keys_to_list(hash(Keys, _, _, _, _, _), LKeys) :-
Keys =.. (_.LKs),
mklistels(LKs, LKeys).
b_hash_values_to_list(hash(_, Vals, _, _, _, _), LVals) :-
Vals =.. (_.LVs),
mklistvals(LVs, LVals).
mklistpairs([], [], []).
mklistpairs(V.LKs, _.LVs, KeyVals) :- var(V), !,
mklistpairs(LKs, LVs, KeyVals).
mklistpairs(K.LKs, V.LVs, (K-VV).KeyVals) :-
get_mutable(VV, V),
mklistpairs(LKs, LVs, KeyVals).
mklistels([], []).
mklistels(V.Els, NEls) :- var(V), !,
mklistels(Els, NEls).
mklistels(K.Els, K.NEls) :-
mklistels(Els, NEls).
mklistvals([], []).
mklistvals(V.Vals, NVals) :- var(V), !,
mklistvals(Vals, NVals).
mklistvals(K.Vals, KK.NVals) :-
get_mutable(KK, K),
mklistvals(Vals, NVals).

229
library/dialect/bprolog.yap Normal file
View File

@ -0,0 +1,229 @@
:- set_prolog_flag(dollar_as_lower_case,on).
:- use_module(library(lists)).
:- use_module(library(hacks),[
current_choicepoint/1,
cut_by/1]).
:- use_module(library(terms)).
:- use_module(library(system)).
:- ensure_loaded(bprolog/arrays).
:- ensure_loaded(bprolog/hashtable).
%:- ensure_loaded(bprolog/actionrules).
:- ensure_loaded(bprolog/foreach).
%:- ensure_loaded(bprolog/compile_foreach).
:- op(700, xfx, [?=]).
:- op(200, fx, (@)).
X ?= Y :- unifiable(X,Y,_).
global_set(F,N,Value) :-
atomic_concat([F,'/',N],Key),
nb_setval(Key, Value).
global_set(F,Value) :-
atom_concat([F,'/0'],Key),
nb_setval(Key, Value).
global_get(F,Arity,Value) :-
atomic_concat([F,'/',Arity],Key),
nb_getval(Key, Value).
global_get(F,Value) :-
atom_concat([F,'/0'],Key),
nb_getval(Key, Value).
global_del(F,Arity) :-
atomic_concat([F,'/',Arity],Key),
catch(nb_delete(Key),_,true).
global_del(F) :-
atom_concat([F,'/0'],Key),
catch(nb_delete(Key),_,true).
getclauses1(File, Prog, _Opts) :-
findall(Clause, '$bpe_get_clause_from_file'(File, Clause), Prog0),
'$bpe_get_preds'(Prog0, Prog).
'$bpe_open_file'(File, Dir, S) :-
absolute_file_name(File, Abs, [expand(true),access(read)]),
file_directory_name(Abs, Dir),
open(Abs, read, S).
'$bpe_get_clause_from_file'(File, Clause) :-
'$bpe_open_file'(File, Dir, S),
working_directory(Old, Dir),
repeat,
read(S, Clause0),
( Clause0 = end_of_file ->
!,
working_directory(Dir, Old),
fail
;
%ugh, but we have to process include directives on the spot...
Clause0 = (:- include(Include))
->
'$bpe_get_clause_from_file'(Include, Clause)
;
Clause = Clause0
).
'$bpe_get_preds'(Decl.Prog0, pred(F,N,Modes,Delay,Tabled,Cls).NProg) :-
'$get_pred'(Decl, F, N, Modes,Delay, Tabled, Cls, Cls0), !,
'$bpe_process_pred'(Prog0, F,N,Modes,Delay,Tabled, Cls0, ProgF, []),
'$bpe_get_preds'(ProgF, NProg).
'$bpe_get_preds'(_Decl.Prog0, NProg) :-
'$bpe_get_preds'(Prog0, NProg).
'$bpe_get_preds'([], []).
'$bpe_process_pred'([], _F, N, Mode, _Delay, _Tabled, []) -->
{ '$init_mode'(N, Mode) }.
'$bpe_process_pred'(Call.Prog0, F,N,Modes,Delay,Tabled, Cls0) -->
{ '$get_pred'(Call, F, N, Modes, Delay, Tabled, Cls0, ClsI) }, !,
'$bpe_process_pred'(Prog0, F,N,Modes,Delay,Tabled, ClsI).
'$bpe_process_pred'(Call.Prog0, F,N,Modes,Delay,Tabled, Cls0) -->
[ Call ],
'$bpe_process_pred'(Prog0, F,N,Modes,Delay,Tabled, Cls0).
'$init_mode'(_N, Mode) :- nonvar(Mode), !.
'$init_mode'(0, []) :- !.
'$init_mode'(I, [d|Mode]) :- !,
I0 is I-1,
'$init_mode'(I0, Mode).
'$get_pred'((P :- Q), F, N, _Modes, _Delay, _Tabled) -->
{ functor(P, F, N), ! },
[(P:-Q)].
'$get_pred'((:- mode Q), F, N, _Modes, _Delay, _Tabled) -->
{ functor(Q, F, N), !, Q =.. [_|Modes0],
'$bpe_cvt_modes'(Modes0,Modes,[])
},
[].
%'$get_pred'((:- table _), F, N, Modes, Delay, Tabled) -->
% { functor(Q, F, N), !, Q =.. [_|Modes] },
% [].
'$get_pred'((:- _), _F, _N, _Modes, _Delay, _Tabled) --> !, { fail }.
'$get_pred'((P), F, N, _Modes, _Delay, _Tabled) -->
{ functor(P, F, N), ! },
[(P)].
'$bpe_cvt_modes'(Mode.Modes0) --> [NewMode],
{ '$bpe_cvt_mode'(Mode, NewMode) },
'$bpe_cvt_modes'(Modes0).
'$bpe_cvt_modes'([]) --> [].
'$bpe_cvt_mode'(Mode, Mode).
list_to_and([], true).
list_to_and([G], G).
list_to_and([G1,G2|Gs], (G1, NGs)) :-
list_to_and([G2|Gs], NGs).
preprocess_cl(Cl, Cl, _, _, _, _).
phase_1_process(Prog, Prog).
compileProgToFile(_,_File,[]).
compileProgToFile(_,File,pred(F,N,_,_,Tabled,Clauses).Prog2) :-
(nonvar(Tabled) -> table(F/N) ; true),
functor(S,F,N),
assert(b_IS_CONSULTED_c(S)),
'$assert_clauses'(Clauses),
compileProgToFile(_,File,Prog2).
'$assert_clauses'([]).
'$assert_clauses'(Cl.Clauses) :-
assert_static(Cl),
'$assert_clauses'(Clauses).
'$myload'(_F).
initialize_table :- abolish_all_tables.
:- dynamic b_IS_DEBUG_MODE/0.
'_$savecp'(B) :- current_choicepoint(B).
'_$cutto'(B) :- cut_by(B).
X <= Y :- subsumes_chk(Y,X).
cputime(X) :- statistics(cputime,[X,_]).
vars_set(Term, Vars) :-
term_variables(Term, Vars).
sort(=<, L, R) :-
length(L, N),
$bp_sort(@=<, N, L, _, R1), !,
R = R1.
sort(>=, L, R) :-
length(L, N),
$bp_sort(@>=, N, L, _, R1), !,
R = R1.
sort(<, L, R) :-
length(L, N),
$bp_sort2(@<, N, L, _, R1), !,
R = R1.
sort(>, L, R) :-
length(L, N),
$bp_sort2(@>, N, L, _, R1), !,
R = R1.
$bp_sort(P, 2, [X1, X2|L], L, R) :- !,
(
call(P, X1, X2) ->
R = [X1,X2]
;
R = [X2,X1]
).
$bp_sort(_, 1, [X|L], L, [X]) :- !.
$bp_sort(_, 0, L, L, []) :- !.
$bp_sort(P, N, L1, L3, R) :-
N1 is N // 2,
plus(N1, N2, N),
$bp_sort(P, N1, L1, L2, R1),
$bp_sort(P, N2, L2, L3, R2),
$bp_predmerge(P, R1, R2, R).
$bp_predmerge(_, [], R, R) :- !.
$bp_predmerge(_, R, [], R) :- !.
$bp_predmerge(P, [H1|T1], [H2|T2], [H1|Result]) :-
call(P, H1, H2), !,
$bp_predmerge(P, T1, [H2|T2], Result).
$bp_predmerge(P, [H1|T1], [H2|T2], [H2|Result]) :-
$bp_predmerge(P, [H1|T1], T2, Result).
$bp_sort2(P, 2, [X1, X2|L], L, R) :- !,
(
call(P, X1, X2) ->
R = [X1,X2]
;
X1 == X2
->
R = [X1]
;
R = [X2,X1]
).
$bp_sort2(_, 1, [X|L], L, [X]) :- !.
$bp_sort2(_, 0, L, L, []) :- !.
$bp_sort2(P, N, L1, L3, R) :-
N1 is N // 2,
plus(N1, N2, N),
$bp_sort(P, N1, L1, L2, R1),
$bp_sort(P, N2, L2, L3, R2),
$bp_predmerge(P, R1, R2, R).
$bp_predmerge2(_, [], R, R) :- !.
$bp_predmerge2(_, R, [], R) :- !.
$bp_predmerge2(P, [H1|T1], [H2|T2], [H1|Result]) :-
call(P, H1, H2), !,
$bp_predmerge(P, T1, [H2|T2], Result).
$bp_predmerge2(P, [H1|T1], [H2|T2], [H1|Result]) :-
H1 == H2, !,
$bp_predmerge(P, T1, T2, Result).
$bp_predmerge2(P, [H1|T1], [H2|T2], [H2|Result]) :-
$bp_predmerge(P, [H1|T1], T2, Result).

464
library/dialect/bprolog/actionrules.pl Normal file
View File

@ -0,0 +1,464 @@
/*
Author: Bart Demoen, Phuong-Lan Nguyen
E-mail: Bart.Demoen@cs.kuleuven.be, nguyen@uco.fr
WWW: http://www.swi-prolog.org
Copyright (C): 2006, K.U. Leuven
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
/* What is this module for ... see bottom of the file */
:- module(actionrules,[op(1200,xfx,=>),
op(1200,xfx,?=>),
op(1000,xfy,:::),
op(900,xfy,<=),
post/1,
post_event/2,
post_event_df/2,
post_event_df/3,
register_event/2
]).
:- use_module(library(lists)).
:- dynamic ar_term/2, extra_ar_term/2.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% the built-ins and the preds needed in the transformation %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
register_event(event(X,_),G) :- add_attr(X,'$$event',G).
register_event(ins(X),G) :- add_attr(X,'$$ins',G).
register_event(generated,_). % ignore
add_attr(X,Mod,A) :-
(get_attr(X,Mod,Old) ->
New = [A|Old]
;
New = [A]
),
put_attr(X,Mod,New).
post(event(X,Mes)) :- !,
(get_attr(X,'$$event',Gs) ->
activate_agents_rev(Gs,Mes)
;
(var(X) ->
true
;
throw(actionrule(event/2,illegalfirstargument))
)
).
post(ins(X)) :- !,
(get_attr(X,'$$ins',Gs) ->
call_list_rev(Gs)
;
(var(X) ->
true
;
throw(actionrule(ins/1,illegalfirstargument))
)
).
post(Event) :-
throw(actionrule(Event,illegalpost)).
post_event(X,Mes) :-
get_attr(X,'$$event',Gs), !, activate_agents_rev(Gs,Mes).
post_event(X,_) :-
(var(X) ->
true
;
throw(actionrule(post_event/2,illegalfirstargument))
).
post_event_df(X,Mes) :-
get_attr(X,'$$event',Gs), !, activate_agents1(Gs,Mes).
post_event_df(_,_).
post_event_df(X,Alive,Mes) :-
get_attr(X,'$$event',Gs), !, activate_agents(Gs,Alive,Mes).
post_event_df(_,_,_).
'$$ins':attr_unify_hook(AttrX,Y) :-
(var(Y) ->
(get_attr(Y,'$$ins',AttrY) ->
append(AttrX,AttrY,NewAttr)
;
NewAttr = AttrX
),
put_attr(Y,ins,NewAttr)
;
true
),
call_list_rev(AttrX).
'$$event':attr_unify_hook(_,_).
call_list_rev(Goals) :-
reverse(Goals,Gs),
call_list(Gs).
call_list([]).
call_list([G|Gs]) :-
call(G),
call_list(Gs).
activate_agents_rev(Goals,M) :-
reverse(Goals,Gs),
activate_agents(Gs,M).
activate_agents([],_).
activate_agents([G|Gs],Mes) :-
G =.. [N,_|R],
NewG =.. [N,Mes|R],
call(NewG),
activate_agents(Gs,Mes).
activate_agents([],_,_).
activate_agents([G|Gs],Alive,Mes) :-
(var(Alive) ->
G =.. [N,_|R],
NewG =.. [N,Mes|R],
call(NewG),
activate_agents(Gs,Alive,Mes)
;
true
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% ar_translate and helper predicates %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
ars2p(ARs,Det,Head,Program,Errors,TailProgram,TailErrors) :-
copyskel(Head,Skel),
cleanheads(ARs,NewARs,Skel),
Skel =.. [N|Args],
makeagentname(N,AgentName),
NewSkel =.. [AgentName,Mes,Alive|Args],
findmess(NewARs,Mes),
genfirstclause(NewARs,Det,NewSkel,Skel,Program,Errors,TailProgram1,TailErrors1),
gensecondclause(NewARs,Det,NewSkel,Alive,TailProgram1,TailErrors1,TailProgram,TailErrors).
genfirstclause(NewARs,Det,NewSkel,Skel,Program,Errors,TailProgram,TailErrors) :-
Clause = (Skel :- (Closure = NewSkel), Body),
makefirstbody(NewARs,Det,Closure,Body,Errors,TailErrors),
Program = [Clause | TailProgram].
build_conditional(det, Guard, B, (Guard -> B)).
build_conditional(nondet, Guard, B, (Guard, B)).
makefirstbody([ar(Head,Guard,Events,B)|R],Det,Closure,Bodys,Errors,TailErrors) :-
(Events == [] ->
build_conditional(Det, Guard, B, Body),
Errors = Errors1
;
check_events(Events,Head,Errors,Errors1),
mkregistergoals(Events,Register,Closure),
(member(generated,Events) ->
build_conditional(Det, Guard, (Register,B), Body)
;
build_conditional(Det, Guard, Register, Body)
)
),
(R == [] ->
Bodys = Body,
Errors1 = TailErrors
;
Bodys = (Body ; MoreBody),
makefirstbody(R,Det,Closure,MoreBody,Errors1,TailErrors)
).
gensecondclause(NewARs,Det,NewSkel,Alive,Program,Errors,TailProgram,Errors) :-
Clause = (NewSkel :- (var(Alive) -> Body ; true)),
makesecondbody(NewARs,Det,NewSkel,Body,Alive),
Program = [Clause | TailProgram].
makesecondbody([ar(_,Guard,Events,B)|R],Det,NewSkel,Bodys,Alive) :-
(Events == [] ->
build_conditional(Det, Guard, (Alive = no, B), Body)
;
build_conditional(Det, Guard, B, Body)
),
(R == [] ->
Bodys = Body
;
Bodys = (Body ; MoreBody),
makesecondbody(R,Det,NewSkel,MoreBody,Alive)
).
check_events([],_,E,E).
check_events([Event|R],S,E,TailE) :-
(nonvar(Event), okevent(Event) ->
E = E1
;
E = [illegalevent(Event,S)|E1]
),
check_events(R,S,E1,TailE).
okevent(ins(X)) :- !, var(X).
okevent(event(X,M)) :- !, var(X), var(M).
okevent(generated).
findmess([],_).
findmess([ar(_,_,Events,_)|R],Mes) :-
findmess2(Events,Mes),
findmess(R,Mes).
findmess2([],_).
findmess2([A|R],Mes) :-
(A = event(_,Mes) ->
true
;
true
),
findmess2(R,Mes).
copyskel(T1,T2) :-
functor(T1,N,A),
functor(T2,N,A).
cleanheads([],[],_).
cleanheads([ar(Head,Conds,Events,Body)|R],[ar(NewHead,NewConds,Events,Body)|S],Skel) :-
makenewhead(Head,NewHead,Unies),
Skel = NewHead,
append(Unies,Conds,LNewConds),
conds_to_goals(LNewConds, NewConds0),
removetrue(NewConds0, NewConds),
cleanheads(R,S,Skel).
conds_to_goals([], true) :- !.
conds_to_goals(C.LNewConds, (C,NewConds0)) :- !,
conds_to_goals(LNewConds, NewConds0).
conds_to_goals(C,C).
makenewhead(Head,NewHead,Unies) :-
Head =.. [_|Args],
functor(Head,N,A),
functor(NewHead,N,A),
NewHead =.. [_|NewArgs],
makeunies(Args,NewArgs,Unies).
makeunies([],_,[]).
makeunies([X|R],[Y|S],Us) :-
(var(X) ->
X = Y,
Us = Us2
;
Us = [X=Y|Us2] % this should be matching instead of unification
),
makeunies(R,S,Us2).
get_arinfo(AR,ARInfo,Head) :-
AR = (Something => Body),
(Something = (Head,Rest) ->
findcondevents(Rest,Conds,Events)
;
Something = Head, Conds = true, Events = []
),
ARInfo = ar(Head,Conds,Events,Body).
get_arinfo(AR,ARInfo,Head) :-
AR = (Something ?=> Body),
(Something = (Head,Rest) ->
findcondevents(Rest,Conds,Events)
;
Something = Head, Conds = true, Events = []
),
ARInfo = ar(Head,Conds,Events,Body).
get_arinfo(AR,ARInfo,Head) :-
AR = (Head :- Rest ::: Body),
Conds = Rest, Events = [],
ARInfo = ar(Head,Conds,Events,Body).
findcondevents((A,B),(A,As),Ts) :- !,
findcondevents(B,As,Ts).
findcondevents({Trs},true,Ts) :- !,
makeevents(Trs,Ts).
findcondevents(A,A,[]).
makeevents((A,B),[A|R]) :- !, makeevents(B,R).
makeevents(A,[A]).
samehead(A,B) :-
functor(A,X,Y),
functor(B,X,Y).
makeagentname(N,Out) :-
name(N,NL),
name('$$suspended_',A),
append(A,NL,ANL),
name(Out,ANL).
mkregistergoals([],true,_).
mkregistergoals([X|R],Register,Skel) :-
(X == generated ->
mkregistergoals(R,Register,Skel)
;
Register = (register_event(X,Skel),S),
mkregistergoals(R,S,Skel)
).
removetrue(true,true) :- !.
removetrue((true,A),AA) :- !, removetrue(A,AA).
removetrue((A,true),AA) :- !, removetrue(A,AA).
removetrue((A,B),(AA,BB)) :- !, removetrue(A,AA), removetrue(B,BB).
removetrue((A->B),(AA->BB)) :- !, removetrue(A,AA), removetrue(B,BB).
removetrue((A;B),(AA;BB)) :- !, removetrue(A,AA), removetrue(B,BB).
removetrue(X,X).
ar_translate([],_,[],[]).
ar_translate([AR|ARs],Module,Program,Errors) :-
get_head(AR,ARHead),
collect_ars_same_head(ARs,ARHead,ActionPredRest,RestARs),
ars2p([AR|ActionPredRest],det,ARHead,Program,Errors,TailProgram,TailErrors),
extra_ars(AR, TailProgram, NTailProgram),
ar_translate(RestARs,Module,NTailProgram,TailErrors).
nondet_ar_translate([],_,Program,Program,[]).
nondet_ar_translate([AR|ARs],Module,Program,EndProgram,Errors) :-
get_head(AR,ARHead),
collect_ars_same_head(ARs,ARHead,ActionPredRest,RestARs),
ars2p([AR|ActionPredRest],nondet,ARHead,Program,Errors,TailProgram,TailErrors),
nondet_ar_translate(RestARs,Module,TailProgram, EndProgram,TailErrors).
collect_ars_same_head([],_,[],[]).
collect_ars_same_head([AR1|ARs],Head,SameHeadARs,RestARs) :-
get_head(AR1,Head1),
(same_head(Head1,Head) ->
SameHeadARs = [AR1|SameHeadARsRest],
collect_ars_same_head(ARs,Head,SameHeadARsRest,RestARs)
;
RestARs = [AR1|RestARsRest],
collect_ars_same_head(ARs,Head,SameHeadARs,RestARsRest)
).
get_head(ar(Head,_Conds,_Events,_Body),Head).
same_head(T1,T2) :-
functor(T1,N,A),
functor(T2,N,A).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
ar_expand(Term, []) :-
Term = (_ => _), !,
prolog_load_context(file,File),
get_arinfo(Term,ARInfo,_),
assert(ar_term(File,ARInfo)).
ar_expand(Term, []) :-
Term = (_ :- _ ::: _), !,
prolog_load_context(file,File),
get_arinfo(Term,ARInfo,_),
assert(ar_term(File,ARInfo)).
ar_expand(Term, []) :-
Term = (_ ?=> _ ), !,
prolog_load_context(file,File),
get_arinfo(Term,ARInfo,_),
assert(nondet_ar_term(File,ARInfo)).
ar_expand(Term, []) :-
Term = (Head :- Body ),
prolog_load_context(file,File),
functor(Head, Na, Ar),
functor(Empty, Na, Ar),
ar_term(File,ar(Empty,_,_,_)), !,
assert(extra_ar_term(File,ar(Head, Body))).
ar_expand(Head, []) :-
prolog_load_context(file,File),
functor(Head, Na, Ar),
functor(Empty, Na, Ar),
ar_term(File,ar(Empty,_,_,_)), !,
assert(extra_ar_term(File,ar(Head, true))).
ar_expand(end_of_file, FinalProgram) :-
prolog_load_context(file,File),
compile_ar(File, DetProgram),
compile_nondet_ar(File, FinalProgram, DetProgram).
compile_ar(File, FinalProgram) :-
findall(T, retract(ar_term(File,T)), ARs),
ARs \== [],
prolog_load_context(module, Module),
ar_translate(ARs, Module, FinalProgram, Errors),
!, % just to make sure there are no choice points left
(Errors == [] ->
true
;
report_errors(Errors)
).
compile_nondet_ar(File, FinalProgram, StartProgram) :-
findall(T, retract(nondet_ar_term(File,T)), ARs),
ARs \== [],
prolog_load_context(module, Module),
nondet_ar_translate(ARs, Module, FinalProgram, StartProgram, Errors),
!, % just to make sure there are no choice points left
(Errors == [] ->
true
;
report_errors(Errors)
).
report_errors(Errors) :- throw(action_rule_error(Errors)). % for now
extra_ars(ar(Head,_,_,_), LF, L0) :-
functor(Head, N, A),
functor(Empty, N, A),
findall((Empty :- B), extra_ar_term(_,ar(Empty, B)), LF, L0).
/*******************************
* MUST BE LAST! *
*******************************/
:- multifile user:term_expansion/2.
:- dynamic user:term_expansion/2.
user:term_expansion(In, Out) :-
ar_expand(In, Out).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% What this file is for .... %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
Action Rules were defined and implemented first in the context of
B-Prolog and the TOAM by Neng-Fa Zhou - see http://www.probp.com/
See http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW456.abs.html
for an explanation what this file is based on.
Use_module-ing this file will give you an implementation of Action Rules
functionality related to the event patterns ins/1, generated/0 and
event/2.
It is not a fast implementation in SWI-Prolog, because there isn't any
low-level support.
If you need more functionality, please contact the authors.
*/

35
library/dialect/bprolog/arrays.yap Normal file
View File

@ -0,0 +1,35 @@
:- module(bparrays, [new_array/2, a2_new/3, a3_new/4, is_array/1, '$aget'/3]).
:- use_module(library(lists), [flatten/2]).
new_array(X, Dim.Dims) :-
functor(X, '[]', Dim),
recurse_new_array(0, Dim, Dims, X).
recurse_new_array(_, _, [], _X) :- !.
recurse_new_array(Dim, Dim, _Dims, _X) :- !.
recurse_new_array(I0, Dim, Dims, X) :-
I is I0+1,
arg(I, X, A),
new_array(A, Dims),
recurse_new_array(0, Dim, Dims, X).
a2_new(X, Dim1, Dim2) :-
functor(X, '[]', Dim1),
recurse_new_array(0, Dim1, [Dim2], X).
a2_new(X, Dim1, Dim2, Dim3) :-
functor(X, '.', Dim1),
recurse_new_array(0, Dim1, [Dim2,Dim3], X).
is_array(X) :-
functor(X, '[]', _Dim).
'$aget'(A,[],A).
'$aget'(A,I.Is,A) :-
arg(I, A, X),
'$aget'(X,Is,A).
array_to_list(A, List) :-
flatten(A, List).

514
library/dialect/bprolog/compile_foreach.pl Normal file
View File

@ -0,0 +1,514 @@
s% File : compile_foreach.pl
% Author : Neng-Fa Zhou
% Updated: June 2009, updated Dec. 2009, updated Sep. 2010
% Purpose: compile away foreach
/* compile_foreach(Cls,NCls): NCls is a list of clauses obtained by
compiling away foreach calls in Cls. The new predicate introduced
for a foreach is named p_#_i where p is the name of the predicate
in which the foreach occurs and i is a unique integer.
*/
:- yap_flag(unknown,error).
:- ensure_loaded(actionrules).
:- op(560,xfx,[..,to,downto]).
:- op(700,xfx,[subset,notin,in,@=]).
/*
test:-
Cl1=(test1(L):-foreach(I in L, write(I))),
Cl2=(test2(L):-foreach(I in L, ac(S,0), S^1 is S^0+I)),
Cl3=(test3(T):-functor(T,_,N),foreach(I in 1..N, [Ti],ac(S,0), (arg(I,T,Ti),S^1 is S^0+Ti))),
Cl4=(test4(L):-foreach(I in L, ac1(C,[]), C^0=[I|C^1])),
Cl5=(test5:-foreach(I in [1,2], J in [a,b], ac(L,[]),L^1=[(I,J)|L^0]),writeln(L),fail),
Cl6=(test6:-foreach(I in [1,2], J in [a,b], ac1(L,[]),L^0=[(I,J)|L^1]),writeln(L),fail),
Cl7=(test7(L1,L2):-foreach(X in L1, (write(X),foreach(Y in L2, writeln((X,Y)))))),
Cl8=(p(D1,D3,IN,OUT):-
foreach(E in D3,
[INi,OUTi],
(asp_lib_clone_rel(IN,OUT,INi,OUTi),
(foreach(X in D1, Y in D1,(not diagY(X,Y,E)->asp_lib_add_tuples(OUTi,X,Y);true)),
asp_lib_card_unique(2,INi,OUTi))))),
compile_foreach([Cl1,Cl2,Cl3,Cl4,Cl5,Cl6,Cl7,Cl8],NCls),
(member(NCl,NCls), portray_clause(NCl),fail;true).
*/
compile_foreach(File):-
$getclauses_read_file(File,'$t.t.t$',0,_Singleton,_Redef,Cls,[]),
compile_foreach(Cls,NCls),
foreach(NCl in NCls, portray_clause(NCl)).
compile_foreach(Cls,NCls):-
new_hashtable(ProgTab),
compile_foreach(Cls,NCls,NCls1,ProgTab,0),
hashtable_values_to_list(ProgTab,Prog),
retrieve_new_cls(Prog,NCls1).
retrieve_new_cls([],[]).
retrieve_new_cls([pred(_,_,_,_,_,Cls)|Preds],NCls):-
append_diff(Cls,NCls,NCls1),
retrieve_new_cls(Preds,NCls1).
compile_foreach([],NCls,NClsR,_ProgTab,_DumNo) => NCls=NClsR.
compile_foreach([Cl|Cls],NCls,NClsR,ProgTab,DumNo) =>
NCls=[NCl|NCls1],
expand_constr(Cl,NCl,ProgTab,DumNo,DumNo1),
compile_foreach(Cls,NCls1,NClsR,ProgTab,DumNo1).
cl_contains_foreach((delay (_H:-(_G : B)))) =>
goal_contains_foreach(B,Flag),nonvar(Flag).
cl_contains_foreach((_H:-_G : B)) =>
goal_contains_foreach(B,Flag),nonvar(Flag).
cl_contains_foreach((_H:-_G ? B)) =>
goal_contains_foreach(B,Flag),nonvar(Flag).
cl_contains_foreach((_H:-B)) =>
goal_contains_foreach(B,Flag),nonvar(Flag).
goal_contains_foreach(G):-
goal_contains_foreach(G,Flag),
nonvar(Flag).
goal_contains_foreach(_G,Flag), nonvar(Flag) => true.
goal_contains_foreach(G,_Flag), var(G) => true.
goal_contains_foreach((_G : B),Flag) =>
goal_contains_foreach(B,Flag).
goal_contains_foreach((_G ? B),Flag) =>
goal_contains_foreach(B,Flag).
goal_contains_foreach((A,B),Flag) =>
goal_contains_foreach(A,Flag),
goal_contains_foreach(B,Flag).
goal_contains_foreach((A -> B ; C),Flag) =>
goal_contains_foreach(A,Flag),
goal_contains_foreach(B,Flag),
goal_contains_foreach(C,Flag).
goal_contains_foreach((A;B),Flag) =>
goal_contains_foreach(A,Flag),
goal_contains_foreach(B,Flag).
goal_contains_foreach(not(A),Flag) =>
goal_contains_foreach(A,Flag).
goal_contains_foreach(\+(A),Flag) =>
goal_contains_foreach(A,Flag).
goal_contains_foreach(Lhs @= Rhs,Flag) =>
exp_contains_list_comp(Lhs,Flag),
exp_contains_list_comp(Rhs,Flag).
goal_contains_foreach(E1#=E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#\=E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#<E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#=<E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#>E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(E1#>=E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
goal_contains_foreach(G,Flag), functor(G,foreach,_) => Flag=1.
goal_contains_foreach(_G,_Flag) => true.
exp_contains_list_comp(_,Flag), nonvar(Flag) => true.
exp_contains_list_comp([(_ : _)|_],Flag) => Flag=1.
exp_contains_list_comp(E1+E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(E1-E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(E1*E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(E1/E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(E1//E2,Flag) =>
exp_contains_list_comp(E1,Flag),
exp_contains_list_comp(E2,Flag).
exp_contains_list_comp(-E,Flag) =>
exp_contains_list_comp(E,Flag).
exp_contains_list_comp(abs(E),Flag) =>
exp_contains_list_comp(E,Flag).
exp_contains_list_comp(sum([(_ : _)|_]),Flag) => Flag=1.
exp_contains_list_comp(min([(_ : _)|_]),Flag) => Flag=1.
exp_contains_list_comp(max([(_ : _)|_]),Flag) => Flag=1.
exp_contains_list_comp(_,_) => true.
%%
$change_list_comprehension_to_foreach_cmptime(T,I,Is,CallForeach,L):-
$retrieve_list_comp_lvars_goal_cmptime(Is,LocalVars1,Goal1,Is1),
(nonvar(T),T=_^_-> % array access
LocalVars=[TempVar|LocalVars1],
(Goal1==true->
Goal=(TempVar@=T,L^0=[TempVar|L^1])
;
Goal=(Goal1->(TempVar@=T,L^0=[TempVar|L^1]);L^0=L^1)
)
;
LocalVars=LocalVars1,
(Goal1==true->
Goal=(L^0=[T|L^1])
;
Goal=(Goal1->L^0=[T|L^1];L^0=L^1)
)
),
append(Is1,[LocalVars,ac1(L,[]),Goal],Is2),
CallForeach=..[foreach,I|Is2].
$retrieve_list_comp_lvars_goal_cmptime([],LocalVars,Goal,Is) =>
LocalVars=[],Goal=true,Is=[].
$retrieve_list_comp_lvars_goal_cmptime([E|Es],LocalVars,Goal,Is),E = (_ in _) =>
Is=[E|IsR],
$retrieve_list_comp_lvars_goal_cmptime(Es,LocalVars,Goal,IsR).
$retrieve_list_comp_lvars_goal_cmptime([LVars,G],LocalVars,Goal,Is),LVars=[] =>
Is=[],LocalVars=LVars,G=Goal.
$retrieve_list_comp_lvars_goal_cmptime([LVars,G],LocalVars,Goal,Is),LVars=[_|_] =>
Is=[],LocalVars=LVars,G=Goal.
$retrieve_list_comp_lvars_goal_cmptime([LVars],LocalVars,Goal,Is),LVars=[_|_] =>
Is=[],LocalVars=LVars,Goal=true.
$retrieve_list_comp_lvars_goal_cmptime([LVars],LocalVars,Goal,Is),LVars=[] =>
Is=[],LocalVars=LVars,Goal=true.
$retrieve_list_comp_lvars_goal_cmptime([G],LocalVars,Goal,Is),nonvar(G) =>
Is=[],LocalVars=[],G=Goal.
%%
extract_list_comprehension_array_notation(T,NT,TempCalls,TempCallsR), var(T) =>
NT=T,TempCalls=TempCallsR.
extract_list_comprehension_array_notation(T,NT,TempCalls,TempCallsR), T=(_^_) =>
TempCalls=[NT @= T|TempCallsR].
extract_list_comprehension_array_notation(sum(T),NT,TempCalls,TempCallsR), T=[(_ : _)|_] =>
NT=sum(L),
TempCalls=[L @= T|TempCallsR].
extract_list_comprehension_array_notation(min(T),NT,TempCalls,TempCallsR), T=[(_ : _)|_] =>
NT=min(L),
TempCalls=[L @= T|TempCallsR].
extract_list_comprehension_array_notation(max(T),NT,TempCalls,TempCallsR), T=[(_ : _)|_] =>
NT=max(L),
TempCalls=[L @= T|TempCallsR].
extract_list_comprehension_array_notation(X+Y,NT,TempCalls,TempCallsR) =>
NT=(NX+NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(X-Y,NT,TempCalls,TempCallsR) =>
NT=(NX-NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(X*Y,NT,TempCalls,TempCallsR) =>
NT=(NX*NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(X//Y,NT,TempCalls,TempCallsR) =>
NT=(NX//NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(X/Y,NT,TempCalls,TempCallsR) =>
NT=(NX/NY),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCalls1),
extract_list_comprehension_array_notation(Y,NY,TempCalls1,TempCallsR).
extract_list_comprehension_array_notation(abs(X),NT,TempCalls,TempCallsR) =>
NT=abs(NX),
extract_list_comprehension_array_notation(X,NX,TempCalls,TempCallsR).
extract_list_comprehension_array_notation(T,NT,TempCalls,TempCallsR) =>
NT=T,TempCalls=TempCallsR.
compile_foreach_goal(G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
functor(G,_,Arity),
(compile_foreach_retrieve_iterators(G,1,Arity,Is,ACs,LocalVars,Goal)->
compile_foreach(Is,LocalVars,ACs,Goal,NG,PrefixName,ProgTab,DumNo,DumNoR)
;
NG=G,DumNo=DumNoR % interpreted
).
compile_foreach(Iterators,LocalVars,ACs,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
initial_acs_map(ACs,ACMap,Init,Fin),
NG=(Init,G1,Fin),
compile_foreach_iterators(Iterators,LocalVars,ACMap,G,G1,PrefixName,ProgTab,DumNo,DumNoR).
compile_foreach_iterators([],_LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) =>
substitute_accumulators(G,G1,ACMap),
expand_constr(G1,NG,PrefixName,ProgTab,DumNo,DumNoR).
compile_foreach_iterators([I in B1..Step..B2|Iterators],LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) =>
(var(I)->true; cmp_error(["wrong loop variable: ", I])),
(Step== -1 ->
compile_foreach_range_downto_1(I,B1,B2,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR);
compile_foreach_range_step(I,B1,B2,Step,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR)).
compile_foreach_iterators([I in L..U|Iterators],LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) =>
(var(I)->true; cmp_error(["wrong loop variable: ", I])),
compile_foreach_range_upto_1(I,L,U,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR).
compile_foreach_iterators([I in Lst|Iterators],LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR) =>
compile_foreach_lst(I,Lst,Iterators,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR).
compile_foreach_range_upto_1(I,LExp,UExp,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
new_pred_name_foreach(PrefixName,DumNo,NewPredName),
DumNo1 is DumNo+1,
term_variables((IteratorsR,G),AllVars),
extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]),
foreach_accumulator_args(ACMap,ACHeadArgs,[]),
split_acs_map(ACMap,ACMap1,ACMap2),
append(GVars,ACHeadArgs,Args),
foreach_accumulator_args(ACMap2,ACTailArgs,[]),
append(GVars,ACTailArgs,TailArgs),
foreach_end_accumulator_args(ACMap,BodyR1),
CallNewPred=..[NewPredName,Lower,Upper|Args],
NG=(Lower is LExp, Upper is UExp, CallNewPred),
Head=..[NewPredName,Elm,Upper|Args],
Body1=(Elm>Upper : BodyR1),
Tail2=..[NewPredName,Elm1,Upper|TailArgs],
Body2=(G1,Elm1 is Elm+1,Tail2),
Cl1=(Head:-Body1),
copy_term(Cl1,Cl1CP),
Cl2=(Head:-true : Body2),
I=Elm,
copy_term(t(IteratorsR,LocalVars,ACMap1,G,G1,Cl2),TCopy),
TCopy=t(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,Cl2CP),
%
compile_foreach_iterators(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,PrefixName,ProgTab,DumNo1,DumNo2),
%
'$eliminate_disjunctions'(Cl1CP,NCl1CP,ProgTab,DumNo2,DumNo3),
'$eliminate_disjunctions'(Cl2CP,NCl2CP,ProgTab,DumNo3,DumNoR),
functor(Head,_,Arity),
PredDef=pred(NewPredName,Arity,_Mode,_Delay,_Tabled,[NCl1CP,NCl2CP]),
hashtable_put(ProgTab,NewPredName/Arity,PredDef).
compile_foreach_range_downto_1(I,UExp,LExp,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
new_pred_name_foreach(PrefixName,DumNo,NewPredName),
DumNo1 is DumNo+1,
term_variables((IteratorsR,G),AllVars),
extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]),
foreach_accumulator_args(ACMap,ACHeadArgs,[]),
split_acs_map(ACMap,ACMap1,ACMap2),
append(GVars,ACHeadArgs,Args),
foreach_accumulator_args(ACMap2,ACTailArgs,[]),
append(GVars,ACTailArgs,TailArgs),
foreach_end_accumulator_args(ACMap,BodyR1),
CallNewPred=..[NewPredName,Upper,Lower|Args],
NG=(Lower is LExp, Upper is UExp, CallNewPred),
Head=..[NewPredName,Elm,Lower|Args],
Body1=(Elm<Lower : BodyR1),
Tail2=..[NewPredName,Elm1,Lower|TailArgs],
Body2=(G1,Elm1 is Elm-1,Tail2),
Cl1=(Head:-Body1),
copy_term(Cl1,Cl1CP),
Cl2=(Head:-true : Body2),
I=Elm,
copy_term(t(IteratorsR,LocalVars,ACMap1,G,G1,Cl2),TCopy),
TCopy=t(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,Cl2CP),
%
compile_foreach_iterators(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,PrefixName,ProgTab,DumNo1,DumNo2),
%
'$eliminate_disjunctions'(Cl1CP,NCl1CP,ProgTab,DumNo2,DumNo3),
'$eliminate_disjunctions'(Cl2CP,NCl2CP,ProgTab,DumNo3,DumNoR),
functor(Head,_,Arity),
PredDef=pred(NewPredName,Arity,_Mode,_Delay,_Tabled,[NCl1CP,NCl2CP]),
hashtable_put(ProgTab,NewPredName/Arity,PredDef).
compile_foreach_range_step(I,B1,B2,Step,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
new_pred_name_foreach(PrefixName,DumNo,NewPredName),
DumNo1 is DumNo+1,
term_variables((IteratorsR,G),AllVars),
extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]),
foreach_accumulator_args(ACMap,ACHeadArgs,[]),
split_acs_map(ACMap,ACMap1,ACMap2),
append(GVars,ACHeadArgs,Args),
foreach_accumulator_args(ACMap2,ACTailArgs,[]),
append(GVars,ACTailArgs,TailArgs),
foreach_end_accumulator_args(ACMap,BodyR1),
CallNewPred=..[NewPredName,B1Val,B2Val,StepVal|Args],
NG=(B1Val is B1, B2Val is B2, StepVal is Step, CallNewPred),
Head=..[NewPredName,Elm,B2Arg,StepArg|Args],
Body1=(StepArg>0,Elm>B2Arg : BodyR1),
Cl1=(Head:-Body1),
copy_term(Cl1,Cl1CP),
Body2=(StepArg<0,Elm<B2Arg : BodyR1),
Cl2=(Head:-Body2),
copy_term(Cl2,Cl2CP),
Tail3=..[NewPredName,Elm1,B2Arg,StepArg|TailArgs],
Body3=(G1,Elm1 is Elm+StepArg,Tail3),
Cl3=(Head:-true : Body3),
I=Elm,
copy_term(t(IteratorsR,LocalVars,ACMap1,G,G1,Cl3),TCopy),
TCopy=t(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,Cl3CP),
%
compile_foreach_iterators(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,PrefixName,ProgTab,DumNo1,DumNo2),
%
'$eliminate_disjunctions'(Cl1CP,NCl1CP,ProgTab,DumNo2,DumNo3),
'$eliminate_disjunctions'(Cl2CP,NCl2CP,ProgTab,DumNo3,DumNo4),
'$eliminate_disjunctions'(Cl3CP,NCl3CP,ProgTab,DumNo4,DumNoR),
functor(Head,_,Arity),
PredDef=pred(NewPredName,Arity,_Mode,_Delay,_Tabled,[NCl1CP,NCl2CP,NCl3CP]),
hashtable_put(ProgTab,NewPredName/Arity,PredDef).
compile_foreach_lst(I,Lst,IteratorsR,LocalVars,ACMap,G,NG,PrefixName,ProgTab,DumNo,DumNoR):-
new_pred_name_foreach(PrefixName,DumNo,NewPredName),
DumNo1 is DumNo+1,
term_variables((IteratorsR,G),AllVars),
extract_arg_vars(AllVars,I,IteratorsR,LocalVars,ACMap,GVars,[]),
foreach_accumulator_args(ACMap,ACHeadArgs,[]),
split_acs_map(ACMap,ACMap1,ACMap2),
append(GVars,ACHeadArgs,Args),
foreach_accumulator_args(ACMap2,ACTailArgs,[]),
append(GVars,ACTailArgs,TailArgs),
foreach_end_accumulator_args(ACMap,BodyR1),
NG=..[NewPredName,Lst|Args],
Head1=..[NewPredName,[]|Args],
Body1=BodyR1,
Head2=..[NewPredName,[Elm|Elms]|Args],
Tail2=..[NewPredName,Elms|TailArgs],
Head3=..[NewPredName,[_|Elms]|Args],
Tail3=..[NewPredName,Elms|Args],
Body2=(G1,Tail2),
Cl1=(Head1:-true : Body1),
copy_term(Cl1,Cl1CP),
Cl2=(Head2:-true : Body2),
I=Elm,
copy_term(t(IteratorsR,LocalVars,ACMap1,G,G1,Cl2),TCopy2),
TCopy2=t(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,Cl2CP),
Cl3=(Head3:-true : Tail3),
copy_term(Cl3,Cl3CP),
compile_foreach_iterators(IteratorsRCP,LocalVarsCP,ACMap1CP,GCP,G1CP,PrefixName,ProgTab,DumNo1,DumNo2),
'$eliminate_disjunctions'(Cl1CP,NCl1CP,ProgTab,DumNo2,DumNo3),
'$eliminate_disjunctions'(Cl2CP,NCl2CP,ProgTab,DumNo3,DumNoR),
functor(Head1,_,Arity),
Head4=..[NewPredName,Collection|Args],
Tail4=..[NewPredName,CollectionLst|Args],
Cl4=(Head4:-true : (foreach_collection_to_lst(Collection,CollectionLst),Tail4)),
copy_term(Cl4,Cl4CP),
PredDef=pred(NewPredName,Arity,_Mode,_Delay,_Tabled,[NCl1CP,NCl2CP,Cl3CP,Cl4CP]),
hashtable_put(ProgTab,NewPredName/Arity,PredDef).
foreach_accumulator_args([],Args,ArgsR) => Args=ArgsR.
foreach_accumulator_args([ac_inout(_Name,In,Out)|ACMap],Args,ArgsR) =>
Args=[In,Out|Args1],
foreach_accumulator_args(ACMap,Args1,ArgsR).
foreach_end_accumulator_args([],Body) => Body=true.
foreach_end_accumulator_args([ac_inout(_Name,In,Out)|ACMap],Body) =>
Body=(In=Out,BodyR),
foreach_end_accumulator_args(ACMap,BodyR).
split_acs_map([],ACMap1,ACMap2) => ACMap1=[],ACMap2=[].
split_acs_map([ac_inout(Name,In,Out)|ACMap],ACMap1,ACMap2) =>
ACMap1=[ac_inout(Name,In,Mid)|ACMap1R],
ACMap2=[ac_inout(Name,Mid,Out)|ACMap2R],
split_acs_map(ACMap,ACMap1R,ACMap2R).
/* utilities */
extract_arg_vars([],_I,_Iterators,_LocalVars,_ACMap,Args,ArgsR) => Args=ArgsR.
extract_arg_vars([Var|Vars],I,Iterators,LocalVars,ACMap,Args,ArgsR):-true ?
($occur(Var,I);
is_a_loop_var(Var,Iterators);
membchk(Var,LocalVars);
foreach_lookup_acmap(Var,1,_,ACMap);
foreach_lookup_acmap(Var,0,_,ACMap)),!,
extract_arg_vars(Vars,I,Iterators,LocalVars,ACMap,Args,ArgsR).
extract_arg_vars([Var|Vars],I,Iterators,LocalVars,ACMap,Args,ArgsR) =>
Args=[Var|Args1],
extract_arg_vars(Vars,I,Iterators,LocalVars,ACMap,Args1,ArgsR).
is_a_loop_var(Var,(I in _)):-true ? $occur(Var,I),!.
is_a_loop_var(Var,(Iterators1,_)):-true ?
is_a_loop_var(Var,Iterators1),!.
is_a_loop_var(Var,(_,Iterators2)) =>
is_a_loop_var(Var,Iterators2).
initial_acs_map([],ACMap,InitCode,FinCode) => ACMap=[],InitCode=true,FinCode=true.
initial_acs_map([AC],ACMap,InitCode,FinCode) =>
ACMap=[Triplet],
initial_ac_map(AC,Triplet,InitCode,FinCode).
initial_acs_map([AC|ACs],[Triplet|ACMap],InitCode,FinCode):-
InitCode=(InitCode1,InitCodeR),
FinCode=(FinCode1,FinCodeR),
initial_ac_map(AC,Triplet,InitCode1,FinCode1),
initial_acs_map(ACs,ACMap,InitCodeR,FinCodeR).
initial_acs_map(AC,ACMap,InitCode,FinCode) =>
ACMap=[Triplet],
initial_ac_map(AC,Triplet,InitCode,FinCode).
initial_ac_map(ac(Name,InitVal),ac_inout(Name,NameIn,NameOut),(NameIn=InitVal),(Name=NameOut)).
initial_ac_map(ac1(Name,FinVal),ac_inout(Name,NameIn,NameOut),(Name=NameIn),(NameOut=FinVal)).
% Replace inputs and outputs in recurrences: A^0 is input and A^1 is output.
substitute_accumulators(Term,NTerm,_ACMap):-var(Term) :
NTerm=Term.
substitute_accumulators(Term,NTerm,_ACMap):-atomic(Term) :
NTerm=Term.
substitute_accumulators(Term,NTerm,ACMap):-Term=(Var^Tail) :
(foreach_lookup_acmap(Var,Tail,NTerm,ACMap)->true;
NTerm=Term).
substitute_accumulators([E|Es],Lst,ACMap) =>
Lst=[E1|Es1],
substitute_accumulators(E,E1,ACMap),
substitute_accumulators(Es,Es1,ACMap).
substitute_accumulators(Term,NTerm,ACMap) =>
functor(Term,F,N),
functor(NTerm,F,N),
substitute_accumulators(Term,NTerm,1,N,ACMap).
substitute_accumulators(_Term,_NTerm,I,N,_), I>N => true.
substitute_accumulators(Term,NTerm,I,N,ACMap) =>
arg(I,Term,A),
arg(I,NTerm,NA),
substitute_accumulators(A,NA,ACMap),
I1 is I+1,
substitute_accumulators(Term,NTerm,I1,N,ACMap).
foreach_lookup_acmap(Term,Tail,NTerm,[ac_inout(Term1,In,Out)|_]), Term==Term1 =>
(Tail==0->NTerm=In;
Tail==1->NTerm=Out).
foreach_lookup_acmap(Term,Tail,NTerm,[_|ACMap]) =>
foreach_lookup_acmap(Term,Tail,NTerm,ACMap).
new_pred_name_foreach(PrefixName,DumNo,NewPredName):-
number_codes(DumNo,DumNoCodes),
append(PrefixName,[0'_,0'#,0'_|DumNoCodes],NewPredNameCodes),
atom_codes(NewPredName,NewPredNameCodes).
compile_foreach_retrieve_iterators(G,I,Arity,Iterators,ACs,LocalVars,Goal), I==Arity =>
arg(I,G,Goal),
Iterators=[],
(var(ACs)->ACs=[];true),
(var(LocalVars)->LocalVars=[];true).
compile_foreach_retrieve_iterators(G,I,Arity,Iterators,ACs,LocalVars,Goal) =>
arg(I,G,A),
(nonvar(A),A=(_ in _) ->
Iterators=[A|Iterators1]
;I>=Arity-2 ->
(cmp_foreach_check_accumulators(A) ->
Iterators=Iterators1,
(var(ACs)->ACs=A;cmp_error(["two accumulators given separately in foreach"]),fail)
;cmp_foreach_check_lvars(A)->
Iterators=Iterators1,
(var(LocalVars)->LocalVars=A;cmp_error(["invalid local variables given in foreach"]),fail)
;fail
)
;fail
),
I1 is I+1,
compile_foreach_retrieve_iterators(G,I1,Arity,Iterators1,ACs,LocalVars,Goal).
cmp_foreach_check_lvars([]) => true.
cmp_foreach_check_lvars([X|Xs]) => var(X),cmp_foreach_check_lvars(Xs).
cmp_foreach_check_accumulators(ac1(_,_)) => true.
cmp_foreach_check_accumulators(ac(_,_)) => true.
cmp_foreach_check_accumulators(Accumulators), Accumulators=[_|_] =>
cmp_foreach_check_accumulator_lst(Accumulators).
cmp_foreach_check_accumulator_lst([]) => true.
cmp_foreach_check_accumulator_lst([X|_]), var(X) => fail.
cmp_foreach_check_accumulator_lst([ac(_,_)|L]) =>
cmp_foreach_check_accumulator_lst(L).
cmp_foreach_check_accumulator_lst([ac1(_,_)|L]) =>
cmp_foreach_check_accumulator_lst(L).

169
library/dialect/bprolog/fli/bprolog.h Normal file
View File

@ -0,0 +1,169 @@
#ifndef BPROLOG_H
#define BPROLOG_H 1
#include <YapInterface.h>
#include <math.h>
typedef YAP_Term TERM;
typedef YAP_Int BPLONG;
typedef YAP_UInt BPULONG;
typedef BPLONG *BPLONG_PTR;
#define BP_TRUE TRUE
#define BP_FALSE FALSE
//extern TERM bp_get_call_arg(int i, int arity);
#define bp_get_call_arg( i, arity) YAP_A(i)
//extern int bp_is_atom(TERM t)
#define bp_is_atom(t) YAP_IsAtomTerm(t)
//extern int bp_is_integer(TERM t)
#define bp_is_integer(t) YAP_IsIntTerm(t)
//extern int bp_is_float(TERM t)
#define bp_is_float(t) YAP_IsFloatTerm(t)
//extern int bp_is_nil(TERM t)
#define bp_is_nil(t) YAP_IsTermNil(t)
//extern int bp_is_list(TERM t)
#define bp_is_list(t) YAP_IsPairTerm(t)
//extern int bp_is_structure(TERM t)
#define bp_is_structure(t) YAP_IsApplTerm(t)
//extern int bp_is_compound(TERM t)
#define bp_is_compound(t) YAP_IsCompoundTerm(t)
//extern int bp_is_unifiable(TERM t1, Term t2)
#define bp_is_unifiable(t1, t2) YAP_unifiable(t1, t2)
//extern int bp_is_identical(TERM t1, Term t2)
#define bp_is_identical(t1, t2) YAP_ExactlyEqual(t1, t2)
// int bp_get_integer(TERM t)
#define bp_get_integer(t) YAP_IntOfTerm(t)
// double bp_get_float(TERM t)
#define bp_get_float(t) YAP_FloatOfTerm(t)
// char *bp_get_name(TERM t)
inline static const char *
bp_get_name(TERM t)
{
if (YAP_IsAtomTerm(t)) {
return YAP_AtomName(YAP_AtomOfTerm(t));
}
if (YAP_IsApplTerm(t)) {
return YAP_AtomName(YAP_NameOfFunctor(YAP_FunctorOfTerm(t)));
}
// exception = illegal_arguments;
return NULL;
}
// char *bp_get_name(TERM t)
static inline int
bp_get_arity(TERM t)
{
if (YAP_IsAtomTerm(t)) {
return 0;
}
if (YAP_IsApplTerm(t)) {
return (int)YAP_ArityOfFunctor(YAP_FunctorOfTerm(t));
}
// exception = illegal_arguments;
return 0;
}
//extern int bp_unify(TERM t1, TERM t2)
#define bp_unify(t1, t2) YAP_Unify(t1, t2)
//TERM bp_get_arg(int i, TERM t)
#define bp_get_arg(i, t) YAP_ArgOfTerm(i, t)
//TERM bp_get_car(Term t)
#define bp_get_car(t) YAP_HeadOfTerm(t)
//TERM bp_get_cdr(Term t)
#define bp_get_cdr(t) YAP_TailOfTerm(t)
// void bp_write(TERM t)
#define bp_write(t) YAP_WriteTerm(t, NULL, 0)
// TERM bp_build_var()
#define bp_build_var(t) YAP_MkVarTerm()
// TERM bp_build_integer(int i)
#define bp_build_integer(i) YAP_MkIntTerm(i)
// TERM bp_build_float(double f)
#define bp_build_float(f) YAP_MkFloatTerm(f)
// TERM bp_build_atom(char *name)
#define bp_build_atom(name) YAP_MkAtomTerm(YAP_LookupAtom((name)))
// TERM bp_build_nil()
#define bp_build_nil() YAP_TermNil()
// TERM bp_build_list()
#define bp_build_list() YAP_MkNewPairTerm()
// TERM bp_build_structure(char *name, int arity)
#define bp_build_structure(name, arity) YAP_MkNewApplTerm(YAP_MkFunctor(YAP_LookupAtom(name),arity), arity)
// TERM bp_insert_pred(char *name, int arity, int (*func)())
#define bp_insert_pred(name, arity, func) YAP_UserCPredicate(name, func, arity)
// int bp_call_string(char *goal)
extern inline int
bp_call_string(const char *goal) {
return YAP_RunGoal(YAP_ReadBuffer(goal, NULL));
}
// int bp_call_term(TERM goal)
extern inline int
bp_call_term(TERM t) {
return YAP_RunGoal(t);
}
#define TOAM_NOTSET 0L
#define curr_out stdout
#define BP_ERROR (-1)
#define INTERRUPT 0x2L
#define exception YAP_BPROLOG_exception
#define curr_toam_status YAP_BPROLOG_curr_toam_status
extern YAP_Term YAP_BPROLOG_curr_toam_status;
extern YAP_Int YAP_BPROLOG_exception;
// TERM bp_next_solution()
extern inline int bp_next_solution(void)
{
if (curr_toam_status) {
TERM goal = curr_toam_status;
curr_toam_status = TOAM_NOTSET;
return YAP_RunGoal(goal);
}
return YAP_RestartGoal();
}
// void bp_mount_query_string(char *goal)
#define bp_mount_query_string(goal) (curr_toam_status = YAP_ReadBuffer(goal, NULL))
// void bp_mount_query_term(TERM goal)
extern inline int
bp_mount_query_term(TERM goal)
{
curr_toam_status = goal;
return TRUE;
}
#endif /* BPROLOG_H */

399
library/dialect/bprolog/foreach.pl Normal file
View File

@ -0,0 +1,399 @@
% File : foreach.pl
% Author : Neng-Fa Zhou
% Updated: June 2009, updated Dec. 2009, updated Sep. 2010
% Purpose: an interpreter of foreach/2-10 and list comprehension
/************************************************************************/
:- yap_flag(unknown,error).
:- ensure_loaded(actionrules).
:- op(560,xfy,[..,to,downto]).
:- op(700,xfx,[subset,notin,in,@=]).
:- use_module(library(lists)).
/*
test:-
L=[1,2,3],foreach(I in L, writeln(I)),fail.
test:-
foreach(I in 1..10,format("~d ",I)),fail.
test:-
foreach(I in 1..2..10,format("~d ",I)),fail. % step = 2
test:-
foreach(I in 10.. -1.. 1,format("~d ",I)),fail. % step = -1
test:-
foreach((A,N) in ([a,b],1..2),writeln(A=N)),fail.
test:-
L=[1,2,3],foreach(I in L, ac(S,0), S^1 is S^0+I),writeln(S),fail.
test:-
T=f(1,2,3),functor(T,_,N),foreach(I in 1..N,ac(S,0),(S^1 is S^0+T[I])),writeln(S),fail.
test:-
L=[1,2,3],foreach(I in L, ac1(C,[]), C^0=[I|C^1]),writeln(C),fail.
test:-
foreach(I in [1,2], J in [a,b], ac(L,[]),L^1=[(I,J)|L^0]),writeln(L),fail.
test:-
foreach(I in [1,2], J in [a,b], ac1(L,[]),L^0=[(I,J)|L^1]),writeln(L),fail.
test:-
foreach(T in ([a,b],1..2),writeln(T)),fail.
test:-
foreach(F in 1.0..0.2..1.5,format("~1f ",F)),fail.
test:-
L @= [I : I in 1..10],writeln(L),fail.
test:-
L @= [I : I in 1..2..10],writeln(L),fail.
test:-
L @= [I : I in 10..-1..1],writeln(L),fail.
test:-
L @=[X : X in 1..5],writeln(L),fail.
test:-
L @= [1 : X in 1..5],writeln(L),fail.
test:-
L @= [Y : X in 1..5],writeln(L),fail.
test:-
L @= [Y : X in 1..5,[Y]],writeln(L),fail.
test:-
L @=[(A,I): (A,I) in ([a,b],1..2)],writeln(L),fail.
test:-
L @= [Y : X in [1,2,3], [Y], Y is -X],writeln(L),fail.
test:-
L @=[(A,I): A in [a,b], I in 1..2],writeln(L),fail.
test:-
L @=[(A,I): (A,I) in ([a,b],1..2)],writeln(L),fail.
test.
*/
Lhs @= Rhs,
Rhs=[(T:I)|Is],
I=(_ in _) => % list comprehension
'$change_list_comprehension_to_foreach'(T,I,Is,CallForeach,L),
call(CallForeach),
L @= Lhs.
Lhs @= Rhs,
Lhs=[(T:I)|Is],
I=(_ in _) => % list comprehension
'$change_list_comprehension_to_foreach'(T,I,Is,CallForeach,L),
call(CallForeach),
L @= Rhs.
A^Indexes @= Exp => % array access
'$aget'(A,Indexes,T),
Exp @= T.
Exp @= A^Indexes => % array access
'$aget'(A,Indexes,T),
Exp @= T.
Lhs @= Rhs => Lhs=Rhs.
'$change_list_comprehension_to_foreach'(T,I,Is,CallForeach,L):-
'$retrieve_list_comp_lvars_goal'(Is,LocalVars1,Goal1,Is1),
(nonvar(T),T=_^_-> % array access
LocalVars=[TempVar|LocalVars1],
(Goal1==true->
Goal=(TempVar@=T,L^0=[TempVar|L^1])
;
Goal=(Goal1->(TempVar@=T,L^0=[TempVar|L^1]);L^0=L^1)
)
;
LocalVars=LocalVars1,
(Goal1==true->
Goal=(L^0=[T|L^1])
;
Goal=(Goal1->L^0=[T|L^1];L^0=L^1)
)
),
append(Is1,[LocalVars,ac1(L,[]),Goal],Is2),
CallForeach=..[foreach,I|Is2].
'$retrieve_list_comp_lvars_goal'([],LocalVars,Goal,Is) =>
LocalVars=[],Goal=true,Is=[].
'$retrieve_list_comp_lvars_goal'([E|Es],LocalVars,Goal,Is),E = (_ in _) =>
Is=[E|IsR],
'$retrieve_list_comp_lvars_goal'(Es,LocalVars,Goal,IsR).
'$retrieve_list_comp_lvars_goal'([LVars,G],LocalVars,Goal,Is),LVars=[] =>
Is=[],LocalVars=LVars,G=Goal.
'$retrieve_list_comp_lvars_goal'([LVars,G],LocalVars,Goal,Is),LVars=[_|_] =>
Is=[],LocalVars=LVars,G=Goal.
'$retrieve_list_comp_lvars_goal'([LVars],LocalVars,Goal,Is),LVars=[_|_] =>
Is=[],LocalVars=LVars,Goal=true.
'$retrieve_list_comp_lvars_goal'([LVars],LocalVars,Goal,Is),LVars=[] =>
Is=[],LocalVars=LVars,Goal=true.
'$retrieve_list_comp_lvars_goal'([G],LocalVars,Goal,Is) =>
Is=[],LocalVars=[],G=Goal.
'$retrieve_list_comp_lvars_goal'(Args,_LocalVars,_Goal,_Is) =>
throw(illegal_arguments(list_comprehension(Args))).
foreach(A1,A2,A3,A4,A5,A6,A7,A8,A9,A10):-
foreach_aux((A1,A2,A3,A4,A5,A6,A7),A8,A9,A10).
foreach(A1,A2,A3,A4,A5,A6,A7,A8,A9):-
foreach_aux((A1,A2,A3,A4,A5,A6),A7,A8,A9).
foreach(A1,A2,A3,A4,A5,A6,A7,A8):-
foreach_aux((A1,A2,A3,A4,A5),A6,A7,A8).
foreach(A1,A2,A3,A4,A5,A6,A7):-
foreach_aux((A1,A2,A3,A4),A5,A6,A7).
foreach(A1,A2,A3,A4,A5,A6):-
foreach_aux((A1,A2,A3),A4,A5,A6).
foreach(A1,A2,A3,A4,A5):-
foreach_aux((A1,A2),A3,A4,A5).
foreach(A1,A2,A3,A4):-
foreach_aux(A1,A2,A3,A4).
foreach_aux(A1,A2,A3,A4):-
(A2=(_ in _); A2=(_,_)),!, % iterator
foreach_aux((A1,A2),A3,A4).
foreach_aux(A1,A2,A3,A4):-
foreach_check_accumulators(A3),!,
interp_foreach_with_acs(A1,A2,A3,A4).
foreach_aux(A1,A2,A3,A4):-
foreach_check_accumulators(A2),!,
interp_foreach_with_acs(A1,A3,A2,A4).
foreach_aux(A1,A2,A3,A4):-
throw(illegal_arguments(foreach(A1,A2,A3,A4))).
foreach(A1,A2,A3):-
foreach_aux(A1,A2,A3).
foreach_aux(A1,A2,A3):-
(A2=(_ in _); A2=(_,_)),!,
interp_foreach((A1,A2),true,[],A3,[],[],_).
foreach_aux(A1,A2,A3):-
foreach_check_accumulators(A2),!,
interp_foreach_with_acs(A1,[],A2,A3).
foreach_aux(A1,A2,A3):-
foreach_check_lvars(A2),!,
interp_foreach(A1,true,A2,A3,[],[],_).
foreach(Iterators,Goal):-
interp_foreach(Iterators,true,[],Goal,[],[],_).
interp_foreach_with_acs(Iterators,LVars,Accumulators,Goal):-
init_accumulators(Accumulators,ACs0),!,
interp_foreach(Iterators,true,LVars,Goal,[],ACs0,ACs),
fin_accumulators(Accumulators,ACs0,ACs).
interp_foreach_with_acs(Iterators,LVars,Accumulators,Goal):-
throw(illegal_arguments(foreach(Iterators,LVars,Accumulators,Goal))).
interp_foreach((I,Is),IsRest,LVars,Goal,Map,ACs0,ACs):-!,
(IsRest==true->IsRest1=Is;IsRest1=(Is,IsRest)),
interp_foreach(I,IsRest1,LVars,Goal,Map,ACs0,ACs).
interp_foreach(Pattern in D,IsRest,LVars,Goal,Map,ACs0,ACs):-
interp_foreach_term_instance(D,D1,Map),
(var(D1)->handle_exception(instantiation_error,foreach);true),
interp_foreach_in(Pattern,D1,IsRest,LVars,Goal,Map,ACs0,ACs).
interp_foreach(true,true,LVars,Goal,Map,ACs0,ACs):-!,
foreach_copy_accumulators(ACs0,ACs),
interp_foreach_term_instance(Goal,Goal1,LVars,Map,_,ACs0,ACs),
call(Goal1).
interp_foreach(true,Is,LVars,Goal,Map,ACs0,ACs):-
interp_foreach(Is,true,LVars,Goal,Map,ACs0,ACs).
interp_foreach_in(Var,(L..Step..U),IsRest,LVars,Goal,Map,ACs0,ACs) =>
(var(Var)->true;throw(wrong_loop_variable(Var))),
(foreach_lookup_map(Var,_,Map)->throw(duplicate_loop_variable(Var));true),
L1 is L,
U1 is U,
Step1 is Step,
foreach_range(Var,L1,U1,Step1,IsRest,LVars,Goal,Map,ACs0,ACs).
interp_foreach_in(Var,L..U,IsRest,LVars,Goal,Map,ACs0,ACs) =>
(var(Var)->true;throw(wrong_loop_variable(Var))),
(foreach_lookup_map(Var,_,Map)->throw(duplicate_loop_variable(Var));true),
L1 is L,
U1 is U,
foreach_range(Var,L1,U1,1,IsRest,LVars,Goal,Map,ACs0,ACs).
interp_foreach_in(_,[],IsRest,LVars,Goal,Map,ACs0,ACs) =>
ACs=ACs0.
interp_foreach_in(E,D,IsRest,LVars,Goal,Map,ACs0,ACs):-true :::
term_variables(E,EVars),
(member(Var,EVars),foreach_lookup_map(Var,_,Map),!,throw(duplicate_loop_variable(Var));true),
foreach_pattern_in(E,D,IsRest,LVars,Goal,Map,ACs0,ACs).
foreach_range(_Var,L,U,Step,_IsRest,_LVars,_Goal,_Map,ACs0,ACs),Step>0,L>U =>
ACs0=ACs.
foreach_range(_Var,L,U,Step,_IsRest,_LVars,_Goal,_Map,ACs0,ACs),Step<0,L<U =>
ACs0=ACs.
foreach_range(Var,L,U,Step,IsRest,LVars,Goal,Map,ACs0,ACs) =>
interp_foreach(IsRest,true,LVars,Goal,[(Var,L)|Map],ACs0,ACs1),
L1 is L+Step,
foreach_range(Var,L1,U,Step,IsRest,LVars,Goal,Map,ACs1,ACs).
foreach_pattern_in(_Pattern,D,_IsRest,_LVars,_Goal,_Map,_ACs0,_ACs),var(D) =>
handle_exception(instantiation_error,foreach).
foreach_pattern_in(Pattern,D,IsRest,LVars,Goal,Map,ACs0,ACs),D=[_|_] =>
foreach_pattern_in_list(Pattern,D,IsRest,LVars,Goal,Map,ACs0,ACs).
foreach_pattern_in(Pattern,D,IsRest,LVars,Goal,Map,ACs0,ACs) =>
foreach_simu_collection_to_tuples(D,Tuples),
foreach_pattern_in_list(Pattern,Tuples,IsRest,LVars,Goal,Map,ACs0,ACs).
foreach_pattern_in_list(_Pattern,Lst,_IsRest,_LVars,_Goal,_Map,_ACs0,_ACs),var(Lst) =>
handle_exception(instantiation_error,foreach).
foreach_pattern_in_list(_Pattern,[],_IsRest,_LVars,_Goal,_Map,ACs0,ACs) =>
ACs0=ACs.
foreach_pattern_in_list(Pattern,[E|Es],IsRest,LVars,Goal,Map,ACs0,ACs) =>
(foreach_update_map(Pattern,E,Map,Map1)->
interp_foreach(IsRest,true,LVars,Goal,Map1,ACs0,ACs1)
;
ACs0=ACs1),
foreach_pattern_in_list(Pattern,Es,IsRest,LVars,Goal,Map,ACs1,ACs).
foreach_pattern_in_list(_Pattern,Lst,_IsRest,_LVars,_Goal,_Map,_ACs0,_ACs):-true :::
handle_exception(type_error(list,Lst),foreach).
foreach_update_map(Var,E,Map0,Map):-var(Var),!,Map=[(Var,E)|Map0].
foreach_update_map(Pattern,E,Map0,Map):-atomic(Pattern),!,E==Pattern,Map=Map0.
foreach_update_map(Pattern,E,Map0,Map):-nonvar(E),
functor(Pattern,F,N),
functor(E,F,N),
foreach_update_map(Pattern,E,Map0,Map,1,N).
foreach_update_map(_Pattern,_E,Map0,Map,I,N):-I>N,!,Map=Map0.
foreach_update_map(Pattern,E,Map0,Map,I,N):-
arg(I,Pattern,Ti),
arg(I,E,Ei),
foreach_update_map(Ti,Ei,Map0,Map1),
I1 is I+1,
foreach_update_map(Pattern,E,Map1,Map,I1,N).
interp_foreach_term_instance(Term,Term1,Map):-
interp_foreach_term_instance(Term,Term1,[],Map,_,[],[]).
% Replace loop variables with their values; rename local variables;
% replace inputs and outputs in recurrences: A^0 is input and A^1 is output.
interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,_ACs0,_ACs):-var(Term),!,
(foreach_lookup_map(Term,NTerm,Map)->NMap=Map;
membchk(Term,LVars)->NMap=[(Term,NTerm)|Map];
NTerm=Term,NMap=Map).
interp_foreach_term_instance(Term,NTerm,_LVars,Map,NMap,_ACs0,_ACs):-atomic(Term),!,
NTerm=Term,NMap=Map.
interp_foreach_term_instance(Term^Tail,NTerm,_LVars,Map,NMap,ACs0,_ACs):-
var(Term),Tail==0,
foreach_lookup_map(Term,NTerm,ACs0),!,
NMap=Map.
interp_foreach_term_instance(Term^Tail,NTerm,_LVars,Map,NMap,_ACs0,ACs):-
var(Term),Tail==1,
foreach_lookup_map(Term,NTerm,ACs),!,
NMap=Map.
interp_foreach_term_instance([E|Es],Lst,LVars,Map,NMap,ACs0,ACs):-!,
Lst=[E1|Es1],
interp_foreach_term_instance(E,E1,LVars,Map,Map1,ACs0,ACs),
interp_foreach_term_instance(Es,Es1,LVars,Map1,NMap,ACs0,ACs).
interp_foreach_term_instance(Term,NTerm,_LVars,Map,NMap,_ACs0,_ACs):-
is_array(Term),!,
NTerm=Term,NMap=Map.
interp_foreach_term_instance(Term,NTerm,_LVars,Map,NMap,_ACs0,_ACs):-
is_hashtable(Term),!,
NTerm=Term,NMap=Map.
interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,ACs0,ACs):-
functor(Term,F,N),
functor(NTerm,F,N),
interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,1,N,ACs0,ACs).
interp_foreach_term_instance(_Term,_NTerm,_LVars,Map,NMap,I,N,_,_):-I>N,!,
NMap=Map.
interp_foreach_term_instance(Term,NTerm,LVars,Map,NMap,I,N,ACs0,ACs):-
arg(I,Term,A),
arg(I,NTerm,NA),
interp_foreach_term_instance(A,NA,LVars,Map,Map1,ACs0,ACs),
I1 is I+1,
interp_foreach_term_instance(Term,NTerm,LVars,Map1,NMap,I1,N,ACs0,ACs).
init_accumulators(ac1(Name,_),ACs):-!, ACs=[(Name,_)].
init_accumulators(ac(Name,Init),ACs):-!, ACs=[(Name,Init)].
init_accumulators(Accumulators,ACs):-Accumulators=[_|_],
init_accumulator_lst(Accumulators,ACs).
init_accumulator_lst([],ACs):-!,ACs=[].
init_accumulator_lst([ac1(Name,_)|Accumulators],ACs):-!,
ACs=[(Name,_)|ACsR],
init_accumulator_lst(Accumulators,ACsR).
init_accumulator_lst([ac(Name,Init)|Accumulators],ACs):-
ACs=[(Name,Init)|ACsR],
init_accumulator_lst(Accumulators,ACsR).
fin_accumulators(ac1(Name,Fin),[(_,Init)],[(_,Val)]):-!,
Name=Init,Fin=Val.
fin_accumulators(ac(Name,_),_,[(_,Val)]):-!, Name=Val.
fin_accumulators(Accumulators,ACs0,ACs):-Accumulators=[_|_],
fin_accumulator_lst(Accumulators,ACs0,ACs).
fin_accumulator_lst([],_,_).
fin_accumulator_lst([ac1(Name,Fin)|Accumulators],[(_,Init)|ACs0],[(_,Val)|ACs]):-!,
Fin=Val,
Name=Init,
fin_accumulator_lst(Accumulators,ACs0,ACs).
fin_accumulator_lst([ac(Name,_)|Accumulators],[_|ACs0],[(_,Val)|ACs]):-
Name=Val,
fin_accumulator_lst(Accumulators,ACs0,ACs).
foreach_copy_accumulators([],ACs):-!, ACs=[].
foreach_copy_accumulators([(Name,_)|ACs0],ACs):-
ACs=[(Name,_)|ACs1],
foreach_copy_accumulators(ACs0,ACs1).
foreach_check_lvars([]):-true ::: true.
foreach_check_lvars([X|Xs]):- var(X) ::: foreach_check_lvars(Xs).
foreach_check_lvars(Xs):-true :::
throw(illegal_local_variables(Xs)).
foreach_check_accumulators(ac1(_,_)):-!.
foreach_check_accumulators(ac(_,_)):-!.
foreach_check_accumulators(Accumulators):-Accumulators=[_|_],
foreach_check_accumulator_lst(Accumulators).
foreach_check_accumulator_lst([]).
foreach_check_accumulator_lst([X|_]):-var(X),!,fail.
foreach_check_accumulator_lst([ac(_,_)|L]):-!,
foreach_check_accumulator_lst(L).
foreach_check_accumulator_lst([ac1(_,_)|L]):-
foreach_check_accumulator_lst(L).
foreach_lookup_map(Term,NTerm,[(Term1,NTerm1)|_]):-Term==Term1,!,
NTerm=NTerm1.
foreach_lookup_map(Term,NTerm,[_|Map]):-
foreach_lookup_map(Term,NTerm,Map).
foreach_simu_collection_to_tuples((C1,C2,C3),Tuples) ?=>
foreach_collection_to_lst(C1,L1),
foreach_collection_to_lst(C2,L2),
foreach_collection_to_lst(C3,L3),!,
(foreach_simu_collection_to_tuples3(L1,L2,L3,Tuples)->true;
handle_exception(wrong_collection_in_foreach,(C1,C2,C3))).
foreach_simu_collection_to_tuples((C1,C2),Tuples) ?=>
foreach_collection_to_lst(C1,L1),
foreach_collection_to_lst(C2,L2),!,
(foreach_simu_collection_to_tuples2(L1,L2,Tuples)->true;
handle_exception(wrong_collection_in_foreach,(C1,C2))).
foreach_simu_collection_to_tuples(CTuple,_) =>
handle_exception(wrong_collection_in_foreach,CTuple).
foreach_collection_to_lst([],L) => L=[].
foreach_collection_to_lst(C,L),C=[_|_] => L=C.
foreach_collection_to_lst((B1..Step..B2),L) =>
NB1 is B1,
NB2 is B2,
NStep is Step,
foreach_eval_range(NB1,NB2,NStep,L).
foreach_collection_to_lst((B1..B2),L) =>
NB1 is B1,
NB2 is B2,
foreach_eval_range(NB1,NB2,1,L).
foreach_collection_to_lst(CTuple,L),CTuple=(_,_) =>
foreach_simu_collection_to_tuples(CTuple,L).
foreach_collection_to_lst(Collection,_L) =>
handle_exception(wrong_collection_in_foreach,Collection).
foreach_eval_range(B1,B2,Step,L),Step>0,B1>B2 => L=[].
foreach_eval_range(B1,B2,Step,L),Step<0,B1<B2 => L=[].
foreach_eval_range(B1,B2,Step,L) => L=[B1|LR],
NB1 is B1+Step,
foreach_eval_range(NB1,B2,Step,LR).
foreach_simu_collection_to_tuples3([],[],[],Tuples) => Tuples=[].
foreach_simu_collection_to_tuples3([X1|L1],[X2|L2],[X3|L3],Tuples) =>
Tuples=[(X1,X2,X3)|TuplesR],
foreach_simu_collection_to_tuples3(L1,L2,L3,TuplesR).
foreach_simu_collection_to_tuples2([],[],Tuples) => Tuples=[].
foreach_simu_collection_to_tuples2([X1|L1],[X2|L2],Tuples) =>
Tuples=[(X1,X2)|TuplesR],
foreach_simu_collection_to_tuples2(L1,L2,TuplesR).

63
library/dialect/bprolog/hashtable.yap Normal file
View File

@ -0,0 +1,63 @@
%% -*- Prolog -*-
:- module(bphash, [new_hashtable/1,
new_hashtable/2,
is_hashtable/1,
hashtable_get/3,
hashtable_put/3,
hashtable_register/3,
hashtable_size/2,
hashtable_to_list/2,
hashtable_values_to_list/2,
hashtable_keys_to_list/2]).
:- use_module(library(bhash), [b_hash_new/2,
is_b_hash/1,
b_hash_lookup/3,
b_hash_insert/4,
b_hash_size/2,
b_hash_to_list/2,
b_hash_values_to_list/2,
b_hash_keys_to_list/2]).
new_hashtable(Hash) :-
b_hash_new(Hash, 7).
new_hashtable(Hash, Size) :-
b_hash_new(Hash, Size).
is_hashtable(Hash) :-
is_b_hash(Hash).
hashtable_get(Hash, Key, Value) :-
b_hash_lookup(Key, Value, Hash).
hashtable_put(Hash, Key, Value) :-
b_hash_insert(Hash, Key, Value, Hash).
hashtable_register(Hash, Key, Value) :-
b_hash_lookup(Key, Value0, Hash), !,
Value0 = Value.
hashtable_register(Hash, Key, Value) :-
b_hash_insert(Hash, Key, Value, Hash).
hashtable_size(Hash, Size) :-
b_hash_size(Hash, Size).
hashtable_to_list(Hash, List) :-
b_hash_to_list(Hash, List0),
keylist_to_bp(List0, List).
hashtable_keys_to_list(Hash, List) :-
b_hash_keys_to_list(Hash, List).
hashtable_values_to_list(Hash, List) :-
b_hash_values_to_list(Hash, List).
keylist_to_bp([], []).
keylist_to_bp((X-Y).List0, (X=Y).List) :-
keylist_to_bp(List0, List).

7
library/dialect/swi/fli/swi.c
View File

@ -931,7 +931,10 @@ X_API int PL_put_integer(term_t t, long n)
X_API int PL_put_int64(term_t t, int64_t n)
{
CACHE_REGS
#if USE_GMP
#if SIZEOF_INT_P==8
Yap_PutInSlot(t,MkIntegerTerm(n));
return TRUE;
#elif USE_GMP
char s[64];
MP_INT rop;
@ -1176,6 +1179,8 @@ X_API int PL_unify_int64(term_t t, int64_t n)
iterm = YAP_MkBigNumTerm((void *)&rop);
return YAP_Unify(Yap_GetFromSlot(t PASS_REGS),iterm);
#else
if ((long)n == n)
return PL_unify_integer(t, n);
fprintf(stderr,"Error in PL_unify_int64: please install GMP\n");
return FALSE;
#endif

4
library/terms.yap
View File

@ -38,9 +38,5 @@ term_hash(T,H) :-
subsumes_chk(X,Y) :-
\+ \+ subsumes(X,Y).
unifiable(X,Y,Z) :-
protected_unifiable(X,Y,Z), !.
unifiable(_,_,_) :- fail.

28
library/varnumbers.yap
View File

@ -31,30 +31,4 @@ max_var_numberl(I0,Ar,T,Max0,Max) :-
).
varnumbers(GT, VT) :-
max_var_number(GT,0,Max),
Max1 is Max+1,
functor(Vars,vars,Max1),
varnumbers(GT, Vars, VT).
varnumbers(V,_,V) :- var(V), !.
varnumbers('$VAR'(I),Vs,V) :- !,
I1 is I+1,
arg(I1,Vs,V).
varnumbers(S,Vs,NS) :-
functor(S,N,Ar),
functor(NS,N,Ar),
varnumbersl(0,Ar,Vs,S,NS).
varnumbersl(I0,Ar,Vs,S,NS) :-
(I0 =:= Ar ->
true
;
I is I0+1,
arg(I,S,A),
arg(I,NS,NA),
varnumbers(A,Vs,NA),
varnumbersl(I,Ar,Vs,S,NS)
).
unnumber_vars(GT, VT).

1
misc/ATOMS
View File

@ -155,6 +155,7 @@ A LOOP N "_LOOP_"
A LT N "<"
A LastExecuteWithin F "$last_execute_within"
A Leash F "$leash"
A Length F "length"
A List N "list"
A Live F "$live"
A LoadAnswers N "load_answers"

4
packages/udi/rtree_udi.c
View File

@ -12,7 +12,7 @@
#include "rtree_udi_i.h"
#include "rtree_udi.h"
static int YAP_IsNumberTerm (Term term, YAP_Float *n)
static int YAP_IsNumberTermToFloat (Term term, YAP_Float *n)
{
if (YAP_IsIntTerm (term) != FALSE)
{
@ -41,7 +41,7 @@ static rect_t RectOfTerm (Term term)
for (i = 0; YAP_IsPairTerm(term) && i < 4; i++)
{
tmp = YAP_HeadOfTerm (term);
if (!YAP_IsNumberTerm(tmp,&(rect.coords[i])))
if (!YAP_IsNumberTermToFloat(tmp,&(rect.coords[i])))
return (RectInit());
term = YAP_TailOfTerm (term);
}

4
pl/ground.yap
View File

@ -48,8 +48,6 @@ ground(Term) :-
ground(ArgN),
'$ground'(M, Term).
*/
numbervars(Term, M, N) :-
'$variables_in_term'(Term, [], L),
'$numbermarked_vars'(L, M, N).
@ -62,3 +60,5 @@ numbervars(Term, M, N) :-
M1 is M+1,
'$numbermarked_vars'(L, M1, N).
*/

11
pl/tabling.yap
View File

@ -111,6 +111,17 @@ table(Pred) :-
integer(PredArity),
functor(PredFunctor,PredName,PredArity), !,
'$set_table'(Mod,PredFunctor).
%MODE_DIRECTED_TABLING
'$do_table'(Mod,Pred) :-
Pred=.. L,
L = [X|XS],
%writeln(X),
%writeln(XS),
length(XS,Len),
functor(PredFunctor,X,Len), !,
%writeln('antes'),
'$c_table_mode_directed'(Mod,PredFunctor,XS).
%MODE_DIRECTED_TABLING
'$do_table'(Mod,Pred) :-
'$do_error'(type_error(callable,Mod:Pred),table(Mod:Pred)).