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