From: Mark Oteiza Date: Tue, 12 Sep 2017 16:44:45 +0000 (-0400) Subject: Implement and-let* X-Git-Tag: emacs-26.0.90~173^2~41 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=4612b2a2b37026bef5a9b8e92878a15dabb9b261;p=emacs.git 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. --- diff --git a/etc/NEWS b/etc/NEWS index af29b29264d..03ef05b2a30 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -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. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 849ac19d6a5..3ea01065c8b 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -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)))) - ,then - ,@else))) + (if varlist + `(let* ,(setq varlist (internal--build-bindings varlist)) + (if ,(caar (last varlist)) + ,then + ,@else)) + `(let* () ,@else))) + +(defmacro when-let* (varlist &rest body) + "Bind variables according to VARLIST and conditionally eval BODY. +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 when-let* (bindings &rest body) +(defmacro and-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*) +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)." diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index 2b2a5cd0d71..111dc38f295 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -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,104 +108,106 @@ (- 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)) - (list a b c) - "no") + (let (z) + (if-let* (z (a 1) (b 2) (c 3)) + (list a b c) + "no")) "no")) (should (equal - (if-let ((a 1) (b 2) (c 3) d) - (list a b c) - "no") + (let (d) + (if-let* ((a 1) (b 2) (c 3) d) + (list a b c) + "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) - (b (setq b-called t)) - (c (setq c-called t))) + (if-let* ((a nil) + (b (setq b-called t)) + (c (setq c-called t))) "yes" (list a-called b-called c-called)) (list nil nil nil)))) (let (a-called b-called c-called) (should (equal - (if-let ((a (setq a-called t)) - (b nil) - (c (setq c-called t))) + (if-let* ((a (setq a-called t)) + (b nil) + (c (setq c-called t))) "yes" (list a-called b-called c-called)) (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) - (- a))) - '(let* ((nil (and t nil))) - (if nil - (- a))))) - (should (equal - (macroexpand - '(when-let ((nil)) + '(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,107 +278,170 @@ (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)) - (list a b c) - "no") + (let (z) + (when-let* (z (a 1) (b 2) (c 3)) + (list a b c) + "no")) nil)) (should (equal - (when-let ((a 1) (b 2) (c 3) d) - (list a b c) - "no") + (let (d) + (when-let* ((a 1) (b 2) (c 3) d) + (list a b c) + "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) - (b (setq b-called t)) - (c (setq c-called t))) + (when-let* ((a nil) + (b (setq b-called t)) + (c (setq c-called t))) "yes") (list a-called b-called c-called)) (list nil nil nil)))) (let (a-called b-called c-called) (should (equal (progn - (when-let ((a (setq a-called t)) - (b nil) - (c (setq c-called t))) + (when-let* ((a (setq a-called t)) + (b nil) + (c (setq c-called t))) "yes") (list a-called b-called c-called)) (list t nil nil)))) (let (a-called b-called c-called) (should (equal (progn - (when-let ((a (setq a-called t)) - (b (setq b-called t)) - (c nil) - (d (setq c-called t))) + (when-let* ((a (setq a-called t)) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) "yes") (list a-called b-called c-called)) (list t t nil))))) + +;; `and-let*' tests + +;; Adapted from the Guile tests +;; https://git.savannah.gnu.org/cgit/guile.git/tree/test-suite/tests/srfi-2.test + +(ert-deftest subr-x-and-let*-test-empty-varlist () + (should (equal 1 (and-let* () 1))) + (should (equal 2 (and-let* () 1 2))) + (should (equal t (and-let* ())))) + +(ert-deftest subr-x-and-let*-test-group-1 () + (should (equal nil (let ((x nil)) (and-let* (x))))) + (should (equal 1 (let ((x 1)) (and-let* (x))))) + (should (equal nil (and-let* ((x nil))))) + (should (equal 1 (and-let* ((x 1))))) + (should-error (and-let* (nil (x 1))) :type 'setting-constant) + (should (equal nil (and-let* ((nil) (x 1))))) + (should-error (and-let* (2 (x 1))) :type 'wrong-type-argument) + (should (equal 1 (and-let* ((2) (x 1))))) + (should (equal 2 (and-let* ((x 1) (2))))) + (should (equal nil (let ((x nil)) (and-let* (x) x)))) + (should (equal "" (let ((x "")) (and-let* (x) x)))) + (should (equal "" (let ((x "")) (and-let* (x))))) + (should (equal 2 (let ((x 1)) (and-let* (x) (+ x 1))))) + (should (equal nil (let ((x nil)) (and-let* (x) (+ x 1))))) + (should (equal 2 (let ((x 1)) (and-let* (((> x 0))) (+ x 1))))) + (should (equal t (let ((x 1)) (and-let* (((> x 0))))))) + (should (equal nil (let ((x 0)) (and-let* (((> x 0))) (+ x 1))))) + (should (equal 3 + (let ((x 1)) (and-let* (((> x 0)) (x (+ x 1))) (+ x 1)))))) + +(ert-deftest subr-x-and-let*-test-rebind () + (should + (equal 4 + (let ((x 1)) + (and-let* (((> x 0)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))))) + +(ert-deftest subr-x-and-let*-test-group-2 () + (should + (equal 2 (let ((x 1)) (and-let* (x ((> x 0))) (+ x 1))))) + (should + (equal 2 (let ((x 1)) (and-let* (((progn x)) ((> x 0))) (+ x 1))))) + (should (equal nil (let ((x 0)) (and-let* (x ((> x 0))) (+ x 1))))) + (should (equal nil (let ((x nil)) (and-let* (x ((> x 0))) (+ x 1))))) + (should + (equal nil (let ((x nil)) (and-let* (((progn x)) ((> x 0))) (+ x 1)))))) + +(ert-deftest subr-x-and-let*-test-group-3 () + (should + (equal nil (let ((x 1)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y))))) + (should + (equal nil (let ((x 0)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y))))) + (should + (equal nil + (let ((x nil)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y))))) + (should + (equal (/ 3.0 2) + (let ((x 3.0)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))) + + ;; Thread first tests