From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Mark H Weaver Newsgroups: gmane.lisp.guile.devel Subject: Re: [PATCH] Implement SRFI-105 curly infix expressions Date: Sun, 14 Oct 2012 19:15:00 -0400 Message-ID: <87sj9gwsqz.fsf@tines.lan> References: <87hapxxvhv.fsf@tines.lan> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1350256539 15749 80.91.229.3 (14 Oct 2012 23:15:39 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Sun, 14 Oct 2012 23:15:39 +0000 (UTC) Cc: Alan Manuel Gloria To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon Oct 15 01:15:46 2012 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1TNXPN-0007uV-0p for guile-devel@m.gmane.org; Mon, 15 Oct 2012 01:15:45 +0200 Original-Received: from localhost ([::1]:53745 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TNXPG-0001aX-2k for guile-devel@m.gmane.org; Sun, 14 Oct 2012 19:15:38 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:36638) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TNXPA-0001aK-V4 for guile-devel@gnu.org; Sun, 14 Oct 2012 19:15:35 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1TNXP7-0003Qi-Qp for guile-devel@gnu.org; Sun, 14 Oct 2012 19:15:32 -0400 Original-Received: from world.peace.net ([96.39.62.75]:55799) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TNXP7-0003Qc-Hf for guile-devel@gnu.org; Sun, 14 Oct 2012 19:15:29 -0400 Original-Received: from 209-6-91-212.c3-0.smr-ubr1.sbo-smr.ma.cable.rcn.com ([209.6.91.212] helo=tines.lan) by world.peace.net with esmtpsa (TLS1.0:DHE_RSA_AES_128_CBC_SHA1:16) (Exim 4.72) (envelope-from ) id 1TNXOm-0006aL-FW; Sun, 14 Oct 2012 19:15:09 -0400 In-Reply-To: <87hapxxvhv.fsf@tines.lan> (Mark H. Weaver's message of "Sun, 14 Oct 2012 05:18:04 -0400") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.2 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) X-Received-From: 96.39.62.75 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:14980 Archived-At: --=-=-= Content-Type: text/plain Hello all, Here's an improved version of the SRFI-105 patch for Guile 2.0. It incorporates the recent name change 'nfx' --> '$nfx$', has an improved test suite, and now correctly handles the case where 'curly-infix' is enabled but the 'square-brackets' read option is disabled. This patch assumes that the following patch set (per-port read options and reader directives) has already been applied: http://lists.gnu.org/archive/html/guile-devel/2012-10/msg00056.html Note that in the interests of backward compatibility, SRFI-105 syntax is enabled by default, since '{' and '}' are currently considered "extended alphabetic characters". It must first be enabled in one of two ways: * On a per-port basis, when the reader encounters the "#!curly-infix" reader directive, e.g. near the top of source files. * Globally, by evaluating: (read-enable 'curly-infix) Reviews solicited. Thanks, Mark --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Implement-SRFI-105-curly-infix-expressions.patch Content-Description: [PATCH] Implement SRFI-105 curly infix expressions (v2) >From 4102fbbd852d2f36e13f0c7f10dbac2017552bff Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 14 Oct 2012 04:09:01 -0400 Subject: [PATCH] Implement SRFI-105 curly infix expressions. * libguile/private-options.h: Add SCM_CURLY_INFIX_P macro, and increment SCM_N_READ_OPTIONS. * libguile/read.c (scm_read_opts): Add curly-infix reader option. (scm_t_read_opts): Add curly_infix_p field. (init_read_options): Initialize new curly_infix_p field. (CHAR_IS_DELIMITER): Add '{', '}', '[', and ']' as delimiters if curly_infix_p is set. (set_per_port_curly_infix_p): New internal static function. (scm_read_shebang): Handle '#!curly-infix' reader directive. (scm_read, scm_read_keyword, scm_read_vector, scm_read_bytevector): Pass new 'neoteric_p' argument to subroutines where needed. (scm_read_expression_1): New internal static function, which contains the code that was previously in 'scm_read_expression'. Handle curly braces when curly_infix_p is set. Pass new 'neoteric_p' argument to subroutines where needed. (scm_read_expression): Add 'neoteric_p' argument. New function body to handle neoteric expressions where appropriate. (scm_read_sexp): Add 'neoteric_p' argument. Handle curly infix expressions, converting them to normal s-expressions. (flush_ws, scm_read_commented_expression, scm_read_sharp, scm_read_quote, scm_read_syntax): Add 'neoteric_p' argument. Pass new 'neoteric_p' argument to subroutines where needed. * doc/ref/srfi-modules.texi (SRFI-105): Add stub doc for SRFI-105. * doc/ref/api-evaluation.texi (Scheme Read): Add documentation for the 'curly-infix' read option and the '#!curly-infix' reader directive. * doc/ref/api-options.texi (Runtime Options): Add 'curly-infix' to the list of read options. * test-suite/Makefile.am: Add tests/srfi-105.test. * test-suite/tests/srfi-105.test: New file. --- doc/ref/api-evaluation.texi | 10 +- doc/ref/api-options.texi | 1 + doc/ref/srfi-modules.texi | 14 +++ libguile/private-options.h | 3 +- libguile/read.c | 231 +++++++++++++++++++++++++++++++--------- test-suite/Makefile.am | 1 + test-suite/tests/srfi-105.test | 76 +++++++++++++ 7 files changed, 282 insertions(+), 54 deletions(-) create mode 100644 test-suite/tests/srfi-105.test diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 9eccb39..245d4e0 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -338,13 +338,15 @@ r6rs-hex-escapes no Use R6RS variable-length character and string hex escape 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. @end smalllisp Note that Guile also includes a preliminary mechanism for overriding -read options on a per-port basis. Currently, the only read option that -is overridden in this way is the @code{case-insensitive} option, which -is set or unset when the reader encounters the special directives -@code{#!fold-case} or @code{#!no-fold-case}. There is currently no +read options on a per-port basis. The only read options that can +currently be overridden in this way are the @code{case-insensitive} and +@code{curly-infix} options, which are set (or unset) when the reader +encounters the special directives @code{#!fold-case}, +@code{#!no-fold-case}, or @code{#!curly-infix}. There is currently no other way to access or set these per-port read options. The boolean options may be toggled with @code{read-enable} and diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi index f635978..1734318 100644 --- a/doc/ref/api-options.texi +++ b/doc/ref/api-options.texi @@ -390,6 +390,7 @@ r6rs-hex-escapes no Use R6RS variable-length character and string hex escape 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. scheme@@(guile-user) [1]> (read-enable 'case-insensitive) $2 = (square-brackets keywords #f case-insensitive positions) scheme@@(guile-user) [1]> ,q diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index ba701a2..bf7b3f2 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -54,6 +54,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-69:: Basic hash tables. * SRFI-88:: Keyword objects. * SRFI-98:: Accessing environment variables. +* SRFI-105:: Curly infix expressions. @end menu @@ -4469,6 +4470,19 @@ Returns the names and values of all the environment variables as an association list in which both the keys and the values are strings. @end deffn +@node SRFI-105 +@subsection SRFI-105 Curly infix expressions. +@cindex SRFI-105 +@cindex curly infix expressions +@cindex curly-infix + +Guile's built-in reader includes support for SRFI-105 curly infix +expressions. To enable curly infix expressions, place the reader +directive @code{#!curly-infix} near the top of each source file. To +globally enable curly infix expressions in Guile's reader, set the +@code{curly-infix} reader option. For more information on reader +options, @xref{Scheme Read}. + @c srfi-modules.texi ends here @c Local Variables: diff --git a/libguile/private-options.h b/libguile/private-options.h index 9d2d43c..ed0f314 100644 --- a/libguile/private-options.h +++ b/libguile/private-options.h @@ -67,7 +67,8 @@ SCM_INTERNAL scm_t_option scm_read_opts[]; #define SCM_R6RS_ESCAPES_P scm_read_opts[4].val #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_N_READ_OPTIONS 6 +#define SCM_N_READ_OPTIONS 7 #endif /* PRIVATE_OPTIONS */ diff --git a/libguile/read.c b/libguile/read.c index da51a05..5a3cdb4 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -63,6 +63,10 @@ SCM_SYMBOL (scm_keyword_prefix, "prefix"); SCM_SYMBOL (scm_keyword_postfix, "postfix"); SCM_SYMBOL (sym_nil, "nil"); +/* SRFI-105 curly infix expression support */ +SCM_SYMBOL (sym_nfx, "$nfx$"); +SCM_SYMBOL (sym_bracket_apply, "$bracket-apply$"); + scm_t_option scm_read_opts[] = { { SCM_OPTION_BOOLEAN, "copy", 0, "Copy source code expressions." }, @@ -78,6 +82,8 @@ scm_t_option scm_read_opts[] = { "Treat `[' and `]' as parentheses, for R6RS compatibility."}, { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0, "In strings, consume leading whitespace after an escaped end-of-line."}, + { SCM_OPTION_BOOLEAN, "curly-infix", 0, + "Support SRFI-105 curly infix expressions."}, { 0, }, }; @@ -96,6 +102,7 @@ typedef struct { char r6rs_escapes_p; char square_brackets_p; char hungry_eol_escapes_p; + char curly_infix_p; } scm_t_read_opts; /* @@ -129,7 +136,8 @@ SCM_SYMBOL (sym_read_option_overrides, "%read-option-overrides%"); #define OVERRIDE_SHIFT_R6RS_ESCAPES_P 8 #define OVERRIDE_SHIFT_SQUARE_BRACKETS_P 10 #define OVERRIDE_SHIFT_HUNGRY_EOL_ESCAPES_P 12 -#define OVERRIDES_SHIFT_END 14 +#define OVERRIDE_SHIFT_CURLY_INFIX_P 14 +#define OVERRIDES_SHIFT_END 16 #define OVERRIDES_ALL_DEFAULTS ((1UL << OVERRIDES_SHIFT_END) - 1) #define OVERRIDES_MAX_VALUE OVERRIDES_ALL_DEFAULTS @@ -168,6 +176,15 @@ set_per_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value) set_per_port_read_option (port, OVERRIDE_SHIFT_CASE_INSENSITIVE_P, value); } +/* Set curly_infix_p on a per-port basis. */ +static void +set_per_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value) +{ + value = !!value; + opts->curly_infix_p = value; + set_per_port_read_option (port, OVERRIDE_SHIFT_CURLY_INFIX_P, value); +} + /* Initialize the internal read options structure from the global and per-port read options. */ static void @@ -214,6 +231,7 @@ init_read_options (SCM port, scm_t_read_opts *opts) RESOLVE_BOOLEAN_OPTION(R6RS_ESCAPES_P, r6rs_escapes_p); 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); #undef RESOLVE_BOOLEAN_OPTION } @@ -330,7 +348,9 @@ scm_i_read_hash_procedures_set_x (SCM value) #define CHAR_IS_DELIMITER(c) \ (CHAR_IS_R5RS_DELIMITER (c) \ - || (opts->square_brackets_p && ((c) == ']' || (c) == '['))) + || (((c) == ']' || (c) == '[') && (opts->square_brackets_p \ + || opts->curly_infix_p)) \ + || (((c) == '}' || (c) == '{') && opts->curly_infix_p)) /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical Structure''. */ @@ -341,7 +361,8 @@ scm_i_read_hash_procedures_set_x (SCM value) /* Read an SCSH block comment. */ static SCM scm_read_scsh_block_comment (scm_t_wchar, SCM); static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM); -static SCM scm_read_commented_expression (scm_t_wchar, SCM, scm_t_read_opts *); +static SCM scm_read_commented_expression (scm_t_wchar, SCM, + scm_t_read_opts *, int); static SCM scm_read_shebang (scm_t_wchar, SCM, scm_t_read_opts *); static SCM scm_get_hash_procedure (int); @@ -427,7 +448,7 @@ read_complete_token (SCM port, scm_t_read_opts *opts, /* Skip whitespace from PORT and return the first non-whitespace character read. Raise an error on end-of-file. */ static int -flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) +flush_ws (SCM port, scm_t_read_opts *opts, int neoteric_p, const char *eoferr) { scm_t_wchar c; while (1) @@ -467,7 +488,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) scm_read_shebang (c, port, opts); break; case ';': - scm_read_commented_expression (c, port, opts); + scm_read_commented_expression (c, port, opts, neoteric_p); break; case '|': if (scm_is_false (scm_get_hash_procedure (c))) @@ -498,9 +519,10 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) /* Token readers. */ -static SCM scm_read_expression (SCM port, scm_t_read_opts *opts); +static SCM scm_read_expression (SCM port, scm_t_read_opts *opts, + int neoteric_p); static SCM scm_read_sharp (int chr, SCM port, scm_t_read_opts *opts, - long line, int column); + int neoteric_p, long line, int column); static SCM @@ -513,31 +535,35 @@ maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts, } static SCM -scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, int neoteric_p) #define FUNC_NAME "scm_i_lreadparen" { int c; SCM tmp, tl, ans = SCM_EOL; - const int terminating_char = ((chr == '[') ? ']' : ')'); + const int curly_infix_p = (chr == '{'); + const int terminating_char = ((chr == '{') ? '}' + : ((chr == '[') ? ']' + : ')')); /* Need to capture line and column numbers here. */ long line = SCM_LINUM (port); int column = SCM_COL (port) - 1; - c = flush_ws (port, opts, FUNC_NAME); + c = flush_ws (port, opts, neoteric_p, FUNC_NAME); if (terminating_char == c) return SCM_EOL; scm_ungetc (c, port); - tmp = scm_read_expression (port, opts); + tmp = scm_read_expression (port, opts, neoteric_p); /* Note that it is possible for scm_read_expression to return scm_sym_dot, but not as part of a dotted pair: as in #{.}#. So check that it's a real dot by checking `c'. */ if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { - ans = scm_read_expression (port, opts); - if (terminating_char != (c = flush_ws (port, opts, FUNC_NAME))) + ans = scm_read_expression (port, opts, neoteric_p); + if (terminating_char != (c = flush_ws (port, opts, neoteric_p, + FUNC_NAME))) scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL); return ans; @@ -546,28 +572,30 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) /* Build the head of the list structure. */ ans = tl = scm_cons (tmp, SCM_EOL); - while (terminating_char != (c = flush_ws (port, opts, FUNC_NAME))) + while (terminating_char != (c = flush_ws (port, opts, neoteric_p, + FUNC_NAME))) { SCM new_tail; - if (c == ')' || (opts->square_brackets_p && c == ']')) + if (c == ')' || (opts->square_brackets_p && c == ']') + || (opts->curly_infix_p && (c == '}' || c == ']'))) scm_i_input_error (FUNC_NAME, port, "in pair: mismatched close paren: ~A", scm_list_1 (SCM_MAKE_CHAR (c))); scm_ungetc (c, port); - tmp = scm_read_expression (port, opts); + tmp = scm_read_expression (port, opts, neoteric_p); /* See above note about scm_sym_dot. */ if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { - SCM_SETCDR (tl, scm_read_expression (port, opts)); + SCM_SETCDR (tl, scm_read_expression (port, opts, neoteric_p)); - c = flush_ws (port, opts, FUNC_NAME); + c = flush_ws (port, opts, neoteric_p, FUNC_NAME); if (terminating_char != c) scm_i_input_error (FUNC_NAME, port, "in pair: missing close paren", SCM_EOL); - goto exit; + break; } new_tail = scm_cons (tmp, SCM_EOL); @@ -575,8 +603,51 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) tl = new_tail; } - exit: - return maybe_annotate_source (ans, port, opts, line, column); + if (curly_infix_p) + { + int len = scm_ilength (ans); + + if (len == 1) + ans = scm_car (ans); + else if (len == 2) + ; /* Leave the list unchanged */ + else if (len >= 3 && (len & 1)) + { + SCM op = scm_cadr (ans); + + /* Verify that all infix operators are 'equal?' */ + for (tl = scm_cdddr (ans); ; tl = scm_cddr (tl)) + { + if (scm_is_null (tl)) + { + tl = ans; + + /* Convert simple curly-infix list to prefix */ + while (scm_is_pair (scm_cdr (tl))) + { + tmp = scm_cddr (tl); + SCM_SETCDR (tl, tmp); + tl = tmp; + } + ans = scm_cons (op, ans); + break; + } + else if (scm_is_false (scm_equal_p (op, scm_car (tl)))) + { + /* Mixed curly-infix list */ + ans = scm_cons (sym_nfx, ans); + break; + } + } + } + else + ans = scm_cons (sym_nfx, ans); /* Mixed curly-infix list */ + } + + if (SCM_NIMP (ans)) + return maybe_annotate_source (ans, port, opts, line, column); + else + return ans; } #undef FUNC_NAME @@ -875,7 +946,7 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) #undef FUNC_NAME static SCM -scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) +scm_read_quote (int chr, SCM port, scm_t_read_opts *opts, int neoteric_p) { SCM p; long line = SCM_LINUM (port); @@ -912,7 +983,7 @@ scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) abort (); } - p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL); + p = scm_cons2 (p, scm_read_expression (port, opts, neoteric_p), SCM_EOL); return maybe_annotate_source (p, port, opts, line, column); } @@ -922,7 +993,7 @@ SCM_SYMBOL (sym_unsyntax, "unsyntax"); SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing"); static SCM -scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) +scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts, int neoteric_p) { SCM p; long line = SCM_LINUM (port); @@ -959,7 +1030,7 @@ scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) abort (); } - p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL); + p = scm_cons2 (p, scm_read_expression (port, opts, neoteric_p), SCM_EOL); return maybe_annotate_source (p, port, opts, line, column); } @@ -1128,7 +1199,7 @@ scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts) to adapt to the delimiters currently valid of symbols. XXX: This implementation allows sloppy syntaxes like `#: key'. */ - symbol = scm_read_expression (port, opts); + symbol = scm_read_expression (port, opts, 0); if (!scm_is_symbol (symbol)) scm_i_input_error ("scm_read_keyword", port, "keyword prefix `~a' not followed by a symbol: ~s", @@ -1145,8 +1216,9 @@ scm_read_vector (int chr, SCM port, scm_t_read_opts *opts, guarantee that it's going to do what we want. After all, this is an implementation detail of `scm_read_vector ()', not a desirable property. */ - return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port, opts)), - port, opts, line, column); + return maybe_annotate_source + (scm_vector (scm_read_sexp (chr, port, opts, 0)), + port, opts, line, column); } static SCM @@ -1184,7 +1256,7 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, goto syntax; return maybe_annotate_source - (scm_u8_list_to_bytevector (scm_read_sexp (chr, port, opts)), + (scm_u8_list_to_bytevector (scm_read_sexp (chr, port, opts, 0)), port, opts, line, column); syntax: @@ -1267,6 +1339,8 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) set_per_port_case_insensitive_p (port, opts, 1); else if (0 == strcmp ("no-fold-case", name)) set_per_port_case_insensitive_p (port, opts, 0); + else if (0 == strcmp ("curly-infix", name)) + set_per_port_curly_infix_p (port, opts, 1); else break; @@ -1318,16 +1392,16 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port) static SCM scm_read_commented_expression (scm_t_wchar chr, SCM port, - scm_t_read_opts *opts) + scm_t_read_opts *opts, int neoteric_p) { scm_t_wchar c; - c = flush_ws (port, opts, (char *) NULL); + c = flush_ws (port, opts, neoteric_p, (char *) NULL); if (EOF == c) scm_i_input_error ("read_commented_expression", port, "no expression after #; comment", SCM_EOL); scm_ungetc (c, port); - scm_read_expression (port, opts); + scm_read_expression (port, opts, neoteric_p); return SCM_UNSPECIFIED; } @@ -1456,7 +1530,7 @@ scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts) among the above token readers. */ static SCM scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, - long line, int column) + int neoteric_p, long line, int column) #define FUNC_NAME "scm_lreadr" { SCM result; @@ -1531,11 +1605,11 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, case '!': return (scm_read_shebang (chr, port, opts)); case ';': - return (scm_read_commented_expression (chr, port, opts)); + return (scm_read_commented_expression (chr, port, opts, neoteric_p)); case '`': case '\'': case ',': - return (scm_read_syntax (chr, port, opts)); + return (scm_read_syntax (chr, port, opts, neoteric_p)); case 'n': return (scm_read_nil (chr, port, opts)); default: @@ -1563,8 +1637,8 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, #undef FUNC_NAME static SCM -scm_read_expression (SCM port, scm_t_read_opts *opts) -#define FUNC_NAME "scm_read_expression" +scm_read_expression_1 (SCM port, scm_t_read_opts *opts, int neoteric_p) +#define FUNC_NAME "scm_read_expression_1" { while (1) { @@ -1580,23 +1654,42 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) case ';': (void) scm_read_semicolon_comment (chr, port); break; + case '{': + if (opts->curly_infix_p) + return (scm_read_sexp (chr, port, opts, 1)); + else + return (scm_read_mixed_case_symbol (chr, port, opts)); + case '}': + if (opts->curly_infix_p) + scm_i_input_error (FUNC_NAME, port, "unexpected \"}\"", SCM_EOL); + else + return (scm_read_mixed_case_symbol (chr, port, opts)); case '[': - if (!opts->square_brackets_p) + if (opts->square_brackets_p) + return (scm_read_sexp (chr, port, opts, neoteric_p)); + else if (opts->curly_infix_p) + scm_i_input_error (FUNC_NAME, port, "unexpected \"[\"", SCM_EOL); + else + return (scm_read_mixed_case_symbol (chr, port, opts)); + case ']': + if (opts->square_brackets_p || opts->curly_infix_p) + scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL); + else return (scm_read_mixed_case_symbol (chr, port, opts)); - /* otherwise fall through */ case '(': - return (scm_read_sexp (chr, port, opts)); + return (scm_read_sexp (chr, port, opts, neoteric_p)); case '"': return (scm_read_string (chr, port, opts)); case '\'': case '`': case ',': - return (scm_read_quote (chr, port, opts)); + return (scm_read_quote (chr, port, opts, neoteric_p)); case '#': { long line = SCM_LINUM (port); int column = SCM_COL (port) - 1; - SCM result = scm_read_sharp (chr, port, opts, line, column); + SCM result = scm_read_sharp (chr, port, opts, neoteric_p, + line, column); if (scm_is_eq (result, SCM_UNSPECIFIED)) /* We read a comment or some such. */ break; @@ -1606,15 +1699,12 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) case ')': scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL); break; - case ']': - if (opts->square_brackets_p) - scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL); - /* otherwise fall through */ case EOF: return SCM_EOF_VAL; case ':': if (opts->keyword_style == KEYWORD_STYLE_PREFIX) - return scm_symbol_to_keyword (scm_read_expression (port, opts)); + return scm_symbol_to_keyword + (scm_read_expression (port, opts, neoteric_p)); /* Fall through. */ default: @@ -1630,6 +1720,49 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) } #undef FUNC_NAME +static SCM +scm_read_expression (SCM port, scm_t_read_opts *opts, int neoteric_p) +#define FUNC_NAME "scm_read_expression" +{ + if (!neoteric_p) + return scm_read_expression_1 (port, opts, 0); + else + { + long line = SCM_LINUM (port); + int column = SCM_COL (port) - 1; + SCM expr = scm_read_expression_1 (port, opts, 1); + + for (;;) + { + int chr = scm_getc (port); + + if (chr == '(') + expr = scm_cons (expr, scm_read_sexp (chr, port, opts, 1)); + else if (chr == '[') + expr = scm_cons (sym_bracket_apply, + scm_cons (expr, + scm_read_sexp (chr, port, opts, 1))); + else if (chr == '{') + { + SCM arg = scm_read_sexp (chr, port, opts, 1); + + if (scm_is_null (arg)) + expr = scm_list_1 (expr); + else + expr = scm_list_2 (expr, arg); + } + else + { + scm_ungetc (chr, port); + break; + } + maybe_annotate_source (expr, port, opts, line, column); + } + return expr; + } +} +#undef FUNC_NAME + /* Actual reader. */ @@ -1649,12 +1782,12 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, init_read_options (port, &opts); - c = flush_ws (port, &opts, (char *) NULL); + c = flush_ws (port, &opts, 0, (char *) NULL); if (EOF == c) return SCM_EOF_VAL; scm_ungetc (c, port); - return (scm_read_expression (port, &opts)); + return (scm_read_expression (port, &opts, 0)); } #undef FUNC_NAME diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 168e799..a843fcd 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -136,6 +136,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-67.test \ tests/srfi-69.test \ tests/srfi-88.test \ + tests/srfi-105.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test new file mode 100644 index 0000000..a0ed0ee --- /dev/null +++ b/test-suite/tests/srfi-105.test @@ -0,0 +1,76 @@ +;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*- +;;;; +;;;; Copyright (C) 2012 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 as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +#!curly-infix + +(define-module (test-srfi-105) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1)) + +(with-test-prefix "curly-infix" + (pass-if (equal? '{n <= 5} '(<= n 5))) + (pass-if (equal? '{a + b + c} '(+ a b c))) + (pass-if (equal? '{x ,op y ,op z} '(,op x y z))) + (pass-if (equal? '{a * {b + c}} '(* a (+ b c)))) + (pass-if (equal? '{x eqv? `a} '(eqv? x `a))) + (pass-if (equal? '{(- a) / b} '(/ (- a) b))) + (pass-if (equal? '{-(a) / b} '(/ (- a) b))) + (pass-if (equal? '{(f a b) + (g h)} '(+ (f a b) (g h)))) + (pass-if (equal? '{f(a b) + g(h)} '(+ (f a b) (g h)))) + (pass-if (equal? '{f(g(x))} '(f (g x)))) + (pass-if (equal? '{f(g(x) h(x))} '(f (g x) (h x)))) + (pass-if (equal? '{ (f (g h(x))) } '(f (g (h x))))) + + ;; FIXME Unsure about this one! I've asked for clarification. -mhw + (pass-if (equal? '{ (f #(g h(x))) } '(f #(g h (x))))) + + (pass-if (equal? '{ (f #;g(x) h(x)) } '(f (h x)))) + + (pass-if (equal? '{a + f(b) + x} '(+ a (f b) x))) + (pass-if (equal? '{{a > 0} and {b >= 1}} '(and (> a 0) (>= b 1)))) + (pass-if (equal? '{'f(x)} '(quote (f x)))) + ;;(pass-if (equal? '#1=f(#1#) '#1=(f #1#))) + (pass-if (equal? '{length(x) >= 6} '(>= (length x) 6))) + + (pass-if (equal? '{} '())) + (pass-if (equal? '{e} 'e)) + (pass-if (equal? '{e1 e2} '(e1 e2))) + + (pass-if (equal? '{a . t} '($nfx$ a . t))) + (pass-if (equal? '{a b . t} '($nfx$ a b . t))) + (pass-if (equal? '{a b c . t} '($nfx$ a b c . t))) + (pass-if (equal? '{a b c d . t} '($nfx$ a b c d . t))) + (pass-if (equal? '{a + b +} '($nfx$ a + b +))) + (pass-if (equal? '{a + b + c +} '($nfx$ a + b + c +))) + (pass-if (equal? '{q + r * s} '($nfx$ q + r * s))) + ;;(pass-if (equal? '#1={a + . #1#} '($nfx$ . #1=(a + . #1#)))) + + (pass-if (equal? '{e()} '(e))) + (pass-if (equal? '{e{}} '(e))) + (pass-if (equal? '{e(1)} '(e 1))) + (pass-if (equal? '{e{1}} '(e 1))) + (pass-if (equal? '{e(1 2)} '(e 1 2))) + (pass-if (equal? '{e{1 2}} '(e (1 2)))) + (pass-if (equal? '{f{n - 1}} '(f (- n 1)))) + (pass-if (equal? '{f{n - 1}(x)} '((f (- n 1)) x))) + (pass-if (equal? '{g{- x}} '(g (- x)))) + (pass-if (equal? '{( . e)} 'e)) + + (pass-if (equal? '{e[]} '($bracket-apply$ e))) + (pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2))) + (pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2)))) -- 1.7.10.4 --=-=-=--