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))) |
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))) |
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))) |
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))) |
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))) |
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 |
|
|
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) |
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 |
|
|
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)) |
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 |
|
|