~ chicken-core (chicken-5) 5a27001de982c09874353ea263a0ef9683370bdd
commit 5a27001de982c09874353ea263a0ef9683370bdd
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Mon May 27 14:06:20 2013 +1200
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Wed May 29 22:27:02 2013 +0200
add => syntax for case clauses
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/expand.scm b/expand.scm
index b278ec04..3688fa25 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1174,6 +1174,7 @@
(body (cddr form)) )
(let ((tmp (r 'tmp))
(%or (r 'or))
+ (%=> (r '=>))
(%eqv? (r 'eqv?))
(%else (r 'else)))
`(let ((,tmp ,exp))
@@ -1185,7 +1186,10 @@
(##sys#check-syntax 'case clause '#(_ 1))
(cond ((c %else (car clause))
(expand rclauses #t)
- `(##core#begin ,@(cdr clause)) )
+ (if (and (fx= (length clause) 3) ; (else => expr)
+ (c %=> (cadr clause)))
+ `(,(caddr clause) ,tmp)
+ `(##core#begin ,@(cdr clause))))
(else?
(##sys#notice
"non-`else' clause following `else' clause in `case'"
@@ -1196,7 +1200,10 @@
`(##core#if (,%or ,@(##sys#map
(lambda (x) `(,%eqv? ,tmp ',x))
(car clause)))
- (##core#begin ,@(cdr clause))
+ ,(if (and (fx= (length clause) 3) ; ((...) => expr)
+ (c %=> (cadr clause)))
+ `(,(caddr clause) ,tmp)
+ `(##core#begin ,@(cdr clause)))
,(expand rclauses #f) ) ) ) ) ) ) ) ) ) ) ) )
(##sys#extend-macro-environment
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index c0f6ebda..84a95d13 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -57,6 +57,14 @@
(exit 1)))
(newline))
+(SECTION 4 2 1)
+
+;; case with => clause
+(test "a" (lambda () (case 'a ((a) => symbol->string))))
+(test "a" (lambda () (case 'a (else => symbol->string))))
+(test-error condition? (lambda () (case 'a ((a) =>))))
+(test-error condition? (lambda () (case 'a (else =>))))
+
(SECTION 4 2 5)
Trap