X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/fcd953f6990a813a204beea6992bc4287bb94513..d8d9a8da05ec876acba81a559798eb5eeceb5a17:/libguile/print.c diff --git a/libguile/print.c b/libguile/print.c index a8f220b63..d95051183 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008, - * 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -67,6 +67,9 @@ static size_t display_string (const void *, int, size_t, SCM, scm_t_string_failed_conversion_handler); +static size_t write_string (const void *, int, size_t, SCM, + scm_t_string_failed_conversion_handler); + static int display_character (scm_t_wchar, SCM, scm_t_string_failed_conversion_handler); @@ -113,6 +116,8 @@ scm_t_option scm_print_opts[] = { "'reader' quotes them when the reader option 'keywords' is not '#f'." }, { SCM_OPTION_BOOLEAN, "escape-newlines", 1, "Render newlines as \\n when printing using `write'." }, + { SCM_OPTION_BOOLEAN, "r7rs-symbols", 0, + "Escape symbols using R7RS |...| symbol notation." }, { 0 }, }; @@ -359,6 +364,13 @@ symbol_has_extended_read_syntax (SCM sym) case '#': /* Some initial-character constraints. */ return 1; + + case '|': + case '\\': + /* R7RS allows neither '|' nor '\' in bare symbols. */ + if (SCM_PRINT_R7RS_SYMBOLS_P) + return 1; + break; case ':': /* Symbols that look like keywords. */ @@ -409,6 +421,9 @@ symbol_has_extended_read_syntax (SCM sym) return 1; else if (c == '"' || c == ';' || c == '#') return 1; + else if ((c == '|' || c == '\\') && SCM_PRINT_R7RS_SYMBOLS_P) + /* R7RS allows neither '|' nor '\' in bare symbols. */ + return 1; } return 0; @@ -456,23 +471,76 @@ print_extended_symbol (SCM sym, SCM port) } else { - display_string ("\\x", 1, 2, port, iconveh_question_mark); + scm_lfwrite_unlocked ("\\x", 2, port); scm_intprint (c, 16, port); - display_character (';', port, iconveh_question_mark); + scm_putc_unlocked (';', port); } } scm_lfwrite_unlocked ("}#", 2, port); } -/* FIXME: allow R6RS hex escapes instead of #{...}#. */ +static void +print_r7rs_extended_symbol (SCM sym, SCM port) +{ + size_t pos, len; + scm_t_string_failed_conversion_handler strategy; + + len = scm_i_symbol_length (sym); + strategy = PORT_CONVERSION_HANDLER (port); + + scm_putc_unlocked ('|', port); + + for (pos = 0; pos < len; pos++) + { + scm_t_wchar c = scm_i_symbol_ref (sym, pos); + + switch (c) + { + case '\a': scm_lfwrite_unlocked ("\\a", 2, port); break; + case '\b': scm_lfwrite_unlocked ("\\b", 2, port); break; + case '\t': scm_lfwrite_unlocked ("\\t", 2, port); break; + case '\n': scm_lfwrite_unlocked ("\\n", 2, port); break; + case '\r': scm_lfwrite_unlocked ("\\r", 2, port); break; + case '|': scm_lfwrite_unlocked ("\\|", 2, port); break; + case '\\': scm_lfwrite_unlocked ("\\x5c;", 5, port); break; + default: + if (uc_is_general_category_withtable (c, + UC_CATEGORY_MASK_L + | UC_CATEGORY_MASK_M + | UC_CATEGORY_MASK_N + | UC_CATEGORY_MASK_P + | UC_CATEGORY_MASK_S) + || (c == ' ')) + { + if (!display_character (c, port, strategy)) + scm_encoding_error ("print_r7rs_extended_symbol", errno, + "cannot convert to output locale", + port, SCM_MAKE_CHAR (c)); + } + else + { + scm_lfwrite_unlocked ("\\x", 2, port); + scm_intprint (c, 16, port); + scm_putc_unlocked (';', port); + } + break; + } + } + + scm_putc_unlocked ('|', port); +} + +/* FIXME: allow R6RS hex escapes instead of #{...}# or |...|. */ static void print_symbol (SCM sym, SCM port) { - if (symbol_has_extended_read_syntax (sym)) - print_extended_symbol (sym, port); - else + if (!symbol_has_extended_read_syntax (sym)) print_normal_symbol (sym, port); + else if (SCM_PRINT_R7RS_SYMBOLS_P) + print_r7rs_extended_symbol (sym, port); + else + print_extended_symbol (sym, port); } void @@ -519,6 +587,33 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) iprin1 (exp, port, pstate); } +static void +print_vector_or_weak_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t), + SCM port, scm_print_state *pstate) +{ + long i; + long last = len - 1; + int cutp = 0; + if (pstate->fancyp && len > pstate->length) + { + last = pstate->length - 1; + cutp = 1; + } + for (i = 0; i < last; ++i) + { + scm_iprin1 (ref (v, i), port, pstate); + scm_putc_unlocked (' ', port); + } + if (i == last) + { + /* CHECK_INTS; */ + scm_iprin1 (ref (v, i), port, pstate); + } + if (cutp) + scm_puts_unlocked (" ...", port); + scm_putc_unlocked (')', port); +} + static void iprin1 (SCM exp, SCM port, scm_print_state *pstate) { @@ -613,32 +708,29 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_i_print_stringbuf (exp, port, pstate); break; case scm_tc7_string: - if (SCM_WRITINGP (pstate)) - { - size_t len, i; - - display_character ('"', port, iconveh_question_mark); - len = scm_i_string_length (exp); - for (i = 0; i < len; ++i) - write_character (scm_i_string_ref (exp, i), port, 1); - - display_character ('"', port, iconveh_question_mark); - scm_remember_upto_here_1 (exp); - } - else - { - size_t len, printed; + { + size_t len, printed; - len = scm_i_string_length (exp); + len = scm_i_string_length (exp); + if (SCM_WRITINGP (pstate)) + { + printed = write_string (scm_i_string_data (exp), + scm_i_is_narrow_string (exp), + len, port, + PORT_CONVERSION_HANDLER (port)); + len += 2; /* account for the quotes */ + } + else printed = display_string (scm_i_string_data (exp), scm_i_is_narrow_string (exp), len, port, PORT_CONVERSION_HANDLER (port)); - if (SCM_UNLIKELY (printed < len)) - scm_encoding_error (__func__, errno, - "cannot convert to output locale", - port, scm_c_string_ref (exp, printed)); - } + + if (SCM_UNLIKELY (printed < len)) + scm_encoding_error (__func__, errno, + "cannot convert to output locale", + port, scm_c_string_ref (exp, printed)); + } scm_remember_upto_here_1 (exp); break; @@ -684,6 +776,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_frame: scm_i_frame_print (exp, port, pstate); break; + case scm_tc7_keyword: + scm_puts_unlocked ("#:", port); + scm_iprin1 (scm_keyword_to_symbol (exp), port, pstate); + break; case scm_tc7_vm_cont: scm_i_vm_cont_print (exp, port, pstate); break; @@ -701,35 +797,15 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_wvect: ENTER_NESTED_DATA (pstate, exp, circref); scm_puts_unlocked ("#w(", port); - goto common_vector_printer; + print_vector_or_weak_vector (exp, scm_c_weak_vector_length (exp), + scm_c_weak_vector_ref, port, pstate); + EXIT_NESTED_DATA (pstate); + break; case scm_tc7_vector: ENTER_NESTED_DATA (pstate, exp, circref); scm_puts_unlocked ("#(", port); - common_vector_printer: - { - register long i; - long last = SCM_SIMPLE_VECTOR_LENGTH (exp) - 1; - int cutp = 0; - if (pstate->fancyp - && SCM_SIMPLE_VECTOR_LENGTH (exp) > pstate->length) - { - last = pstate->length - 1; - cutp = 1; - } - 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_unlocked (" ...", port); - scm_putc_unlocked (')', port); - } + print_vector_or_weak_vector (exp, SCM_SIMPLE_VECTOR_LENGTH (exp), + scm_c_vector_ref, port, pstate); EXIT_NESTED_DATA (pstate); break; case scm_tc7_port: @@ -1049,8 +1125,6 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, return printed; } -#undef STR_REF - /* Display the LEN codepoints in STR to PORT according to STRATEGY; return the number of codepoints successfully displayed. If NARROW_P, then STR is interpreted as a sequence of `char', denoting a Latin-1 @@ -1073,8 +1147,8 @@ display_string (const void *str, int narrow_p, return display_string_using_iconv (str, narrow_p, len, port, strategy); } -/* Attempt to display CH to PORT according to STRATEGY. Return non-zero - if CH was successfully displayed, zero otherwise (e.g., if it was not +/* Attempt to display CH to PORT according to STRATEGY. Return one if + CH was successfully displayed, zero otherwise (e.g., if it was not representable in PORT's encoding.) */ static int display_character (scm_t_wchar ch, SCM port, @@ -1083,6 +1157,34 @@ display_character (scm_t_wchar ch, SCM port, return display_string (&ch, 0, 1, port, strategy) == 1; } +/* Same as 'display_string', but using the 'write' syntax. */ +static size_t +write_string (const void *str, int narrow_p, + size_t len, SCM port, + scm_t_string_failed_conversion_handler strategy) +{ + size_t printed; + + printed = display_character ('"', port, strategy); + + if (printed > 0) + { + size_t i; + + for (i = 0; i < len; ++i) + { + write_character (STR_REF (str, i), port, 1); + printed++; + } + + printed += display_character ('"', port, strategy); + } + + return printed; +} + +#undef STR_REF + /* Attempt to pretty-print CH, a combining character, to PORT. Return zero upon failure, non-zero otherwise. The idea is to print CH above a dotted circle to make it more visible. */ @@ -1477,6 +1579,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, if (scm_is_eq (destination, SCM_BOOL_T)) { destination = port = scm_current_output_port (); + SCM_VALIDATE_OPORT_VALUE (1, destination); } else if (scm_is_false (destination)) {