Andy Wingo <wi...@pobox.com> writes:
> Please fix the commit log. Thanks :)
Whoops, here we go:
>From 232757c7f99d39beb16a09cd81a94670f6249ba2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<taylanbayi...@gmail.com>
Date: Fri, 2 Oct 2015 22:56:04 +0200
Subject: [PATCH 1/2] 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*
--
2.8.4
>From 527bc1821a4ce1cd007c2f07355eebd196a753cc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
<taylanbayi...@gmail.com>
Date: Sat, 3 Oct 2015 11:39:27 +0200
Subject: [PATCH 2/2] Add SRFI-2 (and-let*) test suite.
* test-suite/tests/srfi-2.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add it.
---
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-2.test | 77 ++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 78 insertions(+)
create mode 100644 test-suite/tests/srfi-2.test
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3b10353..c0c79cb 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -125,6 +125,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/sort.test \
tests/srcprop.test \
tests/srfi-1.test \
+ tests/srfi-2.test \
tests/srfi-6.test \
tests/srfi-10.test \
tests/srfi-11.test \
diff --git a/test-suite/tests/srfi-2.test b/test-suite/tests/srfi-2.test
new file mode 100644
index 0000000..b8de21d
--- /dev/null
+++ b/test-suite/tests/srfi-2.test
@@ -0,0 +1,77 @@
+;;;; srfi-2.test --- Test suite for Guile's and-let* macro. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-2)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-2))
+
+(pass-if-equal 1 (and-let* () 1))
+(pass-if-equal 2 (and-let* () 1 2))
+(pass-if-equal #t (and-let* ()))
+
+(pass-if-equal #f (let ((x #f)) (and-let* (x))))
+(pass-if-equal 1 (let ((x 1)) (and-let* (x))))
+(pass-if-equal #f (and-let* ((x #f))))
+(pass-if-equal 1 (and-let* ((x 1))))
+(pass-if-exception "bad clause" '(syntax-error . "Bad clause")
+ (eval '(and-let* (#f (x 1))) (current-module)))
+(pass-if-equal #f (and-let* ((#f) (x 1))))
+(pass-if-exception "bad clause" '(syntax-error . "Bad clause")
+ (eval '(and-let* (2 (x 1))) (current-module)))
+(pass-if-equal 1 (and-let* ((2) (x 1))))
+(pass-if-equal 2 (and-let* ((x 1) (2))))
+(pass-if-equal #f (let ((x #f)) (and-let* (x) x)))
+(pass-if-equal "" (let ((x "")) (and-let* (x) x)))
+(pass-if-equal "" (let ((x "")) (and-let* (x))))
+(pass-if-equal 2 (let ((x 1)) (and-let* (x) (+ x 1))))
+(pass-if-equal #f (let ((x #f)) (and-let* (x) (+ x 1))))
+(pass-if-equal 2 (let ((x 1)) (and-let* (((positive? x))) (+ x 1))))
+(pass-if-equal #t (let ((x 1)) (and-let* (((positive? x))))))
+(pass-if-equal #f (let ((x 0)) (and-let* (((positive? x))) (+ x 1))))
+(pass-if-equal 3
+ (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))))
+
+;; This is marked as must-be-error in the original test suite, but
+;; that's a mistake of the SRFI author who thinks that rebinding
+;; variables in let* is an error; in fact it's allowed in let*
+;; (explicitly since R6RS), so it should be allowed by and-let* too.
+(pass-if-equal 4
+ (let ((x 1))
+ (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1))))
+
+(pass-if-equal 2
+ (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))))
+(pass-if-equal 2
+ (let ((x 1)) (and-let* (((begin x)) ((positive? x))) (+ x 1))))
+(pass-if-equal #f
+ (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))))
+(pass-if-equal #f
+ (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))))
+(pass-if-equal #f
+ (let ((x #f)) (and-let* (((begin x)) ((positive? x))) (+ x 1))))
+
+(pass-if-equal #f
+ (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+(pass-if-equal #f
+ (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+(pass-if-equal #f
+ (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+(pass-if-equal 3/2
+ (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))))
+
+;;; srfi-2.test ends here
--
2.8.4
