/*-------------------------------------------------------------------------*
* PUSH_DELAYED_CSTR *
* *
*-------------------------------------------------------------------------*/
static WamWord
Push_Delayed_Cstr(int cstr, WamWord a1, WamWord a2, WamWord a3)
{
WamWord res_word;
res_word = Make_Self_Ref(H);
Global_Push(res_word);
if (delay_sp - delay_cstr_stack >= DELAY_CSTR_STACK_SIZE)
Pl_Err_Resource(pl_resource_too_big_fd_constraint);
delay_sp->cstr = cstr;
delay_sp->a1 = a1;
delay_sp->a2 = a2;
delay_sp->a3 = a3;
delay_sp->res = res_word;
delay_sp++;
return res_word;
}
/*-------------------------------------------------------------------------*
* 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);
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* 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;
}