/*-------------------------------------------------------------------------*
* PL_BLT_COMPARE *
* *
*-------------------------------------------------------------------------*/
Bool FC
Pl_Blt_Compare(WamWord cmp_word, WamWord x, WamWord y)
{
int cmp;
char c;
Bool res;
Pl_Set_C_Bip_Name("compare", 3);
cmp = Pl_Term_Compare(x, y);
c = (cmp < 0) ? '<' : (cmp == 0) ? '=' : '>';
res = Pl_Un_Atom_Check(ATOM_CHAR(c), cmp_word);
if (!res) /* check if it is one of < = > */
{
WamWord word, tag_mask;
char *s;
DEREF(cmp_word, word, tag_mask); /* we know it is an atom */
s = pl_atom_tbl[UnTag_ATM(word)].name;
if ((s[0] != '<' && s[0] != '=' && s[0] != '>') || s[1] != '\0')
Pl_Err_Domain(pl_domain_order, cmp_word);
}
Pl_Unset_C_Bip_Name();
return res;
}
/*-------------------------------------------------------------------------*
* PL_GET_PRED_INDICATOR *
* *
* returns the functor and initializes the arity of the predicate indicator*
* func= -1 if it is a variable, arity= -1 if it is a variable *
*-------------------------------------------------------------------------*/
int
Pl_Get_Pred_Indicator(WamWord pred_indic_word, Bool must_be_ground, int *arity)
{
WamWord word, tag_mask;
int func;
DEREF(pred_indic_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK && must_be_ground)
Pl_Err_Instantiation();
if (!Pl_Get_Structure(ATOM_CHAR('/'), 2, pred_indic_word))
{
if (!Flag_Value(FLAG_STRICT_ISO) &&
Pl_Rd_Callable(word, &func, arity) != NULL)
return func;
Pl_Err_Type(pl_type_predicate_indicator, pred_indic_word);
}
pl_pi_name_word = Pl_Unify_Variable();
pl_pi_arity_word = Pl_Unify_Variable();
if (must_be_ground)
func = Pl_Rd_Atom_Check(pl_pi_name_word);
else
{
DEREF(pl_pi_name_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
func = -1;
else
func = Pl_Rd_Atom_Check(pl_pi_name_word);
}
if (must_be_ground)
{
*arity = Pl_Rd_Positive_Check(pl_pi_arity_word);
if (*arity > MAX_ARITY)
Pl_Err_Representation(pl_representation_max_arity);
}
else
{
DEREF(pl_pi_arity_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
*arity = -1;
else
{
*arity = Pl_Rd_Positive_Check(pl_pi_arity_word);
if (*arity > MAX_ARITY)
Pl_Err_Representation(pl_representation_max_arity);
}
}
return func;
}
/*-------------------------------------------------------------------------*
* PL_BLT_COMPARE *
* *
*-------------------------------------------------------------------------*/
Bool FC
Pl_Blt_Compare(WamWord cmp_word, WamWord x, WamWord y)
{
int cmp;
char c;
Bool res;
Pl_Set_C_Bip_Name("compare", 3);
cmp = Pl_Term_Compare(x, y);
c = (cmp < 0) ? '<' : (cmp == 0) ? '=' : '>';
res = Pl_Un_Atom_Check(ATOM_CHAR(c), cmp_word);
Pl_Unset_C_Bip_Name();
return res;
}
/*-------------------------------------------------------------------------*
* MATH_SUPP_INITIALIZER *
* *
*-------------------------------------------------------------------------*/
static void
Math_Supp_Initializer(void)
{
arith_tbl[PLUS_1] = Functor_Arity(ATOM_CHAR('+'), 1);
arith_tbl[PLUS_2] = Functor_Arity(ATOM_CHAR('+'), 2);
arith_tbl[MINUS_1] = Functor_Arity(ATOM_CHAR('-'), 1);
arith_tbl[MINUS_2] = Functor_Arity(ATOM_CHAR('-'), 2);
arith_tbl[TIMES_2] = Functor_Arity(ATOM_CHAR('*'), 2);
arith_tbl[POWER_2] = Functor_Arity(Pl_Create_Atom("**"), 2);
arith_tbl[DIV_2] = Functor_Arity(ATOM_CHAR('/'), 2);
arith_tbl[MIN_2] = Functor_Arity(Pl_Create_Atom("min"), 2);
arith_tbl[MAX_2] = Functor_Arity(Pl_Create_Atom("max"), 2);
arith_tbl[DIST_2] = Functor_Arity(Pl_Create_Atom("dist"), 2);
arith_tbl[QUOT_2] = Functor_Arity(Pl_Create_Atom("//"), 2);
arith_tbl[REM_2] = Functor_Arity(Pl_Create_Atom("rem"), 2);
arith_tbl[QUOT_REM_3] = Functor_Arity(Pl_Create_Atom("quot_rem"), 3);
}
/*-------------------------------------------------------------------------*
* PL_FREE_VARIABLES_4 *
* *
* Fail if no free variables. *
*-------------------------------------------------------------------------*/
Bool
Pl_Free_Variables_4(WamWord templ_word, WamWord gen_word, WamWord gen1_word,
WamWord key_word)
{
WamWord gl_key_word;
WamWord *save_H, *arg;
int nb_free_var = 0;
bound_var_ptr = pl_glob_dico_var; /* pl_glob_dico_var: stores bound vars */
Pl_Treat_Vars_Of_Term(templ_word, TRUE, Bound_Var);
new_gen_word = Existential_Variables(gen_word);
save_H = H++; /* one more word for f/n is possible */
arg = free_var_base = H; /* array is in the heap */
Pl_Treat_Vars_Of_Term(new_gen_word, TRUE, Free_Var);
nb_free_var = H - arg;
if (nb_free_var == 0)
return FALSE;
if (nb_free_var <= MAX_ARITY)
{
*save_H = Functor_Arity(ATOM_CHAR('.'), nb_free_var);
gl_key_word = Tag_STC(save_H);
}
else
{
H = free_var_base;
gl_key_word = Pl_Mk_Proper_List(nb_free_var, arg);
}
Pl_Unify(new_gen_word, gen1_word);
return Pl_Unify(gl_key_word, key_word);
}
/*-------------------------------------------------------------------------*
* 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(')');
}
/*-------------------------------------------------------------------------*
* LOAD_MATH_EXPRESSION *
* *
*-------------------------------------------------------------------------*/
static WamWord
Load_Math_Expression(WamWord exp)
{
WamWord word, tag_mask;
WamWord *adr;
WamWord *lst_adr;
ArithInf *arith;
DEREF(exp, word, tag_mask);
if (tag_mask == TAG_INT_MASK || tag_mask == TAG_FLT_MASK)
return word;
if (tag_mask == TAG_LST_MASK)
{
lst_adr = UnTag_LST(word);
DEREF(Cdr(lst_adr), word, tag_mask);
if (word != NIL_WORD)
{
word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
Pl_Unify_Atom(ATOM_CHAR('.'));
Pl_Unify_Integer(2);
Pl_Err_Type(pl_type_evaluable, 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);
}
return word;
}
if (tag_mask == TAG_STC_MASK)
{
adr = UnTag_STC(word);
arith = (ArithInf *) Pl_Hash_Find(arith_tbl, Functor_And_Arity(adr));
if (arith == NULL)
{
word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
Pl_Unify_Atom(Functor(adr));
Pl_Unify_Integer(Arity(adr));
Pl_Err_Type(pl_type_evaluable, word);
}
if (Arity(adr) == 1)
return (*(arith->fct)) (Load_Math_Expression(Arg(adr, 0)));
return (*(arith->fct)) (Load_Math_Expression(Arg(adr, 0)),
Load_Math_Expression(Arg(adr, 1)));
}
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (tag_mask == TAG_ATM_MASK)
{
word = Pl_Put_Structure(ATOM_CHAR('/'), 2);
Pl_Unify_Value(exp);
Pl_Unify_Integer(0); /* then type_error */
}
Pl_Err_Type(pl_type_evaluable, word);
return word;
}
/*-------------------------------------------------------------------------*
* ALL_SOLUT_INITIALIZER *
* *
*-------------------------------------------------------------------------*/
static void
All_Solut_Initializer(void)
{
exist_2 = Functor_Arity(ATOM_CHAR('^'), 2);
}
/*-------------------------------------------------------------------------*
* 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_BLT_FUNCTOR *
* *
*-------------------------------------------------------------------------*/
Bool FC
Pl_Blt_Functor(WamWord term_word, WamWord functor_word, WamWord arity_word)
{
WamWord word, tag_mask;
WamWord *adr;
WamWord tag_functor;
int arity;
Bool res;
Pl_Set_C_Bip_Name("functor", 3);
DEREF(term_word, word, tag_mask);
if (tag_mask != TAG_REF_MASK)
{
if (tag_mask == TAG_LST_MASK)
res = Pl_Un_Atom_Check(ATOM_CHAR('.'), functor_word) &&
Pl_Un_Integer_Check(2, arity_word);
else if (tag_mask == TAG_STC_MASK)
{
adr = UnTag_STC(word);
res = Pl_Un_Atom_Check(Functor(adr), functor_word) &&
Pl_Un_Integer_Check(Arity(adr), arity_word);
}
else
res = Pl_Unify(word, functor_word) && Pl_Un_Integer_Check(0, arity_word);
goto finish;
}
/* tag_mask == TAG_REF_MASK */
DEREF(functor_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (tag_mask != TAG_ATM_MASK && tag_mask != TAG_INT_MASK &&
tag_mask != TAG_FLT_MASK)
Pl_Err_Type(pl_type_atomic, functor_word);
tag_functor = tag_mask;
functor_word = word;
arity = Pl_Rd_Positive_Check(arity_word);
if (arity > MAX_ARITY)
Pl_Err_Representation(pl_representation_max_arity);
if (tag_functor == TAG_ATM_MASK && UnTag_ATM(functor_word) == ATOM_CHAR('.')
&& arity == 2)
{
res = (Pl_Get_List(term_word)) ? Pl_Unify_Void(2), TRUE : FALSE;
goto finish;
}
if (tag_functor == TAG_ATM_MASK && arity > 0)
{
res = (Pl_Get_Structure(UnTag_ATM(functor_word), arity, term_word)) ?
Pl_Unify_Void(arity), TRUE : FALSE;
goto finish;
}
if (arity != 0)
Pl_Err_Type(pl_type_atom, functor_word);
res = Pl_Unify(functor_word, term_word);
finish:
Pl_Unset_C_Bip_Name();
return res;
}
/*-------------------------------------------------------------------------*
* FORMAT *
* *
*-------------------------------------------------------------------------*/
static void
Format(StmInf *pstm, char *format, WamWord *lst_adr)
#define IMPOSS -12345678
{
WamWord word;
Bool has_n;
long generic;
long n, n1;
char *p;
long x;
double d;
int lg, stop;
int i, k;
char *format_stack[256];
char **top_stack = format_stack;
char buff[2048];
*top_stack++ = format;
do
{
format = *--top_stack;
while (*format)
{
if (*format == '%') /* C printf format */
{
if (format[1] == '%')
{
Pl_Stream_Putc('%', pstm);
format += 2;
continue;
}
p = buff;
n = n1 = IMPOSS;
do
if ((*p++ = *format++) == '*')
{
if (n == IMPOSS)
n = Arg_Integer(&lst_adr);
else
n1 = Arg_Integer(&lst_adr);
}
while ((char *) strchr("diouxXpnceEfgGs", p[-1]) == NULL);
*p = '\0';
if (strchr("eEfgG", p[-1]) == NULL)
{
generic = (p[-1] == 's') ? (long) Arg_Atom(&lst_adr)
: Arg_Integer(&lst_adr);
if (n != IMPOSS)
{
if (n1 != IMPOSS)
Pl_Stream_Printf(pstm, buff, n, n1, generic);
else
Pl_Stream_Printf(pstm, buff, n, generic);
}
else
Pl_Stream_Printf(pstm, buff, generic);
}
else
{
d = Arg_Float(&lst_adr);
if (n != IMPOSS)
{
if (n1 != IMPOSS)
Pl_Stream_Printf(pstm, buff, n, n1, d);
else
Pl_Stream_Printf(pstm, buff, n, d);
}
else
Pl_Stream_Printf(pstm, buff, d);
}
continue;
}
if (*format != '~')
{
Pl_Stream_Putc(*format, pstm);
format++;
continue;
}
if (*++format == '*')
{
n = Arg_Integer(&lst_adr);
format++;
has_n = TRUE;
}
else
{
p = format;
n = strtol(format, &format, 10);
has_n = (format != p);
}
switch (*format)
{
case 'a':
p = Arg_Atom(&lst_adr);
if (has_n)
Pl_Stream_Printf(pstm, "%*s", -n, p);
else
Pl_Stream_Puts(p, pstm);
break;
case 'c':
x = Arg_Integer(&lst_adr);
if (!Is_Valid_Code(x))
Pl_Err_Representation(pl_representation_character_code);
do
Pl_Stream_Putc(x, pstm);
while (--n > 0);
break;
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
x = *format;
d = Arg_Float(&lst_adr);
if (has_n)
sprintf(buff, "%%.%ld%c", n, (char) x);
else
sprintf(buff, "%%%c", (char) x);
Pl_Stream_Printf(pstm, buff, d);
break;
case 'd':
case 'D':
x = Arg_Integer(&lst_adr);
if (n == 0 && *format == 'd')
{
Pl_Stream_Printf(pstm, "%ld", x);
break;
}
if (x < 0)
{
Pl_Stream_Putc('-', pstm);
x = -x;
}
sprintf(buff, "%ld", x);
lg = strlen(buff) - n;
if (lg <= 0)
{
Pl_Stream_Puts("0.", pstm);
for (i = 0; i < -lg; i++)
Pl_Stream_Putc('0', pstm);
Pl_Stream_Printf(pstm, "%ld", x);
break;
}
stop = (*format == 'D') ? lg % 3 : -1;
if (stop == 0)
stop = 3;
for (p = buff, i = 0; *p; p++, i++)
{
if (i == lg)
Pl_Stream_Putc('.', pstm), stop = -1;
if (i == stop)
Pl_Stream_Putc(',', pstm), stop += 3;
Pl_Stream_Putc(*p, pstm);
}
break;
case 'r':
case 'R':
x = Arg_Integer(&lst_adr);
if (!has_n || n < 2 || n > 36)
n = 8;
k = ((*format == 'r') ? 'a' : 'A') - 10;
if (x < 0)
{
Pl_Stream_Putc('-', pstm);
x = -x;
}
p = buff + sizeof(buff) - 1;
*p = '\0';
do
{
i = x % n;
x = x / n;
--p;
*p = (i < 10) ? i + '0' : i + k;
}
while (x);
Pl_Stream_Puts(p, pstm);
break;
case 's':
case 'S':
word = Read_Arg(&lst_adr);
if (*format == 's')
p = Pl_Rd_Codes_Check(word);
else
p = Pl_Rd_Chars_Check(word);
if (has_n)
Pl_Stream_Printf(pstm, "%-*.*s", n, n, p);
else
Pl_Stream_Printf(pstm, "%s", p);
break;
case 'i':
do
Read_Arg(&lst_adr);
while (--n > 0);
break;
case 'k':
word = Read_Arg(&lst_adr);
Pl_Write_Term(pstm, -1, MAX_PREC,
WRITE_IGNORE_OP | WRITE_QUOTED, word);
break;
case 'q':
word = Read_Arg(&lst_adr);
Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS |
WRITE_NAME_VARS | WRITE_QUOTED, word);
break;
case 'p': /* only work if print.pl is linked */
word = Read_Arg(&lst_adr);
Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS |
WRITE_NAME_VARS | WRITE_PORTRAYED, word);
break;
case 'w':
word = Read_Arg(&lst_adr);
Pl_Write_Term(pstm, -1, MAX_PREC, WRITE_NUMBER_VARS |
WRITE_NAME_VARS, word);
break;
case '~':
Pl_Stream_Putc('~', pstm);
break;
case 'N':
if (pstm->line_pos == 0)
break;
case 'n':
do
Pl_Stream_Putc('\n', pstm);
while (--n > 0);
break;
case '?':
if (format[1])
*top_stack++ = format + 1;
format = Arg_Atom(&lst_adr);
continue;
default:
Pl_Err_Domain(pl_domain_format_control_sequence,
Tag_ATM(ATOM_CHAR(*format)));
}
format++;
}
}
while (top_stack > format_stack);
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* 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_ATOM_CHAR *
* *
*-------------------------------------------------------------------------*/
int Pl_Atom_Char(char c)
{
return ATOM_CHAR(c);
}
