From 8c8a7c02eea310aea54ae6d4be3bb9fa3a48179f Mon Sep 17 00:00:00 2001 From: vsc Date: Mon, 11 Nov 2002 17:40:31 +0000 Subject: [PATCH] move inline callables to their own space. git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@676 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/inlines.c | 787 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 787 insertions(+) create mode 100755 C/inlines.c diff --git a/C/inlines.c b/C/inlines.c new file mode 100755 index 000000000..af51c1aea --- /dev/null +++ b/C/inlines.c @@ -0,0 +1,787 @@ +/************************************************************************* +* * +* YAP Prolog * +* * +* Yap Prolog was developed at NCCUP - Universidade do Porto * +* * +* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * +* * +************************************************************************** +* * +* File: inlines.c * +* Last rev: * +* mods: * +* comments: C-version for inline code used in meta-calls * +* * +*************************************************************************/ + +#define IN_INLINES_C 1 + +#include "absmi.h" + +STATIC_PROTO(Int p_atom, (void)); +STATIC_PROTO(Int p_atomic, (void)); +STATIC_PROTO(Int p_integer, (void)); +STATIC_PROTO(Int p_nonvar, (void)); +STATIC_PROTO(Int p_number, (void)); +STATIC_PROTO(Int p_var, (void)); +STATIC_PROTO(Int p_db_ref, (void)); +STATIC_PROTO(Int p_primitive, (void)); +STATIC_PROTO(Int p_compound, (void)); +STATIC_PROTO(Int p_float, (void)); +STATIC_PROTO(Int p_equal, (void)); +STATIC_PROTO(Int p_dif, (void)); +STATIC_PROTO(Int p_eq, (void)); +STATIC_PROTO(Int p_arg, (void)); +STATIC_PROTO(Int p_functor, (void)); + + +static Int +p_atom(void) +{ /* atom(?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, atom_unk); + atom_nvar: + if (IsAtomTerm(d0)) { + return(TRUE); + } + else { + return(FALSE); + } + + BEGP(pt0); + deref_body(d0, pt0, atom_unk, atom_nvar); + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_atomic(void) +{ /* atomic(?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, atomic_unk); + atomic_nvar: + if (IsAtomicTerm(d0)) { + return(TRUE); + } + else { + return(FALSE); + } + + BEGP(pt0); + deref_body(d0, pt0, atomic_unk, atomic_nvar); + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_integer(void) +{ /* integer(?,?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, integer_unk); + integer_nvar: + if (IsIntegerTerm(d0)) { + return(TRUE); + } + else { + return(FALSE); + } + + BEGP(pt0); + deref_body(d0, pt0, integer_unk, integer_nvar); + ENDP(pt0); + return(FALSE); + ENDD(d0); +} + +static Int +p_number(void) +{ /* number(?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, number_unk); + number_nvar: + if (IsNumTerm(d0)) { + return(TRUE); + } + else { + return(FALSE); + } + + BEGP(pt0); + deref_body(d0, pt0, number_unk, number_nvar); + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_db_ref(void) +{ /* db_reference(?,?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, db_ref_unk); + db_ref_nvar: + if (IsDBRefTerm(d0)) { + return(TRUE); + } + else { + return(FALSE); + } + + BEGP(pt0); + deref_body(d0, pt0, db_ref_unk, db_ref_nvar); + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_primitive(void) +{ /* primitive(?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, primitive_unk); + primitive_nvar: + if (IsPrimitiveTerm(d0)) { + return(TRUE); + } + else { + return(FALSE); + } + + BEGP(pt0); + deref_body(d0, pt0, primitive_unk, primitive_nvar); + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_float(void) +{ /* float(?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, float_unk); + float_nvar: + if (IsFloatTerm(d0)) { + return(TRUE); + } + else { + return(FALSE); + } + + BEGP(pt0); + deref_body(d0, pt0, float_unk, float_nvar); + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_compound(void) +{ /* compound(?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, compound_unk); + compound_nvar: + if (IsPairTerm(d0)) { + return(TRUE); + } + else if (IsApplTerm(d0)) { + if (IsExtensionFunctor(FunctorOfTerm(d0))) { + return(FALSE); + } + return(TRUE); + } + else { + return(FALSE); + } + + BEGP(pt0); + deref_body(d0, pt0, compound_unk, compound_nvar); + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_nonvar(void) +{ /* nonvar(?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, nonvar_unk); + nonvar_nvar: + return(TRUE); + + BEGP(pt0); + deref_body(d0, pt0, nonvar_unk, nonvar_nvar); + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_var(void) +{ /* var(?) */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, var_unk); + var_nvar: + return(FALSE); + + BEGP(pt0); + deref_body(d0, pt0, var_unk, var_nvar); + return(TRUE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_equal(void) +{ /* ?=? */ + return(_YAP_IUnify(ARG1, ARG2)); +} + +static Int +p_eq(void) +{ /* ? == ? */ + BEGD(d0); + d0 = ARG1; + deref_head(d0, p_eq_unk1); + p_eq_nvar1: + /* first argument is bound */ + BEGD(d1); + d1 = ARG2; + deref_head(d1, p_eq_nvar1_unk2); + p_eq_nvar1_nvar2: + /* both arguments are bound */ + if (d0 == d1) { + return(TRUE); + } + if (IsPairTerm(d0)) { + if (!IsPairTerm(d1)) { + return(FALSE); + } + return(iequ_complex(RepPair(d0)-1, RepPair(d0)+1,RepPair(d1)-1)); + } + if (IsApplTerm(d0)) { + Functor f0 = FunctorOfTerm(d0); + Functor f1; + if (!IsApplTerm(d1)) { + return(FALSE); + } + f1 = FunctorOfTerm(d1); + if (f0 != f1) { + return(FALSE); + } + if (IsExtensionFunctor(f0)) { + switch ((CELL)f0) { + case (CELL)FunctorDBRef: + return (d0 == d1); + case (CELL)FunctorLongInt: + return(LongIntOfTerm(d0) == LongIntOfTerm(d1)); +#ifdef USE_GMP + case (CELL)FunctorBigInt: + return (mpz_cmp(_YAP_BigIntOfTerm(d0), _YAP_BigIntOfTerm(d1)) == 0); +#endif + case (CELL)FunctorDouble: + return(FloatOfTerm(d0) == FloatOfTerm(d1)); + default: + return(FALSE); + } + } + return(iequ_complex(RepAppl(d0), RepAppl(d0)+ArityOfFunctor(f0), RepAppl(d1))); + } + return(FALSE); + + BEGP(pt0); + deref_body(d1, pt0, p_eq_nvar1_unk2, p_eq_nvar1_nvar2); + ENDP(pt0); + /* first argument is bound */ + /* second argument is unbound */ + /* I don't need to worry about co-routining because an + unbound variable may never be == to a constrained variable!! */ + return(FALSE); + ENDD(d1); + + BEGP(pt0); + deref_body(d0, pt0, p_eq_unk1, p_eq_nvar1); + BEGD(d1); + d1 = ARG2; + deref_head(d1, p_eq_var1_unk2); + p_eq_var1_nvar2: + /* I don't need to worry about co-routining because an + unbound variable may never be == to a constrained variable!! */ + return(FALSE); + + BEGP(pt1); + deref_body(d1, pt1, p_eq_var1_unk2, p_eq_var1_nvar2); + /* first argument is unbound */ + /* second argument is unbound */ + return(pt1 == pt0); + ENDP(pt1); + ENDD(d1); + ENDP(pt0); + + ENDD(d0); +} + +static Int +p_dif(void) +{ /* ? \= ? */ +#if SHADOW_HB + register CELL *HBREG = HB; +#endif + BEGD(d0); + BEGD(d1); + d0 = ARG1; + deref_head(d0, dif_unk1); + dif_nvar1: + /* first argument is bound */ + d1 = ARG2; + deref_head(d1, dif_nvar1_unk2); + dif_nvar1_nvar2: + /* both arguments are bound */ + if (d0 == d1) { + return(FALSE); + } + if (IsAtomOrIntTerm(d0) || IsAtomOrIntTerm(d1)) { + return(TRUE); + } + { +#ifdef COROUTINING + /* + * We may wake up goals during our attempt to unify the + * two terms. If we are adding to the tail of a list of + * woken goals that should be ok, but otherwise we need + * to restore WokenGoals to its previous value. + */ + CELL OldWokenGoals = _YAP_ReadTimedVar(WokenGoals); + +#endif + /* We will have to look inside compound terms */ + BEGP(pt0); + /* store the old value of TR for clearing bindings */ + pt0 = (CELL *)TR; + BEGCHO(pt1); + pt1 = B; + /* make B and HB point to H to guarantee all bindings will + * be trailed + */ + HBREG = H; + B = (choiceptr) H; + save_hb(); + if (_YAP_IUnify(d0, d1) == TRUE) { + /* restore B, no need to restore HB */ + B = pt1; + return(FALSE); + } + B = pt1; + /* restore B, and later HB */ + ENDCHO(pt1); + BEGP(pt1); + /* untrail all bindings made by _YAP_IUnify */ + while (TR != (tr_fr_ptr)pt0) { + pt1 = (CELL *) TrailTerm(--TR); + RESET_VARIABLE(pt1); + } + HBREG = B->cp_h; + ENDP(pt1); + } +#ifdef COROUTINING + /* now restore Woken Goals to its old value */ + _YAP_UpdateTimedVar(WokenGoals, OldWokenGoals); +#endif + return(TRUE); + ENDP(pt0); + + BEGP(pt0); + deref_body(d0, pt0, dif_unk1, dif_nvar1); + ENDP(pt0); + /* first argument is unbound */ + return(FALSE); + + BEGP(pt0); + deref_body(d1, pt0, dif_nvar1_unk2, dif_nvar1_nvar2); + ENDP(pt0); + /* second argument is unbound */ + return(FALSE); + ENDD(d1); + ENDD(d0); +} + +static Int +p_arg(void) +{ /* arg(?,?,?) */ +#if SHADOW_HB + register CELL *HBREG = HB; +#endif + BEGD(d0); + d0 = ARG1; + deref_head(d0, arg_arg1_unk); + arg_arg1_nvar: + /* ARG1 is ok! */ + if (IsIntTerm(d0)) + d0 = IntOfTerm(d0); + else if (IsLongIntTerm(d0)) { + d0 = LongIntOfTerm(d0); + } else { + _YAP_Error(TYPE_ERROR_INTEGER,d0,"arg 1 of arg/3"); + return(FALSE); + } + + /* d0 now got the argument we want */ + BEGD(d1); + d1 = ARG2; + deref_head(d1, arg_arg2_unk); + arg_arg2_nvar: + /* d1 now got the structure we want to fetch the argument + * from */ + if (IsApplTerm(d1)) { + BEGP(pt0); + pt0 = RepAppl(d1); + d1 = *pt0; + if (IsExtensionFunctor((Functor) d1)) { + return(FALSE); + } + save_hb(); + if ((Int)d0 <= 0 || + (Int)d0 > ArityOfFunctor((Functor) d1) || + _YAP_IUnify(pt0[d0], ARG3) == FALSE) { + /* don't complain here for Prolog compatibility + if ((Int)d0 <= 0) { + _YAP_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, + MkIntegerTerm(d0),"arg 1 of arg/3"); + } + */ + return(FALSE); + } + return(TRUE); + ENDP(pt0); + } + else if (IsPairTerm(d1)) { + BEGP(pt0); + pt0 = RepPair(d1); + if (d0 == 1) { + save_hb(); + if (_YAP_IUnify((CELL)pt0, ARG3) == FALSE) { + return(FALSE); + } + return(TRUE); + } + else if (d0 == 2) { + save_hb(); + if (_YAP_IUnify((CELL)(pt0+1), ARG3) == FALSE) { + return(FALSE); + } + return(TRUE); + } + else { + if ((Int)d0 < 0) + _YAP_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, + MkIntegerTerm(d0),"arg 1 of arg/3"); + return(FALSE); + } + ENDP(pt0); + } + else { + _YAP_Error(TYPE_ERROR_COMPOUND, d1, "arg 2 of arg/3"); + return(FALSE); + } + + BEGP(pt0); + deref_body(d1, pt0, arg_arg2_unk, arg_arg2_nvar); + _YAP_Error(INSTANTIATION_ERROR,(CELL)pt0,"arg 2 of arg/3");; + ENDP(pt0); + return(FALSE); + ENDD(d1); + + BEGP(pt0); + deref_body(d0, pt0, arg_arg1_unk, arg_arg1_nvar); + _YAP_Error(INSTANTIATION_ERROR,(CELL)pt0,"arg 1 of arg/3");; + ENDP(pt0); + return(FALSE); + ENDD(d0); + +} + +static Int +p_functor(void) /* functor(?,?,?) */ +{ +#if SHADOW_HB + register CELL *HBREG; +#endif + + restart: +#if SHADOW_HB + HBREG = HB; +#endif + BEGD(d0); + d0 = ARG1; + deref_head(d0, func_unk); + func_nvar: + /* A1 is bound */ + BEGD(d1); + if (IsApplTerm(d0)) { + d1 = *RepAppl(d0); + if (IsExtensionFunctor((Functor) d1)) { + if (d1 == (CELL)FunctorDouble) { + d1 = MkIntTerm(0); + } else if (d1 == (CELL)FunctorLongInt) { + d1 = MkIntTerm(0); + } else + return(FALSE); + } else { + d0 = MkAtomTerm(NameOfFunctor((Functor) d1)); + d1 = MkIntTerm(ArityOfFunctor((Functor) d1)); + } + } + else if (IsPairTerm(d0)) { + d0 = TermDot; + d1 = MkIntTerm(2); + } + else { + d1 = MkIntTerm(0); + } + /* d1 and d0 now have the two arguments */ + /* let's go and bind them */ + { + register CELL arity = d1; + + d1 = ARG2; + deref_head(d1, func_nvar_unk); + func_nvar_nvar: + /* A2 was bound */ + if (d0 != d1) { + return(FALSE); + } + /* have to buffer ENDP and label */ + d0 = arity; + goto func_bind_x3; + + BEGP(pt0); + deref_body(d1, pt0, func_nvar_unk, func_nvar_nvar); + /* A2 is a variable, go and bind it */ + BIND(pt0, d0, bind_func_nvar_var); +#ifdef COROUTINING + DO_TRAIL(pt0, d0); + if (pt0 < H0) _YAP_WakeUp(pt0); + bind_func_nvar_var: +#endif + /* have to buffer ENDP and label */ + d0 = arity; + ENDP(pt0); + /* now let's process A3 */ + + func_bind_x3: + d1 = ARG3; + deref_head(d1, func_nvar3_unk); + func_nvar3_nvar: + /* A3 was bound */ + if (d0 != d1) { + return(FALSE); + } + /* Done */ + return(TRUE); + + + BEGP(pt0); + deref_body(d1, pt0, func_nvar3_unk, func_nvar3_nvar); + /* A3 is a variable, go and bind it */ + BIND(pt0, d0, bind_func_nvar3_var); + /* Done */ +#ifdef COROUTINING + DO_TRAIL(pt0, d0); + if (pt0 < H0) _YAP_WakeUp(pt0); + bind_func_nvar3_var: +#endif + return(TRUE); + + ENDP(pt0); + + } + ENDD(d1); + + BEGP(pt0); + deref_body(d0, pt0, func_unk, func_nvar); + /* A1 is a variable */ + /* We have to build the structure */ + d0 = ARG2; + deref_head(d0, func_var_2unk); + func_var_2nvar: + /* we do, let's get the third argument */ + BEGD(d1); + d1 = ARG3; + deref_head(d1, func_var_3unk); + func_var_3nvar: + /* Uuuff, the second and third argument are bound */ + if (IsIntTerm(d1)) + d1 = IntOfTerm(d1); + else { + _YAP_Error(TYPE_ERROR_INTEGER,ARG3,"functor/3"); + return(FALSE); + } + if (!IsAtomicTerm(d0)) { + _YAP_Error(TYPE_ERROR_ATOMIC,d0,"functor/3"); + return(FALSE); + } + /* We made it!!!!! we got in d0 the name, in d1 the arity and + * in pt0 the variable to bind it to. */ + if (d0 == TermDot && d1 == 2) { + RESET_VARIABLE(H); + RESET_VARIABLE(H+1); + d0 = AbsPair(H); + H += 2; + } + else if ((Int)d1 > 0) { + /* now let's build a compound term */ + if (!IsAtomTerm(d0)) { + _YAP_Error(TYPE_ERROR_ATOM,d0,"functor/3"); + return(FALSE); + } + BEGP(pt1); + if (!IsAtomTerm(d0)) { + return(FALSE); + } + else + d0 = (CELL) _YAP_MkFunctor(AtomOfTerm(d0), (Int) d1); + pt1 = H; + *pt1++ = d0; + d0 = AbsAppl(H); + if (pt1+d1 > ENV - CreepFlag) { + if (!_YAP_gc(3, ENV, P)) { + _YAP_Error(OUT_OF_STACK_ERROR, TermNil, _YAP_ErrorMessage); + return(FALSE); + } + goto restart; + } + while (d1-- > 0) { + RESET_VARIABLE(pt1); + pt1++; + } + /* done building the term */ + H = pt1; + ENDP(pt1); + } else if ((Int)d1 < 0) { + _YAP_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,MkIntegerTerm(d1),"functor/3"); + return(FALSE); + } + /* else if arity is 0 just pass d0 through */ + /* Ding, ding, we made it */ + BIND(pt0, d0, bind_func_var_3nvar); +#ifdef COROUTINING + DO_TRAIL(pt0, d0); + if (pt0 < H0) _YAP_WakeUp(pt0); + bind_func_var_3nvar: +#endif + return(TRUE); + + + BEGP(pt1); + deref_body(d1, pt1, func_var_3unk, func_var_3nvar); + _YAP_Error(INSTANTIATION_ERROR,(CELL)pt1,"functor/3"); + ENDP(pt1); + /* Oops, third argument was unbound */ + return(FALSE); + ENDD(d1); + + BEGP(pt1); + + deref_body(d0, pt1, func_var_2unk, func_var_2nvar); + _YAP_Error(INSTANTIATION_ERROR,(CELL)pt1,"functor/3"); + ENDP(pt1); + /* Oops, second argument was unbound too */ + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_cut_by( void) +{ + BEGD(d0); + d0 = ARG1; + deref_head(d0, cutby_x_unk); + cutby_x_nvar: +#if SBA + if (!IsIntegerTerm(d0)) { +#else + if (!IsIntTerm(d0)) { +#endif + return(FALSE); + } + BEGCHO(pt0); +#if SBA + pt0 = (choiceptr)IntegerOfTerm(d0); +#else + pt0 = (choiceptr)(LCL0-IntOfTerm(d0)); +#endif + /* find where to cut to */ + if (pt0 > B) { + /* Wow, we're gonna cut!!! */ +#ifdef YAPOR + CUT_prune_to(pt0); +#else + B = pt0; +#endif /* YAPOR */ +#ifdef TABLING + abolish_incomplete_subgoals(B); +#endif /* TABLING */ + HB = B->cp_h; + /* trim_trail();*/ + } + ENDCHO(pt0); + return(TRUE); + + BEGP(pt0); + deref_body(d0, pt0, cutby_x_unk, cutby_x_nvar); + /* never cut to a variable */ + /* Abort */ + return(FALSE); + ENDP(pt0); + ENDD(d0); +} + +static Int +p_erroneous_call(void) +{ + _YAP_Error(SYSTEM_ERROR, TermNil, "bad call to internal built-in"); + return(FALSE); +} + +void +_YAP_InitInlines(void) +{ + _YAP_InitAsmPred("$$cut_by", 1, _cut_by, p_cut_by, SafePredFlag); + + _YAP_InitAsmPred("atom", 1, _atom, p_atom, SafePredFlag); + _YAP_InitAsmPred("atomic", 1, _atomic, p_atomic, SafePredFlag); + _YAP_InitAsmPred("integer", 1, _integer, p_integer, SafePredFlag); + _YAP_InitAsmPred("nonvar", 1, _nonvar, p_nonvar, SafePredFlag); + _YAP_InitAsmPred("number", 1, _number, p_number, SafePredFlag); + _YAP_InitAsmPred("var", 1, _var, p_var, SafePredFlag); + _YAP_InitAsmPred("db_reference", 1, _db_ref, p_db_ref, SafePredFlag); + _YAP_InitAsmPred("primitive", 1, _primitive, p_primitive, SafePredFlag); + _YAP_InitAsmPred("compound", 1, _compound, p_compound, SafePredFlag); + _YAP_InitAsmPred("float", 1, _float, p_float, SafePredFlag); + _YAP_InitAsmPred("=", 2, _equal, p_equal, SafePredFlag); + _YAP_InitAsmPred("\\=", 2, _dif, p_dif, SafePredFlag); + _YAP_InitAsmPred("==", 2, _eq, p_eq, SafePredFlag); + _YAP_InitAsmPred("arg", 3, _arg, p_arg, SafePredFlag); + _YAP_InitAsmPred("functor", 3, _functor, p_functor, SafePredFlag); + _YAP_InitAsmPred("$plus", 3, _plus, p_erroneous_call, SafePredFlag); + _YAP_InitAsmPred("$minus", 3, _minus, p_erroneous_call, SafePredFlag); + _YAP_InitAsmPred("$times", 3, _times, p_erroneous_call, SafePredFlag); + _YAP_InitAsmPred("$div", 3, _div, p_erroneous_call, SafePredFlag); + _YAP_InitAsmPred("$and", 3, _and, p_erroneous_call, SafePredFlag); + _YAP_InitAsmPred("$or", 3, _or, p_erroneous_call, SafePredFlag); + _YAP_InitAsmPred("$sll", 3, _sll, p_erroneous_call, SafePredFlag); + _YAP_InitAsmPred("$slr", 3, _slr, p_erroneous_call, SafePredFlag); +} +