Add :application-type parameter for save-lisp-and-die on Windows.
[sbcl.git] / tests / list.pure.lisp
1 ;;;; tests related to lists
2
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.
13
14 (in-package :cl-user)
15
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 (dolist (testcase
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
38       ;; Test with BUTLAST.
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))))))
49
50 (multiple-value-bind (result error)
51     (ignore-errors (apply #'butlast (list t)))
52   (assert (null result))
53   (assert (typep error 'type-error)))
54
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))))
58
59 ;;; evaluation order in PUSH, PUSHNEW
60 (let ((a (map 'vector #'list '(a b c))))
61   (let ((i 0))
62     (pushnew (incf i) (aref a (incf i)))
63     (assert (equalp a #((a) (b) (1 c))))))
64
65 (symbol-macrolet ((s (aref a (incf i))))
66     (let ((a (map 'vector #'list '(a b c))))
67       (let ((i 0))
68         (push t s)
69         (assert (equalp a #((a) (t b) (c))))
70         (pushnew 1 s)
71         (assert (equalp a #((a) (t b) (1 c))))
72         (setq i 0)
73         (assert (eql (pop s) 't))
74         (assert (equalp a #((a) (b) (1 c)))))))
75
76 ;;; Type checking in NCONC
77 (let ((tests '((((1 . 2)) (1 . 2))
78                (((1 . 2) (3 . 4)) (1 3 . 4))
79                (((1 . 2) 3) (1 . 3))
80                ((3) 3))))
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)
84                                         `(copy-tree ',arg))
85                                       args))))
86           (assert (equal (funcall (compile nil `(lambda () ,exp))) result)))))
87
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.)
92                     (ignore-errors ,form)
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)
100                                           `(copy-tree ',arg))
101                                         args))))
102             (check-error (funcall (compile nil `(lambda () ,exp))) fail)))))
103
104 (dolist (test '((append 1 2)
105                 (append (1 2) nil (3 . 4) nil)
106                 (append nil (1 2) nil (3 . 4) nil)
107                 (reverse (1 2 . 3))
108                 (nreverse (1 2 . 3))
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)))
112                          type-error)))
113
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)
117                                                            (list 4 1 3 3))
118                                         #'<))
119                '(2 4)))
120
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)))
127
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)))))
132
133 (assert (eq :atom (last (list* 1 2 3 :atom) (eval 0))))
134 (assert (eq :atom (last (list* 1 2 3 :atom) 0)))
135
136 ;;; enforce lists in symbol-plist
137 (let ((s (gensym))
138       (l (list 1 3 4)))
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)))
143     (assert (not res))
144     (assert (typep err 'type-error))))
145
146 ;;; member
147
148 (macrolet ((test  (expected form)
149              `(progn
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)))
155                                                       ,form)))))
156                 (assert (equal ,expected (funcall (lambda ()
157                                                     (declare (optimize space))
158                                                     (let ((numbers '(1 2)))
159                                                       ,form))))))))
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 ))
167
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 '=))
172
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 '<))
176
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 #'-))
180
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))))
184
185 ;;; assoc
186 (macrolet ((test  (expected form)
187              (let ((numbers '((1 a) (2 b)))
188                    (tricky '(nil (a . b) nil (nil . c) (c . d))))
189                `(progn
190                   (assert (equal ',expected (let ((numbers ',numbers)
191                                                   (tricky ',tricky))
192                                               (funcall fun ,@(cdr form)))))
193                   (assert (equal ',expected (funcall (lambda ()
194                                                        (declare (optimize speed))
195                                                        (let ((numbers ',numbers)
196                                                              (tricky ',tricky))
197                                                          ,form)))))
198                   (assert (equal ',expected (funcall (lambda ()
199                                                        (declare (optimize space))
200                                                        (let ((numbers ',numbers)
201                                                              (tricky ',tricky))
202                                                         ,form)))))))))
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))
209
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 '=))
214
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 '<))
218
219     (test (1 a) (assoc -1 numbers :key #'-))
220     (test (2 b) (assoc -2 numbers :key '-))
221     (test nil (assoc -1.0 numbers :key #'-))
222
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))
226
227     ;; Bug reported by Paul Dietz: ASSOC should ignore NIL elements in a
228     ;; alist
229     (test (nil . c) (assoc nil tricky :test #'eq))))
230
231 ;;; rassoc
232 (macrolet ((test  (expected form)
233              (let ((numbers '((a . 1) (b . 2)))
234                    (tricky '(nil (b . a) nil (c . nil) (d . c))))
235                `(progn
236                   (assert (equal ',expected (let ((numbers ',numbers)
237                                                   (tricky ',tricky))
238                                               (funcall fun ,@(cdr form)))))
239                   (assert (equal ',expected (funcall (lambda ()
240                                                        (declare (optimize speed))
241                                                        (let ((numbers ',numbers)
242                                                              (tricky ',tricky))
243                                                          ,form)))))
244                   (assert (equal ',expected (funcall (lambda ()
245                                                        (declare (optimize space))
246                                                        (let ((numbers ',numbers)
247                                                              (tricky ',tricky))
248                                                         ,form)))))))))
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))
255
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 '=))
260
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 '<))
264
265     (test (a . 1) (rassoc -1 numbers :key #'-))
266     (test (b . 2) (rassoc -2 numbers :key '-))
267     (test nil (rassoc -1.0 numbers :key #'-))
268
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))
272
273     (test (c . nil) (rassoc nil tricky :test #'eq))))
274
275 ;;;; member-if & assoc-if & rassoc-if
276 (macrolet ((test (value form)
277              `(let ((* ,value))
278                 (assert (eval ,form))
279                 (assert (funcall (compile nil (lambda () ,form)))))))
280   (test 'evenp
281         (equal '(2 3 4) (member-if * (list 1 2 3 4))))
282   (test 'evenp
283         (equal '(2 3 4) (locally (declare (optimize speed))
284                           (member-if * '(1 2 3 4)))))
285   (test 'evenp
286         (equal '(3 4) (member-if * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
287   (test 'evenp
288         (equal '(2 :two) (assoc-if * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
289   (test 'evenp
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)))))
292   (test 'evenp
293         (equal '(:two . 2) (rassoc-if * (list '(:one . 1) '(:three . 3) '(:two . 2) '(:four . 4)))))
294   (test (list 1 2 3 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 *))))
298
299 ;;;; member-if-not & assoc-if-not
300 (macrolet ((test (value form)
301              `(let ((* ,value))
302                 (assert (eval ,form))
303                 (assert (funcall (compile nil (lambda () ,form)))))))
304   (test 'oddp
305         (equal '(2 3 4) (member-if-not * (list 1 2 3 4))))
306   (test 'oddp
307         (equal '(2 3 4) (locally (declare (optimize speed))
308                           (member-if-not * '(1 2 3 4)))))
309   (test 'oddp
310         (equal '(3 4) (member-if-not * (list 1 2 3 4) :key (lambda (x) (if (= 3 x) 2 1)))))
311   (test 'oddp
312         (equal '(2 :two) (assoc-if-not * (list (list 1 :one) (list 3 :three) (list 2 :two) (list 4 :four)))))
313   (test 'oddp
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)))))
316   (test (list 1 2 3 4)
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 *))))
320
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)))
327                                    3 '(1 2 3 4 5)))))
328
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))
332     (assert (not res))
333     (assert (typep err 'sb-kernel:bounding-indices-bad-error))))
334
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)))))
339 #+sb-eval
340 (assert (equal '((:b))
341                (let ((sb-ext:*evaluator-mode* :interpret))
342                  (eval '(adjoin (list 'b) (list '(:b)) :key #'car :test #'string=)))))
343
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))))
349                          ':x)))
350 (assert (equal '(:x :y) (funcall
351                          (compile nil '(lambda (elt)
352                                         (declare (optimize speed))
353                                         (adjoin elt '(:y))))
354                          ':x)))
355 (assert (equal '(a) (funcall (compile nil '(lambda () (adjoin 'a nil))))))
356
357 (macrolet ((test (expected list-1 list-2 &rest args)
358              `(progn
359                 (assert (equal ,expected (funcall #'union ,list-1 ,list-2 ,@args)))
360                 (assert (equal ,expected (funcall #'nunion
361                                                   (copy-list ,list-1)
362                                                   (copy-list ,list-2)
363                                                   ,@args))))))
364   (test nil nil nil)
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 #'<))
373
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)))
376
377 (with-test (:name :adjoin-folding)
378   (flet ((%f () (adjoin 'x '(a b))))
379     (assert (not (eq (%f) (%f))))))