1 ;;;; tests related to lists
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
16 ;;; Since *another* BUTLAST problem was reported (anonymously!) on the
17 ;;; SourceForge summary page magical bugs web interface 2001-09-01, it
18 ;;; looks as though it's past time to start accumulating regression
21 '((:args ((1 2 3 4 5)) :result (1 2 3 4))
22 (:args ((1 2 3 4 5) 6) :result nil)
23 (:args (nil) :result nil)
24 (:args ((1 2 3) 0) :result (1 2 3))
25 (:args ((1 2 3) 1) :result (1 2))
26 (:args ((1 2 3)) :result (1 2))
27 (:args ((1 2 3) 2) :result (1))
28 (:args ((1 2 3) 3) :result nil)
29 (:args ((1 2 3) 4) :result nil)
30 (:args ((1 2 3 . 4) 0) :result (1 2 3 . 4))
31 (:args ((1 2 3 . 4) 1) :result (1 2))
32 (:args ((1 2 3 . 4)) :result (1 2))
33 (:args ((1 2 3 . 4) 2) :result (1))
34 (:args ((1 2 3 . 4) 3) :result nil)
35 (:args ((1 2 3 . 4) 4) :result nil)))
36 (destructuring-bind (&key args result) testcase
37 (destructuring-bind (list &rest rest) args
39 (let ((actual-result (apply #'butlast args)))
40 (when (and (consp list) (eq actual-result list))
41 (error "not a copy in BUTLAST for ~S" args))
42 (unless (equal actual-result result)
43 (error "failed BUTLAST for ~S" args)))
44 ;; Test with NBUTLAST.
45 (let* ((copied-list (copy-list list))
46 (actual-result (apply #'nbutlast copied-list rest)))
47 (unless (equal actual-result result)
48 (error "failed NBUTLAST for ~S" args))))))
50 (multiple-value-bind (result error)
51 (ignore-errors (apply #'butlast (list t)))
52 (assert (null result))
53 (assert (typep error 'type-error)))
55 ;;; reported by Paul Dietz on cmucl-imp: LDIFF does not check type of
56 ;;; its first argument
57 (assert (not (ignore-errors (ldiff 1 2))))
59 ;;; evaluation order in PUSH, PUSHNEW
60 (let ((a (map 'vector #'list '(a b c))))
62 (pushnew (incf i) (aref a (incf i)))
63 (assert (equalp a #((a) (b) (1 c))))))
65 (symbol-macrolet ((s (aref a (incf i))))
66 (let ((a (map 'vector #'list '(a b c))))
69 (assert (equalp a #((a) (t b) (c))))
71 (assert (equalp a #((a) (t b) (1 c))))
73 (assert (eql (pop s) 't))
74 (assert (equalp a #((a) (b) (1 c)))))))
76 ;;; Type checking in NCONC
77 (let ((tests '((((1 . 2)) (1 . 2))
78 (((1 . 2) (3 . 4)) (1 3 . 4))
81 (loop for (args result) in tests
82 do (assert (equal (apply 'nconc (copy-tree args)) result))
83 do (let ((exp `(nconc ,@ (mapcar (lambda (arg)
86 (assert (equal (funcall (compile nil `(lambda () ,exp))) result)))))
88 (let ((tests '(((3 (1 . 2)) 3)
89 (((1 . 2) 3 (4 . 5)) 3))))
90 (macrolet ((check-error (form failed-arg)
91 `(multiple-value-bind (.result. .error.)
93 (assert (null .result.))
94 (assert (typep .error. 'type-error))
95 (assert (eq (type-error-expected-type .error.) 'list))
96 (assert (equal (type-error-datum .error.) ,failed-arg)))))
97 (loop for (args fail) in tests
98 do (check-error (apply #'nconc (copy-tree args)) fail)
99 do (let ((exp `(nconc ,@ (mapcar (lambda (arg)
102 (check-error (funcall (compile nil `(lambda () ,exp))) fail)))))
104 (dolist (test '((append 1 2)
105 (append (1 2) nil (3 . 4) nil)
106 (append nil (1 2) nil (3 . 4) nil)
109 (nreconc (1 2 . 3) (4 5))
110 (copy-alist ((1 . 2) (3 . 4) . 5))))
111 (assert (raises-error? (apply (first test) (copy-tree (rest test)))
114 ;;; Bug reported by Paul Dietz: NSET-EXCLUSIVE-OR should not return
115 ;;; extra elements, even when given "sets" contain duplications
116 (assert (equal (remove-duplicates (sort (nset-exclusive-or (list 1 2 1 3)
121 ;;; Bug reported by Adam Warner: valid list index designator is not
122 ;;; necessary a fixnum
123 (let ((s (read-from-string "(a . #1=(b c . #1#))")))
124 (assert (eq (nth (* 1440 most-positive-fixnum) s) 'c))
125 (setf (nth (* 1440 most-positive-fixnum) s) 14)
126 (assert (eq (nth (* 1440 most-positive-fixnum) s) 14)))
128 (let ((s (copy-list '(1 2 3))))
129 (assert (eq s (last s (* 1440 most-positive-fixnum))))
130 (assert (null (butlast s (* 1440 most-positive-fixnum))))
131 (assert (null (nbutlast s (* 1440 most-positive-fixnum)))))
133 (assert (eq :atom (last (list* 1 2 3 :atom) (eval 0))))
134 (assert (eq :atom (last (list* 1 2 3 :atom) 0)))
136 ;;; enforce lists in symbol-plist
139 (assert (not (symbol-plist s)))
140 (assert (eq l (setf (symbol-plist s) l)))
141 (multiple-value-bind (res err)
142 (ignore-errors (setf (symbol-plist s) (car l)))
144 (assert (typep err 'type-error))))
148 (macrolet ((test (expected form)
150 (assert (equal ,expected (let ((numbers '(1 2)))
151 (funcall fun ,@(cdr form)))))
152 (assert (equal ,expected (funcall (lambda ()
153 (declare (optimize speed))
154 (let ((numbers '(1 2)))
156 (assert (equal ,expected (funcall (lambda ()
157 (declare (optimize space))
158 (let ((numbers '(1 2)))
160 (let ((x-numbers '(1 2))
161 (fun (car (list 'member))))
162 (test x-numbers (member 1 numbers))
163 (test x-numbers (member 1 numbers :key 'identity))
164 (test x-numbers (member 1 numbers :key #'identity))
165 (test (cdr x-numbers) (member 2 numbers))
166 (test nil (member 1.0 numbers ))
168 (test x-numbers (member 1.0 numbers :test #'=))
169 (test x-numbers (member 1.0 numbers :test #'= :key nil))
170 (test (cdr x-numbers) (member 2.0 numbers :test '=))
171 (test nil (member 0 numbers :test '=))
173 (test x-numbers (member 0 numbers :test-not #'>))
174 (test (cdr x-numbers) (member 1 numbers :test-not 'eql))
175 (test nil (member 0 numbers :test-not '<))
177 (test x-numbers (member -1 numbers :key #'-))
178 (test (cdr x-numbers) (member -2 numbers :key '-))
179 (test nil (member -1.0 numbers :key #'-))
181 (test x-numbers (member -1.0 numbers :key #'- :test '=))
182 (test (cdr x-numbers) (member -2.0 numbers :key #'- :test '=))
183 (test nil (member -1.0 numbers :key #'- :test 'eql))))
186 (macrolet ((test (expected form)
187 (let ((numbers '((1 a) (2 b)))
188 (tricky '(nil (a . b) nil (nil . c) (c . d))))
190 (assert (equal ',expected (let ((numbers ',numbers)
192 (funcall fun ,@(cdr form)))))
193 (assert (equal ',expected (funcall (lambda ()
194 (declare (optimize speed))
195 (let ((numbers ',numbers)
198 (assert (equal ',expected (funcall (lambda ()
199 (declare (optimize space))
200 (let ((numbers ',numbers)
203 (let ((fun (car (list 'assoc))))
204 (test (1 a) (assoc 1 numbers))
205 (test (2 b) (assoc 2 numbers))
206 (test (1 a) (assoc 1 numbers :key 'identity))
207 (test (2 b) (assoc 2 numbers :key #'identity))
208 (test nil (assoc 1.0 numbers))
210 (test (1 a) (assoc 1.0 numbers :test #'=))
211 (test (1 a) (assoc 1.0 numbers :test #'= :key nil))
212 (test (2 b) (assoc 2.0 numbers :test '=))
213 (test nil (assoc 0 numbers :test '=))
215 (test (1 a) (assoc 0 numbers :test-not #'>))
216 (test (2 b) (assoc 1 numbers :test-not 'eql))
217 (test nil (assoc 0 numbers :test-not '<))
219 (test (1 a) (assoc -1 numbers :key #'-))
220 (test (2 b) (assoc -2 numbers :key '-))
221 (test nil (assoc -1.0 numbers :key #'-))
223 (test (1 a) (assoc -1.0 numbers :key #'- :test '=))
224 (test (2 b) (assoc -2.0 numbers :key #'- :test '=))
225 (test nil (assoc -1.0 numbers :key #'- :test 'eql))
227 ;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a
229 (test (nil . c) (assoc nil tricky :test #'eq))))
232 (macrolet ((test (expected form)
233 (let ((numbers '((a . 1) (b . 2)))
234 (tricky '(nil (b . a) nil (c . nil) (d . c))))
236 (assert (equal ',expected (let ((numbers ',numbers)
238 (funcall fun ,@(cdr form)))))
239 (assert (equal ',expected (funcall (lambda ()
240 (declare (optimize speed))
241 (let ((numbers ',numbers)
244 (assert (equal ',expected (funcall (lambda ()
245 (declare (optimize space))
246 (let ((numbers ',numbers)
249 (let ((fun (car (list 'rassoc))))
250 (test (a . 1) (rassoc 1 numbers))
251 (test (b . 2) (rassoc 2 numbers))
252 (test (a . 1) (rassoc 1 numbers :key 'identity))
253 (test (b . 2) (rassoc 2 numbers :key #'identity))
254 (test nil (rassoc 1.0 numbers))
256 (test (a . 1) (rassoc 1.0 numbers :test #'=))
257 (test (a . 1) (rassoc 1.0 numbers :test #'= :key nil))
258 (test (b . 2) (rassoc 2.0 numbers :test '=))
259 (test nil (rassoc 0 numbers :test '=))
261 (test (a . 1) (rassoc 0 numbers :test-not #'>))
262 (test (b . 2) (rassoc 1 numbers :test-not 'eql))
263 (test nil (rassoc 0 numbers :test-not '<))
265 (test (a . 1) (rassoc -1 numbers :key #'-))
266 (test (b . 2) (rassoc -2 numbers :key '-))
267 (test nil (rassoc -1.0 numbers :key #'-))
269 (test (a . 1) (rassoc -1.0 numbers :key #'- :test '=))
270 (test (b . 2) (rassoc -2.0 numbers :key #'- :test '=))
271 (test nil (rassoc -1.0 numbers :key #'- :test 'eql))
273 (test (c . nil) (rassoc nil tricky :test #'eq))))
275 ;;;; member-if & assoc-if & rassoc-if
276 (macrolet ((test (value form)
278 (assert (eval ,form))
279 (assert (funcall (compile nil (lambda () ,form)))))))
281 (equal '(2 3 4) (member-if * (list 1 2 3 4))))
283 (equal '(2 3 4) (locally (declare (optimize speed))
284 (member-if * '(1 2 3 4)))))
286 (equal '(3 4) (member-if * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
288 (equal '(2 :two) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
290 (equal '(3 :three) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))
291 :key (lambda (x) (if (= 3 x) 2 1)))))
293 (equal '(:two . 2) (rassoc-if * (list '(:one . 1) '(:three . 3) '(:two . 2) '(:four . 4)))))
295 (equal '(2 3 4) (member-if 'evenp *)))
296 (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c))
297 (equal (cons 2 'b) (assoc-if 'evenp *))))
299 ;;;; member-if-not & assoc-if-not
300 (macrolet ((test (value form)
302 (assert (eval ,form))
303 (assert (funcall (compile nil (lambda () ,form)))))))
305 (equal '(2 3 4) (member-if-not * (list 1 2 3 4))))
307 (equal '(2 3 4) (locally (declare (optimize speed))
308 (member-if-not * '(1 2 3 4)))))
310 (equal '(3 4) (member-if-not * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
312 (equal '(2 :two) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
314 (equal '(3 :three) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))
315 :key (lambda (x) (if (= 3 x) 2 1)))))
317 (equal '(2 3 4) (member-if-not 'oddp *)))
318 (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c))
319 (equal (cons 2 'b) (assoc-if-not 'oddp *))))
321 ;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms
322 ;;; for ASSOC & MEMBER
323 (let ((*print-case* :downcase))
324 (assert (eql 2 (cdr (funcall (compile nil '(lambda (i l) (assoc i l)))
325 :b '((:a . 1) (:b . 2))))))
326 (assert (equal '(3 4 5) (funcall (compile nil '(lambda (i l) (member i l)))
329 ;;; bad bounding index pair to SUBSEQ on a list
330 (let ((list (list 0 1 2 3 4 5)))
331 (multiple-value-bind (res err) (ignore-errors (subseq list 4 2))
333 (assert (typep err 'sb-kernel:bounding-indices-bad-error))))
335 ;;; ADJOIN must apply key to item as well
336 (assert (equal '((:b)) (funcall
337 (compile nil '(lambda (x y) (adjoin x y :key #'car :test #'string=)))
338 (list 'b) (list '(:b)))))
340 (assert (equal '((:b))
341 (let ((sb-ext:*evaluator-mode* :interpret))
342 (eval '(adjoin (list 'b) (list '(:b)) :key #'car :test #'string=)))))
344 ;;; constant list argument to ADJOIN
345 (assert (equal '(:x :y) (funcall
346 (compile nil '(lambda (elt)
347 (declare (optimize speed))
348 (adjoin elt '(:x :y))))
350 (assert (equal '(:x :y) (funcall
351 (compile nil '(lambda (elt)
352 (declare (optimize speed))
355 (assert (equal '(a) (funcall (compile nil '(lambda () (adjoin 'a nil))))))
357 (macrolet ((test (expected list-1 list-2 &rest args)
359 (assert (equal ,expected (funcall #'union ,list-1 ,list-2 ,@args)))
360 (assert (equal ,expected (funcall #'nunion
365 (test '(42) nil '(42))
366 (test '(42) '(42) nil)
367 (test '(42) '(42) '(42))
368 (test '((42) (42)) '((42)) '((42)))
369 (test '((42) (42)) '((42)) '((42)) :test-not #'equal)
370 (test '((42)) '((42)) '((42)) :test #'equal)
371 (test '((42)) '((42)) '((42)) :key #'car)
372 (test '((42)) '((42)) '((42)) :key #'car :test-not #'<))
374 ;;; FIND on lists should not call key outside the specified subsquence.
375 (assert (not (find :a '(0 (:c) 1) :start 1 :end 2 :key #'car)))
377 (with-test (:name :adjoin-folding)
378 (flet ((%f () (adjoin 'x '(a b))))
379 (assert (not (eq (%f) (%f))))))