diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

eplace format

Browse Source
This commit is contained in:
ubu32 2011-02-14 14:13:45 -08:00
parent 52f8cb1041
commit 4dbdaaa772
12 changed files with 142 additions and 1022 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
C/c_interface.c
View File

@ -497,6 +497,7 @@ X_API void STD_PROTO(YAP_UserCPredicateWithArgs,(char *,CPredicate,UInt,Term)
X_API void STD_PROTO(YAP_UserBackCutCPredicate,(char *,CPredicate,CPredicate,CPredicate,UInt,unsigned int));
X_API void *STD_PROTO(YAP_ExtraSpaceCut,(void));
#endif
X_API Term STD_PROTO(YAP_SetCurrentModule,(Term));
X_API Term STD_PROTO(YAP_CurrentModule,(void));
X_API Term STD_PROTO(YAP_CreateModule,(Atom));
X_API Term STD_PROTO(YAP_StripModule,(Term, Term *));
@ -3105,6 +3106,14 @@ YAP_CurrentModule(void)
return(CurrentModule);
}
X_API Term
YAP_SetCurrentModule(Term new)
{
Term omod = CurrentModule;
CurrentModule = new;
return omod;
}
X_API Term
YAP_CreateModule(Atom at)
{

958
C/iopreds.c
View File

@ -108,10 +108,8 @@ STATIC_PROTO (Int p_set_read_error_handler, (void));
STATIC_PROTO (Int p_get_read_error_handler, (void));
STATIC_PROTO (Int p_read, (void));
STATIC_PROTO (Int p_past_eof, (void));
STATIC_PROTO (Int p_skip, (void));
STATIC_PROTO (Int p_write_depth, (void));
STATIC_PROTO (Int p_user_file_name, (void));
STATIC_PROTO (Int p_format, (void));
STATIC_PROTO (Int p_startline, (void));
STATIC_PROTO (Int p_change_type_of_char, (void));
STATIC_PROTO (Int p_type_of_char, (void));
@ -2317,955 +2315,6 @@ p_get0_line_codes (void)
return Yap_unify(out,ARG2);
}
#define FORMAT_MAX_SIZE 256
typedef struct {
Int pos; /* tab point */
char pad; /* ok, it's not standard english */
} pads;
typedef struct format_status {
int format_error;
char *format_ptr, *format_base, *format_max;
int format_buf_size;
pads pad_entries[16], *pad_max;
} format_info;
static int
format_putc(int sno, wchar_t ch) {
if (FormatInfo->format_buf_size == -1)
return EOF;
if (ch == 10) {
char *ptr = FormatInfo->format_base;
#if MAC || _MSC_VER
ch = '\n';
#endif
for (ptr = FormatInfo->format_base; ptr < FormatInfo->format_ptr; ptr++) {
Stream[sno].stream_putc(sno, *ptr);
}
/* reset line */
FormatInfo->format_ptr = FormatInfo->format_base;
FormatInfo->pad_max = FormatInfo->pad_entries;
Stream[sno].stream_putc(sno, '\n');
return((int)10);
} else {
*FormatInfo->format_ptr++ = (char)ch;
if (FormatInfo->format_ptr == FormatInfo->format_max) {
/* oops, we have reached an overflow */
Int new_max_size = FormatInfo->format_buf_size + FORMAT_MAX_SIZE;
char *newbuf;
if ((newbuf = Yap_AllocAtomSpace(new_max_size*sizeof(char))) == NULL) {
FormatInfo->format_buf_size = -1;
Yap_Error(SYSTEM_ERROR, TermNil, "YAP could not grow heap for format/2");
return(EOF);
}
#if HAVE_MEMMOVE
memmove((void *)newbuf, (void *)FormatInfo->format_base, (size_t)((FormatInfo->format_ptr-FormatInfo->format_base)*sizeof(char)));
#else
{
Int n = FormatInfo->format_ptr-FormatInfo->format_base;
char *to = newbuf;
char *from = FormatInfo->format_base;
while (n-- >= 0) {
*to++ = *from++;
}
}
#endif
Yap_FreeAtomSpace(FormatInfo->format_base);
FormatInfo->format_ptr = newbuf+(FormatInfo->format_ptr-FormatInfo->format_base);
FormatInfo->format_base = newbuf;
FormatInfo->format_max = newbuf+new_max_size;
FormatInfo->format_buf_size = new_max_size;
if (ActiveSignals & YAP_CDOVF_SIGNAL) {
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP failed to grow heap at format");
}
}
}
}
return ((int) ch);
}
static void fill_pads(int nchars)
{
int nfillers, fill_space, lfill_space;
if (nchars <= 0) return; /* ignore */
nfillers = FormatInfo->pad_max-FormatInfo->pad_entries;
if (nfillers == 0) {
/* OK, just pad with spaces */
while (nchars--) {
*FormatInfo->format_ptr++ = ' ';
}
return;
}
fill_space = nchars/nfillers;
lfill_space = nchars%nfillers;
if (fill_space) {
pads *padi = FormatInfo->pad_max;
while (padi > FormatInfo->pad_entries) {
char *start_pos;
int n, i;
padi--;
start_pos = FormatInfo->format_base+padi->pos;
n = FormatInfo->format_ptr-start_pos;
#if HAVE_MEMMOVE
memmove((void *)(start_pos+fill_space), (void *)start_pos, (size_t)(n*sizeof(char)));
#else
{
char *to = start_pos+(fill_space+n);
char *from = FormatInfo->format_ptr;
while (n-- > 0) {
*--to = *--from;
}
}
#endif
FormatInfo->format_ptr += fill_space;
for (i = 0; i < fill_space; i++) {
*start_pos++ = padi->pad;
}
}
}
while (lfill_space--) {
*FormatInfo->format_ptr++ = FormatInfo->pad_max[-1].pad;
}
}
static int
format_print_str (Int sno, Int size, Int has_size, Term args, int (* f_putc)(int, wchar_t))
{
Term arghd;
while (!has_size || size > 0) {
if (IsVarTerm(args)) {
Yap_Error(INSTANTIATION_ERROR, args, "format/2");
return FALSE;
} else if (args == TermNil) {
return TRUE;
}
else if (!IsPairTerm (args)) {
Yap_Error(TYPE_ERROR_LIST, args, "format/2");
return FALSE;
}
arghd = HeadOfTerm (args);
args = TailOfTerm (args);
if (IsVarTerm(arghd)) {
Yap_Error(INSTANTIATION_ERROR, arghd, "format/2");
return FALSE;
} else if (!IsIntTerm (arghd)) {
Yap_Error(TYPE_ERROR_LIST, arghd, "format/2");
return FALSE;
}
f_putc(sno, (int) IntOfTerm (arghd));
size--;
}
return TRUE;
}
typedef enum {
fst_ok,
fst_error,
fst_too_long
} format_cp_res;
static format_cp_res
copy_format_string(Term inp, char *out, int max)
{
int i = 0;
while (inp != TermNil) {
Term hd;
int ch;
if (IsVarTerm(inp)) {
Yap_Error(INSTANTIATION_ERROR,inp,"format/2");
return fst_error;
}
if (!IsPairTerm(inp)) {
Yap_Error(TYPE_ERROR_LIST,inp,"format/2");
return fst_error;
}
hd = HeadOfTerm(inp);
if (IsVarTerm(hd)) {
Yap_Error(INSTANTIATION_ERROR,hd,"format/2");
return fst_error;
}
if (!IsIntTerm(hd)) {
Yap_Error(TYPE_ERROR_INTEGER,hd,"format/2");
return fst_error;
}
ch = IntOfTerm(hd);
if (ch < 0) {
Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO,hd,"format/2");
return fst_error;
}
if (i+1 == max) {
return fst_too_long;
}
/* we've got a character */
out[i++] = ch;
/* done */
inp = TailOfTerm(inp);
}
out[i] = '\0';
return fst_ok;
}
#define FORMAT_COPY_ARGS_ERROR -1
#define FORMAT_COPY_ARGS_OVERFLOW -2
static Int
format_copy_args(Term args, Term *targs, Int tsz)
{
Int n = 0;
while (args != TermNil) {
if (IsVarTerm(args)) {
Yap_Error(INSTANTIATION_ERROR,args,"format/2");
return FORMAT_COPY_ARGS_ERROR;
}
if (!IsPairTerm(args)) {
Yap_Error(TYPE_ERROR_LIST,args,"format/2");
return FORMAT_COPY_ARGS_ERROR;
}
if (n == tsz)
return FORMAT_COPY_ARGS_OVERFLOW;
targs[n] = HeadOfTerm(args);
args = TailOfTerm(args);
n++;
}
return n;
}
static void
format_clean_up(char *format_base, char *fstr, Term *targs)
{
if (format_base)
Yap_FreeAtomSpace(format_base);
if (fstr)
Yap_FreeAtomSpace(fstr);
if (targs)
Yap_FreeAtomSpace((char *)targs);
}
static Int
fetch_index_from_args(Term t)
{
Int i;
if (IsVarTerm(t))
return -1;
if (!IsIntegerTerm(t))
return -1;
i = IntegerOfTerm(t);
if (i < 0)
return -1;
return i;
}
static int
format_has_tabs(const char *seq)
{
int ch;
while ((ch = *seq++)) {
if (ch == '~') {
ch = *seq++;
if (ch == 'p' || ch == '@') {
return TRUE;
}
if (ch == '*') {
ch = *seq++;
} else {
while (ch >= '0' && ch <= '9') ch = *seq++;
}
if (ch == 't' || ch == '|' || ch == '+') {
return TRUE;
}
if (!ch)
return FALSE;
}
}
return FALSE;
}
static wchar_t
base_dig(Int dig, Int ch)
{
if (dig < 10)
return dig+'0';
else if (ch == 'r')
return (dig-10)+'a';
else /* ch == 'R' */
return (dig-10)+'A';
}
#define TMP_STRING_SIZE 1024
static Int
format(volatile Term otail, volatile Term oargs, int sno)
{
char tmp1[TMP_STRING_SIZE], *tmpbase;
int ch;
int column_boundary;
Term mytargs[8], *targs;
Int tnum, targ;
char *fstr = NULL, *fptr;
Term args;
Term tail;
int (* f_putc)(int, wchar_t);
int has_tabs;
volatile void *old_handler;
format_info finfo;
Term fmod = CurrentModule;
FormatInfo = &finfo;
finfo.pad_max = finfo.pad_entries;
finfo.format_error = FALSE;
old_handler = NULL;
args = oargs;
tail = otail;
targ = 0;
column_boundary = 0;
if (IsVarTerm(tail)) {
Yap_Error(INSTANTIATION_ERROR,tail,"format/2");
return(FALSE);
} else if (IsPairTerm (tail)) {
int sz = 256;
do {
format_cp_res fr;
fstr = fptr = Yap_AllocAtomSpace(sz*sizeof(char));
if ((fr = copy_format_string(tail, fstr, sz)) == fst_ok)
break;
if (fr == fst_error) return FALSE;
sz += 256;
Yap_FreeCodeSpace(fstr);
} while (TRUE);
} else if (IsAtomTerm(tail)) {
fstr = fptr = RepAtom(AtomOfTerm(tail))->StrOfAE;
} else {
Yap_Error(CONSISTENCY_ERROR, tail, "format/2");
return FALSE;
}
if (IsVarTerm(args)) {
Yap_Error(INSTANTIATION_ERROR, args, "format/2");
return FALSE;
}
while (IsApplTerm(args) && FunctorOfTerm(args) == FunctorModule) {
fmod = ArgOfTerm(1,args);
args = ArgOfTerm(2,args);
if (IsVarTerm(fmod)) {
Yap_Error(INSTANTIATION_ERROR, fmod, "format/2");
return FALSE;
}
if (!IsAtomTerm(fmod)) {
Yap_Error(TYPE_ERROR_ATOM, fmod, "format/2");
return FALSE;
}
if (IsVarTerm(args)) {
Yap_Error(INSTANTIATION_ERROR, args, "format/2");
return FALSE;
}
}
if (IsPairTerm(args)) {
Int tsz = 8;
targs = mytargs;
do {
tnum = format_copy_args(args, targs, tsz);
if (tnum == FORMAT_COPY_ARGS_ERROR)
return FALSE;
else if (tnum == FORMAT_COPY_ARGS_OVERFLOW) {
if (mytargs != targs) {
Yap_FreeCodeSpace((char *)targs);
}
tsz += 16;
targs = (Term *)Yap_AllocAtomSpace(tsz*sizeof(Term));
} else {
break;
}
} while (TRUE);
} else if (args != TermNil) {
tnum = 1;
mytargs[0] = args;
targs = mytargs;
} else {
tnum = 0;
targs = mytargs;
}
finfo.format_error = FALSE;
if ((has_tabs = format_has_tabs(fptr))) {
finfo.format_base = finfo.format_ptr = Yap_AllocAtomSpace(FORMAT_MAX_SIZE*sizeof(char));
finfo.format_max = finfo.format_base+FORMAT_MAX_SIZE;
if (finfo.format_ptr == NULL) {
Yap_Error(INSTANTIATION_ERROR,tail,"format/2");
return(FALSE);
}
finfo.format_buf_size = FORMAT_MAX_SIZE;
f_putc = format_putc;
} else {
f_putc = Stream[sno].stream_wputc;
finfo.format_base = NULL;
}
while ((ch = *fptr++)) {
Term t = TermNil;
int has_repeats = FALSE;
int repeats = 0;
if (ch == '~') {
/* start command */
ch = *fptr++;
if (ch == '*') {
ch = *fptr++;
has_repeats = TRUE;
if (targ > tnum-1) {
goto do_consistency_error;
}
repeats = fetch_index_from_args(targs[targ++]);
if (repeats == -1)
goto do_consistency_error;
} else if (ch == '`') {
/* next character is kept as code */
has_repeats = TRUE;
repeats = *fptr++;
ch = *fptr++;
} else if (ch >= '0' && ch <= '9') {
has_repeats = TRUE;
repeats = 0;
while (ch >= '0' && ch <= '9') {
repeats = repeats*10+(ch-'0');
ch = *fptr++;
}
}
switch (ch) {
case 'a':
/* print an atom */
if (has_repeats || targ > tnum-1)
goto do_consistency_error;
t = targs[targ++];
if (IsVarTerm(t))
goto do_instantiation_error;
if (!IsAtomTerm(t))
goto do_type_atom_error;
Yap_StartSlots();
Yap_plwrite (t, f_putc, Handle_vars_f|To_heap_f, 1200);
Yap_CloseSlots();
FormatInfo = &finfo;
break;
case 'c':
{
Int nch, i;
if (targ > tnum-1)
goto do_consistency_error;
t = targs[targ++];
if (IsVarTerm(t))
goto do_instantiation_error;
if (!IsIntegerTerm(t))
goto do_type_int_error;
nch = IntegerOfTerm(t);
if (nch < 0)
goto do_domain_not_less_zero_error;
if (!has_repeats)
repeats = 1;
for (i = 0; i < repeats; i++)
f_putc(sno, nch);
break;
}
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
{
Float fl;
char *ptr;
if (targ > tnum-1)
goto do_consistency_error;
t = targs[targ++];
if (IsVarTerm(t))
goto do_instantiation_error;
if (!IsNumTerm(t))
goto do_type_number_error;
if (IsIntegerTerm(t)) {
fl = (Float)IntegerOfTerm(t);
#ifdef USE_GMP
} else if (IsBigIntTerm(t)) {
fl = Yap_gmp_to_float(t);
#endif
} else {
fl = FloatOfTerm(t);
}
if (!has_repeats)
repeats = 6;
tmp1[0] = '%';
tmp1[1] = '.';
ptr = tmp1+2;
#if HAVE_SNPRINTF
snprintf(ptr,256-5,"%d",repeats);
#else
sprintf(ptr,"%d",repeats);
#endif
while (*ptr) ptr++;
ptr[0] = ch;
ptr[1] = '\0';
{
char *tmp2;
if (!(tmp2 = Yap_AllocCodeSpace(repeats+10)))
goto do_type_int_error;
#if HAVE_SNPRINTF
snprintf (tmp2, repeats+10, tmp1, fl);
#else
sprintf (tmp2, tmp1, fl);
#endif
ptr = tmp2;
while ((ch = *ptr++) != 0)
f_putc(sno, ch);
Yap_FreeCodeSpace(tmp2);
}
break;
case 'd':
case 'D':
/* print a decimal, using weird . stuff */
if (targ > tnum-1)
goto do_consistency_error;
t = targs[targ++];
if (IsVarTerm(t))
goto do_instantiation_error;
if (!IsIntegerTerm(t)
#ifdef USE_GMP
&& !IsBigIntTerm(t)
#endif
)
goto do_type_int_error;
{
Int siz = 0;
char *ptr = tmp1;
tmpbase = tmp1;
if (IsIntegerTerm(t)) {
Int il = IntegerOfTerm(t);
#if HAVE_SNPRINTF
snprintf(tmp1, 256, "%ld", (long int)il);
#else
sprintf(tmp1, "%ld", (long int)il);
#endif
siz = strlen(tmp1);
if (il < 0) siz--;
#ifdef USE_GMP
} else if (IsBigIntTerm(t) && RepAppl(t)[1] == BIG_INT) {
char *res;
tmpbase = tmp1;
while (!(res = Yap_gmp_to_string(t, tmpbase, TMP_STRING_SIZE, 10))) {
if (tmpbase == tmp1) {
tmpbase = NULL;
} else {
tmpbase = res;
goto do_type_int_error;
}
}
tmpbase = res;
ptr = tmpbase;
#endif
siz = strlen(tmpbase);
} else {
goto do_type_int_error;
}
if (tmpbase[0] == '-') {
f_putc(sno, (int) '-');
ptr++;
}
if (ch == 'D') {
int first = TRUE;
while (siz > repeats) {
if ((siz-repeats) % 3 == 0 &&
!first) {
f_putc(sno, (int) ',');
}
f_putc(sno, (int) (*ptr++));
first = FALSE;
siz--;
}
} else {
while (siz > repeats) {
f_putc(sno, (int) (*ptr++));
siz--;
}
}
if (repeats) {
if (ptr == tmpbase ||
ptr[-1] == '-') {
f_putc(sno, (int) '0');
}
f_putc(sno, (int) '.');
while (repeats > siz) {
f_putc(sno, (int) '0');
repeats--;
}
while (repeats) {
f_putc(sno, (int) (*ptr++));
repeats--;
}
}
if (tmpbase != tmp1)
free(tmpbase);
break;
case 'r':
case 'R':
{
Int numb, radix;
UInt divfactor = 1, size = 1, i;
wchar_t och;
/* print a decimal, using weird . stuff */
if (targ > tnum-1)
goto do_consistency_error;
t = targs[targ++];
if (IsVarTerm(t))
goto do_instantiation_error;
if (!has_repeats)
radix = 8;
else
radix = repeats;
if (radix > 36 || radix < 2)
goto do_domain_error_radix;
#ifdef USE_GMP
if (IsBigIntTerm(t) && RepAppl(t)[1] == BIG_INT) {
char *pt, *res;
tmpbase = tmp1;
while (!(res = Yap_gmp_to_string(t, tmpbase, TMP_STRING_SIZE, radix))) {
if (tmpbase == tmp1) {
tmpbase = NULL;
} else {
tmpbase = res;
goto do_type_int_error;
}
}
tmpbase = res;
pt = tmpbase;
while ((ch = *pt++))
f_putc(sno, ch);
if (tmpbase != tmp1)
free(tmpbase);
break;
}
#endif
if (!IsIntegerTerm(t))
goto do_type_int_error;
numb = IntegerOfTerm(t);
if (numb < 0) {
numb = -numb;
f_putc(sno, (int) '-');
}
while (numb/divfactor >= radix) {
divfactor *= radix;
size++;
}
for (i = 1; i < size; i++) {
Int dig = numb/divfactor;
och = base_dig(dig, ch);
f_putc(sno, och);
numb %= divfactor;
divfactor /= radix;
}
och = base_dig(numb, ch);
f_putc(sno, och);
break;
}
case 's':
if (targ > tnum-1)
goto do_consistency_error;
t = targs[targ++];
if (!format_print_str (sno, repeats, has_repeats, t, f_putc)) {
goto do_default_error;
}
break;
case 'i':
if (targ > tnum-1 || has_repeats)
goto do_consistency_error;
targ++;
break;
case 'k':
if (targ > tnum-1 || has_repeats)
goto do_consistency_error;
t = targs[targ++];
Yap_StartSlots();
Yap_plwrite (t, f_putc, Quote_illegal_f|Ignore_ops_f|To_heap_f , 1200);
Yap_CloseSlots();
FormatInfo = &finfo;
break;
case '@':
t = targs[targ++];
Yap_StartSlots();
{
Int sl = Yap_InitSlot(args);
Int sl2;
Int res;
Term ta[2];
Term ts;
ta[0] = fmod;
ta[1] = t;
ta[0] = Yap_MkApplTerm(FunctorModule, 2, ta);
ta[1] = MkVarTerm();
sl2 = Yap_InitSlot(ta[1]);
ts = Yap_MkApplTerm(FunctorGFormatAt, 2, ta);
res = Yap_execute_goal(ts, 0, CurrentModule);
FormatInfo = &finfo;
args = Yap_GetFromSlot(sl);
if (EX) goto ex_handler;
if (!res) return FALSE;
ts = Yap_GetFromSlot(sl2);
Yap_RecoverSlots(2);
if (!format_print_str (sno, repeats, has_repeats, ts, f_putc)) {
goto do_default_error;
}
}
Yap_CloseSlots();
break;
case 'p':
if (targ > tnum-1 || has_repeats)
goto do_consistency_error;
t = targs[targ++];
Yap_StartSlots();
{
Int sl = Yap_InitSlot(args);
Yap_plwrite(t, f_putc, Handle_vars_f|Use_portray_f|To_heap_f, 1200);
FormatInfo = &finfo;
args = Yap_GetFromSlot(sl);
Yap_RecoverSlots(1);
}
Yap_CloseSlots();
if (EX != 0L) {
Term ball;
ex_handler:
ball = Yap_PopTermFromDB(EX);
EX = NULL;
if (tnum <= 8)
targs = NULL;
if (IsAtomTerm(tail)) {
fstr = NULL;
}
format_clean_up(finfo.format_base, fstr, targs);
Yap_JumpToEnv(ball);
return FALSE;
}
break;
case 'q':
if (targ > tnum-1 || has_repeats)
goto do_consistency_error;
t = targs[targ++];
Yap_StartSlots();
Yap_plwrite (t, f_putc, Handle_vars_f|Quote_illegal_f|To_heap_f, 1200);
Yap_CloseSlots();
FormatInfo = &finfo;
break;
case 'w':
if (targ > tnum-1 || has_repeats)
goto do_consistency_error;
t = targs[targ++];
Yap_StartSlots();
Yap_plwrite (t, f_putc, Handle_vars_f|To_heap_f, 1200);
Yap_CloseSlots();
FormatInfo = &finfo;
break;
case '~':
if (has_repeats)
goto do_consistency_error;
f_putc(sno, (int) '~');
break;
case 'n':
if (!has_repeats)
repeats = 1;
while (repeats--) {
f_putc(sno, (int) '\n');
}
column_boundary = 0;
finfo.pad_max = finfo.pad_entries;
break;
case 'N':
if (!has_repeats)
has_repeats = 1;
if (Stream[sno].linepos != 0) {
f_putc(sno, (int) '\n');
column_boundary = 0;
finfo.pad_max = finfo.pad_entries;
}
if (repeats > 1) {
Int i;
for (i = 1; i < repeats; i++)
f_putc(sno, (int) '\n');
column_boundary = 0;
finfo.pad_max = finfo.pad_entries;
}
break;
/* padding */
case '|':
if (has_repeats) {
fill_pads(repeats-(finfo.format_ptr-finfo.format_base));
}
finfo.pad_max = finfo.pad_entries;
if (repeats)
column_boundary = repeats;
else
column_boundary = finfo.format_ptr-finfo.format_base;
break;
case '+':
if (has_repeats) {
fill_pads((repeats+column_boundary)-(finfo.format_ptr-finfo.format_base));
} else {
repeats = 8;
fill_pads(8);
}
finfo.pad_max = finfo.pad_entries;
column_boundary = repeats+column_boundary;
break;
case 't':
if (!has_repeats)
finfo.pad_max->pad = ' ';
else
finfo.pad_max->pad = fptr[-2];
finfo.pad_max->pos = finfo.format_ptr-finfo.format_base;
finfo.pad_max++;
f_putc = format_putc;
break;
do_instantiation_error:
Yap_Error_TYPE = INSTANTIATION_ERROR;
goto do_default_error;
do_type_int_error:
Yap_Error_TYPE = TYPE_ERROR_INTEGER;
goto do_default_error;
do_type_number_error:
Yap_Error_TYPE = TYPE_ERROR_NUMBER;
goto do_default_error;
do_type_atom_error:
Yap_Error_TYPE = TYPE_ERROR_ATOM;
goto do_default_error;
do_domain_not_less_zero_error:
Yap_Error_TYPE = DOMAIN_ERROR_NOT_LESS_THAN_ZERO;
goto do_default_error;
do_domain_error_radix:
Yap_Error_TYPE = DOMAIN_ERROR_RADIX;
goto do_default_error;
do_consistency_error:
default:
Yap_Error_TYPE = CONSISTENCY_ERROR;
do_default_error:
if (tnum <= 8)
targs = NULL;
if (IsAtomTerm(tail)) {
fstr = NULL;
}
{
Term ta[2];
ta[0] = otail;
ta[1] = oargs;
Yap_Error(Yap_Error_TYPE, Yap_MkApplTerm(Yap_MkFunctor(AtomFormat,2),2,ta), "format/2");
}
format_clean_up(finfo.format_base, fstr, targs);
Yap_Error_TYPE = YAP_NO_ERROR;
return FALSE;
}
}
/* ok, now we should have a command */
}
} else {
f_putc(sno, ch);
}
}
if (has_tabs) {
for (fptr = finfo.format_base; fptr < finfo.format_ptr; fptr++) {
Stream[sno].stream_putc(sno, *fptr);
}
}
if (IsAtomTerm(tail)) {
fstr = NULL;
}
if (tnum <= 8)
targs = NULL;
format_clean_up(finfo.format_base, fstr, targs);
return (TRUE);
}
static Int
p_format(void)
{ /* 'format'(Control,Args) */
Int res;
res = format(Deref(ARG1),Deref(ARG2), Yap_c_output_stream);
return res;
}
static Int
format2(UInt stream_flag)
{
int old_c_stream = Yap_c_output_stream;
Int out;
Term tin = Deref(ARG1);
if (IsVarTerm(tin)) {
Yap_Error(INSTANTIATION_ERROR,tin,"format/3");
return FALSE;
}
/* needs to change Yap_c_output_stream for write */
Yap_c_output_stream = CheckStream (ARG1, Output_Stream_f|stream_flag, "format/3");
UNLOCK(Stream[Yap_c_output_stream].streamlock);
if (Yap_c_output_stream == -1) {
Yap_c_output_stream = old_c_stream;
return FALSE;
}
out = format(Deref(ARG2),Deref(ARG3),Yap_c_output_stream);
{
Yap_c_output_stream = old_c_stream;
}
return out;
}
static Int
p_format2(void)
{ /* 'format'(Stream,Control,Args) */
return format2(0);
}
static Int
p_swi_format(void)
{ /* 'format'(Stream,Control,Args) */
return format2(SWI_Stream_f);
}
static Int
p_skip (void)
{ /* '$skip'(Stream,N) */
int sno = CheckStream (ARG1, Input_Stream_f, "skip/2");
Int n = IntOfTerm (Deref (ARG2));
int ch;
if (sno < 0)
return (FALSE);
if (n < 0 || n > 127) {
UNLOCK(Stream[sno].streamlock);
return (FALSE);
}
UNLOCK(Stream[sno].streamlock);
while ((ch = Stream[sno].stream_wgetc(sno)) != n && ch != -1);
return (TRUE);
}
void Yap_FlushStreams(void)
{
}
@ -3822,9 +2871,6 @@ Yap_InitIOPreds(void)
Yap_InitCPred ("$get_read_error_handler", 1, p_get_read_error_handler, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred ("$read", 6, p_read, SyncPredFlag|HiddenPredFlag|UserCPredFlag);
Yap_InitCPred ("$read", 7, p_read2, SyncPredFlag|HiddenPredFlag|UserCPredFlag);
Yap_InitCPred ("$skip", 2, p_skip, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred ("format", 2, p_format, SyncPredFlag);
Yap_InitCPred ("format", 3, p_format2, SyncPredFlag);
Yap_InitCPred ("$start_line", 1, p_startline, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred ("$user_file_name", 2, p_user_file_name, SafePredFlag|SyncPredFlag),
Yap_InitCPred ("$past_eof", 1, p_past_eof, SafePredFlag|SyncPredFlag),
@ -3852,10 +2898,6 @@ Yap_InitIOPreds(void)
Yap_InitCPred ("$toupper", 2, p_toupper, SafePredFlag|HiddenPredFlag);
Yap_InitCPred ("$tolower", 2, p_tolower, SafePredFlag|HiddenPredFlag);
CurrentModule = SYSTEM_MODULE;
Yap_InitCPred ("swi_format", 3, p_swi_format, SyncPredFlag);
CurrentModule = cm;
Yap_InitReadUtil ();
InitPlIO ();
#if HAVE_LIBREADLINE && HAVE_READLINE_READLINE_H

2
C/modules.c
View File

@ -273,7 +273,7 @@ Yap_StripModule(Term t, Term *modp)
restart:
if (IsVarTerm(t)) {
return 0L;
} else if (IsAtomTerm(t)) {
} else if (IsAtomTerm(t) || IsPairTerm(t)) {
*modp = tmod;
return t;
} else if (IsApplTerm(t)) {

5
include/YapInterface.h
View File

@ -465,7 +465,10 @@ extern X_API void PROTO(YAP_PredicateInfo,(void *,YAP_Atom *,YAP_Arity*,YAP_Mod
/* int YAP_CurrentModule() */
extern X_API YAP_Module PROTO(YAP_CurrentModule,(void));
/* int YAP_CurrentModule() */
/* int YAP_SetCurrentModule() */
extern X_API YAP_Module PROTO(YAP_SetCurrentModule,(YAP_Module));
/* int YAP_CreateModule() */
extern X_API YAP_Module PROTO(YAP_CreateModule,(YAP_Atom));
/* int YAP_StripModule() */

22
packages/PLStream/pl-error.c
View File

@ -373,7 +373,27 @@ X_API int PL_error(const char *pred, int arity, const char *msg, int id, ...)
PL_TERM, stream);
break;
}
case ERR_FORMAT:
{ const char *s = va_arg(args, const char*);
int rc;
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "format", 1,
PL_CHARS, s);
break;
}
case ERR_FORMAT_ARG:
{ const char *s = va_arg(args, const char*);
term_t arg = va_arg(args, term_t);
int rc;
rc = PL_unify_term(formal,
PL_FUNCTOR_CHARS, "format_argument_type", 2,
PL_CHARS, s,
PL_TERM, arg);
break;
}
default:
fprintf(stderr, "unimplemented SWI error %d\n",id);
goto err_instantiation;

1
packages/PLStream/pl-file.c
View File

@ -4675,6 +4675,7 @@ static const PL_extension foreigns[] = {
FRG("writeq", 1, pl_writeq, ISO),
FRG("print", 1, pl_print, 0),
FRG("nl", 1, pl_nl1, ISO),
FRG("format", 2, pl_format, META),
FRG("write", 2, pl_write2, ISO),
FRG("writeq", 2, pl_writeq2, ISO),

25
packages/PLStream/pl-fmt.c
View File

@ -320,12 +320,29 @@ word
pl_format3(term_t out, term_t format, term_t args)
{ redir_context ctx;
word rc;
#if __YAP_PROLOG__
/*
YAP allows the last argument to format to be of the form
module:[]
*/
YAP_Term mod;
#endif
if ( (rc=setupOutputRedirect(out, &ctx, FALSE)) )
{ if ( (rc = format_impl(ctx.stream, format, args)) )
rc = closeOutputRedirect(&ctx);
else
if ( (rc=setupOutputRedirect(out, &ctx, FALSE)) ) {
#if __YAP_PROLOG__
/* module processing */
{
args = Yap_fetch_module_for_format(args, &mod);
}
#endif
{ if ( (rc = format_impl(ctx.stream, format, args)) )
rc = closeOutputRedirect(&ctx);
else
discardOutputRedirect(&ctx);
}
#if __YAP_PROLOG__
YAP_SetCurrentModule(mod);
#endif
}
return rc;

19
packages/PLStream/pl-incl.h
View File

@ -50,6 +50,25 @@ typedef struct
} value;
} number, *Number;
#define TOINT_CONVERT_FLOAT 0x1 /* toIntegerNumber() */
#define TOINT_TRUNCATE 0x2
#ifdef O_GMP
#define intNumber(n) ((n)->type <= V_MPZ)
#else
#define intNumber(n) ((n)->type < V_FLOAT)
#endif
#define floatNumber(n) ((n)->type >= V_FLOAT)
typedef enum
{ NUM_ERROR = FALSE, /* Syntax error */
NUM_OK = TRUE, /* Ok */
NUM_FUNDERFLOW = -1, /* Float underflow */
NUM_FOVERFLOW = -2, /* Float overflow */
NUM_IOVERFLOW = -3 /* Integer overflow */
} strnumstat;
#define Arg(N) (PL__t0+((n)-1))
#define A1 (PL__t0)
#define A2 (PL__t0+1)

59
packages/PLStream/pl-yap.c
View File

@ -147,9 +147,39 @@ callProlog(module_t module, term_t goal, int flags, term_t *ex)
}
}
extern YAP_Term Yap_InnerEval(YAP_Term t);
inline static YAP_Term
Yap_Eval(YAP_Term t)
{
if (t == 0L || ( !YAP_IsVarTerm(t) && (YAP_IsIntTerm(t) || YAP_IsFloatTerm(t)) ))
return t;
return Yap_InnerEval(t);
}
int
valueExpression(term_t t, Number r ARG_LD)
{ //return YAP__expression(t, r, 0 PASS_LD);
{
YAP_Term t0 = Yap_Eval(YAP_GetFromSlot(t));
if (YAP_IsIntTerm(t0)) {
r->type = V_INTEGER;
r->value.i = YAP_IntOfTerm(t0);
return 1;
}
if (YAP_IsFloatTerm(t0)) {
r->type = V_FLOAT;
r->value.f = YAP_FloatOfTerm(t0);
return 1;
}
#ifdef O_GMP
if (YAP_IsBigNumTerm(t0)) {
r->type = V_MPZ;
mpz_init(&r->value.mpz);
YAP_BigNumOfTerm(t0, &r->value.mpz);
return 1;
}
#endif
return 0;
}
@ -166,10 +196,21 @@ Note that if a double is out of range for int64_t, it never has a
fractional part.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static int
double_in_int64_range(double x)
{ int k;
double y = frexp(x, &k);
if ( k < 8*(int)sizeof(int64_t) ||
(y == -0.5 && k == 8*(int)sizeof(int64_t)) )
return TRUE;
return FALSE;
}
int
toIntegerNumber(Number n, int flags)
{
#if SWI_PROLOG
switch(n->type)
{ case V_INTEGER:
succeed;
@ -185,7 +226,7 @@ switch(n->type)
}
fail;
#endif
case V_REAL:
case V_FLOAT:
if ( (flags & TOINT_CONVERT_FLOAT) )
{ if ( double_in_int64_range(n->value.f) )
{ int64_t l = (int64_t)n->value.f;
@ -209,7 +250,6 @@ switch(n->type)
}
return FALSE;
}
#endif
assert(0);
fail;
}
@ -826,6 +866,17 @@ PL_utf8_strlen(const char *s, size_t len)
{ return utf8_strlen(s, len);
}
term_t
Yap_fetch_module_for_format(term_t args, YAP_Term *modp) {
YAP_Term nmod;
YAP_Term nt = YAP_StripModule(YAP_GetFromSlot(args), &nmod);
*modp = YAP_SetCurrentModule(nmod);
if (!nt) {
return args;
}
return YAP_InitSlot(nt);
}
#define COUNT_MUTEX_INITIALIZER(name) \
{ PTHREAD_MUTEX_INITIALIZER, \
name, \

5
pl/boot.yap
View File

@ -1554,3 +1554,8 @@ telling(File) :-
swi_telling(File).
told :-
swi_told.
format(Command, Args) :-
swi_format(Command, Args).
format(Stream, Command, Args) :-
swi_format(Stream, Command, Args).

1
pl/consult.yap
View File

@ -248,7 +248,6 @@ use_module(M,F,Is) :-
'$file_name'(Stream,File),
'$fetch_stream_alias'(OldStream,'$loop_stream'),
set_stream(Stream,alias('$loop_stream')),
format('this~n',[]),
nb_getval('$consulting',Old),
nb_setval('$consulting',false),
'$access_yap_flags'(18,GenerateDebug),

58
pl/yio.yap
View File

@ -33,8 +33,6 @@
'$check_opt_read'(Opt, G).
'$check_opt'(stream_property(_,_),Opt,G) :-
'$check_opt_sp'(Opt, G).
'$check_opt'(write_term(_,_),Opt,G) :-
'$check_opt_write'(Opt, G).
'$check_opt'(yap_flag(_,_),Opt,G) :-
'$check_opt_write'(Opt, G).
@ -64,29 +62,6 @@
'$check_opt_sp'(A, G) :-
'$do_error'(domain_error(stream_property,A),G).
'$check_opt_write'(attributes(T), G) :- !,
'$check_write_attributes'(T, G).
'$check_opt_write'(cycles(T), G) :- !,
'$check_boolean'(T, write_option, cycles(T), G).
'$check_opt_write'(quoted(T), G) :- !,
'$check_boolean'(T, write_option, quoted(T), G).
'$check_opt_write'(ignore_ops(T), G) :- !,
'$check_boolean'(T, write_option, ignore_ops(T), G).
'$check_opt_write'(max_depth(T), G) :- !,
'$check_write_max_depth'(T, G).
'$check_opt_write'(numbervars(T), G) :- !,
'$check_boolean'(T, write_option, ignore_ops(T), G).
'$check_opt_write'(portrayed(T), G) :- !,
'$check_boolean'(T, write_option, portrayed(T), G).
'$check_opt_write'(portray(T), G) :- !,
'$check_boolean'(T, write_option, portray(T), G).
'$check_opt_write'(priority(T), G) :- !,
'$check_priority_arg'(T, G).
'$check_opt_write'(swi(T), G) :- !,
'$check_boolean'(T, write_option, swi(T), G).
'$check_opt_write'(A, G) :-
'$do_error'(domain_error(write_option,A),G).
'$check_read_syntax_errors_arg'(X, G) :- var(X), !,
'$do_error'(instantiation_error,G).
'$check_read_syntax_errors_arg'(dec10,_) :- !.
@ -96,15 +71,6 @@
'$check_read_syntax_errors_arg'(X,G) :-
'$do_error'(domain_error(read_option,syntax_errors(X)),G).
'$check_write_attributes'(X, G) :- var(X), !,
'$do_error'(instantiation_error,G).
'$check_write_attributes'(ignore,_) :- !.
'$check_write_attributes'(dots,_) :- !.
'$check_write_attributes'(write,_) :- !.
'$check_write_attributes'(portray,_) :- !.
'$check_write_attributes'(X,G) :-
'$do_error'(domain_error(write_option,attributes(X)),G).
'$check_boolean'(X, _, _, G) :- var(X), !,
'$do_error'(instantiation_error,G).
'$check_boolean'(true,_,_,_) :- !.
@ -112,18 +78,6 @@
'$check_boolean'(X,B,T,G) :-
'$do_error'(domain_error(B,T),G).
'$check_write_max_depth'(X, G) :- var(X), !,
'$do_error'(instantiation_error,G).
'$check_write_max_depth'(I,_) :- integer(I), I >= 0, !.
'$check_write_max_depth'(X,G) :-
'$do_error'(domain_error(write_option,max_depth(X)),G).
'$check_priority_arg'(X, G) :- var(X), !,
'$do_error'(instantiation_error,G).
'$check_priority_arg'(I,_) :- integer(I), I >= 0, I =< 1200, !.
'$check_priority_arg'(X,G) :-
'$do_error'(domain_error(write_option,priority(X)),G).
open_pipe_streams(Read, Write) :-
(
'$undefined'(pipe(_,_),unix)
@ -360,18 +314,18 @@ write_depth(T,L) :- write_depth(T,L,_).
stream_position_data(Prop, Term, Value) :-
nonvar(Prop), !,
( stream_position_field(Prop, Pos)
( '$stream_position_field'(Prop, Pos)
-> arg(Pos, Term, Value)
; throw(error(domain_error(stream_position_data, Prop)))
).
stream_position_data(Prop, Term, Value) :-
stream_position_field(Prop, Pos),
'$stream_position_field'(Prop, Pos),
arg(Pos, Term, Value).
stream_position_field(char_count, 1).
stream_position_field(line_count, 2).
stream_position_field(line_position, 3).
stream_position_field(byte_count, 4).
'$stream_position_field'(char_count, 1).
'$stream_position_field'(line_count, 2).
'$stream_position_field'(line_position, 3).
'$stream_position_field'(byte_count, 4).
'$default_expand'(Expand) :-