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

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

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

revision 1.6 by pfdietz, Fri Jan 17 13:29:23 2003 UTC revision 1.7 by pfdietz, Mon Feb 10 00:05:26 2003 UTC
# Line 10  Line 10 
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)
# Line 59  Line 69 
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)))
# Line 92  Line 102 
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))
# Line 179  Line 189 
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)
# Line 194  Line 204 
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
# Line 253  Line 301 
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)))
# Line 263  Line 311 
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+)))
# Line 273  Line 321 
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)))
# Line 283  Line 331 
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
# Line 348  Line 417 
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)))
# Line 358  Line 427 
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+)))
# Line 368  Line 437 
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)))
# Line 378  Line 447 
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

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