12 |
;;; copy-tree |
;;; copy-tree |
13 |
|
|
14 |
;; Try copy-tree on a tree containing elements of various kinds |
;; Try copy-tree on a tree containing elements of various kinds |
15 |
(deftest copy-tree-1 |
(deftest copy-tree.1 |
16 |
(let ((x (cons 'a (list (cons 'b 'c) |
(let ((x (cons 'a (list (cons 'b 'c) |
17 |
(cons 1 1.2) |
(cons 1 1.2) |
18 |
(list (list "abcde" |
(list (list "abcde" |
19 |
(make-array '(10) :initial-element (cons 'e 'f))) |
(make-array '(10) :initial-element (cons 'e 'f))) |
20 |
'g))))) |
'g))))) |
21 |
(let ((y (copy-tree x))) |
(let ((y (copy-tree x))) |
22 |
(check-cons-copy x y))) |
(check-cons-copy x y))) |
23 |
t) |
t) |
24 |
|
|
25 |
;; Try copy-tree on *universe* |
;; Try copy-tree on *universe* |
26 |
(deftest copy-tree-2 |
(deftest copy-tree.2 |
27 |
(let ((x (copy-list *universe*))) |
(let* ((x (copy-list *universe*)) |
28 |
(let ((y (copy-tree x))) |
(y (copy-tree x))) |
29 |
(check-cons-copy x y))) |
(check-cons-copy x y)) |
30 |
t) |
t) |
31 |
|
|
32 |
(deftest copy-tree.error.1 |
(deftest copy-tree.error.1 |
37 |
(classify-error (copy-tree 'a 'b)) |
(classify-error (copy-tree 'a 'b)) |
38 |
program-error) |
program-error) |
39 |
|
|
40 |
(deftest sublis-1 |
(deftest sublis.1 |
41 |
(check-sublis '((a b) g (d e 10 g h) 15 . g) |
(check-sublis '((a b) g (d e 10 g h) 15 . g) |
42 |
'((e . e2) (g . 17))) |
'((e . e2) (g . 17))) |
43 |
((a b) 17 (d e2 10 17 h) 15 . 17)) |
((a b) 17 (d e2 10 17 h) 15 . 17)) |
44 |
|
|
45 |
(deftest sublis-2 |
(deftest sublis.2 |
46 |
(check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) |
(check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) |
47 |
'(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) |
'(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) |
48 |
:test #'equal) |
:test #'equal) |
49 |
(F6 10 (F4 (F3 (F2 A B) (F1 A P)) (F1 A B)))) |
(F6 10 (F4 (F3 (F2 A B) (F1 A P)) (F1 A B)))) |
50 |
|
|
51 |
(deftest sublis-3 |
(deftest sublis.3 |
52 |
(check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) |
(check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) |
53 |
'((30 . "foo"))) |
'((30 . "foo"))) |
54 |
(10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) |
(10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) |
55 |
|
|
56 |
(deftest sublis-4 |
(deftest sublis.4 |
57 |
(check-sublis (sublis |
(check-sublis (sublis |
58 |
(copy-tree '((a . 2) (b . 4) (c . 1))) |
(copy-tree '((a . 2) (b . 4) (c . 1))) |
59 |
(copy-tree '(a b c d e (a b c a d b) f))) |
(copy-tree '(a b c d e (a b c a d b) f))) |
60 |
'((t . "yes")) |
'((t . "yes")) |
61 |
:key #'(lambda (x) (and (typep x 'integer) |
:key #'(lambda (x) (and (typep x 'integer) |
62 |
(evenp x)))) |
(evenp x)))) |
63 |
("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) |
("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) |
64 |
|
|
65 |
(deftest sublis-5 |
(deftest sublis.5 |
66 |
(check-sublis '("fee" (("fee" "Fie" "foo")) |
(check-sublis '("fee" (("fee" "Fie" "foo")) |
67 |
fie ("fee" "fie")) |
fie ("fee" "fie")) |
68 |
`((,(copy-seq "fie") . #\f))) |
`((,(copy-seq "fie") . #\f))) |
69 |
("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) |
("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) |
70 |
|
|
71 |
(deftest sublis-6 |
(deftest sublis.6 |
72 |
(check-sublis '("fee" fie (("fee" "Fie" "foo") 1) |
(check-sublis '("fee" fie (("fee" "Fie" "foo") 1) |
73 |
("fee" "fie")) |
("fee" "fie")) |
74 |
`((,(copy-seq "fie") . #\f)) |
`((,(copy-seq "fie") . #\f)) |
75 |
:test 'equal) |
:test 'equal) |
76 |
("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) |
("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) |
77 |
|
|
78 |
(deftest sublis-7 |
(deftest sublis.7 |
79 |
(check-sublis '(("aa" a b) |
(check-sublis '(("aa" a b) |
80 |
(z "bb" d) |
(z "bb" d) |
81 |
((x . "aa"))) |
((x . "aa"))) |
82 |
`((,(copy-seq "aa") . 1) |
`((,(copy-seq "aa") . 1) |
83 |
(,(copy-seq "bb") . 2)) |
(,(copy-seq "bb") . 2)) |
84 |
:test 'equal |
:test 'equal |
85 |
:key #'(lambda (x) (if (consp x) (car x) |
:key #'(lambda (x) (if (consp x) (car x) |
86 |
'*not-present*))) |
'*not-present*))) |
87 |
(1 (z . 2) ((x . "aa")))) |
(1 (z . 2) ((x . "aa")))) |
88 |
|
|
89 |
;; Check that a null key arg is ignored. |
;; Check that a null key arg is ignored. |
90 |
|
|
91 |
(deftest sublis-8 |
(deftest sublis.8 |
92 |
(check-sublis |
(check-sublis |
93 |
'(1 2 a b) |
'(1 2 a b) |
94 |
'((1 . 2) (a . b)) |
'((1 . 2) (a . b)) |
95 |
:key nil) |
:key nil) |
96 |
(2 2 b b)) |
(2 2 b b)) |
97 |
|
|
98 |
|
;;; Order of argument evaluation |
99 |
|
(deftest sublis.9 |
100 |
|
(let ((i 0) w x y z) |
101 |
|
(values |
102 |
|
(sublis |
103 |
|
(progn (setf w (incf i)) |
104 |
|
'((a . z))) |
105 |
|
(progn (setf x (incf i)) |
106 |
|
(copy-tree '(a b c d))) |
107 |
|
:test (progn (setf y (incf i)) #'eql) |
108 |
|
:key (progn (setf z (incf i)) #'identity)) |
109 |
|
i w x y z)) |
110 |
|
(z b c d) |
111 |
|
4 1 2 3 4) |
112 |
|
|
113 |
|
(deftest sublis.10 |
114 |
|
(let ((i 0) w x y z) |
115 |
|
(values |
116 |
|
(sublis |
117 |
|
(progn (setf w (incf i)) |
118 |
|
'((a . z))) |
119 |
|
(progn (setf x (incf i)) |
120 |
|
(copy-tree '(a b c d))) |
121 |
|
:key (progn (setf y (incf i)) #'identity) |
122 |
|
:test-not (progn (setf z (incf i)) (complement #'eql)) |
123 |
|
) |
124 |
|
i w x y z)) |
125 |
|
(z b c d) |
126 |
|
4 1 2 3 4) |
127 |
|
|
128 |
|
|
129 |
;;; Keyword tests |
;;; Keyword tests |
130 |
|
|
131 |
(deftest sublis.allow-other-keys.1 |
(deftest sublis.allow-other-keys.1 |
174 |
|
|
175 |
;; nsublis |
;; nsublis |
176 |
|
|
177 |
(deftest nsublis-1 |
(deftest nsublis.1 |
178 |
(check-nsublis '((a b) g (d e 10 g h) 15 . g) |
(check-nsublis '((a b) g (d e 10 g h) 15 . g) |
179 |
'((e . e2) (g . 17))) |
'((e . e2) (g . 17))) |
180 |
((a b) 17 (d e2 10 17 h) 15 . 17)) |
((a b) 17 (d e2 10 17 h) 15 . 17)) |
181 |
|
|
182 |
(deftest nsublis-2 |
(deftest nsublis.2 |
183 |
(check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) |
(check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) |
184 |
'(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) |
'(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) |
185 |
:test #'equal) |
:test #'equal) |
186 |
(F6 10 (F4 (F3 (F2 A B) (F1 A P)) (F1 A B)))) |
(F6 10 (F4 (F3 (F2 A B) (F1 A P)) (F1 A B)))) |
187 |
|
|
188 |
(deftest nsublis-3 |
(deftest nsublis.3 |
189 |
(check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) |
(check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) |
190 |
'((30 . "foo"))) |
'((30 . "foo"))) |
191 |
(10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) |
(10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) |
192 |
|
|
193 |
(deftest nsublis-4 |
(deftest nsublis.4 |
194 |
(check-nsublis |
(check-nsublis |
195 |
(nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) |
(nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) |
196 |
(copy-tree '(a b c d e (a b c a d b) f))) |
(copy-tree '(a b c d e (a b c a d b) f))) |
197 |
'((t . "yes")) |
'((t . "yes")) |
198 |
:key #'(lambda (x) (and (typep x 'integer) |
:key #'(lambda (x) (and (typep x 'integer) |
199 |
(evenp x)))) |
(evenp x)))) |
200 |
("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) |
("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) |
201 |
|
|
202 |
(deftest nsublis-5 |
(deftest nsublis.5 |
203 |
(check-nsublis '("fee" (("fee" "Fie" "foo")) |
(check-nsublis '("fee" (("fee" "Fie" "foo")) |
204 |
fie ("fee" "fie")) |
fie ("fee" "fie")) |
205 |
`((,(copy-seq "fie") . #\f))) |
`((,(copy-seq "fie") . #\f))) |
206 |
("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) |
("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) |
207 |
|
|
208 |
(deftest nsublis-6 |
(deftest nsublis.6 |
209 |
(check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) |
(check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) |
210 |
("fee" "fie")) |
("fee" "fie")) |
211 |
`((,(copy-seq "fie") . #\f)) |
`((,(copy-seq "fie") . #\f)) |
212 |
:test 'equal) |
:test 'equal) |
213 |
("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) |
("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) |
214 |
|
|
215 |
(deftest nsublis-7 |
(deftest nsublis.7 |
216 |
(check-nsublis '(("aa" a b) |
(check-nsublis '(("aa" a b) |
217 |
(z "bb" d) |
(z "bb" d) |
218 |
((x . "aa"))) |
((x . "aa"))) |
219 |
`((,(copy-seq "aa") . 1) |
`((,(copy-seq "aa") . 1) |
220 |
(,(copy-seq "bb") . 2)) |
(,(copy-seq "bb") . 2)) |
221 |
:test 'equal |
:test 'equal |
222 |
:key #'(lambda (x) (if (consp x) (car x) |
:key #'(lambda (x) (if (consp x) (car x) |
223 |
'*not-present*))) |
'*not-present*))) |
224 |
(1 (z . 2) ((x . "aa")))) |
(1 (z . 2) ((x . "aa")))) |
225 |
|
|
226 |
(deftest nsublis-9 |
(deftest nsublis.8 |
227 |
(nsublis nil 'a :bad-keyword t :allow-other-keys t) |
(nsublis nil 'a :bad-keyword t :allow-other-keys t) |
228 |
a) |
a) |
229 |
|
|
230 |
;; Check that a null key arg is ignored. |
;; Check that a null key arg is ignored. |
231 |
|
|
232 |
(deftest nsublis-8 |
(deftest nsublis.9 |
233 |
(check-nsublis |
(check-nsublis |
234 |
'(1 2 a b) |
'(1 2 a b) |
235 |
'((1 . 2) (a . b)) |
'((1 . 2) (a . b)) |
236 |
:key nil) |
:key nil) |
237 |
(2 2 b b)) |
(2 2 b b)) |
238 |
|
|
239 |
|
;;; Order of argument evaluation |
240 |
|
(deftest nsublis.10 |
241 |
|
(let ((i 0) w x y z) |
242 |
|
(values |
243 |
|
(nsublis |
244 |
|
(progn (setf w (incf i)) |
245 |
|
'((a . z))) |
246 |
|
(progn (setf x (incf i)) |
247 |
|
(copy-tree '(a b c d))) |
248 |
|
:test (progn (setf y (incf i)) #'eql) |
249 |
|
:key (progn (setf z (incf i)) #'identity)) |
250 |
|
i w x y z)) |
251 |
|
(z b c d) |
252 |
|
4 1 2 3 4) |
253 |
|
|
254 |
|
(deftest nsublis.11 |
255 |
|
(let ((i 0) w x y z) |
256 |
|
(values |
257 |
|
(nsublis |
258 |
|
(progn (setf w (incf i)) |
259 |
|
'((a . z))) |
260 |
|
(progn (setf x (incf i)) |
261 |
|
(copy-tree '(a b c d))) |
262 |
|
:key (progn (setf y (incf i)) #'identity) |
263 |
|
:test-not (progn (setf z (incf i)) (complement #'eql)) |
264 |
|
) |
265 |
|
i w x y z)) |
266 |
|
(z b c d) |
267 |
|
4 1 2 3 4) |
268 |
|
|
269 |
;;; Keyword tests |
;;; Keyword tests |
270 |
|
|
271 |
(deftest nsublis.allow-other-keys.1 |
(deftest nsublis.allow-other-keys.1 |
313 |
program-error) |
program-error) |
314 |
|
|
315 |
|
|
316 |
(deftest sublis-shared |
(deftest sublis.shared |
317 |
(let* ((shared-piece (list 'a 'b)) |
(let* ((shared-piece (list 'a 'b)) |
318 |
(a (list shared-piece shared-piece))) |
(a (list shared-piece shared-piece))) |
319 |
(check-sublis a '((a . b) (b . a)))) |
(check-sublis a '((a . b) (b . a)))) |
320 |
((b a) (b a))) |
((b a) (b a))) |
321 |
|
|
322 |
(defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) |
(defvar *subst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) |
323 |
|
|
324 |
(deftest subst-1 |
(deftest subst.1 |
325 |
(check-subst "Z" 30 (copy-tree *subst-tree-1*)) |
(check-subst "Z" 30 (copy-tree *subst-tree-1*)) |
326 |
(10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) |
(10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) |
327 |
|
|
328 |
(deftest subst-2 |
(deftest subst.2 |
329 |
(check-subst "A" 0 (copy-tree *subst-tree-1*)) |
(check-subst "A" 0 (copy-tree *subst-tree-1*)) |
330 |
(10 (30 20 10) (20 10) (10 20 30 40))) |
(10 (30 20 10) (20 10) (10 20 30 40))) |
331 |
|
|
332 |
(deftest subst-3 |
(deftest subst.3 |
333 |
(check-subst "Z" 100 (copy-tree *subst-tree-1*) :test-not #'eql) |
(check-subst "Z" 100 (copy-tree *subst-tree-1*) :test-not #'eql) |
334 |
"Z") |
"Z") |
335 |
|
|
336 |
(deftest subst-4 |
(deftest subst.4 |
337 |
(check-subst 'grape 'dick |
(check-subst 'grape 'dick |
338 |
'(melville wrote (moby dick))) |
'(melville wrote (moby dick))) |
339 |
(MELVILLE WROTE (MOBY GRAPE))) |
(MELVILLE WROTE (MOBY GRAPE))) |
340 |
|
|
341 |
(deftest subst-5 |
(deftest subst.5 |
342 |
(check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick))) |
(check-subst 'cha-cha-cha 'nil '(melville wrote (moby dick))) |
343 |
(MELVILLE WROTE (MOBY DICK . CHA-CHA-CHA) . CHA-CHA-CHA)) |
(MELVILLE WROTE (MOBY DICK . CHA-CHA-CHA) . CHA-CHA-CHA)) |
344 |
|
|
345 |
(deftest subst-6 |
(deftest subst.6 |
346 |
(check-subst |
(check-subst |
347 |
'(1 2) '(foo . bar) |
'(1 2) '(foo . bar) |
348 |
'((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) |
'((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) |
349 |
:test #'equal) |
:test #'equal) |
350 |
((foo . baz) (1 2) (bar . foo) (baz 1 2))) |
((foo . baz) (1 2) (bar . foo) (baz 1 2))) |
351 |
|
|
352 |
(deftest subst-7 |
(deftest subst.7 |
353 |
(check-subst |
(check-subst |
354 |
'foo "aaa" |
'foo "aaa" |
355 |
'((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) |
'((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) |
359 |
:test #'string=) |
:test #'string=) |
360 |
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) |
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) |
361 |
|
|
362 |
(deftest subst-8 |
(deftest subst.8 |
363 |
(check-subst |
(check-subst |
364 |
'foo nil |
'foo nil |
365 |
'((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) |
'((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) |
369 |
:test-not #'equal) |
:test-not #'equal) |
370 |
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) |
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) |
371 |
|
|
372 |
(deftest subst-9 |
(deftest subst.9 |
373 |
(check-subst 'a 'b |
(check-subst 'a 'b |
374 |
(copy-tree '(a b c d a b)) |
(copy-tree '(a b c d a b)) |
375 |
:key nil) |
:key nil) |
376 |
(a a c d a a)) |
(a a c d a a)) |
377 |
|
|
378 |
|
;;; Order of argument evaluation |
379 |
|
(deftest subst.10 |
380 |
|
(let ((i 0) v w x y z) |
381 |
|
(values |
382 |
|
(subst (progn (setf v (incf i)) 'b) |
383 |
|
(progn (setf w (incf i)) 'a) |
384 |
|
(progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) |
385 |
|
:key (progn (setf y (incf i)) #'identity) |
386 |
|
:test (progn (setf z (incf i)) #'eql)) |
387 |
|
i v w x y z)) |
388 |
|
((10 b . b) b b c ((b)) z) |
389 |
|
5 1 2 3 4 5) |
390 |
|
|
391 |
|
(deftest subst.11 |
392 |
|
(let ((i 0) v w x y z) |
393 |
|
(values |
394 |
|
(subst (progn (setf v (incf i)) 'b) |
395 |
|
(progn (setf w (incf i)) 'a) |
396 |
|
(progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) |
397 |
|
:test-not (progn (setf y (incf i)) (complement #'eql)) |
398 |
|
:key (progn (setf z (incf i)) #'identity) |
399 |
|
) |
400 |
|
i v w x y z)) |
401 |
|
((10 b . b) b b c ((b)) z) |
402 |
|
5 1 2 3 4 5) |
403 |
|
|
404 |
|
|
405 |
|
|
406 |
;;; Keyword tests for subst |
;;; Keyword tests for subst |
407 |
|
|
408 |
(deftest subst.allow-other-keys.1 |
(deftest subst.allow-other-keys.1 |
433 |
|
|
434 |
;;; Tests for subst-if, subst-if-not |
;;; Tests for subst-if, subst-if-not |
435 |
|
|
436 |
(deftest subst-if-1 |
(deftest subst-if.1 |
437 |
(check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) |
(check-subst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) |
438 |
A) |
A) |
439 |
|
|
440 |
(deftest subst-if-not-1 |
(deftest subst-if-not.1 |
441 |
(check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) |
(check-subst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) |
442 |
((X) |
((X) |
443 |
((X) (X) X) |
((X) (X) X) |
444 |
((X) (X) (X) X) |
((X) (X) (X) X) |
445 |
((X) (X) (X) (X) X) |
((X) (X) (X) (X) X) |
446 |
X)) |
X)) |
447 |
|
|
448 |
(deftest subst-if-2 |
(deftest subst-if.2 |
449 |
(check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) |
(check-subst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) |
450 |
(17 (17 17) (17 17 17) (17 nil 17 17 17))) |
(17 (17 17) (17 17 17) (17 nil 17 17 17))) |
451 |
|
|
452 |
(deftest subst-if-3 |
(deftest subst-if.3 |
453 |
(check-subst-if '(z) |
(check-subst-if '(z) |
454 |
(complement #'consp) |
(complement #'consp) |
455 |
'(a (a b) (c d e) (f g h i))) |
'(a (a b) (c d e) (f g h i))) |
456 |
((Z) |
((Z) |
457 |
((Z) (Z) Z) |
((Z) (Z) Z) |
458 |
((Z) (Z) (Z) Z) |
((Z) (Z) (Z) Z) |
459 |
((Z) (Z) (Z) (Z) Z) |
((Z) (Z) (Z) (Z) Z) |
460 |
Z)) |
Z)) |
461 |
|
|
462 |
(deftest subst-if-not-2 |
(deftest subst-if-not.2 |
463 |
(check-subst-if-not 'a (complement #'listp) |
(check-subst-if-not 'a (complement #'listp) |
464 |
'((100 1) (2 3) (4 3 2 1) (a b c))) |
'((100 1) (2 3) (4 3 2 1) (a b c))) |
465 |
A) |
A) |
466 |
|
|
467 |
(deftest subst-if-4 |
(deftest subst-if.4 |
468 |
(check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) |
(check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) |
469 |
:key #'listp) |
:key #'listp) |
470 |
B) |
B) |
471 |
|
|
472 |
(deftest subst-if-not-3 |
(deftest subst-if-not.3 |
473 |
(check-subst-if-not 'c #'identity |
(check-subst-if-not 'c #'identity |
474 |
'((100 1) (2 3) (4 3 2 1) (a b c)) |
'((100 1) (2 3) (4 3 2 1) (a b c)) |
475 |
:key (complement #'listp)) |
:key (complement #'listp)) |
476 |
C) |
C) |
477 |
|
|
478 |
(deftest subst-if-5 |
(deftest subst-if.5 |
479 |
(check-subst-if 4 #'(lambda (x) (eql x 1)) |
(check-subst-if 4 #'(lambda (x) (eql x 1)) |
480 |
'((1 3) (1) (1 10 20 30) (1 3 x y)) |
'((1 3) (1) (1 10 20 30) (1 3 x y)) |
481 |
:key #'(lambda (x) |
:key #'(lambda (x) |
482 |
(and (consp x) |
(and (consp x) |
483 |
(car x)))) |
(car x)))) |
484 |
(4 4 4 4)) |
(4 4 4 4)) |
485 |
|
|
486 |
(deftest subst-if-not-4 |
(deftest subst-if-not.4 |
487 |
(check-subst-if-not |
(check-subst-if-not |
488 |
40 |
40 |
489 |
#'(lambda (x) (not (eql x 17))) |
#'(lambda (x) (not (eql x 17))) |
490 |
'((17) (17 22) (17 22 31) (17 21 34 54)) |
'((17) (17 22) (17 22 31) (17 21 34 54)) |
491 |
:key #'(lambda (x) |
:key #'(lambda (x) |
492 |
(and (consp x) |
(and (consp x) |
493 |
(car x)))) |
(car x)))) |
494 |
(40 40 40 40)) |
(40 40 40 40)) |
495 |
|
|
496 |
(deftest subst-if-6 |
(deftest subst-if.6 |
497 |
(check-subst-if 'a #'(lambda (x) (eql x 'b)) |
(check-subst-if 'a #'(lambda (x) (eql x 'b)) |
498 |
'((a) (b) (c) (d)) |
'((a) (b) (c) (d)) |
499 |
:key nil) |
:key nil) |
500 |
((a) (a) (c) (d))) |
((a) (a) (c) (d))) |
501 |
|
|
502 |
(deftest subst-if-not-5 |
(deftest subst-if-not.5 |
503 |
(check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) |
(check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) |
504 |
'((a) (b) (c) (d)) |
'((a) (b) (c) (d)) |
505 |
:key nil) |
:key nil) |
506 |
((a) (a) (c) (d))) |
((a) (a) (c) (d))) |
507 |
|
|
508 |
|
(deftest subst-if.7 |
509 |
|
(let ((i 0) w x y z) |
510 |
|
(values |
511 |
|
(subst-if |
512 |
|
(progn (setf w (incf i)) 'a) |
513 |
|
(progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) |
514 |
|
(progn (setf y (incf i)) (copy-list '(1 2 a b c))) |
515 |
|
:key (progn (setf z (incf i)) #'identity)) |
516 |
|
i w x y z)) |
517 |
|
(1 2 a a c) |
518 |
|
4 1 2 3 4) |
519 |
|
|
520 |
|
(deftest subst-if-not.7 |
521 |
|
(let ((i 0) w x y z) |
522 |
|
(values |
523 |
|
(subst-if-not |
524 |
|
(progn (setf w (incf i)) 'a) |
525 |
|
(progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) |
526 |
|
(progn (setf y (incf i)) (copy-list '(1 2 a b c))) |
527 |
|
:key (progn (setf z (incf i)) #'identity)) |
528 |
|
i w x y z)) |
529 |
|
(1 2 a a c) |
530 |
|
4 1 2 3 4) |
531 |
|
|
532 |
|
|
533 |
|
|
534 |
;;; Keyword tests for subst-if |
;;; Keyword tests for subst-if |
535 |
|
|
536 |
(deftest subst-if.allow-other-keys.1 |
(deftest subst-if.allow-other-keys.1 |
586 |
|
|
587 |
(defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) |
(defvar *nsubst-tree-1* '(10 (30 20 10) (20 10) (10 20 30 40))) |
588 |
|
|
589 |
(deftest nsubst-1 |
(deftest nsubst.1 |
590 |
(check-nsubst "Z" 30 (copy-tree *nsubst-tree-1*)) |
(check-nsubst "Z" 30 (copy-tree *nsubst-tree-1*)) |
591 |
(10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) |
(10 ("Z" 20 10) (20 10) (10 20 "Z" 40))) |
592 |
|
|
593 |
(deftest nsubst-2 |
(deftest nsubst.2 |
594 |
(check-nsubst "A" 0 (copy-tree *nsubst-tree-1*)) |
(check-nsubst "A" 0 (copy-tree *nsubst-tree-1*)) |
595 |
(10 (30 20 10) (20 10) (10 20 30 40))) |
(10 (30 20 10) (20 10) (10 20 30 40))) |
596 |
|
|
597 |
(deftest nsubst-3 |
(deftest nsubst.3 |
598 |
(check-nsubst "Z" 100 (copy-tree *nsubst-tree-1*) :test-not #'eql) |
(check-nsubst "Z" 100 (copy-tree *nsubst-tree-1*) :test-not #'eql) |
599 |
"Z") |
"Z") |
600 |
|
|
601 |
(deftest nsubst-4 |
(deftest nsubst.4 |
602 |
(check-nsubst 'grape 'dick |
(check-nsubst 'grape 'dick |
603 |
'(melville wrote (moby dick))) |
'(melville wrote (moby dick))) |
604 |
(MELVILLE WROTE (MOBY GRAPE))) |
(MELVILLE WROTE (MOBY GRAPE))) |
605 |
|
|
606 |
(deftest nsubst-5 |
(deftest nsubst.5 |
607 |
(check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick))) |
(check-nsubst 'cha-cha-cha 'nil '(melville wrote (moby dick))) |
608 |
(MELVILLE WROTE (MOBY DICK . CHA-CHA-CHA) . CHA-CHA-CHA)) |
(MELVILLE WROTE (MOBY DICK . CHA-CHA-CHA) . CHA-CHA-CHA)) |
609 |
|
|
610 |
(deftest nsubst-6 |
(deftest nsubst.6 |
611 |
(check-nsubst |
(check-nsubst |
612 |
'(1 2) '(foo . bar) |
'(1 2) '(foo . bar) |
613 |
'((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) |
'((foo . baz) (foo . bar) (bar . foo) (baz foo . bar)) |
614 |
:test #'equal) |
:test #'equal) |
615 |
((foo . baz) (1 2) (bar . foo) (baz 1 2))) |
((foo . baz) (1 2) (bar . foo) (baz 1 2))) |
616 |
|
|
617 |
(deftest nsubst-7 |
(deftest nsubst.7 |
618 |
(check-nsubst |
(check-nsubst |
619 |
'foo "aaa" |
'foo "aaa" |
620 |
'((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) |
'((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) |
621 |
:key #'(lambda (x) (if (and (numberp x) (evenp x)) |
:key #'(lambda (x) (if (and (numberp x) (evenp x)) |
622 |
"aaa" |
"aaa" |
623 |
nil)) |
nil)) |
624 |
:test #'string=) |
:test #'string=) |
625 |
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) |
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) |
626 |
|
|
627 |
(deftest nsubst-8 |
(deftest nsubst.8 |
628 |
(check-nsubst |
(check-nsubst |
629 |
'foo nil |
'foo nil |
630 |
'((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) |
'((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) |
631 |
:key #'(lambda (x) (if (and (numberp x) (evenp x)) |
:key #'(lambda (x) (if (and (numberp x) (evenp x)) |
632 |
(copy-seq "aaa") |
(copy-seq "aaa") |
633 |
nil)) |
nil)) |
634 |
:test-not #'equal) |
:test-not #'equal) |
635 |
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) |
((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) |
636 |
|
|
637 |
(deftest nsubst-9 |
(deftest nsubst.9 |
638 |
(check-nsubst 'a 'b |
(check-nsubst 'a 'b |
639 |
(copy-tree '(a b c d a b)) |
(copy-tree '(a b c d a b)) |
640 |
:key nil) |
:key nil) |
641 |
(a a c d a a)) |
(a a c d a a)) |
642 |
|
|
643 |
|
;;; Order of argument evaluation |
644 |
|
(deftest nsubst.10 |
645 |
|
(let ((i 0) v w x y z) |
646 |
|
(values |
647 |
|
(nsubst (progn (setf v (incf i)) 'b) |
648 |
|
(progn (setf w (incf i)) 'a) |
649 |
|
(progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) |
650 |
|
:key (progn (setf y (incf i)) #'identity) |
651 |
|
:test (progn (setf z (incf i)) #'eql)) |
652 |
|
i v w x y z)) |
653 |
|
((10 b . b) b b c ((b)) z) |
654 |
|
5 1 2 3 4 5) |
655 |
|
|
656 |
|
(deftest nsubst.11 |
657 |
|
(let ((i 0) v w x y z) |
658 |
|
(values |
659 |
|
(nsubst (progn (setf v (incf i)) 'b) |
660 |
|
(progn (setf w (incf i)) 'a) |
661 |
|
(progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) |
662 |
|
:test-not (progn (setf y (incf i)) (complement #'eql)) |
663 |
|
:key (progn (setf z (incf i)) #'identity) |
664 |
|
) |
665 |
|
i v w x y z)) |
666 |
|
((10 b . b) b b c ((b)) z) |
667 |
|
5 1 2 3 4 5) |
668 |
|
|
669 |
;;; Keyword tests for nsubst |
;;; Keyword tests for nsubst |
670 |
|
|
671 |
(deftest nsubst.allow-other-keys.1 |
(deftest nsubst.allow-other-keys.1 |
695 |
|
|
696 |
;;; Tests for nsubst-if, nsubst-if-not |
;;; Tests for nsubst-if, nsubst-if-not |
697 |
|
|
698 |
(deftest nsubst-if-1 |
(deftest nsubst-if.1 |
699 |
(check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) |
(check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c))) |
700 |
A) |
A) |
701 |
|
|
702 |
(deftest nsubst-if-not-1 |
(deftest nsubst-if-not.1 |
703 |
(check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) |
(check-nsubst-if-not '(x) 'consp '(1 (1 2) (1 2 3) (1 2 3 4))) |
704 |
((X) |
((X) |
705 |
((X) (X) X) |
((X) (X) X) |
706 |
((X) (X) (X) X) |
((X) (X) (X) X) |
707 |
((X) (X) (X) (X) X) |
((X) (X) (X) (X) X) |
708 |
X)) |
X)) |
709 |
|
|
710 |
(deftest nsubst-if-2 |
(deftest nsubst-if.2 |
711 |
(check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) |
(check-nsubst-if 17 (complement #'listp) '(a (a b) (a c d) (a nil e f g))) |
712 |
(17 (17 17) (17 17 17) (17 nil 17 17 17))) |
(17 (17 17) (17 17 17) (17 nil 17 17 17))) |
713 |
|
|
714 |
(deftest nsubst-if-3 |
(deftest nsubst-if.3 |
715 |
(check-nsubst-if '(z) |
(check-nsubst-if '(z) |
716 |
(complement #'consp) |
(complement #'consp) |
717 |
'(a (a b) (c d e) (f g h i))) |
'(a (a b) (c d e) (f g h i))) |
718 |
((Z) |
((Z) |
719 |
((Z) (Z) Z) |
((Z) (Z) Z) |
720 |
((Z) (Z) (Z) Z) |
((Z) (Z) (Z) Z) |
721 |
((Z) (Z) (Z) (Z) Z) |
((Z) (Z) (Z) (Z) Z) |
722 |
Z)) |
Z)) |
723 |
|
|
724 |
(deftest nsubst-if-not-2 |
(deftest nsubst-if-not.2 |
725 |
(check-nsubst-if-not 'a (complement #'listp) |
(check-nsubst-if-not 'a (complement #'listp) |
726 |
'((100 1) (2 3) (4 3 2 1) (a b c))) |
'((100 1) (2 3) (4 3 2 1) (a b c))) |
727 |
A) |
A) |
728 |
|
|
729 |
(deftest nsubst-if-4 |
(deftest nsubst-if.4 |
730 |
(check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) |
(check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) |
731 |
:key #'listp) |
:key #'listp) |
732 |
B) |
B) |
733 |
|
|
734 |
(deftest nsubst-if-not-3 |
(deftest nsubst-if-not.3 |
735 |
(check-nsubst-if-not 'c #'identity |
(check-nsubst-if-not 'c #'identity |
736 |
'((100 1) (2 3) (4 3 2 1) (a b c)) |
'((100 1) (2 3) (4 3 2 1) (a b c)) |
737 |
:key (complement #'listp)) |
:key (complement #'listp)) |
738 |
C) |
C) |
739 |
|
|
740 |
(deftest nsubst-if-5 |
(deftest nsubst-if.5 |
741 |
(check-nsubst-if 4 #'(lambda (x) (eql x 1)) |
(check-nsubst-if 4 #'(lambda (x) (eql x 1)) |
742 |
'((1 3) (1) (1 10 20 30) (1 3 x y)) |
'((1 3) (1) (1 10 20 30) (1 3 x y)) |
743 |
:key #'(lambda (x) |
:key #'(lambda (x) |
744 |
(and (consp x) |
(and (consp x) |
745 |
(car x)))) |
(car x)))) |
746 |
(4 4 4 4)) |
(4 4 4 4)) |
747 |
|
|
748 |
(deftest nsubst-if-not-4 |
(deftest nsubst-if-not.4 |
749 |
(check-nsubst-if-not |
(check-nsubst-if-not |
750 |
40 |
40 |
751 |
#'(lambda (x) (not (eql x 17))) |
#'(lambda (x) (not (eql x 17))) |
752 |
'((17) (17 22) (17 22 31) (17 21 34 54)) |
'((17) (17 22) (17 22 31) (17 21 34 54)) |
753 |
:key #'(lambda (x) |
:key #'(lambda (x) |
754 |
(and (consp x) |
(and (consp x) |
755 |
(car x)))) |
(car x)))) |
756 |
(40 40 40 40)) |
(40 40 40 40)) |
757 |
|
|
758 |
(deftest nsubst-if-6 |
(deftest nsubst-if.6 |
759 |
(check-nsubst-if 'a #'(lambda (x) (eql x 'b)) |
(check-nsubst-if 'a #'(lambda (x) (eql x 'b)) |
760 |
'((a) (b) (c) (d)) |
'((a) (b) (c) (d)) |
761 |
:key nil) |
:key nil) |
762 |
((a) (a) (c) (d))) |
((a) (a) (c) (d))) |
763 |
|
|
764 |
(deftest nsubst-if-not-5 |
(deftest nsubst-if-not.5 |
765 |
(check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) |
(check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) |
766 |
'((a) (b) (c) (d)) |
'((a) (b) (c) (d)) |
767 |
:key nil) |
:key nil) |
768 |
((a) (a) (c) (d))) |
((a) (a) (c) (d))) |
769 |
|
|
770 |
(deftest nsubst-if-7 |
(deftest nsubst-if.7 |
771 |
(nsubst-if 'a #'null nil :bad t :allow-other-keys t) |
(nsubst-if 'a #'null nil :bad t :allow-other-keys t) |
772 |
a) |
a) |
773 |
|
|
774 |
(deftest nsubst-if-not-6 |
(deftest nsubst-if-not.6 |
775 |
(nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) |
(nsubst-if-not 'a #'null nil :bad t :allow-other-keys t) |
776 |
nil) |
nil) |
777 |
|
|
778 |
|
(deftest nsubst-if.8 |
779 |
|
(let ((i 0) w x y z) |
780 |
|
(values |
781 |
|
(nsubst-if |
782 |
|
(progn (setf w (incf i)) 'a) |
783 |
|
(progn (setf x (incf i)) #'(lambda (x) (eql x 'b))) |
784 |
|
(progn (setf y (incf i)) (copy-list '(1 2 a b c))) |
785 |
|
:key (progn (setf z (incf i)) #'identity)) |
786 |
|
i w x y z)) |
787 |
|
(1 2 a a c) |
788 |
|
4 1 2 3 4) |
789 |
|
|
790 |
|
(deftest nsubst-if-not.7 |
791 |
|
(let ((i 0) w x y z) |
792 |
|
(values |
793 |
|
(nsubst-if-not |
794 |
|
(progn (setf w (incf i)) 'a) |
795 |
|
(progn (setf x (incf i)) #'(lambda (x) (not (eql x 'b)))) |
796 |
|
(progn (setf y (incf i)) (copy-list '(1 2 a b c))) |
797 |
|
:key (progn (setf z (incf i)) #'identity)) |
798 |
|
i w x y z)) |
799 |
|
(1 2 a a c) |
800 |
|
4 1 2 3 4) |
801 |
|
|
802 |
;;; Keyword tests for nsubst-if |
;;; Keyword tests for nsubst-if |
803 |
|
|
804 |
(deftest nsubst-if.allow-other-keys.1 |
(deftest nsubst-if.allow-other-keys.1 |