Fix problem of retaining !LATE-TYPE-COLD-INIT symbol
[sbcl.git] / tests / list.pure.lisp
blob20276626e21308e134113ba65377724e0116f350
1 ;;;; tests related to lists
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
14 (in-package :cl-user)
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
19 ;;; tests for these.
20 (with-test (:name (butlast nbutlast :structure-sharing))
21 (dolist (testcase
22 '((:args ((1 2 3 4 5)) :result (1 2 3 4))
23 (:args ((1 2 3 4 5) 6) :result nil)
24 (:args (nil) :result nil)
25 (:args ((1 2 3) 0) :result (1 2 3))
26 (:args ((1 2 3) 1) :result (1 2))
27 (:args ((1 2 3)) :result (1 2))
28 (:args ((1 2 3) 2) :result (1))
29 (:args ((1 2 3) 3) :result nil)
30 (:args ((1 2 3) 4) :result nil)
31 (:args ((1 2 3 . 4) 0) :result (1 2 3 . 4))
32 (:args ((1 2 3 . 4) 1) :result (1 2))
33 (:args ((1 2 3 . 4)) :result (1 2))
34 (:args ((1 2 3 . 4) 2) :result (1))
35 (:args ((1 2 3 . 4) 3) :result nil)
36 (:args ((1 2 3 . 4) 4) :result nil)))
37 (destructuring-bind (&key args result) testcase
38 (destructuring-bind (list &rest rest) args
39 ;; Test with BUTLAST.
40 (let ((actual-result (apply #'butlast args)))
41 (when (and (consp list) (eq actual-result list))
42 (error "not a copy in BUTLAST for ~S" args))
43 (unless (equal actual-result result)
44 (error "failed BUTLAST for ~S" args)))
45 ;; Test with NBUTLAST.
46 (let* ((copied-list (copy-list list))
47 (actual-result (apply #'nbutlast copied-list rest)))
48 (unless (equal actual-result result)
49 (error "failed NBUTLAST for ~S" args)))))))
51 (with-test (:name (butlast type-error))
52 (assert-error (apply #'butlast (list t)) type-error))
54 ;;; reported by Paul Dietz on cmucl-imp: LDIFF does not check type of
55 ;;; its first argument
56 (with-test (:name (ldiff type-error))
57 (multiple-value-bind (fun failure-p warnings)
58 (checked-compile '(lambda () (ldiff 1 2))
59 :allow-failure t :allow-warnings t)
60 (assert failure-p)
61 (assert (= 1 (length warnings)))
62 (assert (typep (first warnings) 'sb-int:type-warning))
63 (assert-error (funcall fun) type-error)))
65 ;;; evaluation order in PUSH, PUSHNEW
66 (with-test (:name (push :evaluation-order.1))
67 (let ((a (map 'vector #'list '(a b c)))
68 (i 0))
69 (pushnew (incf i) (aref a (incf i)))
70 (assert (equalp a #((a) (b) (1 c))))))
72 (with-test (:name (push pushnew :evaluation-order.2))
73 (symbol-macrolet ((s (aref a (incf i))))
74 (let ((a (map 'vector #'list '(a b c)))
75 (i 0))
76 (push t s)
77 (assert (equalp a #((a) (t b) (c))))
78 (pushnew 1 s)
79 (assert (equalp a #((a) (t b) (1 c))))
80 (setq i 0)
81 (assert (eql (pop s) 't))
82 (assert (equalp a #((a) (b) (1 c)))))))
84 ;;; Type checking in NCONC
85 (with-test (:name (nconc :improper-list))
86 (let ((tests '((((1 . 2)) (1 . 2))
87 (((1 . 2) (3 . 4)) (1 3 . 4))
88 (((1 . 2) 3) (1 . 3))
89 ((3) 3))))
90 (loop for (args result) in tests
91 do (assert (equal (apply 'nconc (copy-tree args)) result))
92 do (let* ((exp `(nconc ,@ (mapcar (lambda (arg)
93 `(copy-tree ',arg))
94 args)))
95 (fun (checked-compile `(lambda () ,exp))))
96 (assert (equal (funcall fun) result))))))
98 (with-test (:name (nconc :improper-list type-error))
99 (let ((tests '(((3 (1 . 2)) 3)
100 (((1 . 2) 3 (4 . 5)) 3))))
101 (macrolet ((check-error (form failed-arg)
102 `(multiple-value-bind (.result. .error.)
103 (ignore-errors ,form)
104 (assert (null .result.))
105 (assert (typep .error. 'type-error))
106 (assert (eq (type-error-expected-type .error.) 'list))
107 (assert (equal (type-error-datum .error.) ,failed-arg)))))
108 (loop for (args fail) in tests
109 do (check-error (apply #'nconc (copy-tree args)) fail)
110 do (let* ((exp `(nconc ,@(mapcar (lambda (arg)
111 `(copy-tree ',arg))
112 args)))
113 (fun (checked-compile `(lambda () ,exp))))
114 (check-error (funcall fun) fail))))))
116 (with-test (:name (append nreverse nreverse nreconc copy-alist type-error))
117 (dolist (test '((append 1 2)
118 (append (1 2) nil (3 . 4) nil)
119 (append nil (1 2) nil (3 . 4) nil)
120 (reverse (1 2 . 3))
121 (nreverse (1 2 . 3))
122 (nreconc (1 2 . 3) (4 5))
123 (copy-alist ((1 . 2) (3 . 4) . 5))))
124 (assert-error (apply (first test) (copy-tree (rest test)))
125 type-error)))
127 ;;; Bug reported by Paul Dietz: NSET-EXCLUSIVE-OR should not return
128 ;;; extra elements, even when given "sets" contain duplications
129 (with-test (:name (nset-exclusive-or :duplicates))
130 (assert (equal (remove-duplicates (sort (nset-exclusive-or (list 1 2 1 3)
131 (list 4 1 3 3))
132 #'<))
133 '(2 4))))
135 ;;; Bug reported by Adam Warner: valid list index designator is not
136 ;;; necessarily a fixnum
137 (with-test (:name (nth bignum))
138 (let ((s (read-from-string "(a . #1=(b c . #1#))")))
139 (assert (eq (nth (* 1440 most-positive-fixnum) s) 'c))
140 (setf (nth (* 1440 most-positive-fixnum) s) 14)
141 (assert (eq (nth (* 1440 most-positive-fixnum) s) 14)))
143 (let ((s (copy-list '(1 2 3))))
144 (assert (eq s (last s (* 1440 most-positive-fixnum))))
145 (assert (null (butlast s (* 1440 most-positive-fixnum))))
146 (assert (null (nbutlast s (* 1440 most-positive-fixnum))))))
148 (assert (eq :atom (last (list* 1 2 3 :atom) (eval 0))))
149 (assert (eq :atom (last (list* 1 2 3 :atom) 0)))
151 ;;; enforce lists in symbol-plist
152 (with-test (:name symbol-plist)
153 (let ((s (gensym))
154 (l (list 1 3 4)))
155 (assert (not (symbol-plist s)))
156 (assert (eq l (setf (symbol-plist s) l)))
157 (assert-error (setf (symbol-plist s) (car l)) type-error)))
159 ;;; member
161 (with-test (:name member)
162 (macrolet ((test (expected form)
163 `(progn
164 (assert (equal ,expected (let ((numbers '(1 2)))
165 (funcall fun ,@(cdr form)))))
166 (assert (equal ,expected (funcall (lambda ()
167 (declare (optimize speed))
168 (let ((numbers '(1 2)))
169 ,form)))))
170 (assert (equal ,expected (funcall (lambda ()
171 (declare (optimize space))
172 (let ((numbers '(1 2)))
173 ,form))))))))
174 (let ((x-numbers '(1 2))
175 (fun (car (list 'member))))
176 (test x-numbers (member 1 numbers))
177 (test x-numbers (member 1 numbers :key 'identity))
178 (test x-numbers (member 1 numbers :key #'identity))
179 (test (cdr x-numbers) (member 2 numbers))
180 (test nil (member 1.0 numbers ))
182 (test x-numbers (member 1.0 numbers :test #'=))
183 (test x-numbers (member 1.0 numbers :test #'= :key nil))
184 (test (cdr x-numbers) (member 2.0 numbers :test '=))
185 (test nil (member 0 numbers :test '=))
187 (test x-numbers (member 0 numbers :test-not #'>))
188 (test (cdr x-numbers) (member 1 numbers :test-not 'eql))
189 (test nil (member 0 numbers :test-not '<))
191 (test x-numbers (member -1 numbers :key #'-))
192 (test (cdr x-numbers) (member -2 numbers :key '-))
193 (test nil (member -1.0 numbers :key #'-))
195 (test x-numbers (member -1.0 numbers :key #'- :test '=))
196 (test (cdr x-numbers) (member -2.0 numbers :key #'- :test '=))
197 (test nil (member -1.0 numbers :key #'- :test 'eql)))))
199 ;;; assoc
200 (with-test (:name assoc)
201 (macrolet ((test (expected form)
202 (let ((numbers '((1 a) (2 b)))
203 (tricky '(nil (a . b) nil (nil . c) (c . d))))
204 `(progn
205 (assert (equal ',expected (let ((numbers ',numbers)
206 (tricky ',tricky))
207 (funcall fun ,@(cdr form)))))
208 (assert (equal ',expected (funcall (lambda ()
209 (declare (optimize speed))
210 (let ((numbers ',numbers)
211 (tricky ',tricky))
212 ,form)))))
213 (assert (equal ',expected (funcall (lambda ()
214 (declare (optimize space))
215 (let ((numbers ',numbers)
216 (tricky ',tricky))
217 ,form)))))))))
218 (let ((fun (car (list 'assoc))))
219 (test (1 a) (assoc 1 numbers))
220 (test (2 b) (assoc 2 numbers))
221 (test (1 a) (assoc 1 numbers :key 'identity))
222 (test (2 b) (assoc 2 numbers :key #'identity))
223 (test nil (assoc 1.0 numbers))
225 (test (1 a) (assoc 1.0 numbers :test #'=))
226 (test (1 a) (assoc 1.0 numbers :test #'= :key nil))
227 (test (2 b) (assoc 2.0 numbers :test '=))
228 (test nil (assoc 0 numbers :test '=))
230 (test (1 a) (assoc 0 numbers :test-not #'>))
231 (test (2 b) (assoc 1 numbers :test-not 'eql))
232 (test nil (assoc 0 numbers :test-not '<))
234 (test (1 a) (assoc -1 numbers :key #'-))
235 (test (2 b) (assoc -2 numbers :key '-))
236 (test nil (assoc -1.0 numbers :key #'-))
238 (test (1 a) (assoc -1.0 numbers :key #'- :test '=))
239 (test (2 b) (assoc -2.0 numbers :key #'- :test '=))
240 (test nil (assoc -1.0 numbers :key #'- :test 'eql))
242 ;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements
243 ;; in a alist
244 (test (nil . c) (assoc nil tricky :test #'eq)))))
246 ;;; rassoc
247 (with-test (:name rassoc)
248 (macrolet ((test (expected form)
249 (let ((numbers '((a . 1) (b . 2)))
250 (tricky '(nil (b . a) nil (c . nil) (d . c))))
251 `(progn
252 (assert (equal ',expected (let ((numbers ',numbers)
253 (tricky ',tricky))
254 (funcall fun ,@(cdr form)))))
255 (assert (equal ',expected (funcall (lambda ()
256 (declare (optimize speed))
257 (let ((numbers ',numbers)
258 (tricky ',tricky))
259 ,form)))))
260 (assert (equal ',expected (funcall (lambda ()
261 (declare (optimize space))
262 (let ((numbers ',numbers)
263 (tricky ',tricky))
264 ,form)))))))))
265 (let ((fun (car (list 'rassoc))))
266 (test (a . 1) (rassoc 1 numbers))
267 (test (b . 2) (rassoc 2 numbers))
268 (test (a . 1) (rassoc 1 numbers :key 'identity))
269 (test (b . 2) (rassoc 2 numbers :key #'identity))
270 (test nil (rassoc 1.0 numbers))
272 (test (a . 1) (rassoc 1.0 numbers :test #'=))
273 (test (a . 1) (rassoc 1.0 numbers :test #'= :key nil))
274 (test (b . 2) (rassoc 2.0 numbers :test '=))
275 (test nil (rassoc 0 numbers :test '=))
277 (test (a . 1) (rassoc 0 numbers :test-not #'>))
278 (test (b . 2) (rassoc 1 numbers :test-not 'eql))
279 (test nil (rassoc 0 numbers :test-not '<))
281 (test (a . 1) (rassoc -1 numbers :key #'-))
282 (test (b . 2) (rassoc -2 numbers :key '-))
283 (test nil (rassoc -1.0 numbers :key #'-))
285 (test (a . 1) (rassoc -1.0 numbers :key #'- :test '=))
286 (test (b . 2) (rassoc -2.0 numbers :key #'- :test '=))
287 (test nil (rassoc -1.0 numbers :key #'- :test 'eql))
289 (test (c . nil) (rassoc nil tricky :test #'eq)))))
291 ;;;; member-if & assoc-if & rassoc-if
292 (with-test (:name (member-if assoc-if rassoc-if))
293 (macrolet ((test (value form)
294 `(let ((* ,value))
295 (assert (eval ,form))
296 (assert (funcall (checked-compile '(lambda () ,form)))))))
297 (test 'evenp
298 (equal '(2 3 4) (member-if * (list 1 2 3 4))))
299 (test 'evenp
300 (equal '(2 3 4) (locally (declare (optimize speed))
301 (member-if * '(1 2 3 4)))))
302 (test 'evenp
303 (equal '(3 4) (member-if * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
304 (test 'evenp
305 (equal '(2 :two) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
306 (test 'evenp
307 (equal '(3 :three) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))
308 :key (lambda (x) (if (= 3 x) 2 1)))))
309 (test 'evenp
310 (equal '(:two . 2) (rassoc-if * (list '(:one . 1) '(:three . 3) '(:two . 2) '(:four . 4)))))
311 (test (list 1 2 3 4)
312 (equal '(2 3 4) (member-if 'evenp *)))
313 (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c))
314 (equal (cons 2 'b) (assoc-if 'evenp *)))))
316 ;;;; member-if-not & assoc-if-not
317 (with-test (:name (member-if-not assoc-if-not))
318 (macrolet ((test (value form)
319 `(let ((* ,value))
320 (assert (eval ,form))
321 (assert (funcall (checked-compile '(lambda () ,form)))))))
322 (test 'oddp
323 (equal '(2 3 4) (member-if-not * (list 1 2 3 4))))
324 (test 'oddp
325 (equal '(2 3 4) (locally (declare (optimize speed))
326 (member-if-not * '(1 2 3 4)))))
327 (test 'oddp
328 (equal '(3 4) (member-if-not * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
329 (test 'oddp
330 (equal '(2 :two) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
331 (test 'oddp
332 (equal '(3 :three) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four))
333 :key (lambda (x) (if (= 3 x) 2 1)))))
334 (test (list 1 2 3 4)
335 (equal '(2 3 4) (member-if-not 'oddp *)))
336 (test (list (cons 1 'a) (cons 2 'b) (cons 3 'c))
337 (equal (cons 2 'b) (assoc-if-not 'oddp *)))))
339 ;;; bug reported by Dan Corkill: *PRINT-CASE* affected the compiler transforms
340 ;;; for ASSOC & MEMBER
341 (with-test (:name (assoc member *print-case*))
342 (let ((*print-case* :downcase))
343 (assert (eql 2
344 (cdr (funcall (checked-compile `(lambda (i l) (assoc i l)))
345 :b '((:a . 1) (:b . 2))))))
346 (assert (equal '(3 4 5)
347 (funcall (checked-compile `(lambda (i l) (member i l)))
348 3 '(1 2 3 4 5))))))
350 ;;; bad bounding index pair to SUBSEQ on a list
351 (with-test (:name (subseq sb-kernel:bounding-indices-bad-error))
352 (let ((list (list 0 1 2 3 4 5)))
353 (assert-error (subseq list 4 2) sb-kernel:bounding-indices-bad-error)))
355 ;;; ADJOIN must apply key to item as well
356 (with-test (:name (adjoin :key))
357 (let ((fun (checked-compile `(lambda (x y)
358 (adjoin x y :key #'car :test #'string=)))))
359 (assert (equal '((:b)) (funcall fun (list 'b) (list '(:b))))))
361 #+(or sb-eval sb-fasteval)
362 (assert (equal '((:b))
363 (let ((sb-ext:*evaluator-mode* :interpret))
364 (eval '(adjoin (list 'b) (list '(:b))
365 :key #'car :test #'string=))))))
367 ;;; constant list argument to ADJOIN
368 (with-test (:name (adjoin :constant :list-argument))
369 (flet ((test (form args expected)
370 (let ((fun (checked-compile form)))
371 (assert (equal expected (apply fun args))))))
372 (test `(lambda (elt)
373 (declare (optimize speed))
374 (adjoin elt '(:x :y)))
375 '(:x) '(:x :y))
376 (test `(lambda (elt)
377 (declare (optimize speed))
378 (adjoin elt '(:y)))
379 '(:x) '(:x :y))
380 (test `(lambda () (adjoin 'a nil)) '() '(a))))
382 (with-test (:name union)
383 (macrolet ((test (expected list-1 list-2 &rest args)
384 `(progn
385 (assert (equal ,expected (funcall #'union ,list-1 ,list-2 ,@args)))
386 (assert (equal ,expected (funcall #'nunion
387 (copy-list ,list-1)
388 (copy-list ,list-2)
389 ,@args))))))
390 (test nil nil nil)
391 (test '(42) nil '(42))
392 (test '(42) '(42) nil)
393 (test '(42) '(42) '(42))
394 (test '((42) (42)) '((42)) '((42)))
395 (test '((42) (42)) '((42)) '((42)) :test-not #'equal)
396 (test '((42)) '((42)) '((42)) :test #'equal)
397 (test '((42)) '((42)) '((42)) :key #'car)
398 (test '((42)) '((42)) '((42)) :key #'car :test-not #'<)))
400 ;;; FIND on lists should not call key outside the specified
401 ;;; subsequence.
402 (with-test (:name (find :start :end))
403 (assert (not (find :a '(0 (:c) 1) :start 1 :end 2 :key #'car))))
405 (with-test (:name (adjoin :folding))
406 (flet ((%f () (adjoin 'x '(a b))))
407 (assert (not (eq (%f) (%f))))))