← Back to branch summary

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

« back to all changes in this revision

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