/*-------------------------------------------------------------------------*
* PL_STREAM_POSITION_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Stream_Position_2(WamWord sora_word, WamWord position_word)
{
WamWord word, tag_mask;
WamWord p_word[4];
PlLong p[4];
int i;
int stm;
StmInf *pstm;
stm = Pl_Get_Stream_Or_Alias(sora_word, STREAM_CHECK_EXIST);
pstm = pl_stm_tbl[stm];
Pl_Stream_Get_Position(pstm, p, p + 1, p + 2, p + 3);
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 && tag_mask != TAG_INT_MASK)
goto dom_error;
}
for (i = 0; i < 4; i++)
if (!Pl_Get_Integer(p[i], p_word[i]))
return FALSE;
return TRUE;
}
/*-------------------------------------------------------------------------*
* PL_CLOSE_INPUT_TERM_STREAM_1 *
* *
*-------------------------------------------------------------------------*/
void
Pl_Close_Input_Term_Stream_1(WamWord sora_word)
{
int stm;
StmInf *pstm;
StrSInf *str_stream;
int type;
stm = Pl_Get_Stream_Or_Alias(sora_word, STREAM_CHECK_EXIST);
pstm = pl_stm_tbl[stm];
type = pstm->prop.other;
if (type < 1 || type > 3)
Pl_Err_Domain(pl_domain_term_stream_or_alias, sora_word);
if (pstm->prop.output)
Pl_Err_Permission(pl_permission_operation_close,
pl_permission_type_stream, sora_word);
if (type != TERM_STREAM_ATOM)
{
str_stream = (StrSInf *) (pstm->file);
Free(str_stream->buff);
}
Pl_Delete_Str_Stream(stm);
}
/*-------------------------------------------------------------------------*
* READ_ARG *
* *
*-------------------------------------------------------------------------*/
static WamWord
Read_Arg(WamWord **lst_adr)
{
WamWord word, tag_mask;
WamWord *adr;
WamWord car_word;
DEREF(**lst_adr, word, tag_mask);
if (tag_mask != TAG_LST_MASK)
{
if (tag_mask == TAG_REF_MASK)
Pl_Err_Instantiation();
if (word == NIL_WORD)
Pl_Err_Domain(pl_domain_non_empty_list, word);
Pl_Err_Type(pl_type_list, word);
}
adr = UnTag_LST(word);
car_word = Car(adr);
*lst_adr = &Cdr(adr);
DEREF(car_word, word, tag_mask);
return 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_CLOSE_OUTPUT_TERM_STREAM_2 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Close_Output_Term_Stream_2(WamWord sora_word, WamWord sink_term_word)
{
int stm;
StmInf *pstm;
int type;
char *str;
stm = Pl_Get_Stream_Or_Alias(sora_word, STREAM_CHECK_EXIST);
pstm = pl_stm_tbl[stm];
type = pstm->prop.other;
if (type < 1 || type > 3)
Pl_Err_Domain(pl_domain_term_stream_or_alias, sora_word);
if (pstm->prop.input)
Pl_Err_Permission(pl_permission_operation_close,
pl_permission_type_stream, sora_word);
str = Pl_Term_Write_Str_Stream(stm);
switch (SYS_VAR_OPTION_MASK)
{
case TERM_STREAM_ATOM:
if (!Pl_Un_String_Check(str, sink_term_word))
return FALSE;
break;
case TERM_STREAM_CHARS:
if (!Pl_Un_Chars_Check(str, sink_term_word))
return FALSE;
break;
case TERM_STREAM_CODES:
if (!Pl_Un_Codes_Check(str, sink_term_word))
return FALSE;
break;
}
Pl_Delete_Str_Stream(stm);
return TRUE;
}
/*-------------------------------------------------------------------------*
* PL_SEEK_4 *
* *
*-------------------------------------------------------------------------*/
Bool
Pl_Seek_4(WamWord sora_word, WamWord whence_word, WamWord offset_word,
WamWord new_loc_word)
{
int stm;
StmInf *pstm;
int whence;
PlLong offset;
int atom;
PlLong p[4];
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);
if (pstm->prop.text)
Pl_Err_Permission(pl_permission_operation_reposition,
pl_permission_type_text_stream, sora_word);
atom = Pl_Rd_Atom_Check(whence_word);
if (atom == pl_atom_bof)
whence = SEEK_SET;
else if (atom == pl_atom_current)
whence = SEEK_CUR;
else if (atom == pl_atom_eof)
whence = SEEK_END;
else
Pl_Err_Domain(pl_domain_stream_seek_method, whence_word);
offset = Pl_Rd_Integer_Check(offset_word);
Pl_Check_For_Un_Integer(new_loc_word);
if (Pl_Stream_Set_Position(pstm, whence, offset, offset, 0, 0) != 0)
return FALSE;
Pl_Stream_Get_Position(pstm, &offset, p + 1, p + 2, p + 3);
return Pl_Get_Integer(offset, new_loc_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_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_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);
}
/*-------------------------------------------------------------------------*
* 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);
}