177 |
;; For everything in *universe*, it is either an atom, or satisfies |
;; For everything in *universe*, it is either an atom, or satisfies |
178 |
;; consp, but not both |
;; consp, but not both |
179 |
(deftest consp-xor-atom-universe |
(deftest consp-xor-atom-universe |
180 |
(not (not |
(notnot |
181 |
(every #'(lambda (x) (or (and (consp x) (not (atom x))) |
(every #'(lambda (x) (or (and (consp x) (not (atom x))) |
182 |
(and (not (consp x)) (atom x)))) |
(and (not (consp x)) (atom x)))) |
183 |
*universe*))) |
*universe*)) |
184 |
t) |
t) |
185 |
|
|
186 |
;; Everything in type cons satisfies consp, and vice versa |
;; Everything in type cons satisfies consp, and vice versa |
190 |
|
|
191 |
;; Tests of car, cdr and compound forms |
;; Tests of car, cdr and compound forms |
192 |
(deftest cons-23 |
(deftest cons-23 |
193 |
(car '(a)) |
(car '(a)) |
194 |
a) |
a) |
195 |
|
|
196 |
(deftest cons-24 |
(deftest cons-24 |
197 |
(cdr '(a . b)) |
(cdr '(a . b)) |
198 |
b) |
b) |
199 |
|
|
200 |
(deftest cons-25 |
(deftest cons-25 |
201 |
(caar '((a))) |
(caar '((a))) |
202 |
a) |
a) |
203 |
|
|
204 |
(deftest cons-26 |
(deftest cons-26 |
205 |
(cdar '((a . b))) |
(cdar '((a . b))) |
206 |
b) |
b) |
207 |
|
|
208 |
(deftest cons-27 |
(deftest cons-27 |
209 |
(cadr '(a b)) |
(cadr '(a b)) |
210 |
b) |
b) |
211 |
|
|
212 |
(deftest cons-28 |
(deftest cons-28 |
213 |
(cddr '(a b . c)) |
(cddr '(a b . c)) |
214 |
c) |
c) |
215 |
|
|
216 |
(deftest cons-29 |
(deftest cons-29 |
217 |
(caaar '(((a)))) |
(caaar '(((a)))) |
218 |
a) |
a) |
219 |
|
|
220 |
(deftest cons-30 |
(deftest cons-30 |
221 |
(cdaar '(((a . b)))) |
(cdaar '(((a . b)))) |
222 |
b) |
b) |
223 |
|
|
224 |
(deftest cons-31 |
(deftest cons-31 |
225 |
(cadar (cons (cons 'a (cons 'b 'c)) 'd)) |
(cadar (cons (cons 'a (cons 'b 'c)) 'd)) |
226 |
b) |
b) |
227 |
|
|
228 |
(deftest cons-32 |
(deftest cons-32 |
229 |
(cddar (cons (cons 'a (cons 'b 'c)) 'd)) |
(cddar (cons (cons 'a (cons 'b 'c)) 'd)) |
230 |
c) |
c) |
231 |
|
|
232 |
(deftest cons-33 |
(deftest cons-33 |
233 |
(caadr (cons 'a (cons (cons 'b 'c) 'd))) |
(caadr (cons 'a (cons (cons 'b 'c) 'd))) |
234 |
b) |
b) |
235 |
|
|
236 |
(deftest cons-34 |
(deftest cons-34 |
237 |
(caddr (cons 'a (cons 'b (cons 'c 'd)))) |
(caddr (cons 'a (cons 'b (cons 'c 'd)))) |
238 |
c) |
c) |
239 |
|
|
240 |
(deftest cons-36 |
(deftest cons-36 |
241 |
(cdadr (cons 'a (cons (cons 'b 'c) 'd))) |
(cdadr (cons 'a (cons (cons 'b 'c) 'd))) |
242 |
c) |
c) |
243 |
|
|
244 |
(deftest cons-37 |
(deftest cons-37 |
245 |
(cdddr (cons 'a (cons 'b (cons 'c 'd)))) |
(cdddr (cons 'a (cons 'b (cons 'c 'd)))) |
246 |
d) |
d) |
247 |
|
|
248 |
(defvar *cons-test-4* |
(defvar *cons-test-4* |
249 |
(cons (cons (cons (cons 'a 'b) |
(cons (cons (cons (cons 'a 'b) |
250 |
(cons 'c 'd)) |
(cons 'c 'd)) |
251 |
(cons (cons 'e 'f) |
(cons (cons 'e 'f) |
252 |
(cons 'g 'h))) |
(cons 'g 'h))) |
253 |
(cons (cons (cons 'i 'j) |
(cons (cons (cons 'i 'j) |
254 |
(cons 'k 'l)) |
(cons 'k 'l)) |
255 |
(cons (cons 'm 'n) |
(cons (cons 'm 'n) |
256 |
(cons 'o 'p))))) |
(cons 'o 'p))))) |
257 |
|
|
258 |
|
|
259 |
(deftest cons-38 |
(deftest cons-38 |
260 |
(caaaar *cons-test-4*) |
(caaaar *cons-test-4*) |
261 |
a) |
a) |
262 |
|
|
263 |
(deftest cons-39 |
(deftest cons-39 |
264 |
(cdaaar *cons-test-4*) |
(cdaaar *cons-test-4*) |
265 |
b) |
b) |
266 |
|
|
267 |
(deftest cons-40 |
(deftest cons-40 |
268 |
(cadaar *cons-test-4*) |
(cadaar *cons-test-4*) |
269 |
c) |
c) |
270 |
|
|
271 |
(deftest cons-41 |
(deftest cons-41 |
272 |
(cddaar *cons-test-4*) |
(cddaar *cons-test-4*) |
273 |
d) |
d) |
274 |
|
|
275 |
(deftest cons-42 |
(deftest cons-42 |
276 |
(caadar *cons-test-4*) |
(caadar *cons-test-4*) |
277 |
e) |
e) |
278 |
|
|
279 |
(deftest cons-43 |
(deftest cons-43 |
280 |
(cdadar *cons-test-4*) |
(cdadar *cons-test-4*) |
281 |
f) |
f) |
282 |
|
|
283 |
(deftest cons-44 |
(deftest cons-44 |
284 |
(caddar *cons-test-4*) |
(caddar *cons-test-4*) |
285 |
g) |
g) |
286 |
|
|
287 |
(deftest cons-45 |
(deftest cons-45 |
288 |
(cdddar *cons-test-4*) |
(cdddar *cons-test-4*) |
289 |
h) |
h) |
290 |
|
|
291 |
;;; |
;;; |
292 |
|
|
293 |
(deftest cons-46 |
(deftest cons-46 |
294 |
(caaadr *cons-test-4*) |
(caaadr *cons-test-4*) |
295 |
i) |
i) |
296 |
|
|
297 |
(deftest cons-47 |
(deftest cons-47 |
298 |
(cdaadr *cons-test-4*) |
(cdaadr *cons-test-4*) |
299 |
j) |
j) |
300 |
|
|
301 |
(deftest cons-48 |
(deftest cons-48 |
302 |
(cadadr *cons-test-4*) |
(cadadr *cons-test-4*) |
303 |
k) |
k) |
304 |
|
|
305 |
(deftest cons-49 |
(deftest cons-49 |
306 |
(cddadr *cons-test-4*) |
(cddadr *cons-test-4*) |
307 |
l) |
l) |
308 |
|
|
309 |
(deftest cons-50 |
(deftest cons-50 |
310 |
(caaddr *cons-test-4*) |
(caaddr *cons-test-4*) |
311 |
m) |
m) |
312 |
|
|
313 |
(deftest cons-51 |
(deftest cons-51 |
314 |
(cdaddr *cons-test-4*) |
(cdaddr *cons-test-4*) |
315 |
n) |
n) |
316 |
|
|
317 |
(deftest cons-52 |
(deftest cons-52 |
318 |
(cadddr *cons-test-4*) |
(cadddr *cons-test-4*) |
319 |
o) |
o) |
320 |
|
|
321 |
(deftest cons-53 |
(deftest cons-53 |
322 |
(cddddr *cons-test-4*) |
(cddddr *cons-test-4*) |
323 |
p) |
p) |
324 |
|
|
325 |
|
|
326 |
;; Test rplaca, rplacd |
;; Test rplaca, rplacd |
327 |
|
|
328 |
(deftest rplaca-1 |
(deftest rplaca-1 |
329 |
(let ((x (cons 'a 'b))) |
(let ((x (cons 'a 'b))) |
330 |
(let ((y x)) |
(let ((y x)) |
331 |
(and (eqt (rplaca x 'c) y) |
(and (eqt (rplaca x 'c) y) |
332 |
(eqt x y) |
(eqt x y) |
333 |
(eqt (car x) 'c) |
(eqt (car x) 'c) |
334 |
(eqt (cdr x) 'b) |
(eqt (cdr x) 'b)))) |
|
t))) |
|
335 |
t) |
t) |
336 |
|
|
337 |
(deftest rplacd-1 |
(deftest rplacd-1 |
338 |
(let ((x (cons 'a 'b))) |
(let ((x (cons 'a 'b))) |
339 |
(let ((y x)) |
(let ((y x)) |
340 |
(and (eqt (rplacd x 'd) y) |
(and (eqt (rplacd x 'd) y) |
341 |
(eqt x y) |
(eqt x y) |
342 |
(eqt (car x) 'a) |
(eqt (car x) 'a) |
343 |
(eqt (cdr x) 'd) |
(eqt (cdr x) 'd)))) |
|
t))) |
|
344 |
t) |
t) |
345 |
|
|
346 |
;; rplaca on a fixnum is a type error |
;; rplaca on a fixnum is a type error |
347 |
(deftest rplaca-error-1 |
(deftest rplaca-error-1 |
348 |
(let ((x 12340131)) |
(loop for x in *universe* |
349 |
(catch-type-error (rplaca x 1))) |
thereis (and (not (consp x)) |
350 |
type-error) |
(not (eq (catch-type-error (rplaca x 1)) 'type-error)))) |
351 |
|
nil) |
352 |
|
|
353 |
;; rplacd on a fixnum is a type error |
;; rplacd on a fixnum is a type error |
354 |
(deftest rplacd-error-1 |
(deftest rplacd-error-1 |
355 |
(let ((x 12340132)) |
(loop for x in *universe* |
356 |
(catch-type-error (rplacd x 1))) |
thereis (and (not (consp x)) |
357 |
type-error) |
(not (eq (catch-type-error (rplacd x 1)) 'type-error)))) |
358 |
|
nil) |
|
;; To do: add tests for other invalid arguments |
|