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

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

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

File size: 6.3 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Wed Apr  1 22:10:54 1998
4;;;; Contains: Tests of SUBSETP
5
6(in-package :cl-test)
7
8(compile-and-load "cons-aux.lsp")
9
10(defvar cons-test-24-var '(78 "z" (8 9)))
11
12(deftest subsetp.1
13  (subsetp-with-check (copy-tree '(78)) cons-test-24-var)
14  t)
15
16(deftest subsetp.2
17  (subsetp-with-check (copy-tree '((8 9))) cons-test-24-var)
18  nil)
19
20(deftest subsetp.3
21  (subsetp-with-check (copy-tree '((8 9)))
22                      cons-test-24-var :test 'equal)
23  t)
24
25(deftest subsetp.4
26  (subsetp-with-check (list 78 (copy-seq "Z")) cons-test-24-var
27                      :test #'equalp)
28  t)
29
30(deftest subsetp.5
31  (subsetp-with-check (list 1) (list 0 2 3 4)
32                      :key #'(lambda (i) (floor (/ i 2))))
33  t)
34
35(deftest subsetp.6
36  (subsetp-with-check (list 1 6) (list 0 2 3 4)
37                      :key #'(lambda (i) (floor (/ i 2))))
38  nil)
39
40(deftest subsetp.7
41  (subsetp-with-check (list '(a . 10) '(b . 20) '(c . 30))
42                      (list '(z . c) '(a . y) '(b . 100) '(e . f)
43                            '(c . foo))
44                      :key #'car)
45  t)
46
47(deftest subsetp.8
48  (subsetp-with-check (copy-tree '((a . 10) (b . 20) (c . 30)))
49                      (copy-tree '((z . c) (a . y) (b . 100) (e . f)
50                                   (c . foo)))
51                      :key 'car)
52  t)
53
54(deftest subsetp.9
55  (subsetp-with-check (list 'a 'b 'c)
56                      (copy-tree
57                       (list '(z . c) '(a . y) '(b . 100) '(e . f)
58                             '(c . foo)))
59                      :test #'(lambda (e1 e2)
60                                (eqt e1 (car e2))))
61  t)
62
63(deftest subsetp.10
64  (subsetp-with-check (list 'a 'b 'c)
65                      (copy-tree
66                       (list '(z . c) '(a . y) '(b . 100) '(e . f)
67                             '(c . foo)))
68                      :test #'(lambda (e1 e2)
69                                (eqt e1 (car e2)))
70                      :key nil)
71  t)
72
73(deftest subsetp.11
74  (subsetp-with-check (list 'a 'b 'c)
75                      (copy-tree
76                       (list '(z . c) '(a . y) '(b . 100) '(e . f)
77                             '(c . foo)))
78                      :test-not  #'(lambda (e1 e2)
79                                     (not (eqt e1 (car e2)))))
80  t)
81
82;; Check that it maintains order of arguments
83
84(deftest subsetp.12
85  (block fail
86    (subsetp-with-check
87     (list 1 2 3)
88     (list 4 5 6)
89     :test #'(lambda (x y)
90               (when (< y x) (return-from fail 'fail))
91               t)))
92  t)
93
94(deftest subsetp.13
95  (block fail
96    (subsetp-with-check
97     (list 1 2 3)
98     (list 4 5 6)
99     :key #'identity
100     :test #'(lambda (x y)
101               (when (< y x) (return-from fail 'fail))
102               t)))
103  t)
104
105(deftest subsetp.14
106  (block fail
107    (subsetp-with-check
108     (list 1 2 3)
109     (list 4 5 6)
110     :test-not #'(lambda (x y)
111                   (when (< y x) (return-from fail 'fail))
112                   nil)))
113  t)
114
115(deftest subsetp.15
116  (block fail
117    (subsetp-with-check
118     (list 1 2 3)
119     (list 4 5 6)
120     :key #'identity
121     :test-not #'(lambda (x y)
122                   (when (< y x) (return-from fail 'fail))
123                   nil)))
124  t)
125
126(defharmless subsetp.test-and-test-not.1
127  (subsetp '(a b c) '(a g c e b) :test #'eql :test-not #'eql))
128
129(defharmless subsetp.test-and-test-not.3
130  (subsetp '(a b c) '(a g c e b) :test-not #'eql :test #'eql))
131
132;;; Order of argument evaluation tests
133
134(deftest subsetp.order.1
135  (let ((i 0) x y)
136    (values
137     (notnot (subsetp (progn (setf x (incf i))
138                             '(a b c))
139                      (progn (setf y (incf i))
140                             '(a b c d))))
141     i x y))
142  t 2 1 2)
143
144(deftest subsetp.order.2
145  (let ((i 0) x y z w)
146    (values
147     (notnot (subsetp (progn (setf x (incf i))
148                             '(a b c))
149                      (progn (setf y (incf i))
150                             '(a b c d))
151                      :test (progn (setf z (incf i)) #'eql)
152                      :key  (progn (setf w (incf i)) nil)))
153     i x y z w))
154  t 4 1 2 3 4)
155
156(deftest subsetp.order.3
157  (let ((i 0) x y z w)
158    (values
159     (notnot (subsetp (progn (setf x (incf i))
160                             '(a b c))
161                      (progn (setf y (incf i))
162                             '(a b c d))
163                      :key  (progn (setf z (incf i)) nil)
164                      :test (progn (setf w (incf i)) #'eql)))
165     i x y z w))
166  t 4 1 2 3 4)
167
168;;; Keyword tests
169
170(deftest subsetp.allow-other-keys.1
171  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :bad t :allow-other-keys 67))
172  t)
173
174(deftest subsetp.allow-other-keys.2
175  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5)
176                   :allow-other-keys #'cons :bad t))
177  t)
178
179(deftest subsetp.allow-other-keys.3
180  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4)
181                   :allow-other-keys (make-hash-table)
182                   :bad t
183                   :test #'(lambda (x y) (= (1+ x) y))))
184  nil)
185
186(deftest subsetp.allow-other-keys.4
187  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys t))
188  t)
189
190(deftest subsetp.allow-other-keys.5
191  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) :allow-other-keys nil))
192  t)
193
194(deftest subsetp.allow-other-keys.6
195  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5)
196                   :allow-other-keys t :bad1 t
197                   :allow-other-keys nil :bad2 t))
198  t)
199
200(deftest subsetp.keywords.7
201  (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4)
202                   :test #'(lambda (x y) (= (1+ x) y))
203                   :test #'eql))
204  nil)
205
206(deftest subsetp.keywords.8
207  (notnot-mv (subsetp '(1 2 3 4 10) '(0 1 2 3 4)
208                   :key nil
209                   :key #'(lambda (x) (mod x 2))))
210  nil)
211
212
213;;; Error tests
214
215(deftest subsetp.error.1
216  (signals-error (subsetp) program-error)
217  t)
218
219(deftest subsetp.error.2
220  (signals-error (subsetp nil) program-error)
221  t)
222
223(deftest subsetp.error.3
224  (signals-error (subsetp nil nil :bad t) program-error)
225  t)
226
227(deftest subsetp.error.4
228  (signals-error (subsetp nil nil :key) program-error)
229  t)
230
231(deftest subsetp.error.5
232  (signals-error (subsetp nil nil 1 2) program-error)
233  t)
234
235(deftest subsetp.error.6
236  (signals-error (subsetp nil nil :bad t :allow-other-keys nil) program-error)
237  t)
238
239(deftest subsetp.error.7
240  (signals-error (subsetp (list 1 2) (list 3 4) :test #'identity) program-error)
241  t)
242
243(deftest subsetp.error.8
244  (signals-error (subsetp (list 1 2) (list 3 4) :test-not #'identity) program-error)
245  t)
246
247(deftest subsetp.error.9
248  (signals-error (subsetp (list 1 2) (list 3 4) :key #'cons) program-error)
249  t)
250
251(deftest subsetp.error.10
252  (signals-error (subsetp (list 1 2) (list 3 4) :key #'car) type-error)
253  t)
254
255(deftest subsetp.error.11
256  (signals-error (subsetp (list 1 2 3) (list* 4 5 6)) type-error)
257  t)
258
259(deftest subsetp.error.12
260  (signals-error (subsetp (list* 1 2 3) (list 1 2 3 4 5 6)) type-error)
261  t)
262
263;;; The next two tests previously compared against NIL, but arguably
264;;; a conforming implementation is not required to signal an error
265;;; in these cases, since it doesn't have to traverse the other list.
266
267(deftest subsetp.error.13
268  (check-type-error #'(lambda (x) (subsetp x '(a b))) #'listp)
269  nil)
270
271(deftest subsetp.error.14
272  (check-type-error #'(lambda (x) (subsetp '(a b) x)) #'listp)
273  nil)
274
Note: See TracBrowser for help on using the repository browser.