/*-------------------------------------------------------------------------*
* PL_FORMAT_3 *
* *
*-------------------------------------------------------------------------*/
void
Pl_Format_3(WamWord sora_word, WamWord format_word, WamWord args_word)
{
WamWord word, tag_mask;
int stm;
StmInf *pstm;
char *str;
char buff[2048];
stm = (sora_word == NOT_A_WAM_WORD)
? pl_stm_output : Pl_Get_Stream_Or_Alias(sora_word, STREAM_CHECK_OUTPUT);
pstm = pl_stm_tbl[stm];
pl_last_output_sora = sora_word;
Pl_Check_Stream_Type(stm, TRUE, FALSE);
DEREF(format_word, word, tag_mask);
if (tag_mask == TAG_ATM_MASK && word != NIL_WORD)
str = pl_atom_tbl[UnTag_ATM(word)].name;
else
{
strcpy(buff, Pl_Rd_Codes_Check(format_word));
str = buff;
}
Format(pl_stm_tbl[stm], str, &args_word);
}
/*-------------------------------------------------------------------------*
* 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_IS_VALID_VAR_NAME_1 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Is_Valid_Var_Name_1(WamWord name_word)
{
WamWord word, tag_mask;
DEREF(name_word, word, tag_mask);
return (tag_mask == TAG_ATM_MASK) && Is_Valid_Var_Name(pl_atom_tbl[UnTag_ATM(word)].name);
}
/*-------------------------------------------------------------------------*
* 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_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_ATOM_PROPERTY_6 *
* *
*-------------------------------------------------------------------------*/
void
Pl_Atom_Property_6(WamWord atom_word,
WamWord prefix_op_word, WamWord infix_op_word,
WamWord postfix_op_word,
WamWord needs_quote_word, WamWord needs_scan_word)
{
WamWord word, tag_mask;
int atom;
DEREF(atom_word, word, tag_mask);
atom = UnTag_ATM(word);
Pl_Get_Integer(Check_Oper(atom, PREFIX) != 0, prefix_op_word);
Pl_Get_Integer(Check_Oper(atom, INFIX) != 0, infix_op_word);
Pl_Get_Integer(Check_Oper(atom, POSTFIX) != 0, postfix_op_word);
Pl_Get_Integer(pl_atom_tbl[atom].prop.needs_quote, needs_quote_word);
Pl_Get_Integer(pl_atom_tbl[atom].prop.needs_scan, needs_scan_word);
}
/*-------------------------------------------------------------------------*
* 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_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(')');
}
static void
Show_List_Arg(int depth, WamWord *lst_adr)
{
WamWord word, tag_mask;
terminal_rec:
depth--;
Show_Term(depth, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM, Car(lst_adr));
if (depth == 0) /* dots already written by Show_Term */
return;
DEREF(Cdr(lst_adr), word, tag_mask);
switch (Tag_From_Tag_Mask(tag_mask))
{
case REF:
SHOW_LIST_PIPE;
Show_Global_Var(UnTag_REF(word));
break;
case ATM:
if (word != NIL_WORD)
{
SHOW_LIST_PIPE;
if (Try_Portray(word))
return;
Show_Atom(GENERAL_TERM, UnTag_ATM(word));
}
break;
#ifndef NO_USE_FD_SOLVER
case FDV:
SHOW_LIST_PIPE;
if (Try_Portray(word))
return;
Show_Fd_Variable(UnTag_FDV(word));
break;
#endif
case INT:
SHOW_LIST_PIPE;
if (Try_Portray(word))
return;
Show_Integer(UnTag_INT(word));
break;
case FLT:
SHOW_LIST_PIPE;
if (Try_Portray(word))
return;
Show_Float(Pl_Obtain_Float(UnTag_FLT(word)));
break;
case LST:
Out_Char(',');
if (space_args)
Out_Space();
lst_adr = UnTag_LST(word);
goto terminal_rec;
break;
case STC:
SHOW_LIST_PIPE;
if (Try_Portray(word))
return;
Show_Structure(depth, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM,
UnTag_STC(word));
break;
}
}
/*-------------------------------------------------------------------------*
* SHOW_TERM *
* *
*-------------------------------------------------------------------------*/
static void
Show_Term(int depth, int prec, int context, WamWord term_word)
{
WamWord word, tag_mask;
WamWord *adr;
if (depth == 0)
{
Show_Atom(GENERAL_TERM, atom_dots);
return;
}
DEREF(term_word, word, tag_mask);
if (tag_mask != TAG_REF_MASK && Try_Portray(word))
return;
switch (Tag_From_Tag_Mask(tag_mask))
{
case REF:
adr = UnTag_REF(word);
if (Is_A_Local_Adr(adr))
{
Globalize_Local_Unbound_Var(adr, word);
adr = UnTag_REF(word);
}
Show_Global_Var(adr);
break;
case ATM:
Show_Atom(context, UnTag_ATM(word));
break;
#ifndef NO_USE_FD_SOLVER
case FDV:
Show_Fd_Variable(UnTag_FDV(word));
break;
#endif
case INT:
Show_Integer(UnTag_INT(word));
break;
case FLT:
Show_Float(Pl_Obtain_Float(UnTag_FLT(word)));
break;
case LST:
adr = UnTag_LST(word);
if (ignore_op)
{
Out_String("'.'(");
Show_Term(depth - 1, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM,
Car(adr));
Out_Char(',');
Show_Term(depth - 1, MAX_ARG_OF_FUNCTOR_PREC, GENERAL_TERM,
Cdr(adr));
Out_Char(')');
}
else
{
Out_Char('[');
Show_List_Arg(depth, adr);
Out_Char(']');
}
break;
case STC:
adr = UnTag_STC(word);
Show_Structure(depth, prec, context, adr);
break;
}
}
/*-------------------------------------------------------------------------*
* PL_SUB_ATOM_5 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Sub_Atom_5(WamWord atom_word, WamWord before_word, WamWord length_word,
WamWord after_word, WamWord sub_atom_word)
{
WamWord word, tag_mask;
AtomInf *patom;
AtomInf *psub_atom = NULL; /* only for the compiler */
int length;
PlLong b, l, a;
int b1, l1, a1;
Bool nondet;
int mask = 0;
char *str;
patom = pl_atom_tbl + Pl_Rd_Atom_Check(atom_word);
length = patom->prop.length;
DEREF_LG(before_word, b);
DEREF_LG(length_word, l);
DEREF_LG(after_word, a);
DEREF(sub_atom_word, word, tag_mask);
if (tag_mask != TAG_REF_MASK && tag_mask != TAG_ATM_MASK)
Pl_Err_Type(pl_type_atom, word);
sub_atom_word = word;
if (tag_mask == TAG_ATM_MASK)
{
psub_atom = pl_atom_tbl + UnTag_ATM(word);
l = psub_atom->prop.length;
if (!Pl_Get_Integer(l, length_word))
return FALSE;
if ((mask & 5) == 5 && length != b + l + a) /* B and A fixed */
return FALSE;
if (mask & 4) /* B fixed */
{
a = length - b - l;
return strncmp(patom->name + b, psub_atom->name, l) == 0 &&
Pl_Get_Integer(a, after_word);
}
if (mask & 1) /* A fixed */
{
b = length - l - a;
return strncmp(patom->name + b, psub_atom->name, l) == 0 &&
Pl_Get_Integer(b, before_word);
}
mask = 8; /* set sub_atom as fixed */
}
switch (mask) /* mask <= 7, B L A (1: fixed, 0: var) */
{
case 0: /* nothing fixed */
case 2: /* L fixed */
case 4: /* B fixed */
a = length - b - l;
nondet = TRUE;
break;
case 1: /* A fixed */
l = length - b - a;
nondet = TRUE;
break;
case 3: /* L A fixed */
b = length - l - a;
nondet = FALSE;
break;
case 5: /* B A fixed */
l = length - b - a;
nondet = FALSE;
break;
case 6: /* B L fixed */
case 7: /* B L A fixed */
a = length - b - l;
nondet = FALSE;
break;
default: /* sub_atom fixed */
if ((str = strstr(patom->name + b, psub_atom->name)) == NULL)
return FALSE;
b = str - patom->name;
a = length - b - l;
nondet = TRUE;
break;
}
if (b < 0 || l < 0 || a < 0)
return FALSE;
if (nondet
&& Compute_Next_BLA(mask, patom, psub_atom, b, l, a, &b1, &l1, &a1))
{ /* non deterministic case */
A(0) = before_word;
A(1) = length_word;
A(2) = after_word;
A(3) = sub_atom_word;
A(4) = (WamWord) patom;
A(5) = (WamWord) psub_atom;
A(6) = mask;
A(7) = b1;
A(8) = l1;
A(9) = a1;
Pl_Create_Choice_Point((CodePtr) Prolog_Predicate(SUB_ATOM_ALT, 0), 10);
}
if (mask <= 7)
{
MALLOC_STR(l);
strncpy(str, patom->name + b, l);
str[l] = '\0';
Pl_Get_Atom(Create_Malloc_Atom(str), sub_atom_word);
Pl_Get_Integer(l, length_word);
}
return Pl_Get_Integer(b, before_word) && Pl_Get_Integer(a, after_word);
}
/*-------------------------------------------------------------------------*
* PL_ATOM_CONCAT_3 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Atom_Concat_3(WamWord atom1_word, WamWord atom2_word, WamWord atom3_word)
{
WamWord word, tag_mask;
int tag1, tag2, tag3;
AtomInf *patom1, *patom2, *patom3;
char *str;
int l;
DEREF(atom1_word, word, tag_mask);
if (tag_mask != TAG_REF_MASK && tag_mask != TAG_ATM_MASK)
Pl_Err_Type(pl_type_atom, atom1_word);
tag1 = tag_mask;
atom1_word = word;
DEREF(atom2_word, word, tag_mask);
if (tag_mask != TAG_REF_MASK && tag_mask != TAG_ATM_MASK)
Pl_Err_Type(pl_type_atom, atom2_word);
tag2 = tag_mask;
atom2_word = word;
DEREF(atom3_word, word, tag_mask);
if (tag_mask != TAG_REF_MASK && tag_mask != TAG_ATM_MASK)
Pl_Err_Type(pl_type_atom, atom3_word);
tag3 = tag_mask;
atom3_word = word;
if (tag3 == TAG_REF_MASK && (tag1 == TAG_REF_MASK || tag2 == TAG_REF_MASK))
Pl_Err_Instantiation();
if (tag1 == TAG_ATM_MASK)
{
patom1 = pl_atom_tbl + UnTag_ATM(atom1_word);
if (tag2 == TAG_ATM_MASK)
{
patom2 = pl_atom_tbl + UnTag_ATM(atom2_word);
l = patom1->prop.length + patom2->prop.length;
MALLOC_STR(l);
strcpy(str, patom1->name);
strcpy(str + patom1->prop.length, patom2->name);
return Pl_Get_Atom(Create_Malloc_Atom(str), atom3_word);
}
patom3 = pl_atom_tbl + UnTag_ATM(atom3_word);
l = patom3->prop.length - patom1->prop.length;
if (l < 0 || strncmp(patom1->name, patom3->name, patom1->prop.length) != 0)
return FALSE;
MALLOC_STR(l);
strcpy(str, patom3->name + patom1->prop.length);
return Pl_Get_Atom(Create_Malloc_Atom(str), atom2_word);
}
if (tag2 == TAG_ATM_MASK) /* here tag1 == REF */
{
patom2 = pl_atom_tbl + UnTag_ATM(atom2_word);
patom3 = pl_atom_tbl + UnTag_ATM(atom3_word);
l = patom3->prop.length - patom2->prop.length;
if (l < 0 || strncmp(patom2->name, patom3->name + l, patom2->prop.length) != 0)
return FALSE;
MALLOC_STR(l);
strncpy(str, patom3->name, l);
str[l] = '\0';
return Pl_Get_Atom(Create_Malloc_Atom(str), atom1_word);
}
/* A1 and A2 are variables: non deterministic case */
patom3 = pl_atom_tbl + UnTag_ATM(atom3_word);
if (patom3->prop.length > 0)
{
A(0) = atom1_word;
A(1) = atom2_word;
A(2) = (WamWord) patom3;
A(3) = (WamWord) (patom3->name + 1);
Pl_Create_Choice_Point((CodePtr) Prolog_Predicate(ATOM_CONCAT_ALT, 0), 4);
}
return Pl_Get_Atom(pl_atom_void, atom1_word) &&
Pl_Get_Atom_Tagged(atom3_word, atom2_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;
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* PL_OPEN_3 *
* *
*-------------------------------------------------------------------------*/
void
Pl_Open_3(WamWord source_sink_word, WamWord mode_word, WamWord stm_word)
{
WamWord word, tag_mask;
int atom;
int mode;
Bool text;
StmProp prop;
char *path;
int atom_file_name;
int stm;
FILE *f;
int mask = SYS_VAR_OPTION_MASK;
Bool reposition;
DEREF(source_sink_word, word, tag_mask);
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (tag_mask != TAG_ATM_MASK)
Pl_Err_Domain(pl_domain_source_sink, source_sink_word);
atom_file_name = UnTag_ATM(word);
path = pl_atom_tbl[atom_file_name].name;
if ((path = Pl_M_Absolute_Path_Name(path)) == NULL)
Pl_Err_Existence(pl_existence_source_sink, source_sink_word);
text = mask & 1;
mask >>= 1;
atom = Pl_Rd_Atom_Check(mode_word);
if (atom == pl_atom_read)
mode = STREAM_MODE_READ;
else if (atom == pl_atom_write)
mode = STREAM_MODE_WRITE;
else if (atom == pl_atom_append)
mode = STREAM_MODE_APPEND;
else
Pl_Err_Domain(pl_domain_io_mode, mode_word);
stm = Pl_Add_Stream_For_Stdio_File(path, mode, text);
if (stm < 0)
{
if (errno == ENOENT || errno == ENOTDIR)
Pl_Err_Existence(pl_existence_source_sink, source_sink_word);
else
Pl_Err_Permission(pl_permission_operation_open,
pl_permission_type_source_sink, source_sink_word);
}
prop = pl_stm_tbl[stm]->prop;
f = (FILE *) pl_stm_tbl[stm]->file;
/* change properties wrt to specified ones */
if ((mask & 2) != 0) /* reposition specified */
{
reposition = mask & 1;
if (reposition && !prop.reposition)
{
fclose(f);
word = Pl_Put_Structure(pl_atom_reposition, 1);
Pl_Unify_Atom(pl_atom_true);
Pl_Err_Permission(pl_permission_operation_open,
pl_permission_type_source_sink, word);
}
prop.reposition = reposition;
}
mask >>= 2;
if ((mask & 4) != 0) /* eof_action specified */
prop.eof_action = mask & 3;
mask >>= 3;
if ((mask & 4) != 0) /* buffering specified */
if (prop.buffering != (unsigned) (mask & 3)) /* cast for MSVC warning */
{
prop.buffering = mask & 3;
Pl_Stdio_Set_Buffering(f, prop.buffering);
}
mask >>= 3;
pl_stm_tbl[stm]->atom_file_name = atom_file_name;
pl_stm_tbl[stm]->prop = prop;
Pl_Get_Integer(stm, stm_word);
}
/*-------------------------------------------------------------------------*
* PL_TERM_COMPARE *
* *
*-------------------------------------------------------------------------*/
long
Pl_Term_Compare(WamWord start_u_word, WamWord start_v_word)
{
WamWord u_word, u_tag_mask;
WamWord v_word, v_tag_mask;
WamWord u_tag, v_tag;
int u_func, u_arity;
WamWord *u_arg_adr;
int v_func, v_arity;
WamWord *v_arg_adr;
int i, x;
double d1, d2;
DEREF(start_u_word, u_word, u_tag_mask);
DEREF(start_v_word, v_word, v_tag_mask);
u_tag = Tag_From_Tag_Mask(u_tag_mask);
v_tag = Tag_From_Tag_Mask(v_tag_mask);
switch (u_tag)
{
case REF:
return (v_tag != REF) ? -1 : UnTag_REF(u_word) - UnTag_REF(v_word);
#ifndef NO_USE_FD_SOLVER
case FDV:
if (v_tag == REF)
return 1;
return (v_tag != FDV) ? -1 : UnTag_FDV(u_word) - UnTag_FDV(v_word);
#endif
case FLT:
if (v_tag == REF
#ifndef NO_USE_FD_SOLVER
|| v_tag == FDV
#endif
)
return 1;
if (v_tag != FLT)
return -1;
d1 = Pl_Obtain_Float(UnTag_FLT(u_word));
d2 = Pl_Obtain_Float(UnTag_FLT(v_word));
return (d1 < d2) ? -1 : (d1 == d2) ? 0 : 1;
case INT:
if (v_tag == REF ||
#ifndef NO_USE_FD_SOLVER
v_tag == FDV ||
#endif
v_tag == FLT)
return 1;
return (v_tag != INT) ? -1 : UnTag_INT(u_word) - UnTag_INT(v_word);
case ATM:
if (v_tag == REF ||
#ifndef NO_USE_FD_SOLVER
v_tag == FDV ||
#endif
v_tag == FLT || v_tag == INT)
return 1;
return (v_tag != ATM) ? -1 : strcmp(pl_atom_tbl[UnTag_ATM(u_word)].name,
pl_atom_tbl[UnTag_ATM(v_word)].name);
}
/* u_tag == LST / STC */
v_arg_adr = Pl_Rd_Compound(v_word, &v_func, &v_arity);
if (v_arg_adr == NULL) /* v_tag != LST / STC */
return 1;
u_arg_adr = Pl_Rd_Compound(u_word, &u_func, &u_arity);
if (u_arity != v_arity)
return u_arity - v_arity;
if (u_func != v_func)
return strcmp(pl_atom_tbl[u_func].name, pl_atom_tbl[v_func].name);
for (i = 0; i < u_arity; i++)
if ((x = Pl_Term_Compare(*u_arg_adr++, *v_arg_adr++)) != 0)
return x;
return 0;
}
