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