source: trunk/source/tests/ansi-tests/member.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.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Mar 28 07:38:57 1998
4;;;; Contains: Tests of MEMBER
5
6(in-package :cl-test)
7
8(compile-and-load "cons-aux.lsp")
9
10(deftest member.1
11  (let* ((x (copy-tree '(a b c d e f)))
12         (xcopy (make-scaffold-copy x))
13         (result (member 'c x)))
14    (and
15     (eqt result (cddr x))
16     (check-scaffold-copy x xcopy)))
17  t)
18
19(deftest member.2
20  (let* ((x (copy-tree '(a b c d e f)))
21         (xcopy (make-scaffold-copy x))
22         (result (member 'e x)))
23    (and
24     (eqt result (cddddr x))
25     (check-scaffold-copy x xcopy)))
26  t)
27
28(deftest member.3
29  (let* ((x (copy-tree '(1 2 3 4 5 6 7)))
30         (xcopy (make-scaffold-copy x))
31         (result (member 4 x)))
32    (and
33     (eqt result (cdddr x))
34     (check-scaffold-copy x xcopy)))
35  t)
36
37(deftest member.4
38  (let* ((x (copy-tree '(2 4 6 8 10 12)))
39         (xcopy (make-scaffold-copy x))
40         (result (member 9 x :key #'1+)))
41    (and
42     (eqt result (cdddr x))
43     (check-scaffold-copy x xcopy)))
44  t)
45
46(deftest member.5
47  (let* ((x (copy-tree '((a b) (c d) (e f) (g h))))
48         (xcopy (make-scaffold-copy x))
49         (result (member '(c d) x :test #'equal)))
50    (and
51     (eqt result (cdr x))
52     (check-scaffold-copy x xcopy)))
53  t)
54
55(deftest member.6
56  (let* ((x (copy-tree '((a b) (c d) (e f) (g h))))
57         (xcopy (make-scaffold-copy x))
58         (result (member 'c x :key #'car)))
59    (and
60     (eqt result (cdr x))
61     (check-scaffold-copy x xcopy)))
62  t)
63
64(deftest member.7
65  (let* ((x (copy-tree '((a b) (c d) (e f) (g h))))
66         (xcopy (make-scaffold-copy x))
67         (result (member 'c x :key #'car :test #'eq)))
68    (and
69     (eqt result (cdr x))
70     (check-scaffold-copy x xcopy)))
71  t)
72
73(deftest member.8
74  (let* ((x (copy-tree '((a b) (c d) (e f) (g h))))
75         (xcopy (make-scaffold-copy x))
76         (result (member 'c x :key #'car :test-not (complement #'eq))))
77    (and
78     (eqt result (cdr x))
79     (check-scaffold-copy x xcopy)))
80  t)
81
82(deftest member.9
83  (let* ((x (copy-tree '((a b) (c d) (e f) (g h))))
84         (xcopy (make-scaffold-copy x))
85         (result (member 'c x :key #'car :test #'eql)))
86    (and
87     (eqt result (cdr x))
88     (check-scaffold-copy x xcopy)))
89  t)
90
91(deftest member.10
92  (let* ((x (copy-tree '((a b) (c d) (e f) (g h))))
93         (xcopy (make-scaffold-copy x))
94         (result (member (list 'd) x :key #'cdr :test #'equal)))
95    (and
96     (eqt result (cdr x))
97     (check-scaffold-copy x xcopy)))
98  t)
99
100(deftest member.11
101  (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee")))
102  nil)
103
104(deftest member.12
105  (member 1 (copy-tree '(3 4 1 31 423)))
106  (1 31 423))
107
108(deftest member.13
109  (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee"))
110          :test #'equal)
111  ("cc" "dd" "ee"))
112
113(deftest member.14
114  (member 'a nil)
115  nil)
116
117(deftest member.15
118  (member nil nil)
119  nil)
120
121(deftest member.16
122  (member nil nil :test #'equal)
123  nil)
124
125(deftest member.16-a
126  (member nil nil :test #'(lambda (x y) (error "Should not call this function")))
127  nil)
128
129(deftest member.17
130  (member 'a nil :test #'(lambda (x y) (error "Should not call this function")))
131  nil)
132
133;; Check that a null key argument is ignored
134
135(deftest member.18
136  (member 'a '(c d a b e) :key nil)
137  (a b e))
138
139(deftest member.19
140  (member 'z '(a b c d) :key nil)
141  nil)
142
143(deftest member.20
144  (member 10 '(1 2 3 4 10 11 14 18) :test #'<)
145  (11 14 18))
146
147(deftest member.21
148  (member 10 '(1 2 3 4 10 11 14 18) :test-not #'>=)
149  (11 14 18))
150
151(defharmless member.test-and-test-not.1
152  (member 'b '(a b c) :test #'eql :test-not #'eql))
153
154(defharmless member.test-and-test-not.2
155  (member 'b '(a b c) :test-not #'eql :test #'eql))
156
157;;; Order of evaluation
158
159(deftest member.order.1
160  (let ((i 0) x y)
161    (values
162     (member (progn (setf x (incf i)) 'c)
163             (progn (setf y (incf i)) '(a b c d)))
164     i x y))
165  (c d) 2 1 2)
166
167(deftest member.order.2
168  (let ((i 0) x y z p)
169    (values
170     (member (progn (setf x (incf i)) 'c)
171             (progn (setf y (incf i)) '(a b c d))
172             :key (progn (setf z (incf i)) #'identity)
173             :test (progn (setf p (incf i)) #'eq))
174     i x y z p))
175  (c d) 4 1 2 3 4)
176
177(deftest member.order.3
178  (let ((i 0) x y)
179    (values
180     (member (progn (setf x (incf i)) 'c)
181             (progn (setf y (incf i)) '(a b c d))
182             :test #'eq)
183     i x y))
184  (c d) 2 1 2)
185
186(deftest member.order.4
187  (let ((i 0) x y z p q)
188    (values
189     (member (progn (setf x (incf i)) 'c)
190             (progn (setf y (incf i)) '(a b c d))
191             :key (progn (setf z (incf i)) #'identity)
192             :test (progn (setf p (incf i)) #'eq)
193             :key (progn (setf q (incf i)) (constantly 'z)))
194     i x y z p q))
195  (c d) 5 1 2 3 4 5)
196
197(deftest member.order.5
198  (let ((i 0) x y z q)
199    (values
200     (member (progn (setf x (incf i)) 'c)
201             (progn (setf y (incf i)) '(a b c d))
202             :test #'eq
203             :key (progn (setf z (incf i)) #'identity)
204             :key (progn (setf q (incf i)) (constantly 'z)))
205     i x y z q))
206  (c d) 4 1 2 3 4)
207
208
209;;; Keyword tests
210
211(deftest member.allow-other-keys.1
212  (member 'b '(a b c) :bad t :allow-other-keys t)
213  (b c))
214
215(deftest member.allow-other-keys.2
216  (member 'b '(a b c) :allow-other-keys t :bad t)
217  (b c))
218
219(deftest member.allow-other-keys.3
220  (member 'b '(a b c) :allow-other-keys t)
221  (b c))
222
223(deftest member.allow-other-keys.4
224  (member 'b '(a b c) :allow-other-keys nil)
225  (b c))
226
227(deftest member.allow-other-keys.5
228  (member 'b '(a b c) :allow-other-keys 17 :allow-other-keys nil '#:x t)
229  (b c))
230
231(deftest member.keywords.6
232  (member 'b '(a b c) :test #'eq :test (complement #'eq))
233  (b c))
234
235;;; Error cases
236
237(deftest member.error.1
238  (check-type-error #'(lambda (x) (member 'a x)) #'listp)
239  nil)
240
241(deftest member.error.2
242  (signals-error (member 'a 1.3) type-error)
243  t)
244
245(deftest member.error.3
246  (signals-error (member 'a 1) type-error)
247  t)
248
249(deftest member.error.4
250  (signals-error (member 'a 0) type-error)
251  t)
252
253(deftest member.error.5
254  (signals-error (member 'a "abcde") type-error)
255  t)
256
257(deftest member.error.6
258  (signals-error (member 'a #\w) type-error)
259  t)
260
261(deftest member.error.7
262  (signals-error (member 'a t) type-error)
263  t)
264
265(deftest member.error.8
266  (signals-error (member) program-error)
267  t)
268
269(deftest member.error.9
270  (signals-error (member nil) program-error)
271  t)
272
273(deftest member.error.10
274  (signals-error (member nil nil :bad t) program-error)
275  t)
276
277(deftest member.error.11
278  (signals-error (member nil nil :test) program-error)
279  t)
280
281(deftest member.error.12
282  (signals-error (member nil nil :bad t :allow-other-keys nil)
283                 program-error)
284  t)
285
286(deftest member.error.13
287  (signals-error (member nil nil nil) program-error)
288  t)
289
290(deftest member.error.14
291  (signals-error (locally (member 'a t) t) type-error)
292  t)
293
294(deftest member.error.15
295  (signals-error (member 'a '(a b c) :test #'identity) program-error)
296  t)
297
298(deftest member.error.16
299  (signals-error (member 'a '(a b c) :test-not #'identity) program-error)
300  t)
301
302(deftest member.error.17
303  (signals-error (member 'a '(a b c) :key #'cons) program-error)
304  t)
Note: See TracBrowser for help on using the repository browser.