/*-------------------------------------------------------------------------*
* PL_FD_UNIFY_WITH_FD_VAR0 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Fd_Unify_With_Fd_Var0(WamWord *fdv_adr1, WamWord *fdv_adr2)
{
Bool pl_unify_x_y(WamWord x, WamWord y);
/* defined in fd_unify.fd as a constraint */
return pl_unify_x_y(Tag_REF(fdv_adr1), Tag_REF(fdv_adr2));
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* 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_RECOVER_SOLUTIONS_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Recover_Solutions_2(WamWord stop_word, WamWord handle_key_word,
WamWord list_word)
{
int stop;
int nb_sol;
WamWord *p, *q;
OneSol *s;
Bool handle_key;
stop = Pl_Rd_Integer(stop_word);
nb_sol = sol->sol_no - stop;
if (nb_sol == 0)
return Pl_Get_Nil(list_word);
handle_key = Pl_Rd_Integer(handle_key_word);
key_var_ptr = pl_glob_dico_var; /* pl_glob_dico_var: key vars */
H += 2 * nb_sol;
/* Since we start from the end to the beginning, if nb_sol is very big
* when the heap overflow triggers a SIGSEGV the handler will not detect
* that the heap is the culprit (and emits a simple Segmentation Violation
* message). To avoid this we remain just after the end of the stack.
*/
if (H > Global_Stack + Global_Size)
H = Global_Stack + Global_Size;
p = q = H;
while (nb_sol--)
{
p--;
*p = Tag_LST(p + 1);
*--p = Tag_REF(H);
Pl_Copy_Contiguous_Term(H, &sol->term_word);
if (handle_key)
Handle_Key_Variables(*H);
H += sol->term_size;
s = sol;
sol = sol->prev;
Free(s);
}
q[-1] = NIL_WORD;
return Pl_Unify(Tag_LST(p), list_word);
}
/*-------------------------------------------------------------------------*
* SET_NOT *
* *
*-------------------------------------------------------------------------*/
static Bool
Set_Not(WamWord *exp, int result, WamWord *load_word)
{
if (result == 0) /* ~X is false */
return Pl_Get_Integer(1, exp[1]);
if (result == 1) /* ~X is true */
return Pl_Get_Integer(0, exp[1]);
/* ~X=B */
*load_word = Tag_REF(Pl_Fd_New_Bool_Variable());
BOOL_CSTR_2(pl_not_x_eq_b, exp[1], *load_word);
return TRUE;
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* SET_NOR *
* *
*-------------------------------------------------------------------------*/
static Bool
Set_Nor(WamWord *exp, int result, WamWord *load_word)
{
WamWord load_l, load_r;
if (result <= 1) /* L ~\/ R is true or false */
return Set_Or(exp, 1 - result, load_word);
if (!Load_Bool_Into_Word((WamWord *) (exp[1]), 2, &load_l) ||
!Load_Bool_Into_Word((WamWord *) (exp[2]), 2, &load_r))
return FALSE;
/* L ~\/ R = B */
*load_word = Tag_REF(Pl_Fd_New_Bool_Variable());
BOOL_CSTR_3(pl_x_nor_y_eq_b, load_l, load_r, *load_word);
return TRUE;
}
/*-------------------------------------------------------------------------*
* FREE_VAR *
* *
*-------------------------------------------------------------------------*/
static void
Free_Var(WamWord *adr)
{
long *p;
WamWord word;
for (p = pl_glob_dico_var; p < bound_var_ptr; p++)
if (*p == (long) adr)
return;
word = Tag_REF(adr); /* if an FDV for a Dont_Separate_Tag */
for (p = free_var_base; p < H; p++)
if (*p == word)
return;
*H++ = word;
}
/*-------------------------------------------------------------------------*
* PL_RECOVER_SOLUTIONS_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Recover_Solutions_2(WamWord stop_word, WamWord handle_key_word,
WamWord list_word)
{
int stop;
int nb_sol;
WamWord *p, *q;
OneSol *s;
Bool handle_key;
stop = Pl_Rd_Integer(stop_word);
nb_sol = sol->sol_no - stop;
if (nb_sol == 0)
return Pl_Get_Nil(list_word);
handle_key = Pl_Rd_Integer(handle_key_word);
key_var_ptr = pl_glob_dico_var; /* pl_glob_dico_var: key vars */
H += 2 * nb_sol;
p = q = H;
while (nb_sol--)
{
p--;
*p = Tag_LST(p + 1);
*--p = Tag_REF(H);
Pl_Copy_Contiguous_Term(H, &sol->term_word);
if (handle_key)
Handle_Key_Variables(*H);
H += sol->term_size;
s = sol;
sol = sol->prev;
Free(s);
}
q[-1] = NIL_WORD;
return Pl_Unify(Tag_LST(p), list_word);
}
/*-------------------------------------------------------------------------*
* SET_EQUIV *
* *
*-------------------------------------------------------------------------*/
static Bool
Set_Equiv(WamWord *exp, int result, WamWord *load_word)
{
WamWord load_l, load_r;
if (!Load_Bool_Into_Word((WamWord *) (exp[1]), 2, &load_l) ||
!Load_Bool_Into_Word((WamWord *) (exp[2]), 2, &load_r))
return FALSE;
if (result == 0) /* L <=> R is false */
{
BOOL_CSTR_2(pl_not_x_eq_b, load_l, load_r);
return TRUE;
}
if (result == 1) /* L <=> R is true */
return Pl_Fd_Math_Unify_X_Y(load_l, load_r);
/* L <=> R = B */
*load_word = Tag_REF(Pl_Fd_New_Bool_Variable());
BOOL_CSTR_3(pl_x_equiv_y_eq_b, load_l, load_r, *load_word);
return TRUE;
}
/*-------------------------------------------------------------------------*
* SET_OR *
* *
*-------------------------------------------------------------------------*/
static Bool
Set_Or(WamWord *exp, int result, WamWord *load_word)
{
WamWord load_l, load_r;
if (result == 0) /* L \/ R is false */
return Load_Bool_Into_Word((WamWord *) (exp[1]), 0, NULL) &&
Load_Bool_Into_Word((WamWord *) (exp[2]), 0, NULL);
if (!Load_Bool_Into_Word((WamWord *) (exp[1]), 2, &load_l) ||
!Load_Bool_Into_Word((WamWord *) (exp[2]), 2, &load_r))
return FALSE;
if (result == 1) /* L \/ R is true */
{
BOOL_CSTR_2(pl_x_or_y_eq_1, load_l, load_r);
return TRUE;
}
/* L \/ R = B */
*load_word = Tag_REF(Pl_Fd_New_Bool_Variable());
BOOL_CSTR_3(pl_x_or_y_eq_b, load_l, load_r, *load_word);
return TRUE;
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* SET_LTE *
* *
*-------------------------------------------------------------------------*/
static Bool
Set_Lte(WamWord *exp, int result, WamWord *load_word)
{
WamWord le_word, re_word;
int mask;
WamWord l_word, r_word;
PlLong c;
le_word = exp[1];
re_word = exp[2];
if (result == 0) /* L <= R is false */
return Pl_Fd_Lt_2(re_word, le_word);
if (result == 1) /* L <= R is true */
return Pl_Fd_Lte_2(le_word, re_word);
*load_word = Tag_REF(Pl_Fd_New_Bool_Variable());
#ifdef DEBUG
cur_op = (pl_full_ac) ? "truth#=<#" : "truth#=<";
#endif
if (!Pl_Load_Left_Right(FALSE, le_word, re_word, &mask, &c, &l_word, &r_word)
|| !Pl_Term_Math_Loading(l_word, r_word))
return FALSE;
switch (mask)
{
case MASK_EMPTY:
return Pl_Get_Integer(c <= 0, *load_word);
case MASK_LEFT:
if (c > 0)
return Pl_Get_Integer(0, *load_word);
PRIM_CSTR_3(pl_truth_x_lte_c, l_word, Tag_INT(-c), *load_word);
return TRUE;
case MASK_RIGHT:
if (c <= 0)
return Pl_Get_Integer(1, *load_word);
PRIM_CSTR_3(pl_truth_x_gte_c, r_word, Tag_INT(c), *load_word);
return TRUE;
}
if (c > 0)
{
PRIM_CSTR_4(pl_truth_x_plus_c_lte_y, l_word, Tag_INT(c), r_word,
*load_word);
return TRUE;
}
if (c < 0)
{
PRIM_CSTR_4(pl_truth_x_plus_c_gte_y, r_word, Tag_INT(-c), l_word,
*load_word);
return TRUE;
}
PRIM_CSTR_3(pl_truth_x_lte_y, l_word, r_word, *load_word);
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;
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;
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* 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;
}
}
/*-------------------------------------------------------------------------*
* 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;
}
}
