/* 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
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);
"'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 },
};
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. */
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;
}
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
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)
{
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;
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;
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:
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
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,
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. */
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))
{
HCoop / bpt / guile.git / blobdiff