WamWord FC
Pl_Fct_Fast_Mul(WamWord x, WamWord y)
{
long vx = UnTag_INT(x);
long vy = UnTag_INT(y);
return Tag_INT(vx * vy);
}
WamWord FC
Pl_Fct_Fast_Shr(WamWord x, WamWord y)
{
long vx = UnTag_INT(x);
long vy = UnTag_INT(y);
return Tag_INT(vx >> vy);
}
Bool FC
Pl_Blt_Fast_Gte(WamWord x, WamWord y)
{
long vx = UnTag_INT(x);
long vy = UnTag_INT(y);
return vx >= vy;
}
WamWord FC
Pl_Fct_Fast_Rem(WamWord x, WamWord y)
{
long vx = UnTag_INT(x);
long vy = UnTag_INT(y);
if (vy == 0)
Pl_Err_Evaluation(pl_evluation_zero_divisor);
return Tag_INT(vx % vy);
}
/*-------------------------------------------------------------------------*
* PL_NUMBER_CODES_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Number_Codes_2(WamWord number_word, WamWord codes_word)
{
WamWord word, tag_mask;
WamWord *lst_adr, list_word;
char *str = pl_glob_buff;
PlLong c;
list_word = codes_word;
for (;;)
{
DEREF(list_word, word, tag_mask);
if (word == NIL_WORD)
break;
if (tag_mask != TAG_LST_MASK)
goto from_nb;
lst_adr = UnTag_LST(word);
DEREF(Car(lst_adr), word, tag_mask);
c = UnTag_INT(word);
if (tag_mask != TAG_INT_MASK || !Is_Valid_Code(c))
goto from_nb;
*str++ = (char) c;
list_word = Cdr(lst_adr);
}
*str = '\0';
return String_To_Number(pl_glob_buff, number_word);
from_nb:
DEREF(number_word, word, tag_mask);
if (tag_mask == TAG_INT_MASK)
{
sprintf(pl_glob_buff, "%" PL_FMT_d, UnTag_INT(word));
return Pl_Un_Codes_Check(pl_glob_buff, codes_word);
}
if (tag_mask != TAG_REF_MASK)
{
str = Pl_Float_To_String(Pl_Rd_Number_Check(word));
return Pl_Un_Codes_Check(str, codes_word);
}
Pl_Rd_Codes_Check(codes_word); /* only to raise the correct error */
return FALSE;
}
/*-------------------------------------------------------------------------*
* PL_CURRENT_STREAM_1 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Current_Stream_1(WamWord stm_word)
{
WamWord word, tag_mask;
int stm = 0;
DEREF(stm_word, word, tag_mask); /* either an INT or a REF */
if (tag_mask == TAG_INT_MASK)
{
stm = UnTag_INT(word);
return (stm >= 0 && stm <= pl_stm_last_used && pl_stm_tbl[stm] != NULL);
}
for (; stm <= pl_stm_last_used; stm++)
if (pl_stm_tbl[stm])
break;
if (stm >= pl_stm_last_used)
{
if (stm > pl_stm_last_used)
return FALSE;
}
else /* non deterministic case */
{
A(0) = stm_word;
A(1) = stm + 1;
Pl_Create_Choice_Point((CodePtr) Prolog_Predicate(CURRENT_STREAM_ALT, 0),
2);
}
return Pl_Get_Integer(stm, stm_word);
}
/*-------------------------------------------------------------------------*
* 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;
}
WamWord FC
Pl_Fct_Fast_Mod(WamWord x, WamWord y)
{
long vx = UnTag_INT(x);
long vy = UnTag_INT(y);
long m;
if (vy == 0)
Pl_Err_Evaluation(pl_evluation_zero_divisor);
m = vx % vy;
if (m != 0 && (m ^ vy) < 0) /* have m and vy different signs ? */
m += vy;
return Tag_INT(m);
}
/*-------------------------------------------------------------------------*
* PL_CURRENT_PREDICATE_ALT_0 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Current_Predicate_Alt_0(void)
{
WamWord name_word, arity_word;
HashScan scan;
PredInf *pred;
int which_preds;
int func, arity;
int func1, arity1;
Bool all;
Pl_Update_Choice_Point((CodePtr) Prolog_Predicate(CURRENT_PREDICATE_ALT, 0),
0);
name_word = AB(B, 0);
arity_word = AB(B, 1);
which_preds = AB(B, 2);
scan.endt = (char *) AB(B, 3);
scan.cur_t = (char *) AB(B, 4);
scan.cur_p = (char *) AB(B, 5);
func = Tag_Mask_Of(name_word) == TAG_REF_MASK ? -1 : UnTag_ATM(name_word);
arity = Tag_Mask_Of(arity_word) == TAG_REF_MASK ? -1 : UnTag_INT(arity_word);
/* here func or arity == -1 (or both) */
all = (func == -1 && arity == -1);
for (;;)
{
pred = (PredInf *) Pl_Hash_Next(&scan);
if (pred == NULL)
{
Delete_Last_Choice_Point();
return FALSE;
}
func1 = Functor_Of(pred->f_n);
arity1 = Arity_Of(pred->f_n);
if ((all || func == func1 || arity == arity1) &&
Pred_Is_Ok(pred, func1, which_preds))
break;
}
/* non deterministic case */
#if 0 /* the following data is unchanged */
AB(B, 0) = name_word;
AB(B, 1) = arity_word;
AB(B, 2) = which_preds;
AB(B, 3) = (WamWord) scan.endt;
#endif
AB(B, 4) = (WamWord) scan.cur_t;
AB(B, 5) = (WamWord) scan.cur_p;
return Pl_Get_Atom(Functor_Of(pred->f_n), name_word) &&
Pl_Get_Integer(Arity_Of(pred->f_n), arity_word);
}
/*-------------------------------------------------------------------------*
* PL_FD_PROLOG_TO_ARRAY_INT *
* *
*-------------------------------------------------------------------------*/
WamWord *
Pl_Fd_Prolog_To_Array_Int(WamWord list_word)
{
WamWord word, tag_mask;
WamWord save_list_word;
WamWord *lst_adr;
WamWord val;
int n = 0;
WamWord *array;
WamWord *save_array;
array = CS;
save_list_word = list_word;
save_array = array;
array++; /* +1 for the nb of elems */
for (;;)
{
DEREF(list_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (word == NIL_WORD)
break;
if (tag_mask != TAG_LST_MASK)
Pl_Err_Type(pl_type_list, save_list_word);
lst_adr = UnTag_LST(word);
DEREF(Car(lst_adr), word, tag_mask);
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (tag_mask != TAG_INT_MASK)
Pl_Err_Type(pl_type_integer, word);
val = UnTag_INT(word);
*array++ = val;
n++;
list_word = Cdr(lst_adr);
}
*save_array = n;
CS = array;
return save_array;
}
/*-------------------------------------------------------------------------*
* PL_FD_LIST_INT_TO_RANGE *
* *
*-------------------------------------------------------------------------*/
void
Pl_Fd_List_Int_To_Range(Range *range, WamWord list_word)
{
WamWord word, tag_mask;
WamWord save_list_word;
WamWord *lst_adr;
WamWord val;
int n = 0;
save_list_word = list_word;
range->extra_cstr = FALSE;
Vector_Allocate_If_Necessary(range->vec);
Pl_Vector_Empty(range->vec);
for (;;)
{
DEREF(list_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (word == NIL_WORD)
break;
if (tag_mask != TAG_LST_MASK)
Pl_Err_Type(pl_type_list, save_list_word);
lst_adr = UnTag_LST(word);
DEREF(Car(lst_adr), word, tag_mask);
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (tag_mask != TAG_INT_MASK)
Pl_Err_Type(pl_type_integer, word);
val = UnTag_INT(word);
if ((unsigned) val > (unsigned) pl_vec_max_integer)
range->extra_cstr = TRUE;
else
{
Vector_Set_Value(range->vec, val);
n++;
}
list_word = Cdr(lst_adr);
}
if (n == 0)
Set_To_Empty(range);
else
Pl_Range_From_Vector(range);
}
/*-------------------------------------------------------------------------*
* 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_FD_MIN_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Fd_Min_2(WamWord fdv_word, WamWord min_word)
{
WamWord word, tag_mask;
int n;
Fd_Deref_Check_Fd_Var(fdv_word, word, tag_mask);
if (tag_mask == TAG_INT_MASK)
n = UnTag_INT(word);
else
n = Min(UnTag_FDV(word));
return Pl_Un_Integer_Check(n, min_word);
}
/*-------------------------------------------------------------------------*
* PL_NUMBER_CHARS_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Number_Chars_2(WamWord number_word, WamWord chars_word)
{
WamWord word, tag_mask;
WamWord *lst_adr, list_word;
char *str = pl_glob_buff;
int atom;
list_word = chars_word;
for (;;)
{
DEREF(list_word, word, tag_mask);
if (word == NIL_WORD)
break;
if (tag_mask != TAG_LST_MASK)
goto from_nb;
lst_adr = UnTag_LST(word);
DEREF(Car(lst_adr), word, tag_mask);
atom = UnTag_ATM(word);
if (tag_mask != TAG_ATM_MASK || pl_atom_tbl[atom].prop.length != 1)
goto from_nb;
*str++ = pl_atom_tbl[atom].name[0];
list_word = Cdr(lst_adr);
}
*str = '\0';
return String_To_Number(pl_glob_buff, number_word);
from_nb:
DEREF(number_word, word, tag_mask);
if (tag_mask == TAG_INT_MASK)
{
sprintf(pl_glob_buff, "%" PL_FMT_d, UnTag_INT(word));
return Pl_Un_Chars_Check(pl_glob_buff, chars_word);
}
if (tag_mask != TAG_REF_MASK)
{
str = Pl_Float_To_String(Pl_Rd_Number_Check(word));
return Pl_Un_Chars_Check(str, chars_word);
}
Pl_Rd_Chars_Check(chars_word); /* only to raise the correct error */
return FALSE;
}
/*-------------------------------------------------------------------------*
* PL_FD_DOM_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Fd_Dom_2(WamWord fdv_word, WamWord list_word)
{
WamWord word, tag_mask;
WamWord *fdv_adr;
int x, end;
int vec_elem;
Pl_Check_For_Un_List(list_word);
Fd_Deref_Check_Fd_Var(fdv_word, word, tag_mask);
if (tag_mask == TAG_INT_MASK)
{
x = UnTag_INT(word);
if (!Pl_Get_List(list_word) || !Pl_Unify_Integer(x))
return FALSE;
list_word = Pl_Unify_Variable();
}
else
{
fdv_adr = UnTag_FDV(word);
if (Is_Interval(Range(fdv_adr)))
{
end = Max(fdv_adr);
for (x = Min(fdv_adr); x <= end; x++)
{
if (!Pl_Get_List(list_word) || !Pl_Unify_Integer(x))
return FALSE;
list_word = Pl_Unify_Variable();
}
}
else
{
VECTOR_BEGIN_ENUM(Vec(fdv_adr), vec_elem);
if (!Pl_Get_List(list_word) || !Pl_Unify_Integer(vec_elem))
return FALSE;
list_word = Pl_Unify_Variable();
VECTOR_END_ENUM;
}
}
return Pl_Get_Nil(list_word);
}
/*-------------------------------------------------------------------------*
* PL_FD_PROLOG_TO_VALUE *
* *
*-------------------------------------------------------------------------*/
int
Pl_Fd_Prolog_To_Value(WamWord arg_word)
{
WamWord word, tag_mask;
DEREF(arg_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (tag_mask != TAG_INT_MASK)
Pl_Err_Type(pl_type_integer, word);
return UnTag_INT(word);
}
/*-------------------------------------------------------------------------*
* PL_SET_STREAM_POSITION_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Set_Stream_Position_2(WamWord sora_word, WamWord position_word)
{
WamWord word, tag_mask;
WamWord p_word[4];
int p[4];
int i;
int stm;
StmInf *pstm;
stm = Pl_Get_Stream_Or_Alias(sora_word, STREAM_CHECK_EXIST);
pstm = pl_stm_tbl[stm];
if (!pstm->prop.reposition)
Pl_Err_Permission(pl_permission_operation_reposition,
pl_permission_type_stream, sora_word);
DEREF(position_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (!Pl_Get_Structure(pl_atom_stream_position, 4, position_word))
dom_error:
Pl_Err_Domain(pl_domain_stream_position, position_word);
for (i = 0; i < 4; i++)
{
p_word[i] = Pl_Unify_Variable();
DEREF(p_word[i], word, tag_mask);
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (tag_mask != TAG_INT_MASK)
goto dom_error;
p[i] = UnTag_INT(word);
}
return Pl_Stream_Set_Position(pstm, SEEK_SET, p[0], p[1], p[2], p[3]) == 0;
}
/*-------------------------------------------------------------------------*
* PL_NUMBER_ATOM_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Number_Atom_2(WamWord number_word, WamWord atom_word)
{
WamWord word, tag_mask;
char *str;
DEREF(atom_word, word, tag_mask);
if (tag_mask == TAG_ATM_MASK)
return String_To_Number(pl_atom_tbl[UnTag_ATM(word)].name, number_word);
if (tag_mask != TAG_REF_MASK)
Pl_Err_Type(pl_type_atom, word);
DEREF(number_word, word, tag_mask);
if (tag_mask == TAG_INT_MASK)
{
sprintf(pl_glob_buff, "%" PL_FMT_d, UnTag_INT(word));
return Pl_Un_String_Check(pl_glob_buff, atom_word);
}
str = Pl_Float_To_String(Pl_Rd_Number_Check(word));
return Pl_Un_String_Check(str, atom_word);
}
/*-------------------------------------------------------------------------*
* 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;
}
}
WamWord FC
Pl_Fct_Fast_Sign(WamWord x)
{
long vx = UnTag_INT(x);
return (vx < 0) ? Tag_INT(-1) : (vx == 0) ? Tag_INT(0) : Tag_INT(1);
}
WamWord FC
Pl_Fct_Fast_Abs(WamWord x)
{
long vx = UnTag_INT(x);
return (vx < 0) ? Tag_INT(-vx) : x;
}
/*-------------------------------------------------------------------------*
* 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;
}
WamWord FC
Pl_Fct_Fast_Not(WamWord x)
{
long vx = UnTag_INT(x);
return Tag_INT(~vx);
}
WamWord FC
Pl_Fct_Fast_Dec(WamWord x)
{
long vx = UnTag_INT(x);
return Tag_INT(vx - 1);
}
WamWord FC
Pl_Fct_Fast_Inc(WamWord x)
{
long vx = UnTag_INT(x);
return Tag_INT(vx + 1);
}
WamWord FC
Pl_Fct_Fast_Neg(WamWord x)
{
long vx = UnTag_INT(x);
return Tag_INT(-vx);
}
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_STRUCTURE *
* *
*-------------------------------------------------------------------------*/
static void
Show_Structure(int depth, int prec, int context, WamWord *stc_adr)
{
WamWord word, tag_mask;
WamWord *adr;
WamWord f_n = Functor_And_Arity(stc_adr);
int functor = Functor(stc_adr);
int arity = Arity(stc_adr);
OperInf *oper;
int nb_args_to_disp;
int i, j, n;
char str[32];
Bool bracket;
Bool surround_space;
char *p;
depth--;
if (name_vars && f_n == dollar_varname_1 && stc_adr >= name_number_above_H)
{
DEREF(Arg(stc_adr, 0), word, tag_mask);
if (tag_mask == TAG_ATM_MASK)
{
p = pl_atom_tbl[UnTag_ATM(word)].name;
if (Is_Valid_Var_Name(p))
{
Out_String(p);
pl_last_writing = W_IDENTIFIER;
return;
}
}
}
if (number_vars && f_n == dollar_var_1 && stc_adr >= name_number_above_H)
{
DEREF(Arg(stc_adr, 0), word, tag_mask);
if (tag_mask == TAG_INT_MASK && (n = UnTag_INT(word)) >= 0)
{
i = n % 26;
j = n / 26;
Out_Char('A' + i);
if (j)
{
sprintf(str, "%d", j);
Out_String(str);
}
pl_last_writing = W_IDENTIFIER;
return;
}
}
if (ignore_op || arity > 2)
goto functional;
if (f_n == curly_brackets_1)
{
Out_Char('{');
if (space_args)
Out_Space();
Show_Term(depth, MAX_PREC, GENERAL_TERM, Arg(stc_adr, 0));
if (space_args)
Out_Space();
Out_Char('}');
return;
}
bracket = FALSE;
if (arity == 1 && (oper = Pl_Lookup_Oper(functor, PREFIX)))
{
#if 1
/* Koen de Bosschere says "in case of ambiguity : */
/* select the associative operator over the nonassociative */
/* select prefix over postfix". */
OperInf *oper1;
if (oper->prec > oper->right
&& (oper1 = Pl_Lookup_Oper(functor, POSTFIX))
&& oper1->left == oper1->prec)
{
oper = oper1;
goto postfix;
}
#endif
if (oper->prec > prec || (context == INSIDE_LEFT_ASSOC_OP &&
(oper->prec == oper->right
&& oper->prec == prec)))
{ /* prevent also the case: fy T yf(x) */
Out_Char('(');
bracket = TRUE;
}
Show_Atom(GENERAL_TERM, functor);
last_prefix_op = W_PREFIX_OP_ANY;
if (space_args
#if SPACE_ARGS_RESTRICTED /* space_args -> space after fx operator */
&& oper->prec > oper->right
#endif
)
Out_Space();
else
if (strcmp(pl_atom_tbl[functor].name, "-") == 0)
{
last_prefix_op = W_PREFIX_OP_MINUS;
p_bracket_minus = &bracket;
}
Show_Term(depth, oper->right, INSIDE_ANY_OP, Arg(stc_adr, 0));
last_prefix_op = W_NO_PREFIX_OP;
/* Here we need a while(bracket--) instead of if(bracket) because
* in some cases with the minus op and additional bracket is needed.
* Example: with op(100, xfx, &) (recall the prec of - is 200).
* The term ((-(1)) & b must be displayed as: (- (1)) & b
* Concerning the sub-term - (1), the first ( is emitted 10 lines above
* because the precedence of - (200) is > precedence of & (100).
* The second ( is emitted by Need_Space() because the argument of - begins
* by a digit. At the return we have to close 2 ).
*/
while (bracket--)
Out_Char(')');
return;
}
if (arity == 1 && (oper = Pl_Lookup_Oper(functor, POSTFIX)))
{
postfix:
if (oper->prec > prec)
{
Out_Char('(');
bracket = TRUE;
}
context =
(oper->left == oper->prec) ? INSIDE_LEFT_ASSOC_OP : INSIDE_ANY_OP;
Show_Term(depth, oper->left, context, Arg(stc_adr, 0));
if (space_args
#if SPACE_ARGS_RESTRICTED /* space_args -> space before xf operator */
&& oper->prec > oper->left
#endif
)
Out_Space();
Show_Atom(GENERAL_TERM, functor);
if (bracket)
Out_Char(')');
return;
}
if (arity == 2 && (oper = Pl_Lookup_Oper(functor, INFIX)))
{
if (oper->prec > prec || (context == INSIDE_LEFT_ASSOC_OP &&
(oper->prec == oper->right
&& oper->prec == prec)))
{ /* prevent also the case: T xfy U yf(x) */
Out_Char('(');
bracket = TRUE;
}
context =
(oper->left == oper->prec) ? INSIDE_LEFT_ASSOC_OP : INSIDE_ANY_OP;
Show_Term(depth, oper->left, context, Arg(stc_adr, 0));
#if 1 /* to show | unquoted if it is an infix operator with prec > 1000 */
if (functor == ATOM_CHAR('|') && oper->prec > 1000)
{
if (space_args)
Out_Space();
Out_Char('|');
if (space_args)
Out_Space();
}
else
#endif
if (functor == ATOM_CHAR(','))
{
Out_Char(',');
if (space_args)
Out_Space();
}
else
{
surround_space = FALSE;
if (pl_atom_tbl[functor].prop.type == IDENTIFIER_ATOM ||
pl_atom_tbl[functor].prop.type == OTHER_ATOM ||
(space_args
#ifdef SPACE_ARGS_RESTRICTED /* space_args -> space around xfx operators */
&& oper->left != oper->prec && oper->right != oper->prec
#endif
))
{
surround_space = TRUE;
Out_Space();
}
Show_Atom(GENERAL_TERM, functor);
if (surround_space)
Out_Space();
}
Show_Term(depth, oper->right, INSIDE_ANY_OP, Arg(stc_adr, 1));
if (bracket)
Out_Char(')');
return;
}
functional: /* functional notation */
Show_Atom(GENERAL_TERM, functor);
Out_Char('(');
nb_args_to_disp = i = (arity < depth + 1 || depth < 0) ? arity : depth + 1;
adr = &Arg(stc_adr, 0);
goto start_display;
do
{
Out_Char(',');
if (space_args)
Out_Space();
start_display:
Show_Term(depth, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, *adr++);
}
while (--i);
if (arity != nb_args_to_disp)
{
Out_Char(',');
if (space_args)
Out_Space();
Show_Atom(GENERAL_TERM, atom_dots);
}
Out_Char(')');
}
/*-------------------------------------------------------------------------*
* TO_DOUBLE *
* *
*-------------------------------------------------------------------------*/
static double
To_Double(WamWord x)
{
return (Tag_Is_INT(x)) ? (double) (UnTag_INT(x)) :
Pl_Obtain_Float(UnTag_FLT(x));
}
