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

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

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

revision 1.7 by pfdietz, Wed Jan 29 02:11:54 2003 UTC revision 1.8 by pfdietz, Sat Feb 8 06:23:02 2003 UTC
# Line 10  Line 10 
10  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11  ;;; ldiff, tailp  ;;; ldiff, tailp
12    
13  (deftest ldiff-1  (deftest ldiff.1
14      (let* ((x (copy-tree '(a b c d e f)))    (let* ((x (copy-tree '(a b c d e f)))
15             (xcopy (make-scaffold-copy x)))           (xcopy (make-scaffold-copy x)))
16        (let ((result (ldiff x (cdddr x))))      (let ((result (ldiff x (cdddr x))))
17          (and (check-scaffold-copy x xcopy)        (and (check-scaffold-copy x xcopy)
18               result)))             result)))
19    (a b c))    (a b c))
20    
21  (deftest ldiff-2  (deftest ldiff.2
22    (let* ((x (copy-tree '(a b c d e f)))    (let* ((x (copy-tree '(a b c d e f)))
23           (xcopy (make-scaffold-copy x)))           (xcopy (make-scaffold-copy x)))
24      (let ((result (ldiff x 'a)))      (let ((result (ldiff x 'a)))
# Line 32  Line 32 
32    (a b c d e f))    (a b c d e f))
33    
34  ;; Works when the end of the dotted list is a symbol  ;; Works when the end of the dotted list is a symbol
35  (deftest ldiff-3  (deftest ldiff.3
36      (let* ((x (copy-tree '(a b c d e . f)))    (let* ((x (copy-tree '(a b c d e . f)))
37             (xcopy (make-scaffold-copy x)))           (xcopy (make-scaffold-copy x)))
38        (let ((result (ldiff x 'a)))      (let ((result (ldiff x 'a)))
39          (and        (and
40           (check-scaffold-copy x xcopy)         (check-scaffold-copy x xcopy)
41           result)))         result)))
42    (a b c d e . f))    (a b c d e . f))
43    
44  ;; Works when the end of the dotted list is a fixnum  ;; Works when the end of the dotted list is a fixnum
45  (deftest ldiff-4  (deftest ldiff.4
46    (let* ((n 18)    (let* ((n 18)
47           (x (list* 'a 'b 'c 18))           (x (list* 'a 'b 'c 18))
48           (xcopy (make-scaffold-copy x)))           (xcopy (make-scaffold-copy x)))
# Line 54  Line 54 
54    
55  ;; Works when the end of the dotted list is a larger  ;; Works when the end of the dotted list is a larger
56  ;; integer (that is eql, but probably not eq).  ;; integer (that is eql, but probably not eq).
57  (deftest ldiff-5  (deftest ldiff.5
58    (let* ((n 18000000000000)    (let* ((n 18000000000000)
59           (x (list* 'a 'b 'c (1- 18000000000001)))           (x (list* 'a 'b 'c (1- 18000000000001)))
60           (xcopy (make-scaffold-copy x)))           (xcopy (make-scaffold-copy x)))
# Line 65  Line 65 
65    (a b c))    (a b c))
66    
67  ;; Test works when the end of a dotted list is a string  ;; Test works when the end of a dotted list is a string
68  (deftest ldiff-6  (deftest ldiff.6
69    (let* ((n (copy-seq "abcde"))    (let* ((n (copy-seq "abcde"))
70           (x (list* 'a 'b 'c n))           (x (list* 'a 'b 'c n))
71           (xcopy (make-scaffold-copy x)))           (xcopy (make-scaffold-copy x)))
# Line 77  Line 77 
77    
78  ;; Check that having the cdr of a dotted list be string-equal, but  ;; Check that having the cdr of a dotted list be string-equal, but
79  ;; not eql, does not result in success  ;; not eql, does not result in success
80  (deftest ldiff-6b  (deftest ldiff.7
81    (let* ((n (copy-seq "abcde"))    (let* ((n (copy-seq "abcde"))
82           (x (list* 'a 'b 'c n))           (x (list* 'a 'b 'c n))
83           (xcopy (make-scaffold-copy x)))           (xcopy (make-scaffold-copy x)))
# Line 90  Line 90 
90  ;; Check that on failure, the list returned by ldiff is  ;; Check that on failure, the list returned by ldiff is
91  ;; a copy of the list, not the list itself.  ;; a copy of the list, not the list itself.
92    
93  (deftest ldiff-6a  (deftest ldiff.8
94      (let ((x (list 'a 'b 'c 'd)))    (let ((x (list 'a 'b 'c 'd)))
95        (let ((result (ldiff x '(e))))      (let ((result (ldiff x '(e))))
96          (and (equal x result)        (and (equal x result)
97               (loop             (loop
98                   for c1 on x              for c1 on x
99                   for c2 on result              for c2 on result
100                   count (eqt c1 c2)))))              count (eqt c1 c2)))))
101    0)    0)
102                  
103    (deftest ldiff.9
104      (let ((i 0) x y)
105        (values
106         (ldiff (progn (setf x (incf i))
107                       (list* 'a 'b 'c 'd))
108                (progn (setf y (incf i))
109                       'd))
110         i x y))
111      (a b c) 2 1 2)              
112    
113  ;; Error checking  ;; Error checking
114    
# Line 148  Line 157 
157  ;;  ;;
158  #|  #|
159  (defun ldiff-12-body ()  (defun ldiff-12-body ()
160      (loop    (loop
161          for x in *universe*     for x in *universe*
162          count (and (not (listp x))     count (and (not (listp x))
163                     (not (eqt 'type-error                (not (eqt 'type-error
164                              (catch-type-error (ldiff x x)))))))                          (catch-type-error (ldiff x x)))))))
165    
166  (deftest ldiff-12  (deftest ldiff-12
167      (ldiff-12-body)      (ldiff-12-body)
# Line 162  Line 171 
171  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
172  ;;; tailp  ;;; tailp
173    
174  (deftest tailp-1  (deftest tailp.1
175      (let ((x (copy-tree '(a b c d e . f))))    (let ((x (copy-tree '(a b c d e . f))))
176        (and      (and
177         (tailp x x)       (tailp x x)
178         (tailp (cdr x) x)       (tailp (cdr x) x)
179         (tailp (cddr x) x)       (tailp (cddr x) x)
180         (tailp (cdddr x) x)       (tailp (cdddr x) x)
181         (tailp (cddddr x) x)       (tailp (cddddr x) x)
182         t))       t))
183    t)    t)
184    
185    
186  ;; The next four tests test that tailp handles dotted lists.  See  ;; The next four tests test that tailp handles dotted lists.  See
187  ;; TAILP-NIL:T in the X3J13 documentation.  ;; TAILP-NIL:T in the X3J13 documentation.
188    
189  (deftest tailp-2  (deftest tailp.2
190    (notnot-mv (tailp 'e (copy-tree '(a b c d . e))))    (notnot-mv (tailp 'e (copy-tree '(a b c d . e))))
191    t)    t)
192    
193  (deftest tailp-3  (deftest tailp.3
194    (tailp 'z (copy-tree '(a b c d . e)))    (tailp 'z (copy-tree '(a b c d . e)))
195    nil)    nil)
196    
197  (deftest tailp-4  (deftest tailp.4
198    (notnot-mv (tailp 10203040506070    (notnot-mv (tailp 10203040506070
199                      (list* 'a 'b (1- 10203040506071))))                      (list* 'a 'b (1- 10203040506071))))
200    t)    t)
201    
202  (deftest tailp-5  (deftest tailp.5
203    (let ((x "abcde")) (tailp x (list* 'a 'b (copy-seq x))))    (let ((x "abcde")) (tailp x (list* 'a 'b (copy-seq x))))
204    nil)    nil)
205    
# Line 208  Line 217 
217    
218  ;; Test that tailp does not modify its arguments  ;; Test that tailp does not modify its arguments
219    
220  (deftest tailp-6  (deftest tailp.6
221      (let* ((x (copy-list '(a b c d e)))      (let* ((x (copy-list '(a b c d e)))
222             (y (cddr x)))             (y (cddr x)))
223        (let ((xcopy (make-scaffold-copy x))        (let ((xcopy (make-scaffold-copy x))
# Line 230  Line 239 
239  ;;  ;;
240    
241  #|  #|
242  (defun tailp-7-body ()  (defun tailp.7-body ()
243    (loop    (loop
244        for x in *universe*        for x in *universe*
245        count (and (not (listp x))        count (and (not (listp x))
246                   (eqt 'type-error                   (eqt 'type-error
247                       (catch-type-error (tailp x x))))))                       (catch-type-error (tailp x x))))))
248    
249  (deftest tailp-7  (deftest tailp.7
250      (tailp-7-body)      (tailp.7-body)
251    0)    0)
252  |#  |#
253            
254    (deftest tailp.8
255      (let ((i 0) x y)
256        (values
257         (notnot
258          (tailp (progn (setf x (incf i)) 'd)
259                 (progn (setf y (incf i)) '(a b c . d))))
260         i x y))
261      t 2 1 2)
262    

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