mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
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
variables.
(scm_read_opts): Add curly-infix reader option. Reformat to comply
with GNU coding standards.
(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.
(read_inner_expression): New 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.
This commit is contained in:
Mark H Weaver
parent
9331ffd891
commit
bf9eb54aab
8 changed files with 538 additions and 31 deletions
|
|
@ -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
|
||||
@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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 and there is no other meaning assigned
|
||||
to square brackets (i.e. 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:
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
263
libguile/read.c
263
libguile/read.c
|
|
@ -63,23 +63,31 @@ SCM_SYMBOL (scm_keyword_prefix, "prefix");
|
|||
SCM_SYMBOL (scm_keyword_postfix, "postfix");
|
||||
SCM_SYMBOL (sym_nil, "nil");
|
||||
|
||||
scm_t_option scm_read_opts[] = {
|
||||
{ SCM_OPTION_BOOLEAN, "copy", 0,
|
||||
"Copy source code expressions." },
|
||||
{ SCM_OPTION_BOOLEAN, "positions", 1,
|
||||
"Record positions of source code expressions." },
|
||||
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0,
|
||||
"Convert symbols to lower case."},
|
||||
{ SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
|
||||
"Style of keyword recognition: #f, 'prefix or 'postfix."},
|
||||
{ SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
|
||||
"Use R6RS variable-length character and string hex escapes."},
|
||||
{ SCM_OPTION_BOOLEAN, "square-brackets", 1,
|
||||
"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."},
|
||||
{ 0, },
|
||||
};
|
||||
/* 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." },
|
||||
{ SCM_OPTION_BOOLEAN, "positions", 1,
|
||||
"Record positions of source code expressions." },
|
||||
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0,
|
||||
"Convert symbols to lower case."},
|
||||
{ SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
|
||||
"Style of keyword recognition: #f, 'prefix or 'postfix."},
|
||||
{ SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
|
||||
"Use R6RS variable-length character and string hex escapes."},
|
||||
{ SCM_OPTION_BOOLEAN, "square-brackets", 1,
|
||||
"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, },
|
||||
};
|
||||
|
||||
/* Internal read options structure. This is initialized by 'scm_read'
|
||||
from the global and per-port read options, and a pointer is passed
|
||||
|
|
@ -101,6 +109,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;
|
||||
|
|
@ -217,7 +227,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''. */
|
||||
|
|
@ -405,7 +417,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);
|
||||
|
|
@ -437,7 +452,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)));
|
||||
|
|
@ -454,7 +470,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);
|
||||
|
|
@ -462,7 +478,59 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
|
|||
tl = new_tail;
|
||||
}
|
||||
|
||||
exit:
|
||||
if (curly_list_p)
|
||||
{
|
||||
/* In addition to finding the length, 'scm_ilength' checks for
|
||||
improper or circular lists, in which case it returns -1. */
|
||||
int len = scm_ilength (ans);
|
||||
|
||||
/* The (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))
|
||||
{
|
||||
/* It's a proper list whose length is odd and at least 3. If
|
||||
the elements at odd indices (the infix operator positions)
|
||||
are all 'equal?', then it's a simple curly-infix list.
|
||||
Otherwise it's a mixed curly-infix list. */
|
||||
SCM op = scm_cadr (ans);
|
||||
|
||||
/* Check to see if the elements at 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
|
||||
|
|
@ -1281,6 +1349,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)
|
||||
|
|
@ -1307,6 +1379,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;
|
||||
|
||||
|
|
@ -1603,8 +1682,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"
|
||||
read_inner_expression (SCM port, scm_t_read_opts *opts)
|
||||
#define FUNC_NAME "read_inner_expression"
|
||||
{
|
||||
while (1)
|
||||
{
|
||||
|
|
@ -1620,10 +1699,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 '"':
|
||||
|
|
@ -1646,6 +1757,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);
|
||||
|
|
@ -1670,6 +1786,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 read_inner_expression (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 'read_inner_expression' 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 = read_inner_expression (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. */
|
||||
|
||||
|
|
@ -1980,8 +2164,10 @@ 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
|
||||
/* The total width in bits of the per-port overrides */
|
||||
#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
|
||||
|
|
@ -2020,6 +2206,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
|
||||
|
|
@ -2067,8 +2271,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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
240
test-suite/tests/srfi-105.test
Normal file
240
test-suite/tests/srfi-105.test
Normal file
|
|
@ -0,0 +1,240 @@
|
|||
;;;; 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))
|
||||
|
||||
(define (read-string s)
|
||||
(with-fluids ((%default-port-encoding #f))
|
||||
(with-input-from-string s read)))
|
||||
|
||||
(define (with-read-options opts thunk)
|
||||
(let ((saved-options (read-options)))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(read-options opts))
|
||||
thunk
|
||||
(lambda ()
|
||||
(read-options saved-options)))))
|
||||
|
||||
;; Verify that curly braces are allowed in identifiers and that neoteric
|
||||
;; expressions are not recognized by default.
|
||||
(with-test-prefix "no-curly-infix"
|
||||
(pass-if (equal? '({f(x) + g[y] + h{z} + [a]})
|
||||
`(,(string->symbol "{f")
|
||||
(x) + g [y] +
|
||||
,(string->symbol "h{z}")
|
||||
+ [a]
|
||||
,(string->symbol "}")))))
|
||||
|
||||
#!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? '{ (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(x)[y] h(x)) } '(f (h x))))
|
||||
(pass-if (equal? '{ (f #; g[x]{y} 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)))
|
||||
|
||||
;; The following two tests will become relevant when Guile's reader
|
||||
;; supports datum labels, specified in SRFI-38 (External
|
||||
;; Representation for Data With Shared Structure).
|
||||
|
||||
;;(pass-if (equal? '#1=f(#1#) '#1=(f #1#)))
|
||||
;;(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)))
|
||||
|
||||
;; Verify that source position information is not recorded if not
|
||||
;; asked for.
|
||||
(with-test-prefix "no positions"
|
||||
(pass-if "simple curly-infix list"
|
||||
(let ((sexp (with-read-options '(curly-infix)
|
||||
(lambda ()
|
||||
(read-string " {1 + 2 + 3}")))))
|
||||
(and (not (source-property sexp 'line))
|
||||
(not (source-property sexp 'column)))))
|
||||
(pass-if "mixed curly-infix list"
|
||||
(let ((sexp (with-read-options '(curly-infix)
|
||||
(lambda ()
|
||||
(read-string " {1 + 2 * 3}")))))
|
||||
(and (not (source-property sexp 'line))
|
||||
(not (source-property sexp 'column)))))
|
||||
(pass-if "singleton curly-infix list"
|
||||
(let ((sexp (with-read-options '(curly-infix)
|
||||
(lambda ()
|
||||
(read-string " { 1.0 }")))))
|
||||
(and (not (source-property sexp 'line))
|
||||
(not (source-property sexp 'column)))))
|
||||
(pass-if "neoteric expression"
|
||||
(let ((sexp (with-read-options '(curly-infix)
|
||||
(lambda ()
|
||||
(read-string " { f(x) }")))))
|
||||
(and (not (source-property sexp 'line))
|
||||
(not (source-property sexp 'column))))))
|
||||
|
||||
;; Verify that source position information is properly recorded.
|
||||
(with-test-prefix "positions"
|
||||
(pass-if "simple curly-infix list"
|
||||
(let ((sexp (with-read-options '(curly-infix positions)
|
||||
(lambda ()
|
||||
(read-string " {1 + 2 + 3}")))))
|
||||
(and (equal? (source-property sexp 'line) 0)
|
||||
(equal? (source-property sexp 'column) 1))))
|
||||
(pass-if "mixed curly-infix list"
|
||||
(let ((sexp (with-read-options '(curly-infix positions)
|
||||
(lambda ()
|
||||
(read-string " {1 + 2 * 3}")))))
|
||||
(and (equal? (source-property sexp 'line) 0)
|
||||
(equal? (source-property sexp 'column) 1))))
|
||||
(pass-if "singleton curly-infix list"
|
||||
(let ((sexp (with-read-options '(curly-infix positions)
|
||||
(lambda ()
|
||||
(read-string " { 1.0 }")))))
|
||||
(and (equal? (source-property sexp 'line) 0)
|
||||
(equal? (source-property sexp 'column) 3))))
|
||||
(pass-if "neoteric expression"
|
||||
(let ((sexp (with-read-options '(curly-infix positions)
|
||||
(lambda ()
|
||||
(read-string " { f(x) }")))))
|
||||
(and (equal? (source-property sexp 'line) 0)
|
||||
(equal? (source-property sexp 'column) 3)))))
|
||||
|
||||
;; Verify that neoteric expressions are recognized only within curly braces.
|
||||
(pass-if (equal? '(a(x)(y)) '(a (x) (y))))
|
||||
(pass-if (equal? '(x[a]) '(x [a])))
|
||||
(pass-if (equal? '(y[a b]) '(y [a b])))
|
||||
(pass-if (equal? '(a f{n - 1}) '(a f (- n 1))))
|
||||
(pass-if (equal? '(a f{n - 1}(x)) '(a f (- n 1) (x))))
|
||||
(pass-if (equal? '(a f{n - 1}[x]) '(a f (- n 1) [x])))
|
||||
(pass-if (equal? '(a f{n - 1}{y - 1}) '(a f (- n 1) (- y 1))))
|
||||
|
||||
;; Verify that bracket lists are not recognized by default.
|
||||
(pass-if (equal? '{[]} '()))
|
||||
(pass-if (equal? '{[a]} '(a)))
|
||||
(pass-if (equal? '{[a b]} '(a b)))
|
||||
(pass-if (equal? '{[a . b]} '(a . b)))
|
||||
(pass-if (equal? '[] '()))
|
||||
(pass-if (equal? '[a] '(a)))
|
||||
(pass-if (equal? '[a b] '(a b)))
|
||||
(pass-if (equal? '[a . b] '(a . b))))
|
||||
|
||||
|
||||
#!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)))
|
||||
|
||||
(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))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue