--- 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:
--- 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.
--- 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 ;;;;