From 4dbdaaa772403be4dbab8c518ceecd8070cdf09b Mon Sep 17 00:00:00 2001 From: ubu32 Date: Mon, 14 Feb 2011 14:13:45 -0800 Subject: [PATCH] eplace format --- C/c_interface.c | 9 + C/iopreds.c | 958 ----------------------------------- C/modules.c | 2 +- include/YapInterface.h | 5 +- packages/PLStream/pl-error.c | 22 +- packages/PLStream/pl-file.c | 1 + packages/PLStream/pl-fmt.c | 25 +- packages/PLStream/pl-incl.h | 19 + packages/PLStream/pl-yap.c | 59 ++- pl/boot.yap | 5 + pl/consult.yap | 1 - pl/yio.yap | 58 +-- 12 files changed, 142 insertions(+), 1022 deletions(-) diff --git a/C/c_interface.c b/C/c_interface.c index aff29e216..2d6510b3f 100755 --- a/C/c_interface.c +++ b/C/c_interface.c @@ -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) { diff --git a/C/iopreds.c b/C/iopreds.c index 16463a638..5bca52b78 100644 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -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 diff --git a/C/modules.c b/C/modules.c index 9c7c0276e..e85e78c32 100644 --- a/C/modules.c +++ b/C/modules.c @@ -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)) { diff --git a/include/YapInterface.h b/include/YapInterface.h index b787fae33..c26a10ff0 100755 --- a/include/YapInterface.h +++ b/include/YapInterface.h @@ -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() */ diff --git a/packages/PLStream/pl-error.c b/packages/PLStream/pl-error.c index becd6b6cd..ef0f793fe 100644 --- a/packages/PLStream/pl-error.c +++ b/packages/PLStream/pl-error.c @@ -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; diff --git a/packages/PLStream/pl-file.c b/packages/PLStream/pl-file.c index d20d84970..910a6c0a4 100755 --- a/packages/PLStream/pl-file.c +++ b/packages/PLStream/pl-file.c @@ -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), diff --git a/packages/PLStream/pl-fmt.c b/packages/PLStream/pl-fmt.c index 8f005b120..7b7077249 100644 --- a/packages/PLStream/pl-fmt.c +++ b/packages/PLStream/pl-fmt.c @@ -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; diff --git a/packages/PLStream/pl-incl.h b/packages/PLStream/pl-incl.h index 3f150759f..e6d0053d4 100755 --- a/packages/PLStream/pl-incl.h +++ b/packages/PLStream/pl-incl.h @@ -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) diff --git a/packages/PLStream/pl-yap.c b/packages/PLStream/pl-yap.c index 6b201826d..e6224db27 100755 --- a/packages/PLStream/pl-yap.c +++ b/packages/PLStream/pl-yap.c @@ -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, \ diff --git a/pl/boot.yap b/pl/boot.yap index fa7e189e3..34f324955 100755 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -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). diff --git a/pl/consult.yap b/pl/consult.yap index 138b58fd1..9e0a2c6e5 100755 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -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), diff --git a/pl/yio.yap b/pl/yio.yap index 2b4f4834e..477e02397 100644 --- a/pl/yio.yap +++ b/pl/yio.yap @@ -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) :-