/*-------------------------------------------------------------------------*
* PL_FD_PROLOG_TO_FD_VAR *
* *
*-------------------------------------------------------------------------*/
WamWord *
Pl_Fd_Prolog_To_Fd_Var(WamWord arg_word, Bool pl_var_ok)
{
WamWord word, tag_mask;
WamWord *adr, *fdv_adr;
DEREF(arg_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
{
if (!pl_var_ok)
Pl_Err_Instantiation();
adr = UnTag_REF(word);
fdv_adr = Pl_Fd_New_Variable();
Bind_UV(adr, Tag_REF(fdv_adr));
return fdv_adr;
}
if (tag_mask == TAG_INT_MASK)
return Pl_Fd_New_Int_Variable(UnTag_INT(word));
if (tag_mask == TAG_FDV_MASK)
return UnTag_FDV(word);
Pl_Err_Type(pl_type_fd_variable, word);
return NULL;
}
/*-------------------------------------------------------------------------*
* PL_TERM_MATH_LOADING *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Term_Math_Loading(WamWord l_word, WamWord r_word)
{
WamWord word, tag_mask;
WamWord *adr, *fdv_adr;
if (delay_sp != delay_cstr_stack)
{
#ifdef DEBUG
DBGPRINTF("\nnon Linear part\n");
#endif
if (!Load_Delay_Cstr_Part())
return FALSE;
}
while (--vars_sp >= vars_tbl)
{
DEREF(*vars_sp, word, tag_mask);
if (tag_mask == TAG_REF_MASK && word != l_word && word != r_word)
{
adr = UnTag_REF(word);
fdv_adr = Pl_Fd_New_Variable();
Bind_UV(adr, Tag_REF(fdv_adr));
}
}
return TRUE;
}
/*-------------------------------------------------------------------------*
* CHECK_VARIABLE *
* *
*-------------------------------------------------------------------------*/
static Bool
Check_Variable(WamWord *adr, WamWord var_word)
{
WamWord word, tag_mask;
WamWord *adr1;
PlLong *p;
if (Tag_Of(var_word) == FDV) /* improve FDV */
return FALSE;
for (p = pl_glob_dico_var; p < base_var_ptr; p++) /* check if already found until now */
if (*p == (PlLong) adr) /* test if already present (thus well dereferenced) */
return TRUE;
if (base_var_ptr >= var_ptr)
return FALSE; /* not found */
/* check if Specific has been modified (also deref which is important) */
DEREF(*base_var_ptr, word, tag_mask);
if (Tag_Of(word) != REF) /* TODO: treat FD vars */
return FALSE; /* specific has been instantiated - no longer a var */
adr1 = UnTag_REF(word); /* save dereferenced adr */
if (adr1 != adr) /* check if it is the current variable */
return FALSE; /* not ok */
*base_var_ptr = (PlLong) adr1; /* replace adr by dereferenced adr */
base_var_ptr++;
return TRUE;
}
/*-------------------------------------------------------------------------*
* PL_FD_CHECK_FOR_BOOL_VAR *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Fd_Check_For_Bool_Var(WamWord x_word)
{
WamWord word, tag_mask;
WamWord *adr, *fdv_adr;
Range range;
DEREF(x_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
{
adr = UnTag_REF(word);
fdv_adr = Pl_Fd_New_Bool_Variable();
Bind_UV(adr, Tag_REF(fdv_adr));
return TRUE;
}
if (tag_mask == TAG_INT_MASK)
return (unsigned long) (UnTag_INT(word)) <= 1;
if (tag_mask != TAG_FDV_MASK)
Pl_Err_Type(pl_type_fd_variable, word);
fdv_adr = UnTag_FDV(word);
if (Min(fdv_adr) > 1)
return FALSE;
if (Max(fdv_adr) <= 1)
return TRUE;
/* here max > 1 */
if (Min(fdv_adr) == 1)
return Pl_Fd_Unify_With_Integer0(fdv_adr, 1);
/* here min == 0 */
if (!Pl_Range_Test_Value(Range(fdv_adr), 1))
return Pl_Fd_Unify_With_Integer0(fdv_adr, 0);
/* Check Bool == X in 0..1 */
Pl_Fd_Before_Add_Cstr();
if (Is_Sparse(Range(fdv_adr)))
{
Range_Init_Interval(&range, 0, 1);
if (!Pl_Fd_Tell_Range_Range(fdv_adr, &range))
return FALSE;
}
else if (!Pl_Fd_Tell_Interv_Interv(fdv_adr, 0, 1))
return FALSE;
return Pl_Fd_After_Add_Cstr();
}
/*-------------------------------------------------------------------------*
* PL_FD_BOOL_META_3 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Fd_Bool_Meta_3(WamWord le_word, WamWord re_word, WamWord op_word)
{
WamWord word, tag_mask;
WamWord *adr, *fdv_adr;
WamWord *exp;
int op;
static WamWord h[3]; /* static to avoid high address */
DEREF(op_word, word, tag_mask);
op = UnTag_INT(op_word);
h[0] = bool_tbl[op]; /* also works for NOT/1 */
h[1] = le_word;
h[2] = re_word;
sp = stack;
vars_sp = vars_tbl;
exp = Simplify(1, Tag_STC(h));
#ifdef DEBUG
Display_Stack(exp);
DBGPRINTF("\n");
#endif
if (!Load_Bool_Into_Word(exp, 1, NULL))
return FALSE;
while (--vars_sp >= vars_tbl)
if (*vars_sp-- == 0) /* bool var */
{
if (!Pl_Fd_Check_For_Bool_Var(*vars_sp))
return FALSE;
}
else /* FD var */
{
DEREF(*vars_sp, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
{
adr = UnTag_REF(word);
fdv_adr = Pl_Fd_New_Variable();
Bind_UV(adr, Tag_REF(fdv_adr));
}
}
return TRUE;
}
/*-------------------------------------------------------------------------*
* 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;
}
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* PL_TERM_REF_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Term_Ref_2(WamWord term_word, WamWord ref_word)
{
WamWord word, tag_mask;
WamWord word1, *adr;
int ref;
/* my own DEREF here to get the address */
adr = NULL; /* added this */
word = term_word;
do
{
word1 = word;
tag_mask = Tag_Mask_Of(word);
if (tag_mask != TAG_REF_MASK)
break;
adr = UnTag_REF(word); /* added this */
word = *adr;
}
while (word != word1);
if (tag_mask == TAG_REF_MASK)
{
ref = Pl_Rd_Positive_Check(ref_word);
adr = Global_Stack + ref;
return Pl_Unify(word, *adr);
}
if (adr < Global_Stack || adr > H)
{
adr = H;
Global_Push(word);
}
ref = Global_Offset(adr);
return Pl_Un_Positive_Check(ref, ref_word);
}
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;
}
}
/*-------------------------------------------------------------------------*
* 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;
}
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* PL_FD_REIFIED_IN *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Fd_Reified_In(WamWord x_word, WamWord l_word, WamWord u_word, WamWord b_word)
{
WamWord word, tag_mask;
WamWord b_tag_mask, x_tag_mask;
WamWord *adr, *fdv_adr;
PlLong x;
PlLong b = -1; /* a var */
int min, max;
int x_min, x_max;
Range *r;
// Bool pl_fd_domain(WamWord x_word, WamWord l_word, WamWord u_word);
/* from fd_values_c.c (optimized version) */
Bool Pl_Fd_Domain_Interval(WamWord x_word, int min, int max);
/* from fd_values_fd.fd */
Bool pl_fd_not_domain(WamWord x_word, WamWord l_word, WamWord u_word);
min = Pl_Fd_Prolog_To_Value(l_word);
if (min < 0)
min = 0;
max = Pl_Fd_Prolog_To_Value(u_word);
DEREF(x_word, word, tag_mask);
x_word = word;
x_tag_mask = tag_mask;
if (tag_mask != TAG_REF_MASK && tag_mask != TAG_FDV_MASK && tag_mask != TAG_INT_MASK)
{
err_type_fd:
Pl_Err_Type(pl_type_fd_variable, word);
return FALSE;
}
DEREF(b_word, word, tag_mask);
b_word = word;
b_tag_mask = tag_mask;
if (tag_mask != TAG_REF_MASK && tag_mask != TAG_FDV_MASK && tag_mask != TAG_INT_MASK)
goto err_type_fd;
if (x_tag_mask == TAG_INT_MASK)
{
x = UnTag_INT(x_word);
b = (x >= min) && (x <= max);
unif_b:
return Pl_Get_Integer(b, b_word);
}
if (b_tag_mask == TAG_INT_MASK)
{
b = UnTag_INT(b_word);
if (b == 0)
return pl_fd_not_domain(x_word, l_word, u_word);
return (b == 1) && Pl_Fd_Domain_Interval(x_word, min, max);
}
if (x_tag_mask == TAG_REF_MASK) /* make an FD var */
{
adr = UnTag_REF(x_word);
fdv_adr = Pl_Fd_New_Variable();
Bind_UV(adr, Tag_REF(fdv_adr));
}
else
fdv_adr = UnTag_FDV(x_word);
r = Range(fdv_adr);
x_min = r->min;
x_max = r->max;
if (x_min >= min && x_max <= max)
{
b = 1;
goto unif_b;
}
if (min > max || x_max < min || x_min > max) /* NB: if L..U is empty then B = 0 */
{
b = 0;
goto unif_b;
}
if (!Pl_Fd_Check_For_Bool_Var(b_word))
return FALSE;
PRIM_CSTR_4(pl_truth_x_in_l_u, x_word, l_word, u_word, b_word);
return TRUE;
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* PL_TERM_COMPARE *
* *
*-------------------------------------------------------------------------*/
long
Pl_Term_Compare(WamWord start_u_word, WamWord start_v_word)
{
WamWord u_word, u_tag_mask;
WamWord v_word, v_tag_mask;
WamWord u_tag, v_tag;
int u_func, u_arity;
WamWord *u_arg_adr;
int v_func, v_arity;
WamWord *v_arg_adr;
int i, x;
double d1, d2;
DEREF(start_u_word, u_word, u_tag_mask);
DEREF(start_v_word, v_word, v_tag_mask);
u_tag = Tag_From_Tag_Mask(u_tag_mask);
v_tag = Tag_From_Tag_Mask(v_tag_mask);
switch (u_tag)
{
case REF:
return (v_tag != REF) ? -1 : UnTag_REF(u_word) - UnTag_REF(v_word);
#ifndef NO_USE_FD_SOLVER
case FDV:
if (v_tag == REF)
return 1;
return (v_tag != FDV) ? -1 : UnTag_FDV(u_word) - UnTag_FDV(v_word);
#endif
case FLT:
if (v_tag == REF
#ifndef NO_USE_FD_SOLVER
|| v_tag == FDV
#endif
)
return 1;
if (v_tag != FLT)
return -1;
d1 = Pl_Obtain_Float(UnTag_FLT(u_word));
d2 = Pl_Obtain_Float(UnTag_FLT(v_word));
return (d1 < d2) ? -1 : (d1 == d2) ? 0 : 1;
case INT:
if (v_tag == REF ||
#ifndef NO_USE_FD_SOLVER
v_tag == FDV ||
#endif
v_tag == FLT)
return 1;
return (v_tag != INT) ? -1 : UnTag_INT(u_word) - UnTag_INT(v_word);
case ATM:
if (v_tag == REF ||
#ifndef NO_USE_FD_SOLVER
v_tag == FDV ||
#endif
v_tag == FLT || v_tag == INT)
return 1;
return (v_tag != ATM) ? -1 : strcmp(pl_atom_tbl[UnTag_ATM(u_word)].name,
pl_atom_tbl[UnTag_ATM(v_word)].name);
}
/* u_tag == LST / STC */
v_arg_adr = Pl_Rd_Compound(v_word, &v_func, &v_arity);
if (v_arg_adr == NULL) /* v_tag != LST / STC */
return 1;
u_arg_adr = Pl_Rd_Compound(u_word, &u_func, &u_arity);
if (u_arity != v_arity)
return u_arity - v_arity;
if (u_func != v_func)
return strcmp(pl_atom_tbl[u_func].name, pl_atom_tbl[v_func].name);
for (i = 0; i < u_arity; i++)
if ((x = Pl_Term_Compare(*u_arg_adr++, *v_arg_adr++)) != 0)
return x;
return 0;
}
/*-------------------------------------------------------------------------*
* 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;
}
}
/*-------------------------------------------------------------------------*
* PL_FD_REIFIED_IN *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Fd_Reified_In(WamWord x_word, WamWord l_word, WamWord u_word, WamWord b_word)
{
WamWord word, tag_mask;
WamWord b_tag_mask, x_tag_mask;
WamWord *adr, *fdv_adr;
int x;
int l = Pl_Rd_Integer_Check(l_word);
int u = Pl_Rd_Integer_Check(u_word);
int b = -1; /* a var */
Range *r;
int x_min, x_max;
Bool pl_fd_domain(WamWord x_word, WamWord l_word, WamWord u_word);
Bool pl_fd_not_domain(WamWord x_word, WamWord l_word, WamWord u_word);
DEREF(x_word, word, tag_mask);
x_word = word;
x_tag_mask = tag_mask;
if (tag_mask != TAG_REF_MASK && tag_mask != TAG_FDV_MASK && tag_mask != TAG_INT_MASK)
{
err_type_fd:
Pl_Err_Type(pl_type_fd_variable, word);
return FALSE;
}
DEREF(b_word, word, tag_mask);
b_word = word;
b_tag_mask = tag_mask;
if (tag_mask != TAG_REF_MASK && tag_mask != TAG_FDV_MASK && tag_mask != TAG_INT_MASK)
goto err_type_fd;
if (x_tag_mask == TAG_INT_MASK)
{
x = UnTag_INT(x_word);
b = (x >= l) && (x <= u);
unif_b:
return Pl_Get_Integer(b, b_word);
}
if (b_tag_mask == TAG_INT_MASK)
{
b = UnTag_INT(b_word);
if (b == 0)
return pl_fd_not_domain(x_word, l_word, u_word);
return (b == 1) && pl_fd_domain(x_word, l_word, u_word);
}
if (x_tag_mask == TAG_REF_MASK) /* make an FD var */
{
adr = UnTag_REF(x_word);
fdv_adr = Pl_Fd_New_Variable();
Bind_UV(adr, Tag_REF(fdv_adr));
}
else
fdv_adr = UnTag_FDV(x_word);
r = Range(fdv_adr);
x_min = r->min;
x_max = r->max;
if (x_min >= l && x_max <= u)
{
b = 1;
goto unif_b;
}
if (l > u || x_max < l || x_min > u) /* NB: if L..U is empty then B = 0 */
{
b = 0;
goto unif_b;
}
if (!Pl_Fd_Check_For_Bool_Var(b_word))
return FALSE;
PRIM_CSTR_4(pl_truth_x_in_l_u, x_word, l_word, u_word, b_word);
return TRUE;
}
