aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMark Oteiza2017-09-12 12:44:45 -0400
committerMark Oteiza2017-09-12 13:18:06 -0400
commit4612b2a2b37026bef5a9b8e92878a15dabb9b261 (patch)
tree2434bb2f510047ae9570086c424266743411a39f
parentc87331a1c04aa4be55be7b944680e4ec486f5b04 (diff)
downloademacs-4612b2a2b37026bef5a9b8e92878a15dabb9b261.tar.gz
emacs-4612b2a2b37026bef5a9b8e92878a15dabb9b261.zip
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.
-rw-r--r--etc/NEWS12
-rw-r--r--lisp/emacs-lisp/subr-x.el108
-rw-r--r--test/lisp/emacs-lisp/subr-x-tests.el308
3 files changed, 238 insertions, 190 deletions
diff --git a/etc/NEWS b/etc/NEWS
index af29b29264d..03ef05b2a30 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1137,6 +1137,14 @@ be disabled by setting 'byte-compile-cond-use-jump-table' to nil.
1137** The alist 'ucs-names' is now a hash table. 1137** The alist 'ucs-names' is now a hash table.
1138 1138
1139--- 1139---
1140** 'if-let' and 'when-let' are subsumed by 'if-let*' and 'when-let*'.
1141The incumbent 'if-let' and 'when-let' are now marked obsolete.
1142'if-let*' and 'when-let*' do not accept the single tuple special case.
1143New macro 'and-let*' is an implementation of the Scheme SRFI-2 syntax
1144of the same name. 'if-let*' and 'when-let*' now accept the same
1145binding syntax as 'and-let*'.
1146
1147---
1140** 'C-up', 'C-down', 'C-left' and 'C-right' are now defined in term 1148** 'C-up', 'C-down', 'C-left' and 'C-right' are now defined in term
1141mode to send the same escape sequences that xterm does. This makes 1149mode to send the same escape sequences that xterm does. This makes
1142things like forward-word in readline work. 1150things like forward-word in readline work.
@@ -1529,10 +1537,6 @@ It avoids unnecessary consing (and garbage collection).
1529** 'gensym' is now part of Elisp. 1537** 'gensym' is now part of Elisp.
1530 1538
1531--- 1539---
1532** 'if-let*', 'when-let*', and 'and-let*' are new in subr-x.el.
1533The incumbent 'if-let' and 'when-let' are now aliases.
1534
1535---
1536** Low-level list functions like 'length' and 'member' now do a better 1540** Low-level list functions like 'length' and 'member' now do a better
1537job of signaling list cycles instead of looping indefinitely. 1541job of signaling list cycles instead of looping indefinitely.
1538 1542
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."
83 `(internal--thread-argument nil ,@forms)) 83 `(internal--thread-argument nil ,@forms))
84 84
85(defsubst internal--listify (elt) 85(defsubst internal--listify (elt)
86 "Wrap ELT in a list if it is not one." 86 "Wrap ELT in a list if it is not one.
87 (if (not (listp elt)) 87If ELT is of the form ((EXPR)), listify (EXPR) with a dummy symbol."
88 (list elt) 88 (cond
89 elt)) 89 ((symbolp elt) (list elt elt))
90 ((and (null (cdr elt))
91 (let ((form (car elt)))
92 (or (listp form) (atom form))))
93 (list (make-symbol "s") (car elt)))
94 (t elt)))
90 95
91(defsubst internal--check-binding (binding) 96(defsubst internal--check-binding (binding)
92 "Check BINDING is properly formed." 97 "Check BINDING is properly formed."
@@ -98,7 +103,10 @@ threading."
98 103
99(defsubst internal--build-binding-value-form (binding prev-var) 104(defsubst internal--build-binding-value-form (binding prev-var)
100 "Build the conditional value form for BINDING using PREV-VAR." 105 "Build the conditional value form for BINDING using PREV-VAR."
101 `(,(car binding) (and ,prev-var ,(cadr binding)))) 106 (let ((var (car binding)))
107 (if (and (null (cdr binding)) (atom (car binding)) (not (symbolp (car binding))))
108 `(,var (and ,prev-var ,var))
109 `(,var (and ,prev-var ,(cadr binding))))))
102 110
103(defun internal--build-binding (binding prev-var) 111(defun internal--build-binding (binding prev-var)
104 "Check and build a single BINDING with PREV-VAR." 112 "Check and build a single BINDING with PREV-VAR."
@@ -117,44 +125,68 @@ threading."
117 binding)) 125 binding))
118 bindings))) 126 bindings)))
119 127
120(defmacro if-let* (bindings then &rest else) 128(defmacro if-let* (varlist then &rest else)
121 "Bind variables according to VARLIST and eval THEN or ELSE. 129 "Bind variables according to VARLIST and eval THEN or ELSE.
122Each binding is evaluated in turn with `let*', and evaluation 130Each binding is evaluated in turn, and evaluation stops if a
123stops if a binding value is nil. If all are non-nil, the value 131binding value is nil. If all are non-nil, the value of THEN is
124of THEN is returned, or the last form in ELSE is returned. 132returned, or the last form in ELSE is returned.
125Each element of VARLIST is a symbol (which is bound to nil) 133
126or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). 134Each element of VARLIST is a list (SYMBOL VALUEFORM) which binds
127In the special case you only want to bind a single value, 135SYMBOL to the value of VALUEFORM).
128VARLIST can just be a plain tuple. 136An element can additionally be of the form (VALUEFORM), which is
129\n(fn VARLIST THEN ELSE...)" 137evaluated and checked for nil."
130 (declare (indent 2) 138 (declare (indent 2)
131 (debug ([&or (&rest [&or symbolp (symbolp form)]) (symbolp form)] 139 (debug ((&rest [&or symbolp (symbolp form) (sexp)])
132 form body))) 140 form body)))
133 (when (and (<= (length bindings) 2) 141 (if varlist
134 (not (listp (car bindings)))) 142 `(let* ,(setq varlist (internal--build-bindings varlist))
135 ;; Adjust the single binding case 143 (if ,(caar (last varlist))
136 (setq bindings (list bindings))) 144 ,then
137 `(let* ,(internal--build-bindings bindings) 145 ,@else))
138 (if ,(car (internal--listify (car (last bindings)))) 146 `(let* () ,@else)))
139 ,then 147
140 ,@else))) 148(defmacro when-let* (varlist &rest body)
149 "Bind variables according to VARLIST and conditionally eval BODY.
150Each binding is evaluated in turn, and evaluation stops if a
151binding value is nil. If all are non-nil, the value of the last
152form in BODY is returned.
153
154VARLIST is the same as in `if-let*'."
155 (declare (indent 1) (debug if-let*))
156 (list 'if-let* varlist (macroexp-progn body)))
141 157
142(defmacro when-let* (bindings &rest body) 158(defmacro and-let* (varlist &rest body)
143 "Bind variables according to VARLIST and conditionally eval BODY. 159 "Bind variables according to VARLIST and conditionally eval BODY.
144Each binding is evaluated in turn with `let*', and evaluation 160Like `when-let*', except if BODY is empty and all the bindings
145stops if a binding value is nil. If all are non-nil, the value 161are non-nil, then the result is non-nil."
146of the last form in BODY is returned. 162 (declare (indent 1) (debug when-let*))
147Each element of VARLIST is a symbol (which is bound to nil) 163 (let (res)
148or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM). 164 (if varlist
149In the special case you only want to bind a single value, 165 `(let* ,(setq varlist (internal--build-bindings varlist))
150VARLIST can just be a plain tuple. 166 (if ,(setq res (caar (last varlist)))
151\n(fn VARLIST BODY...)" 167 ,@(or body `(,res))))
152 (declare (indent 1) (debug if-let)) 168 `(let* () ,@(or body '(t))))))
153 (list 'if-let bindings (macroexp-progn body))) 169
154 170(defmacro if-let (spec then &rest else)
155(defalias 'if-let 'if-let*) 171 "Bind variables according to SPEC and eval THEN or ELSE.
156(defalias 'when-let 'when-let*) 172Like `if-let*' except SPEC can have the form (SYMBOL VALUEFORM)."
157(defalias 'and-let* 'when-let*) 173 (declare (indent 2)
174 (debug ([&or (&rest [&or symbolp (symbolp form) (sexp)])
175 (symbolp form)]
176 form body))
177 (obsolete "use `if-let*' instead." "26.1"))
178 (when (and (<= (length spec) 2)
179 (not (listp (car spec))))
180 ;; Adjust the single binding case
181 (setq spec (list spec)))
182 (list 'if-let* spec then (macroexp-progn else)))
183
184(defmacro when-let (spec &rest body)
185 "Bind variables according to SPEC and conditionally eval BODY.
186Like `when-let*' except SPEC can have the form (SYMBOL VALUEFORM)."
187 (declare (indent 1) (debug if-let)
188 (obsolete "use `when-let*' instead." "26.1"))
189 (list 'if-let spec (macroexp-progn body)))
158 190
159(defsubst hash-table-empty-p (hash-table) 191(defsubst hash-table-empty-p (hash-table)
160 "Check whether HASH-TABLE is empty (has 0 elements)." 192 "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 @@
28(require 'subr-x) 28(require 'subr-x)
29 29
30 30
31;; if-let tests 31;; `if-let*' tests
32 32
33(ert-deftest subr-x-test-if-let-single-binding-expansion () 33(ert-deftest subr-x-test-if-let*-single-binding-expansion ()
34 "Test single bindings are expanded properly." 34 "Test single bindings are expanded properly."
35 (should (equal 35 (should (equal
36 (macroexpand 36 (macroexpand
37 '(if-let (a 1) 37 '(if-let* ((a 1))
38 (- a) 38 (- a)
39 "no")) 39 "no"))
40 '(let* ((a (and t 1))) 40 '(let* ((a (and t 1)))
@@ -43,53 +43,53 @@
43 "no")))) 43 "no"))))
44 (should (equal 44 (should (equal
45 (macroexpand 45 (macroexpand
46 '(if-let (a) 46 '(if-let* (a)
47 (- a) 47 (- a)
48 "no")) 48 "no"))
49 '(let* ((a (and t nil))) 49 '(let* ((a (and t a)))
50 (if a 50 (if a
51 (- a) 51 (- a)
52 "no"))))) 52 "no")))))
53 53
54(ert-deftest subr-x-test-if-let-single-symbol-expansion () 54(ert-deftest subr-x-test-if-let*-single-symbol-expansion ()
55 "Test single symbol bindings are expanded properly." 55 "Test single symbol bindings are expanded properly."
56 (should (equal 56 (should (equal
57 (macroexpand 57 (macroexpand
58 '(if-let (a) 58 '(if-let* (a)
59 (- a) 59 (- a)
60 "no")) 60 "no"))
61 '(let* ((a (and t nil))) 61 '(let* ((a (and t a)))
62 (if a 62 (if a
63 (- a) 63 (- a)
64 "no")))) 64 "no"))))
65 (should (equal 65 (should (equal
66 (macroexpand 66 (macroexpand
67 '(if-let (a b c) 67 '(if-let* (a b c)
68 (- a) 68 (- a)
69 "no")) 69 "no"))
70 '(let* ((a (and t nil)) 70 '(let* ((a (and t a))
71 (b (and a nil)) 71 (b (and a b))
72 (c (and b nil))) 72 (c (and b c)))
73 (if c 73 (if c
74 (- a) 74 (- a)
75 "no")))) 75 "no"))))
76 (should (equal 76 (should (equal
77 (macroexpand 77 (macroexpand
78 '(if-let (a (b 2) c) 78 '(if-let* (a (b 2) c)
79 (- a) 79 (- a)
80 "no")) 80 "no"))
81 '(let* ((a (and t nil)) 81 '(let* ((a (and t a))
82 (b (and a 2)) 82 (b (and a 2))
83 (c (and b nil))) 83 (c (and b c)))
84 (if c 84 (if c
85 (- a) 85 (- a)
86 "no"))))) 86 "no")))))
87 87
88(ert-deftest subr-x-test-if-let-nil-related-expansion () 88(ert-deftest subr-x-test-if-let*-nil-related-expansion ()
89 "Test nil is processed properly." 89 "Test nil is processed properly."
90 (should (equal 90 (should (equal
91 (macroexpand 91 (macroexpand
92 '(if-let (nil) 92 '(if-let* (nil)
93 (- a) 93 (- a)
94 "no")) 94 "no"))
95 '(let* ((nil (and t nil))) 95 '(let* ((nil (and t nil)))
@@ -98,27 +98,7 @@
98 "no")))) 98 "no"))))
99 (should (equal 99 (should (equal
100 (macroexpand 100 (macroexpand
101 '(if-let ((nil)) 101 '(if-let* ((a 1) nil (b 2))
102 (- a)
103 "no"))
104 '(let* ((nil (and t nil)))
105 (if nil
106 (- a)
107 "no"))))
108 (should (equal
109 (macroexpand
110 '(if-let ((a 1) (nil) (b 2))
111 (- a)
112 "no"))
113 '(let* ((a (and t 1))
114 (nil (and a nil))
115 (b (and nil 2)))
116 (if b
117 (- a)
118 "no"))))
119 (should (equal
120 (macroexpand
121 '(if-let ((a 1) nil (b 2))
122 (- a) 102 (- a)
123 "no")) 103 "no"))
124 '(let* ((a (and t 1)) 104 '(let* ((a (and t 1))
@@ -128,104 +108,106 @@
128 (- a) 108 (- a)
129 "no"))))) 109 "no")))))
130 110
131(ert-deftest subr-x-test-if-let-malformed-binding () 111(ert-deftest subr-x-test-if-let*-malformed-binding ()
132 "Test malformed bindings trigger errors." 112 "Test malformed bindings trigger errors."
133 (should-error (macroexpand 113 (should-error (macroexpand
134 '(if-let (_ (a 1 1) (b 2) (c 3) d) 114 '(if-let* (_ (a 1 1) (b 2) (c 3) d)
135 (- a) 115 (- a)
136 "no")) 116 "no"))
137 :type 'error) 117 :type 'error)
138 (should-error (macroexpand 118 (should-error (macroexpand
139 '(if-let (_ (a 1) (b 2 2) (c 3) d) 119 '(if-let* (_ (a 1) (b 2 2) (c 3) d)
140 (- a) 120 (- a)
141 "no")) 121 "no"))
142 :type 'error) 122 :type 'error)
143 (should-error (macroexpand 123 (should-error (macroexpand
144 '(if-let (_ (a 1) (b 2) (c 3 3) d) 124 '(if-let* (_ (a 1) (b 2) (c 3 3) d)
145 (- a) 125 (- a)
146 "no")) 126 "no"))
147 :type 'error) 127 :type 'error)
148 (should-error (macroexpand 128 (should-error (macroexpand
149 '(if-let ((a 1 1)) 129 '(if-let* ((a 1 1))
150 (- a) 130 (- a)
151 "no")) 131 "no"))
152 :type 'error)) 132 :type 'error))
153 133
154(ert-deftest subr-x-test-if-let-true () 134(ert-deftest subr-x-test-if-let*-true ()
155 "Test `if-let' with truthy bindings." 135 "Test `if-let' with truthy bindings."
156 (should (equal 136 (should (equal
157 (if-let (a 1) 137 (if-let* ((a 1))
158 a 138 a
159 "no") 139 "no")
160 1)) 140 1))
161 (should (equal 141 (should (equal
162 (if-let ((a 1) (b 2) (c 3)) 142 (if-let* ((a 1) (b 2) (c 3))
163 (list a b c) 143 (list a b c)
164 "no") 144 "no")
165 (list 1 2 3)))) 145 (list 1 2 3))))
166 146
167(ert-deftest subr-x-test-if-let-false () 147(ert-deftest subr-x-test-if-let*-false ()
168 "Test `if-let' with falsie bindings." 148 "Test `if-let' with falsie bindings."
169 (should (equal 149 (should (equal
170 (if-let (a nil) 150 (if-let* ((a nil))
171 (list a b c) 151 (list a b c)
172 "no") 152 "no")
173 "no")) 153 "no"))
174 (should (equal 154 (should (equal
175 (if-let ((a nil) (b 2) (c 3)) 155 (if-let* ((a nil) (b 2) (c 3))
176 (list a b c) 156 (list a b c)
177 "no") 157 "no")
178 "no")) 158 "no"))
179 (should (equal 159 (should (equal
180 (if-let ((a 1) (b nil) (c 3)) 160 (if-let* ((a 1) (b nil) (c 3))
181 (list a b c) 161 (list a b c)
182 "no") 162 "no")
183 "no")) 163 "no"))
184 (should (equal 164 (should (equal
185 (if-let ((a 1) (b 2) (c nil)) 165 (if-let* ((a 1) (b 2) (c nil))
186 (list a b c) 166 (list a b c)
187 "no") 167 "no")
188 "no")) 168 "no"))
189 (should (equal 169 (should (equal
190 (if-let (z (a 1) (b 2) (c 3)) 170 (let (z)
191 (list a b c) 171 (if-let* (z (a 1) (b 2) (c 3))
192 "no") 172 (list a b c)
173 "no"))
193 "no")) 174 "no"))
194 (should (equal 175 (should (equal
195 (if-let ((a 1) (b 2) (c 3) d) 176 (let (d)
196 (list a b c) 177 (if-let* ((a 1) (b 2) (c 3) d)
197 "no") 178 (list a b c)
179 "no"))
198 "no"))) 180 "no")))
199 181
200(ert-deftest subr-x-test-if-let-bound-references () 182(ert-deftest subr-x-test-if-let*-bound-references ()
201 "Test `if-let' bindings can refer to already bound symbols." 183 "Test `if-let' bindings can refer to already bound symbols."
202 (should (equal 184 (should (equal
203 (if-let ((a (1+ 0)) (b (1+ a)) (c (1+ b))) 185 (if-let* ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
204 (list a b c) 186 (list a b c)
205 "no") 187 "no")
206 (list 1 2 3)))) 188 (list 1 2 3))))
207 189
208(ert-deftest subr-x-test-if-let-and-laziness-is-preserved () 190(ert-deftest subr-x-test-if-let*-and-laziness-is-preserved ()
209 "Test `if-let' respects `and' laziness." 191 "Test `if-let' respects `and' laziness."
210 (let (a-called b-called c-called) 192 (let (a-called b-called c-called)
211 (should (equal 193 (should (equal
212 (if-let ((a nil) 194 (if-let* ((a nil)
213 (b (setq b-called t)) 195 (b (setq b-called t))
214 (c (setq c-called t))) 196 (c (setq c-called t)))
215 "yes" 197 "yes"
216 (list a-called b-called c-called)) 198 (list a-called b-called c-called))
217 (list nil nil nil)))) 199 (list nil nil nil))))
218 (let (a-called b-called c-called) 200 (let (a-called b-called c-called)
219 (should (equal 201 (should (equal
220 (if-let ((a (setq a-called t)) 202 (if-let* ((a (setq a-called t))
221 (b nil) 203 (b nil)
222 (c (setq c-called t))) 204 (c (setq c-called t)))
223 "yes" 205 "yes"
224 (list a-called b-called c-called)) 206 (list a-called b-called c-called))
225 (list t nil nil)))) 207 (list t nil nil))))
226 (let (a-called b-called c-called) 208 (let (a-called b-called c-called)
227 (should (equal 209 (should (equal
228 (if-let ((a (setq a-called t)) 210 (if-let* ((a (setq a-called t))
229 (b (setq b-called t)) 211 (b (setq b-called t))
230 (c nil) 212 (c nil)
231 (d (setq c-called t))) 213 (d (setq c-called t)))
@@ -234,13 +216,13 @@
234 (list t t nil))))) 216 (list t t nil)))))
235 217
236 218
237;; when-let tests 219;; `when-let*' tests
238 220
239(ert-deftest subr-x-test-when-let-body-expansion () 221(ert-deftest subr-x-test-when-let*-body-expansion ()
240 "Test body allows for multiple sexps wrapping with progn." 222 "Test body allows for multiple sexps wrapping with progn."
241 (should (equal 223 (should (equal
242 (macroexpand 224 (macroexpand
243 '(when-let (a 1) 225 '(when-let* ((a 1))
244 (message "opposite") 226 (message "opposite")
245 (- a))) 227 (- a)))
246 '(let* ((a (and t 1))) 228 '(let* ((a (and t 1)))
@@ -249,79 +231,46 @@
249 (message "opposite") 231 (message "opposite")
250 (- a))))))) 232 (- a)))))))
251 233
252(ert-deftest subr-x-test-when-let-single-binding-expansion () 234(ert-deftest subr-x-test-when-let*-single-symbol-expansion ()
253 "Test single bindings are expanded properly."
254 (should (equal
255 (macroexpand
256 '(when-let (a 1)
257 (- a)))
258 '(let* ((a (and t 1)))
259 (if a
260 (- a)))))
261 (should (equal
262 (macroexpand
263 '(when-let (a)
264 (- a)))
265 '(let* ((a (and t nil)))
266 (if a
267 (- a))))))
268
269(ert-deftest subr-x-test-when-let-single-symbol-expansion ()
270 "Test single symbol bindings are expanded properly." 235 "Test single symbol bindings are expanded properly."
271 (should (equal 236 (should (equal
272 (macroexpand 237 (macroexpand
273 '(when-let (a) 238 '(when-let* (a)
274 (- a))) 239 (- a)))
275 '(let* ((a (and t nil))) 240 '(let* ((a (and t a)))
276 (if a 241 (if a
277 (- a))))) 242 (- a)))))
278 (should (equal 243 (should (equal
279 (macroexpand 244 (macroexpand
280 '(when-let (a b c) 245 '(when-let* (a b c)
281 (- a))) 246 (- a)))
282 '(let* ((a (and t nil)) 247 '(let* ((a (and t a))
283 (b (and a nil)) 248 (b (and a b))
284 (c (and b nil))) 249 (c (and b c)))
285 (if c 250 (if c
286 (- a))))) 251 (- a)))))
287 (should (equal 252 (should (equal
288 (macroexpand 253 (macroexpand
289 '(when-let (a (b 2) c) 254 '(when-let* (a (b 2) c)
290 (- a))) 255 (- a)))
291 '(let* ((a (and t nil)) 256 '(let* ((a (and t a))
292 (b (and a 2)) 257 (b (and a 2))
293 (c (and b nil))) 258 (c (and b c)))
294 (if c 259 (if c
295 (- a)))))) 260 (- a))))))
296 261
297(ert-deftest subr-x-test-when-let-nil-related-expansion () 262(ert-deftest subr-x-test-when-let*-nil-related-expansion ()
298 "Test nil is processed properly." 263 "Test nil is processed properly."
299 (should (equal 264 (should (equal
300 (macroexpand 265 (macroexpand
301 '(when-let (nil) 266 '(when-let* (nil)
302 (- a)))
303 '(let* ((nil (and t nil)))
304 (if nil
305 (- a)))))
306 (should (equal
307 (macroexpand
308 '(when-let ((nil))
309 (- a))) 267 (- a)))
310 '(let* ((nil (and t nil))) 268 '(let* ((nil (and t nil)))
311 (if nil 269 (if nil
312 (- a))))) 270 (- a)))))
313 (should (equal 271 (should (equal
314 (macroexpand 272 (macroexpand
315 '(when-let ((a 1) (nil) (b 2)) 273 '(when-let* ((a 1) nil (b 2))
316 (- a)))
317 '(let* ((a (and t 1))
318 (nil (and a nil))
319 (b (and nil 2)))
320 (if b
321 (- a)))))
322 (should (equal
323 (macroexpand
324 '(when-let ((a 1) nil (b 2))
325 (- a))) 274 (- a)))
326 '(let* ((a (and t 1)) 275 '(let* ((a (and t 1))
327 (nil (and a nil)) 276 (nil (and a nil))
@@ -329,108 +278,171 @@
329 (if b 278 (if b
330 (- a)))))) 279 (- a))))))
331 280
332(ert-deftest subr-x-test-when-let-malformed-binding () 281(ert-deftest subr-x-test-when-let*-malformed-binding ()
333 "Test malformed bindings trigger errors." 282 "Test malformed bindings trigger errors."
334 (should-error (macroexpand 283 (should-error (macroexpand
335 '(when-let (_ (a 1 1) (b 2) (c 3) d) 284 '(when-let* (_ (a 1 1) (b 2) (c 3) d)
336 (- a))) 285 (- a)))
337 :type 'error) 286 :type 'error)
338 (should-error (macroexpand 287 (should-error (macroexpand
339 '(when-let (_ (a 1) (b 2 2) (c 3) d) 288 '(when-let* (_ (a 1) (b 2 2) (c 3) d)
340 (- a))) 289 (- a)))
341 :type 'error) 290 :type 'error)
342 (should-error (macroexpand 291 (should-error (macroexpand
343 '(when-let (_ (a 1) (b 2) (c 3 3) d) 292 '(when-let* (_ (a 1) (b 2) (c 3 3) d)
344 (- a))) 293 (- a)))
345 :type 'error) 294 :type 'error)
346 (should-error (macroexpand 295 (should-error (macroexpand
347 '(when-let ((a 1 1)) 296 '(when-let* ((a 1 1))
348 (- a))) 297 (- a)))
349 :type 'error)) 298 :type 'error))
350 299
351(ert-deftest subr-x-test-when-let-true () 300(ert-deftest subr-x-test-when-let*-true ()
352 "Test `when-let' with truthy bindings." 301 "Test `when-let' with truthy bindings."
353 (should (equal 302 (should (equal
354 (when-let (a 1) 303 (when-let* ((a 1))
355 a) 304 a)
356 1)) 305 1))
357 (should (equal 306 (should (equal
358 (when-let ((a 1) (b 2) (c 3)) 307 (when-let* ((a 1) (b 2) (c 3))
359 (list a b c)) 308 (list a b c))
360 (list 1 2 3)))) 309 (list 1 2 3))))
361 310
362(ert-deftest subr-x-test-when-let-false () 311(ert-deftest subr-x-test-when-let*-false ()
363 "Test `when-let' with falsie bindings." 312 "Test `when-let' with falsie bindings."
364 (should (equal 313 (should (equal
365 (when-let (a nil) 314 (when-let* ((a nil))
366 (list a b c) 315 (list a b c)
367 "no") 316 "no")
368 nil)) 317 nil))
369 (should (equal 318 (should (equal
370 (when-let ((a nil) (b 2) (c 3)) 319 (when-let* ((a nil) (b 2) (c 3))
371 (list a b c) 320 (list a b c)
372 "no") 321 "no")
373 nil)) 322 nil))
374 (should (equal 323 (should (equal
375 (when-let ((a 1) (b nil) (c 3)) 324 (when-let* ((a 1) (b nil) (c 3))
376 (list a b c) 325 (list a b c)
377 "no") 326 "no")
378 nil)) 327 nil))
379 (should (equal 328 (should (equal
380 (when-let ((a 1) (b 2) (c nil)) 329 (when-let* ((a 1) (b 2) (c nil))
381 (list a b c) 330 (list a b c)
382 "no") 331 "no")
383 nil)) 332 nil))
384 (should (equal 333 (should (equal
385 (when-let (z (a 1) (b 2) (c 3)) 334 (let (z)
386 (list a b c) 335 (when-let* (z (a 1) (b 2) (c 3))
387 "no") 336 (list a b c)
337 "no"))
388 nil)) 338 nil))
389 (should (equal 339 (should (equal
390 (when-let ((a 1) (b 2) (c 3) d) 340 (let (d)
391 (list a b c) 341 (when-let* ((a 1) (b 2) (c 3) d)
392 "no") 342 (list a b c)
343 "no"))
393 nil))) 344 nil)))
394 345
395(ert-deftest subr-x-test-when-let-bound-references () 346(ert-deftest subr-x-test-when-let*-bound-references ()
396 "Test `when-let' bindings can refer to already bound symbols." 347 "Test `when-let' bindings can refer to already bound symbols."
397 (should (equal 348 (should (equal
398 (when-let ((a (1+ 0)) (b (1+ a)) (c (1+ b))) 349 (when-let* ((a (1+ 0)) (b (1+ a)) (c (1+ b)))
399 (list a b c)) 350 (list a b c))
400 (list 1 2 3)))) 351 (list 1 2 3))))
401 352
402(ert-deftest subr-x-test-when-let-and-laziness-is-preserved () 353(ert-deftest subr-x-test-when-let*-and-laziness-is-preserved ()
403 "Test `when-let' respects `and' laziness." 354 "Test `when-let' respects `and' laziness."
404 (let (a-called b-called c-called) 355 (let (a-called b-called c-called)
405 (should (equal 356 (should (equal
406 (progn 357 (progn
407 (when-let ((a nil) 358 (when-let* ((a nil)
408 (b (setq b-called t)) 359 (b (setq b-called t))
409 (c (setq c-called t))) 360 (c (setq c-called t)))
410 "yes") 361 "yes")
411 (list a-called b-called c-called)) 362 (list a-called b-called c-called))
412 (list nil nil nil)))) 363 (list nil nil nil))))
413 (let (a-called b-called c-called) 364 (let (a-called b-called c-called)
414 (should (equal 365 (should (equal
415 (progn 366 (progn
416 (when-let ((a (setq a-called t)) 367 (when-let* ((a (setq a-called t))
417 (b nil) 368 (b nil)
418 (c (setq c-called t))) 369 (c (setq c-called t)))
419 "yes") 370 "yes")
420 (list a-called b-called c-called)) 371 (list a-called b-called c-called))
421 (list t nil nil)))) 372 (list t nil nil))))
422 (let (a-called b-called c-called) 373 (let (a-called b-called c-called)
423 (should (equal 374 (should (equal
424 (progn 375 (progn
425 (when-let ((a (setq a-called t)) 376 (when-let* ((a (setq a-called t))
426 (b (setq b-called t)) 377 (b (setq b-called t))
427 (c nil) 378 (c nil)
428 (d (setq c-called t))) 379 (d (setq c-called t)))
429 "yes") 380 "yes")
430 (list a-called b-called c-called)) 381 (list a-called b-called c-called))
431 (list t t nil))))) 382 (list t t nil)))))
432 383
433 384
385;; `and-let*' tests
386
387;; Adapted from the Guile tests
388;; https://git.savannah.gnu.org/cgit/guile.git/tree/test-suite/tests/srfi-2.test
389
390(ert-deftest subr-x-and-let*-test-empty-varlist ()
391 (should (equal 1 (and-let* () 1)))
392 (should (equal 2 (and-let* () 1 2)))
393 (should (equal t (and-let* ()))))
394
395(ert-deftest subr-x-and-let*-test-group-1 ()
396 (should (equal nil (let ((x nil)) (and-let* (x)))))
397 (should (equal 1 (let ((x 1)) (and-let* (x)))))
398 (should (equal nil (and-let* ((x nil)))))
399 (should (equal 1 (and-let* ((x 1)))))
400 (should-error (and-let* (nil (x 1))) :type 'setting-constant)
401 (should (equal nil (and-let* ((nil) (x 1)))))
402 (should-error (and-let* (2 (x 1))) :type 'wrong-type-argument)
403 (should (equal 1 (and-let* ((2) (x 1)))))
404 (should (equal 2 (and-let* ((x 1) (2)))))
405 (should (equal nil (let ((x nil)) (and-let* (x) x))))
406 (should (equal "" (let ((x "")) (and-let* (x) x))))
407 (should (equal "" (let ((x "")) (and-let* (x)))))
408 (should (equal 2 (let ((x 1)) (and-let* (x) (+ x 1)))))
409 (should (equal nil (let ((x nil)) (and-let* (x) (+ x 1)))))
410 (should (equal 2 (let ((x 1)) (and-let* (((> x 0))) (+ x 1)))))
411 (should (equal t (let ((x 1)) (and-let* (((> x 0)))))))
412 (should (equal nil (let ((x 0)) (and-let* (((> x 0))) (+ x 1)))))
413 (should (equal 3
414 (let ((x 1)) (and-let* (((> x 0)) (x (+ x 1))) (+ x 1))))))
415
416(ert-deftest subr-x-and-let*-test-rebind ()
417 (should
418 (equal 4
419 (let ((x 1))
420 (and-let* (((> x 0)) (x (+ x 1)) (x (+ x 1))) (+ x 1))))))
421
422(ert-deftest subr-x-and-let*-test-group-2 ()
423 (should
424 (equal 2 (let ((x 1)) (and-let* (x ((> x 0))) (+ x 1)))))
425 (should
426 (equal 2 (let ((x 1)) (and-let* (((progn x)) ((> x 0))) (+ x 1)))))
427 (should (equal nil (let ((x 0)) (and-let* (x ((> x 0))) (+ x 1)))))
428 (should (equal nil (let ((x nil)) (and-let* (x ((> x 0))) (+ x 1)))))
429 (should
430 (equal nil (let ((x nil)) (and-let* (((progn x)) ((> x 0))) (+ x 1))))))
431
432(ert-deftest subr-x-and-let*-test-group-3 ()
433 (should
434 (equal nil (let ((x 1)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))
435 (should
436 (equal nil (let ((x 0)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))
437 (should
438 (equal nil
439 (let ((x nil)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))
440 (should
441 (equal (/ 3.0 2)
442 (let ((x 3.0)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y))))))
443
444
445
434;; Thread first tests 446;; Thread first tests
435 447
436(ert-deftest subr-x-test-thread-first-no-forms () 448(ert-deftest subr-x-test-thread-first-no-forms ()