Commit | Line | Data |
---|---|---|
a19b3c2d GM |
1 | ;;; cl-lib.el --- tests for emacs-lisp/cl-lib.el |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2013-2014 Free Software Foundation, Inc. |
a19b3c2d GM |
4 | |
5 | ;; This file is part of GNU Emacs. | |
6 | ||
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. | |
11 | ;; | |
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. | |
16 | ;; | |
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/'. | |
19 | ||
20 | ;;; Commentary: | |
21 | ||
22 | ;; Extracted from ert-tests.el, back when ert used to reimplement some | |
23 | ;; cl functions. | |
24 | ||
25 | ;;; Code: | |
26 | ||
27 | (require 'cl-lib) | |
28 | (require 'ert) | |
29 | ||
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. | |
34 | (cl-remprop x 'b) | |
35 | (should (equal (symbol-plist x) '())) | |
36 | (put x 'a 1) | |
37 | (should (equal (symbol-plist x) '(a 1))) | |
38 | ;; Remove nonexistent property on nonempty plist. | |
39 | (cl-remprop x 'b) | |
40 | (should (equal (symbol-plist x) '(a 1))) | |
41 | (put x 'b 2) | |
42 | (put x 'c 3) | |
43 | (put x 'd 4) | |
44 | (should (equal (symbol-plist x) '(a 1 b 2 c 3 d 4))) | |
45 | ;; Remove property that is neither first nor last. | |
46 | (cl-remprop x 'c) | |
47 | (should (equal (symbol-plist x) '(a 1 b 2 d 4))) | |
48 | ;; Remove last property from a plist of length >1. | |
49 | (cl-remprop x 'd) | |
50 | (should (equal (symbol-plist x) '(a 1 b 2))) | |
51 | ;; Remove first property from a plist of length >1. | |
52 | (cl-remprop x 'a) | |
53 | (should (equal (symbol-plist x) '(b 2))) | |
54 | ;; Remove property when there is only one. | |
55 | (cl-remprop x 'b) | |
56 | (should (equal (symbol-plist x) '())))) | |
57 | ||
58 | (ert-deftest cl-lib-test-remove-if-not () | |
59 | (let ((list (list 'a 'b 'c 'd)) | |
60 | (i 0)) | |
61 | (let ((result (cl-remove-if-not (lambda (x) | |
62 | (should (eql x (nth i list))) | |
63 | (cl-incf i) | |
64 | (member i '(2 3))) | |
65 | list))) | |
66 | (should (equal i 4)) | |
67 | (should (equal result '(b c))) | |
68 | (should (equal list '(a b c d))))) | |
69 | (should (equal '() | |
70 | (cl-remove-if-not (lambda (_x) (should nil)) '())))) | |
71 | ||
72 | (ert-deftest cl-lib-test-remove () | |
73 | (let ((list (list 'a 'b 'c 'd)) | |
74 | (key-index 0) | |
75 | (test-index 0)) | |
76 | (let ((result | |
77 | (cl-remove 'foo list | |
78 | :key (lambda (x) | |
79 | (should (eql x (nth key-index list))) | |
80 | (prog1 | |
81 | (list key-index x) | |
82 | (cl-incf key-index))) | |
83 | :test | |
84 | (lambda (a b) | |
85 | (should (eql a 'foo)) | |
86 | (should (equal b (list test-index | |
87 | (nth test-index list)))) | |
88 | (cl-incf test-index) | |
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)) | |
95 | (y (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' | |
101 | (list y))))) | |
102 | ||
103 | ||
104 | (ert-deftest cl-lib-test-set-functions () | |
105 | (let ((c1 (cons nil nil)) | |
106 | (c2 (cons nil nil)) | |
107 | (sym (make-symbol "a"))) | |
108 | (let ((e '()) | |
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))) | |
122 | ||
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))) | |
133 | ||
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))) | |
142 | ||
143 | (should (equal (cl-union b a) (list 'x 'y 'a 'b sym nil "" "x" c1 c2))) | |
144 | ||
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)))))) | |
154 | ||
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 | |
162 | '(lambda () | |
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)) | |
170 | (funcall body)))) | |
171 | ||
172 | (ert-deftest cl-lib-test-coerce-to-vector () | |
173 | (let* ((a (vector)) | |
174 | (b (vector 1 a 3)) | |
175 | (c (list)) | |
176 | (d (list b a))) | |
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))))) | |
181 | ||
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))) | |
189 | ||
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))) | |
197 | ||
c6b0fbe7 DC |
198 | (ert-deftest cl-lib-keyword-names-versus-values () |
199 | (should (equal | |
200 | (funcall (cl-function (lambda (&key a b) (list a b))) | |
201 | :b :a :a 42) | |
202 | '(42 :a)))) | |
203 | ||
89a2e783 DC |
204 | (ert-deftest cl-lib-struct-accessors () |
205 | (cl-defstruct mystruct (abc :readonly t) def) | |
206 | (let ((x (make-mystruct :abc 1 :def 2))) | |
207 | (should (eql (cl-struct-slot-value 'mystruct 'abc x) 1)) | |
208 | (should (eql (cl-struct-slot-value 'mystruct 'def x) 2)) | |
209 | (cl-struct-set-slot-value 'mystruct 'def x -1) | |
210 | (should (eql (cl-struct-slot-value 'mystruct 'def x) -1)) | |
211 | (should (eql (cl-struct-slot-offset 'mystruct 'abc) 1)) | |
212 | (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) | |
213 | (should (equal (cl-struct-slot-info 'mystruct) | |
214 | '((cl-tag-slot) (abc :readonly t) (def)))))) | |
215 | ||
216 | (ert-deftest cl-the () | |
217 | (should (eql (the integer 42) 42)) | |
218 | (should-error (the integer "abc")) | |
219 | (let ((sideffect 0)) | |
220 | (should (= (the integer (incf sideffect)) 1)) | |
221 | (should (= sideffect 1)))) | |
222 | ||
2fa1b97d DC |
223 | (ert-deftest cl-loop-destructuring-with () |
224 | (should (equal (cl-loop with (a b c) = '(1 2 3) return (+ a b c)) 6))) | |
225 | ||
a19b3c2d | 226 | ;;; cl-lib.el ends here |