~ chicken-core (chicken-5) 8219c6ab02ec77d3e439d92ed02c2b228fb37f12
commit 8219c6ab02ec77d3e439d92ed02c2b228fb37f12
Author: LemonBoy <thatlemon@gmail.com>
AuthorDate: Sun Nov 12 19:04:21 2017 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Dec 13 11:45:44 2017 +0100
Make and-let* behave as specified in SRFI-2
When the body is missing the construction should return the last
expression that's been evaluated or the last variable that's been bound.
If there are no bindings and no body then #t is returned, like (and)
does.
Make sure the non-braced expressions refer to a variable and throw a
syntax error otherwise.
Signed-off-by: Peter Bex <peter@more-magic.net>
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 48a84726..d423371a 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -688,18 +688,25 @@
(##sys#check-syntax 'and-let* form '(_ #(_ 0) . _))
(let ((bindings (cadr form))
(body (cddr form)))
- (let fold ([bs bindings])
+ (let fold ([bs bindings] [last #t])
(if (null? bs)
- `(##core#begin ,@body)
+ `(##core#begin ,last . ,body)
(let ([b (car bs)]
[bs2 (cdr bs)] )
- (cond [(not (pair? b)) `(##core#if ,b ,(fold bs2) #f)]
- [(null? (cdr b)) `(##core#if ,(car b) ,(fold bs2) #f)]
+ (cond [(not (pair? b))
+ (##sys#check-syntax 'and-let* b 'symbol)
+ (let ((var (r (gensym))))
+ `(##core#let ((,var ,b))
+ (##core#if ,var ,(fold bs2 var) #f)))]
+ [(null? (cdr b))
+ (let ((var (r (gensym))))
+ `(##core#let ((,var ,(car b)))
+ (##core#if ,var ,(fold bs2 var) #f)))]
[else
(##sys#check-syntax 'and-let* b '(symbol _))
(let ((var (car b)))
`(##core#let ((,var ,(cadr b)))
- (##core#if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) ) ) ) )
+ (##core#if ,var ,(fold bs2 var) #f)))]))))))))
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index de754e95..9e750b17 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -914,6 +914,42 @@
(t 'foo (and-let* (((= 4 4)) (a 'foo)) a))
(t #f (and-let* ((a #f) ((error "not reached 1"))) (error "not reached 2")))
+(t (and-let* () 1) 1)
+(t (and-let* () 1 2) 2)
+(t (and-let* () ) #t)
+
+(t (let ((x #f)) (and-let* (x))) #f)
+(t (let ((x 1)) (and-let* (x))) 1)
+(t (and-let* ((x #f)) ) #f)
+(t (and-let* ((x 1)) ) 1)
+(f (eval '(and-let* ( #f (x 1))) ))
+(t (and-let* ( (#f) (x 1)) ) #f)
+(f (eval '(and-let* (2 (x 1))) ))
+(t (and-let* ( (2) (x 1)) ) 1)
+(t (and-let* ( (x 1) (2)) ) 2)
+(t (let ((x #f)) (and-let* (x) x)) #f)
+(t (let ((x "")) (and-let* (x) x)) "")
+(t (let ((x "")) (and-let* (x) )) "")
+(t (let ((x 1)) (and-let* (x) (+ x 1))) 2)
+(t (let ((x #f)) (and-let* (x) (+ x 1))) #f)
+(t (let ((x 1)) (and-let* (((positive? x))) (+ x 1))) 2)
+(t (let ((x 1)) (and-let* (((positive? x))) )) #t)
+(t (let ((x 0)) (and-let* (((positive? x))) (+ x 1))) #f)
+(t (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))) 3)
+; The uniqueness of the bindings isn't enforced
+(t (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))) 4)
+
+(t (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))) 2)
+(t (let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) 2)
+(t (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))) #f)
+(t (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))) #f)
+(t (let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) #f)
+
+(t (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
+(t (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
+(t (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f)
+(t (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) 3/2)
+
;;; SRFI-26
;; Cut
Trap