1 /* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
7 *
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16 */
17
18
19
20 #ifdef HAVE_CONFIG_H
21 # include <config.h>
22 #endif
23
24 #include <errno.h>
25
26 #include "libguile/_scm.h"
27 #include "libguile/chars.h"
28 #include "libguile/continuations.h"
29 #include "libguile/smob.h"
30 #include "libguile/eval.h"
31 #include "libguile/macros.h"
32 #include "libguile/procprop.h"
33 #include "libguile/read.h"
34 #include "libguile/weaks.h"
35 #include "libguile/unif.h"
36 #include "libguile/alist.h"
37 #include "libguile/struct.h"
38 #include "libguile/objects.h"
39 #include "libguile/ports.h"
40 #include "libguile/root.h"
41 #include "libguile/strings.h"
42 #include "libguile/strports.h"
43 #include "libguile/vectors.h"
44 #include "libguile/lang.h"
45 #include "libguile/numbers.h"
46
47 #include "libguile/validate.h"
48 #include "libguile/print.h"
49
50
51 /* {Names of immediate symbols}
52 *
53 * This table must agree with the declarations in scm.h: {Immediate Symbols}.
54 */
55
56 /* This table must agree with the list of flags in tags.h. */
57 static const char *iflagnames[] =
58 {
59 "#f",
60 "#t",
61 "#<undefined>",
62 "#<eof>",
63 "()",
64 "#<unspecified>",
65
66 /* Unbound slot marker for GOOPS. For internal use in GOOPS only. */
67 "#<unbound>",
68
69 /* Elisp nil value. This is its Scheme name; whenever it's printed in
70 * Elisp, it should appear as the symbol `nil'. */
71 "#nil"
72 };
73
74 SCM_SYMBOL (sym_reader, "reader");
75
76 scm_t_option scm_print_opts[] = {
77 { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F),
78 "Hook for printing closures (should handle macros as well)." },
79 { SCM_OPTION_BOOLEAN, "source", 0,
80 "Print closures with source." },
81 { SCM_OPTION_SCM, "highlight-prefix", (unsigned long)SCM_BOOL_F,
82 "The string to print before highlighted values." },
83 { SCM_OPTION_SCM, "highlight-suffix", (unsigned long)SCM_BOOL_F,
84 "The string to print after highlighted values." },
85 { SCM_OPTION_SCM, "quote-keywordish-symbols", (unsigned long)SCM_BOOL_F,
86 "How to print symbols that have a colon as their first or last character. "
87 "The value '#f' does not quote the colons; '#t' quotes them; "
88 "'reader' quotes them when the reader option 'keywords' is not '#f'."
89 }
90 };
91
92 SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
93 (SCM setting),
94 "Option interface for the print options. Instead of using\n"
95 "this procedure directly, use the procedures\n"
96 "@code{print-enable}, @code{print-disable}, @code{print-set!}\n"
97 "and @code{print-options}.")
98 #define FUNC_NAME s_scm_print_options
99 {
100 SCM ans = scm_options (setting,
101 scm_print_opts,
102 SCM_N_PRINT_OPTIONS,
103 FUNC_NAME);
104 return ans;
105 }
106 #undef FUNC_NAME
107
108
109 /* {Printing of Scheme Objects}
110 */
111
112 /* Detection of circular references.
113 *
114 * Due to other constraints in the implementation, this code has bad
115 * time complexity (O (depth * N)), The printer code can be
116 * rewritten to be O(N).
117 */
118 #define PUSH_REF(pstate, obj) \
119 do \
120 { \
121 PSTATE_STACK_SET (pstate, pstate->top, obj); \
122 pstate->top++; \
123 if (pstate->top == pstate->ceiling) \
124 grow_ref_stack (pstate); \
125 } while(0)
126
127 #define ENTER_NESTED_DATA(pstate, obj, label) \
128 do \
129 { \
130 register unsigned long i; \
131 for (i = 0; i < pstate->top; ++i) \
132 if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj))) \
133 goto label; \
134 if (pstate->fancyp) \
135 { \
136 if (pstate->top - pstate->list_offset >= pstate->level) \
137 { \
138 scm_putc ('#', port); \
139 return; \
140 } \
141 } \
142 PUSH_REF(pstate, obj); \
143 } while(0)
144
145 #define EXIT_NESTED_DATA(pstate) \
146 do \
147 { \
148 --pstate->top; \
149 PSTATE_STACK_SET (pstate, pstate->top, SCM_UNDEFINED); \
150 } \
151 while (0)
152
153 SCM scm_print_state_vtable = SCM_BOOL_F;
154 static SCM print_state_pool = SCM_EOL;
155 scm_i_pthread_mutex_t print_state_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
156
157 #ifdef GUILE_DEBUG /* Used for debugging purposes */
158
159 SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0,
160 (),
161 "Return the current-pstate -- the car of the\n"
162 "@code{print_state_pool}. @code{current-pstate} is only\n"
163 "included in @code{--enable-guile-debug} builds.")
164 #define FUNC_NAME s_scm_current_pstate
165 {
166 if (!scm_is_null (print_state_pool))
167 return SCM_CAR (print_state_pool);
168 else
169 return SCM_BOOL_F;
170 }
171 #undef FUNC_NAME
172
173 #endif
174
175 #define PSTATE_SIZE 50L
176
177 static SCM
make_print_state(void)178 make_print_state (void)
179 {
180 SCM print_state
181 = scm_make_struct (scm_print_state_vtable, SCM_INUM0, SCM_EOL);
182 scm_print_state *pstate = SCM_PRINT_STATE (print_state);
183 pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
184 pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect);
185 pstate->highlight_objects = SCM_EOL;
186 return print_state;
187 }
188
189 SCM
scm_make_print_state()190 scm_make_print_state ()
191 {
192 SCM answer = SCM_BOOL_F;
193
194 /* First try to allocate a print state from the pool */
195 scm_i_pthread_mutex_lock (&print_state_mutex);
196 if (!scm_is_null (print_state_pool))
197 {
198 answer = SCM_CAR (print_state_pool);
199 print_state_pool = SCM_CDR (print_state_pool);
200 }
201 scm_i_pthread_mutex_unlock (&print_state_mutex);
202
203 return scm_is_false (answer) ? make_print_state () : answer;
204 }
205
206 void
scm_free_print_state(SCM print_state)207 scm_free_print_state (SCM print_state)
208 {
209 SCM handle;
210 scm_print_state *pstate = SCM_PRINT_STATE (print_state);
211 /* Cleanup before returning print state to pool.
212 * It is better to do it here. Doing it in scm_prin1
213 * would cost more since that function is called much more
214 * often.
215 */
216 pstate->fancyp = 0;
217 pstate->revealed = 0;
218 pstate->highlight_objects = SCM_EOL;
219 scm_i_pthread_mutex_lock (&print_state_mutex);
220 handle = scm_cons (print_state, print_state_pool);
221 print_state_pool = handle;
222 scm_i_pthread_mutex_unlock (&print_state_mutex);
223 }
224
225 SCM
scm_i_port_with_print_state(SCM port,SCM print_state)226 scm_i_port_with_print_state (SCM port, SCM print_state)
227 {
228 if (SCM_UNBNDP (print_state))
229 {
230 if (SCM_PORT_WITH_PS_P (port))
231 return port;
232 else
233 print_state = scm_make_print_state ();
234 /* port does not need to be coerced since it doesn't have ps */
235 }
236 else
237 port = SCM_COERCE_OUTPORT (port);
238 SCM_RETURN_NEWSMOB (scm_tc16_port_with_ps,
239 SCM_UNPACK (scm_cons (port, print_state)));
240 }
241
242 static void
grow_ref_stack(scm_print_state * pstate)243 grow_ref_stack (scm_print_state *pstate)
244 {
245 SCM old_vect = pstate->ref_vect;
246 size_t old_size = SCM_SIMPLE_VECTOR_LENGTH (old_vect);
247 size_t new_size = 2 * pstate->ceiling;
248 SCM new_vect = scm_c_make_vector (new_size, SCM_UNDEFINED);
249 unsigned long int i;
250
251 for (i = 0; i != old_size; ++i)
252 SCM_SIMPLE_VECTOR_SET (new_vect, i, SCM_SIMPLE_VECTOR_REF (old_vect, i));
253
254 pstate->ref_vect = new_vect;
255 pstate->ceiling = new_size;
256 }
257
258 #define PSTATE_STACK_REF(p,i) SCM_SIMPLE_VECTOR_REF((p)->ref_vect, (i))
259 #define PSTATE_STACK_SET(p,i,v) SCM_SIMPLE_VECTOR_SET((p)->ref_vect, (i), (v))
260
261 static void
print_circref(SCM port,scm_print_state * pstate,SCM ref)262 print_circref (SCM port, scm_print_state *pstate, SCM ref)
263 {
264 register long i;
265 long self = pstate->top - 1;
266 i = pstate->top - 1;
267 if (scm_is_pair (PSTATE_STACK_REF (pstate, i)))
268 {
269 while (i > 0)
270 {
271 if (!scm_is_pair (PSTATE_STACK_REF (pstate, i-1))
272 || !scm_is_eq (SCM_CDR (PSTATE_STACK_REF (pstate, i-1)),
273 SCM_CDR (PSTATE_STACK_REF (pstate, i))))
274 break;
275 --i;
276 }
277 self = i;
278 }
279 for (i = pstate->top - 1; 1; --i)
280 if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
281 break;
282 scm_putc ('#', port);
283 scm_intprint (i - self, 10, port);
284 scm_putc ('#', port);
285 }
286
287 /* Print the name of a symbol. */
288
289 static int
quote_keywordish_symbol(const char * str,size_t len)290 quote_keywordish_symbol (const char *str, size_t len)
291 {
292 SCM option;
293
294 /* LEN is guaranteed to be > 0.
295 */
296 if (str[0] != ':' && str[len-1] != ':')
297 return 0;
298
299 option = SCM_PRINT_KEYWORD_STYLE;
300 if (scm_is_false (option))
301 return 0;
302 if (scm_is_eq (option, sym_reader))
303 return scm_is_true (SCM_PACK (SCM_KEYWORD_STYLE));
304 return 1;
305 }
306
307 void
scm_print_symbol_name(const char * str,size_t len,SCM port)308 scm_print_symbol_name (const char *str, size_t len, SCM port)
309 {
310 /* This points to the first character that has not yet been written to the
311 * port. */
312 size_t pos = 0;
313 /* This points to the character we're currently looking at. */
314 size_t end;
315 /* If the name contains weird characters, we'll escape them with
316 * backslashes and set this flag; it indicates that we should surround the
317 * name with "#{" and "}#". */
318 int weird = 0;
319 /* Backslashes are not sufficient to make a name weird, but if a name is
320 * weird because of other characters, backslahes need to be escaped too.
321 * The first time we see a backslash, we set maybe_weird, and mw_pos points
322 * to the backslash. Then if the name turns out to be weird, we re-process
323 * everything starting from mw_pos.
324 * We could instead make backslashes always weird. This is not necessary
325 * to ensure that the output is (read)-able, but it would make this code
326 * simpler and faster. */
327 int maybe_weird = 0;
328 size_t mw_pos = 0;
329
330 if (len == 0 || str[0] == '\'' || str[0] == '`' || str[0] == ','
331 || quote_keywordish_symbol (str, len)
332 || (str[0] == '.' && len == 1)
333 || scm_is_true (scm_c_locale_stringn_to_number (str, len, 10)))
334 {
335 scm_lfwrite ("#{", 2, port);
336 weird = 1;
337 }
338
339 for (end = pos; end < len; ++end)
340 switch (str[end])
341 {
342 #ifdef BRACKETS_AS_PARENS
343 case '[':
344 case ']':
345 #endif
346 case '(':
347 case ')':
348 case '"':
349 case ';':
350 case '#':
351 case SCM_WHITE_SPACES:
352 case SCM_LINE_INCREMENTORS:
353 weird_handler:
354 if (maybe_weird)
355 {
356 end = mw_pos;
357 maybe_weird = 0;
358 }
359 if (!weird)
360 {
361 scm_lfwrite ("#{", 2, port);
362 weird = 1;
363 }
364 if (pos < end)
365 scm_lfwrite (str + pos, end - pos, port);
366 {
367 char buf[2];
368 buf[0] = '\\';
369 buf[1] = str[end];
370 scm_lfwrite (buf, 2, port);
371 }
372 pos = end + 1;
373 break;
374 case '\\':
375 if (weird)
376 goto weird_handler;
377 if (!maybe_weird)
378 {
379 maybe_weird = 1;
380 mw_pos = pos;
381 }
382 break;
383 default:
384 break;
385 }
386 if (pos < end)
387 scm_lfwrite (str + pos, end - pos, port);
388 if (weird)
389 scm_lfwrite ("}#", 2, port);
390 }
391
392 /* Print generally. Handles both write and display according to PSTATE.
393 */
394 SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
395 SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);
396
397 static void iprin1 (SCM exp, SCM port, scm_print_state *pstate);
398
399 void
scm_iprin1(SCM exp,SCM port,scm_print_state * pstate)400 scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
401 {
402 if (pstate->fancyp
403 && scm_is_true (scm_memq (exp, pstate->highlight_objects)))
404 {
405 scm_display (SCM_PRINT_HIGHLIGHT_PREFIX, port);
406 iprin1 (exp, port, pstate);
407 scm_display (SCM_PRINT_HIGHLIGHT_SUFFIX, port);
408 }
409 else
410 iprin1 (exp, port, pstate);
411 }
412
413 static void
iprin1(SCM exp,SCM port,scm_print_state * pstate)414 iprin1 (SCM exp, SCM port, scm_print_state *pstate)
415 {
416 switch (SCM_ITAG3 (exp))
417 {
418 case scm_tc3_closure:
419 case scm_tc3_tc7_1:
420 case scm_tc3_tc7_2:
421 /* These tc3 tags should never occur in an immediate value. They are
422 * only used in cell types of non-immediates, i. e. the value returned
423 * by SCM_CELL_TYPE (exp) can use these tags.
424 */
425 scm_ipruk ("immediate", exp, port);
426 break;
427 case scm_tc3_int_1:
428 case scm_tc3_int_2:
429 scm_intprint (SCM_I_INUM (exp), 10, port);
430 break;
431 case scm_tc3_imm24:
432 if (SCM_CHARP (exp))
433 {
434 long i = SCM_CHAR (exp);
435
436 if (SCM_WRITINGP (pstate))
437 {
438 scm_puts ("#\\", port);
439 if ((i >= 0) && (i <= ' ') && scm_charnames[i])
440 scm_puts (scm_charnames[i], port);
441 #ifndef EBCDIC
442 else if (i == '\177')
443 scm_puts (scm_charnames[scm_n_charnames - 1], port);
444 #endif
445 else if (i < 0 || i > '\177')
446 scm_intprint (i, 8, port);
447 else
448 scm_putc (i, port);
449 }
450 else
451 scm_putc (i, port);
452 }
453 else if (SCM_IFLAGP (exp)
454 && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
455 {
456 scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
457 }
458 else if (SCM_ISYMP (exp))
459 {
460 scm_i_print_isym (exp, port);
461 }
462 else if (SCM_ILOCP (exp))
463 {
464 scm_i_print_iloc (exp, port);
465 }
466 else
467 {
468 /* unknown immediate value */
469 scm_ipruk ("immediate", exp, port);
470 }
471 break;
472 case scm_tc3_cons:
473 switch (SCM_TYP7 (exp))
474 {
475 case scm_tcs_struct:
476 {
477 ENTER_NESTED_DATA (pstate, exp, circref);
478 if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
479 {
480 SCM pwps, print = pstate->writingp ? g_write : g_display;
481 if (!print)
482 goto print_struct;
483 pwps = scm_i_port_with_print_state (port, pstate->handle);
484 pstate->revealed = 1;
485 scm_call_generic_2 (print, exp, pwps);
486 }
487 else
488 {
489 print_struct:
490 scm_print_struct (exp, port, pstate);
491 }
492 EXIT_NESTED_DATA (pstate);
493 }
494 break;
495 case scm_tcs_cons_imcar:
496 case scm_tcs_cons_nimcar:
497 ENTER_NESTED_DATA (pstate, exp, circref);
498 scm_iprlist ("(", exp, ')', port, pstate);
499 EXIT_NESTED_DATA (pstate);
500 break;
501 circref:
502 print_circref (port, pstate, exp);
503 break;
504 case scm_tcs_closures:
505 if (scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
506 || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
507 exp, port, pstate)))
508 {
509 SCM formals = SCM_CLOSURE_FORMALS (exp);
510 scm_puts ("#<procedure", port);
511 scm_putc (' ', port);
512 scm_iprin1 (scm_procedure_name (exp), port, pstate);
513 scm_putc (' ', port);
514 if (SCM_PRINT_SOURCE_P)
515 {
516 SCM env = SCM_ENV (exp);
517 SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
518 SCM src = scm_i_unmemocopy_body (SCM_CODE (exp), xenv);
519 ENTER_NESTED_DATA (pstate, exp, circref);
520 scm_iprin1 (src, port, pstate);
521 EXIT_NESTED_DATA (pstate);
522 }
523 else
524 scm_iprin1 (formals, port, pstate);
525 scm_putc ('>', port);
526 }
527 break;
528 case scm_tc7_number:
529 switch SCM_TYP16 (exp) {
530 case scm_tc16_big:
531 scm_bigprint (exp, port, pstate);
532 break;
533 case scm_tc16_real:
534 scm_print_real (exp, port, pstate);
535 break;
536 case scm_tc16_complex:
537 scm_print_complex (exp, port, pstate);
538 break;
539 case scm_tc16_fraction:
540 scm_i_print_fraction (exp, port, pstate);
541 break;
542 }
543 break;
544 case scm_tc7_string:
545 if (SCM_WRITINGP (pstate))
546 {
547 size_t i, j, len;
548 const char *data;
549
550 scm_putc ('"', port);
551 len = scm_i_string_length (exp);
552 data = scm_i_string_chars (exp);
553 for (i = 0, j = 0; i < len; ++i)
554 {
555 unsigned char ch = data[i];
556 if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148))
557 {
558 static char const hex[]="0123456789abcdef";
559 char buf[4];
560
561 scm_lfwrite (data+j, i-j, port);
562 buf[0] = '\\';
563 buf[1] = 'x';
564 buf[2] = hex [ch / 16];
565 buf[3] = hex [ch % 16];
566 scm_lfwrite (buf, 4, port);
567 data = scm_i_string_chars (exp);
568 j = i+1;
569 }
570 else if (ch == '"' || ch == '\\')
571 {
572 scm_lfwrite (data+j, i-j, port);
573 scm_putc ('\\', port);
574 data = scm_i_string_chars (exp);
575 j = i;
576 }
577 }
578 scm_lfwrite (data+j, i-j, port);
579 scm_putc ('"', port);
580 scm_remember_upto_here_1 (exp);
581 }
582 else
583 scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp),
584 port);
585 scm_remember_upto_here_1 (exp);
586 break;
587 case scm_tc7_symbol:
588 if (scm_i_symbol_is_interned (exp))
589 {
590 scm_print_symbol_name (scm_i_symbol_chars (exp),
591 scm_i_symbol_length (exp),
592 port);
593 scm_remember_upto_here_1 (exp);
594 }
595 else
596 {
597 scm_puts ("#<uninterned-symbol ", port);
598 scm_print_symbol_name (scm_i_symbol_chars (exp),
599 scm_i_symbol_length (exp),
600 port);
601 scm_putc (' ', port);
602 scm_uintprint (SCM_UNPACK (exp), 16, port);
603 scm_putc ('>', port);
604 }
605 break;
606 case scm_tc7_variable:
607 scm_i_variable_print (exp, port, pstate);
608 break;
609 case scm_tc7_wvect:
610 ENTER_NESTED_DATA (pstate, exp, circref);
611 if (SCM_IS_WHVEC (exp))
612 scm_puts ("#wh(", port);
613 else
614 scm_puts ("#w(", port);
615 goto common_vector_printer;
616
617 case scm_tc7_vector:
618 ENTER_NESTED_DATA (pstate, exp, circref);
619 scm_puts ("#(", port);
620 common_vector_printer:
621 {
622 register long i;
623 long last = SCM_SIMPLE_VECTOR_LENGTH (exp) - 1;
624 int cutp = 0;
625 if (pstate->fancyp
626 && SCM_SIMPLE_VECTOR_LENGTH (exp) > pstate->length)
627 {
628 last = pstate->length - 1;
629 cutp = 1;
630 }
631 for (i = 0; i < last; ++i)
632 {
633 /* CHECK_INTS; */
634 scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
635 scm_putc (' ', port);
636 }
637 if (i == last)
638 {
639 /* CHECK_INTS; */
640 scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
641 }
642 if (cutp)
643 scm_puts (" ...", port);
644 scm_putc (')', port);
645 }
646 EXIT_NESTED_DATA (pstate);
647 break;
648 case scm_tcs_subrs:
649 scm_puts (SCM_SUBR_GENERIC (exp)
650 ? "#<primitive-generic "
651 : "#<primitive-procedure ",
652 port);
653 scm_puts (scm_i_symbol_chars (SCM_SNAME (exp)), port);
654 scm_putc ('>', port);
655 break;
656 #ifdef CCLO
657 case scm_tc7_cclo:
658 {
659 SCM proc = SCM_CCLO_SUBR (exp);
660 if (scm_is_eq (proc, scm_f_gsubr_apply))
661 {
662 /* Print gsubrs as primitives */
663 SCM name = scm_procedure_name (exp);
664 scm_puts ("#<primitive-procedure", port);
665 if (scm_is_true (name))
666 {
667 scm_putc (' ', port);
668 scm_puts (scm_i_symbol_chars (name), port);
669 }
670 }
671 else
672 {
673 scm_puts ("#<compiled-closure ", port);
674 scm_iprin1 (proc, port, pstate);
675 }
676 scm_putc ('>', port);
677 }
678 break;
679 #endif
680 case scm_tc7_pws:
681 scm_puts ("#<procedure-with-setter", port);
682 {
683 SCM name = scm_procedure_name (exp);
684 if (scm_is_true (name))
685 {
686 scm_putc (' ', port);
687 scm_display (name, port);
688 }
689 }
690 scm_putc ('>', port);
691 break;
692 case scm_tc7_port:
693 {
694 register long i = SCM_PTOBNUM (exp);
695 if (i < scm_numptob
696 && scm_ptobs[i].print
697 && (scm_ptobs[i].print) (exp, port, pstate))
698 break;
699 goto punk;
700 }
701 case scm_tc7_smob:
702 ENTER_NESTED_DATA (pstate, exp, circref);
703 SCM_SMOB_DESCRIPTOR (exp).print (exp, port, pstate);
704 EXIT_NESTED_DATA (pstate);
705 break;
706 default:
707 punk:
708 scm_ipruk ("type", exp, port);
709 }
710 }
711 }
712
713 /* Print states are necessary for circular reference safe printing.
714 * They are also expensive to allocate. Therefore print states are
715 * kept in a pool so that they can be reused.
716 */
717
718 /* The PORT argument can also be a print-state/port pair, which will
719 * then be used instead of allocating a new print state. This is
720 * useful for continuing a chain of print calls from Scheme. */
721
722 void
scm_prin1(SCM exp,SCM port,int writingp)723 scm_prin1 (SCM exp, SCM port, int writingp)
724 {
725 SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */
726 SCM pstate_scm;
727 scm_print_state *pstate;
728 int old_writingp;
729
730 /* If PORT is a print-state/port pair, use that. Else create a new
731 print-state. */
732
733 if (SCM_PORT_WITH_PS_P (port))
734 {
735 pstate_scm = SCM_PORT_WITH_PS_PS (port);
736 port = SCM_PORT_WITH_PS_PORT (port);
737 }
738 else
739 {
740 /* First try to allocate a print state from the pool */
741 scm_i_pthread_mutex_lock (&print_state_mutex);
742 if (!scm_is_null (print_state_pool))
743 {
744 handle = print_state_pool;
745 print_state_pool = SCM_CDR (print_state_pool);
746 }
747 scm_i_pthread_mutex_unlock (&print_state_mutex);
748 if (scm_is_false (handle))
749 handle = scm_list_1 (make_print_state ());
750 pstate_scm = SCM_CAR (handle);
751 }
752
753 pstate = SCM_PRINT_STATE (pstate_scm);
754 old_writingp = pstate->writingp;
755 pstate->writingp = writingp;
756 scm_iprin1 (exp, port, pstate);
757 pstate->writingp = old_writingp;
758
759 /* Return print state to pool if it has been created above and
760 hasn't escaped to Scheme. */
761
762 if (scm_is_true (handle) && !pstate->revealed)
763 {
764 scm_i_pthread_mutex_lock (&print_state_mutex);
765 SCM_SETCDR (handle, print_state_pool);
766 print_state_pool = handle;
767 scm_i_pthread_mutex_unlock (&print_state_mutex);
768 }
769 }
770
771
772 /* Print an integer.
773 */
774
775 void
scm_intprint(scm_t_intmax n,int radix,SCM port)776 scm_intprint (scm_t_intmax n, int radix, SCM port)
777 {
778 char num_buf[SCM_INTBUFLEN];
779 scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
780 }
781
782 void
scm_uintprint(scm_t_uintmax n,int radix,SCM port)783 scm_uintprint (scm_t_uintmax n, int radix, SCM port)
784 {
785 char num_buf[SCM_INTBUFLEN];
786 scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port);
787 }
788
789 /* Print an object of unrecognized type.
790 */
791
792 void
scm_ipruk(char * hdr,SCM ptr,SCM port)793 scm_ipruk (char *hdr, SCM ptr, SCM port)
794 {
795 scm_puts ("#<unknown-", port);
796 scm_puts (hdr, port);
797 if (scm_in_heap_p (ptr))
798 {
799 scm_puts (" (0x", port);
800 scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
801 scm_puts (" . 0x", port);
802 scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
803 scm_puts (") @", port);
804 }
805 scm_puts (" 0x", port);
806 scm_uintprint (SCM_UNPACK (ptr), 16, port);
807 scm_putc ('>', port);
808 }
809
810
811 /* Print a list.
812 */
813 void
scm_iprlist(char * hdr,SCM exp,int tlr,SCM port,scm_print_state * pstate)814 scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate)
815 {
816 register SCM hare, tortoise;
817 long floor = pstate->top - 2;
818 scm_puts (hdr, port);
819 /* CHECK_INTS; */
820 if (pstate->fancyp)
821 goto fancy_printing;
822
823 /* Run a hare and tortoise so that total time complexity will be
824 O(depth * N) instead of O(N^2). */
825 hare = SCM_CDR (exp);
826 tortoise = exp;
827 while (scm_is_pair (hare))
828 {
829 if (scm_is_eq (hare, tortoise))
830 goto fancy_printing;
831 hare = SCM_CDR (hare);
832 if (!scm_is_pair (hare))
833 break;
834 hare = SCM_CDR (hare);
835 tortoise = SCM_CDR (tortoise);
836 }
837
838 /* No cdr cycles intrinsic to this list */
839 scm_iprin1 (SCM_CAR (exp), port, pstate);
840 for (exp = SCM_CDR (exp); scm_is_pair (exp); exp = SCM_CDR (exp))
841 {
842 register long i;
843
844 for (i = floor; i >= 0; --i)
845 if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
846 goto circref;
847 PUSH_REF (pstate, exp);
848 scm_putc (' ', port);
849 /* CHECK_INTS; */
850 scm_iprin1 (SCM_CAR (exp), port, pstate);
851 }
852 if (!SCM_NULL_OR_NIL_P (exp))
853 {
854 scm_puts (" . ", port);
855 scm_iprin1 (exp, port, pstate);
856 }
857
858 end:
859 scm_putc (tlr, port);
860 pstate->top = floor + 2;
861 return;
862
863 fancy_printing:
864 {
865 long n = pstate->length;
866
867 scm_iprin1 (SCM_CAR (exp), port, pstate);
868 exp = SCM_CDR (exp); --n;
869 for (; scm_is_pair (exp); exp = SCM_CDR (exp))
870 {
871 register unsigned long i;
872
873 for (i = 0; i < pstate->top; ++i)
874 if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
875 goto fancy_circref;
876 if (pstate->fancyp)
877 {
878 if (n == 0)
879 {
880 scm_puts (" ...", port);
881 goto skip_tail;
882 }
883 else
884 --n;
885 }
886 PUSH_REF(pstate, exp);
887 ++pstate->list_offset;
888 scm_putc (' ', port);
889 /* CHECK_INTS; */
890 scm_iprin1 (SCM_CAR (exp), port, pstate);
891 }
892 }
893 if (!SCM_NULL_OR_NIL_P (exp))
894 {
895 scm_puts (" . ", port);
896 scm_iprin1 (exp, port, pstate);
897 }
898 skip_tail:
899 pstate->list_offset -= pstate->top - floor - 2;
900 goto end;
901
902 fancy_circref:
903 pstate->list_offset -= pstate->top - floor - 2;
904
905 circref:
906 scm_puts (" . ", port);
907 print_circref (port, pstate, exp);
908 goto end;
909 }
910
911
912
913 int
scm_valid_oport_value_p(SCM val)914 scm_valid_oport_value_p (SCM val)
915 {
916 return (SCM_OPOUTPORTP (val)
917 || (SCM_PORT_WITH_PS_P (val)
918 && SCM_OPOUTPORTP (SCM_PORT_WITH_PS_PORT (val))));
919 }
920
921 /* SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */
922
923 SCM
scm_write(SCM obj,SCM port)924 scm_write (SCM obj, SCM port)
925 {
926 if (SCM_UNBNDP (port))
927 port = scm_current_output_port ();
928
929 SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
930
931 scm_prin1 (obj, port, 1);
932 #if 0
933 #ifdef HAVE_PIPE
934 # ifdef EPIPE
935 if (EPIPE == errno)
936 scm_close_port (port);
937 # endif
938 #endif
939 #endif
940 return SCM_UNSPECIFIED;
941 }
942
943
944 /* SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); */
945
946 SCM
scm_display(SCM obj,SCM port)947 scm_display (SCM obj, SCM port)
948 {
949 if (SCM_UNBNDP (port))
950 port = scm_current_output_port ();
951
952 SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
953
954 scm_prin1 (obj, port, 0);
955 #if 0
956 #ifdef HAVE_PIPE
957 # ifdef EPIPE
958 if (EPIPE == errno)
959 scm_close_port (port);
960 # endif
961 #endif
962 #endif
963 return SCM_UNSPECIFIED;
964 }
965
966
967 SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
968 (SCM destination, SCM message, SCM args),
969 "Write @var{message} to @var{destination}, defaulting to\n"
970 "the current output port.\n"
971 "@var{message} can contain @code{~A} (was @code{%s}) and\n"
972 "@code{~S} (was @code{%S}) escapes. When printed,\n"
973 "the escapes are replaced with corresponding members of\n"
974 "@var{ARGS}:\n"
975 "@code{~A} formats using @code{display} and @code{~S} formats\n"
976 "using @code{write}.\n"
977 "If @var{destination} is @code{#t}, then use the current output\n"
978 "port, if @var{destination} is @code{#f}, then return a string\n"
979 "containing the formatted text. Does not add a trailing newline.")
980 #define FUNC_NAME s_scm_simple_format
981 {
982 SCM port, answer = SCM_UNSPECIFIED;
983 int fReturnString = 0;
984 int writingp;
985 const char *start;
986 const char *end;
987 const char *p;
988
989 if (scm_is_eq (destination, SCM_BOOL_T))
990 {
991 destination = port = scm_current_output_port ();
992 }
993 else if (scm_is_false (destination))
994 {
995 fReturnString = 1;
996 port = scm_mkstrport (SCM_INUM0,
997 scm_make_string (SCM_INUM0, SCM_UNDEFINED),
998 SCM_OPN | SCM_WRTNG,
999 FUNC_NAME);
1000 destination = port;
1001 }
1002 else
1003 {
1004 SCM_VALIDATE_OPORT_VALUE (1, destination);
1005 port = SCM_COERCE_OUTPORT (destination);
1006 }
1007 SCM_VALIDATE_STRING (2, message);
1008 SCM_VALIDATE_REST_ARGUMENT (args);
1009
1010 start = scm_i_string_chars (message);
1011 end = start + scm_i_string_length (message);
1012 for (p = start; p != end; ++p)
1013 if (*p == '~')
1014 {
1015 if (++p == end)
1016 break;
1017
1018 switch (*p)
1019 {
1020 case 'A': case 'a':
1021 writingp = 0;
1022 break;
1023 case 'S': case 's':
1024 writingp = 1;
1025 break;
1026 case '~':
1027 scm_lfwrite (start, p - start, port);
1028 start = p + 1;
1029 continue;
1030 case '%':
1031 scm_lfwrite (start, p - start - 1, port);
1032 scm_newline (port);
1033 start = p + 1;
1034 continue;
1035 default:
1036 SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead",
1037 scm_list_1 (SCM_MAKE_CHAR (*p)));
1038
1039 }
1040
1041
1042 if (!scm_is_pair (args))
1043 SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A",
1044 scm_list_1 (SCM_MAKE_CHAR (*p)));
1045
1046 scm_lfwrite (start, p - start - 1, port);
1047 /* we pass destination here */
1048 scm_prin1 (SCM_CAR (args), destination, writingp);
1049 args = SCM_CDR (args);
1050 start = p + 1;
1051 }
1052
1053 scm_lfwrite (start, p - start, port);
1054 if (!scm_is_eq (args, SCM_EOL))
1055 SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments",
1056 scm_list_1 (scm_length (args)));
1057
1058 if (fReturnString)
1059 answer = scm_strport_to_string (destination);
1060
1061 return scm_return_first (answer, message);
1062 }
1063 #undef FUNC_NAME
1064
1065
1066 SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
1067 (SCM port),
1068 "Send a newline to @var{port}.\n"
1069 "If @var{port} is omitted, send to the current output port.")
1070 #define FUNC_NAME s_scm_newline
1071 {
1072 if (SCM_UNBNDP (port))
1073 port = scm_current_output_port ();
1074
1075 SCM_VALIDATE_OPORT_VALUE (1, port);
1076
1077 scm_putc ('\n', SCM_COERCE_OUTPORT (port));
1078 return SCM_UNSPECIFIED;
1079 }
1080 #undef FUNC_NAME
1081
1082 SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
1083 (SCM chr, SCM port),
1084 "Send character @var{chr} to @var{port}.")
1085 #define FUNC_NAME s_scm_write_char
1086 {
1087 if (SCM_UNBNDP (port))
1088 port = scm_current_output_port ();
1089
1090 SCM_VALIDATE_CHAR (1, chr);
1091 SCM_VALIDATE_OPORT_VALUE (2, port);
1092
1093 scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
1094 #if 0
1095 #ifdef HAVE_PIPE
1096 # ifdef EPIPE
1097 if (EPIPE == errno)
1098 scm_close_port (port);
1099 # endif
1100 #endif
1101 #endif
1102 return SCM_UNSPECIFIED;
1103 }
1104 #undef FUNC_NAME
1105
1106
1107
1108 /* Call back to Scheme code to do the printing of special objects
1109 * (like structs). SCM_PRINTER_APPLY applies PROC to EXP and a smob
1110 * containing PORT and PSTATE. This object can be used as the port for
1111 * display/write etc to continue the current print chain. The REVEALED
1112 * field of PSTATE is set to true to indicate that the print state has
1113 * escaped to Scheme and thus has to be freed by the GC.
1114 */
1115
1116 scm_t_bits scm_tc16_port_with_ps;
1117
1118 /* Print exactly as the port itself would */
1119
1120 static int
port_with_ps_print(SCM obj,SCM port,scm_print_state * pstate)1121 port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
1122 {
1123 obj = SCM_PORT_WITH_PS_PORT (obj);
1124 return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate);
1125 }
1126
1127 SCM
scm_printer_apply(SCM proc,SCM exp,SCM port,scm_print_state * pstate)1128 scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate)
1129 {
1130 pstate->revealed = 1;
1131 return scm_call_2 (proc, exp,
1132 scm_i_port_with_print_state (port, pstate->handle));
1133 }
1134
1135 SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 1, 1, 0,
1136 (SCM port, SCM pstate),
1137 "Create a new port which behaves like @var{port}, but with an\n"
1138 "included print state @var{pstate}. @var{pstate} is optional.\n"
1139 "If @var{pstate} isn't supplied and @var{port} already has\n"
1140 "a print state, the old print state is reused.")
1141 #define FUNC_NAME s_scm_port_with_print_state
1142 {
1143 SCM_VALIDATE_OPORT_VALUE (1, port);
1144 if (!SCM_UNBNDP (pstate))
1145 SCM_VALIDATE_PRINTSTATE (2, pstate);
1146 return scm_i_port_with_print_state (port, pstate);
1147 }
1148 #undef FUNC_NAME
1149
1150 SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0,
1151 (SCM port),
1152 "Return the print state of the port @var{port}. If @var{port}\n"
1153 "has no associated print state, @code{#f} is returned.")
1154 #define FUNC_NAME s_scm_get_print_state
1155 {
1156 if (SCM_PORT_WITH_PS_P (port))
1157 return SCM_PORT_WITH_PS_PS (port);
1158 if (SCM_OUTPUT_PORT_P (port))
1159 return SCM_BOOL_F;
1160 SCM_WRONG_TYPE_ARG (1, port);
1161 }
1162 #undef FUNC_NAME
1163
1164
1165
1166 void
scm_init_print()1167 scm_init_print ()
1168 {
1169 SCM vtable, layout, type;
1170
1171 scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
1172
1173 scm_print_options (scm_list_4 (scm_from_locale_symbol ("highlight-prefix"),
1174 scm_from_locale_string ("{"),
1175 scm_from_locale_symbol ("highlight-suffix"),
1176 scm_from_locale_string ("}")));
1177
1178 scm_gc_register_root (&print_state_pool);
1179 scm_gc_register_root (&scm_print_state_vtable);
1180 vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
1181 layout =
1182 scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT));
1183 type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout));
1184 scm_set_struct_vtable_name_x (type, scm_from_locale_symbol ("print-state"));
1185 scm_print_state_vtable = type;
1186
1187 /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */
1188 scm_tc16_port_with_ps = scm_make_smob_type (0, 0);
1189 scm_set_smob_mark (scm_tc16_port_with_ps, scm_markcdr);
1190 scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print);
1191
1192 #include "libguile/print.x"
1193
1194 scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
1195 }
1196
1197 /*
1198 Local Variables:
1199 c-file-style: "gnu"
1200 End:
1201 */
1202