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