# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1506555942 14400
# Node ID 280b721cfa9f28d19cd7fa8108142bb19ed3da0c
# Parent  0cf1ef232b1c7fb25402bcbfdb2b46b856334957
Add `[if/when]-let(*)` variants that actually might work

diff -r 0cf1ef232b1c -r 280b721cfa9f DOCUMENTATION.markdown
--- a/DOCUMENTATION.markdown	Mon Sep 25 20:47:21 2017 -0400
+++ b/DOCUMENTATION.markdown	Wed Sep 27 19:45:42 2017 -0400
@@ -451,6 +451,92 @@
 
   
 
+### `IF-LET` (macro)
+
+    (IF-LET BINDINGS
+      &BODY
+      BODY)
+
+Bind `bindings` in parallel and execute `then` if all are true, or `else` otherwise.
+
+  `body` must be of the form `(...optional-declarations... then else)`.
+
+  This macro combines `if` and `let`.  It takes a list of bindings and binds
+  them like `let` before executing the `then` branch of `body`, but if any
+  binding's value evaluate to `nil` the process stops there and the `else`
+  branch is immediately executed (with no bindings in effect).
+
+  If any `optional-declarations` are included they will only be in effect for
+  the `then` branch.
+
+  Examples:
+
+    (if-let ((a (progn (print :a) 1))
+             (b (progn (print :b) 2))
+             (c (progn (print :c) 3)))
+      (list a b c)
+      'nope)
+    ; =>
+    :A
+    :B
+    :C
+    (1 2 3)
+
+    (if-let ((a (progn (print :a) 1))
+             (b (progn (print :b) nil))
+             (c (progn (print :c) 3)))
+      (list a b c)
+      'nope)
+    ; =>
+    :A
+    :B
+    NOPE
+
+  
+
+### `IF-LET*` (macro)
+
+    (IF-LET* BINDINGS
+      &BODY
+      BODY)
+
+Bind `bindings` sequentially and execute `then` if all are true, or `else` otherwise.
+
+  `body` must be of the form `(...optional-declarations... then else)`.
+
+  This macro combines `if` and `let*`.  It takes a list of bindings and binds
+  them like `let*` before executing the `then` branch of `body`, but if any
+  binding's value evaluate to `nil` the process stops there and the `else`
+  branch is immediately executed (with no bindings in effect).
+
+  If any `optional-declarations` are included they will only be in effect for
+  the `then` branch.
+
+  Examples:
+
+    (if-let* ((a (progn (print :a) 1))
+              (b (progn (print :b) 2))
+              (c (progn (print :c) 3)))
+      (list a b c)
+      'nope)
+    ; =>
+    :A
+    :B
+    :C
+    (1 2 3)
+
+    (if-let* ((a (progn (print :a) 1))
+              (b (progn (print :b) nil))
+              (c (progn (print :c) 3)))
+      (list a b c)
+      'nope)
+    ; =>
+    :A
+    :B
+    NOPE
+
+  
+
 ### `MULTIPLE-VALUE-BIND*` (macro)
 
     (MULTIPLE-VALUE-BIND* BINDINGS
@@ -524,17 +610,52 @@
 
   
 
-### `WHEN-LET*` (macro)
-
-    (WHEN-LET* BINDING-FORMS
+### `WHEN-LET` (macro)
+
+    (WHEN-LET BINDINGS
       &BODY
       BODY)
 
-Bind the forms in `binding-forms` in order, short-circuiting on `nil`.
-
-  This is like Clojure's `when-let`.  It takes a list of binding and binds them
-  like `let*`, but if any of the expressions evaluate to `nil` the process stops
-  there and `nil` is immediately returned.
+Bind `bindings` in parallel and execute `body`, short-circuiting on `nil`.
+
+  This macro combines `when` and `let`.  It takes a list of bindings and binds
+  them like `let` before executing `body`, but if any binding's value evaluates
+  to `nil` the process stops there and `nil` is immediately returned.
+
+  Examples:
+
+    (when-let ((a (progn (print :a) 1))
+               (b (progn (print :b) 2))
+               (c (progn (print :c) 3)))
+      (list a b c))
+    ; =>
+    :A
+    :B
+    :C
+    (1 2 3)
+
+    (when-let ((a (progn (print :a) 1))
+               (b (progn (print :b) nil))
+               (c (progn (print :c) 3)))
+      (list a b c))
+    ; =>
+    :A
+    :B
+    NIL
+
+  
+
+### `WHEN-LET*` (macro)
+
+    (WHEN-LET* BINDINGS
+      &BODY
+      BODY)
+
+Bind `bindings` sequentially and execute `body`, short-circuiting on `nil`.
+
+  This macro combines `when` and `let*`.  It takes a list of bindings and binds
+  them like `let` before executing `body`, but if any binding's value evaluates
+  to `nil` the process stops there and `nil` is immediately returned.
 
   Examples:
 
diff -r 0cf1ef232b1c -r 280b721cfa9f losh.lisp
--- a/losh.lisp	Mon Sep 25 20:47:21 2017 -0400
+++ b/losh.lisp	Wed Sep 27 19:45:42 2017 -0400
@@ -584,12 +584,61 @@
          ,result))))
 
 
-(defmacro when-let* (binding-forms &body body)
-  "Bind the forms in `binding-forms` in order, short-circuiting on `nil`.
-
-  This is like Clojure's `when-let`.  It takes a list of binding and binds them
-  like `let*`, but if any of the expressions evaluate to `nil` the process stops
-  there and `nil` is immediately returned.
+(defmacro when-let (bindings &body body)
+  "Bind `bindings` in parallel and execute `body`, short-circuiting on `nil`.
+
+  This macro combines `when` and `let`.  It takes a list of bindings and binds
+  them like `let` before executing `body`, but if any binding's value evaluates
+  to `nil` the process stops there and `nil` is immediately returned.
+
+  Examples:
+
+    (when-let ((a (progn (print :a) 1))
+               (b (progn (print :b) 2))
+               (c (progn (print :c) 3)))
+      (list a b c))
+    ; =>
+    :A
+    :B
+    :C
+    (1 2 3)
+
+    (when-let ((a (progn (print :a) 1))
+               (b (progn (print :b) nil))
+               (c (progn (print :c) 3)))
+      (list a b c))
+    ; =>
+    :A
+    :B
+    NIL
+
+  "
+  ;; (when-let ((a 1)
+  ;;            (b 2))
+  ;;   (+ a b))
+  ;; =>
+  ;; (BLOCK #:BLOCK632
+  ;;   (LET* ((#:A633 (OR 1 (RETURN-FROM #:BLOCK632)))
+  ;;          (#:B634 (OR 2 (RETURN-FROM #:BLOCK632)))
+  ;;          (A #:A633)
+  ;;          (B #:B634))
+  ;;     (+ A B)))
+  (with-gensyms (block)
+    (loop
+      :for (symbol value) :in bindings
+      :for symbol% = (make-gensym symbol)
+      :collect `(,symbol% (or ,value (return-from ,block))) :into initial-let-bindings
+      :collect `(,symbol ,symbol%) :into final-let-bindings
+      :finally (return `(block ,block
+                          (let* (,@initial-let-bindings ,@final-let-bindings)
+                            ,@body))))))
+
+(defmacro when-let* (bindings &body body)
+  "Bind `bindings` sequentially and execute `body`, short-circuiting on `nil`.
+
+  This macro combines `when` and `let*`.  It takes a list of bindings and binds
+  them like `let` before executing `body`, but if any binding's value evaluates
+  to `nil` the process stops there and `nil` is immediately returned.
 
   Examples:
 
@@ -613,14 +662,155 @@
     NIL
 
   "
-  (if (null binding-forms)
-    `(progn ,@body)
-    (destructuring-bind ((symbol expr) . remaining-bindings)
-      binding-forms
-      `(let ((,symbol ,expr))
-         (when ,symbol
-           (when-let* ,remaining-bindings ,@body))))))
-
+  ;; (when-let* ((a 1)
+  ;;             (b 2))
+  ;;      (+ a b))
+  ;; =>
+  ;; (BLOCK #:BLOCK647
+  ;;   (LET* ((A (OR 1 (RETURN-FROM #:BLOCK647)))
+  ;;          (B (OR 2 (RETURN-FROM #:BLOCK647))))
+  ;;     (+ A B)))
+  (with-gensyms (block)
+    (loop
+      :for (symbol value) :in bindings
+      :collect `(,symbol (or ,value (return-from ,block))) :into let-bindings
+      :finally (return `(block ,block
+                          (let* (,@let-bindings)
+                            ,@body))))))
+
+(defmacro if-let (bindings &body body)
+  "Bind `bindings` in parallel and execute `then` if all are true, or `else` otherwise.
+
+  `body` must be of the form `(...optional-declarations... then else)`.
+
+  This macro combines `if` and `let`.  It takes a list of bindings and binds
+  them like `let` before executing the `then` branch of `body`, but if any
+  binding's value evaluate to `nil` the process stops there and the `else`
+  branch is immediately executed (with no bindings in effect).
+
+  If any `optional-declarations` are included they will only be in effect for
+  the `then` branch.
+
+  Examples:
+
+    (if-let ((a (progn (print :a) 1))
+             (b (progn (print :b) 2))
+             (c (progn (print :c) 3)))
+      (list a b c)
+      'nope)
+    ; =>
+    :A
+    :B
+    :C
+    (1 2 3)
+
+    (if-let ((a (progn (print :a) 1))
+             (b (progn (print :b) nil))
+             (c (progn (print :c) 3)))
+      (list a b c)
+      'nope)
+    ; =>
+    :A
+    :B
+    NOPE
+
+  "
+  ;; (if-let ((a 1)
+  ;;          (b 2))
+  ;;   (declare (type fixnum a b))
+  ;;   (+ a b)
+  ;;   'nope)
+  ;; =>
+  ;; (BLOCK #:BLOCK643
+  ;;   (TAGBODY
+  ;;     (LET* ((#:A645 (OR 1 (GO #:ELSE-LABEL644)))
+  ;;            (#:B646 (OR 2 (GO #:ELSE-LABEL644)))
+  ;;            (A #:A645)
+  ;;            (B #:B646))
+  ;;       (DECLARE (TYPE FIXNUM A B))
+  ;;       (RETURN-FROM #:BLOCK643 (+ A B)))
+  ;;    #:ELSE-LABEL644
+  ;;     (RETURN-FROM #:BLOCK643 'NOPE)))
+  (with-gensyms (block else-label)
+    (loop
+      :with (body declarations) = (multiple-value-list (parse-body body))
+      :with (then else) = (destructuring-bind (then else) body (list then else))
+      :for (symbol value) :in bindings
+      :for symbol% = (make-gensym symbol)
+      :collect `(,symbol% (or ,value (go ,else-label))) :into initial-let-bindings
+      :collect `(,symbol ,symbol%) :into final-let-bindings
+      :finally (return `(block ,block
+                          (tagbody
+                            (let* (,@initial-let-bindings ,@final-let-bindings)
+                              ,@declarations
+                              (return-from ,block ,then))
+                            ,else-label
+                            (return-from ,block ,else)))))))
+
+(defmacro if-let* (bindings &body body)
+  "Bind `bindings` sequentially and execute `then` if all are true, or `else` otherwise.
+
+  `body` must be of the form `(...optional-declarations... then else)`.
+
+  This macro combines `if` and `let*`.  It takes a list of bindings and binds
+  them like `let*` before executing the `then` branch of `body`, but if any
+  binding's value evaluate to `nil` the process stops there and the `else`
+  branch is immediately executed (with no bindings in effect).
+
+  If any `optional-declarations` are included they will only be in effect for
+  the `then` branch.
+
+  Examples:
+
+    (if-let* ((a (progn (print :a) 1))
+              (b (progn (print :b) 2))
+              (c (progn (print :c) 3)))
+      (list a b c)
+      'nope)
+    ; =>
+    :A
+    :B
+    :C
+    (1 2 3)
+
+    (if-let* ((a (progn (print :a) 1))
+              (b (progn (print :b) nil))
+              (c (progn (print :c) 3)))
+      (list a b c)
+      'nope)
+    ; =>
+    :A
+    :B
+    NOPE
+
+  "
+  ;; (if-let* ((a 1)
+  ;;           (b 2))
+  ;;   (declare (type fixnum a b))
+  ;;   (+ a b)
+  ;;   'nope)
+  ;; =>
+  ;; (BLOCK #:BLOCK647
+  ;;   (TAGBODY
+  ;;     (LET* ((A (OR 1 (GO #:ELSE-LABEL648)))
+  ;;            (B (OR 2 (GO #:ELSE-LABEL648))))
+  ;;       (DECLARE (TYPE FIXNUM A B))
+  ;;       (RETURN-FROM #:BLOCK647 (+ A B)))
+  ;;    #:ELSE-LABEL648
+  ;;     (RETURN-FROM #:BLOCK647 'NOPE)))
+  (with-gensyms (block else-label)
+    (loop
+      :with (body declarations) = (multiple-value-list (parse-body body))
+      :with (then else) = (destructuring-bind (then else) body (list then else))
+      :for (symbol value) :in bindings
+      :collect `(,symbol (or ,value (go ,else-label))) :into let-bindings
+      :finally (return `(block ,block
+                          (tagbody
+                            (let* ,let-bindings
+                              ,@declarations
+                              (return-from ,block ,then))
+                            ,else-label
+                            (return-from ,block ,else)))))))
 
 (defmacro multiple-value-bind* (bindings &body body)
   "Bind each pair in `bindings` with `multiple-value-bind` sequentially.
diff -r 0cf1ef232b1c -r 280b721cfa9f package.lisp
--- a/package.lisp	Mon Sep 25 20:47:21 2017 -0400
+++ b/package.lisp	Wed Sep 27 19:45:42 2017 -0400
@@ -70,6 +70,9 @@
     :gathering
     :gathering-vector
     :gather
+    :if-let
+    :if-let*
+    :when-let
     :when-let*
     :multiple-value-bind*
     :do-repeat
diff -r 0cf1ef232b1c -r 280b721cfa9f vendor/make-quickutils.lisp
--- a/vendor/make-quickutils.lisp	Mon Sep 25 20:47:21 2017 -0400
+++ b/vendor/make-quickutils.lisp	Wed Sep 27 19:45:42 2017 -0400
@@ -14,9 +14,11 @@
                :hash-table-alist
                :hash-table-keys
                :hash-table-values
+               :make-gensym
                :map-tree
                :mkstr
                :once-only
+               :parse-body
                :range
                :rcurry
                :symb
diff -r 0cf1ef232b1c -r 280b721cfa9f vendor/quickutils.lisp
--- a/vendor/quickutils.lisp	Mon Sep 25 20:47:21 2017 -0400
+++ b/vendor/quickutils.lisp	Wed Sep 27 19:45:42 2017 -0400
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :EMPTYP :ENSURE-KEYWORD :ENSURE-LIST :FLATTEN :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-TREE :MKSTR :ONCE-ONLY :RANGE :RCURRY :SYMB :WEAVE :WITH-GENSYMS) :ensure-package T :package "LOSH.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :EMPTYP :ENSURE-KEYWORD :ENSURE-LIST :FLATTEN :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAKE-GENSYM :MAP-TREE :MKSTR :ONCE-ONLY :PARSE-BODY :RANGE :RCURRY :SYMB :WEAVE :WITH-GENSYMS) :ensure-package T :package "LOSH.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "LOSH.QUICKUTILS")
@@ -19,9 +19,11 @@
                                          :ENSURE-LIST :FLATTEN
                                          :HASH-TABLE-ALIST :MAPHASH-KEYS
                                          :HASH-TABLE-KEYS :MAPHASH-VALUES
-                                         :HASH-TABLE-VALUES :MAP-TREE :MKSTR
-                                         :ONCE-ONLY :RANGE :RCURRY :SYMB :WEAVE
-                                         :STRING-DESIGNATOR :WITH-GENSYMS))))
+                                         :HASH-TABLE-VALUES :MAKE-GENSYM
+                                         :MAP-TREE :MKSTR :ONCE-ONLY
+                                         :PARSE-BODY :RANGE :RCURRY :SYMB
+                                         :WEAVE :STRING-DESIGNATOR
+                                         :WITH-GENSYMS))))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun make-gensym-list (length &optional (x "G"))
     "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
@@ -199,6 +201,15 @@
       values))
   
 
+  (defun make-gensym (name)
+    "If `name` is a non-negative integer, calls `gensym` using it. Otherwise `name`
+must be a string designator, in which case calls `gensym` using the designated
+string as the argument."
+    (gensym (if (typep name '(integer 0))
+                name
+                (string name))))
+  
+
   (defun map-tree (function tree)
     "Map `function` to each of the leave of `tree`."
     (check-type tree cons)
@@ -259,6 +270,28 @@
                ,@forms)))))
   
 
+  (defun parse-body (body &key documentation whole)
+    "Parses `body` into `(values remaining-forms declarations doc-string)`.
+Documentation strings are recognized only if `documentation` is true.
+Syntax errors in body are signalled and `whole` is used in the signal
+arguments when given."
+    (let ((doc nil)
+          (decls nil)
+          (current nil))
+      (tagbody
+       :declarations
+         (setf current (car body))
+         (when (and documentation (stringp current) (cdr body))
+           (if doc
+               (error "Too many documentation strings in ~S." (or whole body))
+               (setf doc (pop body)))
+           (go :declarations))
+         (when (and (listp current) (eql (first current) 'declare))
+           (push (pop body) decls)
+           (go :declarations)))
+      (values body (nreverse decls) doc)))
+  
+
   (defun range (start end &key (step 1) (key 'identity))
     "Return the list of numbers `n` such that `start <= n < end` and
 `n = start + k*step` for suitable integers `k`. If a function `key` is
@@ -337,8 +370,8 @@
   
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(compose copy-hash-table curry emptyp ensure-keyword ensure-list
-            flatten hash-table-alist hash-table-keys hash-table-values map-tree
-            mkstr once-only range rcurry symb weave with-gensyms
-            with-unique-names)))
+            flatten hash-table-alist hash-table-keys hash-table-values
+            make-gensym map-tree mkstr once-only parse-body range rcurry symb
+            weave with-gensyms with-unique-names)))
 
 ;;;; END OF quickutils.lisp ;;;;