* Evan Hanson <ev...@foldling.org> [130527 09:20]:
> On 2013/05/26 09:41P, Evan Hanson wrote:
> > The attached patch adds support and basic tests for case clauses
> > containing `=>` patterns (R7RS 4.2.1).
>
> I just noticed the two comments in this patch are inverted; please find
> attached a hand-munged version with this fixed, and sorry for the noise.
Thanks, this one looks fine to me, please find a signed off version attached.
This should go in.
Cheers,
Christian
--
In the world, there is nothing more submissive and weak than
water. Yet for attacking that which is hard and strong, nothing can
surpass it. --- Lao Tzu
>From 67bbafb61f00730853385e54f30e7a3b90fad01d Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
Date: Mon, 27 May 2013 14:06:20 +1200
Subject: [PATCH] add => syntax for case clauses
Signed-off-by: Christian Kellermann <ck...@pestilenz.org>
---
expand.scm | 11 +++++++++--
tests/r7rs-tests.scm | 8 ++++++++
2 files changed, 17 insertions(+), 2 deletions(-)
diff --git a/expand.scm b/expand.scm
index b278ec0..3688fa2 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 c0f6ebd..84a95d1 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)
--
1.8.1.2
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
