source: trunk/source/tests/ansi-tests/cons-test-05.lsp @ 8991

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

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

File size: 3.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Mar 28 07:34:08 1998
4;;;; Contains:  Testing of CL Features related to "CONS", part 5
5
6(in-package :cl-test)
7
8(compile-and-load "cons-aux.lsp")
9
10(defparameter *cons-accessors*
11  '(first second third fourth fifth sixth seventh eighth ninth tenth
12    car cdr caar cadr cdar cddr
13    caaar caadr cadar caddr cdaar cdadr cddar cdddr
14    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
15    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
16
17;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18;;; first, ..., tenth
19
20(deftest first-etc-1
21  (let ((x (loop for i from 1 to 20 collect i)))
22    (list (first x)
23          (second x)
24          (third x)
25          (fourth x)
26          (fifth x)
27          (sixth x)
28          (seventh x)
29          (eighth x)
30          (ninth x)
31          (tenth x)))
32  (1 2 3 4 5 6 7 8 9 10))
33
34(deftest first-etc-2
35  (let ((x (make-list 15 :initial-element 'a)))
36    (and
37     (eql (setf (first x) 1) 1)
38     (eql (setf (second x) 2) 2)
39     (eql (setf (third x) 3) 3)
40     (eql (setf (fourth x) 4) 4)
41     (eql (setf (fifth x) 5) 5)
42     (eql (setf (sixth x) 6) 6)
43     (eql (setf (seventh x) 7) 7)
44     (eql (setf (eighth x) 8) 8)
45     (eql (setf (ninth x) 9) 9)
46     (eql (setf (tenth x) 10) 10)
47     x))
48  (1 2 3 4 5 6 7 8 9 10 a a a a a))
49
50(deftest rest-set-1
51  (let ((x (list 'a 'b 'c)))
52    (and
53     (eqt (setf (rest x) 'd) 'd)
54     x))
55  (a . d))
56
57;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58;;; setting of C*R accessors
59
60(loop
61 for fn in '(car cdr caar cadr cdar cddr
62                 caaar caadr cadar caddr cdaar cdadr cddar cdddr
63                 caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
64                 cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
65 do
66 (let ((level (- (length (symbol-name fn)) 2)))
67   (eval `(deftest ,(intern
68                     (concatenate 'string
69                                  (symbol-name fn)
70                                  "-SET")
71                     :cl-test)
72            (let ((x (create-c*r-test ,level))
73                  (y (list (create-c*r-test ,level)))
74                  (i 0))
75              (and
76               (setf (,fn (progn (incf i) x)) 'a)
77               (eqlt (,fn x) 'a)
78               (eqlt i 1)
79               (setf (,fn x) 'none)
80               (equalt x (create-c*r-test ,level))
81               (setf (,fn (progn (incf i) (car y))) 'a)
82               (eqlt (,fn (car y)) 'a)
83               (eqlt i 2)
84               (setf (,fn (car y)) 'none)
85               (null (cdr y))
86               (equalt (car y) (create-c*r-test ,level))
87               ))
88            t))))
89
90(loop
91 for (fn len) in '((first 1) (second 2) (third 3) (fourth 4)
92                   (fifth 5) (sixth 6) (seventh 7) (eighth 8)
93                   (ninth 9) (tenth 10))
94 do
95 (eval
96  `(deftest ,(intern
97              (concatenate 'string
98                           (symbol-name fn)
99                           "-SET")
100              :cl-test)
101     (let* ((x (make-list 20 :initial-element nil))
102            (y (list (copy-list x)))
103            (cnt 0))
104       (and
105        (setf (,fn (progn (incf cnt) x)) 'a)
106        (eqlt cnt 1)
107        (loop
108         for i from 1 to 20
109         do (when (and (not (eql i ,len))
110                       (nth (1- i) x))
111              (return nil))
112         finally (return t))
113        (setf (,fn (car y)) 'a)
114        (loop
115         for i from 1 to 20
116         do (when (and (not (eql i ,len))
117                       (nth (1- i) (car y)))
118              (return nil))
119         finally (return t))
120        (eqlt (,fn x) 'a)
121        (eqlt (nth ,(1- len) x) 'a)
122        (eqlt (,fn (car y)) 'a)
123        (nth ,(1- len) (car y))))
124     a)))
125
126;; set up program-error tests
127
128(loop for name in *cons-accessors*
129      do (eval
130          `(deftest ,(intern (concatenate 'string (symbol-name name)
131                                          ".ERROR.NO-ARGS")
132                             :cl-test)
133             (signals-error (,name) program-error)
134             t))
135      do (eval
136          `(deftest ,(intern (concatenate 'string (symbol-name name)
137                                          ".ERROR.EXCESS-ARGS")
138                             :cl-test)
139             (signals-error (,name nil nil) program-error)
140             t)))
Note: See TracBrowser for help on using the repository browser.