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

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

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

revision 1.6 by pfdietz, Sat Jan 18 12:49:35 2003 UTC revision 1.7 by pfdietz, Mon Feb 10 00:05:26 2003 UTC
# Line 18  Line 18 
18  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19  ;;; rassoc  ;;; rassoc
20    
21  (deftest rassoc-1  (deftest rassoc.1
22      (rassoc nil nil)    (rassoc nil nil)
23    nil)    nil)
24    
25  (deftest rassoc-2  (deftest rassoc.2
26      (rassoc nil '(nil))    (rassoc nil '(nil))
27    nil)    nil)
28    
29  (deftest rassoc-3  (deftest rassoc.3
30      (rassoc nil (rev-assoc-list '(nil (nil . 2) (a . b))))    (rassoc nil (rev-assoc-list '(nil (nil . 2) (a . b))))
31    (2 . nil))    (2 . nil))
32    
33  (deftest rassoc-4  (deftest rassoc.4
34      (rassoc nil '((a . b) (c . d)))    (rassoc nil '((a . b) (c . d)))
35    nil)    nil)
36    
37  (deftest rassoc-5  (deftest rassoc.5
38      (rassoc 'a '((b . a)))    (rassoc 'a '((b . a)))
39    (b . a))    (b . a))
40    
41  (deftest rassoc-6  (deftest rassoc.6
42      (rassoc 'a (rev-assoc-list '((:a . b) (#:a . c) (a . d) (a . e) (z . f))))    (rassoc 'a (rev-assoc-list '((:a . b) (#:a . c) (a . d) (a . e) (z . f))))
43    (d . a))    (d . a))
44    
45  (deftest rassoc-7  (deftest rassoc.7
46      (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d)))))    (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d)))))
47             (xcopy (make-scaffold-copy x))           (xcopy (make-scaffold-copy x))
48             (result (rassoc 'b x)))           (result (rassoc 'b x)))
49        (and      (and
50         (eqt result (second x))       (eqt result (second x))
51         (check-scaffold-copy x xcopy)))       (check-scaffold-copy x xcopy)))
52    t)    t)
53    
54  (deftest rassoc-8  (deftest rassoc.8
55      (rassoc 1 (rev-assoc-list '((0 . a) (1 . b) (2 . c))))    (rassoc 1 (rev-assoc-list '((0 . a) (1 . b) (2 . c))))
56    (b . 1))    (b . 1))
57    
58  (deftest rassoc-9  (deftest rassoc.9
59      (rassoc (copy-seq "abc")    (rassoc (copy-seq "abc")
60             (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3))))            (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3))))
61    nil)    nil)
62    
63  (deftest rassoc-10  (deftest rassoc.10
64      (rassoc (copy-list '(a))    (rassoc (copy-list '(a))
65              (copy-tree (rev-assoc-list '(((a) b) ((a) (c))))))            (copy-tree (rev-assoc-list '(((a) b) ((a) (c))))))
66    nil)    nil)
67    
68  (deftest rassoc-11  (deftest rassoc.11
69      (let ((x (list 'a 'b)))    (let ((x (list 'a 'b)))
70        (rassoc x      (rassoc x
71                 (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1)))))              (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1)))))
72    (d a b))    (d a b))
73    
74    
75  (deftest rassoc-12  (deftest rassoc.12
76      (rassoc #\e    (rassoc #\e
77              (copy-tree            (copy-tree
78               (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3))))             (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3))))
79             :key #'(lambda (x) (char x 1)))            :key #'(lambda (x) (char x 1)))
80    (2 . "aevgd"))    (2 . "aevgd"))
81    
82  (deftest rassoc-13  (deftest rassoc.13
83      (rassoc nil    (rassoc nil
84              (copy-tree            (copy-tree
85               (rev-assoc-list             (rev-assoc-list
86                '(((a) . b) ( nil . c ) ((nil) . d))))              '(((a) . b) ( nil . c ) ((nil) . d))))
87             :key #'car)            :key #'car)
88    (c))    (c))
89    
90  (deftest rassoc-14  (deftest rassoc.14
91      (rassoc (copy-seq "abc")    (rassoc (copy-seq "abc")
92              (copy-tree            (copy-tree
93               (rev-assoc-list             (rev-assoc-list
94                '((abc . 1) ("abc" . 2) ("abc" . 3))))              '((abc . 1) ("abc" . 2) ("abc" . 3))))
95             :test #'equal)            :test #'equal)
96    (2 . "abc"))    (2 . "abc"))
97    
98  (deftest rassoc-15  (deftest rassoc.15
99      (rassoc (copy-seq "abc")    (rassoc (copy-seq "abc")
100              (copy-tree            (copy-tree
101               (rev-assoc-list             (rev-assoc-list
102                '((abc . 1) ("abc" . 2) ("abc" . 3))))              '((abc . 1) ("abc" . 2) ("abc" . 3))))
103             :test #'equalp)            :test #'equalp)
104    (2 . "abc"))    (2 . "abc"))
105    
106  (deftest rassoc-16  (deftest rassoc.16
107      (rassoc (copy-list '(a))    (rassoc (copy-list '(a))
108              (copy-tree            (copy-tree
109               (rev-assoc-list '(((a) b) ((a) (c)))))             (rev-assoc-list '(((a) b) ((a) (c)))))
110             :test #'equal)            :test #'equal)
111    ((b) a))    ((b) a))
112    
113  (deftest rassoc-17  (deftest rassoc.17
114      (rassoc (copy-seq "abc")    (rassoc (copy-seq "abc")
115              (copy-tree            (copy-tree
116               (rev-assoc-list             (rev-assoc-list
117                '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3))))              '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3))))
118             :test-not (complement #'equalp))            :test-not (complement #'equalp))
119    (2 . "abc"))    (2 . "abc"))
120    
121  (deftest rassoc-18  (deftest rassoc.18
122      (rassoc 'a    (rassoc 'a
123              (copy-tree            (copy-tree
124               (rev-assoc-list             (rev-assoc-list
125                '((a . d)(b . c))))              '((a . d)(b . c))))
126              :test-not #'eq)            :test-not #'eq)
127    (c . b))    (c . b))
128        
129  (deftest rassoc-19  (deftest rassoc.19
130      (rassoc 'a    (rassoc 'a
131              (copy-tree            (copy-tree
132               (rev-assoc-list             (rev-assoc-list
133                '((a . d)(b . c))))              '((a . d)(b . c))))
134              :test (complement #'eq))            :test (complement #'eq))
135    (c . b))    (c . b))
136    
137  (deftest rassoc-20  (deftest rassoc.20
138      (rassoc "a"    (rassoc "a"
139              (copy-tree            (copy-tree
140               (rev-assoc-list             (rev-assoc-list
141                '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))))              '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))))
142             :key #'(lambda (x) (and (stringp x) (string-downcase x)))            :key #'(lambda (x) (and (stringp x) (string-downcase x)))
143             :test #'equal)            :test #'equal)
144    (6 . "A"))    (6 . "A"))
145    
146  (deftest rassoc-21  (deftest rassoc.21
147      (rassoc "a"    (rassoc "a"
148              (copy-tree            (copy-tree
149               (rev-assoc-list             (rev-assoc-list
150                '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))))              '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))))
151             :key #'(lambda (x) (and (stringp x) x))            :key #'(lambda (x) (and (stringp x) x))
152             :test #'equal)            :test #'equal)
153    (3 . "a"))    (3 . "a"))
154    
155  (deftest rassoc-22  (deftest rassoc.22
156      (rassoc "a"    (rassoc "a"
157              (copy-tree            (copy-tree
158               (rev-assoc-list             (rev-assoc-list
159                '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))))              '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))))
160             :key #'(lambda (x) (and (stringp x) (string-downcase x)))            :key #'(lambda (x) (and (stringp x) (string-downcase x)))
161             :test-not (complement #'equal))            :test-not (complement #'equal))
162    (6 . "A"))    (6 . "A"))
163    
164  (deftest rassoc-23  (deftest rassoc.23
165      (rassoc "a"    (rassoc "a"
166              (copy-tree            (copy-tree
167               (rev-assoc-list             (rev-assoc-list
168                '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))))              '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5))))
169             :key #'(lambda (x) (and (stringp x) x))            :key #'(lambda (x) (and (stringp x) x))
170             :test-not (complement #'equal))            :test-not (complement #'equal))
171    (3 . "a"))    (3 . "a"))
172    
173  ;; Check that it works when test returns a true value  ;; Check that it works when test returns a true value
174  ;; other than T  ;; other than T
175    
176  (deftest rassoc-24  (deftest rassoc.24
177      (rassoc 'a    (rassoc 'a
178              (copy-tree            (copy-tree
179               (rev-assoc-list             (rev-assoc-list
180                '((b . 1) (a . 2) (c . 3))))              '((b . 1) (a . 2) (c . 3))))
181             :test #'(lambda (x y) (and (eqt x y) 'matched)))            :test #'(lambda (x y) (and (eqt x y) 'matched)))
182    (2 . a))    (2 . a))
183    
184  ;; Check that the order of the arguments to :test is correct  ;; Check that the order of the arguments to :test is correct
185    
186  (deftest rassoc-25  (deftest rassoc.25
187      (block fail    (block fail
188        (rassoc 'a '((1 . b) (2 . c) (3 . a))      (rassoc 'a '((1 . b) (2 . c) (3 . a))
189               :test #'(lambda (x y)              :test #'(lambda (x y)
190                         (unless (eqt x 'a) (return-from fail 'fail))                        (unless (eqt x 'a) (return-from fail 'fail))
191                         (eqt x y))))                        (eqt x y))))
192    (3 . A))    (3 . A))
193    
194    ;;; Order of argument evaluation
195    
196    (deftest rassoc.26
197      (let ((i 0) x y)
198        (values
199         (rassoc (progn (setf x (incf i)) 'c)
200                 (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))))
201         i x y))
202      (3 . c) 2 1 2)
203    
204    (deftest rassoc.27
205      (let ((i 0) x y z)
206        (values
207         (rassoc (progn (setf x (incf i)) 'c)
208                 (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))
209                 :test (progn (setf z (incf i)) #'eq))
210         i x y z))
211      (3 . c) 3 1 2 3)
212    
213    (deftest rassoc.28
214      (let ((i 0) x y)
215        (values
216         (rassoc (progn (setf x (incf i)) 'c)
217                (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))
218                :test #'eq)
219         i x y))
220      (3 . c) 2 1 2)
221    
222    (deftest rassoc.29
223      (let ((i 0) x y z w)
224        (values
225         (rassoc (progn (setf x (incf i)) 'c)
226                (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))
227                :key (progn (setf z (incf i)) #'identity)
228                :key (progn (setf w (incf i)) #'not))
229         i x y z w))
230      (3 . c) 4 1 2 3 4)
231    
232  ;;; Keyword tests  ;;; Keyword tests
233    
234  (deftest rassoc.allow-other-keys.1  (deftest rassoc.allow-other-keys.1
# Line 249  Line 287 
287  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
288  ;;; rassoc-if  ;;; rassoc-if
289    
290  (deftest rassoc-if-1  (deftest rassoc-if.1
291      (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))      (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))
292             (xcopy (make-scaffold-copy x))             (xcopy (make-scaffold-copy x))
293             (result (rassoc-if #'evenp x)))             (result (rassoc-if #'evenp x)))
# Line 259  Line 297 
297         result))         result))
298    (c . 6))    (c . 6))
299    
300  (deftest rassoc-if-2  (deftest rassoc-if.2
301    (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))    (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))
302           (xcopy (make-scaffold-copy x))           (xcopy (make-scaffold-copy x))
303           (result (rassoc-if #'oddp x :key #'1+)))           (result (rassoc-if #'oddp x :key #'1+)))
# Line 269  Line 307 
307       result))       result))
308    (c . 6))    (c . 6))
309    
310  (deftest rassoc-if-3  (deftest rassoc-if.3
311      (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d))))      (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d))))
312             (xcopy (make-scaffold-copy x))             (xcopy (make-scaffold-copy x))
313             (result (rassoc-if #'evenp x)))             (result (rassoc-if #'evenp x)))
# Line 279  Line 317 
317         result))         result))
318    (c . 6))    (c . 6))
319    
320  (deftest rassoc-if-4  (deftest rassoc-if.4
321      (rassoc-if #'null      (rassoc-if #'null
322                 (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g))))                 (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g))))
323    (e))    (e))
324    
325    ;;; Order of argument evaluation
326    
327    (deftest rassoc-if.5
328      (let ((i 0) x y)
329        (values
330         (rassoc-if (progn (setf x (incf i)) #'null)
331                    (progn (setf y (incf i))
332                           '((1 . a) (2 . b) (17) (4 . d))))
333         i x y))
334      (17) 2 1 2)
335    
336    (deftest rassoc-if.6
337      (let ((i 0) x y z)
338        (values
339         (rassoc-if (progn (setf x (incf i)) #'null)
340                    (progn (setf y (incf i))
341                           '((1 . a) (2 . b) (17) (4 . d)))
342                    :key (progn (setf z (incf i)) #'null))
343         i x y z))
344      (1 . a) 3 1 2 3)
345    
346    
347  ;;; Keyword tests  ;;; Keyword tests
348    
349  (deftest rassoc-if.allow-other-keys.1  (deftest rassoc-if.allow-other-keys.1
# Line 340  Line 400 
400  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
401  ;;; rassoc-if-not  ;;; rassoc-if-not
402    
403  (deftest rassoc-if-not-1  (deftest rassoc-if-not.1
404      (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))      (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))
405             (xcopy (make-scaffold-copy x))             (xcopy (make-scaffold-copy x))
406             (result (rassoc-if-not #'oddp x)))             (result (rassoc-if-not #'oddp x)))
# Line 350  Line 410 
410         result))         result))
411    (c . 6))    (c . 6))
412    
413  (deftest rassoc-if-not-2  (deftest rassoc-if-not.2
414    (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))    (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d))))
415           (xcopy (make-scaffold-copy x))           (xcopy (make-scaffold-copy x))
416           (result (rassoc-if-not #'evenp x :key #'1+)))           (result (rassoc-if-not #'evenp x :key #'1+)))
# Line 360  Line 420 
420       result))       result))
421    (c . 6))    (c . 6))
422    
423  (deftest rassoc-if-not-3  (deftest rassoc-if-not.3
424      (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d))))      (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d))))
425             (xcopy (make-scaffold-copy x))             (xcopy (make-scaffold-copy x))
426             (result (rassoc-if-not #'oddp x)))             (result (rassoc-if-not #'oddp x)))
# Line 370  Line 430 
430         result))         result))
431    (c . 6))    (c . 6))
432    
433  (deftest rassoc-if-not-4  (deftest rassoc-if-not.4
434      (rassoc-if-not #'identity      (rassoc-if-not #'identity
435                     (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g))))                     (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g))))
436    (e))    (e))
437    
438    ;;; Order of argument evaluation
439    
440    (deftest rassoc-if-not.5
441      (let ((i 0) x y)
442        (values
443         (rassoc-if-not (progn (setf x (incf i)) #'identity)
444                        (progn (setf y (incf i))
445                               '((1 . a) (2 . b) (17) (4 . d))))
446         i x y))
447      (17) 2 1 2)
448    
449    (deftest rassoc-if-not.6
450      (let ((i 0) x y z)
451        (values
452         (rassoc-if-not (progn (setf x (incf i)) #'identity)
453                        (progn (setf y (incf i))
454                               '((1 . a) (2 . b) (17) (4 . d)))
455                        :key (progn (setf z (incf i)) #'null))
456         i x y z))
457      (1 . a) 3 1 2 3)
458    
459  ;;; Keyword tests  ;;; Keyword tests
460    
461  (deftest rassoc-if-not.allow-other-keys.1  (deftest rassoc-if-not.allow-other-keys.1

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

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