1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 1985-2020, University of Amsterdam
7 VU University Amsterdam
8 CWI, Amsterdam
9 All rights reserved.
10
11 Redistribution and use in source and binary forms, with or without
12 modification, are permitted provided that the following conditions
13 are met:
14
15 1. Redistributions of source code must retain the above copyright
16 notice, this list of conditions and the following disclaimer.
17
18 2. Redistributions in binary form must reproduce the above copyright
19 notice, this list of conditions and the following disclaimer in
20 the documentation and/or other materials provided with the
21 distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 #include "pl-incl.h"
38 #include "pl-arith.h"
39 #include "pl-dict.h"
40 #include <math.h>
41 #include "os/pl-dtoa.h"
42 #include "os/pl-ctype.h"
43 #include <stdio.h> /* sprintf() */
44 #ifdef HAVE_LOCALE_H
45 #include <locale.h>
46 #endif
47 #ifdef HAVE_FLOAT_H
48 #include <float.h>
49 #endif
50 #ifdef HAVE_IEEEFP_H
51 #include <ieeefp.h>
52 #endif
53
54 #ifdef fpclassify
55 #define HAVE_FPCLASSIFY 1
56 #endif
57
58 typedef struct
59 { int flags; /* PL_WRT_* flags */
60 int max_depth; /* depth limit */
61 int depth; /* current depth */
62 atom_t spacing; /* Where to insert spaces */
63 Module module; /* Module for operators */
64 IOSTREAM *out; /* stream to write to */
65 term_t portray_goal; /* call/2 activated portray hook */
66 term_t write_options; /* original write options */
67 term_t prec_opt; /* term in write options with prec */
68 } write_options;
69
70 static bool writeTerm2(term_t term, int prec,
71 write_options *options, bool arg) WUNUSED;
72 static bool writeTerm(term_t t, int prec,
73 write_options *options) WUNUSED;
74 static bool writeArgTerm(term_t t, int prec,
75 write_options *options, bool arg) WUNUSED;
76 static int PutToken(const char *s, IOSTREAM *stream);
77 static int writeAtom(atom_t a, write_options *options);
78 static int callPortray(term_t arg, int prec, write_options *options);
79 static int enterPortray(ARG1_LD);
80 static void leavePortray(ARG1_LD);
81
82 char *
var_name_ptr__LD(Word p,char * name ARG_LD)83 var_name_ptr__LD(Word p, char *name ARG_LD)
84 { size_t iref;
85
86 deRef(p);
87
88 if (p > (Word) lBase)
89 iref = ((Word)p - (Word)lBase)*2+1;
90 else
91 iref = ((Word)p - (Word)gBase)*2;
92
93 Ssprintf(name, "_%lld", (int64_t)iref);
94
95 return name;
96 }
97
98
99 char *
varName(term_t t,char * name)100 varName(term_t t, char *name)
101 { GET_LD
102 Word p = valTermRef(t);
103
104 return var_name_ptr(p, name);
105 }
106
107
108 static int
atomIsVarName(atom_t a)109 atomIsVarName(atom_t a)
110 { Atom atom = atomValue(a);
111
112 if ( false(atom->type, PL_BLOB_TEXT) || atom->length == 0 )
113 fail;
114 if ( isUCSAtom(atom) )
115 { pl_wchar_t *w = (pl_wchar_t*)atom->name;
116 size_t len = atom->length / sizeof(pl_wchar_t);
117
118 return atom_varnameW(w, len);
119 } else
120 { const char *s = atom->name;
121 size_t len = atom->length;
122
123 if ( isUpper(*s) || *s == '_' )
124 { for(s++; --len > 0; s++)
125 { if ( !isAlpha(*s) )
126 return FALSE;
127 }
128
129 return TRUE;
130 }
131
132 return FALSE;
133 }
134 }
135
136
137 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
138 Return: TRUE: processes
139 FALSE: not processed
140 -1: error
141 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
142
143 static int
writeNumberVar(term_t t,write_options * options ARG_LD)144 writeNumberVar(term_t t, write_options *options ARG_LD)
145 { Word p = valTermRef(t);
146 Functor f;
147
148 deRef(p);
149 if ( !isTerm(*p) )
150 return FALSE;
151 f = valueTerm(*p);
152
153 if ( f->definition != FUNCTOR_isovar1 )
154 return FALSE;
155
156 if ( LD->var_names.numbervars_frame )
157 { FliFrame fr = (FliFrame)valTermRef(LD->var_names.numbervars_frame);
158
159 assert(fr->magic == FLI_MAGIC);
160 if ( fr->mark.globaltop > (Word)f )
161 return FALSE; /* older $VAR term */
162 }
163
164 p = &f->arguments[0];
165 deRef(p);
166 if ( isInteger(*p) )
167 { int64_t n = valInteger(*p);
168 char buf[32]; /* Max is H354745078340568300 */
169
170 if ( n < 0 )
171 { sprintf(buf, "S_%" PRId64, -n);
172 } else
173 { int i = (int)(n % 26);
174 int64_t j = n / 26;
175
176 if ( j == 0 )
177 { buf[0] = i+'A';
178 buf[1] = EOS;
179 } else
180 { sprintf(buf, "%c%" PRId64, i+'A', j);
181 }
182 }
183
184 return PutToken(buf, options->out) ? TRUE : -1;
185 }
186
187 if ( isAtom(*p) && atomIsVarName(*p) )
188 { write_options o2 = *options;
189 clear(&o2, PL_WRT_QUOTED);
190
191 return writeAtom(*p, &o2) ? TRUE : -1;
192 }
193
194 return FALSE;
195 }
196
197
198 #define AT_LOWER 0
199 #define AT_QUOTE 1
200 #define AT_FULLSTOP 2
201 #define AT_SYMBOL 3
202 #define AT_SOLO 4
203 #define AT_SPECIAL 5
204
205 /* Note: this only deals with ISO Latin-1 atoms; wide atoms are handled
206 by writeUCSAtom()
207 */
208
209 static int
truePrologFlagNoLD(unsigned int flag)210 truePrologFlagNoLD(unsigned int flag)
211 { GET_LD
212
213 return truePrologFlag(flag);
214 }
215
216
217 static inline int
wr_is_symbol(int c,write_options * options)218 wr_is_symbol(int c, write_options *options)
219 { return ( isSymbol(c) ||
220 (c == '`' &&
221 options &&
222 (options->flags & PL_WRT_BACKQUOTE_IS_SYMBOL)) );
223 }
224
225 static int
atomType(atom_t a,write_options * options)226 atomType(atom_t a, write_options *options)
227 { Atom atom = atomValue(a);
228 char *s = atom->name;
229 size_t len = atom->length;
230 IOSTREAM *fd = options ? options->out : NULL;
231 Module m = options ? options->module : MODULE_user;
232
233 if ( len == 0 )
234 return AT_QUOTE;
235
236 if ( isLower(*s) || (true(m, M_VARPREFIX) && isAlpha(*s)) )
237 { do
238 { for( ++s;
239 --len > 0 && isAlpha(*s) && (!fd || Scanrepresent(*s, fd)==0);
240 s++)
241 ;
242 } while ( len >= 2 &&
243 *s == '.' && isAlpha(s[1]) &&
244 truePrologFlagNoLD(PLFLAG_DOT_IN_ATOM) &&
245 (!options || false(options, PL_WRT_NODOTINATOM))
246 );
247
248 return len == 0 ? AT_LOWER : AT_QUOTE;
249 }
250
251 if ( wr_is_symbol(*s, options) )
252 { size_t left = len;
253
254 if ( len == 1 && s[0] == '.' )
255 return AT_FULLSTOP;
256 if ( len >= 2 && s[0] == '/' && s[1] == '*' )
257 return AT_QUOTE;
258
259 for( ;
260 left > 0 && wr_is_symbol(*s, options) &&
261 (!fd || Scanrepresent(*s, fd)==0);
262 s++, left--)
263 ;
264 if ( left > 0 )
265 return AT_QUOTE;
266
267 return AT_SYMBOL;
268 }
269
270 /* % should be quoted! */
271 if ( len == 1 && *s != '%' )
272 { if ( isSolo(*s) )
273 return AT_SOLO;
274 }
275
276 if ( a == ATOM_nil || a == ATOM_curl )
277 return AT_SPECIAL;
278
279 return AT_QUOTE;
280 }
281
282
283 static int
unquoted_atomW(atom_t atom,IOSTREAM * fd,int flags)284 unquoted_atomW(atom_t atom, IOSTREAM *fd, int flags)
285 { Atom ap = atomValue(atom);
286 pl_wchar_t *s = (pl_wchar_t*)ap->name;
287 size_t len = ap->length/sizeof(pl_wchar_t);
288
289 if ( len == 0 )
290 return FALSE;
291
292 if ( !f_is_prolog_atom_start(*s) )
293 { for( ; len > 0; s++, len--)
294 { if ( !f_is_prolog_symbol(*s) ||
295 (fd && Scanrepresent(*s, fd)<0) )
296 return FALSE;
297 }
298 return TRUE;
299 }
300
301 do
302 { for( ++s;
303 ( --len > 0 &&
304 f_is_prolog_identifier_continue(*s) &&
305 (!fd || Scanrepresent(*s, fd)==0)
306 );
307 s++)
308 ;
309 } while ( len >= 2 &&
310 *s == '.' && f_is_prolog_identifier_continue(s[1]) &&
311 truePrologFlagNoLD(PLFLAG_DOT_IN_ATOM) &&
312 !(flags&PL_WRT_NODOTINATOM)
313 );
314
315 return len == 0;
316 }
317
318
319 int
unquoted_atom(atom_t a)320 unquoted_atom(atom_t a)
321 { Atom ap = atomValue(a);
322
323 if ( true(ap->type, PL_BLOB_TEXT) )
324 { if ( !ap->type->write ) /* ordinary atoms */
325 { return atomType(a, NULL) != AT_QUOTE;
326 } else if ( isUCSAtom(ap) ) /* wide atoms */
327 { return unquoted_atomW(a, NULL, 0);
328 }
329 }
330
331 return FALSE;
332 }
333
334
335 /*******************************
336 * PRIMITIVE WRITES *
337 *******************************/
338
339 #define TRUE_WITH_SPACE 2 /* OK, and emitted leading space before token */
340
341 static bool
Putc(int c,IOSTREAM * s)342 Putc(int c, IOSTREAM *s)
343 { return Sputcode(c, s) != EOF;
344 }
345
346
347 static bool
PutString(const char * str,IOSTREAM * s)348 PutString(const char *str, IOSTREAM *s)
349 { const unsigned char *q = (const unsigned char *)str;
350
351 for( ; *q != EOS; q++ )
352 { if ( Sputcode(*q, s) == EOF )
353 return FALSE;
354 }
355
356 return TRUE;
357 }
358
359
360 static bool
PutComma(write_options * options)361 PutComma(write_options *options)
362 { if ( options->spacing == ATOM_next_argument )
363 return PutString(", ", options->out);
364 else
365 return PutString(",", options->out);
366 }
367
368
369 static bool
PutBar(write_options * options)370 PutBar(write_options *options)
371 { if ( options->spacing == ATOM_next_argument )
372 return PutString("| ", options->out);
373 else
374 return PutString("|", options->out);
375 }
376
377
378 static bool
PutStringN(const char * str,size_t length,IOSTREAM * s)379 PutStringN(const char *str, size_t length, IOSTREAM *s)
380 { size_t i;
381 const unsigned char *q = (const unsigned char *)str;
382
383 for(i=0; i<length; i++, q++)
384 { if ( Sputcode(*q, s) == EOF )
385 return FALSE;
386 }
387
388 return TRUE;
389 }
390
391
392 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
393 PutOpenToken() inserts a space in the output stream if the last-written
394 and given character require a space to ensure a token-break.
395
396 The C_* flags denote special cases handled using a flag. The first flag
397 is 0x200000, which is above the Unicode range.
398 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
399
400 #define C_PREFIX_SIGN 0x00200000 /* +/- as prefix op */
401 #define C_PREFIX_OP 0x00400000 /* any prefix op */
402 #define C_INFIX_OP 0x00800000 /* any infix op */
403 #define C_MASK 0xffe00000
404
405 #define isquote(c) ((c) == '\'' || (c) == '"')
406
407 static bool
needSpace(int c,IOSTREAM * s)408 needSpace(int c, IOSTREAM *s)
409 { if ( c == EOF )
410 { s->lastc = EOF;
411 return FALSE;
412 }
413 if ( s->lastc == EOF )
414 return FALSE;
415
416 if ( (s->lastc&C_PREFIX_SIGN) && (isDigit(c) || f_is_prolog_symbol(c)) )
417 return TRUE;
418 if ( (s->lastc&C_PREFIX_OP) && ( c == '(' || c == '{' ) )
419 return TRUE; /* avoid op(...) */
420 if ( (s->lastc&C_INFIX_OP) && c == '(' )
421 return FALSE;
422
423 s->lastc &= ~C_MASK;
424
425 if ( ((f_is_prolog_identifier_continue(s->lastc) &&
426 f_is_prolog_identifier_continue(c)) ||
427 (f_is_prolog_symbol(s->lastc) && f_is_prolog_symbol(c)) ||
428 (c == '(' && !isPunctW(s->lastc)) ||
429 (c == '\'' && (isDigit(s->lastc))) ||
430 (isquote(c) && s->lastc == c)
431 ) )
432 return TRUE;
433
434 return FALSE;
435 }
436
437
438 static int
PutOpenToken(int c,IOSTREAM * s)439 PutOpenToken(int c, IOSTREAM *s)
440 { if ( needSpace(c, s) )
441 { TRY(Putc(' ', s));
442 return TRUE_WITH_SPACE;
443 }
444
445 return TRUE;
446 }
447
448
449 static int
PutToken(const char * s,IOSTREAM * stream)450 PutToken(const char *s, IOSTREAM *stream)
451 { if ( s[0] )
452 { int rc;
453
454 TRY(rc=PutOpenToken(s[0]&0xff, stream));
455 TRY(PutString(s, stream));
456
457 return rc;
458 }
459
460 return TRUE;
461 }
462
463
464 static int
PutTokenN(const char * s,size_t len,IOSTREAM * stream)465 PutTokenN(const char *s, size_t len, IOSTREAM *stream)
466 { if ( len > 0 )
467 { int rc;
468
469 TRY(rc=PutOpenToken(s[0]&0xff, stream));
470 TRY(PutStringN(s, len, stream));
471
472 return rc;
473 }
474
475 return TRUE;
476 }
477
478
479 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
480 PutOpenBrace()/PutCloseBrace() are used to put additional braces around
481 a term to avoid an operator precedence problem. If the last emitted
482 character is alphanumerical, there should be a space before the
483 openbrace to avoid interpretation as a term. E.g. not (a,b) instead of
484 not(a,b). Reported by Stefan.Mueller@dfki.de.
485 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
486
487 static int
PutOpenBrace(IOSTREAM * s)488 PutOpenBrace(IOSTREAM *s)
489 { int rc;
490
491 TRY(rc=PutOpenToken('(', s));
492 TRY(Putc('(', s));
493
494 return rc;
495 }
496
497
498 static bool
PutCloseBrace(IOSTREAM * s)499 PutCloseBrace(IOSTREAM *s)
500 { return Putc(')', s);
501 }
502
503
504 static bool
putQuoted(int c,int quote,int flags,IOSTREAM * stream)505 putQuoted(int c, int quote, int flags, IOSTREAM *stream)
506 { if ( (flags & PL_WRT_CHARESCAPES) )
507 { if ( c == ' ' ||
508 (!(c < 0xff && !isGraph(c)) && c != quote && c != '\\') )
509 { TRY(Putc(c, stream));
510 } else
511 { char esc[8];
512
513 esc[1] = EOS;
514
515 if ( c == quote )
516 { esc[0] = c;
517 } else
518 { switch(c)
519 { case 7:
520 esc[0] = 'a';
521 break;
522 case '\b':
523 esc[0] = 'b';
524 break;
525 case '\t':
526 esc[0] = 't';
527 break;
528 case '\n':
529 esc[0] = 'n';
530 break;
531 case 11:
532 esc[0] = 'v';
533 break;
534 case '\r':
535 esc[0] = 'r';
536 break;
537 case '\f':
538 esc[0] = 'f';
539 break;
540 case '\\':
541 esc[0] = '\\';
542 break;
543 default:
544 if ( c <= 0xff )
545 Ssprintf(esc, "%03o\\", c);
546 else
547 assert(0); /* to be done */
548 }
549 }
550 if ( !Putc('\\', stream) ||
551 !PutString(esc, stream) )
552 fail;
553 }
554 } else
555 { if ( !Putc(c, stream) )
556 fail;
557 if ( c == quote || c == '\\' ) /* write '' or \\ */
558 { if ( !Putc(c, stream) )
559 fail;
560 }
561 }
562
563 return TRUE;
564 }
565
566
567
568 static bool
writeQuoted(IOSTREAM * stream,const char * text,size_t len,int quote,write_options * options)569 writeQuoted(IOSTREAM *stream, const char *text, size_t len, int quote,
570 write_options *options)
571 { const unsigned char *s = (const unsigned char *)text;
572
573 TRY(Putc(quote, stream));
574
575 while(len-- > 0)
576 { TRY(putQuoted(*s++, quote, options->flags, stream));
577 }
578
579 return Putc(quote, stream);
580 }
581
582
583 #if O_ATTVAR
584 static bool
writeAttVar(term_t av,write_options * options)585 writeAttVar(term_t av, write_options *options)
586 { GET_LD
587 char buf[32];
588
589 TRY(PutToken(varName(av, buf), options->out));
590
591 if ( (options->flags & PL_WRT_ATTVAR_DOTS) )
592 { return PutString("{...}", options->out);
593 } else if ( (options->flags & PL_WRT_ATTVAR_WRITE) )
594 { fid_t fid;
595 term_t a;
596
597 if ( !(fid = PL_open_foreign_frame()) )
598 return FALSE;
599
600 Sputcode('{', options->out);
601 a = PL_new_term_ref();
602 PL_get_attr__LD(av, a PASS_LD);
603 if ( !writeTerm(a, 1200, options) )
604 return FALSE;
605 Sputcode('}', options->out);
606 PL_close_foreign_frame(fid);
607
608 return TRUE;
609 } else if ( (options->flags & PL_WRT_ATTVAR_PORTRAY) &&
610 GD->cleaning <= CLN_PROLOG )
611 { static predicate_t pred;
612 IOSTREAM *old;
613 wakeup_state wstate;
614 int rc;
615
616 if ( !pred )
617 pred = _PL_predicate("portray_attvar", 1, "$attvar",
618 &GD->procedures.portray_attvar1);
619
620 if ( !enterPortray(PASS_LD1) )
621 return FALSE;
622 if ( !saveWakeup(&wstate, TRUE PASS_LD) )
623 return FALSE;
624 old = Scurout;
625 Scurout = options->out;
626 rc = PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION, pred, av);
627 if ( rc != TRUE && !PL_exception(0) )
628 rc = TRUE;
629 Scurout = old;
630 restoreWakeup(&wstate PASS_LD);
631 leavePortray(PASS_LD1);
632
633 return rc;
634 }
635
636 succeed;
637 }
638 #endif
639
640
641 static bool
writeBlob(atom_t a,write_options * options)642 writeBlob(atom_t a, write_options *options)
643 { Atom atom = atomValue(a);
644 unsigned char const *s, *e;
645
646 TRY(PutString("<#", options->out));
647 s = (unsigned char const *)atom->name;
648 for (e = s + atom->length; s != e; s++)
649 { static char *digits = "0123456789abcdef";
650
651 TRY(Putc(digits[(*s >> 4) & 0xf], options->out));
652 TRY(Putc(digits[(*s ) & 0xf], options->out));
653 }
654
655 return PutString(">", options->out);
656 }
657
658
659 static int /* FALSE, TRUE or TRUE_WITH_SPACE */
writeAtom(atom_t a,write_options * options)660 writeAtom(atom_t a, write_options *options)
661 { Atom atom = atomValue(a);
662
663 if ( (options->flags & PL_WRT_BLOB_PORTRAY) &&
664 false(atom->type, PL_BLOB_TEXT) &&
665 GD->cleaning <= CLN_PROLOG &&
666 a != ATOM_nil )
667 { GET_LD
668 int rc;
669 fid_t fid;
670 term_t av;
671
672 if ( !(fid = PL_open_foreign_frame()) )
673 return FALSE;
674 av = PL_new_term_ref();
675 PL_put_atom(av, a);
676 rc = callPortray(av, 1200, options);
677 PL_close_foreign_frame(fid);
678 switch(rc)
679 { case TRUE:
680 return TRUE;
681 case FALSE:
682 break;
683 default:
684 return FALSE; /* error */
685 }
686 }
687
688 if ( atom->type->write )
689 return (*atom->type->write)(options->out, a, options->flags);
690 if ( false(atom->type, PL_BLOB_TEXT) )
691 return writeBlob(a, options);
692
693 if ( true(options, PL_WRT_QUOTED) )
694 { switch( atomType(a, options) )
695 { case AT_LOWER:
696 case AT_SYMBOL:
697 case AT_SOLO:
698 case AT_SPECIAL:
699 return PutToken(atom->name, options->out);
700 case AT_QUOTE:
701 case AT_FULLSTOP:
702 default:
703 { int rc;
704
705 TRY(rc=PutOpenToken('\'', options->out));
706 TRY(writeQuoted(options->out,
707 atom->name,
708 atom->length,
709 '\'', options));
710 return rc;
711 }
712 }
713 } else
714 return PutTokenN(atom->name, atom->length, options->out);
715 }
716
717
718 int
writeAtomToStream(IOSTREAM * s,atom_t atom)719 writeAtomToStream(IOSTREAM *s, atom_t atom)
720 { write_options options;
721
722 memset(&options, 0, sizeof(options));
723 options.out = s;
724 options.module = MODULE_user;
725
726 return writeAtom(atom, &options);
727 }
728
729
730 int
writeUCSAtom(IOSTREAM * fd,atom_t atom,int flags)731 writeUCSAtom(IOSTREAM *fd, atom_t atom, int flags)
732 { Atom a = atomValue(atom);
733 pl_wchar_t *s = (pl_wchar_t*)a->name;
734 size_t len = a->length/sizeof(pl_wchar_t);
735 pl_wchar_t *e = &s[len];
736
737 if ( (flags&PL_WRT_QUOTED) && !unquoted_atomW(atom, fd, flags) )
738 { pl_wchar_t quote = L'\'';
739
740 TRY(PutOpenToken(quote, fd) &&
741 Putc(quote, fd));
742
743 while(s < e)
744 { TRY(putQuoted(*s++, quote, flags, fd));
745 }
746
747 return Putc(quote, fd);
748 }
749
750 if ( s < e && !PutOpenToken(s[0], fd) )
751 return FALSE;
752 for( ; s<e; s++)
753 { if ( !Putc(*s, fd) )
754 return FALSE;
755 }
756
757 return TRUE;
758 }
759
760 #ifdef O_RESERVED_SYMBOLS
761 int
writeReservedSymbol(IOSTREAM * fd,atom_t atom,int flags)762 writeReservedSymbol(IOSTREAM *fd, atom_t atom, int flags)
763 { Atom a = atomValue(atom);
764 const char *s = a->name;
765 size_t len = a->length;
766 const char *e = &s[len];
767
768 if ( atom == ATOM_nil )
769 return PutToken("[]", fd);
770
771 if ( (flags&PL_WRT_QUOTED) )
772 { char quote = '\'';
773
774 if ( PutOpenToken('C', fd) &&
775 Putc('C', fd) &&
776 Putc(quote, fd) )
777 { while(s < e)
778 { if ( !putQuoted(*s++, quote, flags, fd) )
779 return FALSE;
780 }
781
782 return Putc(quote, fd);
783 }
784 }
785
786 if ( s < e && !PutOpenToken(s[0], fd) )
787 return FALSE;
788 for( ; s<e; s++)
789 { if ( !Putc(*s, fd) )
790 return FALSE;
791 }
792
793 return TRUE;
794 }
795 #endif
796
797
798 #if O_STRING
799
800 static inline int
get_chr_from_text(const PL_chars_t * t,int index)801 get_chr_from_text(const PL_chars_t *t, int index)
802 { switch(t->encoding)
803 { case ENC_ISO_LATIN_1:
804 return t->text.t[index]&0xff;
805 case ENC_WCHAR:
806 return t->text.w[index];
807 default:
808 assert(0);
809 return 0;
810 }
811 }
812
813
814 static int
writeString(term_t t,write_options * options)815 writeString(term_t t, write_options *options)
816 { GET_LD
817 PL_chars_t txt;
818 int rc = TRUE;
819
820 PL_STRINGS_MARK();
821 PL_get_text(t, &txt, CVT_STRING);
822
823 if ( true(options, PL_WRT_QUOTED) )
824 { int quote;
825 unsigned int i;
826
827 if ( true(options, PL_WRT_BACKQUOTED_STRING) )
828 quote = '`';
829 else
830 quote = '"';
831
832 if ( !(rc=Putc(quote, options->out)) )
833 goto out;
834
835 for(i=0; i<txt.length; i++)
836 { int chr = get_chr_from_text(&txt, i);
837
838 if ( !(rc=putQuoted(chr, quote, options->flags, options->out)) )
839 goto out;
840 }
841
842 rc = Putc(quote, options->out);
843 } else
844 { unsigned int i;
845
846 for(i=0; i<txt.length; i++)
847 { int chr = get_chr_from_text(&txt, i);
848
849 if ( !(rc=Putc(chr, options->out)) )
850 break;
851 }
852 }
853 PL_STRINGS_RELEASE();
854
855 out:
856 PL_free_text(&txt);
857
858 return rc;
859 }
860
861 #endif /*O_STRING*/
862
863
864 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
865 Formatting a float. This used to use sprintf(), but there are two
866 problems with this. First of all, this uses the current locale, which is
867 complicated to avoid. Second, it does not provide a mode that guarantees
868 reliable read-back. Using %g gets closest, but %.15g doesn't guarantee
869 read-back and %.17g does, but prints 0.1 as 0.100..001, etc.
870
871 This uses dtoa.c. See pl-dtoa.c for how this is packed into SWI-Prolog.
872
873 TBD: The number of cases are large. We should see whether it is possible
874 to clean this up a bit. The 5 cases as such are real: there is no way
875 around these.
876
877 NaN and Inf printing based on
878 http://eclipseclp.org/Specs/core_update_float.html, with comments from
879 Joachim Schimpf.
880 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
881
882 #ifdef HAVE_IEEE754_H
883 #include <ieee754.h>
884 #else
885 union ieee754_double
886 { double d;
887 struct
888 {
889 #ifdef WORDS_BIGENDIAN
890 unsigned int negative:1;
891 unsigned int exponent:11;
892 unsigned int mantissa0:20;
893 unsigned int mantissa1:32;
894 #else
895 #ifdef FLOAT_WORDS_BIGENDIAN
896 unsigned int mantissa0:20;
897 unsigned int exponent:11;
898 unsigned int negative:1;
899 unsigned int mantissa1:32;
900 #else
901 unsigned int mantissa1:32;
902 unsigned int mantissa0:20;
903 unsigned int exponent:11;
904 unsigned int negative:1;
905 #endif
906 #endif
907 } ieee;
908 };
909 #endif
910
911 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
912 Joachim Schimpf: The exponent is stored with a "bias" of 1023, so
913 3ff=1023 means 0. And 0 means that the mantissa is to be multiplied by
914 2^0 = 1, maybe that's where my confusion came from...
915
916 To add to the confusion, the mantissa is a "hidden bit" representation,
917 i.e. its actual value is 1.<the 52 bits actually stored>, so with a 0
918 exponent the value of the resulting number is always >= 1 and < 2.
919 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
920
921 double
NaN_value(double f)922 NaN_value(double f)
923 { union ieee754_double u;
924
925 u.d = f;
926 assert(u.ieee.exponent == 0x7ff); /* NaN exponent */
927 u.ieee.exponent = 0x3ff;
928
929 return u.d;
930 }
931
932
933 static char *
writeNaN(double f,char * buf)934 writeNaN(double f, char *buf)
935 { format_float(NaN_value(f), buf);
936 strcat(buf, "NaN");
937 return buf;
938 }
939
940
941 strnumstat
make_nan(double * f)942 make_nan(double *f)
943 { union ieee754_double u;
944
945 u.d = *f;
946 u.ieee.exponent = 0x7ff; /* NaN exponent */
947 if ( isnan(u.d) )
948 { *f = u.d;
949 return NUM_OK;
950 }
951
952 return NUM_CONSTRANGE; /* 1.0NaN is in fact 1.0Inf */
953 }
954
955
956 static char *
writeINF(double f,char * buf)957 writeINF(double f, char *buf)
958 { number n;
959
960 n.value.f = f;
961 n.type = V_FLOAT;
962
963 if ( ar_signbit(&n) < 0 )
964 return strcpy(buf, "-1.0Inf");
965 else
966 return strcpy(buf, "1.0Inf");
967 }
968
969
970 static char *
format_special_float(double f,char * buf)971 format_special_float(double f, char *buf)
972 {
973 #ifdef HAVE_FPCLASSIFY
974 switch(fpclassify(f))
975 { case FP_NAN:
976 return writeNaN(f, buf);
977 case FP_INFINITE:
978 return writeINF(f, buf);
979 }
980 #else
981 #ifdef HAVE_FPCLASS
982 switch(fpclass(f))
983 { case FP_SNAN:
984 case FP_QNAN:
985 return writeNaN(f, buf);
986 case FP_NINF:
987 case FP_PINF:
988 return writeINF(f, buf);
989 case FP_NDENORM: /* pos/neg denormalized non-zero */
990 case FP_PDENORM:
991 case FP_NNORM: /* pos/neg normalized non-zero */
992 case FP_PNORM:
993 case FP_NZERO: /* pos/neg zero */
994 case FP_PZERO:
995 break;
996 }
997 #else
998 #ifdef HAVE__FPCLASS
999 switch(_fpclass(f))
1000 { case _FPCLASS_SNAN:
1001 case _FPCLASS_QNAN:
1002 return writeNaN(f, buf);
1003 case _FPCLASS_NINF:
1004 case _FPCLASS_PINF:
1005 return writeINF(f, buf);
1006 }
1007 #else
1008 #ifdef HAVE_ISINF
1009 if ( isinf(f) )
1010 { return writeINF(f, buf);
1011 } else
1012 #endif
1013 #ifdef HAVE_ISNAN
1014 if ( isnan(f) )
1015 { return writeNaN(f, buf);
1016 }
1017 #endif
1018 #endif /*HAVE__FPCLASS*/
1019 #endif /*HAVE_FPCLASS*/
1020 #endif /*HAVE_FPCLASSIFY*/
1021
1022 return NULL;
1023 }
1024
1025
1026 char *
format_float(double f,char * buf)1027 format_float(double f, char *buf)
1028 { char *end, *o=buf, *s;
1029 int decpt, sign;
1030
1031 if ( (s=format_special_float(f, buf)) )
1032 return s;
1033
1034 s = dtoa(f, 0, 30, &decpt, &sign, &end);
1035 DEBUG(2, Sdprintf("decpt=%d, sign=%d, len = %d, '%s'\n",
1036 decpt, sign, end-s, s));
1037
1038 if ( sign )
1039 *o++ = '-';
1040
1041 if ( decpt <= 0 ) /* decimal dot before */
1042 { if ( decpt <= -4 )
1043 { *o++ = s[0];
1044 *o++ = '.';
1045 if ( end-s > 1 )
1046 { memcpy(o, s+1, end-s-1);
1047 o += end-s-1;
1048 } else
1049 *o++ = '0';
1050 sprintf(o, "e%d", decpt-1);
1051 } else
1052 { int i;
1053
1054 *o++ = '0';
1055 *o++ = '.';
1056 for(i=0; i < -decpt; i++)
1057 *o++ = '0';
1058 memcpy(o, s, end-s);
1059 o[end-s] = 0;
1060 }
1061 } else if ( end-s > decpt ) /* decimal dot inside */
1062 { memcpy(o, s, decpt);
1063 o += decpt;
1064 *o++ = '.';
1065 memcpy(o, s+decpt, end-s-decpt);
1066 o[end-s-decpt] = 0;
1067 } else /* decimal dot after */
1068 { int i;
1069 int trailing = decpt-(int)(end-s);
1070
1071 if ( decpt > 15 ) /* over precision: use eE */
1072 { *o++ = s[0];
1073 *o++ = '.';
1074 if ( end-s > 1 )
1075 { trailing += (int)(end-s)-1;
1076 memcpy(o, s+1, end-s-1);
1077 o += end-s-1;
1078 } else
1079 *o++ = '0';
1080 sprintf(o, "e+%d", trailing);
1081 } else /* within precision trail with .0 */
1082 { memcpy(o, s, end-s);
1083 o += end-s;
1084
1085 for(i=(int)(end-s); i<decpt; i++)
1086 *o++ = '0';
1087 *o++ = '.';
1088 *o++ = '0';
1089 *o = 0;
1090 }
1091 }
1092
1093 freedtoa(s);
1094
1095 return buf;
1096 }
1097
1098 #ifdef O_GMP
1099 static int
writeMPZ(mpz_t mpz,write_options * options ARG_LD)1100 writeMPZ(mpz_t mpz, write_options *options ARG_LD)
1101 { char tmp[1024];
1102 char *buf;
1103 size_t sz = mpz_sizeinbase(mpz, 10) + 2;
1104 int rc;
1105
1106 if ( sz <= sizeof(tmp) )
1107 buf = tmp;
1108 else
1109 buf = PL_malloc(sz);
1110
1111 /* mpz_get_str() can perform large intermediate allocations */
1112 EXCEPTION_GUARDED({ LD->gmp.persistent++;
1113 mpz_get_str(buf, 10, mpz);
1114 LD->gmp.persistent--;
1115 },
1116 { LD->gmp.persistent--;
1117 rc = PL_rethrow();
1118 })
1119 rc = PutToken(buf, options->out);
1120 if ( buf != tmp )
1121 PL_free(buf);
1122
1123 return rc;
1124 }
1125 #endif
1126
1127 static int
WriteNumber(Number n,write_options * options)1128 WriteNumber(Number n, write_options *options)
1129 {
1130 #ifdef O_GMP
1131 GET_LD
1132 #endif
1133
1134 switch(n->type)
1135 { case V_INTEGER:
1136 { char buf[32];
1137
1138 sprintf(buf, "%" PRId64, n->value.i);
1139 return PutToken(buf, options->out);
1140 }
1141 #ifdef O_GMP
1142 case V_MPZ:
1143 return writeMPZ(n->value.mpz, options PASS_LD);
1144 case V_MPQ:
1145 { mpz_t num, den; /* num/den */
1146 char sep = true(options, PL_WRT_RAT_NATURAL) ? '/' : 'r';
1147
1148 num[0] = *mpq_numref(n->value.mpq);
1149 den[0] = *mpq_denref(n->value.mpq);
1150 return ( writeMPZ(num, options PASS_LD) &&
1151 Sputcode(sep, options->out) != EOF &&
1152 (options->out->lastc = EOF) &&
1153 writeMPZ(den, options PASS_LD) );
1154 }
1155 #endif
1156 case V_FLOAT:
1157 { char buf[100];
1158
1159 format_float(n->value.f, buf);
1160 return PutToken(buf, options->out);
1161 }
1162 default:
1163 assert(0);
1164 return FALSE; /* make compiler happy */
1165 }
1166 }
1167
1168
1169
1170 static bool
writePrimitive(term_t t,write_options * options)1171 writePrimitive(term_t t, write_options *options)
1172 { GET_LD
1173 atom_t a;
1174 char buf[32];
1175 IOSTREAM *out = options->out;
1176
1177 #if O_ATTVAR
1178 if ( PL_is_attvar(t) )
1179 return writeAttVar(t, options);
1180 #endif
1181
1182 if ( PL_is_variable(t) )
1183 return PutToken(varName(t, buf), out);
1184
1185 if ( PL_get_atom(t, &a) )
1186 return writeAtom(a, options);
1187
1188 if ( PL_is_number(t) ) /* beware of automatic conversion */
1189 { number n;
1190
1191 PL_get_number(t, &n);
1192 return WriteNumber(&n, options);
1193 }
1194
1195 #if O_STRING
1196 if ( PL_is_string(t) )
1197 return writeString(t, options);
1198 #endif /* O_STRING */
1199
1200 assert(0);
1201 fail;
1202 }
1203
1204
1205 static int
pl_nl__LD(term_t stream ARG_LD)1206 pl_nl__LD(term_t stream ARG_LD)
1207 { IOSTREAM *s;
1208
1209 if ( getTextOutputStream(stream, &s) )
1210 { Sputcode('\n', s);
1211 return streamStatus(s);
1212 }
1213
1214 return FALSE;
1215 }
1216
1217
1218 static
1219 PRED_IMPL("nl", 1, nl, PL_FA_ISO)
1220 { PRED_LD
1221
1222 return pl_nl__LD(A1 PASS_LD);
1223 }
1224
1225 static
1226 PRED_IMPL("nl", 0, nl, PL_FA_ISO)
1227 { PRED_LD
1228
1229 return pl_nl__LD(0 PASS_LD);
1230 }
1231
1232 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1233 Call user:portray/1 if defined.
1234 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1235
1236 static int
put_write_options(term_t opts_in,write_options * options)1237 put_write_options(term_t opts_in, write_options *options)
1238 { GET_LD
1239 term_t newlist = PL_new_term_ref();
1240 term_t precopt = PL_new_term_ref();
1241 fid_t fid = PL_open_foreign_frame();
1242 term_t head = PL_new_term_ref();
1243 term_t tail = PL_copy_term_ref(opts_in);
1244 term_t newhead = PL_new_term_ref();
1245 term_t newtail = PL_copy_term_ref(newlist);
1246 int rc = TRUE;
1247
1248 while(rc && PL_get_list(tail, head, tail))
1249 { if ( !PL_is_functor(head, FUNCTOR_priority1) )
1250 rc = ( PL_unify_list(newtail, newhead, newtail) &&
1251 PL_unify(newhead, head) );
1252 }
1253
1254 if ( rc )
1255 { rc = ( PL_unify_list(newtail, head, newtail) &&
1256 PL_unify_functor(head, FUNCTOR_priority1) &&
1257 PL_get_arg(1, head, precopt) &&
1258 PL_unify_nil(newtail) );
1259 }
1260 if ( rc )
1261 { options->write_options = newlist;
1262 options->prec_opt = precopt;
1263 }
1264
1265 PL_close_foreign_frame(fid);
1266 return rc;
1267 }
1268
1269
1270 static int
enterPortray(ARG1_LD)1271 enterPortray(ARG1_LD)
1272 { if ( LD->IO.portray_nesting >= MAX_PORTRAY_NESTING )
1273 return PL_resource_error("portray_nesting");
1274 LD->IO.portray_nesting++;
1275 return TRUE;
1276 }
1277
1278
1279 static void
leavePortray(ARG1_LD)1280 leavePortray(ARG1_LD)
1281 { LD->IO.portray_nesting--;
1282 }
1283
1284
1285 /* returns: -1: error, FALSE: failed, TRUE: succeeded
1286 */
1287
1288 static int
callPortray(term_t arg,int prec,write_options * options)1289 callPortray(term_t arg, int prec, write_options *options)
1290 { predicate_t pred;
1291
1292 if ( GD->cleaning > CLN_PROLOG )
1293 fail; /* avoid dangerous callbacks */
1294
1295 if ( options->portray_goal )
1296 { pred = _PL_predicate("call", 3, "user", &GD->procedures.call3);
1297 } else
1298 { pred = _PL_predicate("portray", 1, "user", &GD->procedures.portray);
1299 if ( !pred->definition->impl.any.defined )
1300 return FALSE;
1301 }
1302
1303 { GET_LD
1304 wakeup_state wstate;
1305 IOSTREAM *old = Scurout;
1306 int rval;
1307 term_t av;
1308
1309 if ( !enterPortray(PASS_LD1) )
1310 return -1;
1311 if ( !saveWakeup(&wstate, TRUE PASS_LD) )
1312 return -1;
1313 Scurout = options->out;
1314 if ( options->portray_goal )
1315 { av = PL_new_term_refs(3);
1316
1317 PL_put_term(av+0, options->portray_goal);
1318 PL_put_term(av+1, arg);
1319 PL_unify_integer(options->prec_opt, prec);
1320 PL_put_term(av+2, options->write_options);
1321 } else
1322 { av = arg;
1323 }
1324 rval = PL_call_predicate(NULL, PL_Q_NODEBUG|PL_Q_PASS_EXCEPTION,
1325 pred, av);
1326 if ( !rval && PL_exception(0) )
1327 rval = -1;
1328 Scurout = old;
1329 restoreWakeup(&wstate PASS_LD);
1330 leavePortray(PASS_LD1);
1331
1332 return rval;
1333 }
1334
1335 fail;
1336 }
1337
1338
1339 static bool
writeArgTerm(term_t t,int prec,write_options * options,bool arg)1340 writeArgTerm(term_t t, int prec, write_options *options, bool arg)
1341 { GET_LD
1342 int rval;
1343 int levelSave = options->depth;
1344 fid_t fid;
1345
1346 if ( !(fid = PL_open_foreign_frame()) )
1347 return FALSE;
1348
1349 if ( PL_handle_signals() < 0 )
1350 { rval = FALSE;
1351 goto out;
1352 }
1353
1354 if ( ++options->depth > options->max_depth && options->max_depth )
1355 { PutOpenToken('.', options->out);
1356 rval = PutString("...", options->out);
1357 } else
1358 { rval = writeTerm2(t, prec, options, arg);
1359 }
1360
1361 out:
1362 options->depth = levelSave;
1363 PL_close_foreign_frame(fid);
1364
1365 return rval;
1366 }
1367
1368 static bool
writeTerm(term_t t,int prec,write_options * options)1369 writeTerm(term_t t, int prec, write_options *options)
1370 {
1371 return writeArgTerm(t, prec, options, FALSE);
1372 }
1373
1374 static bool
writeList(term_t list,write_options * options)1375 writeList(term_t list, write_options *options)
1376 { GET_LD
1377 term_t head = PL_new_term_ref();
1378 term_t l = PL_copy_term_ref(list);
1379
1380 if ( false(options, PL_WRT_DOTLISTS|PL_WRT_NO_LISTS) )
1381 { TRY(Putc('[', options->out));
1382 for(;;)
1383 { PL_get_list(l, head, l);
1384 TRY(writeArgTerm(head, 999, options, TRUE));
1385
1386 if ( PL_get_nil(l) )
1387 break;
1388 if ( ++options->depth >= options->max_depth && options->max_depth )
1389 return PutString("|...]", options->out);
1390 if ( !PL_is_functor(l, FUNCTOR_dot2) )
1391 { TRY(Putc('|', options->out));
1392 TRY(writeArgTerm(l, 999, options, TRUE));
1393 break;
1394 }
1395
1396 TRY(PutComma(options));
1397 }
1398
1399 return Putc(']', options->out);
1400 } else
1401 { int depth = 0;
1402
1403 for(;;)
1404 { PL_get_list(l, head, l);
1405 if ( true(options, PL_WRT_DOTLISTS) )
1406 { if ( !PutToken(".", options->out) )
1407 return FALSE;
1408 } else
1409 { if ( !writeAtom(ATOM_dot, options) )
1410 return FALSE;
1411 }
1412
1413 if ( !Putc('(', options->out) ||
1414 !writeArgTerm(head, 999, options, TRUE) ||
1415 !PutComma(options) )
1416 return FALSE;
1417
1418 depth++;
1419
1420 if ( PL_get_nil(l) )
1421 { if ( !PutToken("[]", options->out) )
1422 return FALSE;
1423 break;
1424 }
1425
1426 if ( ++options->depth >= options->max_depth && options->max_depth )
1427 { if ( !PutToken("...", options->out) )
1428 return FALSE;
1429 while(depth-->0)
1430 { if ( !Putc(')', options->out) )
1431 return FALSE;
1432 }
1433 return TRUE;
1434 }
1435
1436 if ( !PL_is_functor(l, FUNCTOR_dot2) )
1437 { if ( !writeArgTerm(l, 999, options, TRUE) )
1438 return FALSE;
1439 break;
1440 }
1441 }
1442
1443 while(depth-->0)
1444 { if ( !Putc(')', options->out) )
1445 return FALSE;
1446 }
1447 return TRUE;
1448 }
1449 }
1450
1451
1452 static int
isBlockOp(term_t t,term_t arg,atom_t functor ARG_LD)1453 isBlockOp(term_t t, term_t arg, atom_t functor ARG_LD)
1454 { if ( functor == ATOM_nil || functor == ATOM_curl )
1455 { _PL_get_arg(1, t, arg);
1456 if ( (functor == ATOM_nil && PL_is_pair(arg)) ||
1457 (functor == ATOM_curl && PL_is_functor(arg, FUNCTOR_curl1)) )
1458 return TRUE;
1459 }
1460
1461 return FALSE;
1462 }
1463
1464
1465 static int
writeDictPair(term_t name,term_t value,int last,void * closure)1466 writeDictPair(term_t name, term_t value, int last, void *closure)
1467 { write_options *options = closure;
1468
1469 if ( writeTerm(name, 1200, options) &&
1470 PutToken(":", options->out) &&
1471 writeTerm(value, 999, options) &&
1472 (last || PutComma(options)) )
1473 return 0; /* continue */
1474
1475 return -1;
1476 }
1477
1478
1479 static bool
writeTerm2(term_t t,int prec,write_options * options,bool arg)1480 writeTerm2(term_t t, int prec, write_options *options, bool arg)
1481 { GET_LD
1482 atom_t functor;
1483 size_t arity, n;
1484 int op_type, op_pri;
1485 atom_t a;
1486 IOSTREAM *out = options->out;
1487
1488 if ( !PL_is_variable(t) &&
1489 true(options, PL_WRT_PORTRAY) )
1490 { switch( callPortray(t, prec, options) )
1491 { case TRUE:
1492 return TRUE;
1493 case FALSE:
1494 break;
1495 default: /* error */
1496 return FALSE;
1497 }
1498 }
1499
1500 if ( PL_get_atom(t, &a) )
1501 { if ( !arg && prec < 1200 && priorityOperator(NULL, a) > 0 )
1502 { if ( PutOpenBrace(out) &&
1503 writeAtom(a, options) &&
1504 PutCloseBrace(out) )
1505 succeed;
1506 } else
1507 return writeAtom(a, options);
1508 }
1509
1510 if ( !PL_get_name_arity(t, &functor, &arity) )
1511 { return writePrimitive(t, options);
1512 } else
1513 { if ( true(options, PL_WRT_NUMBERVARS|PL_WRT_VARNAMES) )
1514 { switch( writeNumberVar(t, options PASS_LD) )
1515 { case -1:
1516 return FALSE;
1517 case TRUE:
1518 return TRUE;
1519 }
1520 }
1521
1522 /* handle {a,b,c} */
1523 if ( false(options, PL_WRT_BRACETERMS) &&
1524 functor == ATOM_curl && arity == 1 )
1525 { term_t arg;
1526
1527 if ( (arg=PL_new_term_ref()) &&
1528 PL_get_arg(1, t, arg) &&
1529 PutToken("{", out) &&
1530 writeTerm(arg, 1200, options) &&
1531 Putc('}', out) )
1532 return TRUE;
1533
1534 return FALSE;
1535 }
1536
1537 /* handle lists */
1538 if ( functor == ATOM_dot && arity == 2 )
1539 return writeList(t, options);
1540
1541 /* handle dicts */
1542 if ( false(options, PL_WRT_NODICT) &&
1543 functor == ATOM_dict && PL_is_dict(t) )
1544 { term_t class;
1545
1546 if ( (class=PL_new_term_ref()) &&
1547 PL_get_arg(1, t, class) )
1548 { if ( writeTerm(class, 1200, options) &&
1549 Putc('{', out) &&
1550 PL_for_dict(t, writeDictPair, options, DICT_SORTED) == 0 &&
1551 Putc('}', out) )
1552 return TRUE;
1553 }
1554
1555 return FALSE;
1556 }
1557 /* operators */
1558 if ( false(options, PL_WRT_IGNOREOPS) )
1559 { term_t arg;
1560
1561 if ( !(arg=PL_new_term_ref()) )
1562 return FALSE;
1563
1564 if ( arity == 1 ||
1565 (arity == 2 && isBlockOp(t, arg, functor PASS_LD)) )
1566 {
1567 /* op <term> */
1568 if ( currentOperator(options->module, functor, OP_PREFIX,
1569 &op_type, &op_pri) )
1570 { term_t arg = PL_new_term_ref();
1571 int embrace;
1572
1573 embrace = ( op_pri > prec );
1574
1575 if ( embrace )
1576 TRY(PutOpenBrace(out));
1577 if ( arity == 1 )
1578 { TRY(writeAtom(functor, options));
1579 } else
1580 { _PL_get_arg(1, t, arg);
1581 TRY(writeTerm(arg, 1200, options));
1582 }
1583 /* +/-(Number) : avoid parsing as number */
1584 options->out->lastc |= C_PREFIX_OP;
1585 if ( functor == ATOM_minus || functor == ATOM_plus )
1586 options->out->lastc |= C_PREFIX_SIGN;
1587
1588 _PL_get_arg(arity, t, arg);
1589 TRY(writeTerm(arg,
1590 op_type == OP_FX ? op_pri-1 : op_pri,
1591 options));
1592
1593 if ( embrace )
1594 TRY(PutCloseBrace(out));
1595
1596 succeed;
1597 }
1598
1599 /* <term> op */
1600 if ( currentOperator(options->module, functor, OP_POSTFIX,
1601 &op_type, &op_pri) )
1602 { term_t arg = PL_new_term_ref();
1603
1604 if ( op_pri > prec )
1605 TRY(PutOpenBrace(out));
1606 _PL_get_arg(arity, t, arg);
1607 TRY(writeTerm(arg,
1608 op_type == OP_XF ? op_pri-1 : op_pri,
1609 options));
1610 if ( arity == 1 )
1611 { TRY(writeAtom(functor, options));
1612 } else
1613 { if ( functor == ATOM_curl &&
1614 (PL_is_atom(arg) || PL_is_variable(arg)) )
1615 TRY(Putc(' ', out));
1616 _PL_get_arg(1, t, arg);
1617
1618 TRY(writeTerm(arg, 1200, options));
1619 }
1620 if (op_pri > prec)
1621 TRY(PutCloseBrace(out));
1622
1623 succeed;
1624 }
1625 } else if ( arity == 2 ||
1626 (arity == 3 && isBlockOp(t, arg, functor PASS_LD)) )
1627 { /* <term> op <term> */
1628 if ( currentOperator(options->module, functor, OP_INFIX,
1629 &op_type, &op_pri) )
1630 { static atom_t ATOM_fdot = 0;
1631
1632 if ( !ATOM_fdot ) /* ATOM_dot can be '[|]' */
1633 ATOM_fdot = PL_new_atom(".");
1634
1635 if ( op_pri > prec )
1636 TRY(PutOpenBrace(out));
1637 _PL_get_arg(arity-1, t, arg);
1638 TRY(writeTerm(arg,
1639 op_type == OP_XFX || op_type == OP_XFY
1640 ? op_pri-1 : op_pri,
1641 options));
1642 if ( arity == 2 )
1643 { if ( functor == ATOM_comma )
1644 { TRY(PutComma(options));
1645 } else if ( functor == ATOM_bar )
1646 { TRY(PutBar(options));
1647 } else if ( functor == ATOM_fdot )
1648 { TRY(PutToken(".", out));
1649 } else
1650 { switch(writeAtom(functor, options))
1651 { case FALSE:
1652 fail;
1653 case TRUE_WITH_SPACE:
1654 TRY(Putc(' ', out));
1655 }
1656 }
1657 options->out->lastc |= C_INFIX_OP;
1658 } else /* block operator */
1659 { _PL_get_arg(1, t, arg);
1660 TRY(writeTerm(arg, 1200, options));
1661 }
1662 _PL_get_arg(arity, t, arg);
1663 TRY(writeTerm(arg,
1664 op_type == OP_XFX || op_type == OP_YFX
1665 ? op_pri-1 : op_pri,
1666 options));
1667 if ( op_pri > prec )
1668 TRY(PutCloseBrace(out));
1669 succeed;
1670 }
1671 }
1672 }
1673
1674 /* functor(<args> ...) */
1675 { term_t a = PL_new_term_ref();
1676
1677 TRY(writeAtom(functor, options) &&
1678 Putc('(', out));
1679 for(n=0; n<arity; n++)
1680 { if (n > 0)
1681 TRY(PutComma(options));
1682 _PL_get_arg(n+1, t, a);
1683 TRY(writeArgTerm(a, 999, options, TRUE));
1684 }
1685 return Putc(')', out);
1686 }
1687 }
1688 }
1689
1690
1691 /*******************************
1692 * CYCLE HANDLING *
1693 *******************************/
1694
1695 static int
reunify_acyclic_substitutions(term_t substitutions,term_t cycles,write_options * options)1696 reunify_acyclic_substitutions(term_t substitutions, term_t cycles,
1697 write_options *options)
1698 { GET_LD
1699 term_t s_tail, c_tail, s_head, c_head, var, value;
1700 intptr_t count = 0;
1701
1702 if ( !(s_tail = PL_copy_term_ref(substitutions)) ||
1703 !(c_tail = PL_copy_term_ref(cycles)) ||
1704 !(s_head = PL_new_term_ref()) ||
1705 !(c_head = PL_new_term_ref()) ||
1706 !(var = PL_new_term_ref()) ||
1707 !(value = PL_new_term_ref()) )
1708 return FALSE;
1709
1710 while(PL_get_list(s_tail, s_head, s_tail))
1711 { _PL_get_arg(1, s_head, var);
1712 _PL_get_arg(2, s_head, value);
1713 if ( PL_var_occurs_in(var, value) )
1714 { if ( (options->flags&PL_WRT_NUMBERVARS) )
1715 { if ( !PL_unify_term(var,
1716 PL_FUNCTOR, FUNCTOR_isovar1,
1717 PL_INTPTR, --count) )
1718 return FALSE;
1719 }
1720
1721 if ( !PL_unify_list(c_tail, c_head, c_tail) ||
1722 !PL_unify(c_head, s_head) )
1723 return FALSE;
1724 } else
1725 { if ( !PL_unify(var, value) )
1726 return FALSE;
1727 }
1728 }
1729
1730 return PL_unify_nil(c_tail);
1731 }
1732
1733
1734 static int
writeTopTerm(term_t term,int prec,write_options * options)1735 writeTopTerm(term_t term, int prec, write_options *options)
1736 { GET_LD
1737 int rc;
1738
1739 Slock(options->out);
1740 if ( (!(options->flags&PL_WRT_NO_CYCLES) && options->max_depth) ||
1741 PL_is_acyclic(term) )
1742 { rc = writeTerm(term, prec, options);
1743 } else
1744 { fid_t fid;
1745 term_t template, substitutions, cycles, at_term;
1746
1747 if ( options->flags & PL_WRT_NO_CYCLES )
1748 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_cyclic_term, term);
1749
1750 if ( !(fid = PL_open_foreign_frame()) ||
1751 !(template = PL_new_term_ref()) ||
1752 !(substitutions = PL_new_term_ref()) ||
1753 !(cycles = PL_new_term_ref()) ||
1754 !(at_term = PL_new_term_ref()) ||
1755 !PL_factorize_term(term, template, substitutions) ||
1756 !reunify_acyclic_substitutions(substitutions, cycles, options) ||
1757 !PL_unify_term(at_term,
1758 PL_FUNCTOR, FUNCTOR_xpceref2,
1759 PL_TERM, template,
1760 PL_TERM, cycles) )
1761 return FALSE;
1762 rc = writeTerm(at_term, prec, options);
1763 PL_discard_foreign_frame(fid);
1764 }
1765 Sunlock(options->out);
1766
1767 return rc;
1768 }
1769
1770
1771 static int
bind_varnames(term_t names ARG_LD)1772 bind_varnames(term_t names ARG_LD)
1773 { term_t tail, head, var, namet;
1774 int check_cycle_after = 1000;
1775
1776 if ( !(tail = PL_copy_term_ref(names)) ||
1777 !(head = PL_new_term_ref()) ||
1778 !(var = PL_new_term_ref()) ||
1779 !(namet = PL_new_term_ref()) )
1780 return FALSE;
1781
1782 while(PL_get_list_ex(tail, head, tail))
1783 { if ( PL_is_functor(head, FUNCTOR_equals2) )
1784 { atom_t name;
1785
1786 _PL_get_arg(2, head, var);
1787 _PL_get_arg(1, head, namet);
1788
1789 if ( !PL_get_atom_ex(namet, &name) )
1790 return FALSE;
1791 if ( !atomIsVarName(name) )
1792 return PL_domain_error("variable_name", namet);
1793
1794 if ( PL_is_variable(var) )
1795 { if ( !PL_unify_term(var,
1796 PL_FUNCTOR, FUNCTOR_isovar1,
1797 PL_ATOM, name) )
1798 return FALSE;
1799 }
1800 } else
1801 return PL_type_error("variable_assignment", head);
1802
1803 if ( --check_cycle_after == 0 &&
1804 lengthList(tail, FALSE) == -1 )
1805 return PL_type_error("list", head);
1806 }
1807
1808 return PL_get_nil_ex(tail);
1809 }
1810
1811
1812 /*******************************
1813 * TOPLEVEL *
1814 *******************************/
1815
1816 int
writeAttributeMask(atom_t a)1817 writeAttributeMask(atom_t a)
1818 { if ( a == ATOM_ignore )
1819 { return PL_WRT_ATTVAR_IGNORE;
1820 } else if ( a == ATOM_dots )
1821 { return PL_WRT_ATTVAR_DOTS;
1822 } else if ( a == ATOM_write )
1823 { return PL_WRT_ATTVAR_WRITE;
1824 } else if ( a == ATOM_portray )
1825 { return PL_WRT_ATTVAR_PORTRAY;
1826 } else
1827 return 0;
1828 }
1829
1830
1831 static int
writeBlobMask(atom_t a)1832 writeBlobMask(atom_t a)
1833 { if ( a == ATOM_default )
1834 { return 0;
1835 } else if ( a == ATOM_portray )
1836 { return PL_WRT_BLOB_PORTRAY;
1837 } else
1838 return -1;
1839 }
1840
1841
1842 static const opt_spec write_term_options[] =
1843 { { ATOM_quoted, OPT_BOOL },
1844 { ATOM_ignore_ops, OPT_BOOL },
1845 { ATOM_dotlists, OPT_BOOL },
1846 { ATOM_brace_terms, OPT_BOOL },
1847 { ATOM_numbervars, OPT_BOOL },
1848 { ATOM_portray, OPT_BOOL },
1849 { ATOM_portrayed, OPT_BOOL },
1850 { ATOM_portray_goal, OPT_TERM },
1851 { ATOM_character_escapes, OPT_BOOL },
1852 { ATOM_max_depth, OPT_INT },
1853 { ATOM_module, OPT_ATOM },
1854 { ATOM_back_quotes, OPT_ATOM },
1855 { ATOM_attributes, OPT_ATOM },
1856 { ATOM_priority, OPT_INT },
1857 { ATOM_partial, OPT_BOOL },
1858 { ATOM_spacing, OPT_ATOM },
1859 { ATOM_blobs, OPT_ATOM },
1860 { ATOM_cycles, OPT_BOOL },
1861 { ATOM_variable_names, OPT_TERM },
1862 { ATOM_nl, OPT_BOOL },
1863 { ATOM_fullstop, OPT_BOOL },
1864 { ATOM_no_lists, OPT_BOOL },
1865 { NULL_ATOM, 0 }
1866 };
1867
1868 foreign_t
pl_write_term3(term_t stream,term_t term,term_t opts)1869 pl_write_term3(term_t stream, term_t term, term_t opts)
1870 { GET_LD
1871 bool quoted = FALSE;
1872 bool ignore_ops = FALSE;
1873 bool dotlists = FALSE;
1874 bool braceterms = FALSE;
1875 bool numbervars = -1; /* not set */
1876 bool portray = FALSE;
1877 term_t gportray = 0;
1878 atom_t bq = 0;
1879 bool charescape = -1; /* not set */
1880 atom_t mname = ATOM_user;
1881 atom_t attr = ATOM_nil;
1882 atom_t blobs = ATOM_nil;
1883 int priority = 1200;
1884 bool partial = FALSE;
1885 bool cycles = TRUE;
1886 bool nl = FALSE;
1887 bool fullstop = FALSE;
1888 bool no_lists = FALSE;
1889 term_t varnames = 0;
1890 int local_varnames;
1891 IOSTREAM *s = NULL;
1892 write_options options;
1893 int rc;
1894
1895 memset(&options, 0, sizeof(options));
1896 options.spacing = ATOM_standard;
1897
1898 if ( !scan_options(opts, 0, ATOM_write_option, write_term_options,
1899 "ed, &ignore_ops, &dotlists, &braceterms,
1900 &numbervars, &portray, &portray, &gportray,
1901 &charescape, &options.max_depth, &mname,
1902 &bq, &attr, &priority, &partial, &options.spacing,
1903 &blobs, &cycles, &varnames, &nl, &fullstop,
1904 &no_lists) )
1905 fail;
1906
1907 if ( attr == ATOM_nil )
1908 { options.flags |= LD->prolog_flag.write_attributes;
1909 } else
1910 { int mask = writeAttributeMask(attr);
1911
1912 if ( !mask )
1913 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_option, opts);
1914
1915 options.flags |= mask;
1916 }
1917 if ( blobs != ATOM_nil )
1918 { int mask = writeBlobMask(blobs);
1919
1920 if ( mask < 0 )
1921 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_write_option, opts);
1922
1923 options.flags |= mask;
1924 }
1925 if ( priority < 0 || priority > OP_MAXPRIORITY )
1926 { term_t t = PL_new_term_ref();
1927 PL_put_integer(t, priority);
1928
1929 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_operator_priority, t);
1930 }
1931 switch( options.spacing )
1932 { case ATOM_standard:
1933 case ATOM_next_argument:
1934 break;
1935 default:
1936 { term_t t = PL_new_term_ref();
1937 PL_put_atom(t, options.spacing);
1938
1939 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_spacing, t);
1940 }
1941 }
1942
1943 options.module = isCurrentModule(mname);
1944 if ( !options.module )
1945 options.module = MODULE_user;
1946 if ( charescape == TRUE ||
1947 (charescape == -1 && true(options.module, M_CHARESCAPE)) )
1948 options.flags |= PL_WRT_CHARESCAPES;
1949 if ( true(options.module, RAT_NATURAL) )
1950 options.flags |= PL_WRT_RAT_NATURAL;
1951 if ( gportray )
1952 { options.portray_goal = gportray;
1953 if ( !put_write_options(opts, &options) ||
1954 !PL_qualify(options.portray_goal, options.portray_goal) )
1955 return FALSE;
1956 if ( false(&options, PL_WRT_BLOB_PORTRAY) )
1957 portray = TRUE;
1958 }
1959 if ( numbervars == -1 )
1960 numbervars = (portray ? TRUE : FALSE);
1961
1962 if ( quoted ) options.flags |= PL_WRT_QUOTED;
1963 if ( ignore_ops ) options.flags |= PL_WRT_IGNOREOPS;
1964 if ( dotlists ) options.flags |= PL_WRT_DOTLISTS;
1965 if ( braceterms ) options.flags |= PL_WRT_BRACETERMS;
1966 if ( numbervars ) options.flags |= PL_WRT_NUMBERVARS;
1967 if ( portray ) options.flags |= PL_WRT_PORTRAY;
1968 if ( !cycles ) options.flags |= PL_WRT_NO_CYCLES;
1969 if ( no_lists ) options.flags |= PL_WRT_NO_LISTS;
1970 if ( bq )
1971 { unsigned int flags = 0;
1972
1973 if ( !setBackQuotes(bq, &flags) )
1974 return FALSE;
1975 if ( (flags&BQ_STRING) )
1976 options.flags |= PL_WRT_BACKQUOTED_STRING;
1977 else if ( flags == 0 )
1978 options.flags |= PL_WRT_BACKQUOTE_IS_SYMBOL;
1979 }
1980
1981 local_varnames = (varnames && false(&options, PL_WRT_NUMBERVARS));
1982
1983 BEGIN_NUMBERVARS(local_varnames);
1984 if ( varnames )
1985 { if ( (rc=bind_varnames(varnames PASS_LD)) )
1986 options.flags |= PL_WRT_VARNAMES;
1987 else
1988 goto out;
1989 }
1990 if ( !(rc=getTextOutputStream(stream, &s)) )
1991 goto out;
1992
1993 options.out = s;
1994 if ( !partial )
1995 PutOpenToken(EOF, s); /* reset this */
1996 if ( (options.flags & PL_WRT_QUOTED) && !(s->flags&SIO_REPPL) )
1997 { s->flags |= SIO_REPPL;
1998 rc = writeTopTerm(term, priority, &options);
1999 s->flags &= ~SIO_REPPL;
2000 } else
2001 { rc = writeTopTerm(term, priority, &options);
2002 }
2003
2004 if ( rc && fullstop )
2005 rc = PutToken(".", s) && Putc(nl ? '\n' : ' ', s);
2006 else if ( nl )
2007 rc = Putc('\n', s);
2008
2009 out:
2010 END_NUMBERVARS(local_varnames);
2011
2012 return (!s || streamStatus(s)) && rc;
2013 }
2014
2015
2016 foreign_t
pl_write_term(term_t term,term_t options)2017 pl_write_term(term_t term, term_t options)
2018 { return pl_write_term3(0, term, options);
2019 }
2020
2021
2022 int
PL_write_term(IOSTREAM * s,term_t term,int precedence,int flags)2023 PL_write_term(IOSTREAM *s, term_t term, int precedence, int flags)
2024 { write_options options;
2025 int rc;
2026
2027 memset(&options, 0, sizeof(options));
2028 options.flags = flags;
2029 options.out = s;
2030 options.module = MODULE_user;
2031
2032 if ( (s=PL_acquire_stream(s)) )
2033 { PutOpenToken(EOF, s); /* reset this */
2034 rc = writeTopTerm(term, precedence, &options);
2035 if ( rc && (flags&PL_WRT_NEWLINE) )
2036 rc = Putc('\n', s);
2037 rc = PL_release_stream(s) && rc;
2038 } else
2039 rc = FALSE;
2040
2041 return rc;
2042 }
2043
2044
2045 static word
do_write2(term_t stream,term_t term,int flags,int canonical)2046 do_write2(term_t stream, term_t term, int flags, int canonical)
2047 { GET_LD
2048 IOSTREAM *s;
2049
2050 if ( getTextOutputStream(stream, &s) )
2051 { write_options options;
2052 int rc;
2053
2054 memset(&options, 0, sizeof(options));
2055 options.flags = flags;
2056 if ( !canonical )
2057 options.flags |= LD->prolog_flag.write_attributes;
2058 options.out = s;
2059 options.module = MODULE_user;
2060 if ( true(options.module, M_CHARESCAPE) )
2061 options.flags |= PL_WRT_CHARESCAPES;
2062 if ( true(options.module, BQ_STRING) )
2063 options.flags |= PL_WRT_BACKQUOTED_STRING;
2064
2065 PutOpenToken(EOF, s); /* reset this */
2066 rc = writeTopTerm(term, 1200, &options);
2067 if ( rc && (flags&PL_WRT_NEWLINE) )
2068 rc = Putc('\n', s);
2069
2070 return streamStatus(s) && rc;
2071 }
2072
2073 return FALSE;
2074 }
2075
2076
2077 foreign_t
pl_write2(term_t stream,term_t term)2078 pl_write2(term_t stream, term_t term)
2079 { return do_write2(stream, term, PL_WRT_NUMBERVARS, FALSE);
2080 }
2081
2082 foreign_t
pl_writeln2(term_t stream,term_t term)2083 pl_writeln2(term_t stream, term_t term)
2084 { return do_write2(stream, term, PL_WRT_NUMBERVARS|PL_WRT_NEWLINE, FALSE);
2085 }
2086
2087 foreign_t
pl_writeq2(term_t stream,term_t term)2088 pl_writeq2(term_t stream, term_t term)
2089 { return do_write2(stream, term, PL_WRT_QUOTED|PL_WRT_NUMBERVARS, FALSE);
2090 }
2091
2092 foreign_t
pl_print2(term_t stream,term_t term)2093 pl_print2(term_t stream, term_t term)
2094 { GET_LD
2095 fid_t fid = PL_open_foreign_frame();
2096 term_t opts = PL_new_term_ref();
2097 foreign_t rc;
2098
2099 if ( PL_current_prolog_flag(ATOM_print_write_options, PL_TERM, &opts) )
2100 rc = pl_write_term3(stream, term, opts);
2101 else
2102 rc = do_write2(stream, term,
2103 PL_WRT_PORTRAY|PL_WRT_NUMBERVARS|PL_WRT_QUOTED, FALSE);
2104
2105 PL_discard_foreign_frame(fid);
2106
2107 return rc;
2108 }
2109
2110 word
pl_write_canonical2(term_t stream,term_t term)2111 pl_write_canonical2(term_t stream, term_t term)
2112 { GET_LD
2113 nv_options options;
2114 word rc;
2115
2116 BEGIN_NUMBERVARS(TRUE);
2117
2118 options.functor = FUNCTOR_isovar1;
2119 options.on_attvar = AV_SKIP;
2120 options.singletons = PL_is_acyclic(term);
2121 options.numbered_check = FALSE;
2122
2123 rc = ( numberVars(term, &options, 0 PASS_LD) != NV_ERROR &&
2124 do_write2(stream, term,
2125 PL_WRT_QUOTED|PL_WRT_IGNOREOPS|PL_WRT_NUMBERVARS|
2126 PL_WRT_NODOTINATOM, TRUE)
2127 );
2128
2129 END_NUMBERVARS(TRUE);
2130
2131 return rc;
2132 }
2133
2134 foreign_t
pl_write(term_t term)2135 pl_write(term_t term)
2136 { return pl_write2(0, term);
2137 }
2138
2139 foreign_t
pl_writeq(term_t term)2140 pl_writeq(term_t term)
2141 { return pl_writeq2(0, term);
2142 }
2143
2144 foreign_t
pl_print(term_t term)2145 pl_print(term_t term)
2146 { return pl_print2(0, term);
2147 }
2148
2149 foreign_t
pl_write_canonical(term_t term)2150 pl_write_canonical(term_t term)
2151 { return pl_write_canonical2(0, term);
2152 }
2153
2154 foreign_t
pl_writeln(term_t term)2155 pl_writeln(term_t term)
2156 { return do_write2(0, term, PL_WRT_NUMBERVARS|PL_WRT_NEWLINE, FALSE);
2157 }
2158
2159
2160 static
2161 PRED_IMPL("$put_token", 2, put_token, 0)
2162 { char *s;
2163 size_t len;
2164 IOSTREAM *out;
2165
2166 if ( !PL_get_stream_handle(A1, &out) )
2167 fail;
2168 if ( !PL_get_nchars(A2, &len, &s, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) )
2169 fail;
2170
2171 if ( PutTokenN(s, len, out) )
2172 return PL_release_stream(out);
2173
2174 PL_release_stream(out);
2175 fail;
2176 }
2177
2178 /** '$put_quoted_codes'(+Stream, +Quote, +Codes, +Options)
2179
2180 Emit Codes using the escaped character syntax, but does not emit the
2181 start and end-code itself. Options is currently ignored. It is intended
2182 to provide additional preferences, so as using \uXXXX, \UXXXXXXXX, etc.
2183 */
2184
2185 static
2186 PRED_IMPL("$put_quoted", 4, put_quoted_codes, 0)
2187 { IOSTREAM *out;
2188 pl_wchar_t *w;
2189 size_t i, len;
2190 int quote;
2191 int flags = PL_WRT_CHARESCAPES;
2192 int rc = TRUE;
2193
2194 if ( !PL_get_stream_handle(A1, &out) ||
2195 !PL_get_char_ex(A2, "e, FALSE) ||
2196 !PL_get_wchars(A3, &len, &w, CVT_LIST|CVT_STRING|CVT_EXCEPTION) )
2197 return FALSE;
2198
2199 for(i=0; rc && i<len; i++)
2200 rc = putQuoted(w[i], quote, flags, out);
2201
2202 if ( rc )
2203 rc = PL_release_stream(out);
2204
2205 return rc;
2206 }
2207
2208
2209 /*******************************
2210 * PRINT LENGTH *
2211 *******************************/
2212
2213 typedef struct limit_size_stream
2214 { IOSTREAM *stream; /* Limited stream */
2215 int64_t length; /* Max size */
2216 } limit_size_stream;
2217
2218 static ssize_t
Swrite_lss(void * handle,char * buf,size_t size)2219 Swrite_lss(void *handle, char *buf, size_t size)
2220 { limit_size_stream *lss = handle;
2221 (void)buf;
2222
2223 if ( lss->stream->position->charno > lss->length )
2224 return -1;
2225
2226 return size;
2227 }
2228
2229 static int
Sclose_lss(void * handle)2230 Sclose_lss(void *handle)
2231 { (void)handle;
2232
2233 return 0;
2234 }
2235
2236 static const IOFUNCTIONS lss_functions =
2237 { NULL,
2238 Swrite_lss,
2239 NULL,
2240 Sclose_lss
2241 };
2242
2243 /** write_length(+Term, -Len, +Options) is det.
2244
2245 (*) Avoid error on max_length in iso mode. It might be nicer to get the
2246 option processing out of pl_write_term3(), so we can take control of the
2247 whole lot here more easily.
2248 */
2249
2250 static
2251 PRED_IMPL("write_length", 3, write_length, 0)
2252 { PRED_LD
2253 limit_size_stream lss;
2254 int sflags = SIO_NBUF|SIO_RECORDPOS|SIO_OUTPUT|SIO_TEXT;
2255 IOSTREAM *s;
2256 term_t options = PL_copy_term_ref(A3);
2257 term_t head = PL_new_term_ref();
2258 char buf[100];
2259
2260 lss.length = PLMAXINT;
2261 while(PL_get_list(options, head, options))
2262 { atom_t name;
2263 size_t arity;
2264
2265 if ( PL_get_name_arity(head, &name, &arity) &&
2266 name == ATOM_max_length && arity == 1 )
2267 { term_t a = PL_new_term_ref();
2268
2269 _PL_get_arg(1, head, a);
2270 if ( !PL_get_int64_ex(a, &lss.length) )
2271 return FALSE;
2272 }
2273 }
2274
2275 if ( (s = Snew(&lss, sflags, (IOFUNCTIONS *)&lss_functions)) )
2276 { int64_t len;
2277 int rc;
2278 pl_features_t oldmask = LD->prolog_flag.mask; /* (*) */
2279
2280 lss.stream = s;
2281 s->encoding = ENC_UTF8;
2282 Ssetbuffer(s, buf, sizeof(buf));
2283 s->flags |= SIO_USERBUF;
2284
2285 clearPrologFlagMask(PLFLAG_ISO);
2286 pushOutputContext();
2287 Scurout = s;
2288 rc = pl_write_term3(0, A1, A3);
2289 popOutputContext();
2290 LD->prolog_flag.mask = oldmask;
2291
2292 if ( rc && s->position->charno <= lss.length )
2293 { len = s->position->charno;
2294 } else
2295 { len = -1;
2296 if ( s->position->charno > lss.length )
2297 PL_clear_exception();
2298 }
2299
2300 Sclose(s);
2301 if ( len >= 0 )
2302 return PL_unify_int64(A2, len);
2303 }
2304
2305 return FALSE;
2306 }
2307
2308
2309 /*******************************
2310 * PUBLISH PREDICATES *
2311 *******************************/
2312
2313 BeginPredDefs(write)
2314 PRED_DEF("nl", 0, nl, PL_FA_ISO)
2315 PRED_DEF("nl", 1, nl, PL_FA_ISO)
2316 PRED_DEF("$put_token", 2, put_token, 0)
2317 PRED_DEF("$put_quoted", 4, put_quoted_codes, 0)
2318 PRED_DEF("write_length", 3, write_length, 0)
2319 EndPredDefs
2320
2321