From 130ac5c40c1295f5291162e94bcc9b444d050ed9 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 1 Jun 2008 01:35:09 +0300
Subject: [PATCH] WHEN-LET* short circuits, IF-LET* deleted

---
 binding.lisp | 55 +++++++++++++++----------------------------------------
 package.lisp |  1 -
 tests.lisp   | 35 +++++++----------------------------
 3 files changed, 22 insertions(+), 69 deletions(-)

diff --git a/binding.lisp b/binding.lisp
index 6a4cc05..d5f43b3 100644
--- a/binding.lisp
+++ b/binding.lisp
@@ -30,37 +30,6 @@ effect."
            ,then-form
            ,else-form))))
 
-(defmacro if-let* (bindings then-form &optional else-form)
-  "Creates new variable bindings, and conditionally executes either THEN-FORM
-or ELSE-FORM. ELSE-FORM defaults to NIL.
-
-BINDINGS must be either single binding of the form:
-
- (variable initial-form)
-
-or a list of bindings of the form:
-
- ((variable-1 initial-form-1)
-  (variable-2 initial-form-2)
-  ...
-  (variable-n initial-form-n))
-
-Each initial-form is executed in turn, and the variable bound to the
-corresponding value. Initial-form expressions can refer to variables
-previously bound by the IF-LET*.
-
-If all variables are true after the bindings are complete, the THEN-FORM is
-executed with the bindings in effect, otherwise the ELSE-FORM is executed with
-the bindings in effect."
-  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
-                           (list bindings)
-                           bindings))
-         (variables (mapcar #'car binding-list)))
-    `(let* ,binding-list
-       (if (and ,@variables)
-           ,then-form
-           ,else-form))))
-
 (defmacro when-let (bindings &body forms)
     "Creates new variable bindings, and conditionally executes FORMS.
 
@@ -106,13 +75,19 @@ Each initial-form is executed in turn, and the variable bound to the
 corresponding value. Initial-form expressions can refer to variables
 previously bound by the IF-LET*.
 
-If all variables are true after the bindings are complete, then FORMS are
-executed as an implicit PROGN."
-  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
-                           (list bindings)
-                           bindings))
-         (variables (mapcar #'car binding-list)))
-    `(let* ,binding-list
-       (when (and ,@variables)
-         ,@forms))))
+Execution of WHEN-LET* stops immediately if any initial-form evaluates to NIL.
+If all initial-forms evaluate to true, then FORMS are executed as an implicit
+PROGN."
+  (let ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
+                          (list bindings)
+                          bindings)))
+    (labels ((bind (bindings forms)
+               (if bindings
+                   `((let (,(car bindings))
+                       (when ,(caar bindings)
+                         ,@(bind (cdr bindings) forms))))
+                   forms)))
+      `(let (,(car binding-list))
+         (when ,(caar binding-list)
+           ,@(bind (cdr binding-list) forms))))))
 
diff --git a/package.lisp b/package.lisp
index 1e31c2c..2a89bcb 100644
--- a/package.lisp
+++ b/package.lisp
@@ -4,7 +4,6 @@
   (:export
    ;; Binding constructs
    #:if-let
-   #:if-let*
    #:when-let
    #:when-let*
    ;; Definitions
diff --git a/tests.lisp b/tests.lisp
index 610ecb9..bfc06e3 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -1493,34 +1493,6 @@
         :type-error))
   :type-error)
 
-(deftest if-let*.1
-    (let ((x 1))
-      (if-let* ((x 2)
-                (y x))
-               (+ x y)
-               :oops))
-  4)
-
-(deftest if-let*.2
-    (if-let* ((x 2)
-              (y (prog1 x (setf x nil))))
-             :oops
-             (and (not x) y))
-  2)
-
-(deftest if-let*.3
-    (if-let* (x 1)
-             x
-             :oops)
-  1)
-
-(deftest if-let*.error.1
-    (handler-case
-        (eval '(if-let* x :oops :oops))
-      (type-error ()
-        :type-error))
-  :type-error)
-
 (deftest when-let.1
     (when-let (x (opaque :ok))
       (setf x (cons x x))
@@ -1561,6 +1533,13 @@
         (1+ x)))
   2)
 
+(deftest when-let*.3
+    (when-let* ((x t)
+                (y (consp x))
+                (z (error "OOPS")))
+      t)
+  nil)
+
 (deftest when-let*.error.1
     (handler-case
         (eval '(when-let* x :oops))
-- 
2.11.4.GIT