source: trunk/source/tests/ansi-tests/cxr.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 10.9 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr 19 21:28:38 2003
4;;;; Contains: Tests of C*R functions
5
6(in-package :cl-test)
7
8(compile-and-load "cons-aux.lsp")
9
10;; Tests of car, cdr and compound forms
11(deftest cons.23
12  (car '(a))
13  a)
14
15(deftest cons.24
16  (cdr '(a . b))
17  b)
18
19(deftest cons.25
20  (caar '((a)))
21  a)
22
23(deftest cons.26
24  (cdar '((a . b)))
25  b)
26
27(deftest cons.27
28  (cadr '(a b))
29  b)
30
31(deftest cons.28
32  (cddr '(a b . c))
33  c)
34
35(deftest cons.29
36  (caaar '(((a))))
37  a)
38
39(deftest cons.30
40  (cdaar '(((a . b))))
41  b)
42
43(deftest cons.31
44  (cadar (cons (cons 'a (cons 'b 'c)) 'd))
45  b)
46
47(deftest cons.32
48  (cddar (cons (cons 'a (cons 'b 'c)) 'd))
49  c)
50
51(deftest cons.33
52  (caadr (cons 'a (cons (cons 'b 'c) 'd)))
53  b)
54
55(deftest cons.34
56  (caddr (cons 'a (cons 'b (cons 'c 'd))))
57  c)
58
59(deftest cons.36
60  (cdadr (cons 'a (cons (cons 'b 'c) 'd)))
61  c)
62
63(deftest cons.37
64  (cdddr (cons 'a (cons 'b (cons 'c 'd))))
65  d)
66
67(defvar *cons-test-4*
68  (cons (cons (cons (cons 'a 'b)
69                    (cons 'c 'd))
70              (cons (cons 'e 'f)
71                    (cons 'g 'h)))
72        (cons (cons (cons 'i 'j)
73                    (cons 'k 'l))
74              (cons (cons 'm 'n)
75                    (cons 'o 'p)))))
76
77(deftest cons.38
78  (caaaar *cons-test-4*)
79  a)
80
81(deftest cons.39
82  (cdaaar *cons-test-4*)
83  b)
84
85(deftest cons.40
86  (cadaar *cons-test-4*)
87  c)
88
89(deftest cons.41
90  (cddaar *cons-test-4*)
91  d)
92
93(deftest cons.42
94  (caadar *cons-test-4*)
95  e)
96
97(deftest cons.43
98  (cdadar *cons-test-4*)
99  f)
100
101(deftest cons.44
102  (caddar *cons-test-4*)
103  g)
104
105(deftest cons.45
106  (cdddar *cons-test-4*)
107  h)
108
109;;;
110
111(deftest cons.46
112  (caaadr *cons-test-4*)
113  i)
114
115(deftest cons.47
116  (cdaadr *cons-test-4*)
117  j)
118
119(deftest cons.48
120  (cadadr *cons-test-4*)
121  k)
122
123(deftest cons.49
124  (cddadr *cons-test-4*)
125  l)
126
127(deftest cons.50
128  (caaddr *cons-test-4*)
129  m)
130
131(deftest cons.51
132  (cdaddr *cons-test-4*)
133  n)
134
135(deftest cons.52
136  (cadddr *cons-test-4*)
137  o)
138
139(deftest cons.53
140  (cddddr *cons-test-4*)
141  p)
142
143(deftest car.1
144  (car '(a))
145  a)
146
147(deftest car-nil
148  (car nil)
149  nil)
150
151(deftest car.error.1
152  (check-type-error #'car #'listp)
153  nil)
154
155(deftest car.error.2
156  (signals-error (locally (car 'a) t) type-error)
157  t)
158
159(deftest car.order.1
160  (let ((i 0))
161    (values (car (progn (incf i) '(a b))) i))
162  a 1)
163
164(deftest cdr.1
165  (cdr '(a b))
166  (b))
167
168(deftest cdr-nil
169  (cdr ())
170  nil)
171
172(deftest cdr.order.1
173  (let ((i 0))
174    (values (cdr (progn (incf i) '(a b))) i))
175  (b) 1)
176
177(deftest cdr.error.1
178  (check-type-error #'cdr #'listp)
179  nil)
180
181(deftest cdr.error.2
182  (signals-error (locally (cdr 'a) t) type-error)
183  t)
184
185;;; Error checking of c*r functions
186
187(deftest caar.error.1
188  (signals-error (caar 'a) type-error)
189  t)
190
191(deftest caar.error.2
192  (signals-error (caar '(a)) type-error)
193  t)
194
195(deftest cadr.error.1
196  (signals-error (cadr 'a) type-error)
197  t)
198
199(deftest cadr.error.2
200  (signals-error (cadr '(a . b)) type-error)
201  t)
202
203(deftest cdar.error.1
204  (signals-error (cdar 'a) type-error)
205  t)
206
207(deftest cdar.error.2
208  (signals-error (cdar '(a . b)) type-error)
209  t)
210
211(deftest cddr.error.1
212  (signals-error (cddr 'a) type-error)
213  t)
214
215(deftest cddr.error.2
216  (signals-error (cddr '(a . b)) type-error)
217  t)
218
219(deftest caaar.error.1
220  (signals-error (caaar 'a) type-error)
221  t)
222
223(deftest caaar.error.2
224  (signals-error (caaar '(a)) type-error)
225  t)
226
227(deftest caaar.error.3
228  (signals-error (caaar '((a))) type-error)
229  t)
230
231(deftest caadr.error.1
232  (signals-error (caadr 'a) type-error)
233  t)
234
235(deftest caadr.error.2
236  (signals-error (caadr '(a . b)) type-error)
237  t)
238
239(deftest caadr.error.3
240  (signals-error (caadr '(a . (b))) type-error)
241  t)
242
243(deftest cadar.error.1
244  (signals-error (cadar 'a) type-error)
245  t)
246
247(deftest cadar.error.2
248  (signals-error (cadar '(a . b)) type-error)
249  t)
250
251(deftest cadar.error.3
252  (signals-error (cadar '((a . c) . b)) type-error)
253  t)
254
255(deftest caddr.error.1
256  (signals-error (caddr 'a) type-error)
257  t)
258
259(deftest caddr.error.2
260  (signals-error (caddr '(a . b)) type-error)
261  t)
262
263(deftest caddr.error.3
264  (signals-error (caddr '(a c . b)) type-error)
265  t)
266
267(deftest cdaar.error.1
268  (signals-error (cdaar 'a) type-error)
269  t)
270
271(deftest cdaar.error.2
272  (signals-error (cdaar '(a)) type-error)
273  t)
274
275(deftest cdaar.error.3
276  (signals-error (cdaar '((a . b))) type-error)
277  t)
278
279(deftest cdadr.error.1
280  (signals-error (cdadr 'a) type-error)
281  t)
282
283(deftest cdadr.error.2
284  (signals-error (cdadr '(a . b)) type-error)
285  t)
286
287(deftest cdadr.error.3
288  (signals-error (cdadr '(a b . c)) type-error)
289  t)
290
291(deftest cddar.error.1
292  (signals-error (cddar 'a) type-error)
293  t)
294
295(deftest cddar.error.2
296  (signals-error (cddar '(a . b)) type-error)
297  t)
298
299(deftest cddar.error.3
300  (signals-error (cddar '((a . b) . b)) type-error)
301  t)
302
303(deftest cdddr.error.1
304  (signals-error (cdddr 'a) type-error)
305  t)
306
307(deftest cdddr.error.2
308  (signals-error (cdddr '(a . b)) type-error)
309  t)
310
311(deftest cdddr.error.3
312  (signals-error (cdddr '(a c . b)) type-error)
313  t)
314
315;;
316
317(deftest caaaar.error.1
318  (signals-error (caaaar 'a) type-error)
319  t)
320
321(deftest caaaar.error.2
322  (signals-error (caaaar '(a)) type-error)
323  t)
324
325(deftest caaaar.error.3
326  (signals-error (caaaar '((a))) type-error)
327  t)
328
329(deftest caaaar.error.4
330  (signals-error (caaaar '(((a)))) type-error)
331  t)
332
333(deftest caaadr.error.1
334  (signals-error (caaadr 'a) type-error)
335  t)
336
337(deftest caaadr.error.2
338  (signals-error (caaadr '(a . b)) type-error)
339  t)
340
341(deftest caaadr.error.3
342  (signals-error (caaadr '(a . (b))) type-error)
343  t)
344
345(deftest caaadr.error.4
346  (signals-error (caaadr '(a . ((b)))) type-error)
347  t)
348
349(deftest caadar.error.1
350  (signals-error (caadar 'a) type-error)
351  t)
352
353(deftest caadar.error.2
354  (signals-error (caadar '(a . b)) type-error)
355  t)
356
357(deftest caadar.error.3
358  (signals-error (caadar '((a . c) . b)) type-error)
359  t)
360
361(deftest caadar.error.4
362  (signals-error (caadar '((a . (c)) . b)) type-error)
363  t)
364
365(deftest caaddr.error.1
366  (signals-error (caaddr 'a) type-error)
367  t)
368
369(deftest caaddr.error.2
370  (signals-error (caaddr '(a . b)) type-error)
371  t)
372
373(deftest caaddr.error.3
374  (signals-error (caaddr '(a c . b)) type-error)
375  t)
376
377(deftest caaddr.error.4
378  (signals-error (caaddr '(a c . (b))) type-error)
379  t)
380
381(deftest cadaar.error.1
382  (signals-error (cadaar 'a) type-error)
383  t)
384
385(deftest cadaar.error.2
386  (signals-error (cadaar '(a)) type-error)
387  t)
388
389(deftest cadaar.error.3
390  (signals-error (cadaar '((a . b))) type-error)
391  t)
392
393(deftest cadaar.error.4
394  (signals-error (cadaar '((a . (b)))) type-error)
395  t)
396
397(deftest cadadr.error.1
398  (signals-error (cadadr 'a) type-error)
399  t)
400
401(deftest cadadr.error.2
402  (signals-error (cadadr '(a . b)) type-error)
403  t)
404
405(deftest cadadr.error.3
406  (signals-error (cadadr '(a b . c)) type-error)
407  t)
408
409(deftest cadadr.error.4
410  (signals-error (cadadr '(a (b . e) . c)) type-error)
411  t)
412
413(deftest caddar.error.1
414  (signals-error (caddar 'a) type-error)
415  t)
416
417(deftest caddar.error.2
418  (signals-error (caddar '(a . b)) type-error)
419  t)
420
421(deftest caddar.error.3
422  (signals-error (caddar '((a . b) . b)) type-error)
423  t)
424
425(deftest caddar.error.4
426  (signals-error (caddar '((a  b . c) . b)) type-error)
427  t)
428
429(deftest cadddr.error.1
430  (signals-error (cadddr 'a) type-error)
431  t)
432
433(deftest cadddr.error.2
434  (signals-error (cadddr '(a . b)) type-error)
435  t)
436
437(deftest cadddr.error.3
438  (signals-error (cadddr '(a c . b)) type-error)
439  t)
440
441(deftest cadddr.error.4
442  (signals-error (cadddr '(a c e . b)) type-error)
443  t)
444
445(deftest cdaaar.error.1
446  (signals-error (cdaaar 'a) type-error)
447  t)
448
449(deftest cdaaar.error.2
450  (signals-error (cdaaar '(a)) type-error)
451  t)
452
453(deftest cdaaar.error.3
454  (signals-error (cdaaar '((a))) type-error)
455  t)
456
457(deftest cdaaar.error.4
458  (signals-error (cdaaar '(((a . b)))) type-error)
459  t)
460
461(deftest cdaadr.error.1
462  (signals-error (cdaadr 'a) type-error)
463  t)
464
465(deftest cdaadr.error.2
466  (signals-error (cdaadr '(a . b)) type-error)
467  t)
468
469(deftest cdaadr.error.3
470  (signals-error (cdaadr '(a . (b))) type-error)
471  t)
472
473(deftest cdaadr.error.4
474  (signals-error (cdaadr '(a . ((b . c)))) type-error)
475  t)
476
477(deftest cdadar.error.1
478  (signals-error (cdadar 'a) type-error)
479  t)
480
481(deftest cdadar.error.2
482  (signals-error (cdadar '(a . b)) type-error)
483  t)
484
485(deftest cdadar.error.3
486  (signals-error (cdadar '((a . c) . b)) type-error)
487  t)
488
489(deftest cdadar.error.4
490  (signals-error (cdadar '((a . (c . d)) . b)) type-error)
491  t)
492
493(deftest cdaddr.error.1
494  (signals-error (cdaddr 'a) type-error)
495  t)
496
497(deftest cdaddr.error.2
498  (signals-error (cdaddr '(a . b)) type-error)
499  t)
500
501(deftest cdaddr.error.3
502  (signals-error (cdaddr '(a c . b)) type-error)
503  t)
504
505(deftest cdaddr.error.4
506  (signals-error (cdaddr '(a c b . d)) type-error)
507  t)
508
509(deftest cddaar.error.1
510  (signals-error (cddaar 'a) type-error)
511  t)
512
513(deftest cddaar.error.2
514  (signals-error (cddaar '(a)) type-error)
515  t)
516
517(deftest cddaar.error.3
518  (signals-error (cddaar '((a . b))) type-error)
519  t)
520
521(deftest cddaar.error.4
522  (signals-error (cddaar '((a . (b)))) type-error)
523  t)
524
525(deftest cddadr.error.1
526  (signals-error (cddadr 'a) type-error)
527  t)
528
529(deftest cddadr.error.2
530  (signals-error (cddadr '(a . b)) type-error)
531  t)
532
533(deftest cddadr.error.3
534  (signals-error (cddadr '(a b . c)) type-error)
535  t)
536
537(deftest cddadr.error.4
538  (signals-error (cddadr '(a (b . e) . c)) type-error)
539  t)
540
541(deftest cdddar.error.1
542  (signals-error (cdddar 'a) type-error)
543  t)
544
545(deftest cdddar.error.2
546  (signals-error (cdddar '(a . b)) type-error)
547  t)
548
549(deftest cdddar.error.3
550  (signals-error (cdddar '((a . b) . b)) type-error)
551  t)
552
553(deftest cdddar.error.4
554  (signals-error (cdddar '((a  b . c) . b)) type-error)
555  t)
556
557(deftest cddddr.error.1
558  (signals-error (cddddr 'a) type-error)
559  t)
560
561(deftest cddddr.error.2
562  (signals-error (cddddr '(a . b)) type-error)
563  t)
564
565(deftest cddddr.error.3
566  (signals-error (cddddr '(a c . b)) type-error)
567  t)
568
569(deftest cddddr.error.4
570  (signals-error (cddddr '(a c e . b)) type-error)
571  t)
572
573;;; Need to add 'locally' wrapped forms of these
574
575;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
576;;; setting of C*R accessors
577
578(loop
579    for fn in '(car cdr caar cadr cdar cddr
580                caaar caadr cadar caddr cdaar cdadr cddar cdddr
581                caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
582                cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
583    do
584      (let ((level (- (length (symbol-name fn)) 2)))
585        (eval `(deftest ,(intern
586                          (concatenate 'string
587                            (symbol-name fn)
588                            "-SET-ALT")
589                          :cl-test)
590                   (let ((x (create-c*r-test ,level)))
591                     (and
592                      (setf (,fn x) 'a)
593                      (eql (,fn x) 'a)
594                      (setf (,fn x) 'none)
595                      (equalt x (create-c*r-test ,level))
596                      ))
597                 t))))
598
599(loop
600    for (fn len) in '((first 1) (second 2) (third 3) (fourth 4)
601                      (fifth 5) (sixth 6) (seventh 7) (eighth 8)
602                      (ninth 9) (tenth 10))
603    do
604      (eval
605       `(deftest ,(intern
606                   (concatenate 'string
607                     (symbol-name fn)
608                     "-SET-ALT")
609                   :cl-test)
610            (let ((x (make-list 20 :initial-element nil)))
611              (and
612               (setf (,fn x) 'a)
613               (loop
614                   for i from 1 to 20
615                   do (when (and (not (eql i ,len))
616                                 (nth (1- i) x))
617                        (return nil))
618                   finally (return t))
619               (eql (,fn x) 'a)
620               (nth ,(1- len) x)))
621          a)))
Note: See TracBrowser for help on using the repository browser.