1 ;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el -*- lexical-binding:t -*-
3 ;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
5 ;; This file is part of GNU Emacs.
7 ;; This program is free software: you can redistribute it and/or
8 ;; modify it under the terms of the GNU General Public License as
9 ;; published by the Free Software Foundation, either version 3 of the
10 ;; License, or (at your option) any later version.
12 ;; This program is distributed in the hope that it will be useful, but
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;; General Public License for more details.
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with this program. If not, see `http://www.gnu.org/licenses/'.
22 ;; Extracted from ert-tests.el, back when ert used to reimplement some
30 (ert-deftest cl-lib-test-remprop
()
31 (let ((x (cl-gensym)))
32 (should (equal (symbol-plist x
) '()))
33 ;; Remove nonexistent property on empty plist.
35 (should (equal (symbol-plist x
) '()))
37 (should (equal (symbol-plist x
) '(a 1)))
38 ;; Remove nonexistent property on nonempty plist.
40 (should (equal (symbol-plist x
) '(a 1)))
44 (should (equal (symbol-plist x
) '(a 1 b
2 c
3 d
4)))
45 ;; Remove property that is neither first nor last.
47 (should (equal (symbol-plist x
) '(a 1 b
2 d
4)))
48 ;; Remove last property from a plist of length >1.
50 (should (equal (symbol-plist x
) '(a 1 b
2)))
51 ;; Remove first property from a plist of length >1.
53 (should (equal (symbol-plist x
) '(b 2)))
54 ;; Remove property when there is only one.
56 (should (equal (symbol-plist x
) '()))))
58 (ert-deftest cl-lib-test-remove-if-not
()
59 (let ((list (list 'a
'b
'c
'd
))
61 (let ((result (cl-remove-if-not (lambda (x)
62 (should (eql x
(nth i list
)))
67 (should (equal result
'(b c
)))
68 (should (equal list
'(a b c d
)))))
70 (cl-remove-if-not (lambda (_x) (should nil
)) '()))))
72 (ert-deftest cl-lib-test-remove
()
73 (let ((list (list 'a
'b
'c
'd
))
79 (should (eql x
(nth key-index list
)))
86 (should (equal b
(list test-index
87 (nth test-index list
))))
89 (member test-index
'(2 3))))))
90 (should (equal key-index
4))
91 (should (equal test-index
4))
92 (should (equal result
'(a d
)))
93 (should (equal list
'(a b c d
)))))
94 (let ((x (cons nil nil
))
96 (should (equal (cl-remove x
(list x y
))
97 ;; or (list x), since we use `equal' -- the
98 ;; important thing is that only one element got
99 ;; removed, this proves that the default test is
100 ;; `eql', not `equal'
104 (ert-deftest cl-lib-test-set-functions
()
105 (let ((c1 (cons nil nil
))
107 (sym (make-symbol "a")))
109 (a (list 'a
'b sym nil
"" "x" c1 c2
))
110 (b (list c1
'y
'b sym
'x
)))
111 (should (equal (cl-set-difference e e
) e
))
112 (should (equal (cl-set-difference a e
) a
))
113 (should (equal (cl-set-difference e a
) e
))
114 (should (equal (cl-set-difference a a
) e
))
115 (should (equal (cl-set-difference b e
) b
))
116 (should (equal (cl-set-difference e b
) e
))
117 (should (equal (cl-set-difference b b
) e
))
118 ;; Note: this test (and others) is sensitive to the order of the
119 ;; result, which is not documented.
120 (should (equal (cl-set-difference a b
) (list c2
"x" "" nil
'a
)))
121 (should (equal (cl-set-difference b a
) (list 'x
'y
)))
123 ;; We aren't testing whether this is really using `eq' rather than `eql'.
124 (should (equal (cl-set-difference e e
:test
'eq
) e
))
125 (should (equal (cl-set-difference a e
:test
'eq
) a
))
126 (should (equal (cl-set-difference e a
:test
'eq
) e
))
127 (should (equal (cl-set-difference a a
:test
'eq
) e
))
128 (should (equal (cl-set-difference b e
:test
'eq
) b
))
129 (should (equal (cl-set-difference e b
:test
'eq
) e
))
130 (should (equal (cl-set-difference b b
:test
'eq
) e
))
131 (should (equal (cl-set-difference a b
:test
'eq
) (list c2
"x" "" nil
'a
)))
132 (should (equal (cl-set-difference b a
:test
'eq
) (list 'x
'y
)))
134 (should (equal (cl-union e e
) e
))
135 (should (equal (cl-union a e
) a
))
136 (should (equal (cl-union e a
) a
))
137 (should (equal (cl-union a a
) a
))
138 (should (equal (cl-union b e
) b
))
139 (should (equal (cl-union e b
) b
))
140 (should (equal (cl-union b b
) b
))
141 (should (equal (cl-union a b
) (list 'x
'y
'a
'b sym nil
"" "x" c1 c2
)))
143 (should (equal (cl-union b a
) (list 'x
'y
'a
'b sym nil
"" "x" c1 c2
)))
145 (should (equal (cl-intersection e e
) e
))
146 (should (equal (cl-intersection a e
) e
))
147 (should (equal (cl-intersection e a
) e
))
148 (should (equal (cl-intersection a a
) a
))
149 (should (equal (cl-intersection b e
) e
))
150 (should (equal (cl-intersection e b
) e
))
151 (should (equal (cl-intersection b b
) b
))
152 (should (equal (cl-intersection a b
) (list sym
'b c1
)))
153 (should (equal (cl-intersection b a
) (list sym
'b c1
))))))
155 (ert-deftest cl-lib-test-gensym
()
156 ;; Since the expansion of `should' calls `cl-gensym' and thus has a
157 ;; side-effect on `cl--gensym-counter', we have to make sure all
158 ;; macros in our test body are expanded before we rebind
159 ;; `cl--gensym-counter' and run the body. Otherwise, the test would
160 ;; fail if run interpreted.
161 (let ((body (byte-compile
163 (should (equal (symbol-name (cl-gensym)) "G0"))
164 (should (equal (symbol-name (cl-gensym)) "G1"))
165 (should (equal (symbol-name (cl-gensym)) "G2"))
166 (should (equal (symbol-name (cl-gensym "foo")) "foo3"))
167 (should (equal (symbol-name (cl-gensym "bar")) "bar4"))
168 (should (equal cl--gensym-counter
5))))))
169 (let ((cl--gensym-counter 0))
172 (ert-deftest cl-lib-test-coerce-to-vector
()
177 (should (eql (cl-coerce a
'vector
) a
))
178 (should (eql (cl-coerce b
'vector
) b
))
179 (should (equal (cl-coerce c
'vector
) (vector)))
180 (should (equal (cl-coerce d
'vector
) (vector b a
)))))
182 (ert-deftest cl-lib-test-string-position
()
183 (should (eql (cl-position ?x
"") nil
))
184 (should (eql (cl-position ?a
"abc") 0))
185 (should (eql (cl-position ?b
"abc") 1))
186 (should (eql (cl-position ?c
"abc") 2))
187 (should (eql (cl-position ?d
"abc") nil
))
188 (should (eql (cl-position ?A
"abc") nil
)))
190 (ert-deftest cl-lib-test-mismatch
()
191 (should (eql (cl-mismatch "" "") nil
))
192 (should (eql (cl-mismatch "" "a") 0))
193 (should (eql (cl-mismatch "a" "a") nil
))
194 (should (eql (cl-mismatch "ab" "a") 1))
195 (should (eql (cl-mismatch "Aa" "aA") 0))
196 (should (eql (cl-mismatch '(a b c
) '(a b d
)) 2)))
198 (ert-deftest cl-lib-test-loop
()
199 (should (eql (cl-loop with
(a b c
) = '(1 2 3) return
(+ a b c
)) 6)))
201 (ert-deftest cl-lib-keyword-names-versus-values
()
203 (funcall (cl-function (lambda (&key a b
) (list a b
)))
207 (cl-defstruct (mystruct
208 (:constructor cl-lib--con-1
(&aux
(abc 1)))
209 (:constructor cl-lib--con-2
(&optional def
)))
210 (abc 5 :readonly t
) (def nil
))
211 (ert-deftest cl-lib-struct-accessors
()
212 (let ((x (make-mystruct :abc
1 :def
2)))
213 (should (eql (cl-struct-slot-value 'mystruct
'abc x
) 1))
214 (should (eql (cl-struct-slot-value 'mystruct
'def x
) 2))
215 (setf (cl-struct-slot-value 'mystruct
'def x
) -
1)
216 (should (eql (cl-struct-slot-value 'mystruct
'def x
) -
1))
217 (should (eql (cl-struct-slot-offset 'mystruct
'abc
) 1))
218 (should-error (cl-struct-slot-offset 'mystruct
'marypoppins
))
219 (should (pcase (cl-struct-slot-info 'mystruct
)
220 (`((cl-tag-slot) (abc 5 :readonly t
)
221 (def .
,(or `nil
`(nil))))
224 (ert-deftest cl-lib-arglist-performance
()
225 ;; An `&aux' should not cause lambda's arglist to be turned into an &rest
226 ;; that's parsed by hand.
227 (should (equal () (help-function-arglist 'cl-lib--con-1
)))
228 (should (pcase (help-function-arglist 'cl-lib--con-2
)
229 (`(&optional
,_
) t
))))
231 (ert-deftest cl-the
()
232 (should (eql (cl-the integer
42) 42))
233 (should-error (cl-the integer
"abc"))
234 (let ((side-effect 0))
235 (should (= (cl-the integer
(cl-incf side-effect
)) 1))
236 (should (= side-effect
1))))
238 (ert-deftest cl-lib-test-plusp
()
239 (should-not (cl-plusp -
1.0e
+INF
))
240 (should-not (cl-plusp -
1.5e2
))
241 (should-not (cl-plusp -
3.14))
242 (should-not (cl-plusp -
1))
243 (should-not (cl-plusp -
0.0))
244 (should-not (cl-plusp 0))
245 (should-not (cl-plusp 0.0))
246 (should-not (cl-plusp -
0.0e
+NaN
))
247 (should-not (cl-plusp 0.0e
+NaN
))
248 (should (cl-plusp 1))
249 (should (cl-plusp 3.14))
250 (should (cl-plusp 1.5e2
))
251 (should (cl-plusp 1.0e
+INF
))
252 (should-error (cl-plusp "42") :type
'wrong-type-argument
))
254 (ert-deftest cl-lib-test-minusp
()
255 (should (cl-minusp -
1.0e
+INF
))
256 (should (cl-minusp -
1.5e2
))
257 (should (cl-minusp -
3.14))
258 (should (cl-minusp -
1))
259 (should-not (cl-minusp -
0.0))
260 (should-not (cl-minusp 0))
261 (should-not (cl-minusp 0.0))
262 (should-not (cl-minusp -
0.0e
+NaN
))
263 (should-not (cl-minusp 0.0e
+NaN
))
264 (should-not (cl-minusp 1))
265 (should-not (cl-minusp 3.14))
266 (should-not (cl-minusp 1.5e2
))
267 (should-not (cl-minusp 1.0e
+INF
))
268 (should-error (cl-minusp "-42") :type
'wrong-type-argument
))
270 (ert-deftest cl-lib-test-oddp
()
271 (should (cl-oddp -
3))
273 (should-not (cl-oddp -
2))
274 (should-not (cl-oddp 0))
275 (should-not (cl-oddp 2))
276 (should-error (cl-oddp 3.0e
+NaN
) :type
'wrong-type-argument
)
277 (should-error (cl-oddp 3.0) :type
'wrong-type-argument
)
278 (should-error (cl-oddp "3") :type
'wrong-type-argument
))
280 (ert-deftest cl-lib-test-evenp
()
281 (should (cl-evenp -
2))
282 (should (cl-evenp 0))
283 (should (cl-evenp 2))
284 (should-not (cl-evenp -
3))
285 (should-not (cl-evenp 3))
286 (should-error (cl-evenp 2.0e
+NaN
) :type
'wrong-type-argument
)
287 (should-error (cl-evenp 2.0) :type
'wrong-type-argument
)
288 (should-error (cl-evenp "2") :type
'wrong-type-argument
))
290 (ert-deftest cl-digit-char-p
()
291 (should (eql 3 (cl-digit-char-p ?
3)))
292 (should (eql 10 (cl-digit-char-p ?a
11)))
293 (should (eql 10 (cl-digit-char-p ?A
11)))
294 (should-not (cl-digit-char-p ?a
))
295 (should (eql 32 (cl-digit-char-p ?w
36)))
296 (should-error (cl-digit-char-p ?a
37) :type
'args-out-of-range
)
297 (should-error (cl-digit-char-p ?a
1) :type
'args-out-of-range
))
299 (ert-deftest cl-lib-test-first
()
300 (should (null (cl-first '())))
301 (should (= 4 (cl-first '(4))))
302 (should (= 4 (cl-first '(4 2))))
303 (should-error (cl-first "42") :type
'wrong-type-argument
))
305 (ert-deftest cl-lib-test-second
()
306 (should (null (cl-second '())))
307 (should (null (cl-second '(4))))
308 (should (= 2 (cl-second '(1 2))))
309 (should (= 2 (cl-second '(1 2 3))))
310 (should-error (cl-second "1 2 3") :type
'wrong-type-argument
))
312 (ert-deftest cl-lib-test-third
()
313 (should (null (cl-third '())))
314 (should (null (cl-third '(1 2))))
315 (should (= 3 (cl-third '(1 2 3))))
316 (should (= 3 (cl-third '(1 2 3 4))))
317 (should-error (cl-third "123") :type
'wrong-type-argument
))
319 (ert-deftest cl-lib-test-fourth
()
320 (should (null (cl-fourth '())))
321 (should (null (cl-fourth '(1 2 3))))
322 (should (= 4 (cl-fourth '(1 2 3 4))))
323 (should (= 4 (cl-fourth '(1 2 3 4 5))))
324 (should-error (cl-fourth "1234") :type
'wrong-type-argument
))
326 (ert-deftest cl-lib-test-fifth
()
327 (should (null (cl-fifth '())))
328 (should (null (cl-fifth '(1 2 3 4))))
329 (should (= 5 (cl-fifth '(1 2 3 4 5))))
330 (should (= 5 (cl-fifth '(1 2 3 4 5 6))))
331 (should-error (cl-fifth "12345") :type
'wrong-type-argument
))
333 (ert-deftest cl-lib-test-fifth
()
334 (should (null (cl-fifth '())))
335 (should (null (cl-fifth '(1 2 3 4))))
336 (should (= 5 (cl-fifth '(1 2 3 4 5))))
337 (should (= 5 (cl-fifth '(1 2 3 4 5 6))))
338 (should-error (cl-fifth "12345") :type
'wrong-type-argument
))
340 (ert-deftest cl-lib-test-sixth
()
341 (should (null (cl-sixth '())))
342 (should (null (cl-sixth '(1 2 3 4 5))))
343 (should (= 6 (cl-sixth '(1 2 3 4 5 6))))
344 (should (= 6 (cl-sixth '(1 2 3 4 5 6 7))))
345 (should-error (cl-sixth "123456") :type
'wrong-type-argument
))
347 (ert-deftest cl-lib-test-seventh
()
348 (should (null (cl-seventh '())))
349 (should (null (cl-seventh '(1 2 3 4 5 6))))
350 (should (= 7 (cl-seventh '(1 2 3 4 5 6 7))))
351 (should (= 7 (cl-seventh '(1 2 3 4 5 6 7 8))))
352 (should-error (cl-seventh "1234567") :type
'wrong-type-argument
))
354 (ert-deftest cl-lib-test-eighth
()
355 (should (null (cl-eighth '())))
356 (should (null (cl-eighth '(1 2 3 4 5 6 7))))
357 (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8))))
358 (should (= 8 (cl-eighth '(1 2 3 4 5 6 7 8 9))))
359 (should-error (cl-eighth "12345678") :type
'wrong-type-argument
))
361 (ert-deftest cl-lib-test-ninth
()
362 (should (null (cl-ninth '())))
363 (should (null (cl-ninth '(1 2 3 4 5 6 7 8))))
364 (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9))))
365 (should (= 9 (cl-ninth '(1 2 3 4 5 6 7 8 9 10))))
366 (should-error (cl-ninth "123456789") :type
'wrong-type-argument
))
368 (ert-deftest cl-lib-test-tenth
()
369 (should (null (cl-tenth '())))
370 (should (null (cl-tenth '(1 2 3 4 5 6 7 8 9))))
371 (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10))))
372 (should (= 10 (cl-tenth '(1 2 3 4 5 6 7 8 9 10 11))))
373 (should-error (cl-tenth "1234567890") :type
'wrong-type-argument
))
375 (ert-deftest cl-lib-test-endp
()
376 (should (cl-endp '()))
377 (should-not (cl-endp '(1)))
378 (should-error (cl-endp 1) :type
'wrong-type-argument
)
379 (should-error (cl-endp [1]) :type 'wrong-type-argument))
381 (ert-deftest cl-lib-test-nth-value ()
382 (let ((vals (cl-values 2 3)))
383 (should (= (cl-nth-value 0 vals) 2))
384 (should (= (cl-nth-value 1 vals) 3))
385 (should (null (cl-nth-value 2 vals)))
386 (should-error (cl-nth-value 0.0 vals) :type 'wrong-type-argument)))
388 (ert-deftest cl-lib-nth-value-test-multiple-values ()
389 "While CL multiple values are an alias to list, these won't work."
390 :expected-result :failed
391 (should (eq (cl-nth-value 0 '(2 3)) '(2 3)))
392 (should (= (cl-nth-value 0 1) 1))
393 (should (null (cl-nth-value 1 1)))
394 (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range)
395 (should (string= (cl-nth-value 0 "only lists") "only lists")))
397 (ert-deftest cl-test-caaar ()
398 (should (null (cl-caaar '())))
399 (should (null (cl-caaar '(() (2)))))
400 (should (null (cl-caaar '((() (2)) (a b)))))
401 (should-error (cl-caaar '(1 2)) :type 'wrong-type-argument)
402 (should-error (cl-caaar '((1 2))) :type 'wrong-type-argument)
403 (should (= 1 (cl-caaar '(((1 2) (3 4))))))
404 (should (null (cl-caaar '((() (3 4)))))))
406 (ert-deftest cl-test-caadr ()
407 (should (null (cl-caadr '())))
408 (should (null (cl-caadr '(1))))
409 (should-error (cl-caadr '(1 2)) :type 'wrong-type-argument)
410 (should (= 2 (cl-caadr '(1 (2 3)))))
411 (should (equal '((2) (3)) (cl-caadr '((1) (((2) (3))) (4))))))
413 (ert-deftest cl-test-ldiff ()
415 (should (null (cl-ldiff '() '())))
416 (should (null (cl-ldiff '() l)))
417 (should (null (cl-ldiff l l)))
418 (should (equal l (cl-ldiff l '())))
419 ;; must be part of the list
420 (should (equal l (cl-ldiff l '(2 3))))
421 (should (equal '(1) (cl-ldiff l (nthcdr 1 l))))
422 ;; should return a copy
423 (should-not (eq (cl-ldiff l '()) l))))
425 (ert-deftest cl-lib-adjoin-test ()
428 ;; add non-existing item to the front
429 (should (equal '(3 1 2) (cl-adjoin 3 nums)))
430 ;; just add - don't copy rest
431 (should (eq nums (cdr (cl-adjoin 3 nums))))
432 ;; add only when not already there
433 (should (eq nums (cl-adjoin 2 nums)))
434 (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2)))))
435 ;; default test function is eql
436 (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums)))
437 ;; own :test function - returns true if match
438 (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test nil))) ;defaults to eql
439 (should (eq nums (cl-adjoin 2 nums :test myfn-p))) ;match
440 (should (equal '(3 1 2) (cl-adjoin 3 nums :test myfn-p))) ;no match
441 ;; own :test-not function - returns false if match
442 (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums :test-not nil))) ;defaults to eql
443 (should (equal '(2 2) (cl-adjoin 2 '(2) :test-not myfn-p))) ; no match
444 (should (eq nums (cl-adjoin 2 nums :test-not myfn-p))) ; 1 matches
445 (should (eq nums (cl-adjoin 3 nums :test-not myfn-p))) ; 1 and 2 matches
447 ;; according to CLTL2 passing both :test and :test-not should signal error
448 ;;(should-error (cl-adjoin 3 nums :test 'myfn-p :test-not myfn-p))
451 (should (eq nums (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (1+ x) x)))))
452 (should (equal '(3 1 2) (cl-adjoin 3 nums :key (lambda (x) (if (cl-evenp x) (+ 2 x) x)))))
454 ;; convert using :key, then compare with :test
455 (should (eq nums (cl-adjoin 1 nums :key 'int-to-string :test 'string=)))
456 (should (equal '(3 1 2) (cl-adjoin 3 nums :key 'int-to-string :test 'string=)))
457 (should-error (cl-adjoin 3 nums :key 'int-to-string :test myfn-p)
458 :type 'wrong-type-argument)
460 ;; convert using :key, then compare with :test-not
461 (should (eq nums (cl-adjoin 3 nums :key 'int-to-string :test-not 'string=)))
462 (should (equal '(1 1) (cl-adjoin 1 '(1) :key 'int-to-string :test-not 'string=)))
463 (should-error (cl-adjoin 1 nums :key 'int-to-string :test-not myfn-p)
464 :type 'wrong-type-argument)))
466 (ert-deftest cl-parse-integer ()
467 (should-error (cl-parse-integer "abc"))
468 (should (null (cl-parse-integer "abc" :junk-allowed t)))
469 (should (null (cl-parse-integer "" :junk-allowed t)))
470 (should (= 342391 (cl-parse-integer "0123456789" :radix 8 :junk-allowed t)))
471 (should-error (cl-parse-integer "0123456789" :radix 8))
472 (should (= -239 (cl-parse-integer "-efz" :radix 16 :junk-allowed t)))
473 (should-error (cl-parse-integer "efz" :radix 16))
474 (should (= 239 (cl-parse-integer "zzef" :radix 16 :start 2)))
475 (should (= -123 (cl-parse-integer " -123 "))))
477 (ert-deftest cl-loop-destructuring-with ()
478 (should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6)))
480 (ert-deftest cl-flet-test ()
481 (should (equal (cl-flet ((f1 (x) x)) (let ((x #'f1)) (funcall x 5))) 5)))
483 (ert-deftest cl-lib-test-typep ()
484 (cl-deftype cl-lib-test-type (&optional x) `(member ,x))
485 ;; Make sure we correctly implement the rule that deftype's optional args
486 ;; default to `*' rather than to nil.
487 (should (cl-typep '* 'cl-lib-test-type))
488 (should-not (cl-typep 1 'cl-lib-test-type)))
490 ;;; cl-lib.el ends here