← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/union.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/union.lsp
 
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
;;; Error tests
 
367
 
 
368
(deftest union.error.1
 
369
  (signals-error (union) program-error)
 
370
  t)
 
371
 
 
372
(deftest union.error.2
 
373
  (signals-error (union nil) program-error)
 
374
  t)
 
375
 
 
376
(deftest union.error.3
 
377
  (signals-error (union nil nil :bad t) program-error)
 
378
  t)
 
379
 
 
380
(deftest union.error.4
 
381
  (signals-error (union nil nil :key) program-error)
 
382
  t)
 
383
 
 
384
(deftest union.error.5
 
385
  (signals-error (union nil nil 1 2) program-error)
 
386
  t)
 
387
 
 
388
(deftest union.error.6
 
389
  (signals-error (union nil nil :bad t :allow-other-keys nil) program-error)
 
390
  t)
 
391
 
 
392
(deftest union.error.7
 
393
  (signals-error (union (list 1 2) (list 3 4) :test #'identity) program-error)
 
394
  t)
 
395
 
 
396
(deftest union.error.8
 
397
  (signals-error (union (list 1 2) (list 3 4) :test-not #'identity) program-error)
 
398
  t)
 
399
 
 
400
(deftest union.error.9
 
401
  (signals-error (union (list 1 2) (list 3 4) :key #'cons) program-error)
 
402
  t)
 
403
 
 
404
(deftest union.error.10
 
405
  (signals-error (union (list 1 2) (list 3 4) :key #'car) type-error)
 
406
  t)
 
407
 
 
408
(deftest union.error.11
 
409
  (signals-error (union (list 1 2 3) (list* 4 5 6)) type-error)
 
410
  t)
 
411
 
 
412
(deftest union.error.12
 
413
  (signals-error (union (list* 1 2 3) (list 4 5 6)) type-error)
 
414
  t)