/*-------------------------------------------------------------------------*/ AtomInf *Get_Functor_Arity(WamWord start_word,int *arity,WamWord **arg_adr) { WamWord word,tag,*adr; Deref(start_word,word,tag,adr) switch(tag) { case CST: *arity=0; return UnTag_CST(word); case LST: adr=UnTag_LST(word); *arity=2; *arg_adr=&Car(adr); return atom_dot; case STC: adr=UnTag_STC(word); *arity=Arity(adr); *arg_adr=&Arg(adr,0); return Functor(adr); default: return NULL; } }
/*-------------------------------------------------------------------------* * HANDLE_KEY_VARIABLES * * * *-------------------------------------------------------------------------*/ static void Handle_Key_Variables(WamWord start_word) { WamWord word, tag_mask; WamWord *adr; save_key_var_ptr = key_var_ptr; next_key_var_ptr = pl_glob_dico_var; DEREF(start_word, word, tag_mask); adr = UnTag_STC(word); Pl_Treat_Vars_Of_Term(Arg(adr, 0), TRUE, Link_Key_Var); }
/*-------------------------------------------------------------------------* * GROUP * * * *-------------------------------------------------------------------------*/ static WamWord Group(WamWord all_sol_word, WamWord gl_key_word, WamWord *key_adr) { WamWord word, tag_mask; WamWord *adr; WamWord *lst_adr, *prev_lst_adr; WamWord key_word, key_word1; DEREF(all_sol_word, word, tag_mask); lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), word, tag_mask); /* term of the form Key-Value */ adr = UnTag_STC(word); *key_adr = key_word = Arg(adr, 0); for (;;) { /* Arg(adr,1) cannot be a Dont_Separate_Tag */ Car(lst_adr) = Arg(adr, 1); prev_lst_adr = lst_adr; DEREF(Cdr(lst_adr), word, tag_mask); if (word == NIL_WORD) return NOT_A_WAM_WORD; prev_lst_adr = lst_adr; lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), word, tag_mask); /* term of the form Key-Value */ adr = UnTag_STC(word); key_word1 = Arg(adr, 0); if (Pl_Term_Compare(key_word, key_word1) != 0) break; } all_sol_word = Cdr(prev_lst_adr); Cdr(prev_lst_adr) = NIL_WORD; return all_sol_word; }
/*-------------------------------------------------------------------------* * PL_TERM_SIZE * * * *-------------------------------------------------------------------------*/ int Pl_Term_Size(WamWord start_word) { WamWord word, tag_mask; WamWord *adr; int i; int n = 0; /* init to zero for terminal_rec */ terminal_rec: DEREF(start_word, word, tag_mask); switch (Tag_From_Tag_Mask(tag_mask)) { #ifndef NO_USE_FD_SOLVER case FDV: /* 1+ for <REF,->fdv_adr> since Dont_Separate_Tag */ return n + 1 + Fd_Variable_Size(UnTag_FDV(word)); #endif case FLT: #if WORD_SIZE == 32 return n + 1 + 2; #else return n + 1 + 1; #endif case LST: adr = UnTag_LST(word); adr = &Car(adr); n += 1 + Pl_Term_Size(*adr++); start_word = *adr; goto terminal_rec; case STC: adr = UnTag_STC(word); n += 2; /* tagged word + f_n */ i = Arity(adr); adr = &Arg(adr, 0); while (--i) n += Pl_Term_Size(*adr++); start_word = *adr; goto terminal_rec; default: return n + 1; } }
/*-------------------------------------------------------------------------* * PL_TREAT_VARS_OF_TERM * * * * Call fct for each variable found in a term. * *-------------------------------------------------------------------------*/ void Pl_Treat_Vars_Of_Term(WamWord start_word, Bool generic_var, void (*fct) ()) { WamWord word, tag_mask; WamWord *adr; int i; terminal_rec: DEREF(start_word, word, tag_mask); switch (Tag_Of(word)) { case REF: (*fct) (UnTag_REF(word), word); break; #ifndef NO_USE_FD_SOLVER case FDV: if (generic_var) (*fct) (UnTag_FDV(word), word); break; #endif case LST: adr = UnTag_LST(word); adr = &Car(adr); Pl_Treat_Vars_Of_Term(*adr++, generic_var, fct); start_word = *adr; goto terminal_rec; case STC: adr = UnTag_STC(word); i = Arity(adr); adr = &Arg(adr, 0); while (--i) Pl_Treat_Vars_Of_Term(*adr++, generic_var, fct); start_word = *adr; goto terminal_rec; } }
/*-------------------------------------------------------------------------* * EXISTENTIAL_VARIABLES * * * *-------------------------------------------------------------------------*/ static WamWord Existential_Variables(WamWord start_word) { WamWord word, tag_mask; WamWord *adr; DEREF(start_word, word, tag_mask); if (tag_mask == TAG_STC_MASK) { adr = UnTag_STC(word); if (Functor_And_Arity(adr) == exist_2) { Pl_Treat_Vars_Of_Term(Arg(adr, 0), TRUE, Bound_Var); word = Existential_Variables(Arg(adr, 1)); } } return word; }
/*-------------------------------------------------------------------------* * CHECK_IF_VAR_OCCURS * * * * Only called if var_adr resides in the heap since a var residing in the * * local stack cannot appear in a term (there is no binding from the heap * * to the local stack in the WAM). * *-------------------------------------------------------------------------*/ static Bool Check_If_Var_Occurs(WamWord *var_adr, WamWord term_word) { WamWord word, tag_mask; WamWord *adr; int i; terminal_rec: DEREF(term_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) return UnTag_REF(word) == var_adr; if (tag_mask == TAG_LST_MASK) { adr = UnTag_LST(word); adr = &Car(adr); if (Check_If_Var_Occurs(var_adr, *adr++)) return TRUE; term_word = *adr; goto terminal_rec; } if (tag_mask == TAG_STC_MASK) { adr = UnTag_STC(word); i = Arity(adr); adr = &Arg(adr, 0); while (--i) if (Check_If_Var_Occurs(var_adr, *adr++)) return TRUE; term_word = *adr; goto terminal_rec; } return FALSE; }
/*-------------------------------------------------------------------------* * ADD_FD_VARIABLES * * * *-------------------------------------------------------------------------*/ static void Add_Fd_Variables(WamWord e_word) { WamWord word, tag_mask; WamWord *adr; int i; DEREF(e_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) { if (vars_sp - vars_tbl == VARS_STACK_SIZE) Pl_Err_Resource(pl_resource_too_big_fd_constraint); *vars_sp++ = word; *vars_sp++ = 1; /* FD var */ return; } if (tag_mask == TAG_LST_MASK) { adr = UnTag_LST(word); Add_Fd_Variables(Car(adr)); Add_Fd_Variables(Cdr(adr)); } if (tag_mask == TAG_STC_MASK) { adr = UnTag_STC(word); i = Arity(adr); do Add_Fd_Variables(Arg(adr, --i)); while (i); } }
/*-------------------------------------------------------------------------*/ AtomInf *Get_Compound(WamWord tag,WamWord word,int *arity,WamWord **arg_adr) { WamWord *adr; switch(tag) { case LST: adr=UnTag_LST(word); *arity=2; *arg_adr=&Car(adr); return atom_dot; case STC: adr=UnTag_STC(word); *arity=Arity(adr); *arg_adr=&Arg(adr,0); return Functor(adr); default: return NULL; } }
/*-------------------------------------------------------------------------*/ static Bool G_Assign_Element(GVarElt *g_elem,WamWord gval_word, Bool backtrack,Bool copy) { WamWord word,tag,*adr; AtomInf *atom; int size; int size_base=0; GVarElt save_g_elem; save_g_elem=*g_elem; Deref(gval_word,word,tag,adr) if (tag==STC) { adr=UnTag_STC(word); atom=Functor(adr); if (atom==atom_g_array || atom==atom_g_array_extend) /* an array */ { if (!G_Assign_Array(g_elem,adr,atom==atom_g_array_extend,copy)) return FALSE; goto finish; } } if (!copy || tag==CST || tag==INT) /* a link */ { if (tag==REF && Is_A_Local_Adr(adr)) { word=Tag_Value(REF,H); Globalize_Local_Unbound_Var(adr); } g_elem->size=0; g_elem->val=Global_UnMove(tag) ? Tag_Value(REF,adr) : word; goto finish; } /* a copy */ size=Term_Size(word); if ((adr=(WamWord *) Lib1(malloc,size*sizeof(WamWord)))==NULL) Fatal_Error(ERR_ALLOC_FAULT); g_elem->size=size+size_base; g_elem->val=(WamWord) adr; Copy_Term(adr,&word); finish: if (backtrack) { Trail_Push(save_g_elem.val); /* push frame (see G_Untrail) */ Trail_Push(save_g_elem.size); Trail_Push(g_elem); Trail_FC(G_Untrail) } else
/*-------------------------------------------------------------------------* * SHOW_TERM * * * *-------------------------------------------------------------------------*/ static void Show_Term(int depth, int prec, int context, WamWord term_word) { WamWord word, tag_mask; WamWord *adr; if (depth == 0) { Show_Atom(GENERAL_TERM, atom_dots); return; } DEREF(term_word, word, tag_mask); if (tag_mask != TAG_REF_MASK && Try_Portray(word)) return; switch (Tag_From_Tag_Mask(tag_mask)) { case REF: adr = UnTag_REF(word); if (Is_A_Local_Adr(adr)) { Globalize_Local_Unbound_Var(adr, word); adr = UnTag_REF(word); } Show_Global_Var(adr); break; case ATM: Show_Atom(context, UnTag_ATM(word)); break; #ifndef NO_USE_FD_SOLVER case FDV: Show_Fd_Variable(UnTag_FDV(word)); break; #endif case INT: Show_Integer(UnTag_INT(word)); break; case FLT: Show_Float(Pl_Obtain_Float(UnTag_FLT(word))); break; case LST: adr = UnTag_LST(word); if (ignore_op) { Out_String("'.'("); Show_Term(depth - 1, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, Car(adr)); Out_Char(','); Show_Term(depth - 1, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, Cdr(adr)); Out_Char(')'); } else { Out_Char('['); Show_List_Arg(depth, adr); Out_Char(']'); } break; case STC: adr = UnTag_STC(word); Show_Structure(depth, prec, context, adr); break; } }
/*-------------------------------------------------------------------------* * SIMPLIFY * * * * This function returns the result of the simplified boolean expression * * given in e_word. NOT operators are only applied to variables. * * * * Input: * * sign : current sign of the boolean term (-1 (inside a ~) or +1) * * e_word: boolean term to simplify * * * * Output: * * The returned result is a pointer to a node of the following form: * * * * for binary boolean not operator (~): * * [1]: variable involved (tagged word) * * [0]: operator NOT * * * * for unary boolean operators (<=> ~<=> ==> ~==> /\ ~/\ \/ ~\/): * * [2]: right boolean exp (pointer to node) * * [1]: left boolean exp (pointer to node) * * [0]: operator (EQUIV, NEQUIV, IMPLY, NIMPLY, AND, NAND, OR, NOR) * * * * for boolean false value (0): * * [0]: ZERO * * * * for boolean true value (1): * * [0]: ONE * * * * for boolean variable: * * [0]: tagged word * * * * for binary math operators (= \= < >= > <=) (partial / full AC): * * [2]: right math exp (tagged word) * * [1]: left math exp (tagged word) * * [0]: operator (EQ, NEQ, LT, LTE, EQ_F, NEQ_F, LT_F, LTE_F) * * (GT, GTE, GT_F, and GTE_F becomes LT, LTE, LT_F and LTE_F) * * * * These nodes are stored in a hybrid stack. NB: XOR same as NEQUIV * *-------------------------------------------------------------------------*/ static WamWord * Simplify(int sign, WamWord e_word) { WamWord word, tag_mask; WamWord *adr; WamWord f_n, le_word, re_word; int op, n; WamWord *exp, *sp1; WamWord l, r; #ifdef DEBUG printf("ENTERING %5ld: %2d: ", sp - stack, sign); Pl_Write(e_word); printf("\n"); #endif exp = sp; if (sp - stack > BOOL_STACK_SIZE - 5) Pl_Err_Resource(pl_resource_too_big_fd_constraint); DEREF(e_word, word, tag_mask); if (tag_mask == TAG_REF_MASK || tag_mask == TAG_FDV_MASK) { adr = UnTag_Address(word); if (vars_sp - vars_tbl == VARS_STACK_SIZE) Pl_Err_Resource(pl_resource_too_big_fd_constraint); *vars_sp++ = word; *vars_sp++ = 0; /* bool var */ if (sign != 1) *sp++ = NOT; *sp++ = Tag_REF(adr); return exp; } if (tag_mask == TAG_INT_MASK) { n = UnTag_INT(word); if ((unsigned) n > 1) goto type_error; *sp++ = ZERO + ((sign == 1) ? n : 1 - n); return exp; } if (tag_mask == TAG_ATM_MASK) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Value(e_word); Pl_Unify_Integer(0); type_error: Pl_Err_Type(pl_type_fd_bool_evaluable, word); } if (tag_mask != TAG_STC_MASK) goto type_error; adr = UnTag_STC(word); f_n = Functor_And_Arity(adr); if (bool_xor == f_n) op = NEQUIV; else { for (op = 0; op < NB_OF_OP; op++) if (bool_tbl[op] == f_n) break; if (op == NB_OF_OP) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Atom(Functor(adr)); Pl_Unify_Integer(Arity(adr)); goto type_error; } } le_word = Arg(adr, 0); re_word = Arg(adr, 1); if (op == NOT) return Simplify(-sign, le_word); if (sign != 1) op = (op % 2 == EQ % 2) ? op + 1 : op - 1; if (op >= EQ && op <= LTE_F) { Add_Fd_Variables(le_word); Add_Fd_Variables(re_word); n = (op == GT || op == GT_F) ? op - 2 : (op == GTE || op == GTE_F) ? op + 2 : op; *sp++ = n; *sp++ = (n == op) ? le_word : re_word; *sp++ = (n == op) ? re_word : le_word; return exp; } sp += 3; exp[0] = op; exp[1] = (WamWord) Simplify(1, le_word); sp1 = sp; exp[2] = (WamWord) Simplify(1, re_word); l = *(WamWord *) (exp[1]); r = *(WamWord *) (exp[2]); /* NB: beware when calling below Simplify() (while has been just called above) * this can ran into stack overflow (N^2 space complexity). * Try to recover the stack before calling Simplify(). * Other stack recovery are less important (e.g. when only using exp[1]). * * In the following exp[] += sizeof(WamWord) is used to "skip" the NOT * in a simplification (points to the next cell). */ switch (op) { case EQUIV: if (l == ZERO) /* 0 <=> R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (l == ONE) /* 1 <=> R is R */ { return (WamWord *) exp[2]; } if (r == ZERO) /* L <=> 0 is ~L */ { sp = exp; return Simplify(-1, le_word); } if (r == ONE) /* L <=> 1 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (l == NOT) /* ~X <=> R is X <=> ~R */ { exp[1] += sizeof(WamWord); sp = sp1; exp[2] = (WamWord) Simplify(-1, re_word); break; } if (r == NOT) /* L <=> ~X is ~L <=> X */ { /* NB: cannot recover the stack */ exp[1] = (WamWord) Simplify(-1, le_word); exp[2] += sizeof(WamWord); break; } break; case NEQUIV: if (l == ZERO) /* 0 ~<=> R is R */ { return (WamWord *) exp[2]; } if (l == ONE) /* 1 ~<=> R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (r == ZERO) /* L ~<=> 0 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (r == ONE) /* L ~<=> 1 is ~L */ { sp = exp; return Simplify(-1, le_word); } if (l == NOT) /* ~X ~<=> R is X <=> R */ { exp[0] = EQUIV; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L ~<=> ~X is L <=> X */ { exp[0] = EQUIV; exp[2] += sizeof(WamWord); break; } if (IsVar(l) && !IsVar(r)) /* X ~<=> R is X <=> ~R */ { exp[0] = EQUIV; sp = sp1; exp[2] = (WamWord) Simplify(-1, re_word); break; } if (IsVar(r) && !IsVar(l)) /* L ~<=> X is L <=> ~X */ { exp[0] = EQUIV; /* NB: cannot recover the stack */ exp[1] = (WamWord) Simplify(-1, le_word); break; } break; case IMPLY: if (l == ZERO || r == ONE) /* 0 ==> R is 1 , L ==> 1 is 1 */ { sp = exp; *sp++ = ONE; break; } if (l == ONE) /* 1 ==> R is R */ { return (WamWord *) exp[2]; } if (r == ZERO) /* L ==> 0 is ~L */ return sp = exp, Simplify(-1, le_word); if (l == NOT) /* ~X ==> R is X \/ R */ { exp[0] = OR; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L ==> ~X is X ==> ~L */ { exp[1] = exp[2] + sizeof(WamWord); exp[2] = (WamWord) Simplify(-1, le_word); break; } break; case NIMPLY: if (l == ZERO || r == ONE) /* 0 ~==> R is 0 , L ~==> 1 is 0 */ { sp = exp; *sp++ = ZERO; break; } if (l == ONE) /* 1 ~==> R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (r == ZERO) /* L ~==> 0 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (l == NOT) /* ~X ~==> R is X ~\/ R */ { exp[0] = NOR; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L ~==> ~X is L /\ X */ { exp[0] = AND; exp[2] += sizeof(WamWord); break; } break; case AND: if (l == ZERO || r == ZERO) /* 0 /\ R is 0 , L /\ 0 is 0 */ { sp = exp; *sp++ = ZERO; break; } if (l == ONE) /* 1 /\ R is R */ { return (WamWord *) exp[2]; } if (r == ONE) /* L /\ 1 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (l == NOT) /* ~X /\ R is R ~==> X */ { exp[0] = NIMPLY; word = exp[1]; exp[1] = exp[2]; exp[2] = word + sizeof(WamWord); break; } if (r == NOT) /* L /\ ~X is L ~==> X */ { exp[0] = NIMPLY; exp[2] += sizeof(WamWord); break; } break; case NAND: if (l == ZERO || r == ZERO) /* 0 ~/\ R is 1 , L ~/\ 0 is 1 */ { sp = exp; *sp++ = ONE; break; } if (l == ONE) /* 1 ~/\ R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (r == ONE) /* L ~/\ 1 is ~L */ { sp = exp; return Simplify(-1, le_word); } if (l == NOT) /* ~X ~/\ R is R ==> X */ { exp[0] = IMPLY; word = exp[1]; exp[1] = exp[2]; exp[2] = word + sizeof(WamWord); break; } if (r == NOT) /* L ~/\ ~X is L ==> X */ { exp[0] = IMPLY; exp[2] += sizeof(WamWord); break; } break; case OR: if (l == ONE || r == ONE) /* 1 \/ R is 1 , L \/ 1 is 1 */ { sp = exp; *sp++ = ONE; break; } if (l == ZERO) /* 0 \/ R is R */ { return (WamWord *) exp[2]; } if (r == ZERO) /* L \/ 0 is L */ { sp = sp1; return (WamWord *) exp[1]; } if (l == NOT) /* ~X \/ R is X ==> R */ { exp[0] = IMPLY; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L \/ ~X is X ==> L */ { exp[0] = IMPLY; word = exp[1]; exp[1] = exp[2] + sizeof(WamWord); exp[2] = word; break; } break; case NOR: if (l == ONE || r == ONE) /* 1 ~\/ R is 0 , L ~\/ 1 is 0 */ { sp = exp; *sp++ = ZERO; break; } if (l == ZERO) /* 0 ~\/ R is ~R */ { sp = exp; return Simplify(-1, re_word); } if (r == ZERO) /* L ~\/ 0 is ~L */ { sp = exp; return Simplify(-1, le_word); } if (l == NOT) /* ~X ~\/ R is X ~==> R */ { exp[0] = NIMPLY; exp[1] += sizeof(WamWord); break; } if (r == NOT) /* L ~\/ ~X is X ~==> L */ { exp[0] = NIMPLY; word = exp[1]; exp[1] = exp[2] + sizeof(WamWord); exp[2] = word; break; } break; } return exp; }
/*-------------------------------------------------------------------------* * This file is not compiled separately but included twice by wam_inst.c: * * - to define the Unify function (classical unification). * * - to define the Unify_Occurs_Check function (+ occurs check). * *-------------------------------------------------------------------------*/ Bool FC UNIFY_FCT_NAME(WamWord start_u_word, WamWord start_v_word) { WamWord u_word, u_tag_mask; WamWord v_word, v_tag_mask; WamWord *u_adr, *v_adr; int i; terminal_rec: DEREF(start_u_word, u_word, u_tag_mask); DEREF(start_v_word, v_word, v_tag_mask); if (u_tag_mask == TAG_REF_MASK) { u_adr = UnTag_REF(u_word); if (v_tag_mask == TAG_REF_MASK) { v_adr = UnTag_REF(v_word); if (u_adr > v_adr) Bind_UV(u_adr, Tag_REF(v_adr)); else if (v_adr > u_adr) Bind_UV(v_adr, Tag_REF(u_adr)); } else { #ifdef OCCURS_CHECK if (!Is_A_Local_Adr(u_adr) && /* no binding from heap to local */ Check_If_Var_Occurs(u_adr, v_word)) return FALSE; #endif Do_Copy_Of_Word(v_tag_mask, v_word); Bind_UV(u_adr, v_word); } return TRUE; } if (v_tag_mask == TAG_REF_MASK) { v_adr = UnTag_REF(v_word); #ifdef OCCURS_CHECK if (!Is_A_Local_Adr(v_adr) && /* no binding from heap to local */ Check_If_Var_Occurs(v_adr, u_word)) return FALSE; #endif Do_Copy_Of_Word(u_tag_mask, u_word); Bind_UV(v_adr, u_word); return TRUE; } if (u_word == v_word) return TRUE; if (v_tag_mask == TAG_LST_MASK) { if (u_tag_mask != v_tag_mask) return FALSE; u_adr = UnTag_LST(u_word); v_adr = UnTag_LST(v_word); u_adr = &Car(u_adr); v_adr = &Car(v_adr); if (!UNIFY_FCT_NAME(*u_adr++, *v_adr++)) return FALSE; start_u_word = *u_adr; start_v_word = *v_adr; goto terminal_rec; } if (v_tag_mask == TAG_STC_MASK) { if (u_tag_mask != v_tag_mask) return FALSE; u_adr = UnTag_STC(u_word); v_adr = UnTag_STC(v_word); if (Functor_And_Arity(u_adr) != Functor_And_Arity(v_adr)) return FALSE; i = Arity(u_adr); u_adr = &Arg(u_adr, 0); v_adr = &Arg(v_adr, 0); while (--i) if (!UNIFY_FCT_NAME(*u_adr++, *v_adr++)) return FALSE; start_u_word = *u_adr; start_v_word = *v_adr; goto terminal_rec; } #ifndef NO_USE_FD_SOLVER if (v_tag_mask == TAG_INT_MASK && u_tag_mask == TAG_FDV_MASK) return Fd_Unify_With_Integer(UnTag_FDV(u_word), UnTag_INT(v_word)); if (v_tag_mask == TAG_FDV_MASK) { v_adr = UnTag_FDV(v_word); if (u_tag_mask == TAG_INT_MASK) return Fd_Unify_With_Integer(v_adr, UnTag_INT(u_word)); if (u_tag_mask != v_tag_mask) /* i.e. TAG_FDV_MASK */ return FALSE; return Fd_Unify_With_Fd_Var(UnTag_FDV(u_word), v_adr); } #endif if (v_tag_mask == TAG_FLT_MASK) return (u_tag_mask == v_tag_mask && Pl_Obtain_Float(UnTag_FLT(u_word)) == Pl_Obtain_Float(UnTag_FLT(v_word))); return FALSE; }
/*-------------------------------------------------------------------------* * NORMALIZE * * * * This functions normalizes a term. * * Input: * * e_word: term to normalize * * sign : current sign of the term (-1 or +1) * * * * Output: * * p : the associated polynomial term * * * * Normalizes the term and loads it into p. * * Non-Linear operations are simplified and loaded into a stack to be * * executed later. * * * * T1*T2 : T1 and T2 are normalized to give the polynomials p1 and p2, with* * p1 = c1 + a1X1 + a2X2 + ... + anXn * * p2 = c2 + b1X1 + b2X2 + ... + bmXm * * and replaced by c1*c2 + * * a1X1 * c2 + a1X1 * b1X1 + ... + a1X1 * bmXm * * ... * * anX1 * c2 + anXn * b1X1 + ... + anXn * bmXm * * * * T1**T2: T1 and T2 are loaded into 2 new words word1 and word2 that can * * be integers or variables (tagged words). The code emitted * * depends on 3 possibilities (var**var is not allowed) * * (+ optim 1**T2, 0**T2, T1**0, T1**1), NB 0**0=1 * *-------------------------------------------------------------------------*/ static Bool Normalize(WamWord e_word, int sign, Poly *p) { WamWord word, tag_mask; WamWord *adr; WamWord *fdv_adr; WamWord word1, word2, word3; WamWord f_n, le_word, re_word; int i; PlLong n1, n2, n3; terminal_rec: DEREF(e_word, word, tag_mask); if (tag_mask == TAG_FDV_MASK) { fdv_adr = UnTag_FDV(word); Add_Monom(p, sign, 1, Tag_REF(fdv_adr)); return TRUE; } if (tag_mask == TAG_INT_MASK) { n1 = UnTag_INT(word); if (n1 > MAX_COEF_FOR_SORT) sort = TRUE; Add_Cst_To_Poly(p, sign, n1); return TRUE; } if (tag_mask == TAG_REF_MASK) { if (vars_sp - vars_tbl >= VARS_STACK_SIZE) Pl_Err_Resource(pl_resource_too_big_fd_constraint); *vars_sp++ = word; Add_Monom(p, sign, 1, word); return TRUE; } if (tag_mask == TAG_ATM_MASK) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Value(e_word); Pl_Unify_Integer(0); type_error: Pl_Err_Type(pl_type_fd_evaluable, word); } if (tag_mask != TAG_STC_MASK) goto type_error; adr = UnTag_STC(word); f_n = Functor_And_Arity(adr); for (i = 0; i < NB_OF_OP; i++) if (arith_tbl[i] == f_n) break; le_word = Arg(adr, 0); re_word = Arg(adr, 1); switch (i) { case PLUS_1: e_word = le_word; goto terminal_rec; case PLUS_2: if (!Normalize(le_word, sign, p)) return FALSE; e_word = re_word; goto terminal_rec; case MINUS_2: if (!Normalize(le_word, sign, p)) return FALSE; e_word = re_word; sign = -sign; goto terminal_rec; case MINUS_1: e_word = le_word; sign = -sign; goto terminal_rec; case TIMES_2: #ifdef DEVELOP_TIMES_2 #if 1 /* optimize frequent use: INT*VAR */ DEREF(le_word, word, tag_mask); if (tag_mask != TAG_INT_MASK) goto any; n1 = UnTag_INT(word); if (n1 > MAX_COEF_FOR_SORT) sort = TRUE; DEREF(re_word, word, tag_mask); if (tag_mask != TAG_REF_MASK) { if (tag_mask != TAG_FDV_MASK) goto any; else { fdv_adr = UnTag_FDV(word); word = Tag_REF(fdv_adr); } } Add_Monom(p, sign, n1, word); return TRUE; any: #endif { Poly p1, p2; int i1, i2; New_Poly(p1); New_Poly(p2); if (!Normalize(le_word, 1, &p1) || !Normalize(re_word, 1, &p2)) return FALSE; Add_Cst_To_Poly(p, sign, p1.c * p2.c); for (i1 = 0; i1 < p1.nb_monom; i1++) { Add_Monom(p, sign, p1.m[i1].a * p2.c, p1.m[i1].x_word); for (i2 = 0; i2 < p2.nb_monom; i2++) if (!Add_Multiply_Monom(p, sign, p1.m + i1, p2.m + i2)) return FALSE; } for (i2 = 0; i2 < p2.nb_monom; i2++) Add_Monom(p, sign, p2.m[i2].a * p1.c, p2.m[i2].x_word); return TRUE; } #else if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); n1 = n1 * n2; Add_Cst_To_Poly(p, sign, n1); return TRUE; } Add_Monom(p, sign, n1, word2); return TRUE; } if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); Add_Monom(p, sign, n2, word1); return TRUE; } word1 = (word1 == word2) ? Push_Delayed_Cstr(DC_X2_EQ_Y, word1, 0, 0) : Push_Delayed_Cstr(DC_XY_EQ_Z, word1, word2, 0); Add_Monom(p, sign, 1, word1); return TRUE; #endif case POWER_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); if ((n1 = Pl_Power(n1, n2)) < 0) return FALSE; Add_Cst_To_Poly(p, sign, n1); return TRUE; } if (n1 == 1) { Add_Cst_To_Poly(p, sign, 1); return TRUE; } word = (n1 == 0) ? Push_Delayed_Cstr(DC_ZERO_POWER_N_EQ_Y, word2, 0, 0) : Push_Delayed_Cstr(DC_A_POWER_N_EQ_Y, word1, word2, 0); goto end_power; } if (Tag_Mask_Of(word2) != TAG_INT_MASK) Pl_Err_Instantiation(); else { n2 = UnTag_INT(word2); if (n2 == 0) { Add_Cst_To_Poly(p, sign, 1); return TRUE; } word = (n2 == 1) ? word1 : (n2 == 2) ? Push_Delayed_Cstr(DC_X2_EQ_Y, word1, 0, 0) : Push_Delayed_Cstr(DC_X_POWER_A_EQ_Y, word1, word2, 0); } end_power: Add_Monom(p, sign, 1, word); return TRUE; case MIN_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); n1 = math_min(n1, n2); Add_Cst_To_Poly(p, sign, n1); return TRUE; } word = Push_Delayed_Cstr(DC_MIN_X_A_EQ_Z, word2, word1, 0); goto end_min; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_MIN_X_A_EQ_Z, word1, word2, 0); else word = Push_Delayed_Cstr(DC_MIN_X_Y_EQ_Z, word1, word2, 0); end_min: Add_Monom(p, sign, 1, word); return TRUE; case MAX_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); n1 = math_max(n1, n2); Add_Cst_To_Poly(p, sign, n1); return TRUE; } word = Push_Delayed_Cstr(DC_MAX_X_A_EQ_Z, word2, word1, 0); goto end_max; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_MAX_X_A_EQ_Z, word1, word2, 0); else word = Push_Delayed_Cstr(DC_MAX_X_Y_EQ_Z, word1, word2, 0); end_max: Add_Monom(p, sign, 1, word); return TRUE; case DIST_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); n1 = (n1 >= n2) ? n1 - n2 : n2 - n1; Add_Cst_To_Poly(p, sign, n1); return TRUE; } word = Push_Delayed_Cstr(DC_ABS_X_MINUS_A_EQ_Z, word2, word1, 0); goto end_dist; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_ABS_X_MINUS_A_EQ_Z, word1, word2, 0); else word = Push_Delayed_Cstr(DC_ABS_X_MINUS_Y_EQ_Z, word1, word2, 0); end_dist: Add_Monom(p, sign, 1, word); return TRUE; case QUOT_2: word3 = Make_Self_Ref(H); /* word3 = remainder */ Global_Push(word3); goto quot_rem; case REM_2: word3 = Make_Self_Ref(H); /* word3 = remainder */ Global_Push(word3); goto quot_rem; case QUOT_REM_3: quot_rem: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2) || (i == QUOT_REM_3 && !Load_Term_Into_Word(Arg(adr, 2), &word3))) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); if (n2 == 0) return FALSE; n3 = n1 % n2; if (i == QUOT_2 || i == QUOT_REM_3) { if (i == QUOT_REM_3) PRIM_CSTR_2(pl_x_eq_c, word3, word); else H--; /* recover word3 space */ n3 = n1 / n2; } Add_Cst_To_Poly(p, sign, n3); return TRUE; } word = Push_Delayed_Cstr(DC_QUOT_REM_A_Y_R_EQ_Z, word1, word2, word3); goto end_quot_rem; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_QUOT_REM_X_A_R_EQ_Z, word1, word2, word3); else word = Push_Delayed_Cstr(DC_QUOT_REM_X_Y_R_EQ_Z, word1, word2, word3); end_quot_rem: Add_Monom(p, sign, 1, (i == REM_2) ? word3 : word); return TRUE; case DIV_2: if (!Load_Term_Into_Word(le_word, &word1) || !Load_Term_Into_Word(re_word, &word2)) return FALSE; if (Tag_Is_INT(word1)) { n1 = UnTag_INT(word1); if (Tag_Is_INT(word2)) { n2 = UnTag_INT(word2); if (n2 == 0 || n1 % n2 != 0) return FALSE; n1 /= n2; Add_Cst_To_Poly(p, sign, n1); return TRUE; } word = Push_Delayed_Cstr(DC_DIV_A_Y_EQ_Z, word1, word2, 0); goto end_div; } if (Tag_Is_INT(word2)) word = Push_Delayed_Cstr(DC_DIV_X_A_EQ_Z, word1, word2, 0); else word = Push_Delayed_Cstr(DC_DIV_X_Y_EQ_Z, word1, word2, 0); end_div: Add_Monom(p, sign, 1, word); return TRUE; default: word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Atom(Functor(adr)); Pl_Unify_Integer(Arity(adr)); goto type_error; } return TRUE; }
/*-------------------------------------------------------------------------* * PL_COPY_CONTIGUOUS_TERM * * * * Copy a contiguous term (dereferenced), the result is a contiguous term. * *-------------------------------------------------------------------------*/ void Pl_Copy_Contiguous_Term(WamWord *dst_adr, WamWord *src_adr) #define Old_Adr_To_New_Adr(adr) ((dst_adr)+((adr)-(src_adr))) { WamWord word, *adr; WamWord *q; int i; terminal_rec: word = *src_adr; switch (Tag_Of(word)) { case REF: adr = UnTag_REF(word); q = Old_Adr_To_New_Adr(adr); *dst_adr = Tag_REF(q); if (adr > src_adr) /* only useful for Dont_Separate_Tag */ Pl_Copy_Contiguous_Term(q, adr); return; #ifndef NO_USE_FD_SOLVER case FDV: adr = UnTag_FDV(word); Fd_Copy_Variable(dst_adr, adr); return; #endif case FLT: adr = UnTag_FLT(word); q = Old_Adr_To_New_Adr(adr); q[0] = adr[0]; #if WORD_SIZE == 32 q[1] = adr[1]; #endif *dst_adr = Tag_FLT(q); return; case LST: adr = UnTag_LST(word); q = Old_Adr_To_New_Adr(adr); *dst_adr = Tag_LST(q); q = &Car(q); adr = &Car(adr); Pl_Copy_Contiguous_Term(q++, adr++); dst_adr = q; src_adr = adr; goto terminal_rec; case STC: adr = UnTag_STC(word); q = Old_Adr_To_New_Adr(adr); *dst_adr = Tag_STC(q); Functor_And_Arity(q) = Functor_And_Arity(adr); i = Arity(adr); q = &Arg(q, 0); adr = &Arg(adr, 0); while (--i) Pl_Copy_Contiguous_Term(q++, adr++); dst_adr = q; src_adr = adr; goto terminal_rec; default: *dst_adr = word; return; } }
/*-------------------------------------------------------------------------* * COPY_TERM_REC * * * * p is the next address to use to store the rest of a term. * *-------------------------------------------------------------------------*/ static void Copy_Term_Rec(WamWord *dst_adr, WamWord *src_adr, WamWord **p) { WamWord word, tag_mask; WamWord *adr; WamWord *q; int i; terminal_rec: DEREF(*src_adr, word, tag_mask); switch (Tag_From_Tag_Mask(tag_mask)) { case REF: adr = UnTag_REF(word); q = *p; if (adr < q && adr >= base_copy) /* already a copy */ { *dst_adr = word; return; } if (top_vars >= end_vars) Pl_Err_Representation(pl_representation_too_many_variables); *top_vars++ = word; /* word to restore */ *top_vars++ = (WamWord) adr; /* address to restore */ *adr = *dst_adr = Tag_REF(dst_adr); /* bind to a new copy */ return; #ifndef NO_USE_FD_SOLVER case FDV: adr = UnTag_FDV(word); q = *p; if (adr < q && adr >= base_copy) /* already a copy */ { *dst_adr = Tag_REF(adr); /* since Dont_Separate_Tag */ return; } if (top_vars >= end_vars) Pl_Err_Representation(pl_representation_too_many_variables); *top_vars++ = word; /* word to restore */ *top_vars++ = (WamWord) adr; /* address to restore */ q = *p; *p = q + Fd_Copy_Variable(q, adr); *adr = *dst_adr = Tag_REF(q); /* bind to a new copy */ return; #endif case FLT: adr = UnTag_FLT(word); q = *p; q[0] = adr[0]; #if WORD_SIZE == 32 q[1] = adr[1]; *p = q + 2; #else *p = q + 1; #endif *dst_adr = Tag_FLT(q); return; case LST: adr = UnTag_LST(word); q = *p; *dst_adr = Tag_LST(q); *p = &Cdr(q) + 1; q = &Car(q); adr = &Car(adr); Copy_Term_Rec(q++, adr++, p); dst_adr = q; src_adr = adr; goto terminal_rec; case STC: adr = UnTag_STC(word); q = *p; *dst_adr = Tag_STC(q); Functor_And_Arity(q) = Functor_And_Arity(adr); i = Arity(adr); *p = &Arg(q, i - 1) + 1; q = &Arg(q, 0); adr = &Arg(adr, 0); while (--i) Copy_Term_Rec(q++, adr++, p); dst_adr = q; src_adr = adr; goto terminal_rec; default: *dst_adr = word; return; } }
/*-------------------------------------------------------------------------* * LOAD_MATH_EXPRESSION * * * *-------------------------------------------------------------------------*/ static WamWord Load_Math_Expression(WamWord exp) { WamWord word, tag_mask; WamWord *adr; WamWord *lst_adr; ArithInf *arith; DEREF(exp, word, tag_mask); if (tag_mask == TAG_INT_MASK || tag_mask == TAG_FLT_MASK) return word; if (tag_mask == TAG_LST_MASK) { lst_adr = UnTag_LST(word); DEREF(Cdr(lst_adr), word, tag_mask); if (word != NIL_WORD) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Atom(ATOM_CHAR('.')); Pl_Unify_Integer(2); Pl_Err_Type(pl_type_evaluable, word); } DEREF(Car(lst_adr), word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_INT_MASK) { Pl_Err_Type(pl_type_integer, word); } return word; } if (tag_mask == TAG_STC_MASK) { adr = UnTag_STC(word); arith = (ArithInf *) Pl_Hash_Find(arith_tbl, Functor_And_Arity(adr)); if (arith == NULL) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Atom(Functor(adr)); Pl_Unify_Integer(Arity(adr)); Pl_Err_Type(pl_type_evaluable, word); } if (Arity(adr) == 1) return (*(arith->fct)) (Load_Math_Expression(Arg(adr, 0))); return (*(arith->fct)) (Load_Math_Expression(Arg(adr, 0)), Load_Math_Expression(Arg(adr, 1))); } if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask == TAG_ATM_MASK) { word = Pl_Put_Structure(ATOM_CHAR('/'), 2); Pl_Unify_Value(exp); Pl_Unify_Integer(0); /* then type_error */ } Pl_Err_Type(pl_type_evaluable, word); return word; }
/*-------------------------------------------------------------------------* * PL_BLT_FUNCTOR * * * *-------------------------------------------------------------------------*/ Bool FC Pl_Blt_Functor(WamWord term_word, WamWord functor_word, WamWord arity_word) { WamWord word, tag_mask; WamWord *adr; WamWord tag_functor; int arity; Bool res; Pl_Set_C_Bip_Name("functor", 3); DEREF(term_word, word, tag_mask); if (tag_mask != TAG_REF_MASK) { if (tag_mask == TAG_LST_MASK) res = Pl_Un_Atom_Check(ATOM_CHAR('.'), functor_word) && Pl_Un_Integer_Check(2, arity_word); else if (tag_mask == TAG_STC_MASK) { adr = UnTag_STC(word); res = Pl_Un_Atom_Check(Functor(adr), functor_word) && Pl_Un_Integer_Check(Arity(adr), arity_word); } else res = Pl_Unify(word, functor_word) && Pl_Un_Integer_Check(0, arity_word); goto finish; } /* tag_mask == TAG_REF_MASK */ DEREF(functor_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_ATM_MASK && tag_mask != TAG_INT_MASK && tag_mask != TAG_FLT_MASK) Pl_Err_Type(pl_type_atomic, functor_word); tag_functor = tag_mask; functor_word = word; arity = Pl_Rd_Positive_Check(arity_word); if (arity > MAX_ARITY) Pl_Err_Representation(pl_representation_max_arity); if (tag_functor == TAG_ATM_MASK && UnTag_ATM(functor_word) == ATOM_CHAR('.') && arity == 2) { res = (Pl_Get_List(term_word)) ? Pl_Unify_Void(2), TRUE : FALSE; goto finish; } if (tag_functor == TAG_ATM_MASK && arity > 0) { res = (Pl_Get_Structure(UnTag_ATM(functor_word), arity, term_word)) ? Pl_Unify_Void(arity), TRUE : FALSE; goto finish; } if (arity != 0) Pl_Err_Type(pl_type_atom, functor_word); res = Pl_Unify(functor_word, term_word); finish: Pl_Unset_C_Bip_Name(); return res; }
static void Show_List_Arg(int depth, WamWord *lst_adr) { WamWord word, tag_mask; terminal_rec: depth--; Show_Term(depth, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, Car(lst_adr)); if (depth == 0) /* dots already written by Show_Term */ return; DEREF(Cdr(lst_adr), word, tag_mask); switch (Tag_From_Tag_Mask(tag_mask)) { case REF: SHOW_LIST_PIPE; Show_Global_Var(UnTag_REF(word)); break; case ATM: if (word != NIL_WORD) { SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Atom(GENERAL_TERM, UnTag_ATM(word)); } break; #ifndef NO_USE_FD_SOLVER case FDV: SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Fd_Variable(UnTag_FDV(word)); break; #endif case INT: SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Integer(UnTag_INT(word)); break; case FLT: SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Float(Pl_Obtain_Float(UnTag_FLT(word))); break; case LST: Out_Char(','); if (space_args) Out_Space(); lst_adr = UnTag_LST(word); goto terminal_rec; break; case STC: SHOW_LIST_PIPE; if (Try_Portray(word)) return; Show_Structure(depth, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, UnTag_STC(word)); break; } }
/*-------------------------------------------------------------------------* * PL_BLT_UNIV * * * *-------------------------------------------------------------------------*/ Bool FC Pl_Blt_Univ(WamWord term_word, WamWord list_word) { WamWord word, tag_mask; WamWord *adr; WamWord car_word; int lst_length; WamWord *arg1_adr; WamWord *term_adr, *lst_adr, *stc_adr; WamWord functor_word, functor_tag; int functor; int arity; Pl_Set_C_Bip_Name("=..", 2); DEREF(term_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) goto list_to_term; /* from term to list functor+args */ if (tag_mask == TAG_LST_MASK) { adr = UnTag_LST(word); car_word = Tag_ATM(ATOM_CHAR('.')); lst_length = 1 + 2; arg1_adr = &Car(adr); } else if (tag_mask == TAG_STC_MASK) { adr = UnTag_STC(word); car_word = Tag_ATM(Functor(adr)); lst_length = 1 + Arity(adr); arg1_adr = &Arg(adr, 0); } #ifndef NO_USE_FD_SOLVER else if (tag_mask == TAG_FDV_MASK) { adr = UnTag_FDV(word); car_word = Tag_REF(adr); /* since Dont_Separate_Tag */ lst_length = 1 + 0; } #endif else /* TAG_ATM/INT/FLT_MASK */ { car_word = word; lst_length = 1 + 0; } Pl_Check_For_Un_List(list_word); Pl_Unset_C_Bip_Name(); for (;;) { if (!Pl_Get_List(list_word) || !Pl_Unify_Value(car_word)) return FALSE; list_word = Pl_Unify_Variable(); if (--lst_length == 0) break; car_word = *arg1_adr++; } return Pl_Get_Nil(list_word); /* from list functor+args to term */ list_to_term: term_adr = UnTag_REF(word); DEREF(list_word, word, tag_mask); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (word == NIL_WORD) Pl_Err_Domain(pl_domain_non_empty_list, list_word); if (tag_mask != TAG_LST_MASK) Pl_Err_Type(pl_type_list, list_word); lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), functor_word, functor_tag); if (functor_tag == TAG_REF_MASK) Pl_Err_Instantiation(); DEREF(Cdr(lst_adr), word, tag_mask); if (word == NIL_WORD) { if (functor_tag != TAG_ATM_MASK && functor_tag != TAG_INT_MASK && functor_tag != TAG_FLT_MASK) Pl_Err_Type(pl_type_atomic, functor_word); term_word = functor_word; goto finish; } if (functor_tag != TAG_ATM_MASK) Pl_Err_Type(pl_type_atom, functor_word); if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_LST_MASK) Pl_Err_Type(pl_type_list, list_word); functor = UnTag_ATM(functor_word); stc_adr = H; H++; /* space for f/n maybe lost if a list */ arity = 0; for (;;) { arity++; lst_adr = UnTag_LST(word); DEREF(Car(lst_adr), word, tag_mask); Do_Copy_Of_Word(tag_mask, word); /* since Dont_Separate_Tag */ Global_Push(word); DEREF(Cdr(lst_adr), word, tag_mask); if (word == NIL_WORD) break; if (tag_mask == TAG_REF_MASK) Pl_Err_Instantiation(); if (tag_mask != TAG_LST_MASK) Pl_Err_Type(pl_type_list, list_word); } if (arity > MAX_ARITY) Pl_Err_Representation(pl_representation_max_arity); if (functor == ATOM_CHAR('.') && arity == 2) /* a list */ term_word = Tag_LST(stc_adr + 1); else { *stc_adr = Functor_Arity(functor, arity); term_word = Tag_STC(stc_adr); } finish: Bind_UV(term_adr, term_word); Pl_Unset_C_Bip_Name(); return TRUE; }