/[gcl]/gcl/ansi-tests/cons-test-02.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/cons-test-02.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by pfdietz, Fri Jan 17 13:29:23 2003 UTC revision 1.8 by pfdietz, Sat Feb 8 06:23:02 2003 UTC
# Line 12  Line 12 
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
# Line 37  Line 37 
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
# Line 143  Line 174 
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
# Line 252  Line 313 
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)))
# Line 298  Line 359 
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)))
# Line 308  Line 369 
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
# Line 344  Line 433 
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
# Line 471  Line 586 
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
# Line 554  Line 695 
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

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26