static Int qq_open(USES_REGS1) {
PRED_LD
Term t = Deref(ARG1);
if (!IsVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) =
FunctorDQuasiQuotation) {
void *ptr;
char *start;
size_t l int s;
Term t0, t1, t2;
if (IsPointerTerm((t0 = ArgOfTerm(1, t))) &&
IsPointerTerm((t1 = ArgOfTerm(2, t))) &&
IsIntegerTerm((t2 = ArgOfTerm(3, t)))) {
ptr = PointerOfTerm(t0);
start = PointerOfTerm(t1);
len = IntegerOfTerm(t2);
if ((s = Yap_open_buf_read_stream(start, len, ENC_UTF8, MEM_BUF_USER)) <
0)
return false;
return Yap_unify(ARG2, Yap_MkStream(s));
} else {
Yap_Error(TYPE_ERROR_READ_CONTEXT, t);
}
return FALSE;
}
}
/**
* Specify an alias to the stream. The alias <tt>Name</tt> must be an atom. The
* alias can be used instead of the stream descriptor for every operation
* concerning the stream.
*
* @param + _tname_ Name of Alias
* @param + _tstream_ stream identifier
*
* @return
*/
static Int add_alias_to_stream (USES_REGS1)
{
Term tname = Deref(ARG1);
Term tstream = Deref(ARG2);
Atom at;
Int sno;
if (IsVarTerm(tname)) {
Yap_Error(INSTANTIATION_ERROR, tname, "$add_alias_to_stream");
return (FALSE);
} else if (!IsAtomTerm (tname)) {
Yap_Error(TYPE_ERROR_ATOM, tname, "$add_alias_to_stream");
return (FALSE);
}
if (IsVarTerm(tstream)) {
Yap_Error(INSTANTIATION_ERROR, tstream, "$add_alias_to_stream");
return (FALSE);
} else if (!IsApplTerm (tstream) || FunctorOfTerm (tstream) != FunctorStream ||
!IsIntTerm(ArgOfTerm(1,tstream))) {
Yap_Error(DOMAIN_ERROR_STREAM_OR_ALIAS, tstream, "$add_alias_to_stream");
return (FALSE);
}
at = AtomOfTerm(tname);
sno = (int)IntOfTerm(ArgOfTerm(1,tstream));
if (Yap_AddAlias(at, sno))
return(TRUE);
/* we could not create the alias, time to close the stream */
Yap_CloseStream(sno);
Yap_Error(PERMISSION_ERROR_NEW_ALIAS_FOR_STREAM, tname, "open/3");
return (FALSE);
}
static bool bind_variable_names(Term t USES_REGS) {
while (!IsVarTerm(t) && IsPairTerm(t)) {
Term tl = HeadOfTerm(t);
Functor f;
Term tv, t2, t1;
if (!IsApplTerm(tl))
return FALSE;
if ((f = FunctorOfTerm(tl)) != FunctorEq) {
return FALSE;
}
t1 = ArgOfTerm(1, tl);
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "variable_names");
return false;
}
t2 = ArgOfTerm(2, tl);
tv = Yap_MkApplTerm(FunctorDollarVar, 1, &t1);
if (IsVarTerm(t2)) {
YapBind(VarOfTerm(t2), tv);
}
t = TailOfTerm(t);
}
return true;
}
static int
bind_varnames(term_t varnames ARG_LD)
{
CACHE_REGS
Term t = Yap_GetFromSlot(varnames);
while(!IsVarTerm(t) && IsPairTerm(t)) {
Term tl = HeadOfTerm(t);
Functor f;
Term tv, t2, t1;
if (!IsApplTerm(tl)) return FALSE;
if ((f = FunctorOfTerm(tl)) != FunctorEq) {
return FALSE;
}
t1 = ArgOfTerm(1, tl);
if (IsVarTerm(t1)) {
return PL_error(NULL, 0, "variable_names", ERR_INSTANTIATION, 0, t1);
}
t2 = ArgOfTerm(2, tl);
tv = Yap_MkApplTerm(LOCAL_FunctorVar, 1, &t1);
if (IsVarTerm(t2)) {
Bind_and_Trail(VarOfTerm(t2), tv);
}
t = TailOfTerm(t);
}
return TRUE;
}
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);
}
void Yap_PrintPredName(PredEntry *ap) {
CACHE_REGS
Term tmod = ap->ModuleOfPred;
if (!tmod)
tmod = TermProlog;
#if THREADS
Yap_DebugPlWrite(MkIntegerTerm(worker_id));
Yap_DebugPutc(stderr, ' ');
#endif
Yap_DebugPutc(stderr, '>');
Yap_DebugPutc(stderr, '\t');
Yap_DebugPlWrite(tmod);
Yap_DebugPutc(stderr, ':');
if (ap->ModuleOfPred == IDB_MODULE) {
Term t = Deref(ARG1);
if (IsAtomTerm(t)) {
Yap_DebugPlWrite(t);
} else if (IsIntegerTerm(t)) {
Yap_DebugPlWrite(t);
} else {
Functor f = FunctorOfTerm(t);
Atom At = NameOfFunctor(f);
Yap_DebugPlWrite(MkAtomTerm(At));
Yap_DebugPutc(stderr, '/');
Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
}
} else {
if (ap->ArityOfPE == 0) {
Atom At = (Atom)ap->FunctorOfPred;
Yap_DebugPlWrite(MkAtomTerm(At));
} else {
Functor f = ap->FunctorOfPred;
Atom At = NameOfFunctor(f);
Yap_DebugPlWrite(MkAtomTerm(At));
Yap_DebugPutc(stderr, '/');
Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
}
}
char s[1024];
if (ap->PredFlags & StandardPredFlag)
fprintf(stderr, "S");
if (ap->PredFlags & CPredFlag)
fprintf(stderr, "C");
if (ap->PredFlags & UserCPredFlag)
fprintf(stderr, "U");
if (ap->PredFlags & SyncPredFlag)
fprintf(stderr, "Y");
if (ap->PredFlags & LogUpdatePredFlag)
fprintf(stderr, "Y");
if (ap->PredFlags & HiddenPredFlag)
fprintf(stderr, "H");
sprintf(s, " %llx\n", ap->PredFlags);
Yap_DebugPuts(stderr, s);
}
const char *Yap_GetFileName(Term t USES_REGS) {
char *buf = Malloc(YAP_FILENAME_MAX + 1);
if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorSlash) {
snprintf(buf, YAP_FILENAME_MAX, "%s/%s", Yap_GetFileName(ArgOfTerm(1, t)),
Yap_GetFileName(ArgOfTerm(2, t)));
}
if (IsAtomTerm(t)) {
return RepAtom(AtomOfTerm(t))->StrOfAE;
}
if (IsStringTerm(t)) {
return StringOfTerm(t);
}
return Yap_TextTermToText(t PASS_REGS);
}
YAP_tag_t YAPTerm::tag() {
Term tt = gt();
if (IsVarTerm(tt)) {
CELL *pt = VarOfTerm(tt);
if (IsUnboundVar(pt)) {
CACHE_REGS
if (IsAttVar(pt))
return YAP_TAG_ATT;
return YAP_TAG_UNBOUND;
}
return YAP_TAG_REF;
}
if (IsPairTerm(tt))
return YAP_TAG_PAIR;
if (IsAtomOrIntTerm(tt)) {
if (IsAtomTerm(tt))
return YAP_TAG_ATOM;
return YAP_TAG_INT;
} else {
Functor f = FunctorOfTerm(tt);
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 = (big_blob_type)RepAppl(tt)[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;
}
}
void
Yap_PrintPredName( PredEntry *ap )
{
CACHE_REGS
Term tmod = ap->ModuleOfPred;
if (!tmod) tmod = TermProlog;
#if THREADS
Yap_DebugPlWrite(MkIntegerTerm(worker_id));
Yap_DebugPutc(LOCAL_c_error_stream,' ');
#endif
Yap_DebugPutc(LOCAL_c_error_stream,'>');
Yap_DebugPutc(LOCAL_c_error_stream,'\t');
Yap_DebugPlWrite(tmod);
Yap_DebugPutc(LOCAL_c_error_stream,':');
if (ap->ModuleOfPred == IDB_MODULE) {
Term t = Deref(ARG1);
if (IsAtomTerm(t)) {
Yap_DebugPlWrite(t);
} else if (IsIntegerTerm(t)) {
Yap_DebugPlWrite(t);
} else {
Functor f = FunctorOfTerm(t);
Atom At = NameOfFunctor(f);
Yap_DebugPlWrite(MkAtomTerm(At));
Yap_DebugPutc(LOCAL_c_error_stream,'/');
Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
}
} else {
if (ap->ArityOfPE == 0) {
Atom At = (Atom)ap->FunctorOfPred;
Yap_DebugPlWrite(MkAtomTerm(At));
} else {
Functor f = ap->FunctorOfPred;
Atom At = NameOfFunctor(f);
Yap_DebugPlWrite(MkAtomTerm(At));
Yap_DebugPutc(LOCAL_c_error_stream,'/');
Yap_DebugPlWrite(MkIntegerTerm(ArityOfFunctor(f)));
}
}
Yap_DebugPutc(LOCAL_c_error_stream,'\n');
}
static int unbind_variable_names(Term t USES_REGS) {
while (!IsVarTerm(t) && IsPairTerm(t)) {
Term tl = HeadOfTerm(t);
Functor f;
Term *tp2, t1;
if (!IsApplTerm(tl))
return FALSE;
if ((f = FunctorOfTerm(tl)) != FunctorEq) {
return FALSE;
}
t1 = ArgOfTerm(1, tl);
tp2 = RepAppl(tl) + 2;
while (*tp2 != t1) {
tp2 = (CELL *)*tp2;
}
RESET_VARIABLE(tp2);
t = TailOfTerm(t);
}
return TRUE;
}
Term YAPTerm::getArg(arity_t i) {
BACKUP_MACHINE_REGS();
Term tf = 0;
Term t0 = gt();
if (IsApplTerm(t0)) {
if (i > ArityOfFunctor(FunctorOfTerm(t0)))
throw YAPError(SOURCE(), DOMAIN_ERROR_OUT_OF_RANGE, t0, "t0.getArg()");
tf = (ArgOfTerm(i, t0));
} else if (IsPairTerm(t0)) {
if (i == 1)
tf = (HeadOfTerm(t0));
else if (i == 2)
tf = (TailOfTerm(t0));
else
throw YAPError(SOURCE(), DOMAIN_ERROR_OUT_OF_RANGE, t0, "t0.getArg()");
} else {
throw YAPError(SOURCE(), TYPE_ERROR_COMPOUND, t0, "t0.getArg()");
}
RECOVER_MACHINE_REGS();
return tf;
}
YAPPredicate::YAPPredicate(Term &t, Term &tmod, CELL *&ts, const char *pname) {
Term t0 = t;
ap = nullptr;
restart:
if (IsVarTerm(t)) {
throw YAPError(SOURCE(), INSTANTIATION_ERROR, t0, pname);
} else if (IsAtomTerm(t)) {
ap = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t), tmod));
ts = nullptr;
} else if (IsIntegerTerm(t) && tmod == IDB_MODULE) {
ts = nullptr;
ap = Yap_FindLUIntKey(IntegerOfTerm(t));
} else if (IsPairTerm(t)) {
t = Yap_MkApplTerm(FunctorCsult, 1, &t);
goto restart;
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
if (IsExtensionFunctor(fun)) {
throw YAPError(SOURCE(), TYPE_ERROR_CALLABLE,
Yap_TermToIndicator(t, tmod), pname);
}
if (fun == FunctorModule) {
tmod = ArgOfTerm(1, t);
if (IsVarTerm(tmod)) {
throw YAPError(SOURCE(), INSTANTIATION_ERROR, t0, pname);
}
if (!IsAtomTerm(tmod)) {
throw YAPError(SOURCE(), TYPE_ERROR_ATOM, t0, pname);
}
t = ArgOfTerm(2, t);
goto restart;
}
ap = RepPredProp(Yap_GetPredPropByFunc(fun, tmod));
ts = RepAppl(t) + 1;
} else {
throw YAPError(SOURCE(), TYPE_ERROR_CALLABLE, t0, pname);
}
}
inline static Int compare(Term t1, Term t2) /* compare terms t1 and t2 */
{
if (t1 == t2)
return 0;
if (IsVarTerm(t1)) {
if (IsVarTerm(t2))
return Signed(t1) - Signed(t2);
return -1;
} else if (IsVarTerm(t2)) {
/* get rid of variables */
return 1;
}
if (IsAtomOrIntTerm(t1)) {
if (IsAtomTerm(t1)) {
if (IsAtomTerm(t2))
return cmp_atoms(AtomOfTerm(t1), AtomOfTerm(t2));
if (IsPrimitiveTerm(t2))
return 1;
if (IsStringTerm(t2))
return 1;
return -1;
} else {
if (IsIntTerm(t2)) {
return IntOfTerm(t1) - IntOfTerm(t2);
}
if (IsApplTerm(t2)) {
Functor fun2 = FunctorOfTerm(t2);
switch ((CELL)fun2) {
case double_e:
return 1;
case long_int_e:
return IntOfTerm(t1) - LongIntOfTerm(t2);
#ifdef USE_GMP
case big_int_e:
return Yap_gmp_tcmp_int_big(IntOfTerm(t1), t2);
#endif
case db_ref_e:
return 1;
case string_e:
return -1;
}
}
return -1;
}
} else if (IsPairTerm(t1)) {
if (IsApplTerm(t2)) {
Functor f = FunctorOfTerm(t2);
if (IsExtensionFunctor(f))
return 1;
else {
if (f != FunctorDot)
return strcmp(".", RepAtom(NameOfFunctor(f))->StrOfAE);
else {
return compare_complex(RepPair(t1) - 1, RepPair(t1) + 1, RepAppl(t2));
}
}
}
if (IsPairTerm(t2)) {
return (
compare_complex(RepPair(t1) - 1, RepPair(t1) + 1, RepPair(t2) - 1));
} else
return 1;
} else {
/* compound term */
Functor fun1 = FunctorOfTerm(t1);
if (IsExtensionFunctor(fun1)) {
/* float, long, big, dbref */
switch ((CELL)fun1) {
case double_e: {
if (IsFloatTerm(t2))
return (rfloat(FloatOfTerm(t1) - FloatOfTerm(t2)));
if (IsRefTerm(t2))
return 1;
return -1;
}
case long_int_e: {
if (IsIntTerm(t2))
return LongIntOfTerm(t1) - IntOfTerm(t2);
if (IsFloatTerm(t2)) {
return 1;
}
if (IsLongIntTerm(t2))
return LongIntOfTerm(t1) - LongIntOfTerm(t2);
#ifdef USE_GMP
if (IsBigIntTerm(t2)) {
return Yap_gmp_tcmp_int_big(LongIntOfTerm(t1), t2);
}
#endif
if (IsRefTerm(t2))
return 1;
return -1;
}
#ifdef USE_GMP
case big_int_e: {
if (IsIntTerm(t2))
return Yap_gmp_tcmp_big_int(t1, IntOfTerm(t2));
if (IsFloatTerm(t2)) {
return 1;
}
if (IsLongIntTerm(t2))
return Yap_gmp_tcmp_big_int(t1, LongIntOfTerm(t2));
if (IsBigIntTerm(t2)) {
return Yap_gmp_tcmp_big_big(t1, t2);
}
if (IsRefTerm(t2))
return 1;
return -1;
}
#endif
case string_e: {
if (IsApplTerm(t2)) {
Functor fun2 = FunctorOfTerm(t2);
switch ((CELL)fun2) {
case double_e:
return 1;
case long_int_e:
return 1;
#ifdef USE_GMP
case big_int_e:
return 1;
#endif
case db_ref_e:
return 1;
case string_e:
return strcmp((char *)StringOfTerm(t1), (char *)StringOfTerm(t2));
}
return -1;
}
return -1;
}
case db_ref_e:
if (IsRefTerm(t2))
return Unsigned(RefOfTerm(t2)) - Unsigned(RefOfTerm(t1));
return -1;
}
}
if (!IsApplTerm(t2)) {
if (IsPairTerm(t2)) {
Int out;
Functor f = FunctorOfTerm(t1);
if (!(out = ArityOfFunctor(f)) - 2)
out = strcmp((char *)RepAtom(NameOfFunctor(f))->StrOfAE, ".");
return out;
}
return 1;
} else {
Functor fun2 = FunctorOfTerm(t2);
Int r;
if (IsExtensionFunctor(fun2)) {
return 1;
}
r = ArityOfFunctor(fun1) - ArityOfFunctor(fun2);
if (r)
return r;
r = cmp_atoms(NameOfFunctor(fun1), NameOfFunctor(fun2));
if (r)
return r;
else
return (compare_complex(RepAppl(t1), RepAppl(t1) + ArityOfFunctor(fun1),
RepAppl(t2)));
}
}
}
/* copy to a new list of terms */
static
int key_mergesort(CELL *pt, Int size, int my_p, Functor FuncDMinus)
{
if (size > 2) {
Int half_size = size / 2;
CELL *pt_left, *pt_right, *end_pt, *end_pt_left;
int left_p, right_p;
pt_right = pt + half_size*2;
left_p = my_p^1;
right_p = my_p;
if (!key_mergesort(pt, half_size, left_p, FuncDMinus))
return(FALSE);
if (!key_mergesort(pt_right, size-half_size, right_p, FuncDMinus))
return(FALSE);
/* now implement a simple merge routine */
/* pointer to after the end of the list */
end_pt = pt + 2*size;
/* pointer to the element after the last element to the left */
end_pt_left = pt+half_size*2;
/* where is left list */
pt_left = pt+left_p;
/* where is right list */
pt_right += right_p;
/* where is new list */
pt += my_p;
/* while there are elements in the left or right vector do compares */
while (pt_left < end_pt_left && pt_right < end_pt) {
/* if the element to the left is larger than the one to the right */
Term t0 = pt_left[0] , t1 = pt_right[0];
if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus)
return(FALSE);
t0 = ArgOfTerm(1,t0);
if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus)
return(FALSE);
t1 = ArgOfTerm(1,t1);
if (Yap_compare_terms(t0, t1) <= 0) {
/* copy the one to the left */
pt[0] = pt_left[0];
/* and avance the two pointers */
pt += 2;
pt_left += 2;
} else {
/* otherwise, copy the one to the right */
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
/* if any elements were left in the left vector just copy them */
while (pt_left < end_pt_left) {
pt[0] = pt_left[0];
pt += 2;
pt_left += 2;
}
/* if any elements were left in the right vector
and they are in the wrong place, just copy them */
if (my_p != right_p) {
while(pt_right < end_pt) {
pt[0] = pt_right[0];
pt += 2;
pt_right += 2;
}
}
} else {
if (size > 1) {
Term t0 = pt[0], t1 = pt[2];
if (IsVarTerm(t0) || !IsApplTerm(t0) || FunctorOfTerm(t0) != FuncDMinus)
return(FALSE);
t0 = ArgOfTerm(1,t0);
if (IsVarTerm(t1) || !IsApplTerm(t1) || FunctorOfTerm(t1) != FuncDMinus)
return(FALSE);
t1 = ArgOfTerm(1,t1);
if (Yap_compare_terms(t0,t1) > 0) {
CELL t = pt[2];
pt[2+my_p] = pt[0];
pt[my_p] = t;
} else if (my_p) {
pt[1] = pt[0];
pt[3] = pt[2];
}
} else {
if (my_p)
pt[1] = pt[0];
}
}
return(TRUE);
}
/*
* New user indexed predicate:
* the first argument is the term.
*/
static YAP_Int
p_new_udi( USES_REGS1 )
{
Term spec = Deref(ARG1);
PredEntry *p;
UdiInfo blk;
int info;
/* get the predicate from the spec, copied from cdmgr.c */
if (IsVarTerm(spec)) {
Yap_Error(INSTANTIATION_ERROR,spec,"new user index/1");
return FALSE;
} else if (!IsApplTerm(spec)) {
Yap_Error(TYPE_ERROR_COMPOUND,spec,"new user index/1");
return FALSE;
} else {
Functor fun = FunctorOfTerm(spec);
Term tmod = CurrentModule;
while (fun == FunctorModule) {
tmod = ArgOfTerm(1,spec);
if (IsVarTerm(tmod) ) {
Yap_Error(INSTANTIATION_ERROR, spec, "new user index/1");
return FALSE;
}
if (!IsAtomTerm(tmod) ) {
Yap_Error(TYPE_ERROR_ATOM, spec, "new user index/1");
return FALSE;
}
spec = ArgOfTerm(2, spec);
fun = FunctorOfTerm(spec);
}
p = RepPredProp(PredPropByFunc(fun, tmod));
}
if (!p)
return FALSE;
/* boring, boring, boring! */
if ((p->PredFlags
& (DynamicPredFlag|LogUpdatePredFlag|UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag))
|| (p->ModuleOfPred == PROLOG_MODULE)) {
Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, spec, "udi/2");
return FALSE;
}
if (p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|TabledPredFlag)) {
Yap_Error(PERMISSION_ERROR_ACCESS_PRIVATE_PROCEDURE, spec, "udi/2");
return FALSE;
}
/* TODO: remove AtomRTree from atom list */
/* this is the real work */
blk = (UdiInfo) Yap_AllocCodeSpace(sizeof(struct udi_info));
memset((void *) blk,0, sizeof(struct udi_info));
if (!blk) {
Yap_Error(OUT_OF_HEAP_ERROR, spec, "new user index/1");
return FALSE;
}
/*Init UdiInfo */
utarray_new(blk->args, &arg_icd);
utarray_new(blk->clauselist, &cl_icd);
blk->p = p;
/*Now Init args list*/
info = p_udi_args_init(spec, p->ArityOfPE, blk);
if (!info)
{
utarray_free(blk->args);
utarray_free(blk->clauselist);
Yap_FreeCodeSpace((char *) blk);
return FALSE;
}
/*Push into the hash*/
HASH_ADD_UdiInfo(UdiControlBlocks, p, blk);
p->PredFlags |= UDIPredFlag;
return TRUE;
}
static Int
p_socket_bind(USES_REGS1)
{
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
int sno;
Functor fun;
socket_info status;
int fd;
if ((sno = Yap_CheckSocketStream(t1, "socket_bind/2")) < 0) {
return (FALSE);
}
status = Yap_GetSocketStatus(sno);
fd = Yap_GetStreamFd(sno);
if (status != new_socket) {
/* ok, this should be an error, as you are trying to bind */
return(FALSE);
}
if (IsVarTerm(t2)) {
Yap_Error(INSTANTIATION_ERROR,t2,"socket_bind/2");
return(FALSE);
}
if (!IsApplTerm(t2)) {
Yap_Error(DOMAIN_ERROR_STREAM,t2,"socket_bind/2");
return(FALSE);
}
fun = FunctorOfTerm(t2);
#if HAVE_SYS_UN_H
if (fun == FunctorAfUnix || fun == FunctorAfLocal) {
struct sockaddr_un sock;
Term taddr = ArgOfTerm(1, t2);
char *s;
int len;
if (IsVarTerm(taddr)) {
Yap_Error(INSTANTIATION_ERROR,t2,"socket_bind/2");
return(FALSE);
}
if (!IsAtomTerm(taddr)) {
Yap_Error(TYPE_ERROR_ATOM,taddr,"socket_bind/2");
return(FALSE);
}
s = RepAtom(AtomOfTerm(taddr))->StrOfAE;
sock.sun_family = AF_UNIX;
if ((len = strlen(s)) > 107) /* hit me with a broomstick */ {
Yap_Error(DOMAIN_ERROR_STREAM,taddr,"socket_bind/2");
return(FALSE);
}
sock.sun_family=AF_UNIX;
strcpy(sock.sun_path,s);
if (bind(fd,
(struct sockaddr *)(&sock),
((size_t) (((struct sockaddr_un *) 0)->sun_path) + len))
< 0) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_bind/2 (bind: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_bind/2 (bind)");
#endif
return(FALSE);
}
Yap_UpdateSocketStream(sno, server_socket, af_unix);
return(TRUE);
} else
#endif
if (fun == FunctorAfInet) {
Term thost = ArgOfTerm(1, t2);
Term tport = ArgOfTerm(2, t2);
char *shost;
struct hostent *he;
struct sockaddr_in saddr;
Int port;
memset((void *)&saddr,(int) 0, sizeof(saddr));
if (IsVarTerm(thost)) {
saddr.sin_addr.s_addr = INADDR_ANY;
} else if (!IsAtomTerm(thost)) {
Yap_Error(TYPE_ERROR_ATOM,thost,"socket_bind/2");
return(FALSE);
} else {
shost = RepAtom(AtomOfTerm(thost))->StrOfAE;
if((he=gethostbyname(shost))==NULL) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_bind/2 (gethostbyname: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_bind/2 (gethostbyname)");
#endif
return(FALSE);
}
memcpy((void *)&saddr.sin_addr, (void *)he->h_addr_list[0], he->h_length);
}
if (IsVarTerm(tport)) {
port = 0;
} else {
port = IntOfTerm(tport);
}
saddr.sin_port = htons(port);
saddr.sin_family = AF_INET;
if(bind(fd,(struct sockaddr *)&saddr, sizeof(saddr))==-1) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_bind/2 (bind: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_bind/2 (bind)");
#endif
return(FALSE);
}
if (IsVarTerm(tport)) {
/* get the port number */
#if _WIN32 || defined(__MINGW32__)
int namelen;
#else
unsigned int namelen;
#endif
Term t;
if (getsockname(fd, (struct sockaddr *)&saddr, &namelen) < 0) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_bind/2 (getsockname: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_bind/2 (getsockname)");
#endif
return(FALSE);
}
t = MkIntTerm(ntohs(saddr.sin_port));
Yap_unify(ArgOfTermCell(2, t2),t);
}
Yap_UpdateSocketStream(sno, server_socket, af_inet);
return(TRUE);
} else
return(FALSE);
}
static Int
p_socket_connect(USES_REGS1)
{
Term t1 = Deref(ARG1);
Term t2 = Deref(ARG2);
Functor fun;
int sno;
socket_info status;
int fd;
int flag;
Term out;
if ((sno = Yap_CheckSocketStream(t1, "socket_connect/3")) < 0) {
return (FALSE);
}
if (IsVarTerm(t2)) {
Yap_Error(INSTANTIATION_ERROR,t2,"socket_connect/3");
return(FALSE);
}
if (!IsApplTerm(t2)) {
Yap_Error(DOMAIN_ERROR_STREAM,t2,"socket_connect/3");
return(FALSE);
}
fun = FunctorOfTerm(t2);
fd = Yap_GetStreamFd(sno);
status = Yap_GetSocketStatus(sno);
if (status != new_socket) {
/* ok, this should be an error, as you are trying to bind */
return(FALSE);
}
#if HAVE_SYS_UN_H
if (fun == FunctorAfUnix) {
struct sockaddr_un sock;
Term taddr = ArgOfTerm(1, t2);
char *s;
int len;
if (IsVarTerm(taddr)) {
Yap_Error(INSTANTIATION_ERROR,t2,"socket_connect/3");
return(FALSE);
}
if (!IsAtomTerm(taddr)) {
Yap_Error(TYPE_ERROR_ATOM,taddr,"socket_connect/3");
return(FALSE);
}
s = RepAtom(AtomOfTerm(taddr))->StrOfAE;
sock.sun_family = AF_UNIX;
if ((len = strlen(s)) > 107) /* beat me with a broomstick */ {
Yap_Error(DOMAIN_ERROR_STREAM,taddr,"socket_connect/3");
return(FALSE);
}
sock.sun_family=AF_UNIX;
strcpy(sock.sun_path,s);
if ((flag = connect(fd,
(struct sockaddr *)(&sock),
((size_t) (((struct sockaddr_un *) 0)->sun_path) + len)))
< 0) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (connect: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (connect)");
#endif
return(FALSE);
}
Yap_UpdateSocketStream(sno, client_socket, af_unix);
} else
#endif
if (fun == FunctorAfInet) {
Term thost = ArgOfTerm(1, t2);
Term tport = ArgOfTerm(2, t2);
char *shost;
struct hostent *he;
struct sockaddr_in saddr;
unsigned short int port;
memset((void *)&saddr,(int) 0, sizeof(saddr));
if (IsVarTerm(thost)) {
Yap_Error(INSTANTIATION_ERROR,thost,"socket_connect/3");
return(FALSE);
} else if (!IsAtomTerm(thost)) {
Yap_Error(TYPE_ERROR_ATOM,thost,"socket_connect/3");
return(FALSE);
} else {
shost = RepAtom(AtomOfTerm(thost))->StrOfAE;
if((he=gethostbyname(shost))==NULL) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (gethostbyname: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (gethostbyname)");
#endif
return(FALSE);
}
memcpy((void *)&saddr.sin_addr, (void *)he->h_addr_list[0], he->h_length);
}
if (IsVarTerm(tport)) {
Yap_Error(INSTANTIATION_ERROR,tport,"socket_connect/3");
return(FALSE);
} else if (!IsIntegerTerm(tport)) {
Yap_Error(TYPE_ERROR_INTEGER,tport,"socket_connect/3");
return(FALSE);
} else {
port = (unsigned short int)IntegerOfTerm(tport);
}
saddr.sin_port = htons(port);
saddr.sin_family = AF_INET;
#if ENABLE_SO_LINGER
{
struct linger ling; /* For making sockets linger. */
/* disabled: I see why no reason why we should throw things away by default!! */
ling.l_onoff = 1;
ling.l_linger = 0;
if (setsockopt(fd, SOL_SOCKET, SO_LINGER, (void *) &ling,
sizeof(ling)) < 0) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (setsockopt_linger: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (setsockopt_linger)");
#endif
return FALSE;
}
}
#endif
{
int one = 1; /* code by David MW Powers */
if (setsockopt(fd, SOL_SOCKET, SO_BROADCAST, (void *)&one, sizeof(one))) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (setsockopt_broadcast: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (setsockopt_broadcast)");
#endif
return FALSE;
}
}
flag = connect(fd,(struct sockaddr *)&saddr, sizeof(saddr));
if(flag<0) {
#if HAVE_STRERROR
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (connect: %s)", strerror(socket_errno));
#else
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"socket_connect/3 (connect)");
#endif
return FALSE;
}
Yap_UpdateSocketStream(sno, client_socket, af_inet);
} else
return(FALSE);
out = t1;
return(Yap_unify(out,ARG3));
}
/******
new user indexed predicate;
the type right now is just rtrees, but in the future we'll have more.
the second argument is the term.
******/
static Int
p_new_udi( USES_REGS1 )
{
Term spec = Deref(ARG2), udi_type = Deref(ARG1);
PredEntry *p;
UdiControlBlock cmd;
Atom udi_t;
void *info;
/* fprintf(stderr,"new pred babe\n");*/
/* get the predicate from the spec, copied from cdmgr.c */
if (IsVarTerm(spec)) {
Yap_Error(INSTANTIATION_ERROR,spec,"new user index/1");
return FALSE;
} else if (!IsApplTerm(spec)) {
Yap_Error(TYPE_ERROR_COMPOUND,spec,"new user index/1");
return FALSE;
} else {
Functor fun = FunctorOfTerm(spec);
Term tmod = CurrentModule;
while (fun == FunctorModule) {
tmod = ArgOfTerm(1,spec);
if (IsVarTerm(tmod) ) {
Yap_Error(INSTANTIATION_ERROR, spec, "new user index/1");
return FALSE;
}
if (!IsAtomTerm(tmod) ) {
Yap_Error(TYPE_ERROR_ATOM, spec, "new user index/1");
return FALSE;
}
spec = ArgOfTerm(2, spec);
fun = FunctorOfTerm(spec);
}
p = RepPredProp(PredPropByFunc(fun, tmod));
}
if (!p)
return FALSE;
/* boring, boring, boring! */
if ((p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) ||
(p->ModuleOfPred == PROLOG_MODULE)) {
Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, spec, "udi/2");
return FALSE;
}
if (p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|TabledPredFlag)) {
Yap_Error(PERMISSION_ERROR_ACCESS_PRIVATE_PROCEDURE, spec, "udi/2");
return FALSE;
}
/* just make sure we're looking at the right user type! */
if (IsVarTerm(udi_type)) {
Yap_Error(INSTANTIATION_ERROR,spec,"new user index/1");
return FALSE;
} else if (!IsAtomTerm(udi_type)) {
Yap_Error(TYPE_ERROR_ATOM,spec,"new user index/1");
return FALSE;
}
udi_t = AtomOfTerm(udi_type);
if (udi_t == AtomRTree) {
cmd = &RtreeCmd;
} else {
Yap_Error(TYPE_ERROR_ATOM,spec,"new user index/1");
return FALSE;
}
/* this is the real work */
info = cmd->init(spec, (void *)p, p->ArityOfPE);
if (!info)
return FALSE;
/* add to table */
if (!add_udi_block(info, p, cmd)) {
Yap_Error(OUT_OF_HEAP_ERROR, spec, "new user index/1");
return FALSE;
}
p->PredFlags |= UDIPredFlag;
return TRUE;
}
xarg *
Yap_ArgListToVector (Term listl, const param_t *def, int n)
{
CACHE_REGS
xarg *a = calloc( n , sizeof(xarg) );
if (IsApplTerm(listl) && FunctorOfTerm(listl) == FunctorModule)
listl = ArgOfTerm(2,listl);
if (!IsPairTerm(listl) && listl != TermNil) {
if (IsVarTerm(listl) ) {
free( a );
LOCAL_Error_TYPE = INSTANTIATION_ERROR;
LOCAL_Error_Term = listl;
return NULL;
}
if (IsAtomTerm(listl) ) {
xarg *na = matchKey( AtomOfTerm(listl), a, n, def);
if (!na) {
free( a );
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
LOCAL_Error_Term = listl;
return NULL;
}
} else if (IsApplTerm(listl)) {
Functor f = FunctorOfTerm( listl );
if (IsExtensionFunctor(f)) {
free( a );
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
LOCAL_Error_Term = listl;
return NULL;
}
arity_t arity = ArityOfFunctor( f );
if (arity != 1) {
free( a );
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
LOCAL_Error_Term = listl;
return NULL;
}
xarg *na = matchKey( NameOfFunctor( f ), a, n, def);
if (!na) {
free( a );
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
LOCAL_Error_Term = listl;
return NULL;
}
} else {
free( a );
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
LOCAL_Error_Term = listl;
return NULL;
}
listl = MkPairTerm( listl, TermNil );
}
while (IsPairTerm(listl)) {
Term hd = HeadOfTerm( listl );
listl = TailOfTerm( listl );
if (IsVarTerm(hd) || IsVarTerm(listl)) {
LOCAL_Error_TYPE = INSTANTIATION_ERROR;
if (IsVarTerm(hd)) {
LOCAL_Error_Term = hd;
} else {
LOCAL_Error_Term = listl;
}
free( a );
return NULL;
}
if (IsAtomTerm(hd)) {
xarg *na = matchKey( AtomOfTerm( hd ), a, n, def);
if (!na)
return NULL;
na->used = true;
na->tvalue = TermNil;
continue;
} else if (IsApplTerm( hd )) {
Functor f = FunctorOfTerm( hd );
if (IsExtensionFunctor(f)) {
LOCAL_Error_TYPE = TYPE_ERROR_PARAMETER;
LOCAL_Error_Term = hd;
free( a );
return NULL;
}
arity_t arity = ArityOfFunctor( f );
if (arity != 1) {
LOCAL_Error_TYPE = DOMAIN_ERROR_OUT_OF_RANGE;
LOCAL_Error_Term = hd;
free( a );
return NULL;
}
xarg *na = matchKey( NameOfFunctor( f ), a, n, def);
if (!na) {
free( a );
return NULL;
}
na->used = 1;
na->tvalue = ArgOfTerm(1, hd);
} else {
LOCAL_Error_TYPE = TYPE_ERROR_PARAMETER;
free( a );
return NULL;
}
}
if (IsVarTerm(listl)) {
LOCAL_Error_TYPE = INSTANTIATION_ERROR;
LOCAL_Error_Term = listl;
free( a );
return NULL;
} else if (listl != TermNil) {
LOCAL_Error_TYPE = TYPE_ERROR_LIST;
LOCAL_Error_Term = listl;
free( a );
return NULL;
}
return a;
}
static Int
p_setarg( USES_REGS1 )
{
CELL ti = Deref(ARG1), ts = Deref(ARG2), t3 = Deref(ARG3);
Int i;
if (IsVarTerm(t3) &&
VarOfTerm(t3) > H &&VarOfTerm(t3) < ASP) {
/* local variable */
Term tn = MkVarTerm();
Bind_Local(VarOfTerm(t3), tn);
t3 = tn;
}
if (IsVarTerm(ti)) {
Yap_Error(INSTANTIATION_ERROR,ti,"setarg/3");
return FALSE;
} else {
if (IsIntTerm(ti))
i = IntOfTerm(ti);
else {
Term te = Yap_Eval(ti);
if (IsIntegerTerm(te)) {
i = IntegerOfTerm(te);
} else {
Yap_Error(TYPE_ERROR_INTEGER,ti,"setarg/3");
return FALSE;
}
}
}
if (IsVarTerm(ts)) {
Yap_Error(INSTANTIATION_ERROR,ts,"setarg/3");
} else if(IsApplTerm(ts)) {
CELL *pt;
if (IsExtensionFunctor(FunctorOfTerm(ts))) {
Yap_Error(TYPE_ERROR_COMPOUND,ts,"setarg/3");
return FALSE;
}
if (i < 1 || i > (Int)ArityOfFunctor(FunctorOfTerm(ts))) {
if (i<0)
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
return FALSE;
if (i==0)
Yap_Error(DOMAIN_ERROR_NOT_ZERO,ts,"setarg/3");
return FALSE;
}
pt = RepAppl(ts)+i;
/* the evil deed is to be done now */
MaBind(pt, t3);
} else if(IsPairTerm(ts)) {
CELL *pt;
if (i < 1 || i > 2) {
if (i<0)
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,ts,"setarg/3");
return FALSE;
}
pt = RepPair(ts)+i-1;
/* the evil deed is to be done now */
MaBind(pt, t3);
} else {
Yap_Error(TYPE_ERROR_COMPOUND,ts,"setarg/3");
return FALSE;
}
return TRUE;
}
static Int compare_complex(register CELL *pt0, register CELL *pt0_end,
register CELL *pt1) {
CACHE_REGS
register CELL **to_visit = (CELL **)HR;
register Int out = 0;
loop:
while (pt0 < pt0_end) {
register CELL d0, d1;
++pt0;
++pt1;
d0 = Derefa(pt0);
d1 = Derefa(pt1);
if (IsVarTerm(d0)) {
if (IsVarTerm(d1)) {
out = Signed(d0) - Signed(d1);
if (out)
goto done;
} else {
out = -1;
goto done;
}
} else if (IsVarTerm(d1)) {
out = 1;
goto done;
} else {
if (d0 == d1)
continue;
else if (IsAtomTerm(d0)) {
if (IsAtomTerm(d1))
out = cmp_atoms(AtomOfTerm(d0), AtomOfTerm(d1));
else if (IsPrimitiveTerm(d1))
out = 1;
else
out = -1;
/* I know out must be != 0 */
goto done;
} else if (IsIntTerm(d0)) {
if (IsIntTerm(d1))
out = IntOfTerm(d0) - IntOfTerm(d1);
else if (IsFloatTerm(d1)) {
out = 1;
} else if (IsLongIntTerm(d1)) {
out = IntOfTerm(d0) - LongIntOfTerm(d1);
#ifdef USE_GMP
} else if (IsBigIntTerm(d1)) {
out = Yap_gmp_tcmp_int_big(IntOfTerm(d0), d1);
#endif
} else if (IsRefTerm(d1))
out = 1;
else
out = -1;
if (out != 0)
goto done;
} else if (IsFloatTerm(d0)) {
if (IsFloatTerm(d1)) {
out = rfloat(FloatOfTerm(d0) - FloatOfTerm(d1));
} else if (IsRefTerm(d1)) {
out = 1;
} else {
out = -1;
}
if (out != 0)
goto done;
} else if (IsStringTerm(d0)) {
if (IsStringTerm(d1)) {
out = strcmp((char *)StringOfTerm(d0), (char *)StringOfTerm(d1));
} else if (IsIntTerm(d1))
out = 1;
else if (IsFloatTerm(d1)) {
out = 1;
} else if (IsLongIntTerm(d1)) {
out = 1;
#ifdef USE_GMP
} else if (IsBigIntTerm(d1)) {
out = 1;
#endif
} else if (IsRefTerm(d1)) {
out = 1;
} else {
out = -1;
}
if (out != 0)
goto done;
} else if (IsLongIntTerm(d0)) {
if (IsIntTerm(d1))
out = LongIntOfTerm(d0) - IntOfTerm(d1);
else if (IsFloatTerm(d1)) {
out = 1;
} else if (IsLongIntTerm(d1)) {
out = LongIntOfTerm(d0) - LongIntOfTerm(d1);
#ifdef USE_GMP
} else if (IsBigIntTerm(d1)) {
out = Yap_gmp_tcmp_int_big(LongIntOfTerm(d0), d1);
#endif
} else if (IsRefTerm(d1)) {
out = 1;
} else {
out = -1;
}
if (out != 0)
goto done;
}
#ifdef USE_GMP
else if (IsBigIntTerm(d0)) {
if (IsIntTerm(d1)) {
out = Yap_gmp_tcmp_big_int(d0, IntOfTerm(d1));
} else if (IsFloatTerm(d1)) {
out = 1;
} else if (IsLongIntTerm(d1)) {
out = Yap_gmp_tcmp_big_int(d0, LongIntOfTerm(d1));
} else if (IsBigIntTerm(d1)) {
out = Yap_gmp_tcmp_big_big(d0, d1);
} else if (IsRefTerm(d1))
out = 1;
else
out = -1;
if (out != 0)
goto done;
}
#endif
else if (IsPairTerm(d0)) {
if (!IsPairTerm(d1)) {
if (IsApplTerm(d1)) {
Functor f = FunctorOfTerm(d1);
if (IsExtensionFunctor(f))
out = 1;
else if (!(out = 2 - ArityOfFunctor(f)))
out = strcmp(".", (char *)RepAtom(NameOfFunctor(f))->StrOfAE);
} else
out = 1;
goto done;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
to_visit += 4;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
pt1 = RepPair(d1) - 1;
continue;
} else if (IsRefTerm(d0)) {
if (IsRefTerm(d1))
out = Unsigned(RefOfTerm(d1)) - Unsigned(RefOfTerm(d0));
else
out = -1;
goto done;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2, *ap3;
if (!IsApplTerm(d1)) {
out = 1;
goto done;
} else {
/* store the terms to visit */
Functor f2;
ap2 = RepAppl(d0);
ap3 = RepAppl(d1);
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
out = 1;
goto done;
}
f2 = (Functor)(*ap3);
if (IsExtensionFunctor(f2)) {
out = -1;
goto done;
}
/* compare functors */
if (f != (Functor)*ap3) {
if (!(out = ArityOfFunctor(f) - ArityOfFunctor(f2)))
out = cmp_atoms(NameOfFunctor(f), NameOfFunctor(f2));
goto done;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit[3] = (CELL *)*pt0;
to_visit += 4;
*pt0 = d1;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = pt1;
to_visit += 3;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
pt1 = ap3;
continue;
}
}
}
}
/* Do we still have compound terms to visit */
if (to_visit > (CELL **)HR) {
#ifdef RATIONAL_TREES
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
#else
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
#endif
goto loop;
}
done:
/* failure */
#ifdef RATIONAL_TREES
while (to_visit > (CELL **)HR) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
pt1 = to_visit[2];
*pt0 = (CELL)to_visit[3];
}
#endif
return (out);
}
YAPFunctor YAPApplTerm::getFunctor() {
return YAPFunctor( FunctorOfTerm( gt( )) );
}
static Int p_table( USES_REGS1 ) {
Term mod, t, list;
PredEntry *pe;
Atom at;
int arity;
tab_ent_ptr tab_ent;
#ifdef MODE_DIRECTED_TABLING
int* mode_directed = NULL;
#endif /* MODE_DIRECTED_TABLING */
mod = Deref(ARG1);
t = Deref(ARG2);
list = Deref(ARG3);
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 (list != TermNil) { /* non-empty list */
#ifndef MODE_DIRECTED_TABLING
Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "invalid tabling declaration for %s/%d (mode directed tabling not enabled)", AtomName(at), arity);
return(FALSE);
#else
/*************************************************************************************
The mode operator declaration is reordered as follows:
1. arguments with mode 'index' (any number)
2. arguments with mode 'min' and 'max' (any number, following the original order)
3. arguments with mode 'all' (any number)
4. arguments with mode 'sum' or 'last' (only one of the two is allowed)
5. arguments with mode 'first' (any number)
*************************************************************************************/
int pos_index = 0;
int pos_min_max = 0;
int pos_all = 0;
int pos_sum_last = 0;
int pos_first = 0;
int i;
int *aux_mode_directed;
aux_mode_directed = malloc(arity * sizeof(int));
for (i = 0; i < arity; i++) {
int mode = IntOfTerm(HeadOfTerm(list));
if (mode == MODE_DIRECTED_INDEX)
pos_index++;
else if (mode == MODE_DIRECTED_MIN || mode == MODE_DIRECTED_MAX)
pos_min_max++;
else if (mode == MODE_DIRECTED_ALL)
pos_all++;
else if (mode == MODE_DIRECTED_SUM || mode == MODE_DIRECTED_LAST) {
if (pos_sum_last) {
free(aux_mode_directed);
Yap_Error(INTERNAL_COMPILER_ERROR, TermNil, "invalid tabling declaration for %s/%d (more than one argument with modes 'sum' and/or 'last')", AtomName(at), arity);
return(FALSE);
} else
pos_sum_last = 1;
}
aux_mode_directed[i] = mode;
list = TailOfTerm(list);
}
pos_first = pos_index + pos_min_max + pos_all + pos_sum_last;
pos_sum_last = pos_index + pos_min_max + pos_all;
pos_all = pos_index + pos_min_max;
pos_min_max = pos_index;
pos_index = 0;
ALLOC_BLOCK(mode_directed, arity * sizeof(int), int);
for (i = 0; i < arity; i++) {
int aux_pos = 0;
if (aux_mode_directed[i] == MODE_DIRECTED_INDEX)
aux_pos = pos_index++;
else if (aux_mode_directed[i] == MODE_DIRECTED_MIN || aux_mode_directed[i] == MODE_DIRECTED_MAX)
aux_pos = pos_min_max++;
else if (aux_mode_directed[i] == MODE_DIRECTED_ALL)
aux_pos = pos_all++;
else if (aux_mode_directed[i] == MODE_DIRECTED_SUM || aux_mode_directed[i] == MODE_DIRECTED_LAST)
aux_pos = pos_sum_last++;
else if(aux_mode_directed[i] == MODE_DIRECTED_FIRST)
aux_pos = pos_first++;
mode_directed[aux_pos] = MODE_DIRECTED_SET(i, aux_mode_directed[i]);
}
free(aux_mode_directed);
#endif /* MODE_DIRECTED_TABLING */
}
static Term
Eval(Term t USES_REGS)
{
if (IsVarTerm(t)) {
return Yap_ArithError(INSTANTIATION_ERROR,t,"in arithmetic");
} else if (IsNumTerm(t)) {
return t;
} else if (IsAtomTerm(t)) {
ExpEntry *p;
Atom name = AtomOfTerm(t);
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, 0)))) {
/* error */
Term ti[2];
/* error */
ti[0] = t;
ti[1] = MkIntTerm(0);
t = Yap_MkApplTerm(FunctorSlash, 2, ti);
return Yap_ArithError(TYPE_ERROR_EVALUABLE, t,
"atom %s in arithmetic expression",
RepAtom(name)->StrOfAE);
}
return Yap_eval_atom(p->FOfEE);
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
if (fun == FunctorString) {
const char *s = StringOfTerm(t);
if (s[1] == '\0')
return MkIntegerTerm(s[0]);
return Yap_ArithError(TYPE_ERROR_EVALUABLE, t,
"string in arithmetic expression");
} else if ((Atom)fun == AtomFoundVar) {
return Yap_ArithError(TYPE_ERROR_EVALUABLE, TermNil,
"cyclic term in arithmetic expression");
} else {
Int n = ArityOfFunctor(fun);
Atom name = NameOfFunctor(fun);
ExpEntry *p;
Term t1, t2;
if (EndOfPAEntr(p = RepExpProp(Yap_GetExpProp(name, n)))) {
Term ti[2];
/* error */
ti[0] = t;
ti[1] = MkIntegerTerm(n);
t = Yap_MkApplTerm(FunctorSlash, 2, ti);
return Yap_ArithError(TYPE_ERROR_EVALUABLE, t,
"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) {
*RepAppl(t) = (CELL)fun;
return FALSE;
}
if (n == 1) {
*RepAppl(t) = (CELL)fun;
return Yap_eval_unary(p->FOfEE, t1);
}
t2 = Eval(ArgOfTerm(2,t) PASS_REGS);
*RepAppl(t) = (CELL)fun;
if (t2 == 0L)
return FALSE;
return Yap_eval_binary(p->FOfEE,t1,t2);
}
} /* else if (IsPairTerm(t)) */ {
if (TailOfTerm(t) != TermNil) {
return Yap_ArithError(TYPE_ERROR_EVALUABLE, t,
"string must contain a single character to be evaluated as an arithmetic expression");
}
return Eval(HeadOfTerm(t) PASS_REGS);
}
}
/// Yap_ArgList2ToVector is much the same as before,
/// but assumes parameters also have something called a
/// scope
xarg *
Yap_ArgList2ToVector (Term listl, const param2_t *def, int n)
{
CACHE_REGS
xarg *a = calloc( n , sizeof(xarg) );
if (!IsPairTerm(listl) && listl != TermNil) {
if (IsVarTerm(listl) ) {
return failed( INSTANTIATION_ERROR, listl, a);
}
if (IsAtomTerm(listl) ) {
xarg *na = matchKey2( AtomOfTerm(listl), a, n, def);
if (!na) {
return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, listl, a);
}
}
if (IsApplTerm(listl)) {
Functor f = FunctorOfTerm( listl );
if (IsExtensionFunctor(f)) {
return failed( TYPE_ERROR_PARAMETER, listl, a);
}
arity_t arity = ArityOfFunctor( f );
if (arity != 1) {
return failed( TYPE_ERROR_LIST, listl, a);
}
xarg *na = matchKey2( NameOfFunctor( f ), a, n, def);
if (!na) {
return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, listl, a);
}
} else {
return failed( TYPE_ERROR_LIST, listl, a);
}
listl = MkPairTerm( listl, TermNil );
}
while (IsPairTerm(listl)) {
Term hd = HeadOfTerm( listl );
if (IsVarTerm(hd)) {
return failed( INSTANTIATION_ERROR, hd, a);
}
if (IsAtomTerm(hd)) {
xarg *na = matchKey2( AtomOfTerm( hd ), a, n, def);
if (!na) {
return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a);
}
na->used = true;
na->tvalue = TermNil;
continue;
} else if (IsApplTerm( hd )) {
Functor f = FunctorOfTerm( hd );
if (IsExtensionFunctor(f)) {
return failed( TYPE_ERROR_PARAMETER, hd, a);
}
arity_t arity = ArityOfFunctor( f );
if (arity != 1) {
return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a);
}
xarg *na = matchKey2( NameOfFunctor( f ), a, n, def);
if (na) {
na->used = 1;
na->tvalue = ArgOfTerm(1, hd);
} else {
return failed( DOMAIN_ERROR_GENERIC_ARGUMENT, hd, a);
}
} else {
return failed( INSTANTIATION_ERROR, hd, a);
}
listl = TailOfTerm(listl);
}
if (IsVarTerm(listl)) {
return failed( INSTANTIATION_ERROR, listl, a);
}
if (TermNil != listl) {
return failed( TYPE_ERROR_LIST, listl, a);
}
return a;
}