diff options
Diffstat (limited to 'libguile/print.c')
-rw-r--r-- | libguile/print.c | 302 |
1 files changed, 184 insertions, 118 deletions
diff --git a/libguile/print.c b/libguile/print.c index 2fc536b02..90bc9adf8 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" @@ -161,7 +160,7 @@ do \ { \ if (pstate->top - pstate->list_offset >= pstate->level) \ { \ - scm_putc ('#', port); \ + scm_putc_unlocked ('#', port); \ return; \ } \ } \ @@ -305,9 +304,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. */ @@ -336,6 +335,7 @@ quote_keywordish_symbols (void) (INITIAL_IDENTIFIER_MASK \ | UC_CATEGORY_MASK_Nd | UC_CATEGORY_MASK_Mc | UC_CATEGORY_MASK_Me) +/* FIXME: Cache this information on the symbol, somehow. */ static int symbol_has_extended_read_syntax (SCM sym) { @@ -348,26 +348,56 @@ symbol_has_extended_read_syntax (SCM sym) c = scm_i_symbol_ref (sym, 0); - /* Single dot; conflicts with dotted-pair notation. */ - if (len == 1 && c == '.') - return 1; - - /* Other initial-character constraints. */ - if (c == '\'' || c == '`' || c == ',' || c == '"' || c == ';' || c == '#') - return 1; + switch (c) + { + case '\'': + case '`': + case ',': + case '"': + case ';': + case '#': + /* Some initial-character constraints. */ + return 1; - /* Keywords can be identified by trailing colons too. */ - if (c == ':' || scm_i_symbol_ref (sym, len - 1) == ':') - return quote_keywordish_symbols (); + case ':': + /* Symbols that look like keywords. */ + return quote_keywordish_symbols (); - /* Number-ish symbols. */ - if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10))) - return 1; + case '.': + /* Single dot conflicts with dotted-pair notation. */ + if (len == 1) + return 1; + /* Fall through to check numbers. */ + case '+': + case '-': + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + /* Number-ish symbols. Numbers with radixes already caught be # + above. */ + if (scm_is_true (scm_i_string_to_number (scm_symbol_to_string (sym), 10))) + return 1; + break; + + default: + break; + } /* Other disallowed first characters. */ if (!uc_is_general_category_withtable (c, INITIAL_IDENTIFIER_MASK)) return 1; + /* Keywords can be identified by trailing colons too. */ + if (scm_i_symbol_ref (sym, len - 1) == ':') + return quote_keywordish_symbols (); + /* Otherwise, any character that's in the identifier category mask is fine to pass through as-is, provided it's not one of the ASCII delimiters like `;'. */ @@ -386,7 +416,16 @@ symbol_has_extended_read_syntax (SCM sym) static void print_normal_symbol (SCM sym, SCM port) { - scm_display (scm_symbol_to_string (sym), port); + size_t len; + scm_t_string_failed_conversion_handler strategy; + + len = scm_i_symbol_length (sym); + strategy = SCM_PTAB_ENTRY (port)->ilseq_handler; + + if (scm_i_is_narrow_symbol (sym)) + display_string (scm_i_symbol_chars (sym), 1, len, port, strategy); + else + display_string (scm_i_symbol_wide_chars (sym), 0, len, port, strategy); } static void @@ -398,7 +437,7 @@ print_extended_symbol (SCM sym, SCM port) len = scm_i_symbol_length (sym); strategy = PORT_CONVERSION_HANDLER (port); - scm_lfwrite ("#{", 2, port); + scm_lfwrite_unlocked ("#{", 2, port); for (pos = 0; pos < len; pos++) { @@ -421,12 +460,12 @@ print_extended_symbol (SCM sym, SCM port) } } - scm_lfwrite ("}#", 2, port); + scm_lfwrite_unlocked ("}#", 2, port); } /* FIXME: allow R6RS hex escapes instead of #{...}#. */ -void -scm_i_print_symbol_name (SCM sym, SCM port) +static void +print_symbol (SCM sym, SCM port) { if (symbol_has_extended_read_syntax (sym)) print_extended_symbol (sym, port); @@ -437,8 +476,8 @@ 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_i_print_symbol_name (symbol, port); + SCM symbol = scm_from_utf8_symboln (str, len); + print_symbol (symbol, port); } /* Print generally. Handles both write and display according to PSTATE. @@ -457,7 +496,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); \ } \ } \ @@ -512,7 +551,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 { @@ -533,7 +572,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 { @@ -601,16 +640,16 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_symbol: if (scm_i_symbol_is_interned (exp)) { - scm_i_print_symbol_name (exp, port); + print_symbol (exp, port); scm_remember_upto_here_1 (exp); } else { - scm_puts ("#<uninterned-symbol ", port); - scm_i_print_symbol_name (exp, port); - scm_putc (' ', port); + scm_puts_unlocked ("#<uninterned-symbol ", port); + print_symbol (exp, port); + scm_putc_unlocked (' ', port); scm_uintprint (SCM_UNPACK (exp), 16, port); - scm_putc ('>', port); + scm_putc_unlocked ('>', port); } break; case scm_tc7_variable: @@ -625,6 +664,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; @@ -643,12 +688,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_vm_cont: scm_i_vm_cont_print (exp, port, pstate); break; - case scm_tc7_prompt: - scm_i_prompt_print (exp, port, pstate); - break; - case scm_tc7_with_fluids: - scm_i_with_fluids_print (exp, port, pstate); - break; case scm_tc7_array: ENTER_NESTED_DATA (pstate, exp, circref); scm_i_print_array (exp, port, pstate); @@ -662,14 +701,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; @@ -681,43 +717,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; } @@ -862,7 +881,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; } @@ -871,6 +890,54 @@ display_string_as_utf8 (const void *str, int narrow_p, size_t len, return len; } +/* Write STR to PORT as ISO-8859-1. STR is a LEN-codepoint string; it + is narrow if NARROW_P is true, wide otherwise. Return LEN. */ +static size_t +display_string_as_latin1 (const void *str, int narrow_p, size_t len, + SCM port, + scm_t_string_failed_conversion_handler strategy) +{ + size_t printed = 0; + + if (narrow_p) + { + scm_lfwrite_unlocked (str, len, port); + return len; + } + + while (printed < len) + { + char buf[256]; + size_t i; + + for (i = 0; i < sizeof(buf) && printed < len; i++, printed++) + { + scm_t_wchar c = STR_REF (str, printed); + + if (c < 256) + buf[i] = c; + else + break; + } + + scm_lfwrite_unlocked (buf, i, port); + + if (i < sizeof(buf) && printed < len) + { + if (strategy == SCM_FAILED_CONVERSION_ERROR) + break; + else if (strategy == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE) + write_character_escaped (STR_REF (str, printed), 1, port); + else + /* STRATEGY is `SCM_FAILED_CONVERSION_QUESTION_MARK'. */ + display_string ("?", 1, 1, port, strategy); + printed++; + } + } + + return printed; +} + /* Convert STR through PORT's output conversion descriptor and write the output to PORT. Return the number of codepoints written. */ static size_t @@ -879,9 +946,9 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, scm_t_string_failed_conversion_handler strategy) { size_t printed; - scm_t_port *pt; + scm_t_iconv_descriptors *id; - pt = SCM_PTAB_ENTRY (port); + id = scm_i_port_iconv_descriptors (port); printed = 0; @@ -910,7 +977,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, output = encoded_output; output_left = sizeof (encoded_output); - done = iconv (pt->output_cd, &input, &input_left, + done = iconv (id->output_cd, &input, &input_left, &output, &output_left); output_len = sizeof (encoded_output) - output_left; @@ -920,10 +987,10 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, int errno_save = errno; /* Reset the `iconv' state. */ - iconv (pt->output_cd, NULL, NULL, NULL, NULL); + iconv (id->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. */ @@ -958,7 +1025,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; } @@ -978,22 +1045,17 @@ static size_t display_string (const void *str, int narrow_p, size_t len, SCM port, scm_t_string_failed_conversion_handler strategy) - { scm_t_port *pt; pt = SCM_PTAB_ENTRY (port); - if (pt->output_cd == (iconv_t) -1) - /* Initialize the conversion descriptors, if needed. */ - scm_i_set_port_encoding_x (port, pt->encoding); - - /* FIXME: In 2.1, add a flag to determine whether a port is UTF-8. */ - if (pt->output_cd == (iconv_t) -1) + if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8) return display_string_as_utf8 (str, narrow_p, len, port); + else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) + return display_string_as_latin1 (str, narrow_p, len, port, strategy); else - return display_string_using_iconv (str, narrow_p, len, - port, strategy); + return display_string_using_iconv (str, narrow_p, len, port, strategy); } /* Attempt to display CH to PORT according to STRATEGY. Return non-zero @@ -1038,7 +1100,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) { @@ -1048,7 +1110,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) { @@ -1058,7 +1120,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) { @@ -1070,7 +1132,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 @@ -1093,7 +1155,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 @@ -1103,7 +1165,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); } @@ -1174,14 +1236,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. @@ -1190,19 +1252,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); } @@ -1213,7 +1275,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; @@ -1243,18 +1305,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; @@ -1275,7 +1337,7 @@ fancy_printing: { if (n == 0) { - scm_puts (" ...", port); + scm_puts_unlocked (" ...", port); goto skip_tail; } else @@ -1283,14 +1345,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: @@ -1301,7 +1363,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; } @@ -1326,7 +1388,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; } @@ -1341,7 +1407,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; } @@ -1454,7 +1524,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 @@ -1499,7 +1569,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 @@ -1544,14 +1614,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; |