wingo pushed a commit to branch stable-2.0
in repository guile.
commit 57e877591532703714ec8ffb5aaefc378fc18423
Author: Taylan Ulrich Bayırlı/Kammer <[email protected]>
Date: Fri Oct 2 22:56:04 2015 +0200
Fix SRFI-2 (and-let*) implementation.
* module/ice-9/and-let-star.scm (%and-let*): Re-implemented this in a
more verbose but accurate way.
---
module/ice-9/and-let-star.scm | 52 ++++++++++++++++++++++++++++++-----------
1 file changed, 39 insertions(+), 13 deletions(-)
diff --git a/module/ice-9/and-let-star.scm b/module/ice-9/and-let-star.scm
index ff15a7a..2d53ff3 100644
--- a/module/ice-9/and-let-star.scm
+++ b/module/ice-9/and-let-star.scm
@@ -1,6 +1,7 @@
;;;; and-let-star.scm --- and-let* syntactic form (SRFI-2) for Guile
;;;;
-;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013,
+;;;; 2015 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
@@ -22,20 +23,45 @@
(define-syntax %and-let*
(lambda (form)
(syntax-case form ()
- ((_ orig-form ())
- #'#t)
- ((_ orig-form () body bodies ...)
- #'(begin body bodies ...))
- ((_ orig-form ((var exp) c ...) body ...)
+
+ ;; Handle zero-clauses special-case.
+ ((_ orig-form () . body)
+ #'(begin #t . body))
+
+ ;; Reduce clauses down to one regardless of body.
+ ((_ orig-form ((var expr) rest . rest*) . body)
+ (identifier? #'var)
+ #'(let ((var expr))
+ (and var (%and-let* orig-form (rest . rest*) . body))))
+ ((_ orig-form ((expr) rest . rest*) . body)
+ #'(and expr (%and-let* orig-form (rest . rest*) . body)))
+ ((_ orig-form (var rest . rest*) . body)
+ (identifier? #'var)
+ #'(and var (%and-let* orig-form (rest . rest*) . body)))
+
+ ;; Handle 1-clause cases without a body.
+ ((_ orig-form ((var expr)))
(identifier? #'var)
- #'(let ((var exp))
- (and var (%and-let* orig-form (c ...) body ...))))
- ((_ orig-form ((exp) c ...) body ...)
- #'(and exp (%and-let* orig-form (c ...) body ...)))
- ((_ orig-form (var c ...) body ...)
+ #'expr)
+ ((_ orig-form ((expr)))
+ #'expr)
+ ((_ orig-form (var))
(identifier? #'var)
- #'(and var (%and-let* orig-form (c ...) body ...)))
- ((_ orig-form (bad-clause c ...) body ...)
+ #'var)
+
+ ;; Handle 1-clause cases with a body.
+ ((_ orig-form ((var expr)) . body)
+ (identifier? #'var)
+ #'(let ((var expr))
+ (and var (begin . body))))
+ ((_ orig-form ((expr)) . body)
+ #'(and expr (begin . body)))
+ ((_ orig-form (var) . body)
+ (identifier? #'var)
+ #'(and var (begin . body)))
+
+ ;; Handle bad clauses.
+ ((_ orig-form (bad-clause . rest) . body)
(syntax-violation 'and-let* "Bad clause" #'orig-form #'bad-clause)))))
(define-syntax and-let*
