diff options
Diffstat (limited to 'libguile/print.c')
-rw-r--r-- | libguile/print.c | 149 |
1 files changed, 69 insertions, 80 deletions
diff --git a/libguile/print.c b/libguile/print.c index f144a6491..a1c36eb94 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -40,7 +40,6 @@ #include "libguile/macros.h" #include "libguile/procprop.h" #include "libguile/read.h" -#include "libguile/weaks.h" #include "libguile/programs.h" #include "libguile/alist.h" #include "libguile/struct.h" @@ -158,7 +157,7 @@ do \ { \ if (pstate->top - pstate->list_offset >= pstate->level) \ { \ - scm_putc ('#', port); \ + scm_putc_unlocked ('#', port); \ return; \ } \ } \ @@ -302,9 +301,9 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref) for (i = pstate->top - 1; 1; --i) if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref)) break; - scm_putc ('#', port); + scm_putc_unlocked ('#', port); scm_intprint (i - self, 10, port); - scm_putc ('#', port); + scm_putc_unlocked ('#', port); } /* Print the name of a symbol. */ @@ -395,7 +394,7 @@ print_extended_symbol (SCM sym, SCM port) len = scm_i_symbol_length (sym); strategy = scm_i_get_conversion_strategy (port); - scm_lfwrite ("#{", 2, port); + scm_lfwrite_unlocked ("#{", 2, port); for (pos = 0; pos < len; pos++) { @@ -418,7 +417,7 @@ print_extended_symbol (SCM sym, SCM port) } } - scm_lfwrite ("}#", 2, port); + scm_lfwrite_unlocked ("}#", 2, port); } /* FIXME: allow R6RS hex escapes instead of #{...}#. */ @@ -434,7 +433,7 @@ scm_i_print_symbol_name (SCM sym, SCM port) void scm_print_symbol_name (const char *str, size_t len, SCM port) { - SCM symbol = scm_from_locale_symboln (str, len); + SCM symbol = scm_from_utf8_symboln (str, len); scm_i_print_symbol_name (symbol, port); } @@ -454,7 +453,7 @@ static void iprin1 (SCM exp, SCM port, scm_print_state *pstate); scm_intprint (i, 8, port); \ else \ { \ - scm_puts ("x", port); \ + scm_puts_unlocked ("x", port); \ scm_intprint (i, 16, port); \ } \ } \ @@ -509,7 +508,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) else if (SCM_IFLAGP (exp) && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *)))) { - scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port); + scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port); } else { @@ -530,7 +529,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) goto print_struct; pwps = scm_i_port_with_print_state (port, pstate->handle); pstate->revealed = 1; - scm_call_generic_2 (print, exp, pwps); + scm_call_2 (print, exp, pwps); } else { @@ -603,11 +602,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) } else { - scm_puts ("#<uninterned-symbol ", port); + scm_puts_unlocked ("#<uninterned-symbol ", port); scm_i_print_symbol_name (exp, port); - scm_putc (' ', port); + scm_putc_unlocked (' ', port); scm_uintprint (SCM_UNPACK (exp), 16, port); - scm_putc ('>', port); + scm_putc_unlocked ('>', port); } break; case scm_tc7_variable: @@ -622,6 +621,12 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_hashtable: scm_i_hashtable_print (exp, port, pstate); break; + case scm_tc7_weak_set: + scm_i_weak_set_print (exp, port, pstate); + break; + case scm_tc7_weak_table: + scm_i_weak_table_print (exp, port, pstate); + break; case scm_tc7_fluid: scm_i_fluid_print (exp, port, pstate); break; @@ -658,14 +663,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; case scm_tc7_wvect: ENTER_NESTED_DATA (pstate, exp, circref); - if (SCM_IS_WHVEC (exp)) - scm_puts ("#wh(", port); - else - scm_puts ("#w(", port); + scm_puts_unlocked ("#w(", port); goto common_vector_printer; case scm_tc7_vector: ENTER_NESTED_DATA (pstate, exp, circref); - scm_puts ("#(", port); + scm_puts_unlocked ("#(", port); common_vector_printer: { register long i; @@ -677,43 +679,26 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) last = pstate->length - 1; cutp = 1; } - if (SCM_I_WVECTP (exp)) - { - /* Elements of weak vectors may not be accessed via the - `SIMPLE_VECTOR_REF ()' macro. */ - for (i = 0; i < last; ++i) - { - scm_iprin1 (scm_c_vector_ref (exp, i), - port, pstate); - scm_putc (' ', port); - } - } - else - { - for (i = 0; i < last; ++i) - { - scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate); - scm_putc (' ', port); - } - } - + for (i = 0; i < last; ++i) + { + scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate); + scm_putc_unlocked (' ', port); + } if (i == last) { /* CHECK_INTS; */ scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate); } if (cutp) - scm_puts (" ...", port); - scm_putc (')', port); + scm_puts_unlocked (" ...", port); + scm_putc_unlocked (')', port); } EXIT_NESTED_DATA (pstate); break; case scm_tc7_port: { - register long i = SCM_PTOBNUM (exp); - if (i < scm_numptob - && scm_ptobs[i].print - && (scm_ptobs[i].print) (exp, port, pstate)) + scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (exp); + if (ptob->print && ptob->print (exp, port, pstate)) break; goto punk; } @@ -858,7 +843,7 @@ display_string_as_utf8 (const void *str, int narrow_p, size_t len, /* INPUT was successfully converted, entirely; print the result. */ - scm_lfwrite (utf8_buf, utf8_len, port); + scm_lfwrite_unlocked (utf8_buf, utf8_len, port); printed += i - printed; } @@ -919,7 +904,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, iconv (pt->output_cd, NULL, NULL, NULL, NULL); /* Print the OUTPUT_LEN bytes successfully converted. */ - scm_lfwrite (encoded_output, output_len, port); + scm_lfwrite_unlocked (encoded_output, output_len, port); /* See how many input codepoints these OUTPUT_LEN bytes corresponds to. */ @@ -954,7 +939,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, { /* INPUT was successfully converted, entirely; print the result. */ - scm_lfwrite (encoded_output, output_len, port); + scm_lfwrite_unlocked (encoded_output, output_len, port); codepoints_read = i - printed; printed += codepoints_read; } @@ -1034,7 +1019,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) /* Use special escapes for some C0 controls. */ buf[0] = '\\'; buf[1] = escapes[ch - 0x07]; - scm_lfwrite (buf, 2, port); + scm_lfwrite_unlocked (buf, 2, port); } else if (!SCM_R6RS_ESCAPES_P) { @@ -1044,7 +1029,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) buf[1] = 'x'; buf[2] = hex[ch / 16]; buf[3] = hex[ch % 16]; - scm_lfwrite (buf, 4, port); + scm_lfwrite_unlocked (buf, 4, port); } else if (ch <= 0xFFFF) { @@ -1054,7 +1039,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) buf[3] = hex[(ch & 0xF00) >> 8]; buf[4] = hex[(ch & 0xF0) >> 4]; buf[5] = hex[(ch & 0xF)]; - scm_lfwrite (buf, 6, port); + scm_lfwrite_unlocked (buf, 6, port); } else if (ch > 0xFFFF) { @@ -1066,7 +1051,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) buf[5] = hex[(ch & 0xF00) >> 8]; buf[6] = hex[(ch & 0xF0) >> 4]; buf[7] = hex[(ch & 0xF)]; - scm_lfwrite (buf, 8, port); + scm_lfwrite_unlocked (buf, 8, port); } } else @@ -1089,7 +1074,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) buf[i] = 'x'; i --; buf[i] = '\\'; - scm_lfwrite (buf + i, 9 - i, port); + scm_lfwrite_unlocked (buf + i, 9 - i, port); } } else @@ -1099,7 +1084,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) name = scm_i_charname (SCM_MAKE_CHAR (ch)); if (name != NULL) - scm_puts (name, port); + scm_puts_unlocked (name, port); else PRINT_CHAR_ESCAPE (ch, port); } @@ -1170,14 +1155,14 @@ void scm_intprint (scm_t_intmax n, int radix, SCM port) { char num_buf[SCM_INTBUFLEN]; - scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port); + scm_lfwrite_unlocked (num_buf, scm_iint2str (n, radix, num_buf), port); } void scm_uintprint (scm_t_uintmax n, int radix, SCM port) { char num_buf[SCM_INTBUFLEN]; - scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port); + scm_lfwrite_unlocked (num_buf, scm_iuint2str (n, radix, num_buf), port); } /* Print an object of unrecognized type. @@ -1186,19 +1171,19 @@ scm_uintprint (scm_t_uintmax n, int radix, SCM port) void scm_ipruk (char *hdr, SCM ptr, SCM port) { - scm_puts ("#<unknown-", port); - scm_puts (hdr, port); + scm_puts_unlocked ("#<unknown-", port); + scm_puts_unlocked (hdr, port); if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */ { - scm_puts (" (0x", port); + scm_puts_unlocked (" (0x", port); scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port); - scm_puts (" . 0x", port); + scm_puts_unlocked (" . 0x", port); scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port); - scm_puts (") @", port); + scm_puts_unlocked (") @", port); } - scm_puts (" 0x", port); + scm_puts_unlocked (" 0x", port); scm_uintprint (SCM_UNPACK (ptr), 16, port); - scm_putc ('>', port); + scm_putc_unlocked ('>', port); } @@ -1209,7 +1194,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) { register SCM hare, tortoise; long floor = pstate->top - 2; - scm_puts (hdr, port); + scm_puts_unlocked (hdr, port); /* CHECK_INTS; */ if (pstate->fancyp) goto fancy_printing; @@ -1239,18 +1224,18 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp)) goto circref; PUSH_REF (pstate, exp); - scm_putc (' ', port); + scm_putc_unlocked (' ', port); /* CHECK_INTS; */ scm_iprin1 (SCM_CAR (exp), port, pstate); } if (!SCM_NULL_OR_NIL_P (exp)) { - scm_puts (" . ", port); + scm_puts_unlocked (" . ", port); scm_iprin1 (exp, port, pstate); } end: - scm_putc (tlr, port); + scm_putc_unlocked (tlr, port); pstate->top = floor + 2; return; @@ -1271,7 +1256,7 @@ fancy_printing: { if (n == 0) { - scm_puts (" ...", port); + scm_puts_unlocked (" ...", port); goto skip_tail; } else @@ -1279,14 +1264,14 @@ fancy_printing: } PUSH_REF(pstate, exp); ++pstate->list_offset; - scm_putc (' ', port); + scm_putc_unlocked (' ', port); /* CHECK_INTS; */ scm_iprin1 (SCM_CAR (exp), port, pstate); } } if (!SCM_NULL_OR_NIL_P (exp)) { - scm_puts (" . ", port); + scm_puts_unlocked (" . ", port); scm_iprin1 (exp, port, pstate); } skip_tail: @@ -1297,7 +1282,7 @@ fancy_circref: pstate->list_offset -= pstate->top - floor - 2; circref: - scm_puts (" . ", port); + scm_puts_unlocked (" . ", port); print_circref (port, pstate, exp); goto end; } @@ -1322,7 +1307,11 @@ scm_write (SCM obj, SCM port) SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write); + scm_dynwind_begin (0); + scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port)); scm_prin1 (obj, port, 1); + scm_dynwind_end (); + return SCM_UNSPECIFIED; } @@ -1337,7 +1326,11 @@ scm_display (SCM obj, SCM port) SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display); + scm_dynwind_begin (0); + scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port)); scm_prin1 (obj, port, 0); + scm_dynwind_end (); + return SCM_UNSPECIFIED; } @@ -1450,7 +1443,7 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0, SCM_VALIDATE_OPORT_VALUE (1, port); - scm_putc ('\n', SCM_COERCE_OUTPORT (port)); + scm_putc_unlocked ('\n', SCM_COERCE_OUTPORT (port)); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1495,7 +1488,7 @@ static int port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate) { obj = SCM_PORT_WITH_PS_PORT (obj); - return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate); + return SCM_PORT_DESCRIPTOR (obj)->print (obj, port, pstate); } SCM @@ -1540,14 +1533,10 @@ SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0, void scm_init_print () { - SCM vtable, layout, type; - - scm_gc_register_root (&print_state_pool); - scm_gc_register_root (&scm_print_state_vtable); - vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); - layout = - scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT)); - type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout)); + SCM type; + + type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT), + SCM_BOOL_F); scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state")); scm_print_state_vtable = type; |