Re: [PATCH] Fix and-let*.

[taylanbayirli@gmail.com (Taylan Ulrich Bayırlı/Kammer)]

[-- Attachment #1: Type: text/plain, Size: 69 bytes --]

Pinging this thread at Andy's request. :-)

Here's the two patches:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Fix-SRFI-2-and-let-implementation.patch --]
[-- Type: text/x-diff, Size: 2983 bytes --]

From 8405987e86cd99772f81f98565e66f673e82d57e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
 <taylanbayirli@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 | 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


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-Add-SRFI-2-and-let-test-suite.patch --]
[-- Type: text/x-diff, Size: 4458 bytes --]

From 65478567a67f89e88a8fe64136c34c3c95a214b4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
 <taylanbayirli@gmail.com>
Date: Sat, 3 Oct 2015 11:39:27 +0200
Subject: [PATCH 2/2] Add SRFI-2 (and-let*) test suite.

---
 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