source: trunk/source/tests/ansi-tests/union.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 10.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Apr 20 07:41:24 2003
4;;;; Contains: Tests of UNION
5
6(in-package :cl-test)
7
8(compile-and-load "cons-aux.lsp")
9
10(deftest union.1
11  (union nil nil)
12  nil)
13
14(deftest union.2
15  (union-with-check (list 'a) nil)
16  (a))
17
18(deftest union.3
19  (union-with-check (list 'a) (list 'a))
20  (a))
21
22(deftest union-4
23  (union-with-check (list 1) (list 1))
24  (1))
25
26(deftest union.5
27  (let ((x (list 'a 'b)))
28    (union-with-check (list x) (list x)))
29  ((a b)))
30
31(deftest union.6
32  (let ((x (copy-list '(a b c d e f)))
33        (y (copy-list '(z c y a v b))))
34    (let ((result (union-with-check x y)))
35      (check-union x y result)))
36  t)
37
38(deftest union.6-a
39  (let ((x (copy-list '(a b c d e f)))
40        (y (copy-list '(z c y a v b))))
41    (let ((result (union-with-check x y :test #'eq)))
42      (check-union x y result)))
43  t)
44
45(deftest union.7
46  (let ((x (copy-list '(a b c d e f)))
47        (y (copy-list '(z c y a v b))))
48    (let ((result (union-with-check x y :test #'eql)))
49      (check-union x y result)))
50  t)
51
52(deftest union.8
53  (let ((x (copy-list '(a b c d e f)))
54        (y (copy-list '(z c y a v b))))
55    (let ((result (union-with-check x y :test #'equal)))
56      (check-union x y result)))
57  t)
58
59(deftest union.9
60  (let ((x (copy-list '(a b c d e f)))
61        (y (copy-list '(z c y a v b))))
62    (let ((result (union-with-check x y :test-not (complement #'eql))))
63      (check-union x y result)))
64  t)
65
66(deftest union.10
67  (let ((x (copy-list '(a b c d e f)))
68        (y (copy-list '(z c y a v b))))
69    (let ((result (union-with-check x y :test-not (complement #'equal))))
70      (check-union x y result)))
71  t)
72
73(deftest union.11
74  (let ((x (copy-list '(a b c d e f)))
75        (y (copy-list '(z c y a v b))))
76    (let ((result (union-with-check x y :test-not (complement #'eq))))
77      (check-union x y result)))
78  t)
79
80(deftest union.12
81  (let ((x (copy-list '(1 2 3 4 5 6 7)))
82        (y (copy-list '(10 19 5 3 17 1001 2))))
83    (let ((result (union-with-check x y)))
84      (check-union x y result)))
85  t)
86
87(deftest union.13
88  (let ((x (copy-list '(1 2 3 4 5 6 7)))
89        (y (copy-list '(10 19 5 3 17 1001 2))))
90    (let ((result (union-with-check x y :test #'equal)))
91      (check-union x y result)))
92  t)
93
94(deftest union.14
95  (let ((x (copy-list '(1 2 3 4 5 6 7)))
96        (y (copy-list '(10 19 5 3 17 1001 2))))
97    (let ((result (union-with-check x y :test #'eql)))
98      (check-union x y result)))
99  t)
100
101(deftest union.15
102  (let ((x (copy-list '(1 2 3 4 5 6 7)))
103        (y (copy-list '(10 19 5 3 17 1001 2))))
104    (let ((result (union-with-check x y :test-not (complement #'equal))))
105      (check-union x y result)))
106  t)
107
108(deftest union.16
109  (let ((x (copy-list '(1 2 3 4 5 6 7)))
110        (y (copy-list '(10 19 5 3 17 1001 2))))
111    (let ((result (union-with-check x y :test-not (complement  #'eql))))
112      (check-union x y result)))
113  t)
114
115(deftest union.17
116  (let ((x (copy-list '(1 2 3 4 5 6 7)))
117        (y (copy-list '(10 19 5 3 17 1001 2))))
118    (let ((result (union-with-check-and-key x y #'1+)))
119      (check-union x y result)))
120  t)
121
122(deftest union.18
123  (let ((x (copy-list '(1 2 3 4 5 6 7)))
124        (y (copy-list '(10 19 5 3 17 1001 2))))
125    (let ((result (union-with-check-and-key x y #'1+ :test #'equal)))
126      (check-union x y result)))
127  t)
128
129(deftest union.19
130  (let ((x (copy-list '(1 2 3 4 5 6 7)))
131        (y (copy-list '(10 19 5 3 17 1001 2))))
132    (let ((result (union-with-check-and-key x y #'1+ :test #'eql)))
133      (check-union x y result)))
134  t)
135
136(deftest union.20
137  (let ((x (copy-list '(1 2 3 4 5 6 7)))
138        (y (copy-list '(10 19 5 3 17 1001 2))))
139    (let ((result (union-with-check-and-key x y #'1+
140                                            :test-not (complement #'equal))))
141      (check-union x y result)))
142  t)
143
144(deftest union.21
145  (let ((x (copy-list '(1 2 3 4 5 6 7)))
146        (y (copy-list '(10 19 5 3 17 1001 2))))
147    (let ((result (union-with-check-and-key x y #'1+
148                                            :test-not (complement #'equal))))
149      (check-union x y result)))
150  t)
151
152(deftest union.22
153  (let ((x (copy-list '(1 2 3 4 5 6 7)))
154        (y (copy-list '(10 19 5 3 17 1001 2))))
155    (let ((result (union-with-check-and-key x y nil)))
156      (check-union x y result)))
157  t)
158
159(deftest union.23
160  (let ((x (copy-list '(1 2 3 4 5 6 7)))
161        (y (copy-list '(10 19 5 3 17 1001 2))))
162    (let ((result (union-with-check-and-key x y '1+)))
163      (check-union x y result)))
164  t)
165
166;; Do large numbers of random units
167
168(deftest union.24
169  (do-random-unions 100 100 200)
170  nil)
171
172(deftest union.25
173  (let ((x (shuffle '(1 4 6 10 45 101)))
174        (y (copy-list '(102 5 2 11 44 6))))
175    (let ((result (union-with-check x y
176                                    :test #'(lambda (a b)
177                                                    (<= (abs (- a b)) 1)))))
178      (and
179       (not (eqt result 'failed))
180       (sort
181        (sublis
182         '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101))
183         (copy-list result))
184        #'<))))
185  (1 4 6 10 44 101))
186
187;;; Check that union uses eql, not equal or eq
188
189(deftest union.26
190  (let ((x 1000)
191        (y 1000))
192    (loop
193     while (not (typep x 'bignum))
194     do (progn
195          (setf x (* x x))
196          (setf y (* y y))))
197    (notnot-mv
198     (or
199      (eqt x y)  ;; if bignums are eq, the test is worthless
200      (eql (length
201            (union-with-check
202             (list x) (list x)))
203           1))))
204  t)
205
206(deftest union.27
207  (union-with-check (list (copy-seq "aa"))
208                    (list (copy-seq "aa")))
209  ("aa" "aa"))
210
211;; Check that union does not reverse the arguments to :test, :test-not
212
213(deftest union.28
214  (block fail
215    (sort
216     (union-with-check
217      (list 1 2 3)
218      (list 4 5 6)
219      :test #'(lambda (x y)
220                (when (< y x) (return-from fail 'fail))
221                (eql x y)))
222     #'<))
223  (1 2 3 4 5 6))
224
225(deftest union.29
226  (block fail
227    (sort
228     (union-with-check-and-key
229      (list 1 2 3)
230      (list 4 5 6)
231      #'identity
232      :test #'(lambda (x y)
233                (when (< y x) (return-from fail 'fail))
234                (eql x y)))
235     #'<))
236  (1 2 3 4 5 6))
237
238(deftest union.30
239  (block fail
240    (sort
241     (union-with-check
242      (list 1 2 3)
243      (list 4 5 6)
244      :test-not
245      #'(lambda (x y)
246          (when (< y x) (return-from fail 'fail))
247          (not (eql x y))))
248     #'<))
249  (1 2 3 4 5 6))
250
251(deftest union.31
252  (block fail
253    (sort
254     (union-with-check-and-key
255      (list 1 2 3)
256      (list 4 5 6)
257      #'identity
258      :test-not #'(lambda (x y)
259                    (when (< y x) (return-from fail 'fail))
260                    (not (eql x y))))
261     #'<))
262  (1 2 3 4 5 6))
263
264(defharmless union.test-and-test-not.1
265  (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test #'eql :test-not #'eql))
266
267(defharmless union.test-and-test-not.2
268  (union (list 1 4 8 10) (list 1 2 3 9 10 13) :test-not #'eql :test #'eql))
269
270
271;;; Order of evaluation tests
272
273(deftest union.order.1
274  (let ((i 0) x y)
275    (values
276     (sort
277      (union (progn (setf x (incf i)) (copy-list '(1 3 5)))
278             (progn (setf y (incf i)) (copy-list '(2 5 8))))
279      #'<)
280     i x y))
281  (1 2 3 5 8)
282  2 1 2)
283
284(deftest union.order.2
285  (let ((i 0) x y z w)
286    (values
287     (sort
288      (union (progn (setf x (incf i)) (copy-list '(1 3 5)))
289             (progn (setf y (incf i)) (copy-list '(2 5 8)))
290             :test (progn (setf z (incf i)) #'eql)
291             :key (progn (setf w (incf i)) #'identity))
292      #'<)
293     i x y z w))
294  (1 2 3 5 8)
295  4 1 2 3 4)
296
297
298(deftest union.order.3
299  (let ((i 0) x y z w)
300    (values
301     (sort
302      (union (progn (setf x (incf i)) (copy-list '(1 3 5)))
303             (progn (setf y (incf i)) (copy-list '(2 5 8)))
304             :key (progn (setf z (incf i)) #'identity)
305             :test (progn (setf w (incf i)) #'eql))
306      #'<)
307     i x y z w))
308  (1 2 3 5 8)
309  4 1 2 3 4)
310
311;;; Keyword tests
312
313(deftest union.allow-other-keys.1
314  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t
315               :allow-other-keys "yes")
316        #'<)
317  (1 2 5 7 9 10 11 20))
318
319(deftest union.allow-other-keys.2
320  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
321               :allow-other-keys t :also-bad t)
322        #'<)
323  (1 2 5 7 9 10 11 20))
324
325(deftest union.allow-other-keys.3
326  (sort (union (list 1 2 3) (list 1 2 3)
327               :allow-other-keys t :also-bad t
328               :test #'(lambda (x y) (= x (+ y 100))))
329        #'<)
330  (1 1 2 2 3 3))
331
332(deftest union.allow-other-keys.4
333  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
334               :allow-other-keys t)
335        #'<)
336  (1 2 5 7 9 10 11 20))
337
338(deftest union.allow-other-keys.5
339  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
340               :allow-other-keys nil)
341        #'<)
342  (1 2 5 7 9 10 11 20))
343
344(deftest union.allow-other-keys.6
345  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
346               :allow-other-keys t
347               :allow-other-keys nil)
348        #'<)
349  (1 2 5 7 9 10 11 20))
350
351(deftest union.allow-other-keys.7
352  (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2)
353               :allow-other-keys t
354               :allow-other-keys nil
355               '#:x 1)
356        #'<)
357  (1 2 5 7 9 10 11 20))
358
359(deftest union.keywords.9
360  (sort (union (list 1 2 3) (list 1 2 3)
361               :test #'(lambda (x y) (= x (+ y 100)))
362               :test #'eql)
363        #'<)
364  (1 1 2 2 3 3))
365
366(def-fold-test union.fold.1 (union '(a b c d e) '(d x y a w c)))
367
368;;; Error tests
369
370(deftest union.error.1
371  (signals-error (union) program-error)
372  t)
373
374(deftest union.error.2
375  (signals-error (union nil) program-error)
376  t)
377
378(deftest union.error.3
379  (signals-error (union nil nil :bad t) program-error)
380  t)
381
382(deftest union.error.4
383  (signals-error (union nil nil :key) program-error)
384  t)
385
386(deftest union.error.5
387  (signals-error (union nil nil 1 2) program-error)
388  t)
389
390(deftest union.error.6
391  (signals-error (union nil nil :bad t :allow-other-keys nil) program-error)
392  t)
393
394(deftest union.error.7
395  (signals-error (union (list 1 2) (list 3 4) :test #'identity) program-error)
396  t)
397
398(deftest union.error.8
399  (signals-error (union (list 1 2) (list 3 4) :test-not #'identity) program-error)
400  t)
401
402(deftest union.error.9
403  (signals-error (union (list 1 2) (list 3 4) :key #'cons) program-error)
404  t)
405
406(deftest union.error.10
407  (signals-error (union (list 1 2) (list 3 4) :key #'car) type-error)
408  t)
409
410(deftest union.error.11
411  (signals-error (union (list 1 2 3) (list* 4 5 6)) type-error)
412  t)
413
414(deftest union.error.12
415  (signals-error (union (list* 1 2 3) (list 4 5 6)) type-error)
416  t)
417
418;;; The next two tests used to check for union with NIL, but arguably
419;;; that goes beyond the 'be prepared to signal an error' requirement,
420;;; since a union algorithm doesn't have to traverse one argument
421;;; if the other is the empty list.
422
423(deftest union.error.13
424  (check-type-error #'(lambda (x) (union x '(1 2))) #'listp)
425  nil)
426
427(deftest union.error.14
428  (check-type-error #'(lambda (x) (union '(1 2) x)) #'listp)
429  nil)
Note: See TracBrowser for help on using the repository browser.