/*-------------------------------------------------------------------------*/ 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; } }
/*-------------------------------------------------------------------------* * 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; }