[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Improved source properties and errors; => within case
|
From: |
Mark H Weaver |
|
Subject: |
[PATCH] Improved source properties and errors; => within case |
|
Date: |
Wed, 08 Feb 2012 04:09:14 -0500 |
Hello all,
Here's a preliminary patch set to do the following:
* Add support for '=>' within 'case' as mandated by the R7RS draft.
* Add support in 'read' to set source properties for vectors,
bytevectors, bitvectors, srfi-4 vectors, arrays, and non-empty
strings.
* Reimplement 'cond' and 'case' using syntax-case.
* Improve error messages for syntax errors in 'cond' and 'case'.
* Compile-time warnings for duplicate datums in 'case'.
* Compile-time warnings for some types of datums in 'case' that cannot
be meaningfully compared using 'eqv?' (strings, generalized vectors,
and arrays).
* Remove 'inline' and 'register' attributes from read.c.
Comments and suggestions solicited.
Thanks,
Mark
>From 672e15f5cddd4a203b2e6e38c289f2127078b143 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Wed, 8 Feb 2012 03:00:15 -0500
Subject: [PATCH 1/5] Remove inline and register attributes from read.c
* libguile/read.c: Remove all 'inline' and 'register' attributes.
---
libguile/read.c | 28 ++++++++++++++--------------
1 files changed, 14 insertions(+), 14 deletions(-)
diff --git a/libguile/read.c b/libguile/read.c
index 6166724..fc5aaf8 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -1,5 +1,5 @@
-/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008,
2009, 2010, 2011 Free Software
- * Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2003, 2004, 2006,
+ * 2007, 2008, 2009, 2010, 2011, 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
@@ -142,13 +142,13 @@ SCM_DEFINE (scm_read_options, "read-options-interface",
0, 1, 0,
characters to procedures. */
static SCM *scm_i_read_hash_procedures;
-static inline SCM
+static SCM
scm_i_read_hash_procedures_ref (void)
{
return scm_fluid_ref (*scm_i_read_hash_procedures);
}
-static inline void
+static void
scm_i_read_hash_procedures_set_x (SCM value)
{
scm_fluid_set_x (*scm_i_read_hash_procedures, value);
@@ -197,7 +197,7 @@ scm_i_read_hash_procedures_set_x (SCM value)
|| ((_chr) == 'd') || ((_chr) == 'l'))
/* Read an SCSH block comment. */
-static inline SCM scm_read_scsh_block_comment (scm_t_wchar, SCM);
+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);
static SCM scm_read_shebang (scm_t_wchar, SCM);
@@ -207,7 +207,7 @@ static SCM scm_get_hash_procedure (int);
result in the pre-allocated buffer BUF. Return zero if the whole token has
fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number
of
bytes actually read. */
-static inline int
+static int
read_token (SCM port, char *buf, const size_t buf_size, size_t *read)
{
*read = 0;
@@ -286,7 +286,7 @@ read_complete_token (SCM port, char *buffer, const size_t
buffer_size,
static int
flush_ws (SCM port, const char *eoferr)
{
- register scm_t_wchar c;
+ scm_t_wchar c;
while (1)
switch (c = scm_getc (port))
{
@@ -836,7 +836,7 @@ scm_read_syntax (int chr, SCM port)
return p;
}
-static inline SCM
+static SCM
scm_read_nil (int chr, SCM port)
{
SCM id = scm_read_mixed_case_symbol (chr, port);
@@ -849,7 +849,7 @@ scm_read_nil (int chr, SCM port)
return SCM_ELISP_NIL;
}
-static inline SCM
+static SCM
scm_read_semicolon_comment (int chr, SCM port)
{
int c;
@@ -990,7 +990,7 @@ scm_read_character (scm_t_wchar chr, SCM port)
}
#undef FUNC_NAME
-static inline SCM
+static SCM
scm_read_keyword (int chr, SCM port)
{
SCM symbol;
@@ -1009,7 +1009,7 @@ scm_read_keyword (int chr, SCM port)
return (scm_symbol_to_keyword (symbol));
}
-static inline SCM
+static SCM
scm_read_vector (int chr, SCM port)
{
/* Note: We call `scm_read_sexp ()' rather than READER here in order to
@@ -1019,7 +1019,7 @@ scm_read_vector (int chr, SCM port)
return (scm_vector (scm_read_sexp (chr, port)));
}
-static inline SCM
+static SCM
scm_read_srfi4_vector (int chr, SCM port)
{
return scm_i_read_array (port, chr);
@@ -1069,7 +1069,7 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port)
return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
}
-static inline SCM
+static SCM
scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
{
int bang_seen = 0;
@@ -1415,7 +1415,7 @@ scm_read_expression (SCM port)
{
while (1)
{
- register scm_t_wchar chr;
+ scm_t_wchar chr;
chr = scm_getc (port);
--
1.7.5.4
>From aac5ab0cda76e91e2735dfa929dfcd53c43c7841 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Wed, 8 Feb 2012 03:10:11 -0500
Subject: [PATCH 2/5] Add and use maybe_annotate_source helper in read.c
* libguile/read.c (maybe_annotate_source): New static helper function.
(scm_read_sexp, scm_read_quote, scm_read_syntax): Use
'maybe_annotate_source'.
---
libguile/read.c | 23 +++++++++++------------
1 files changed, 11 insertions(+), 12 deletions(-)
diff --git a/libguile/read.c b/libguile/read.c
index fc5aaf8..0af1822 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -360,6 +360,14 @@ static SCM scm_read_sharp (int chr, SCM port);
static SCM
+maybe_annotate_source (SCM x, SCM port, long line, int column)
+{
+ if (SCM_RECORD_POSITIONS_P)
+ scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port));
+ return x;
+}
+
+static SCM
scm_read_sexp (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_i_lreadparen"
{
@@ -423,10 +431,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
}
exit:
- if (SCM_RECORD_POSITIONS_P)
- scm_i_set_source_properties_x (ans, line, column, SCM_FILENAME (port));
-
- return ans;
+ return maybe_annotate_source (ans, port, line, column);
}
#undef FUNC_NAME
@@ -780,10 +785,7 @@ scm_read_quote (int chr, SCM port)
}
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
- if (SCM_RECORD_POSITIONS_P)
- scm_i_set_source_properties_x (p, line, column, SCM_FILENAME (port));
-
- return p;
+ return maybe_annotate_source (p, port, line, column);
}
SCM_SYMBOL (sym_syntax, "syntax");
@@ -830,10 +832,7 @@ scm_read_syntax (int chr, SCM port)
}
p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
- if (SCM_RECORD_POSITIONS_P)
- scm_i_set_source_properties_x (p, line, column, SCM_FILENAME (port));
-
- return p;
+ return maybe_annotate_source (p, port, line, column);
}
static SCM
--
1.7.5.4
>From 1aee9e4eb47e7996a3a99e92afcc5566684374db Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Wed, 8 Feb 2012 03:14:17 -0500
Subject: [PATCH 3/5] Remove incorrect comment in read.c
* libguile/read.c (scm_read_sharp): Remove incorrect comment that
incorrectly claims that scm_read_boolean might return a SRFI-4 vector.
---
libguile/read.c | 1 -
1 files changed, 0 insertions(+), 1 deletions(-)
diff --git a/libguile/read.c b/libguile/read.c
index 0af1822..4cdde4a 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -1331,7 +1331,6 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
case 't':
case 'T':
case 'F':
- /* This one may return either a boolean or an SRFI-4 vector. */
return (scm_read_boolean (chr, port));
case ':':
return (scm_read_keyword (chr, port));
--
1.7.5.4
>From 8838a4d76bc4deeafd7fd9bd9d438c66e1f6abae Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Wed, 8 Feb 2012 03:24:10 -0500
Subject: [PATCH 4/5] Add source properties to many more types of data
* libguile/read.c (scm_read_array): New internal helper that
calls scm_i_read_array and sets its source property if the
'positions' reader option is set.
(scm_read_string): Set source properties on non-empty strings if the
'positions' reader option is set.
(scm_read_vector, scm_read_srfi4_vector, scm_read_bytevector,
scm_read_guile_bitvector, scm_read_sharp): Add new arguments for the
'line' and 'column' of the first character of the datum being read.
Set source properties if the 'positions' reader option is set.
(scm_read_expression): Pass 'line' and 'column' to scm_read_sharp.
* doc/ref/api-debug.texi (Source Properties): Update manual.
---
doc/ref/api-debug.texi | 12 ++++----
libguile/read.c | 66 ++++++++++++++++++++++++++++++-----------------
2 files changed, 48 insertions(+), 30 deletions(-)
diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index cf9ea5a..d036460 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -239,10 +239,10 @@ Guile's debugger can point back to the file and location
where the
expression originated.
The way that source properties are stored means that Guile can only
-associate source properties with parenthesized expressions, and not, for
-example, with individual symbols, numbers or strings. The difference
-can be seen by typing @code{(xxx)} and @code{xxx} at the Guile prompt
-(where the variable @code{xxx} has not been defined):
+associate source properties with parenthesized expressions and non-empty
+strings, and not, for example, with individual symbols or numbers. The
+difference can be seen by typing @code{(xxx)} and @code{xxx} at the
+Guile prompt (where the variable @code{xxx} has not been defined):
@example
scheme@@(guile-user)> (xxx)
@@ -288,8 +288,8 @@ Return the property specified by @var{key} from @var{obj}'s
source
properties.
@end deffn
-If the @code{positions} reader option is enabled, each parenthesized
-expression will have values set for the @code{filename}, @code{line} and
+If the @code{positions} reader option is enabled, supported expressions
+will have values set for the @code{filename}, @code{line} and
@code{column} properties.
Source properties are also associated with syntax objects. Procedural
diff --git a/libguile/read.c b/libguile/read.c
index 4cdde4a..aa6d439 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -356,8 +356,7 @@ flush_ws (SCM port, const char *eoferr)
/* Token readers. */
static SCM scm_read_expression (SCM port);
-static SCM scm_read_sharp (int chr, SCM port);
-
+static SCM scm_read_sharp (int chr, SCM port, long line, int column);
static SCM
maybe_annotate_source (SCM x, SCM port, long line, int column)
@@ -497,6 +496,10 @@ scm_read_string (int chr, SCM port)
unsigned c_str_len = 0;
scm_t_wchar c;
+ /* Need to capture line and column numbers here. */
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
while ('"' != (c = scm_getc (port)))
{
@@ -582,11 +585,10 @@ scm_read_string (int chr, SCM port)
}
if (c_str_len > 0)
- {
- return scm_i_substring_copy (str, 0, c_str_len);
- }
-
- return scm_nullstr;
+ return maybe_annotate_source (scm_i_substring_copy (str, 0, c_str_len),
+ port, line, column);
+ else
+ return scm_nullstr;
}
#undef FUNC_NAME
@@ -1009,23 +1011,34 @@ scm_read_keyword (int chr, SCM port)
}
static SCM
-scm_read_vector (int chr, SCM port)
+scm_read_vector (int chr, SCM port, long line, int column)
{
/* Note: We call `scm_read_sexp ()' rather than READER here in order to
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 (scm_vector (scm_read_sexp (chr, port)));
+ return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port)),
+ port, line, column);
+}
+
+static SCM
+scm_read_array (int chr, SCM port, long line, int column)
+{
+ SCM result = scm_i_read_array (port, chr);
+ if (scm_is_false (result))
+ return result;
+ else
+ return maybe_annotate_source (result, port, line, column);
}
static SCM
-scm_read_srfi4_vector (int chr, SCM port)
+scm_read_srfi4_vector (int chr, SCM port, long line, int column)
{
- return scm_i_read_array (port, chr);
+ return scm_read_array (chr, port, line, column);
}
static SCM
-scm_read_bytevector (scm_t_wchar chr, SCM port)
+scm_read_bytevector (scm_t_wchar chr, SCM port, long line, int column)
{
chr = scm_getc (port);
if (chr != 'u')
@@ -1039,7 +1052,9 @@ scm_read_bytevector (scm_t_wchar chr, SCM port)
if (chr != '(')
goto syntax;
- return scm_u8_list_to_bytevector (scm_read_sexp (chr, port));
+ return maybe_annotate_source
+ (scm_u8_list_to_bytevector (scm_read_sexp (chr, port)),
+ port, line, column);
syntax:
scm_i_input_error ("read_bytevector", port,
@@ -1049,7 +1064,7 @@ scm_read_bytevector (scm_t_wchar chr, SCM port)
}
static SCM
-scm_read_guile_bit_vector (scm_t_wchar chr, SCM port)
+scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, long line, int column)
{
/* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
terribly inefficient but who cares? */
@@ -1065,7 +1080,9 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port)
if (chr != EOF)
scm_ungetc (chr, port);
- return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
+ return maybe_annotate_source
+ (scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)),
+ port, line, column);
}
static SCM
@@ -1301,7 +1318,7 @@ scm_read_sharp_extension (int chr, SCM port)
/* The reader for the sharp `#' character. It basically dispatches reads
among the above token readers. */
static SCM
-scm_read_sharp (scm_t_wchar chr, SCM port)
+scm_read_sharp (scm_t_wchar chr, SCM port, long line, int column)
#define FUNC_NAME "scm_lreadr"
{
SCM result;
@@ -1317,17 +1334,17 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
case '\\':
return (scm_read_character (chr, port));
case '(':
- return (scm_read_vector (chr, port));
+ return (scm_read_vector (chr, port, line, column));
case 's':
case 'u':
case 'f':
case 'c':
/* This one may return either a boolean or an SRFI-4 vector. */
- return (scm_read_srfi4_vector (chr, port));
+ return (scm_read_srfi4_vector (chr, port, line, column));
case 'v':
- return (scm_read_bytevector (chr, port));
+ return (scm_read_bytevector (chr, port, line, column));
case '*':
- return (scm_read_guile_bit_vector (chr, port));
+ return (scm_read_guile_bit_vector (chr, port, line, column));
case 't':
case 'T':
case 'F':
@@ -1344,7 +1361,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
case 'h':
case 'l':
#endif
- return (scm_i_read_array (port, chr));
+ return (scm_read_array (chr, port, line, column));
case 'i':
case 'e':
@@ -1356,7 +1373,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port)
if (next_c != EOF)
scm_ungetc (next_c, port);
if (next_c == '(')
- return scm_i_read_array (port, chr);
+ return scm_read_array (chr, port, line, column);
/* Fall through. */
}
#endif
@@ -1439,8 +1456,9 @@ scm_read_expression (SCM port)
return (scm_read_quote (chr, port));
case '#':
{
- SCM result;
- result = scm_read_sharp (chr, port);
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+ SCM result = scm_read_sharp (chr, port, line, column);
if (scm_is_eq (result, SCM_UNSPECIFIED))
/* We read a comment or some such. */
break;
--
1.7.5.4
>From 849b96dd703315db31f41e01f10a1140391f82c1 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Tue, 7 Feb 2012 19:40:29 -0500
Subject: [PATCH 5/5] Support => within case, and improve error messages for
cond and case
* module/ice-9/boot-9.scm (cond, case): Reimplement using syntax-case,
with improved error messages and support for '=>' within 'case' as
mandated by the R7RS. Add warnings for duplicate case datums and
case datums that cannot be meaningfully compared using 'eqv?'.
* test-suite/tests/syntax.test (cond, case): Update tests to reflect
improved error reporting. Add tests for '=>' within 'case'.
* module/system/base/message.scm (%warning-types): Add 'bad-case-datum'
and 'duplicate-case-datum' warning types.
* doc/ref/api-control.texi (Conditionals): Document '=>' within 'case'.
---
doc/ref/api-control.texi | 19 ++++-
module/ice-9/boot-9.scm | 192 ++++++++++++++++++++++++++++------------
module/system/base/message.scm | 14 +++
test-suite/tests/syntax.test | 77 +++++++++++++----
4 files changed, 227 insertions(+), 75 deletions(-)
diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi
index fc59350..ca7ad4a 100644
--- a/doc/ref/api-control.texi
+++ b/doc/ref/api-control.texi
@@ -212,18 +212,30 @@ result of the @code{cond}-expression.
@end deffn
@deffn syntax case key clause1 clause2 @dots{}
address@hidden may be any expression, the @var{clause}s must have the form
address@hidden may be any expression, and the @var{clause}s must have the form
@lisp
((@var{datum1} @dots{}) @var{expr1} @var{expr2} @dots{})
@end lisp
+or
+
address@hidden
+((@var{datum1} @dots{}) => @var{expression})
address@hidden lisp
+
and the last @var{clause} may have the form
@lisp
(else @var{expr1} @var{expr2} @dots{})
@end lisp
+or
+
address@hidden
+(else => @var{expression})
address@hidden lisp
+
All @var{datum}s must be distinct. First, @var{key} is evaluated. The
result of this evaluation is compared against all @var{datum} values using
@code{eqv?}. When this comparison succeeds, the expression(s) following
@@ -234,6 +246,11 @@ If the @var{key} matches no @var{datum} and there is an
@code{else}-clause, the expressions following the @code{else} are
evaluated. If there is no such clause, the result of the expression is
unspecified.
+
+For the @code{=>} clause types, @var{expression} is evaluated and the
+resulting procedure is applied to the value of @var{key}. The result of
+this procedure application is then the result of the
address@hidden
@end deffn
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index d1bbd95..41ce924 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -411,70 +411,150 @@ If there is no handler at all, Guile prints an error and
then exits."
((_ x) x)
((_ x y ...) (let ((t x)) (if t t (or y ...))))))
+(include-from-path "ice-9/quasisyntax")
+
(define-syntax-rule (when test stmt stmt* ...)
(if test (begin stmt stmt* ...)))
(define-syntax-rule (unless test stmt stmt* ...)
(if (not test) (begin stmt stmt* ...)))
-;; The "maybe-more" bits are something of a hack, so that we can support
-;; SRFI-61. Rewrites into a standalone syntax-case macro would be
-;; appreciated.
(define-syntax cond
- (syntax-rules (=> else)
- ((_ "maybe-more" test consequent)
- (if test consequent))
-
- ((_ "maybe-more" test consequent clause ...)
- (if test consequent (cond clause ...)))
-
- ((_ (else else1 else2 ...))
- (begin else1 else2 ...))
-
- ((_ (test => receiver) more-clause ...)
- (let ((t test))
- (cond "maybe-more" t (receiver t) more-clause ...)))
-
- ((_ (generator guard => receiver) more-clause ...)
- (call-with-values (lambda () generator)
- (lambda t
- (cond "maybe-more"
- (apply guard t) (apply receiver t) more-clause ...))))
-
- ((_ (test => receiver ...) more-clause ...)
- (syntax-violation 'cond "wrong number of receiver expressions"
- '(test => receiver ...)))
- ((_ (generator guard => receiver ...) more-clause ...)
- (syntax-violation 'cond "wrong number of receiver expressions"
- '(generator guard => receiver ...)))
-
- ((_ (test) more-clause ...)
- (let ((t test))
- (cond "maybe-more" t t more-clause ...)))
-
- ((_ (test body1 body2 ...) more-clause ...)
- (cond "maybe-more"
- test (begin body1 body2 ...) more-clause ...))))
+ (lambda (whole-expr)
+ (define (fold f seed xs)
+ (let loop ((xs xs) (seed seed))
+ (if (null? xs) seed
+ (loop (cdr xs) (f (car xs) seed)))))
+ (define (reverse-map f xs)
+ (fold (lambda (x seed) (cons (f x) seed))
+ '() xs))
+ (syntax-case whole-expr ()
+ ((_ clause clauses ...)
+ #`(begin
+ #,@(fold (lambda (clause-builder tail)
+ (clause-builder tail))
+ #'()
+ (reverse-map
+ (lambda (clause)
+ (define* (bad-clause #:optional (msg "invalid clause"))
+ (syntax-violation 'cond msg whole-expr clause))
+ (syntax-case clause (=> else)
+ ((else e e* ...)
+ (lambda (tail)
+ (if (null? tail)
+ #'((begin e e* ...))
+ (bad-clause "else must be the last clause"))))
+ ((else . _) (bad-clause))
+ ((test => receiver)
+ (lambda (tail)
+ #`((let ((t test))
+ (if t
+ (receiver t)
+ #,@tail)))))
+ ((test => receiver ...)
+ (bad-clause "wrong number of receiver expressions"))
+ ((generator guard => receiver)
+ (lambda (tail)
+ #`((call-with-values (lambda () generator)
+ (lambda vals
+ (if (apply guard vals)
+ (apply receiver vals)
+ #,@tail))))))
+ ((generator guard => receiver ...)
+ (bad-clause "wrong number of receiver expressions"))
+ ((test)
+ (lambda (tail)
+ #`((let ((t test))
+ (if t t #,@tail)))))
+ ((test e e* ...)
+ (lambda (tail)
+ #`((if test
+ (begin e e* ...)
+ #,@tail))))
+ (_ (bad-clause))))
+ #'(clause clauses ...))))))))
(define-syntax case
- (syntax-rules (else)
- ((case (key ...)
- clauses ...)
- (let ((atom-key (key ...)))
- (case atom-key clauses ...)))
- ((case key
- (else result1 result2 ...))
- (begin result1 result2 ...))
- ((case key
- ((atoms ...) result1 result2 ...))
- (if (memv key '(atoms ...))
- (begin result1 result2 ...)))
- ((case key
- ((atoms ...) result1 result2 ...)
- clause clauses ...)
- (if (memv key '(atoms ...))
- (begin result1 result2 ...)
- (case key clause clauses ...)))))
+ (lambda (whole-expr)
+ (define (fold f seed xs)
+ (let loop ((xs xs) (seed seed))
+ (if (null? xs) seed
+ (loop (cdr xs) (f (car xs) seed)))))
+ (define (fold2 f a b xs)
+ (let loop ((xs xs) (a a) (b b))
+ (if (null? xs) (values a b)
+ (call-with-values
+ (lambda () (f (car xs) a b))
+ (lambda (a b)
+ (loop (cdr xs) a b))))))
+ (define (reverse-map-with-seed f seed xs)
+ (fold2 (lambda (x ys seed)
+ (call-with-values
+ (lambda () (f x seed))
+ (lambda (y seed)
+ (values (cons y ys) seed))))
+ '() seed xs))
+ (syntax-case whole-expr ()
+ ((_ expr clause clauses ...)
+ (with-syntax ((key #'key))
+ #`(let ((key expr))
+ #,@(fold
+ (lambda (clause-builder tail)
+ (clause-builder tail))
+ #'()
+ (reverse-map-with-seed
+ (lambda (clause seen)
+ (define* (bad-clause #:optional (msg "invalid clause"))
+ (syntax-violation 'case msg whole-expr clause))
+ (syntax-case clause ()
+ ((test . rest)
+ (with-syntax
+ ((clause-expr
+ (syntax-case #'rest (=>)
+ ((=> receiver) #'(receiver key))
+ ((=> receiver ...)
+ (bad-clause
+ "wrong number of receiver expressions"))
+ ((e e* ...) #'(begin e e* ...))
+ (_ (bad-clause)))))
+ (syntax-case #'test (else)
+ ((datums ...)
+ (let ((seen
+ (fold
+ (lambda (datum seen)
+ (define (warn-datum type)
+ ((@ (system base message)
+ warning)
+ type
+ (append (source-properties datum)
+ (source-properties
+ (syntax->datum #'test)))
+ datum
+ (syntax->datum clause)
+ (syntax->datum whole-expr)))
+ (if (memv datum seen)
+ (warn-datum 'duplicate-case-datum))
+ (if (or (pair? datum)
+ (array? datum)
+ (generalized-vector? datum))
+ (warn-datum 'bad-case-datum))
+ (cons datum seen))
+ seen
+ (map syntax->datum #'(datums ...)))))
+ (values (lambda (tail)
+ #`((if (memv key '(datums ...))
+ clause-expr
+ #,@tail)))
+ seen)))
+ (else (values (lambda (tail)
+ (if (null? tail)
+ #'(clause-expr)
+ (bad-clause
+ "else must be the last
clause")))
+ seen))
+ (_ (bad-clause)))))
+ (_ (bad-clause))))
+ '() #'(clause clauses ...)))))))))
(define-syntax do
(syntax-rules ()
@@ -502,8 +582,6 @@ If there is no handler at all, Guile prints an error and
then exits."
(define-syntax-rule (delay exp)
(make-promise (lambda () exp)))
-(include-from-path "ice-9/quasisyntax")
-
(define-syntax current-source-location
(lambda (x)
(syntax-case x ()
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 8cf285a..9accf71 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -126,6 +126,20 @@
"~A: warning: possibly wrong number of arguments to
`~A'~%"
loc name))))
+ (duplicate-case-datum
+ "report a duplicate datum in a case expression"
+ ,(lambda (port loc datum clause case-expr)
+ (emit port
+ "~A: warning: duplicate datum ~S in clause ~S of case
expression ~S~%"
+ loc datum clause case-expr)))
+
+ (bad-case-datum
+ "report a case datum that cannot be meaningfully compared using
`eqv?'"
+ ,(lambda (port loc datum clause case-expr)
+ (emit port
+ "~A: warning: datum ~S cannot be meaningfully compared
using `eqv?' in clause ~S of case expression ~S~%"
+ loc datum clause case-expr)))
+
(format
"report wrong number of arguments to `format'"
,(lambda (port loc . rest)
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index fcc0349..cdaee71 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -648,11 +648,13 @@
(pass-if-syntax-error "missing recipient"
'(cond . "wrong number of receiver expressions")
- (cond (#t identity =>)))
+ (eval '(cond (#t identity =>))
+ (interaction-environment)))
(pass-if-syntax-error "extra recipient"
'(cond . "wrong number of receiver expressions")
- (cond (#t identity => identity identity))))
+ (eval '(cond (#t identity => identity identity))
+ (interaction-environment))))
(with-test-prefix "bad or missing clauses"
@@ -662,43 +664,48 @@
(interaction-environment)))
(pass-if-syntax-error "(cond #t)"
- exception:generic-syncase-error
+ '(cond . "invalid clause")
(eval '(cond #t)
(interaction-environment)))
(pass-if-syntax-error "(cond 1)"
- exception:generic-syncase-error
+ '(cond . "invalid clause")
(eval '(cond 1)
(interaction-environment)))
(pass-if-syntax-error "(cond 1 2)"
- exception:generic-syncase-error
+ '(cond . "invalid clause")
(eval '(cond 1 2)
(interaction-environment)))
(pass-if-syntax-error "(cond 1 2 3)"
- exception:generic-syncase-error
+ '(cond . "invalid clause")
(eval '(cond 1 2 3)
(interaction-environment)))
(pass-if-syntax-error "(cond 1 2 3 4)"
- exception:generic-syncase-error
+ '(cond . "invalid clause")
(eval '(cond 1 2 3 4)
(interaction-environment)))
(pass-if-syntax-error "(cond ())"
- exception:generic-syncase-error
+ '(cond . "invalid clause")
(eval '(cond ())
(interaction-environment)))
(pass-if-syntax-error "(cond () 1)"
- exception:generic-syncase-error
+ '(cond . "invalid clause")
(eval '(cond () 1)
(interaction-environment)))
(pass-if-syntax-error "(cond (1) 1)"
- exception:generic-syncase-error
+ '(cond . "invalid clause")
(eval '(cond (1) 1)
+ (interaction-environment)))
+
+ (pass-if-syntax-error "(cond (else #f) (#t #t))"
+ '(cond . "else must be the last clause")
+ (eval '(cond (else #f) (#t #t))
(interaction-environment))))
(with-test-prefix "wrong number of arguments"
@@ -712,10 +719,46 @@
(pass-if "clause with empty labels list"
(case 1 (() #f) (else #t)))
+ (with-test-prefix "case handles '=> correctly"
+
+ (pass-if "(1 2 3) => list"
+ (equal? (case 1 ((1 2 3) => list))
+ '(1)))
+
+ (pass-if "else => list"
+ (equal? (case 6
+ ((1 2 3) 'wrong)
+ (else => list))
+ '(6)))
+
+ (with-test-prefix "bound '=> is handled correctly"
+
+ (pass-if "(1) => 'ok"
+ (let ((=> 'foo))
+ (eq? (case 1 ((1) => 'ok)) 'ok)))
+
+ (pass-if "else =>"
+ (let ((=> 'foo))
+ (eq? (case 1 (else =>)) 'foo)))
+
+ (pass-if "else => list"
+ (let ((=> 'foo))
+ (eq? (case 1 (else => identity)) identity))))
+
+ (pass-if-syntax-error "missing recipient"
+ '(case . "wrong number of receiver expressions")
+ (eval '(case 1 ((1) =>))
+ (interaction-environment)))
+
+ (pass-if-syntax-error "extra recipient"
+ '(case . "wrong number of receiver expressions")
+ (eval '(case 1 ((1) => identity identity))
+ (interaction-environment))))
+
(with-test-prefix "case is hygienic"
(pass-if-syntax-error "bound 'else is handled correctly"
- exception:generic-syncase-error
+ '(case . "invalid clause")
(eval '(let ((else #f)) (case 1 (else #f)))
(interaction-environment))))
@@ -742,22 +785,22 @@
(interaction-environment)))
(pass-if-syntax-error "(case 1 \"foo\")"
- exception:generic-syncase-error
+ '(case . "invalid clause")
(eval '(case 1 "foo")
(interaction-environment)))
(pass-if-syntax-error "(case 1 ())"
- exception:generic-syncase-error
+ '(case . "invalid clause")
(eval '(case 1 ())
(interaction-environment)))
(pass-if-syntax-error "(case 1 (\"foo\"))"
- exception:generic-syncase-error
+ '(case . "invalid clause")
(eval '(case 1 ("foo"))
(interaction-environment)))
(pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))"
- exception:generic-syncase-error
+ '(case . "invalid clause")
(eval '(case 1 ("foo" "bar"))
(interaction-environment)))
@@ -767,7 +810,7 @@
(interaction-environment)))
(pass-if-syntax-error "(case 1 ((2) \"bar\") (else))"
- exception:generic-syncase-error
+ '(case . "invalid clause")
(eval '(case 1 ((2) "bar") (else))
(interaction-environment)))
@@ -777,7 +820,7 @@
(interaction-environment)))
(pass-if-syntax-error "(case 1 (else #f) ((1) #t))"
- exception:generic-syncase-error
+ '(case . "else must be the last clause")
(eval '(case 1 (else #f) ((1) #t))
(interaction-environment)))))
--
1.7.5.4