10 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
11 |
;;; acons |
;;; acons |
12 |
|
|
13 |
(deftest acons-1 |
(deftest acons.1 |
14 |
(let* ((x (copy-tree '((c . d) (e . f)))) |
(let* ((x (copy-tree '((c . d) (e . f)))) |
15 |
(xcopy (make-scaffold-copy x)) |
(xcopy (make-scaffold-copy x)) |
16 |
(result (acons 'a 'b x))) |
(result (acons 'a 'b x))) |
17 |
(and |
(and |
18 |
(check-scaffold-copy x xcopy) |
(check-scaffold-copy x xcopy) |
19 |
(eqt (cdr result) x) |
(eqt (cdr result) x) |
20 |
result)) |
result)) |
21 |
((a . b) (c . d) (e . f))) |
((a . b) (c . d) (e . f))) |
22 |
|
|
23 |
(deftest acons-2 |
(deftest acons.2 |
24 |
(acons 'a 'b nil) |
(acons 'a 'b nil) |
25 |
((a . b))) |
((a . b))) |
26 |
|
|
27 |
(deftest acons-3 |
(deftest acons.3 |
28 |
(acons 'a 'b 'c) |
(acons 'a 'b 'c) |
29 |
((a . b) . c)) |
((a . b) . c)) |
30 |
|
|
31 |
(deftest acons-4 |
(deftest acons.4 |
32 |
(acons '((a b)) '(((c d) e) f) '((1 . 2))) |
(acons '((a b)) '(((c d) e) f) '((1 . 2))) |
33 |
(( ((a b)) . (((c d) e) f)) (1 . 2))) |
(( ((a b)) . (((c d) e) f)) (1 . 2))) |
34 |
|
|
35 |
(deftest acons-5 |
(deftest acons.5 |
36 |
(acons "ancd" 1.143 nil) |
(acons "ancd" 1.143 nil) |
37 |
(("ancd" . 1.143))) |
(("ancd" . 1.143))) |
38 |
|
|
39 |
(deftest acons-6 |
(deftest acons.6 |
40 |
(acons #\R :foo :bar) |
(acons #\R :foo :bar) |
41 |
((#\R . :foo) . :bar)) |
((#\R . :foo) . :bar)) |
42 |
|
|
43 |
|
(deftest acons.7 |
44 |
|
(let ((i 0) x y z) |
45 |
|
(values |
46 |
|
(acons (progn (setf x (incf i)) 'a) |
47 |
|
(progn (setf y (incf i)) 'b) |
48 |
|
(progn (setf z (incf i)) '((c . d)))) |
49 |
|
i x y z)) |
50 |
|
((a . b)(c . d)) |
51 |
|
3 1 2 3) |
52 |
|
|
53 |
(deftest acons.error.1 |
(deftest acons.error.1 |
54 |
(classify-error (acons)) |
(classify-error (acons)) |
55 |
program-error) |
program-error) |
69 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
70 |
;;; assoc |
;;; assoc |
71 |
|
|
72 |
(deftest assoc-1 |
(deftest assoc.1 |
73 |
(assoc nil nil) |
(assoc nil nil) |
74 |
nil) |
nil) |
75 |
|
|
76 |
(deftest assoc-2 |
(deftest assoc.2 |
77 |
(assoc nil '(nil)) |
(assoc nil '(nil)) |
78 |
nil) |
nil) |
79 |
|
|
80 |
(deftest assoc-3 |
(deftest assoc.3 |
81 |
(assoc nil '(nil (nil . 2) (a . b))) |
(assoc nil '(nil (nil . 2) (a . b))) |
82 |
(nil . 2)) |
(nil . 2)) |
83 |
|
|
84 |
(deftest assoc-4 |
(deftest assoc.4 |
85 |
(assoc nil '((a . b) (c . d))) |
(assoc nil '((a . b) (c . d))) |
86 |
nil) |
nil) |
87 |
|
|
88 |
(deftest assoc-5 |
(deftest assoc.5 |
89 |
(assoc 'a '((a . b))) |
(assoc 'a '((a . b))) |
90 |
(a . b)) |
(a . b)) |
91 |
|
|
92 |
(deftest assoc-6 |
(deftest assoc.6 |
93 |
(assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f))) |
(assoc 'a '((:a . b) (#:a . c) (a . d) (a . e) (z . f))) |
94 |
(a . d)) |
(a . d)) |
95 |
|
|
96 |
(deftest assoc-7 |
(deftest assoc.7 |
97 |
(let* ((x (copy-tree '((a . b) (b . c) (c . d)))) |
(let* ((x (copy-tree '((a . b) (b . c) (c . d)))) |
98 |
(xcopy (make-scaffold-copy x)) |
(xcopy (make-scaffold-copy x)) |
99 |
(result (assoc 'b x))) |
(result (assoc 'b x))) |
102 |
(check-scaffold-copy x xcopy))) |
(check-scaffold-copy x xcopy))) |
103 |
t) |
t) |
104 |
|
|
105 |
(deftest assoc-8 |
(deftest assoc.8 |
106 |
(assoc 1 '((0 . a) (1 . b) (2 . c))) |
(assoc 1 '((0 . a) (1 . b) (2 . c))) |
107 |
(1 . b)) |
(1 . b)) |
108 |
|
|
109 |
(deftest assoc-9 |
(deftest assoc.9 |
110 |
(assoc (copy-seq "abc") |
(assoc (copy-seq "abc") |
111 |
'((abc . 1) ("abc" . 2) ("abc" . 3))) |
'((abc . 1) ("abc" . 2) ("abc" . 3))) |
112 |
nil) |
nil) |
113 |
|
|
114 |
(deftest assoc-10 |
(deftest assoc.10 |
115 |
(assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))) |
(assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c))))) |
116 |
nil) |
nil) |
117 |
|
|
118 |
(deftest assoc-11 |
(deftest assoc.11 |
119 |
(let ((x (list 'a 'b))) |
(let ((x (list 'a 'b))) |
120 |
(assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1)))) |
(assoc x `(((a b) c) (,x . d) (,x . e) ((a b) 1)))) |
121 |
((a b) . d)) |
((a b) . d)) |
122 |
|
|
123 |
|
|
124 |
(deftest assoc-12 |
(deftest assoc.12 |
125 |
(assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) |
(assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) |
126 |
:key #'(lambda (x) (char x 1))) |
:key #'(lambda (x) (char x 1))) |
127 |
("aevgd" . 2)) |
("aevgd" . 2)) |
128 |
|
|
129 |
(deftest assoc-13 |
(deftest assoc.13 |
130 |
(assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) |
(assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) |
131 |
:key #'car) |
:key #'car) |
132 |
(nil . c)) |
(nil . c)) |
133 |
|
|
134 |
(deftest assoc-14 |
(deftest assoc.14 |
135 |
(assoc (copy-seq "abc") |
(assoc (copy-seq "abc") |
136 |
'((abc . 1) ("abc" . 2) ("abc" . 3)) |
'((abc . 1) ("abc" . 2) ("abc" . 3)) |
137 |
:test #'equal) |
:test #'equal) |
138 |
("abc" . 2)) |
("abc" . 2)) |
139 |
|
|
140 |
(deftest assoc-15 |
(deftest assoc.15 |
141 |
(assoc (copy-seq "abc") |
(assoc (copy-seq "abc") |
142 |
'((abc . 1) ("abc" . 2) ("abc" . 3)) |
'((abc . 1) ("abc" . 2) ("abc" . 3)) |
143 |
:test #'equalp) |
:test #'equalp) |
144 |
("abc" . 2)) |
("abc" . 2)) |
145 |
|
|
146 |
(deftest assoc-16 |
(deftest assoc.16 |
147 |
(assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) |
(assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) |
148 |
:test #'equal) |
:test #'equal) |
149 |
((a) b)) |
((a) b)) |
150 |
|
|
151 |
(deftest assoc-17 |
(deftest assoc.17 |
152 |
(assoc (copy-seq "abc") |
(assoc (copy-seq "abc") |
153 |
'((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) |
'((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) |
154 |
:test-not (complement #'equalp)) |
:test-not (complement #'equalp)) |
155 |
("abc" . 2)) |
("abc" . 2)) |
156 |
|
|
157 |
(deftest assoc-18 |
(deftest assoc.18 |
158 |
(assoc 'a '((a . d)(b . c)) :test-not #'eq) |
(assoc 'a '((a . d)(b . c)) :test-not #'eq) |
159 |
(b . c)) |
(b . c)) |
160 |
|
|
161 |
(deftest assoc-19 |
(deftest assoc.19 |
162 |
(assoc 'a '((a . d)(b . c)) :test (complement #'eq)) |
(assoc 'a '((a . d)(b . c)) :test (complement #'eq)) |
163 |
(b . c)) |
(b . c)) |
164 |
|
|
165 |
(deftest assoc-20 |
(deftest assoc.20 |
166 |
(assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) |
(assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) |
167 |
:key #'(lambda (x) (and (stringp x) (string-downcase x))) |
:key #'(lambda (x) (and (stringp x) (string-downcase x))) |
168 |
:test #'equal) |
:test #'equal) |
169 |
("A" . 6)) |
("A" . 6)) |
170 |
|
|
171 |
(deftest assoc-21 |
(deftest assoc.21 |
172 |
(assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) |
(assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) |
173 |
:key #'(lambda (x) (and (stringp x) x)) |
:key #'(lambda (x) (and (stringp x) x)) |
174 |
:test #'equal) |
:test #'equal) |
175 |
("a" . 3)) |
("a" . 3)) |
176 |
|
|
177 |
(deftest assoc-22 |
(deftest assoc.22 |
178 |
(assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) |
(assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) |
179 |
:key #'(lambda (x) (and (stringp x) (string-downcase x))) |
:key #'(lambda (x) (and (stringp x) (string-downcase x))) |
180 |
:test-not (complement #'equal)) |
:test-not (complement #'equal)) |
181 |
("A" . 6)) |
("A" . 6)) |
182 |
|
|
183 |
(deftest assoc-23 |
(deftest assoc.23 |
184 |
(assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) |
(assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) |
185 |
:key #'(lambda (x) (and (stringp x) x)) |
:key #'(lambda (x) (and (stringp x) x)) |
186 |
:test-not (complement #'equal)) |
:test-not (complement #'equal)) |
189 |
;; Check that it works when test returns a true value |
;; Check that it works when test returns a true value |
190 |
;; other than T |
;; other than T |
191 |
|
|
192 |
(deftest assoc-24 |
(deftest assoc.24 |
193 |
(assoc 'a '((b . 1) (a . 2) (c . 3)) |
(assoc 'a '((b . 1) (a . 2) (c . 3)) |
194 |
:test #'(lambda (x y) (and (eqt x y) 'matched))) |
:test #'(lambda (x y) (and (eqt x y) 'matched))) |
195 |
(a . 2)) |
(a . 2)) |
196 |
|
|
197 |
;; Check that the order of the arguments to test is correct |
;; Check that the order of the arguments to test is correct |
198 |
|
|
199 |
(deftest assoc-25 |
(deftest assoc.25 |
200 |
(block fail |
(block fail |
201 |
(assoc 'a '((b . 1) (c . 2) (a . 3)) |
(assoc 'a '((b . 1) (c . 2) (a . 3)) |
202 |
:test #'(lambda (x y) |
:test #'(lambda (x y) |
204 |
(eqt x y)))) |
(eqt x y)))) |
205 |
(A . 3)) |
(A . 3)) |
206 |
|
|
207 |
|
;;; Order of argument evaluation |
208 |
|
|
209 |
|
(deftest assoc.26 |
210 |
|
(let ((i 0) x y) |
211 |
|
(values |
212 |
|
(assoc (progn (setf x (incf i)) 'c) |
213 |
|
(progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))) |
214 |
|
i x y)) |
215 |
|
(c . 3) 2 1 2) |
216 |
|
|
217 |
|
(deftest assoc.27 |
218 |
|
(let ((i 0) x y z) |
219 |
|
(values |
220 |
|
(assoc (progn (setf x (incf i)) 'c) |
221 |
|
(progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) |
222 |
|
:test (progn (setf z (incf i)) #'eq)) |
223 |
|
i x y z)) |
224 |
|
(c . 3) 3 1 2 3) |
225 |
|
|
226 |
|
(deftest assoc.28 |
227 |
|
(let ((i 0) x y) |
228 |
|
(values |
229 |
|
(assoc (progn (setf x (incf i)) 'c) |
230 |
|
(progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) |
231 |
|
:test #'eq) |
232 |
|
i x y)) |
233 |
|
(c . 3) 2 1 2) |
234 |
|
|
235 |
|
(deftest assoc.29 |
236 |
|
(let ((i 0) x y z w) |
237 |
|
(values |
238 |
|
(assoc (progn (setf x (incf i)) 'c) |
239 |
|
(progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) |
240 |
|
:key (progn (setf z (incf i)) #'identity) |
241 |
|
:key (progn (setf w (incf i)) #'not)) |
242 |
|
i x y z w)) |
243 |
|
(c . 3) 4 1 2 3 4) |
244 |
|
|
245 |
;;; Keyword tests |
;;; Keyword tests |
246 |
|
|
247 |
(deftest assoc.allow-other-keys.1 |
(deftest assoc.allow-other-keys.1 |
301 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
302 |
;;; assoc-if |
;;; assoc-if |
303 |
|
|
304 |
(deftest assoc-if-1 |
(deftest assoc-if.1 |
305 |
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) |
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) |
306 |
(xcopy (make-scaffold-copy x)) |
(xcopy (make-scaffold-copy x)) |
307 |
(result (assoc-if #'evenp x))) |
(result (assoc-if #'evenp x))) |
311 |
result)) |
result)) |
312 |
(6 . c)) |
(6 . c)) |
313 |
|
|
314 |
(deftest assoc-if-2 |
(deftest assoc-if.2 |
315 |
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) |
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) |
316 |
(xcopy (make-scaffold-copy x)) |
(xcopy (make-scaffold-copy x)) |
317 |
(result (assoc-if #'oddp x :key #'1+))) |
(result (assoc-if #'oddp x :key #'1+))) |
321 |
result)) |
result)) |
322 |
(6 . c)) |
(6 . c)) |
323 |
|
|
324 |
(deftest assoc-if-3 |
(deftest assoc-if.3 |
325 |
(let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) |
(let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) |
326 |
(xcopy (make-scaffold-copy x)) |
(xcopy (make-scaffold-copy x)) |
327 |
(result (assoc-if #'evenp x))) |
(result (assoc-if #'evenp x))) |
331 |
result)) |
result)) |
332 |
(6 . c)) |
(6 . c)) |
333 |
|
|
334 |
(deftest assoc-if-4 |
(deftest assoc-if.4 |
335 |
(assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) |
(assoc-if #'null '((a . b) nil (c . d) (nil . e) (f . g))) |
336 |
(nil . e)) |
(nil . e)) |
337 |
|
|
338 |
|
;;; Order of argument evaluation |
339 |
|
|
340 |
|
(deftest assoc-if.5 |
341 |
|
(let ((i 0) x y) |
342 |
|
(values |
343 |
|
(assoc-if (progn (setf x (incf i)) #'null) |
344 |
|
(progn (setf y (incf i)) |
345 |
|
'((a . 1) (b . 2) (nil . 17) (d . 4)))) |
346 |
|
i x y)) |
347 |
|
(nil . 17) 2 1 2) |
348 |
|
|
349 |
|
(deftest assoc-if.6 |
350 |
|
(let ((i 0) x y z) |
351 |
|
(values |
352 |
|
(assoc-if (progn (setf x (incf i)) #'null) |
353 |
|
(progn (setf y (incf i)) |
354 |
|
'((a . 1) (b . 2) (nil . 17) (d . 4))) |
355 |
|
:key (progn (setf z (incf i)) #'null)) |
356 |
|
i x y z)) |
357 |
|
(a . 1) 3 1 2 3) |
358 |
|
|
359 |
;;; Keyword tests |
;;; Keyword tests |
360 |
|
|
361 |
(deftest assoc-if.allow-other-keys.1 |
(deftest assoc-if.allow-other-keys.1 |
417 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
418 |
;;; assoc-if-not |
;;; assoc-if-not |
419 |
|
|
420 |
(deftest assoc-if-not-1 |
(deftest assoc-if-not.1 |
421 |
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) |
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) |
422 |
(xcopy (make-scaffold-copy x)) |
(xcopy (make-scaffold-copy x)) |
423 |
(result (assoc-if-not #'oddp x))) |
(result (assoc-if-not #'oddp x))) |
427 |
result)) |
result)) |
428 |
(6 . c)) |
(6 . c)) |
429 |
|
|
430 |
(deftest assoc-if-not-2 |
(deftest assoc-if-not.2 |
431 |
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) |
(let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) |
432 |
(xcopy (make-scaffold-copy x)) |
(xcopy (make-scaffold-copy x)) |
433 |
(result (assoc-if-not #'evenp x :key #'1+))) |
(result (assoc-if-not #'evenp x :key #'1+))) |
437 |
result)) |
result)) |
438 |
(6 . c)) |
(6 . c)) |
439 |
|
|
440 |
(deftest assoc-if-not-3 |
(deftest assoc-if-not.3 |
441 |
(let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) |
(let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) |
442 |
(xcopy (make-scaffold-copy x)) |
(xcopy (make-scaffold-copy x)) |
443 |
(result (assoc-if-not #'oddp x))) |
(result (assoc-if-not #'oddp x))) |
447 |
result)) |
result)) |
448 |
(6 . c)) |
(6 . c)) |
449 |
|
|
450 |
(deftest assoc-if-not-4 |
(deftest assoc-if-not.4 |
451 |
(assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g))) |
(assoc-if-not #'identity '((a . b) nil (c . d) (nil . e) (f . g))) |
452 |
(nil . e)) |
(nil . e)) |
453 |
|
|
454 |
|
;;; Order of argument evaluation tests |
455 |
|
|
456 |
|
(deftest assoc-if-not.5 |
457 |
|
(let ((i 0) x y) |
458 |
|
(values |
459 |
|
(assoc-if-not (progn (setf x (incf i)) #'identity) |
460 |
|
(progn (setf y (incf i)) |
461 |
|
'((a . 1) (b . 2) (nil . 17) (d . 4)))) |
462 |
|
i x y)) |
463 |
|
(nil . 17) 2 1 2) |
464 |
|
|
465 |
|
(deftest assoc-if-not.6 |
466 |
|
(let ((i 0) x y z) |
467 |
|
(values |
468 |
|
(assoc-if-not (progn (setf x (incf i)) #'identity) |
469 |
|
(progn (setf y (incf i)) |
470 |
|
'((a . 1) (b . 2) (nil . 17) (d . 4))) |
471 |
|
:key (progn (setf z (incf i)) #'null)) |
472 |
|
i x y z)) |
473 |
|
(a . 1) 3 1 2 3) |
474 |
|
|
475 |
;;; Keyword tests |
;;; Keyword tests |
476 |
|
|
477 |
(deftest assoc-if-not.allow-other-keys.1 |
(deftest assoc-if-not.allow-other-keys.1 |