/*-------------------------------------------------------------------------*
* 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;
}
/*-------------------------------------------------------------------------*
* 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);
}
/*-------------------------------------------------------------------------*
* 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 */
}