/* $Id$ Part of SWI-Prolog Author: Jan Wielemaker E-mail: J.Wielemaker@cs.vu.nl WWW: http://www.swi-prolog.org Copyright (C): 1985-2010, University of Amsterdam Vu University Amsterdam This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ #include #include "pl-incl.h" #include "pl-dtoa.h" #include "pl-ctype.h" #include /* sprintf() */ #ifdef HAVE_LOCALE_H #include #endif #ifdef HAVE_FLOAT_H #include #endif #ifdef HAVE_IEEEFP_H #include #endif #ifdef fpclassify #define HAVE_FPCLASSIFY 1 #endif typedef struct visited { Word address; /* we have done this address */ struct visited *next; /* next already visited */ } visited; typedef struct { int flags; /* PL_WRT_* flags */ int max_depth; /* depth limit */ int depth; /* current depth */ atom_t spacing; /* Where to insert spaces */ Module module; /* Module for operators */ IOSTREAM *out; /* stream to write to */ visited *visited; /* visited (attributed-) variables */ } write_options; static bool writeTerm2(term_t term, int prec, write_options *options, bool arg) WUNUSED; static bool writeTerm(term_t t, int prec, write_options *options) WUNUSED; static bool writeArgTerm(term_t t, int prec, write_options *options, bool arg) WUNUSED; #if __YAP_PROLOG__ static Word address_of(term_t t) { return YAP_AddressFromSlot(t); /* non-recursive structure */ } #else static Word address_of(term_t t) { GET_LD Word adr = valTermRef(t); deRef(adr); switch(tag(*adr)) { case TAG_ATTVAR: return adr; case TAG_COMPOUND: return valPtr(*adr); default: return NULL; /* non-recursive structure */ } } #endif static int has_visited(visited *v, Word addr) { for( ; v; v=v->next ) { if ( v->address == addr ) succeed; } fail; } char * varName(term_t t, char *name) #if __YAP_PROLOG__ { YAP_Int adr = YAP_VarSlotToNumber(t); if (adr < 0) Ssprintf(name, "_L%ld", -adr); else Ssprintf(name, "_G%ld", adr); return name; } #else { GET_LD Word adr = valTermRef(t); deRef(adr); if (adr > (Word) lBase) Ssprintf(name, "_L%ld", (Word)adr - (Word)lBase); else Ssprintf(name, "_G%ld", (Word)adr - (Word)gBase); return name; } #endif #define AT_LOWER 0 #define AT_QUOTE 1 #define AT_FULLSTOP 2 #define AT_SYMBOL 3 #define AT_SOLO 4 #define AT_SPECIAL 5 /* Note: this only deals with ISO Latin-1 atoms; wide atoms are handled by writeUCSAtom() */ static int atomType(atom_t a, IOSTREAM *fd) { Atom atom = atomValue(a); char *s = atomName(atom); size_t len = atomLength(atom); if ( len == 0 ) return AT_QUOTE; if ( isLower(*s) ) { for(++s; --len > 0 && isAlpha(*s) && Scanrepresent(*s, fd)==0; s++) ; return len == 0 ? AT_LOWER : AT_QUOTE; } if ( a == ATOM_dot ) return AT_FULLSTOP; if ( isSymbol(*s) ) { if ( len >= 2 && s[0] == '/' && s[1] == '*' ) return AT_QUOTE; for(++s; --len > 0 && isSymbol(*s) && Scanrepresent(*s, fd)==0; s++) ; return len == 0 ? AT_SYMBOL : AT_QUOTE; } /* % should be quoted! */ if ( len == 1 && *s != '%' ) { if ( isSolo(*s) ) return AT_SOLO; } if ( a == ATOM_nil || a == ATOM_curl ) return AT_SPECIAL; return AT_QUOTE; } /******************************* * PRIMITIVE WRITES * *******************************/ #define TRUE_WITH_SPACE 2 /* OK, and emitted leading space before token */ static bool Putc(int c, IOSTREAM *s) { return Sputcode(c, s) == EOF ? FALSE : TRUE; } static bool PutString(const char *str, IOSTREAM *s) { const unsigned char *q = (const unsigned char *)str; for( ; *q != EOS; q++ ) { if ( Sputcode(*q, s) == EOF ) return FALSE; } return TRUE; } static bool PutComma(write_options *options) { if ( options->spacing == ATOM_next_argument ) return PutString(", ", options->out); else return PutString(",", options->out); } static bool PutStringN(const char *str, size_t length, IOSTREAM *s) { size_t i; const unsigned char *q = (const unsigned char *)str; for(i=0; ilastc = EOF; return FALSE; } else if ( s->lastc != EOF && ((isAlphaW(s->lastc) && isAlphaW(c)) || (isSymbolW(s->lastc) && isSymbolW(c)) || (s->lastc != '(' && !isBlank(s->lastc) && c == '(') || (c == '\'' && isDigit(s->lastc))) ) { return TRUE; } return FALSE; } static int PutOpenToken(int c, IOSTREAM *s) { if ( needSpace(c, s) ) { TRY(Putc(' ', s)); return TRUE_WITH_SPACE; } return TRUE; } static int PutToken(const char *s, IOSTREAM *stream) { if ( s[0] ) { int rc; TRY(rc=PutOpenToken(s[0]&0xff, stream)); TRY(PutString(s, stream)); return rc; } return TRUE; } static int PutTokenN(const char *s, size_t len, IOSTREAM *stream) { if ( len > 0 ) { int rc; TRY(rc=PutOpenToken(s[0]&0xff, stream)); TRY(PutStringN(s, len, stream)); return rc; } return TRUE; } #if __YAP_PROLOG__ static bool PutWideStringN(const wchar_t *str, size_t length, IOSTREAM *s) { size_t i; const wchar_t *q = (const wchar_t *)str; for(i=0; i 0 ) { int rc; TRY(rc=PutOpenToken(s[0]&0xff, stream)); TRY(PutWideStringN(s, len, stream)); return rc; } return TRUE; } #endif /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - PutOpenBrace()/PutCloseBrace() are used to put additional braces around a term to avoid an operator precedence problem. If the last emitted character is alphanumerical, there should be a space before the openbrace to avoid interpretation as a term. E.g. not (a,b) instead of not(a,b). Reported by Stefan.Mueller@dfki.de. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static int PutOpenBrace(IOSTREAM *s) { int rc; TRY(rc=PutOpenToken('(', s)); TRY(Putc('(', s)); return rc; } static bool PutCloseBrace(IOSTREAM *s) { return Putc(')', s); } static bool putQuoted(int c, int quote, int flags, IOSTREAM *stream) { if ( (flags & PL_WRT_CHARESCAPES) ) { if ( !(c < 0xff && isControl(c)) && c != quote && c != '\\' ) { TRY(Putc(c, stream)); } else { char esc[8]; esc[1] = EOS; if ( c == quote ) { esc[0] = c; } else { switch(c) { case 7: esc[0] = 'a'; break; case '\b': esc[0] = 'b'; break; case '\t': esc[0] = 't'; break; case '\n': esc[0] = 'n'; break; case 11: esc[0] = 'v'; break; case '\r': esc[0] = 'r'; break; case '\f': esc[0] = 'f'; break; case '\\': esc[0] = '\\'; break; default: if ( c <= 0xff ) Ssprintf(esc, "%03o\\", c); else assert(0); /* to be done */ } } if ( !Putc('\\', stream) || !PutString(esc, stream) ) fail; } } else { if ( !Putc(c, stream) ) fail; if ( c == quote || c == '\\' ) /* write '' or \\ */ { if ( !Putc(c, stream) ) fail; } } return TRUE; } static bool writeQuoted(IOSTREAM *stream, const char *text, size_t len, int quote, write_options *options) { const unsigned char *s = (const unsigned char *)text; TRY(Putc(quote, stream)); while(len-- > 0) { TRY(putQuoted(*s++, quote, options->flags, stream)); } return Putc(quote, stream); } #if O_ATTVAR static bool writeAttVar(term_t av, write_options *options) { GET_LD char buf[32]; TRY(PutToken(varName(av, buf), options->out)); if ( (options->flags & PL_WRT_ATTVAR_DOTS) ) { return PutString("{...}", options->out); } else if ( (options->flags & PL_WRT_ATTVAR_WRITE) ) { fid_t fid; term_t a; visited v; if ( !(fid = PL_open_foreign_frame()) ) return FALSE; v.address = address_of(av); if ( has_visited(options->visited, v.address) ) succeed; v.next = options->visited; options->visited = &v; Sputcode('{', options->out); a = PL_new_term_ref(); PL_get_attr__LD(av, a PASS_LD); if ( !writeTerm(a, 1200, options) ) goto error; Sputcode('}', options->out); PL_discard_foreign_frame(fid); options->visited = v.next; succeed; error: options->visited = v.next; fail; } else if ( (options->flags & PL_WRT_ATTVAR_PORTRAY) && GD->cleaning <= CLN_PROLOG ) { fid_t fid; predicate_t pred; IOSTREAM *old; if ( !(fid = PL_open_foreign_frame()) ) return FALSE; pred = _PL_predicate("portray_attvar", 1, "$attvar", &GD->procedures.portray_attvar1); old = Scurout; Scurout = options->out; PL_call_predicate(NULL, PL_Q_NODEBUG, pred, av); Scurout = old; PL_discard_foreign_frame(fid); } succeed; } #endif static bool writeBlob(atom_t a, write_options *options) { Atom atom = atomValue(a); unsigned char const *s, *e; TRY(PutString("<#", options->out)); s = (unsigned char const *)atomName(atom); for (e = s + atomLength(atom); s != e; s++) { static char *digits = "0123456789abcdef"; TRY(Putc(digits[(*s >> 4) & 0xf], options->out)); TRY(Putc(digits[(*s ) & 0xf], options->out)); } return PutString(">", options->out); } static int /* FALSE, TRUE or TRUE_WITH_SPACE */ writeAtom(atom_t a, write_options *options) { Atom atom = atomValue(a); if ( (options->flags & PL_WRT_BLOB_PORTRAY) && false(atomBlobType(atom), PL_BLOB_TEXT) && GD->cleaning <= CLN_PROLOG ) { GET_LD int rc; fid_t fid; predicate_t pred; IOSTREAM *old; term_t av; if ( !(fid = PL_open_foreign_frame()) ) return FALSE; av = PL_new_term_ref(); PL_put_atom(av, a); pred = _PL_predicate("portray", 1, "user", &GD->procedures.portray); old = Scurout; Scurout = options->out; rc = PL_call_predicate(NULL, PL_Q_NODEBUG, pred, av); Scurout = old; PL_discard_foreign_frame(fid); if ( rc == TRUE ) return TRUE; } if ( atomBlobType(atom)->write ) return (*atomBlobType(atom)->write)(options->out, a, options->flags); if ( false(atomBlobType(atom), PL_BLOB_TEXT) ) return writeBlob(a, options); #if __YAP_PROLOG__ if (isWideAtom(atom)) { return writeUCSAtom(options->out, a, options->flags); } #endif if ( true(options, PL_WRT_QUOTED) ) { switch( atomType(a, options->out) ) { case AT_LOWER: case AT_SYMBOL: case AT_SOLO: case AT_SPECIAL: return PutToken(nameOfAtom(atom), options->out); case AT_QUOTE: case AT_FULLSTOP: default: { int rc; TRY(rc=PutOpenToken('\'', options->out)); TRY(writeQuoted(options->out, nameOfAtom(atom), atomLength(atom), '\'', options)); return rc; } } } else { return PutTokenN(nameOfAtom(atom), atomLength(atom), options->out); } } int writeAtomToStream(IOSTREAM *s, atom_t atom) { write_options options; memset(&options, 0, sizeof(options)); options.out = s; options.module = MODULE_user; return writeAtom(atom, &options); } int writeUCSAtom(IOSTREAM *fd, atom_t atom, int flags) { Atom a = atomValue(atom); pl_wchar_t *s = (pl_wchar_t*)atomName(a); size_t len = atomLength(a)/sizeof(pl_wchar_t); pl_wchar_t *e = &s[len]; if ( flags & PL_WRT_QUOTED ) { pl_wchar_t quote = L'\''; int rc; if ( isLowerW(*s) ) { pl_wchar_t *q; for(q=s; qencoding) { case ENC_ISO_LATIN_1: return t->text.t[index]&0xff; case ENC_WCHAR: return t->text.w[index]; default: assert(0); return 0; } } static int writeString(term_t t, write_options *options) { GET_LD PL_chars_t txt; PL_get_text(t, &txt, CVT_STRING); if ( true(options, PL_WRT_QUOTED) ) { int quote; unsigned int i; if ( true(options, PL_WRT_BACKQUOTED_STRING) ) quote = '`'; else quote = '"'; TRY(Putc(quote, options->out)); for(i=0; iflags, options->out)); } return Putc(quote, options->out); } else { unsigned int i; for(i=0; iout)); } } succeed; } #endif /*O_STRING*/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Formatting a float. This used to use sprintf(), but there are two problems with this. First of all, this uses the current locale, which is complicated to avoid. Second, it does not provide a mode that guarantees reliable read-back. Using %g gets closest, but %.15g doesn't guarantee read-back and %.17g does, but prints 0.1 as 0.100..001, etc. This uses dtoa.c. See pl-dtoa.c for how this is packed into SWI-Prolog. TBD: The number of cases are large. We should see whether it is possible to clean this up a bit. The 5 cases as such are real: there is no way around these. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ char * format_float(double f, char *buf) { char *end, *o=buf; int decpt, sign; char *s = dtoa(f, 0, 30, &decpt, &sign, &end); DEBUG(2, Sdprintf("decpt=%d, sign=%d, len = %d, '%s'\n", decpt, sign, end-s, s)); if ( sign ) *o++ = '-'; if ( decpt <= 0 ) /* decimal dot before */ { if ( decpt <= -4 ) { *o++ = s[0]; *o++ = '.'; if ( end-s > 1 ) { memcpy(o, s+1, end-s-1); o += end-s-1; } else *o++ = '0'; sprintf(o, "e%d", decpt-1); } else { int i; *o++ = '0'; *o++ = '.'; for(i=0; i < -decpt; i++) *o++ = '0'; memcpy(o, s, end-s); o[end-s] = 0; } } else if ( end-s > decpt ) /* decimal dot inside */ { memcpy(o, s, decpt); o += decpt; *o++ = '.'; memcpy(o, s+decpt, end-s-decpt); o[end-s-decpt] = 0; } else /* decimal dot after */ { int i; int trailing = decpt-(int)(end-s); if ( decpt > 15 ) /* over precision: use eE */ { *o++ = s[0]; *o++ = '.'; if ( end-s > 1 ) { trailing += (int)(end-s)-1; memcpy(o, s+1, end-s-1); o += end-s-1; } else *o++ = '0'; sprintf(o, "e+%d", trailing); } else /* within precision trail with .0 */ { memcpy(o, s, end-s); o += end-s; for(i=(int)(end-s); itype) { case V_INTEGER: { char buf[32]; sprintf(buf, INT64_FORMAT, n->value.i); return PutToken(buf, options->out); } #ifdef O_GMP case V_MPZ: { char tmp[1024]; char *buf; size_t sz = mpz_sizeinbase(n->value.mpz, 10) + 2; bool rc; if ( sz <= sizeof(tmp) ) buf = tmp; else buf = PL_malloc(sz); /* mpz_get_str() can perform large intermediate allocations :-( */ EXCEPTION_GUARDED({ LD->gmp.persistent++; mpz_get_str(buf, 10, n->value.mpz); LD->gmp.persistent--; }, { LD->gmp.persistent--; rc = PL_rethrow(); }) rc = PutToken(buf, options->out); if ( buf != tmp ) PL_free(buf); return rc; } case V_MPQ: /* should not get here */ #endif case V_FLOAT: assert(0); } fail; } static bool writePrimitive(term_t t, write_options *options) { GET_LD double f; atom_t a; char buf[32]; IOSTREAM *out = options->out; #if O_ATTVAR if ( PL_is_attvar(t) ) return writeAttVar(t, options); #endif if ( PL_is_variable(t) ) return PutToken(varName(t, buf), out); if ( PL_get_atom(t, &a) ) return writeAtom(a, options); if ( PL_is_integer(t) ) /* beware of automatic conversion */ { number n; PL_get_number(t, &n); return WriteNumber(&n, options); } if ( PL_get_float(t, &f) ) { char *s = NULL; #ifdef HAVE_FPCLASSIFY switch(fpclassify(f)) { case FP_NAN: s = (true(options, PL_WRT_QUOTED) ? "'$NaN'" : "NaN"); break; case FP_INFINITE: s = (true(options, PL_WRT_QUOTED) ? "'$Infinity'" : "Infinity"); break; } #else #ifdef HAVE_FPCLASS switch(fpclass(f)) { case FP_SNAN: case FP_QNAN: s = (true(options, PL_WRT_QUOTED) ? "'$NaN'" : "NaN"); break; case FP_NINF: case FP_PINF: s = (true(options, PL_WRT_QUOTED) ? "'$Infinity'" : "Infinity"); break; case FP_NDENORM: /* pos/neg denormalized non-zero */ case FP_PDENORM: case FP_NNORM: /* pos/neg normalized non-zero */ case FP_PNORM: case FP_NZERO: /* pos/neg zero */ case FP_PZERO: break; } #else #ifdef HAVE__FPCLASS switch(_fpclass(f)) { case _FPCLASS_SNAN: case _FPCLASS_QNAN: s = (true(options, PL_WRT_QUOTED) ? "'$NaN'" : "NaN"); break; case _FPCLASS_NINF: case _FPCLASS_PINF: s = (true(options, PL_WRT_QUOTED) ? "'$Infinity'" : "Infinity"); break; } #else #ifdef HAVE_ISINF if ( isinf(f) ) { s = (true(options, PL_WRT_QUOTED) ? "'$Infinity'" : "Infinity"); } else #endif #ifdef HAVE_ISNAN if ( isnan(f) ) { s = (true(options, PL_WRT_QUOTED) ? "'$NaN'" : "NaN"); } #endif #endif /*HAVE__FPCLASS*/ #endif /*HAVE_FPCLASS*/ #endif /*HAVE_FPCLASSIFY*/ if ( s ) { return PutToken(s, out); } else { char buf[100]; format_float(f, buf); return PutToken(buf, out); } } #if O_STRING if ( PL_is_string(t) ) return writeString(t, options); #endif /* O_STRING */ #if __YAP_PROLOG__ { Opaque_CallOnWrite f; if ( (f = Yap_blob_write_handler_from_slot(t)) ) { return (f)(options->out, Yap_blob_tag_from_slot(t), Yap_blob_info_from_slot(t), options->flags); } else { number n; n.type = V_INTEGER; n.value.i = 0; return WriteNumber(&n, options); } } #endif assert(0); fail; } word pl_nl1(term_t stream) { IOSTREAM *s; if ( getOutputStream(stream, &s) ) { Sputcode('\n', s); return streamStatus(s); } fail; } word pl_nl(void) { return pl_nl1(0); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Call user:portray/1 if defined. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static int callPortray(term_t arg, write_options *options) { predicate_t portray; if ( GD->cleaning > CLN_PROLOG ) fail; /* avoid dangerous callbacks */ portray = _PL_predicate("portray", 1, "user", &GD->procedures.portray); if ( predicateHasClauses(portray) ) { GET_LD wakeup_state wstate; IOSTREAM *old = Scurout; int rval; if ( !saveWakeup(&wstate, TRUE PASS_LD) ) return FALSE; Scurout = options->out; rval = PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION, portray, arg); if ( !rval && PL_exception(0) ) rval = -1; Scurout = old; restoreWakeup(&wstate PASS_LD); return rval; } fail; } static bool writeArgTerm(term_t t, int prec, write_options *options, bool arg) { int rval; int levelSave = options->depth; fid_t fid; if ( !(fid = PL_open_foreign_frame()) ) return FALSE; if ( PL_handle_signals() < 0 ) { rval = FALSE; goto out; } if ( ++options->depth > options->max_depth && options->max_depth ) rval = PutString("...", options->out); else if ( PL_is_compound(t) ) { visited v; v.address = address_of(t); if ( has_visited(options->visited, v.address) ) { rval = PutString("**", options->out); } else { v.next = options->visited; options->visited = &v; rval = writeTerm2(t, prec, options, arg); options->visited = v.next; } } else { rval = writeTerm2(t, prec, options, arg); } out: options->depth = levelSave; PL_close_foreign_frame(fid); return rval; } static bool writeTerm(term_t t, int prec, write_options *options) { return writeArgTerm(t, prec, options, FALSE); } static bool writeList2(term_t list, write_options *options, int cyclic) { GET_LD term_t head = PL_new_term_ref(); term_t l = PL_copy_term_ref(list); TRY(Putc('[', options->out)); for(;;) { PL_get_list(l, head, l); TRY(writeArgTerm(head, 999, options, TRUE)); if ( PL_get_nil(l) ) break; if ( ++options->depth >= options->max_depth && options->max_depth ) return PutString("|...]", options->out); if ( !PL_is_functor(l, FUNCTOR_dot2) ) { TRY(Putc('|', options->out)); TRY(writeArgTerm(l, 999, options, TRUE)); break; } /* cycle detection */ { Word addr = address_of(l); if ( has_visited(options->visited, addr) ) { return PutString("|**]", options->out); } else if ( cyclic ) { visited *v = alloca(sizeof(*v)); v->address = addr; v->next = options->visited; options->visited = v; } } TRY(PutComma(options)); } return Putc(']', options->out); } static bool writeList(term_t list, write_options *options) { GET_LD visited *v = options->visited; Word tail; int rc; skip_list(valTermRef(list), &tail PASS_LD); rc = writeList2(list, options, isList(*tail)); options->visited = v; return rc; } static bool writeTerm2(term_t t, int prec, write_options *options, bool arg) { GET_LD atom_t functor; int arity, n; int op_type, op_pri; atom_t a; IOSTREAM *out = options->out; if ( !PL_is_variable(t) && true(options, PL_WRT_PORTRAY) ) { switch( callPortray(t, options) ) { case TRUE: return TRUE; case FALSE: break; default: return FALSE; } } #if __YAP_PROLOG__ t = Yap_CvtTerm(t); #endif if ( PL_get_atom(t, &a) ) { if ( !arg && prec < 1200 && priorityOperator((Module)NULL, a) > 0 ) { if ( PutOpenBrace(out) && writeAtom(a, options) && PutCloseBrace(out) ) succeed; } else return writeAtom(a, options); } if ( !PL_get_name_arity(t, &functor, &arity) ) { return writePrimitive(t, options); } else { if ( arity == 1 && functor == ATOM_isovar && /* $VAR/1 */ true(options, PL_WRT_NUMBERVARS) ) { int n; atom_t a; term_t arg = PL_new_term_ref(); _PL_get_arg(1, t, arg); #if __YAP_PROLOG__ /* YAP supports $VAR(-1) as a quick hack to write singleton variables */ #define MIN_DOLLAR_VAR -1 #else #define MIN_DOLLAR_VAR 0 #endif if ( PL_get_integer(arg, &n) && n >= MIN_DOLLAR_VAR ) { int i = n % 26; int j = n / 26; char buf[16]; #if __YAP_PROLOG__ if ( n == -1 ) { buf[0] = '_'; buf[1] = EOS; } else #endif if ( j == 0 ) { buf[0] = i+'A'; buf[1] = EOS; } else { sprintf(buf, "%c%d", i+'A', j); } return PutToken(buf, out); } if ( PL_get_atom(arg, &a) ) { write_options o2 = *options; clear(&o2, PL_WRT_QUOTED); return writeAtom(a, &o2); } } if ( false(options, PL_WRT_IGNOREOPS) ) { term_t arg = PL_new_term_ref(); if ( arity == 1 ) { if ( functor == ATOM_curl ) /* {a,b,c} */ { _PL_get_arg(1, t, arg); TRY(Putc('{', out)); TRY(writeTerm(arg, 1200, options) && Putc('}', out)); succeed; } /* op */ if ( currentOperator(options->module, functor, OP_PREFIX, &op_type, &op_pri) ) { term_t arg = PL_new_term_ref(); int embrace; embrace = ( op_pri > prec ); _PL_get_arg(1, t, arg); if ( embrace ) { TRY(PutOpenBrace(out)); } TRY(writeAtom(functor, options)); /* +/-(Number) : avoid parsing as number */ if ( (functor == ATOM_minus || functor == ATOM_plus) && PL_is_number(arg) ) { TRY(Putc('(', out)); TRY(writeTerm(arg, 999, options)); TRY(Putc(')', out)); } else { TRY(writeTerm(arg, op_type == OP_FX ? op_pri-1 : op_pri, options)); } if ( embrace ) { TRY(PutCloseBrace(out)); } succeed; } /* op */ if ( currentOperator(options->module, functor, OP_POSTFIX, &op_type, &op_pri) ) { term_t arg = PL_new_term_ref(); _PL_get_arg(1, t, arg); if ( op_pri > prec ) TRY(PutOpenBrace(out)); TRY(writeTerm(arg, op_type == OP_XF ? op_pri-1 : op_pri, options)); TRY(writeAtom(functor, options)); if (op_pri > prec) TRY(PutCloseBrace(out)); succeed; } } else if ( arity == 2 ) { if ( functor == ATOM_dot ) /* [...] */ return writeList(t, options); /* op */ if ( currentOperator(options->module, functor, OP_INFIX, &op_type, &op_pri) ) { term_t l = PL_new_term_ref(); term_t r = PL_new_term_ref(); _PL_get_arg(1, t, l); _PL_get_arg(2, t, r); if ( op_pri > prec ) TRY(PutOpenBrace(out)); TRY(writeTerm(l, op_type == OP_XFX || op_type == OP_XFY ? op_pri-1 : op_pri, options)); if ( functor == ATOM_comma ) { TRY(PutComma(options)); } else { switch(writeAtom(functor, options)) { case FALSE: fail; case TRUE_WITH_SPACE: TRY(Putc(' ', out)); } } TRY(writeTerm(r, op_type == OP_XFX || op_type == OP_YFX ? op_pri-1 : op_pri, options)); if ( op_pri > prec ) TRY(PutCloseBrace(out)); succeed; } } } /* functor( ...) */ { term_t a = PL_new_term_ref(); TRY(writeAtom(functor, options) && Putc('(', out)); for(n=0; n 0) TRY(PutComma(options)); _PL_get_arg(n+1, t, a); TRY(writeArgTerm(a, 999, options, TRUE)); } return Putc(')', out); } } } int writeAttributeMask(atom_t a) { if ( a == ATOM_ignore ) { return PL_WRT_ATTVAR_IGNORE; } else if ( a == ATOM_dots ) { return PL_WRT_ATTVAR_DOTS; } else if ( a == ATOM_write ) { return PL_WRT_ATTVAR_WRITE; } else if ( a == ATOM_portray ) { return PL_WRT_ATTVAR_PORTRAY; } else return 0; } static int writeBlobMask(atom_t a) { if ( a == ATOM_default ) { return 0; } else if ( a == ATOM_portray ) { return PL_WRT_BLOB_PORTRAY; } else return -1; } static const opt_spec write_term_options[] = { { ATOM_quoted, OPT_BOOL }, { ATOM_ignore_ops, OPT_BOOL }, { ATOM_numbervars, OPT_BOOL }, { ATOM_portray, OPT_BOOL }, { ATOM_character_escapes, OPT_BOOL }, { ATOM_max_depth, OPT_INT }, { ATOM_module, OPT_ATOM }, { ATOM_backquoted_string, OPT_BOOL }, { ATOM_attributes, OPT_ATOM }, { ATOM_priority, OPT_INT }, { ATOM_partial, OPT_BOOL }, { ATOM_spacing, OPT_ATOM }, { ATOM_blobs, OPT_ATOM }, { NULL_ATOM, 0 } }; word pl_write_term3(term_t stream, term_t term, term_t opts) { GET_LD bool quoted = FALSE; bool ignore_ops = FALSE; bool numbervars = -1; /* not set */ bool portray = FALSE; bool bqstring = truePrologFlag(PLFLAG_BACKQUOTED_STRING); bool charescape = -1; /* not set */ atom_t mname = ATOM_user; atom_t attr = ATOM_nil; atom_t blobs = ATOM_nil; int priority = 1200; bool partial = FALSE; IOSTREAM *s; write_options options; int rc; memset(&options, 0, sizeof(options)); options.spacing = ATOM_standard; if ( !scan_options(opts, 0, ATOM_write_option, write_term_options, "ed, &ignore_ops, &numbervars, &portray, &charescape, &options.max_depth, &mname, &bqstring, &attr, &priority, &partial, &options.spacing, &blobs) ) fail; if ( attr == ATOM_nil ) { options.flags |= LD->prolog_flag.write_attributes; } else { int mask = writeAttributeMask(attr); if ( !mask ) return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_option, opts); options.flags |= mask; } if ( blobs != ATOM_nil ) { int mask = writeBlobMask(blobs); if ( mask < 0 ) return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_option, opts); options.flags |= mask; } if ( priority < 0 || priority > OP_MAXPRIORITY ) { term_t t = PL_new_term_ref(); PL_put_integer(t, priority); return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_operator_priority, t); } switch( options.spacing ) { case ATOM_standard: case ATOM_next_argument: break; default: { term_t t = PL_new_term_ref(); PL_put_atom(t, options.spacing); return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_spacing, t); } } if ( !getOutputStream(stream, &s) ) fail; options.module = lookupModule(mname); if ( charescape == TRUE || // (charescape == -1 && true(options.module, CHARESCAPE)) ) charEscapeWriteOption(options)) options.flags |= PL_WRT_CHARESCAPES; if ( numbervars == -1 ) numbervars = (portray ? TRUE : FALSE); if ( quoted ) options.flags |= PL_WRT_QUOTED; if ( ignore_ops ) options.flags |= PL_WRT_IGNOREOPS; if ( numbervars ) options.flags |= PL_WRT_NUMBERVARS; if ( portray ) options.flags |= PL_WRT_PORTRAY; if ( bqstring ) options.flags |= PL_WRT_BACKQUOTED_STRING; options.out = s; if ( !partial ) PutOpenToken(EOF, s); /* reset this */ if ( (options.flags & PL_WRT_QUOTED) && !(s->flags&SIO_REPPL) ) { s->flags |= SIO_REPPL; rc = writeTerm(term, priority, &options); s->flags &= ~SIO_REPPL; } else { rc = writeTerm(term, priority, &options); } return streamStatus(s) && rc; } word pl_write_term(term_t term, term_t options) { return pl_write_term3(0, term, options); } int PL_write_term(IOSTREAM *s, term_t term, int precedence, int flags) { write_options options; memset(&options, 0, sizeof(options)); options.flags = flags; options.out = s; options.module = MODULE_user; PutOpenToken(EOF, s); /* reset this */ return writeTerm(term, precedence, &options); } static word do_write2(term_t stream, term_t term, int flags) { GET_LD IOSTREAM *s; if ( getOutputStream(stream, &s) ) { write_options options; int rc; memset(&options, 0, sizeof(options)); options.flags = flags; options.out = s; options.module = MODULE_user; // if ( options.module && true(options.module, CHARESCAPE) ) if (charEscapeWriteOption(options)) options.flags |= PL_WRT_CHARESCAPES; if ( truePrologFlag(PLFLAG_BACKQUOTED_STRING) ) options.flags |= PL_WRT_BACKQUOTED_STRING; PutOpenToken(EOF, s); /* reset this */ rc = writeTerm(term, 1200, &options); return streamStatus(s) && rc; } return FALSE; } word pl_write2(term_t stream, term_t term) { return do_write2(stream, term, PL_WRT_NUMBERVARS); } word pl_writeq2(term_t stream, term_t term) { return do_write2(stream, term, PL_WRT_QUOTED|PL_WRT_NUMBERVARS); } word pl_print2(term_t stream, term_t term) { return do_write2(stream, term, PL_WRT_PORTRAY|PL_WRT_NUMBERVARS); } word pl_write_canonical2(term_t stream, term_t term) { GET_LD fid_t fid; nv_options options; word rc; if ( !(fid = PL_open_foreign_frame()) ) return FALSE; options.functor = FUNCTOR_isovar1; options.on_attvar = AV_SKIP; options.singletons = TRUE; numberVars(term, &options, 0 PASS_LD); rc = do_write2(stream, term, PL_WRT_QUOTED|PL_WRT_IGNOREOPS|PL_WRT_NUMBERVARS); PL_discard_foreign_frame(fid); return rc; } word pl_write(term_t term) { return pl_write2(0, term); } word pl_writeq(term_t term) { return pl_writeq2(0, term); } word pl_print(term_t term) { return pl_print2(0, term); } word pl_write_canonical(term_t term) { return pl_write_canonical2(0, term); } word /* for debugging purposes! */ pl_writeln(term_t term) { if ( PL_write_term(Serror, term, 1200, PL_WRT_QUOTED|PL_WRT_NUMBERVARS) && Sdprintf("\n") >= 0 ) succeed; fail; } static PRED_IMPL("$put_token", 2, put_token, 0) { char *s; size_t len; IOSTREAM *out; if ( !PL_get_stream_handle(A1, &out) ) fail; if ( !PL_get_nchars(A2, &len, &s, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) ) fail; if ( PutTokenN(s, len, out) ) return PL_release_stream(out); PL_release_stream(out); fail; } /******************************* * PUBLISH PREDICATES * *******************************/ BeginPredDefs(write) PRED_DEF("$put_token", 2, put_token, 0) EndPredDefs