/*-------------------------------------------------------------------------*
* PL_NAME_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Name_2(WamWord atomic_word, WamWord codes_word)
{
WamWord word, tag_mask;
int syn_flag;
Bool is_number;
char *str;
DEREF(atomic_word, word, tag_mask);
if (tag_mask == TAG_ATM_MASK)
return Pl_Atom_Codes_2(word, codes_word);
if (tag_mask == TAG_INT_MASK || tag_mask == TAG_FLT_MASK)
return Pl_Number_Codes_2(word, codes_word);
if (tag_mask != TAG_REF_MASK)
Pl_Err_Type(pl_type_atomic, word);
str = Pl_Rd_Codes_Check(codes_word);
syn_flag = Flag_Value(syntax_error);
Flag_Value(syntax_error) = PF_ERR_FAIL;
is_number = String_To_Number(str, word); /* only fails on syn err */
Flag_Value(syntax_error) = syn_flag;
if (is_number)
return TRUE;
return Pl_Un_String(str, word);
}
/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* STRING_TO_NUMBER *
* *
*-------------------------------------------------------------------------*/
static Bool
String_To_Number(char *str, WamWord number_word)
{
WamWord word;
int stm;
StmInf *pstm;
Bool eof;
Pl_Check_For_Un_Number(number_word);
/* #if 0 since layout leading chars allowed in ISO cf. number_chars */
#if 0
if (!isdigit(*str) && *str != '-')
{
Pl_Set_Last_Syntax_Error("", 1, 1, "non numeric character");
goto err;
}
#endif
stm = Pl_Add_Str_Stream(str, TERM_STREAM_ATOM);
pstm = pl_stm_tbl[stm];
word = Pl_Read_Number(pstm);
eof = (Pl_Stream_Peekc(pstm) == EOF);
if (word != NOT_A_WAM_WORD && !eof)
Pl_Set_Last_Syntax_Error(pl_atom_tbl[pstm->atom_file_name].name,
pstm->line_count + 1, pstm->line_pos + 1,
"non numeric character");
Pl_Delete_Str_Stream(stm);
if (word == NOT_A_WAM_WORD || !eof)
{
#if 0
err:
#endif
Pl_Syntax_Error(Flag_Value(syntax_error));
return FALSE;
}
return Pl_Unify(word, number_word);
}
/*-------------------------------------------------------------------------*
* PL_SCAN_NEXT_ATOM *
* *
* Scan the next atom. *
*-------------------------------------------------------------------------*/
char *
Pl_Scan_Next_Atom(StmInf *pstm)
{
char *s;
err_msg = NULL;
do
Read_Next_Char(pstm, TRUE);
while (c_type == LA); /* layout character */
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos;
switch (c_type)
{
case SL: /* small letter */
s = pl_token.name;
do
{
*s++ = c;
Read_Next_Char(pstm, TRUE);
}
while (c_type & (UL | CL | SL | DI));
*s = '\0';
Unget_Last_Char;
break;
case DQ: /* double quote */
if ((Flag_Value(double_quotes) & PF_QUOT_AS_PART_MASK) != PF_QUOT_AS_ATOM)
goto error;
goto do_scan_quoted;
case BQ: /* back quote */
if ((Flag_Value(back_quotes) & PF_QUOT_AS_PART_MASK) != PF_QUOT_AS_ATOM)
goto error;
case QT: /* quote */
do_scan_quoted:
err_msg = NULL;
Scan_Quoted(pstm);
if (err_msg)
return err_msg;
break;
case GR: /* graphic */
s = pl_token.name;
while (c_type == GR)
{
*s++ = c;
Read_Next_Char(pstm, TRUE);
}
*s = '\0';
Unget_Last_Char;
break;
case SC: /* solo character */
pl_token.name[0] = c;
pl_token.name[1] = '\0';
break;
default:
error:
Unget_Last_Char;
return "cannot start an atom (use quotes ?)";
}
pl_token.type = TOKEN_NAME;
return NULL;
}
/*-------------------------------------------------------------------------*
* SCAN_QUOTED_CHAR *
* *
*-------------------------------------------------------------------------*/
static int
Scan_Quoted_Char(StmInf *pstm, Bool convert, int c0, Bool no_escape)
{
int radix;
char *p, *f;
int x, i;
Read_Next_Char(pstm, convert);
if (c == c0)
{
if (Pl_Scan_Peek_Char(pstm, convert) != c0) /* '' or "" or `` */
return -1; /* closing quote */
Read_Next_Char(pstm, convert);
return c;
}
if (c == EOF)
{
if (err_msg == NULL)
{
Unget_Last_Char;
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos + 1;
err_msg = "unexpected end of file";
}
return -3; /* -3 means EOF */
}
if (c == '\n')
{
if (err_msg == NULL)
{
Unget_Last_Char;
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos + 1;
err_msg = "unexpected newline";
}
return -4; /* -4 means newline */
}
if (c == '\t')
{
if (err_msg == NULL)
{
Unget_Last_Char;
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos + 1;
err_msg = "unexpected tab";
}
return -5; /* -5 means tab */
}
if (c != '\\' || no_escape)
return c;
/* \... escape sequences */
Read_Next_Char(pstm, convert);
if (c == '\n') /* \ followed by newline */
return -2; /* -2 means \ newline */
if (strchr("\\'\"`", c)) /* \\ or \' or \" or \` */
return c;
if ((p = (char *) strchr(pl_escape_symbol, c))) /* \a \b \f \n \r \t \v */
return pl_escape_char[p - pl_escape_symbol];
if (!Flag_Value(strict_iso))
{
if (c == 's') /* \s = space */
return ' ';
if (c == 'e') /* ESCAPE */
return 27;
}
if (c == 'x' || ('0' <= c && c <= '7')) /* \xnn\ \nn\ */
{
if (c == 'x')
{
radix = 16;
f = "0123456789abcdefABCDEF";
x = 0;
}
else
{
radix = 8;
f = "01234567";
x = c - '0';
}
Read_Next_Char(pstm, convert);
while ((p = strchr(f, c)) != NULL)
{
i = p - f;
if (i >= 16)
i -= 6;
x = x * radix + i;
Read_Next_Char(pstm, convert);
}
if (!Is_Valid_Code(x))
{
if (err_msg == NULL)
{
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos;
err_msg = "invalid character code in \\constant\\ sequence";
}
goto pump;
}
if (c != '\\')
{
if (err_msg == NULL)
{
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos;
err_msg = "\\ expected in \\constant\\ sequence";
}
/* pump until \ or closing quote or newline is found */
pump:
while(c != '\\' && c != c0 && c != EOF && c != '\n')
Read_Next_Char(pstm, convert);
if (c == c0)
Unget_Last_Char; /* to be able to continue in the parent's loop */
return -6; /* -6 means other error */
}
return (int) (unsigned char) x;
}
if (err_msg == NULL)
{
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos;
err_msg = "unknown escape sequence";
}
return -6; /* -6 means other error */
}
/*-------------------------------------------------------------------------*
* SCAN_QUOTED *
* *
*-------------------------------------------------------------------------*/
static void
Scan_Quoted(StmInf *pstm)
{
int c0;
char *s;
Bool convert = (c_orig != '\'');
Bool no_escape;
Bool error_found = FALSE;
int i = 0;
if (c_type == QT)
{
pl_token.type = TOKEN_NAME;
pl_token.quoted = TRUE;
i = 0;
}
else if (c_type == DQ)
{
pl_token.type = TOKEN_STRING;
i = Flag_Value(double_quotes);
}
else
{
pl_token.type = TOKEN_BACK_QUOTED;
i = Flag_Value(back_quotes);
}
s = pl_token.name;
c0 = c;
no_escape = i >> PF_QUOT_NO_ESCAPE_BIT;
for (;;)
{
c = Scan_Quoted_Char(pstm, convert, c0, no_escape);
if (c == -1) /* closing quote */
{
if (error_found)
break;
*s = '\0';
return;
}
if (c == -2) /* \ followed by newline */
continue;
if (c == -3 || c == -4) /* EOF newline */
{
pl_token.type = TOKEN_FULL_STOP; /* to stop immediately Pl_Recover_After_Error */
*s = '\0';
return;
}
if (c == -5 || c == -6) /* tab or other error */
{
error_found = TRUE;
continue; /* continue to try to catch the closing quote */
}
if (!error_found)
*s++ = c;
}
/* error */
*s = '\0';
if (err_msg != NULL) /* this test should now always succeed */
return;
/* thus this should never been used - to be checked */
Unget_Last_Char;
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos + 1;
switch (pl_token.type)
{
case TOKEN_NAME:
err_msg = "quote character expected here";
break;
case TOKEN_BACK_QUOTED:
err_msg = "back quote character expected here";
break;
case TOKEN_STRING:
err_msg = "double quote character expected here";
break;
default: /* to avoid compiler warning */
;
}
}
/*-------------------------------------------------------------------------*
* SCAN_NUMBER *
* *
*-------------------------------------------------------------------------*/
static void
Scan_Number(StmInf *pstm, Bool integer_only)
{
int lg;
int radix;
char *p, *f;
int c_orig0;
/* at entry: c is a digit */
p = pl_token.name;
do
{
*p++ = c;
Read_Next_Char(pstm, TRUE);
}
while (c_type == DI);
lg = p - pl_token.name;
if (!integer_only && /* float if . and digit */
c == '.' && isdigit(Pl_Scan_Peek_Char(pstm, TRUE)))
goto is_a_float;
/* integer number */
pl_token.type = TOKEN_INTEGER;
*p = '\0';
/* if case of an underflow/overflow strtol() returns LONG_MIN/LONG_MAX and
* sets errno to ERANGE. We dont test it because LONG_MIN is < INT_LOWEST_VALUE
* and LONG_MAX is > INT_GREATEST_VALUE. We will detect it at return from
* this function.
*/
pl_token.int_num = Str_To_PlLong(pl_token.name, &p, 10);
if (lg != 1 || pl_token.int_num != 0 || strchr("'box", c) == NULL)
goto push_back;
if (c == '\'') /* 0'<character> */
{
c = Scan_Quoted_Char(pstm, TRUE, '\'', FALSE);
if (c == -1) /* <character> is ' */
{
/* STRICT ISO does not allow 0'' one should write 0''' or 0'\' */
if (Flag_Value(strict_iso))
{
/* do not emit an error since 0'' is valid if '' is a postif/infix op
* (this is the only case) - simply return the integer 0
*/
#if 1
if (Check_Oper(pl_atom_void, INFIX) || Check_Oper(pl_atom_void, POSTFIX))
{
Pl_Stream_Ungetc('\'', pstm); /* push back last ' */
Pl_Stream_Ungetc('\'', pstm); /* push back first ' */
return;
}
#endif
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos + 1;
err_msg = "quote character expected here";
return;
}
else
c = '\'';
}
if (c < 0) /* \ newline EOF newline tab other error */
{
Unget_Last_Char;
pl_token.type = TOKEN_FULL_STOP; /* to stop immediately Pl_Recover_After_Error */
pl_token.line = pstm->line_count + 1;
pl_token.col = pstm->line_pos + 1;
err_msg = "character expected here";
}
pl_token.int_num = c;
return;
}
radix = (c == 'b') ? (f = "01", 2) :
(c == 'o') ? (f = "01234567", 8)
: (f = "0123456789abcdefABCDEF", 16);
p = pl_token.name;
Read_Next_Char(pstm, TRUE);
while (strchr(f, c) != NULL)
{
*p++ = c;
Read_Next_Char(pstm, TRUE);
}
*p = '\0';
pl_token.int_num = Str_To_PlLong(pl_token.name, &p, radix);
goto push_back;
is_a_float: /* float number */
pl_token.type = TOKEN_FLOAT;
*p++ = '.';
Read_Next_Char(pstm, TRUE);
while (c_type == DI)
{
*p++ = c;
Read_Next_Char(pstm, TRUE);
}
if (c == 'e' || c == 'E')
{
c_orig0 = c_orig;
Read_Next_Char(pstm, TRUE);
if (!(c_type == DI || ((c == '+' || c == '-') &&
isdigit(Pl_Scan_Peek_Char(pstm, TRUE)))))
{
Unget_Last_Char;
c_orig = c_orig0;
goto end_float;
}
*p++ = 'e';
*p++ = c;
Read_Next_Char(pstm, TRUE);
while (c_type == DI)
{
*p++ = c;
Read_Next_Char(pstm, TRUE);
}
}
end_float:
*p = '\0';
sscanf(pl_token.name, "%lf", &pl_token.float_num);
push_back:
Unget_Last_Char;
}
/*-------------------------------------------------------------------------*
* PL_EMIT_SYNTAX_ERROR *
* *
*-------------------------------------------------------------------------*/
void
Pl_Emit_Syntax_Error(char *file_name, int err_line, int err_col, char *err_msg)
{
Pl_Set_Last_Syntax_Error(file_name, err_line, err_col, err_msg);
Pl_Syntax_Error(Flag_Value(FLAG_SYNTAX_ERROR));
}
/*-------------------------------------------------------------------------*
* PL_CURRENT_PREDICATE_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Current_Predicate_2(WamWord pred_indic_word, WamWord which_preds_word)
{
WamWord name_word, arity_word;
HashScan scan;
PredInf *pred;
int func, arity;
int func1, arity1;
int which_preds; /* 0=user, 1=user+bips, 2=user+bips+system */
Bool all;
func = Pl_Get_Pred_Indicator(pred_indic_word, FALSE, &arity);
name_word = pl_pi_name_word;
arity_word = pl_pi_arity_word;
which_preds = Pl_Rd_Integer(which_preds_word);
if (which_preds == 0 && !Flag_Value(FLAG_STRICT_ISO))
which_preds = 1;
#define Pred_Is_Ok(pred, func, which_preds) \
(which_preds == 2 || (pl_atom_tbl[func].name[0] != '$' && \
(which_preds == 1 || !(pred->prop & MASK_PRED_ANY_BUILTIN))))
if (func >= 0 && arity >= 0)
{
pred = Pl_Lookup_Pred(func, arity);
return pred && Pred_Is_Ok(pred, func, which_preds);
}
/* here func or arity == -1 (or both) */
all = (func == -1 && arity == -1);
pred = (PredInf *) Pl_Hash_First(pl_pred_tbl, &scan);
for (;;)
{
if (pred == NULL)
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;
pred = (PredInf *) Pl_Hash_Next(&scan);
}
/* non deterministic case */
A(0) = name_word;
A(1) = arity_word;
A(2) = which_preds;
A(3) = (WamWord) scan.endt;
A(4) = (WamWord) scan.cur_t;
A(5) = (WamWord) scan.cur_p;
Pl_Create_Choice_Point((CodePtr) Prolog_Predicate(CURRENT_PREDICATE_ALT, 0),
6);
return Pl_Get_Atom(Functor_Of(pred->f_n), name_word) &&
Pl_Get_Integer(Arity_Of(pred->f_n), arity_word);
/*
return Pl_Un_Atom_Check(Functor_Of(pred->f_n), name_word) &&
Pl_Un_Integer_Check(Arity_Of(pred->f_n), arity_word);
*/
}