diff options
-rw-r--r-- | doc/ref/api-data.texi | 10 | ||||
-rw-r--r-- | doc/ref/api-evaluation.texi | 10 | ||||
-rw-r--r-- | doc/ref/srfi-modules.texi | 9 | ||||
-rw-r--r-- | libguile/print.c | 75 | ||||
-rw-r--r-- | libguile/private-options.h | 8 | ||||
-rw-r--r-- | libguile/read.c | 40 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 1 | ||||
-rw-r--r-- | test-suite/tests/print.test | 56 | ||||
-rw-r--r-- | test-suite/tests/reader.test | 5 |
9 files changed, 195 insertions, 19 deletions
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 1a3d2e873..c73a703d5 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -5588,6 +5588,16 @@ Although Guile provides this extended read syntax for symbols, widespread usage of it is discouraged because it is not portable and not very readable. +Alternatively, if you enable the @code{r7rs-symbols} read option (see +@pxref{Scheme Read}), you can write arbitrary symbols using the same +notation used for strings, except delimited by vertical bars instead of +double quotes. + +@example +|foo bar| +|\x3BB; is a greek lambda| +|\| is a vertical bar| +@end example @node Symbol Uninterned @subsubsection Uninterned Symbols diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 1810fe854..aa3729c1f 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2012, 2013 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2009, +@c 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Read/Load/Eval/Compile @@ -340,6 +340,7 @@ square-brackets yes Treat `[' and `]' as parentheses, for R6RS compatibility hungry-eol-escapes no In strings, consume leading whitespace after an escaped end-of-line. curly-infix no Support SRFI-105 curly infix expressions. +r7rs-symbols no Support R7RS |...| symbol notation. @end smalllisp Note that Guile also includes a preliminary mechanism for setting read @@ -377,6 +378,9 @@ For example, to make @code{read} fold all symbols to their lower case For more information on the effect of the @code{r6rs-hex-escapes} and @code{hungry-eol-escapes} options, see (@pxref{String Syntax}). +For more information on the @code{r7rs-symbols} option, see +(@pxref{Symbol Read Syntax}). + @node Scheme Write @subsection Writing Scheme Values @@ -436,6 +440,8 @@ quote-keywordish-symbols reader How to print symbols that have a colon not '#f'. escape-newlines yes Render newlines as \n when printing using `write'. +r7rs-symbols no Escape symbols using R7RS |...| symbol + notation. @end smalllisp These options may be modified with the print-set! syntax. diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 3b73c083e..0eb20d9ae 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -51,6 +51,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-55:: Requiring Features. * SRFI-60:: Integers as bits. * SRFI-61:: A more general `cond' clause +* SRFI-62:: S-expression comments. * SRFI-67:: Compare procedures * SRFI-69:: Basic hash tables. * SRFI-88:: Keyword objects. @@ -155,6 +156,7 @@ srfi-30 srfi-39 srfi-55 srfi-61 +srfi-62 srfi-105 @end example @@ -4829,6 +4831,13 @@ success. SRFI 61 is implemented in the Guile core; there's no module needed to get SRFI-61 itself. Extended @code{cond} is documented in @ref{Conditionals,, Simple Conditional Evaluation}. +@node SRFI-62 +@subsection SRFI-62 - S-expression comments. +@cindex SRFI-62 + +Starting from version 2.0, Guile's @code{read} supports SRFI-62/R7RS +S-expression comments by default. + @node SRFI-67 @subsection SRFI-67 - Compare procedures @cindex SRFI-67 diff --git a/libguile/print.c b/libguile/print.c index a8f220b63..4fe9b7770 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 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 @@ -113,6 +113,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 +361,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 +418,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 +468,72 @@ 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, + SUBSEQUENT_IDENTIFIER_MASK + | UC_CATEGORY_MASK_Zs)) + { + 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 diff --git a/libguile/private-options.h b/libguile/private-options.h index 4f580a640..a3a0c2b94 100644 --- a/libguile/private-options.h +++ b/libguile/private-options.h @@ -4,7 +4,7 @@ * We put this in a private header, since layout of data structures * is an implementation detail that we want to hide. * - * Copyright (C) 2007, 2009, 2010, 2011 Free Software Foundation, Inc. + * Copyright (C) 2007, 2009, 2010, 2011, 2014 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 @@ -52,7 +52,8 @@ SCM_INTERNAL scm_t_option scm_print_opts[]; #define SCM_PRINT_KEYWORD_STYLE_I 2 #define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[2].val)) #define SCM_PRINT_ESCAPE_NEWLINES_P scm_print_opts[3].val -#define SCM_N_PRINT_OPTIONS 4 +#define SCM_PRINT_R7RS_SYMBOLS_P scm_print_opts[4].val +#define SCM_N_PRINT_OPTIONS 5 /* @@ -68,7 +69,8 @@ SCM_INTERNAL scm_t_option scm_read_opts[]; #define SCM_SQUARE_BRACKETS_P scm_read_opts[5].val #define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[6].val #define SCM_CURLY_INFIX_P scm_read_opts[7].val +#define SCM_R7RS_SYMBOLS_P scm_read_opts[8].val -#define SCM_N_READ_OPTIONS 8 +#define SCM_N_READ_OPTIONS 9 #endif /* PRIVATE_OPTIONS */ diff --git a/libguile/read.c b/libguile/read.c index b3e6eebb4..980769b5c 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -88,6 +88,8 @@ scm_t_option scm_read_opts[] = "In strings, consume leading whitespace after an escaped end-of-line."}, { SCM_OPTION_BOOLEAN, "curly-infix", 0, "Support SRFI-105 curly infix expressions."}, + { SCM_OPTION_BOOLEAN, "r7rs-symbols", 0, + "Support R7RS |...| symbol notation."}, { 0, }, }; @@ -113,6 +115,7 @@ struct t_read_opts unsigned int hungry_eol_escapes_p : 1; unsigned int curly_infix_p : 1; unsigned int neoteric_p : 1; + unsigned int r7rs_symbols_p : 1; }; typedef struct t_read_opts scm_t_read_opts; @@ -588,8 +591,11 @@ skip_intraline_whitespace (SCM port) scm_ungetc_unlocked (c, port); } +/* Read either a double-quoted string or an R7RS-style symbol delimited + by vertical lines, depending on the value of 'chr' ('"' or '|'). + Regardless, the result is always returned as a string. */ static SCM -scm_read_string (int chr, SCM port, scm_t_read_opts *opts) +scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) #define FUNC_NAME "scm_lreadr" { /* For strings smaller than C_STR, this function creates only one Scheme @@ -603,13 +609,16 @@ scm_read_string (int chr, SCM port, scm_t_read_opts *opts) long line = SCM_LINUM (port); int column = SCM_COL (port) - 1; - while ('"' != (c = scm_getc_unlocked (port))) + while (chr != (c = scm_getc_unlocked (port))) { if (c == EOF) { str_eof: scm_i_input_error (FUNC_NAME, port, - "end of file in string constant", SCM_EOL); + (chr == '|' + ? "end of file in symbol" + : "end of file in string constant"), + SCM_EOL); } if (c_str_len + 1 >= READER_STRING_BUFFER_SIZE) @@ -624,7 +633,6 @@ scm_read_string (int chr, SCM port, scm_t_read_opts *opts) { case EOF: goto str_eof; - case '"': case '|': case '\\': break; @@ -657,7 +665,7 @@ scm_read_string (int chr, SCM port, scm_t_read_opts *opts) c = '\010'; break; case 'x': - if (opts->r6rs_escapes_p) + if (opts->r6rs_escapes_p || chr == '|') SCM_READ_HEX_ESCAPE (10, ';'); else SCM_READ_HEX_ESCAPE (2, '\0'); @@ -675,6 +683,8 @@ scm_read_string (int chr, SCM port, scm_t_read_opts *opts) break; } default: + if (c == chr) + break; bad_escaped: scm_i_input_error (FUNC_NAME, port, "illegal character in escape sequence: ~S", @@ -700,6 +710,17 @@ scm_read_string (int chr, SCM port, scm_t_read_opts *opts) } #undef FUNC_NAME +static SCM +scm_read_string (int chr, SCM port, scm_t_read_opts *opts) +{ + return scm_read_string_like_syntax (chr, port, opts); +} + +static SCM +scm_read_r7rs_symbol (int chr, SCM port, scm_t_read_opts *opts) +{ + return scm_string_to_symbol (scm_read_string_like_syntax (chr, port, opts)); +} static SCM scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) @@ -1764,6 +1785,11 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) return (scm_read_sexp (chr, port, opts)); case '"': return (scm_read_string (chr, port, opts)); + case '|': + if (opts->r7rs_symbols_p) + return scm_read_r7rs_symbol (chr, port, opts); + else + return scm_read_mixed_case_symbol (chr, port, opts); case '\'': case '`': case ',': @@ -2186,9 +2212,10 @@ SCM_SYMBOL (sym_port_read_options, "port-read-options"); #define READ_OPTION_SQUARE_BRACKETS_P 10 #define READ_OPTION_HUNGRY_EOL_ESCAPES_P 12 #define READ_OPTION_CURLY_INFIX_P 14 +#define READ_OPTION_R7RS_SYMBOLS_P 16 /* The total width in bits of the per-port overrides */ -#define READ_OPTIONS_NUM_BITS 16 +#define READ_OPTIONS_NUM_BITS 18 #define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1) #define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL @@ -2292,6 +2319,7 @@ init_read_options (SCM port, scm_t_read_opts *opts) RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P, square_brackets_p); RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p); RESOLVE_BOOLEAN_OPTION (CURLY_INFIX_P, curly_infix_p); + RESOLVE_BOOLEAN_OPTION (R7RS_SYMBOLS_P, r7rs_symbols_p); #undef RESOLVE_BOOLEAN_OPTION diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index bb4cf1fce..5b52299c9 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -4220,6 +4220,7 @@ when none is available, reading FILE-NAME with READER." srfi-39 ;; parameterize srfi-55 ;; require-extension srfi-61 ;; general cond clause + srfi-62 ;; s-expression comments srfi-105 ;; curly infix expressions )) diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test index 47a107736..7269887d6 100644 --- a/test-suite/tests/print.test +++ b/test-suite/tests/print.test @@ -1,6 +1,6 @@ ;;;; -*- coding: utf-8; mode: scheme; -*- ;;;; -;;;; Copyright (C) 2010, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2013, 2014 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 @@ -29,6 +29,60 @@ (lambda () (pretty-print 'exp))))))) +(define (with-print-options opts thunk) + (let ((saved-options (print-options))) + (dynamic-wind + (lambda () + (print-options opts)) + thunk + (lambda () + (print-options saved-options))))) + +(define-syntax-rule (write-with-options opts x) + (with-print-options opts (lambda () + (with-output-to-string + (lambda () + (write x)))))) + + +(with-test-prefix "write" + + (with-test-prefix "r7rs-symbols" + + (pass-if-equal "basic" + "|foo bar|" + (write-with-options '(r7rs-symbols) + (string->symbol "foo bar"))) + + (pass-if-equal "escapes" + "|bar \\| backslash \\x5c; alarm \\a backspace \\b tab \\t newline \\n cr \\r null \\x0; del \\x7f;|" + (write-with-options + '(r7rs-symbols) + (string->symbol + (string-append + "bar | backslash \\ alarm \a backspace \b tab \t newline \n cr \r null \0 del " + (string #\del))))) + + (pass-if-equal "starts with bar" + "|\\|foo|" + (write-with-options '(r7rs-symbols) + (string->symbol "|foo"))) + + (pass-if-equal "ends with bar" + "|foo\\||" + (write-with-options '(r7rs-symbols) + (string->symbol "foo|"))) + + (pass-if-equal "starts with backslash" + "|\\x5c;foo|" + (write-with-options '(r7rs-symbols) + (string->symbol "\\foo"))) + + (pass-if-equal "ends with backslash" + "|foo\\x5c;|" + (write-with-options '(r7rs-symbols) + (string->symbol "foo\\"))))) + (with-test-prefix "pretty-print" diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 9f30b4bff..d9cb1c883 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -237,6 +237,11 @@ (with-read-options '(case-insensitive) (lambda () (read-string "GuiLe"))))) + (pass-if-equal "r7rs-symbols" + (list 'a (string->symbol "Hello, this is | a \"test\"") 'b) + (with-read-options '(r7rs-symbols) + (lambda () + (read-string "(a |H\\x65;llo, this is \\| a \"test\"| b)")))) (pass-if "prefix keywords" (eq? #:keyword (with-read-options '(keywords prefix case-insensitive) |