Commit 4612b2a2 authored by Mark Oteiza's avatar Mark Oteiza

Implement and-let*

This also includes changes to if-let and when-let.  The single tuple
special case is ambiguous, and binding a symbol to nil is not as
useful as binding it to its value outside the lexical scope of the
binding.  (Bug#28254)
* etc/NEWS: Mention.
* lisp/emacs-lisp/subr-x.el (internal--listify):
(internal--build-binding-value-form): Extend to account for
solitary symbols and (EXPR) items in binding varlist.
(if-let*, when-let*): Nix single tuple case and incumbent
bind-symbol-to-nil behavior.
(and-let*): New macro.
(if-let, when-let): Mark obsolete.  Redefine in terms of if-let*, so
they implicitly gain the new features without breaking existing code.
* test/lisp/emacs-lisp/subr-x-tests.el: Adjust tests for: lack of
single-tuple special case, lack of binding solitary symbols to nil,
and the introduction of uninterned symbols for (EXPR) bindings.  Add
SRFI-2 test suite adapted to Elisp.
parent c87331a1
......@@ -1136,6 +1136,14 @@ be disabled by setting 'byte-compile-cond-use-jump-table' to nil.
---
** The alist 'ucs-names' is now a hash table.
---
** 'if-let' and 'when-let' are subsumed by 'if-let*' and 'when-let*'.
The incumbent 'if-let' and 'when-let' are now marked obsolete.
'if-let*' and 'when-let*' do not accept the single tuple special case.
New macro 'and-let*' is an implementation of the Scheme SRFI-2 syntax
of the same name. 'if-let*' and 'when-let*' now accept the same
binding syntax as 'and-let*'.
---
** 'C-up', 'C-down', 'C-left' and 'C-right' are now defined in term
mode to send the same escape sequences that xterm does. This makes
......@@ -1528,10 +1536,6 @@ It avoids unnecessary consing (and garbage collection).
+++
** 'gensym' is now part of Elisp.
---
** 'if-let*', 'when-let*', and 'and-let*' are new in subr-x.el.
The incumbent 'if-let' and 'when-let' are now aliases.
---
** Low-level list functions like 'length' and 'member' now do a better
job of signaling list cycles instead of looping indefinitely.
......
......@@ -83,10 +83,15 @@ threading."
`(internal--thread-argument nil ,@forms))
(defsubst internal--listify (elt)
"Wrap ELT in a list if it is not one."
(if (not (listp elt))
(list elt)
elt))
"Wrap ELT in a list if it is not one.
If ELT is of the form ((EXPR)), listify (EXPR) with a dummy symbol."
(cond
((symbolp elt) (list elt elt))
((and (null (cdr elt))
(let ((form (car elt)))
(or (listp form) (atom form))))
(list (make-symbol "s") (car elt)))
(t elt)))
(defsubst internal--check-binding (binding)
"Check BINDING is properly formed."
......@@ -98,7 +103,10 @@ threading."
(defsubst internal--build-binding-value-form (binding prev-var)
"Build the conditional value form for BINDING using PREV-VAR."
`(,(car binding) (and ,prev-var ,(cadr binding))))
(let ((var (car binding)))
(if (and (null (cdr binding)) (atom (car binding)) (not (symbolp (car binding))))
`(,var (and ,prev-var ,var))
`(,var (and ,prev-var ,(cadr binding))))))
(defun internal--build-binding (binding prev-var)
"Check and build a single BINDING with PREV-VAR."
......@@ -117,44 +125,68 @@ threading."
binding))
bindings)))
(defmacro if-let* (bindings then &rest else)
(defmacro if-let* (varlist then &rest else)
"Bind variables according to VARLIST and eval THEN or ELSE.
Each binding is evaluated in turn with `let*', and evaluation
stops if a binding value is nil. If all are non-nil, the value
of THEN is returned, or the last form in ELSE is returned.
Each element of VARLIST is a symbol (which is bound to nil)
or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
In the special case you only want to bind a single value,
VARLIST can just be a plain tuple.
\n(fn VARLIST THEN ELSE...)"
Each binding is evaluated in turn, and evaluation stops if a
binding value is nil. If all are non-nil, the value of THEN is
returned, or the last form in ELSE is returned.
Each element of VARLIST is a list (SYMBOL VALUEFORM) which binds
SYMBOL to the value of VALUEFORM).
An element can additionally be of the form (VALUEFORM), which is
evaluated and checked for nil."
(declare (indent 2)
(debug ([&or (&rest [&or symbolp (symbolp form)]) (symbolp form)]
(debug ((&rest [&or symbolp (symbolp form) (sexp)])
form body)))
(when (and (<= (length bindings) 2)
(not (listp (car bindings))))
;; Adjust the single binding case
(setq bindings (list bindings)))
`(let* ,(internal--build-bindings bindings)
(if ,(car (internal--listify (car (last bindings))))
(if varlist
`(let* ,(setq varlist (internal--build-bindings varlist))
(if ,(caar (last varlist))
,then
,@else)))
,@else))
`(let* () ,@else)))
(defmacro when-let* (bindings &rest body)
(defmacro when-let* (varlist &rest body)
"Bind variables according to VARLIST and conditionally eval BODY.
Each binding is evaluated in turn with `let*', and evaluation
stops if a binding value is nil. If all are non-nil, the value
of the last form in BODY is returned.
Each element of VARLIST is a symbol (which is bound to nil)
or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).
In the special case you only want to bind a single value,
VARLIST can just be a plain tuple.
\n(fn VARLIST BODY...)"
(declare (indent 1) (debug if-let))
(list 'if-let bindings (macroexp-progn body)))
(defalias 'if-let 'if-let*)
(defalias 'when-let 'when-let*)
(defalias 'and-let* 'when-let*)
Each binding is evaluated in turn, and evaluation stops if a
binding value is nil. If all are non-nil, the value of the last
form in BODY is returned.
VARLIST is the same as in `if-let*'."
(declare (indent 1) (debug if-let*))
(list 'if-let* varlist (macroexp-progn body)))
(defmacro and-let* (varlist &rest body)
"Bind variables according to VARLIST and conditionally eval BODY.
Like `when-let*', except if BODY is empty and all the bindings
are non-nil, then the result is non-nil."
(declare (indent 1) (debug when-let*))
(let (res)
(if varlist
`(let* ,(setq varlist (internal--build-bindings varlist))
(if ,(setq res (caar (last varlist)))
,@(or body `(,res))))
`(let* () ,@(or body '(t))))))
(defmacro if-let (spec then &rest else)
"Bind variables according to SPEC and eval THEN or ELSE.
Like `if-let*' except SPEC can have the form (SYMBOL VALUEFORM)."
(declare (indent 2)
(debug ([&or (&rest [&or symbolp (symbolp form) (sexp)])
(symbolp form)]
form body))
(obsolete "use `if-let*' instead." "26.1"))
(when (and (<= (length spec) 2)
(not (listp (car spec))))
;; Adjust the single binding case
(setq spec (list spec)))
(list 'if-let* spec then (macroexp-progn else)))
(defmacro when-let (spec &rest body)
"Bind variables according to SPEC and conditionally eval BODY.
Like `when-let*' except SPEC can have the form (SYMBOL VALUEFORM)."
(declare (indent 1) (debug if-let)
(obsolete "use `when-let*' instead." "26.1"))
(list 'if-let spec (macroexp-progn body)))
(defsubst hash-table-empty-p (hash-table)
"Check whether HASH-TABLE is empty (has 0 elements)."
......
......@@ -28,13 +28,13 @@
(require 'subr-x)
;; if-let tests
;; `if-let*' tests
(ert-deftest subr-x-test-if-let-single-binding-expansion ()
(ert-deftest subr-x-test-if-let*-single-binding-expansion ()
"Test single bindings are expanded properly."
(should (equal
(macroexpand
'(if-let (a 1)
'(if-let* ((a 1))
(- a)
"no"))
'(let* ((a (and t 1)))
......@@ -43,53 +43,53 @@
"no"))))
(should (equal
(macroexpand
'(if-let (a)
'(if-let* (a)
(- a)
"no"))
'(let* ((a (and t nil)))
'(let* ((a (and t a)))
(if a
(- a)
"no")))))
(ert-deftest subr-x-test-if-let-single-symbol-expansion ()
(ert-deftest subr-x-test-if-let*-single-symbol-expansion ()
"Test single symbol bindings are expanded properly."
(should (equal
(macroexpand
'(if-let (a)
'(if-let* (a)
(- a)
"no"))
'(let* ((a (and t nil)))
'(let* ((a (and t a)))
(if a
(- a)
"no"))))
(should (equal
(macroexpand
'(if-let (a b c)
'(if-let* (a b c)
(- a)
"no"))
'(let* ((a (and t nil))
(b (and a nil))
(c (and b nil)))
'(let* ((a (and t a))
(b (and a b))
(c (and b c)))
(if c
(- a)
"no"))))
(should (equal
(macroexpand
'(if-let (a (b 2) c)
'(if-let* (a (b 2) c)
(- a)
"no"))
'(let* ((a (and t nil))
'(let* ((a (and t a))
(b (and a 2))
(c (and b nil)))
(c (and b c)))
(if c
(- a)
"no")))))
(ert-deftest subr-x-test-if-let-nil-related-expansion ()
(ert-deftest subr-x-test-if-let*-nil-related-expansion ()
"Test nil is processed properly."
(should (equal
(macroexpand
'(if-let (nil)
'(if-let* (nil)
(- a)
"no"))
'(let* ((nil (and t nil)))
......@@ -98,27 +98,7 @@
"no"))))
(should (equal
(macroexpand
'(if-let ((nil))
(- a)
"no"))
'(let* ((nil (and t nil)))
(if nil
(- a)
"no"))))
(should (equal
(macroexpand
'(if-let ((a 1) (nil) (b 2))
(- a)
"no"))
'(let* ((a (and t 1))
(nil (and a nil))
(b (and nil 2)))
(if b
(- a)
"no"))))
(should (equal
(macroexpand
'(if-let ((a 1) nil (b 2))
'(if-let* ((a 1) nil (b 2))
(- a)
"no"))
'(let* ((a (and t 1))
......@@ -128,88 +108,90 @@
(- a)
"no")))))
(ert-deftest subr-x-test-if-let-malformed-binding ()
(ert-deftest subr-x-test-if-let*-malformed-binding ()
"Test malformed bindings trigger errors."
(should-error (macroexpand
'(if-let (_ (a 1 1) (b 2) (c 3) d)
'(if-let* (_ (a 1 1) (b 2) (c 3) d)
(- a)
"no"))
:type 'error)
(should-error (macroexpand
'(if-let (_ (a 1) (b 2 2) (c 3) d)
'(if-let* (_ (a 1) (b 2 2) (c 3) d)
(- a)
"no"))
:type 'error)
(should-error (macroexpand
'(if-let (_ (a 1) (b 2) (c 3 3) d)
'(if-let* (_ (a 1) (b 2) (c 3 3) d)
(- a)
"no"))
:type 'error)
(should-error (macroexpand
'(if-let ((a 1 1))
'(if-let* ((a 1 1))
(- a)
"no"))
:type 'error))
(ert-deftest subr-x-test-if-let-true ()
(ert-deftest subr-x-test-if-let*-true ()
"Test `if-let' with truthy bindings."
(should (equal
(if-let (a 1)
(if-let* ((a 1))
a
"no")
1))
(should (equal
(if-let ((a 1) (b 2) (c 3))
(if-let* ((a 1) (b 2) (c 3))
(list a b c)
"no")
(list 1 2 3))))
(ert-deftest subr-x-test-if-let-false ()
(ert-deftest subr-x-test-if-let*-false ()
"Test `if-let' with falsie bindings."
(should (equal
(if-let (a nil)
(if-let* ((a nil))
(list a b c)
"no")
"no"))
(should (equal
(if-let ((a nil) (b 2) (c 3))
(if-let* ((a nil) (b 2) (c 3))
(list a b c)
"no")
"no"))
(should (equal
(if-let ((a 1) (b nil) (c 3))
(if-let* ((a 1) (b nil) (c 3))
(list a b c)
"no")
"no"))
(should (equal
(if-let ((a 1) (b 2) (c nil))
(if-let* ((a 1) (b 2) (c nil))
(list a b c)
"no")
"no"))
(should (equal
(if-let (z (a 1) (b 2) (c 3))
(let (z)
(if-let* (z (a 1) (b 2) (c 3))
(list a b c)
"no")
"no"))
"no"))
(should (equal
(if-let ((a 1) (b 2) (c 3) d)
(let (d)
(if-let* ((a 1) (b 2) (c 3) d)
(list a b c)
"no")
"no"))
"no")))
(ert-deftest subr-x-test-if-let-bound-references ()
(ert-deftest subr-x-test-if-let*-bound-references ()
"Test `if-let' bindings can refer to already bound symbols."
(should (equal
(if-let ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
(if-let* ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
(list a b c)
"no")
(list 1 2 3))))
(ert-deftest subr-x-test-if-let-and-laziness-is-preserved ()
(ert-deftest subr-x-test-if-let*-and-laziness-is-preserved ()
"Test `if-let' respects `and' laziness."
(let (a-called b-called c-called)
(should (equal
(if-let ((a nil)
(if-let* ((a nil)
(b (setq b-called t))
(c (setq c-called t)))
"yes"
......@@ -217,7 +199,7 @@
(list nil nil nil))))
(let (a-called b-called c-called)
(should (equal
(if-let ((a (setq a-called t))
(if-let* ((a (setq a-called t))
(b nil)
(c (setq c-called t)))
"yes"
......@@ -225,7 +207,7 @@
(list t nil nil))))
(let (a-called b-called c-called)
(should (equal
(if-let ((a (setq a-called t))
(if-let* ((a (setq a-called t))
(b (setq b-called t))
(c nil)
(d (setq c-called t)))
......@@ -234,13 +216,13 @@
(list t t nil)))))
;; when-let tests
;; `when-let*' tests
(ert-deftest subr-x-test-when-let-body-expansion ()
(ert-deftest subr-x-test-when-let*-body-expansion ()
"Test body allows for multiple sexps wrapping with progn."
(should (equal
(macroexpand
'(when-let (a 1)
'(when-let* ((a 1))
(message "opposite")
(- a)))
'(let* ((a (and t 1)))
......@@ -249,79 +231,46 @@
(message "opposite")
(- a)))))))
(ert-deftest subr-x-test-when-let-single-binding-expansion ()
"Test single bindings are expanded properly."
(should (equal
(macroexpand
'(when-let (a 1)
(- a)))
'(let* ((a (and t 1)))
(if a
(- a)))))
(should (equal
(macroexpand
'(when-let (a)
(- a)))
'(let* ((a (and t nil)))
(if a
(- a))))))
(ert-deftest subr-x-test-when-let-single-symbol-expansion ()
(ert-deftest subr-x-test-when-let*-single-symbol-expansion ()
"Test single symbol bindings are expanded properly."
(should (equal
(macroexpand
'(when-let (a)
'(when-let* (a)
(- a)))
'(let* ((a (and t nil)))
'(let* ((a (and t a)))
(if a
(- a)))))
(should (equal
(macroexpand
'(when-let (a b c)
'(when-let* (a b c)
(- a)))
'(let* ((a (and t nil))
(b (and a nil))
(c (and b nil)))
'(let* ((a (and t a))
(b (and a b))
(c (and b c)))
(if c
(- a)))))
(should (equal
(macroexpand
'(when-let (a (b 2) c)
'(when-let* (a (b 2) c)
(- a)))
'(let* ((a (and t nil))
'(let* ((a (and t a))
(b (and a 2))
(c (and b nil)))
(c (and b c)))
(if c
(- a))))))
(ert-deftest subr-x-test-when-let-nil-related-expansion ()
(ert-deftest subr-x-test-when-let*-nil-related-expansion ()
"Test nil is processed properly."
(should (equal
(macroexpand
'(when-let (nil)
'(when-let* (nil)
(- a)))
'(let* ((nil (and t nil)))
(if nil
(- a)))))
(should (equal
(macroexpand
'(when-let ((nil))
(- a)))
'(let* ((nil (and t nil)))
(if nil
(- a)))))
(should (equal
(macroexpand
'(when-let ((a 1) (nil) (b 2))
(- a)))
'(let* ((a (and t 1))
(nil (and a nil))
(b (and nil 2)))
(if b
(- a)))))
(should (equal
(macroexpand
'(when-let ((a 1) nil (b 2))
'(when-let* ((a 1) nil (b 2))
(- a)))
'(let* ((a (and t 1))
(nil (and a nil))
......@@ -329,82 +278,84 @@
(if b
(- a))))))
(ert-deftest subr-x-test-when-let-malformed-binding ()
(ert-deftest subr-x-test-when-let*-malformed-binding ()
"Test malformed bindings trigger errors."
(should-error (macroexpand
'(when-let (_ (a 1 1) (b 2) (c 3) d)
'(when-let* (_ (a 1 1) (b 2) (c 3) d)
(- a)))
:type 'error)
(should-error (macroexpand
'(when-let (_ (a 1) (b 2 2) (c 3) d)
'(when-let* (_ (a 1) (b 2 2) (c 3) d)
(- a)))
:type 'error)
(should-error (macroexpand
'(when-let (_ (a 1) (b 2) (c 3 3) d)
'(when-let* (_ (a 1) (b 2) (c 3 3) d)
(- a)))
:type 'error)
(should-error (macroexpand
'(when-let ((a 1 1))
'(when-let* ((a 1 1))
(- a)))
:type 'error))
(ert-deftest subr-x-test-when-let-true ()
(ert-deftest subr-x-test-when-let*-true ()
"Test `when-let' with truthy bindings."
(should (equal
(when-let (a 1)
(when-let* ((a 1))
a)
1))
(should (equal
(when-let ((a 1) (b 2) (c 3))
(when-let* ((a 1) (b 2) (c 3))
(list a b c))
(list 1 2 3))))
(ert-deftest subr-x-test-when-let-false ()
(ert-deftest subr-x-test-when-let*-false ()
"Test `when-let' with falsie bindings."
(should (equal
(when-let (a nil)
(when-let* ((a nil))
(list a b c)
"no")
nil))
(should (equal
(when-let ((a nil) (b 2) (c 3))
(when-let* ((a nil) (b 2) (c 3))
(list a b c)
"no")
nil))
(should (equal
(when-let ((a 1) (b nil) (c 3))
(when-let* ((a 1) (b nil) (c 3))
(list a b c)
"no")
nil))
(should (equal
(when-let ((a 1) (b 2) (c nil))
(when-let* ((a 1) (b 2) (c nil))
(list a b c)
"no")
nil))
(should (equal
(when-let (z (a 1) (b 2) (c 3))
(let (z)
(when-let* (z (a 1) (b 2) (c 3))
(list a b c)
"no")
"no"))
nil))
(should (equal
(when-let ((a 1) (b 2) (c 3) d)
(let (d)
(when-let* ((a 1) (b 2) (c 3) d)
(list a b c)
"no")
"no"))
nil)))
(ert-deftest subr-x-test-when-let-bound-references ()
(ert-deftest subr-x-test-when-let*-bound-references ()
"Test `when-let' bindings can refer to already bound symbols."
(should (equal
(when-let ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
(when-let* ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
(list a b c))
(list 1 2 3))))
(ert-deftest subr-x-test-when-let-and-laziness-is-preserved ()
(ert-deftest subr-x-test-when-let*-and-laziness-is-preserved ()
"Test `when-let' respects `and' laziness."
(let (a-called b-called c-called)
(should (equal
(progn
(when-let ((a nil)
(when-let* ((a nil)
(b (setq b-called t))
(c (setq c-called t)))
"yes")
......@@ -413,7 +364,7 @@
(let (a-called b-called c-called)
(should (equal
(progn
(when-let ((a (setq a-called t))
(when-let* ((a (setq a-called t))
(b nil)
(c (setq c-called t)))
"yes")
......@@ -422,7 +373,7 @@
(let (a-called b-called c-called)
(should (equal
(progn
(when-let ((a (setq a-called