Here's an improved version of the patch set, incorporating Ludovic's
suggestions and rebased on the current stable-2.0 branch.
Comments and suggestions solicited.
Thanks,
Mark
>From 77834798bb67076ff6c7a3fd939b2bb55353faff Mon Sep 17 00:00:00 2001
From: Mark H Weaver <m...@netris.org>
Date: Tue, 23 Oct 2012 17:28:43 -0400
Subject: [PATCH 1/3] Implement per-port read options.
* libguile/read.c (scm_t_read_opts): Update comment to mention the
per-port read options.
(sym_port_read_options): New symbol.
(set_port_read_option): New function.
(init_read_options): Add new 'port' parameter, and consult the
per-port read option overrides when initializing the 'scm_t_read_opts'
struct. Move to bottom of file.
(scm_read): Pass 'port' parameter to init_read_options.
---
libguile/read.c | 145 +++++++++++++++++++++++++++++++++++++++++++------------
1 file changed, 113 insertions(+), 32 deletions(-)
diff --git a/libguile/read.c b/libguile/read.c
index 6c91613..18ac0ef 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -82,8 +82,8 @@ scm_t_option scm_read_opts[] = {
};
/* Internal read options structure. This is initialized by 'scm_read'
- from the global read options, and a pointer is passed down to all
- helper functions. */
+ from the global and per-port read options, and a pointer is passed
+ down to all helper functions. */
enum t_keyword_style {
KEYWORD_STYLE_HASH_PREFIX,
KEYWORD_STYLE_PREFIX,
@@ -102,35 +102,6 @@ struct t_read_opts {
typedef struct t_read_opts scm_t_read_opts;
-/* Initialize OPTS from the global read options. */
-static void
-init_read_options (scm_t_read_opts *opts)
-{
- SCM val;
- int x;
-
- val = SCM_PACK (SCM_KEYWORD_STYLE);
- if (scm_is_eq (val, scm_keyword_prefix))
- x = KEYWORD_STYLE_PREFIX;
- else if (scm_is_eq (val, scm_keyword_postfix))
- x = KEYWORD_STYLE_POSTFIX;
- else
- x = KEYWORD_STYLE_HASH_PREFIX;
- opts->keyword_style = x;
-
-#define RESOLVE_BOOLEAN_OPTION(NAME, name) \
- (opts->name = !!SCM_ ## NAME)
-
- RESOLVE_BOOLEAN_OPTION (COPY_SOURCE_P, copy_source_p);
- RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p);
- RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p);
- 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);
-
-#undef RESOLVE_BOOLEAN_OPTION
-}
-
/*
Give meaningful error messages for errors
@@ -1692,6 +1663,8 @@ scm_read_expression (SCM port, scm_t_read_opts *opts)
/* Actual reader. */
+static void init_read_options (SCM port, scm_t_read_opts *opts);
+
SCM_DEFINE (scm_read, "read", 0, 1, 0,
(SCM port),
"Read an s-expression from the input port @var{port}, or from\n"
@@ -1706,7 +1679,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0,
port = scm_current_input_port ();
SCM_VALIDATE_OPINPORT (1, port);
- init_read_options (&opts);
+ init_read_options (port, &opts);
c = flush_ws (port, &opts, (char *) NULL);
if (EOF == c)
@@ -1970,6 +1943,114 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
}
#undef FUNC_NAME
+/* Per-port read options.
+
+ We store per-port read options in the 'port-read-options' key of the
+ port's alist, which is stored in 'scm_i_port_weak_hash'. The value
+ stored in the alist is a single integer that contains a two-bit field
+ for each read option.
+
+ If a bit field contains READ_OPTION_INHERIT (3), that indicates that
+ the applicable value should be inherited from the corresponding
+ global real option. Otherwise, the bit field contains the value of
+ the read option. For boolean read options that have been set
+ per-port, the possible values are 0 or 1. If the 'keyword_style'
+ read option has been set per-port, its possible values are those in
+ 'enum t_keyword_style'. */
+
+SCM_SYMBOL (sym_port_read_options, "port-read-options");
+
+/* Offsets of bit fields for each per-port override */
+#define READ_OPTION_COPY_SOURCE_P 0
+#define READ_OPTION_RECORD_POSITIONS_P 2
+#define READ_OPTION_CASE_INSENSITIVE_P 4
+#define READ_OPTION_KEYWORD_STYLE 6
+#define READ_OPTION_R6RS_ESCAPES_P 8
+#define READ_OPTION_SQUARE_BRACKETS_P 10
+#define READ_OPTION_HUNGRY_EOL_ESCAPES_P 12
+
+#define READ_OPTIONS_NUM_BITS 14
+
+#define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1)
+#define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL
+
+#define READ_OPTION_MASK 3
+#define READ_OPTION_INHERIT 3
+
+static void
+set_port_read_option (SCM port, int option, int new_value)
+{
+ SCM alist, scm_read_options;
+ unsigned int read_options;
+
+ new_value &= READ_OPTION_MASK;
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ alist = scm_hashq_ref (scm_i_port_weak_hash, port, SCM_BOOL_F);
+ scm_read_options = scm_assq_ref (alist, sym_port_read_options);
+ if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
+ read_options = scm_to_uint (scm_read_options);
+ else
+ read_options = READ_OPTIONS_INHERIT_ALL;
+ read_options &= ~(READ_OPTION_MASK << option);
+ read_options |= new_value << option;
+ scm_read_options = scm_from_uint (read_options);
+ alist = scm_assq_set_x (alist, sym_port_read_options, scm_read_options);
+ scm_hashq_set_x (scm_i_port_weak_hash, port, alist);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+}
+
+/* Initialize OPTS based on PORT's read options and the global read
+ options. */
+static void
+init_read_options (SCM port, scm_t_read_opts *opts)
+{
+ SCM alist, val, scm_read_options;
+ int read_options;
+ int x;
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ alist = scm_hashq_ref (scm_i_port_weak_hash, port, SCM_BOOL_F);
+ scm_read_options = scm_assq_ref (alist, sym_port_read_options);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
+ read_options = scm_to_int (scm_read_options);
+ else
+ read_options = READ_OPTIONS_INHERIT_ALL;
+
+ x = READ_OPTION_MASK & (read_options >> READ_OPTION_KEYWORD_STYLE);
+ if (x == READ_OPTION_INHERIT)
+ {
+ val = SCM_PACK (SCM_KEYWORD_STYLE);
+ if (scm_is_eq (val, scm_keyword_prefix))
+ x = KEYWORD_STYLE_PREFIX;
+ else if (scm_is_eq (val, scm_keyword_postfix))
+ x = KEYWORD_STYLE_POSTFIX;
+ else
+ x = KEYWORD_STYLE_HASH_PREFIX;
+ }
+ opts->keyword_style = x;
+
+#define RESOLVE_BOOLEAN_OPTION(NAME, name) \
+ do \
+ { \
+ x = READ_OPTION_MASK & (read_options >> READ_OPTION_ ## NAME); \
+ if (x == READ_OPTION_INHERIT) \
+ x = !!SCM_ ## NAME; \
+ opts->name = x; \
+ } \
+ while (0)
+
+ RESOLVE_BOOLEAN_OPTION (COPY_SOURCE_P, copy_source_p);
+ RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p);
+ RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p);
+ 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);
+
+#undef RESOLVE_BOOLEAN_OPTION
+}
+
void
scm_init_read ()
{
--
1.7.10.4
>From 3ec85650e3deda7f597d4d8b51525413cfd61222 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <m...@netris.org>
Date: Wed, 24 Oct 2012 14:37:36 -0400
Subject: [PATCH 2/3] Implement #!fold-case and #!no-fold-case reader
directives.
* libguile/read.c (set_port_case_insensitive_p): New function.
(scm_read_shebang): Handle #!fold-case and #!no-fold-case.
* doc/ref/api-evaluation.texi (Case Sensitivity, Scheme Read): Document
the #!fold-case and #!no-fold-case reader directives.
* test-suite/tests/reader.test ("per-port-read-options"): Add tests.
---
doc/ref/api-evaluation.texi | 22 +++++++++++++++-------
libguile/read.c | 16 ++++++++++++++++
test-suite/tests/reader.test | 13 +++++++++++++
3 files changed, 44 insertions(+), 7 deletions(-)
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 6112832..c7bf97a 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -254,6 +254,8 @@ Encoding of Source Files}.
@node Case Sensitivity
@subsubsection Case Sensitivity
+@cindex fold-case
+@cindex no-fold-case
@c FIXME::martin: Review me!
@@ -275,9 +277,9 @@ options, @xref{Scheme Read}.
(read-enable 'case-insensitive)
@end lisp
-Note that this is seldom a problem, because Scheme programmers tend not
-to use uppercase letters in their identifiers anyway.
-
+It is also possible to disable (or enable) case sensitivity within a
+single file by placing the reader directives @code{#!fold-case} (or
+@code{#!no-fold-case}) within the file itself.
@node Keyword Syntax
@subsubsection Keyword Syntax
@@ -315,10 +317,10 @@ its read options.
@cindex options - read
@cindex read options
@deffn {Scheme Procedure} read-options [setting]
-Display the current settings of the read options. If @var{setting} is
-omitted, only a short form of the current read options is printed.
-Otherwise if @var{setting} is the symbol @code{help}, a complete options
-description is displayed.
+Display the current settings of the global read options. If
+@var{setting} is omitted, only a short form of the current read options
+is printed. Otherwise if @var{setting} is the symbol @code{help}, a
+complete options description is displayed.
@end deffn
The set of available options, and their default values, may be had by
@@ -338,6 +340,12 @@ hungry-eol-escapes no In strings, consume leading whitespace after an
escaped end-of-line.
@end smalllisp
+Note that Guile also includes a preliminary mechanism for setting read
+options on a per-port basis. For instance, the @code{case-insensitive}
+read option is set (or unset) on the port when the reader encounters the
+@code{#!fold-case} or @code{#!no-fold-case} reader directives. There is
+currently no other way to access or set the per-port read options.
+
The boolean options may be toggled with @code{read-enable} and
@code{read-disable}. The non-boolean @code{keywords} option must be set
using @code{read-set!}.
diff --git a/libguile/read.c b/libguile/read.c
index 18ac0ef..1ec7325 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -1276,6 +1276,9 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
return SCM_UNSPECIFIED;
}
+static void set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts,
+ int value);
+
static SCM
scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
{
@@ -1297,6 +1300,10 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
name[i] = '\0';
if (0 == strcmp ("r6rs", name))
; /* Silently ignore */
+ else if (0 == strcmp ("fold-case", name))
+ set_port_case_insensitive_p (port, opts, 1);
+ else if (0 == strcmp ("no-fold-case", name))
+ set_port_case_insensitive_p (port, opts, 0);
else
break;
@@ -1999,6 +2006,15 @@ set_port_read_option (SCM port, int option, int new_value)
scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
}
+/* Set OPTS and PORT's case-insensitivity according to VALUE. */
+static void
+set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->case_insensitive_p = value;
+ set_port_read_option (port, READ_OPTION_CASE_INSENSITIVE_P, value);
+}
+
/* Initialize OPTS based on PORT's read options and the global read
options. */
static void
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 60c853c..6e02255 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -401,6 +401,19 @@
(lambda ()
(read-disable 'hungry-eol-escapes))))))
+(with-test-prefix "per-port-read-options"
+ (pass-if "case-sensitive"
+ (equal? '(guile GuiLe gUIle)
+ (with-read-options '(case-insensitive)
+ (lambda ()
+ (with-input-from-string "GUIle #!no-fold-case GuiLe gUIle"
+ (lambda ()
+ (list (read) (read) (read))))))))
+ (pass-if "case-insensitive"
+ (equal? '(GUIle guile guile)
+ (with-input-from-string "GUIle #!fold-case GuiLe gUIle"
+ (lambda ()
+ (list (read) (read) (read)))))))
(with-test-prefix "#;"
(for-each
--
1.7.10.4
>From 3345a52824c2ae0e6ffe64ec7e07609d1bc362ef Mon Sep 17 00:00:00 2001
From: Mark H Weaver <m...@netris.org>
Date: Wed, 24 Oct 2012 14:50:16 -0400
Subject: [PATCH 3/3] 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 (sym_nfx, sym_bracket_list, sym_bracket_apply): New
symbols.
(scm_read_opts): Add curly-infix reader option.
(scm_t_read_opts): Add curly_infix_p and neoteric_p fields.
(init_read_options): Initialize new fields.
(CHAR_IS_DELIMITER): Add '{', '}', '[', and ']' as delimiters if
curly_infix_p is set.
(set_port_square_brackets_p, set_port_curly_infix_p): New functions.
(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. If curly_infix_p is set and
square_brackets_p is unset, follow the Kawa convention:
[...] => ($bracket-list$ ...)
(scm_read_expression): New function body to handle neoteric
expressions where appropriate.
(scm_read_shebang): Handle the new reader directives: '#!curly-infix'
and the non-standard '#!curly-infix-and-bracket-lists'.
(scm_read_sexp): Handle curly infix lists.
* module/ice-9/boot-9.scm (%cond-expand-features): Add srfi-105 feature
identifier.
* 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' and
'#!curly-infix-and-bracket-lists' reader directives.
* 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 | 7 +-
doc/ref/api-options.texi | 1 +
doc/ref/srfi-modules.texi | 51 ++++++++++
libguile/private-options.h | 3 +-
libguile/read.c | 221 ++++++++++++++++++++++++++++++++++++++--
module/ice-9/boot-9.scm | 3 +-
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-105.test | 131 ++++++++++++++++++++++++
8 files changed, 404 insertions(+), 14 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 c7bf97a..2c26ae8 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -338,12 +338,17 @@ 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 setting read
options on a per-port basis. For instance, the @code{case-insensitive}
read option is set (or unset) on the port when the reader encounters the
-@code{#!fold-case} or @code{#!no-fold-case} reader directives. There is
+@code{#!fold-case} or @code{#!no-fold-case} reader directives.
+Similarly, the @code{#!curly-infix} reader directive sets the
+@code{curly-infix} read option on the port, and the
+@code{#!curly-infix-and-bracket-lists} sets @code{curly-infix} and
+unsets @code{square-brackets} on the port (@pxref{SRFI-105}). There is
currently no other way to access or set the 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..f50e4df 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,56 @@ 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
+@cindex curly-infix-and-bracket-lists
+
+Guile's built-in reader includes support for SRFI-105 curly-infix
+expressions. See @uref{http://srfi.schemers.org/srfi-105/srfi-105.html,
+the specification of SRFI-105}. Some examples:
+
+@example
+@{n <= 5@} @result{} (<= n 5)
+@{a + b + c@} @result{} (+ a b c)
+@{a * @{b + c@}@} @result{} (* a (+ b c))
+@{(- a) / b@} @result{} (/ (- a) b)
+@{-(a) / b@} @result{} (/ (- a) b) as well
+@{(f a b) + (g h)@} @result{} (+ (f a b) (g h))
+@{f(a b) + g(h)@} @result{} (+ (f a b) (g h)) as well
+@{f[a b] + g(h)@} @result{} (+ ($bracket-apply$ f a b) (g h))
+'@{a + f(b) + x@} @result{} '(+ a (f b) x)
+@{length(x) >= 6@} @result{} (>= (length x) 6)
+@{n-1 + n-2@} @result{} (+ n-1 n-2)
+@{n * factorial@{n - 1@}@} @result{} (* n (factorial (- n 1)))
+@{@{a > 0@} and @{b >= 1@}@} @result{} (and (> a 0) (>= b 1))
+@{f@{n - 1@}(x)@} @result{} ((f (- n 1)) x)
+@{a . z@} @result{} ($nfx$ a . z)
+@{a + b - c@} @result{} ($nfx$ a + b - c)
+@end example
+
+To enable curly-infix expressions within a file, place the reader
+directive @code{#!curly-infix} before the first use of curly-infix
+notation. To globally enable curly-infix expressions in Guile's reader,
+set the @code{curly-infix} read option.
+
+Guile also implements the following non-standard extension to SRFI-105:
+if @code{curly-infix} is enabled but the @code{square-brackets} read
+option is turned off, then lists within square brackets are read as
+normal lists but with the special symbol @code{$bracket-list$} added to
+the front. To enable this combination of read options within a file,
+use the reader directive @code{#!curly-infix-and-bracket-lists}. For
+example:
+
+@example
+[a b] @result{} ($bracket-list$ a b)
+[a . b] @result{} ($bracket-list$ a . b)
+@end example
+
+
+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 1ec7325..498887f 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -63,6 +63,11 @@ 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_list, "$bracket-list$");
+SCM_SYMBOL (sym_bracket_apply, "$bracket-apply$");
+
scm_t_option scm_read_opts[] = {
{ SCM_OPTION_BOOLEAN, "copy", 0,
"Copy source code expressions." },
@@ -78,6 +83,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, },
};
@@ -98,6 +105,8 @@ struct t_read_opts {
unsigned int r6rs_escapes_p : 1;
unsigned int square_brackets_p : 1;
unsigned int hungry_eol_escapes_p : 1;
+ unsigned int curly_infix_p : 1;
+ unsigned int neoteric_p : 1;
};
typedef struct t_read_opts scm_t_read_opts;
@@ -214,7 +223,9 @@ scm_i_read_hash_procedures_set_x (SCM value)
#define CHAR_IS_DELIMITER(c) \
(CHAR_IS_R5RS_DELIMITER (c) \
- || (((c) == ']' || (c) == '[') && opts->square_brackets_p))
+ || (((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''. */
@@ -402,7 +413,10 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
{
int c;
SCM tmp, tl, ans = SCM_EOL;
- const int terminating_char = ((chr == '[') ? ']' : ')');
+ const int curly_list_p = (chr == '{') && opts->curly_infix_p;
+ const int terminating_char = ((chr == '{') ? '}'
+ : ((chr == '[') ? ']'
+ : ')'));
/* Need to capture line and column numbers here. */
long line = SCM_LINUM (port);
@@ -434,7 +448,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
{
SCM new_tail;
- if (c == ')' || (c == ']' && opts->square_brackets_p))
+ if (c == ')' || (c == ']' && opts->square_brackets_p)
+ || ((c == '}' || c == ']') && opts->curly_infix_p))
scm_i_input_error (FUNC_NAME, port,
"in pair: mismatched close paren: ~A",
scm_list_1 (SCM_MAKE_CHAR (c)));
@@ -451,7 +466,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
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);
@@ -459,7 +474,53 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
tl = new_tail;
}
- exit:
+ if (curly_list_p)
+ {
+ int len = scm_ilength (ans);
+
+ /* (len == 0) case is handled above */
+ if (len == 1)
+ /* Return directly to avoid re-annotating the element's source
+ location with the position of the outer brace. Also, it
+ might not be possible to annotate the element. */
+ return scm_car (ans); /* {e} => e */
+ else if (len == 2)
+ ; /* Leave the list unchanged: {e1 e2} => (e1 e2) */
+ else if (len >= 3 && (len & 1))
+ {
+ SCM op = scm_cadr (ans);
+
+ /* Verify that all infix operators (odd indices) are 'equal?' */
+ for (tl = scm_cdddr (ans); ; tl = scm_cddr (tl))
+ {
+ if (scm_is_null (tl))
+ {
+ /* Convert simple curly-infix list to prefix:
+ {a <op> b <op> ...} => (<op> a b ...) */
+ tl = ans;
+ 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: {e ...} => ($nfx$ e ...) */
+ ans = scm_cons (sym_nfx, ans);
+ break;
+ }
+ }
+ }
+ else
+ /* Mixed curly-infix (possibly improper) list:
+ {e . tail} => ($nfx$ e . tail) */
+ ans = scm_cons (sym_nfx, ans);
+ }
+
return maybe_annotate_source (ans, port, opts, line, column);
}
#undef FUNC_NAME
@@ -1278,6 +1339,10 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
static void set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts,
int value);
+static void set_port_square_brackets_p (SCM port, scm_t_read_opts *opts,
+ int value);
+static void set_port_curly_infix_p (SCM port, scm_t_read_opts *opts,
+ int value);
static SCM
scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
@@ -1304,6 +1369,13 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
set_port_case_insensitive_p (port, opts, 1);
else if (0 == strcmp ("no-fold-case", name))
set_port_case_insensitive_p (port, opts, 0);
+ else if (0 == strcmp ("curly-infix", name))
+ set_port_curly_infix_p (port, opts, 1);
+ else if (0 == strcmp ("curly-infix-and-bracket-lists", name))
+ {
+ set_port_curly_infix_p (port, opts, 1);
+ set_port_square_brackets_p (port, opts, 0);
+ }
else
break;
@@ -1600,8 +1672,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)
+#define FUNC_NAME "scm_read_expression_1"
{
while (1)
{
@@ -1617,10 +1689,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)
+ {
+ if (opts->neoteric_p)
+ return scm_read_sexp (chr, port, opts);
+ else
+ {
+ SCM expr;
+
+ /* Enable neoteric expressions within curly braces */
+ opts->neoteric_p = 1;
+ expr = scm_read_sexp (chr, port, opts);
+ opts->neoteric_p = 0;
+ return expr;
+ }
+ }
+ else
+ return scm_read_mixed_case_symbol (chr, port, opts);
case '[':
- if (!opts->square_brackets_p)
- return (scm_read_mixed_case_symbol (chr, port, opts));
- /* otherwise fall through */
+ if (opts->square_brackets_p)
+ return scm_read_sexp (chr, port, opts);
+ else if (opts->curly_infix_p)
+ {
+ /* The syntax of neoteric expressions requires that '[' be
+ a delimiter when curly-infix is enabled, so it cannot
+ be part of an unescaped symbol. We might as well do
+ something useful with it, so we adopt Kawa's convention:
+ [...] => ($bracket-list$ ...) */
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+ return maybe_annotate_source
+ (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)),
+ port, opts, line, column);
+ }
+ else
+ return scm_read_mixed_case_symbol (chr, port, opts);
case '(':
return (scm_read_sexp (chr, port, opts));
case '"':
@@ -1643,6 +1747,11 @@ 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->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)
scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL);
@@ -1667,6 +1776,74 @@ 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)
+#define FUNC_NAME "scm_read_expression"
+{
+ if (!opts->neoteric_p)
+ return scm_read_expression_1 (port, opts);
+ else
+ {
+ long line = 0;
+ int column = 0;
+ SCM expr;
+
+ if (opts->record_positions_p)
+ {
+ /* We need to get the position of the first non-whitespace
+ character in order to correctly annotate neoteric
+ expressions. For example, for the expression 'f(x)', the
+ first call to 'scm_read_expression_1' reads the 'f' (which
+ cannot be annotated), and then we later read the '(x)' and
+ use it to construct the new list (f x). */
+ int c = flush_ws (port, opts, (char *) NULL);
+ if (c == EOF)
+ return SCM_EOF_VAL;
+ scm_ungetc (c, port);
+ line = SCM_LINUM (port);
+ column = SCM_COL (port);
+ }
+
+ expr = scm_read_expression_1 (port, opts);
+
+ /* 'expr' is the first component of the neoteric expression. Now
+ we loop, and as long as the next character is '(', '[', or '{',
+ (without any intervening whitespace), we use it to construct a
+ new expression. For example, f{n - 1}(x) => ((f (- n 1)) x). */
+ for (;;)
+ {
+ int chr = scm_getc (port);
+
+ if (chr == '(')
+ /* e(...) => (e ...) */
+ expr = scm_cons (expr, scm_read_sexp (chr, port, opts));
+ else if (chr == '[')
+ /* e[...] => ($bracket-apply$ e ...) */
+ expr = scm_cons (sym_bracket_apply,
+ scm_cons (expr,
+ scm_read_sexp (chr, port, opts)));
+ else if (chr == '{')
+ {
+ SCM arg = scm_read_sexp (chr, port, opts);
+
+ if (scm_is_null (arg))
+ expr = scm_list_1 (expr); /* e{} => (e) */
+ else
+ expr = scm_list_2 (expr, arg); /* e{...} => (e {...}) */
+ }
+ else
+ {
+ if (chr != EOF)
+ scm_ungetc (chr, port);
+ break;
+ }
+ maybe_annotate_source (expr, port, opts, line, column);
+ }
+ return expr;
+ }
+}
+#undef FUNC_NAME
+
/* Actual reader. */
@@ -1975,8 +2152,9 @@ SCM_SYMBOL (sym_port_read_options, "port-read-options");
#define READ_OPTION_R6RS_ESCAPES_P 8
#define READ_OPTION_SQUARE_BRACKETS_P 10
#define READ_OPTION_HUNGRY_EOL_ESCAPES_P 12
+#define READ_OPTION_CURLY_INFIX_P 14
-#define READ_OPTIONS_NUM_BITS 14
+#define READ_OPTIONS_NUM_BITS 16
#define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1)
#define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL
@@ -2015,6 +2193,24 @@ set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value)
set_port_read_option (port, READ_OPTION_CASE_INSENSITIVE_P, value);
}
+/* Set OPTS and PORT's square_brackets_p option according to VALUE. */
+static void
+set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->square_brackets_p = value;
+ set_port_read_option (port, READ_OPTION_SQUARE_BRACKETS_P, value);
+}
+
+/* Set OPTS and PORT's curly_infix_p option according to VALUE. */
+static void
+set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->curly_infix_p = value;
+ set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value);
+}
+
/* Initialize OPTS based on PORT's read options and the global read
options. */
static void
@@ -2063,8 +2259,11 @@ 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
+
+ opts->neoteric_p = 0;
}
void
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d679f6e..4b111aa 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3716,7 +3716,7 @@ module '(ice-9 q) '(make-q q-length))}."
;;;
;;; Currently, the following feature identifiers are supported:
;;;
-;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
+;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 srfi-105
;;;
;;; Remember to update the features list when adding more SRFIs.
;;;
@@ -3735,6 +3735,7 @@ module '(ice-9 q) '(make-q q-length))}."
srfi-39 ;; parameterize
srfi-55 ;; require-extension
srfi-61 ;; general cond clause
+ srfi-105 ;; curly infix expressions
))
;; This table maps module public interfaces to the list of features.
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..c0de5ad
--- /dev/null
+++ b/test-suite/tests/srfi-105.test
@@ -0,0 +1,131 @@
+;;;; 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
+
+(define-module (test-srfi-105)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1))
+
+#!curly-infix
+
+(with-test-prefix "curly-infix"
+ (pass-if (equal? '{n <= 5} '(<= n 5)))
+ (pass-if (equal? '{x + 1} '(+ x 1)))
+ (pass-if (equal? '{a + b + c} '(+ a b c)))
+ (pass-if (equal? '{x ,op y ,op z} '(,op x y z)))
+ (pass-if (equal? '{x eqv? `a} '(eqv? x `a)))
+ (pass-if (equal? '{'a eq? b} '(eq? 'a b)))
+ (pass-if (equal? '{n-1 + n-2} '(+ n-1 n-2)))
+ (pass-if (equal? '{a * {b + c}} '(* a (+ b c))))
+ (pass-if (equal? '{a + {b - c}} '(+ a (- b c))))
+ (pass-if (equal? '{{a + b} - c} '(- (+ a b) c)))
+ (pass-if (equal? '{{a > 0} and {b >= 1}} '(and (> a 0) (>= b 1))))
+ (pass-if (equal? '{} '()))
+ (pass-if (equal? '{5} '5))
+ (pass-if (equal? '{- x} '(- x)))
+ (pass-if (equal? '{length(x) >= 6} '(>= (length x) 6)))
+ (pass-if (equal? '{f(x) + g(y) + h(z)} '(+ (f x) (g y) (h z))))
+ (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? '{a + f(b) + x} '(+ a (f b) x)))
+ (pass-if (equal? '{(- a) / b} '(/ (- a) b)))
+ (pass-if (equal? '{-(a) / b} '(/ (- a) b)))
+ (pass-if (equal? '{cos(q)} '(cos q)))
+ (pass-if (equal? '{e{}} '(e)))
+ (pass-if (equal? '{pi{}} '(pi)))
+ (pass-if (equal? '{'f(x)} '(quote (f x))))
+ ;;(pass-if (equal? '#1=f(#1#) '#1=(f #1#)))
+
+ (pass-if (equal? '{ (f (g h(x))) } '(f (g (h x)))))
+ (pass-if (equal? '{#(1 2 f(a) 4)} '#(1 2 (f a) 4)))
+ (pass-if (equal? '{ (f #;g(x) h(x)) } '(f (h x))))
+
+ (pass-if (equal? '{ (f #(g h(x))) } '(f #(g (h x)))))
+ (pass-if (equal? '{ (f '(g h(x))) } '(f '(g (h x)))))
+ (pass-if (equal? '{ (f `(g h(x))) } '(f `(g (h x)))))
+ (pass-if (equal? '{ (f #'(g h(x))) } '(f #'(g (h x)))))
+ (pass-if (equal? '{ (f #2((g) (h(x)))) } '(f #2((g) ((h x))))))
+
+ (pass-if (equal? '{(map - ns)} '(map - ns)))
+ (pass-if (equal? '{map(- ns)} '(map - ns)))
+ (pass-if (equal? '{n * factorial{n - 1}} '(* n (factorial (- n 1)))))
+ (pass-if (equal? '{2 * sin{- x}} '(* 2 (sin (- x)))))
+
+ (pass-if (equal? '{3 + 4 +} '($nfx$ 3 + 4 +)))
+ (pass-if (equal? '{3 + 4 + 5 +} '($nfx$ 3 + 4 + 5 +)))
+ (pass-if (equal? '{a . z} '($nfx$ a . z)))
+ (pass-if (equal? '{a + b - c} '($nfx$ a + b - c)))
+
+ (pass-if (equal? '{read(. options)} '(read . options)))
+
+ (pass-if (equal? '{a(x)(y)} '((a x) y)))
+ (pass-if (equal? '{x[a]} '($bracket-apply$ x a)))
+ (pass-if (equal? '{y[a b]} '($bracket-apply$ y a b)))
+
+ (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? '{} '()))
+ (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? '{f{n - 1}{y - 1}} '((f (- n 1)) (- y 1))))
+ (pass-if (equal? '{f{- x}[y]} '($bracket-apply$ (f (- x)) y)))
+ (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))))
+
+
+#!curly-infix-and-bracket-lists
+
+(with-test-prefix "curly-infix-and-bracket-lists"
+ ;; Verify that these neoteric expressions still work properly
+ ;; when the 'square-brackets' read option is unset (which is done by
+ ;; the '#!curly-infix-and-bracket-lists' reader directive above).
+ (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)))
+
+ ;; The following expressions are not actually part of SRFI-105, but
+ ;; they are handled when the 'curly-infix' read option is set and the
+ ;; 'square-brackets' read option is unset. This is a non-standard
+ ;; extension of SRFI-105, and follows the convention of GNU Kawa.
+ (pass-if (equal? '[] '($bracket-list$)))
+ (pass-if (equal? '[a] '($bracket-list$ a)))
+ (pass-if (equal? '[a b] '($bracket-list$ a b)))
+ (pass-if (equal? '[a . b] '($bracket-list$ a . b))))
--
1.7.10.4
