19 |
;;; first, ..., tenth |
;;; first, ..., tenth |
20 |
|
|
21 |
(deftest first-etc-1 |
(deftest first-etc-1 |
22 |
(let ((x (loop for i from 1 to 20 collect i))) |
(let ((x (loop for i from 1 to 20 collect i))) |
23 |
(list (first x) |
(list (first x) |
24 |
(second x) |
(second x) |
25 |
(third x) |
(third x) |
26 |
(fourth x) |
(fourth x) |
27 |
(fifth x) |
(fifth x) |
28 |
(sixth x) |
(sixth x) |
29 |
(seventh x) |
(seventh x) |
30 |
(eighth x) |
(eighth x) |
31 |
(ninth x) |
(ninth x) |
32 |
(tenth x))) |
(tenth x))) |
33 |
(1 2 3 4 5 6 7 8 9 10)) |
(1 2 3 4 5 6 7 8 9 10)) |
34 |
|
|
35 |
(deftest first-etc-2 |
(deftest first-etc-2 |
36 |
(let ((x (make-list 15 :initial-element 'a))) |
(let ((x (make-list 15 :initial-element 'a))) |
37 |
(and |
(and |
38 |
(eql (setf (first x) 1) 1) |
(eql (setf (first x) 1) 1) |
39 |
(eql (setf (second x) 2) 2) |
(eql (setf (second x) 2) 2) |
40 |
(eql (setf (third x) 3) 3) |
(eql (setf (third x) 3) 3) |
41 |
(eql (setf (fourth x) 4) 4) |
(eql (setf (fourth x) 4) 4) |
42 |
(eql (setf (fifth x) 5) 5) |
(eql (setf (fifth x) 5) 5) |
43 |
(eql (setf (sixth x) 6) 6) |
(eql (setf (sixth x) 6) 6) |
44 |
(eql (setf (seventh x) 7) 7) |
(eql (setf (seventh x) 7) 7) |
45 |
(eql (setf (eighth x) 8) 8) |
(eql (setf (eighth x) 8) 8) |
46 |
(eql (setf (ninth x) 9) 9) |
(eql (setf (ninth x) 9) 9) |
47 |
(eql (setf (tenth x) 10) 10) |
(eql (setf (tenth x) 10) 10) |
48 |
x)) |
x)) |
49 |
(1 2 3 4 5 6 7 8 9 10 a a a a a)) |
(1 2 3 4 5 6 7 8 9 10 a a a a a)) |
50 |
|
|
51 |
(deftest rest-set-1 |
(deftest rest-set-1 |
52 |
(let ((x (list 'a 'b 'c))) |
(let ((x (list 'a 'b 'c))) |
53 |
(and |
(and |
54 |
(eqt (setf (rest x) 'd) 'd) |
(eqt (setf (rest x) 'd) 'd) |
55 |
x)) |
x)) |
56 |
(a . d)) |
(a . d)) |
57 |
|
|
58 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
59 |
;;; setting of C*R accessors |
;;; setting of C*R accessors |
60 |
|
|
61 |
(loop |
(loop |
62 |
for fn in '(car cdr caar cadr cdar cddr |
for fn in '(car cdr caar cadr cdar cddr |
63 |
caaar caadr cadar caddr cdaar cdadr cddar cdddr |
caaar caadr cadar caddr cdaar cdadr cddar cdddr |
64 |
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr |
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr |
65 |
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) |
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) |
66 |
do |
do |
67 |
(let ((level (- (length (symbol-name fn)) 2))) |
(let ((level (- (length (symbol-name fn)) 2))) |
68 |
(eval `(deftest ,(intern |
(eval `(deftest ,(intern |
69 |
(concatenate 'string |
(concatenate 'string |
70 |
(symbol-name fn) |
(symbol-name fn) |
71 |
"-SET") |
"-SET") |
72 |
:cl-test) |
:cl-test) |
73 |
(let ((x (create-c*r-test ,level)) |
(let ((x (create-c*r-test ,level)) |
74 |
(y (list (create-c*r-test ,level))) |
(y (list (create-c*r-test ,level))) |
75 |
(i 0)) |
(i 0)) |
|
(and |
|
|
(setf (,fn (progn (incf i) x)) 'a) |
|
|
(eqlt (,fn x) 'a) |
|
|
(eqlt i 1) |
|
|
(setf (,fn x) 'none) |
|
|
(equalt x (create-c*r-test ,level)) |
|
|
(setf (,fn (progn (incf i) (car y))) 'a) |
|
|
(eqlt (,fn (car y)) 'a) |
|
|
(eqlt i 2) |
|
|
(setf (,fn (car y)) 'none) |
|
|
(null (cdr y)) |
|
|
(equalt (car y) (create-c*r-test ,level)) |
|
|
)) |
|
|
t)))) |
|
|
|
|
|
(loop |
|
|
for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) |
|
|
(fifth 5) (sixth 6) (seventh 7) (eighth 8) |
|
|
(ninth 9) (tenth 10)) |
|
|
do |
|
|
(eval |
|
|
`(deftest ,(intern |
|
|
(concatenate 'string |
|
|
(symbol-name fn) |
|
|
"-SET") |
|
|
:cl-test) |
|
|
(let* ((x (make-list 20 :initial-element nil)) |
|
|
(y (list (copy-list x))) |
|
|
(cnt 0)) |
|
76 |
(and |
(and |
77 |
(setf (,fn (progn (incf cnt) x)) 'a) |
(setf (,fn (progn (incf i) x)) 'a) |
|
(eqlt cnt 1) |
|
|
(loop |
|
|
for i from 1 to 20 |
|
|
do (when (and (not (eql i ,len)) |
|
|
(nth (1- i) x)) |
|
|
(return nil)) |
|
|
finally (return t)) |
|
|
(setf (,fn (car y)) 'a) |
|
|
(loop |
|
|
for i from 1 to 20 |
|
|
do (when (and (not (eql i ,len)) |
|
|
(nth (1- i) (car y))) |
|
|
(return nil)) |
|
|
finally (return t)) |
|
78 |
(eqlt (,fn x) 'a) |
(eqlt (,fn x) 'a) |
79 |
(eqlt (nth ,(1- len) x) 'a) |
(eqlt i 1) |
80 |
|
(setf (,fn x) 'none) |
81 |
|
(equalt x (create-c*r-test ,level)) |
82 |
|
(setf (,fn (progn (incf i) (car y))) 'a) |
83 |
(eqlt (,fn (car y)) 'a) |
(eqlt (,fn (car y)) 'a) |
84 |
(nth ,(1- len) (car y)))) |
(eqlt i 2) |
85 |
a))) |
(setf (,fn (car y)) 'none) |
86 |
|
(null (cdr y)) |
87 |
|
(equalt (car y) (create-c*r-test ,level)) |
88 |
|
)) |
89 |
|
t)))) |
90 |
|
|
91 |
|
(loop |
92 |
|
for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) |
93 |
|
(fifth 5) (sixth 6) (seventh 7) (eighth 8) |
94 |
|
(ninth 9) (tenth 10)) |
95 |
|
do |
96 |
|
(eval |
97 |
|
`(deftest ,(intern |
98 |
|
(concatenate 'string |
99 |
|
(symbol-name fn) |
100 |
|
"-SET") |
101 |
|
:cl-test) |
102 |
|
(let* ((x (make-list 20 :initial-element nil)) |
103 |
|
(y (list (copy-list x))) |
104 |
|
(cnt 0)) |
105 |
|
(and |
106 |
|
(setf (,fn (progn (incf cnt) x)) 'a) |
107 |
|
(eqlt cnt 1) |
108 |
|
(loop |
109 |
|
for i from 1 to 20 |
110 |
|
do (when (and (not (eql i ,len)) |
111 |
|
(nth (1- i) x)) |
112 |
|
(return nil)) |
113 |
|
finally (return t)) |
114 |
|
(setf (,fn (car y)) 'a) |
115 |
|
(loop |
116 |
|
for i from 1 to 20 |
117 |
|
do (when (and (not (eql i ,len)) |
118 |
|
(nth (1- i) (car y))) |
119 |
|
(return nil)) |
120 |
|
finally (return t)) |
121 |
|
(eqlt (,fn x) 'a) |
122 |
|
(eqlt (nth ,(1- len) x) 'a) |
123 |
|
(eqlt (,fn (car y)) 'a) |
124 |
|
(nth ,(1- len) (car y)))) |
125 |
|
a))) |
126 |
|
|
127 |
;; set up program error tests |
;; set up program error tests |
128 |
|
|
129 |
(loop for name in *cons-accessors* |
(loop for name in *cons-accessors* |
130 |
do (eval |
do (eval |
131 |
`(deftest ,(intern (concatenate 'string (symbol-name name) |
`(deftest ,(intern (concatenate 'string (symbol-name name) |
132 |
".ERROR.NO-ARGS") |
".ERROR.NO-ARGS") |
133 |
:cl-test) |
:cl-test) |
134 |
(classify-error (,name)) |
(classify-error (,name)) |
135 |
program-error)) |
program-error)) |
136 |
do (eval |
do (eval |
137 |
`(deftest ,(intern (concatenate 'string (symbol-name name) |
`(deftest ,(intern (concatenate 'string (symbol-name name) |
138 |
".ERROR.EXCESS-ARGS") |
".ERROR.EXCESS-ARGS") |
139 |
:cl-test) |
:cl-test) |
140 |
(classify-error (,name nil nil)) |
(classify-error (,name nil nil)) |
141 |
program-error))) |
program-error))) |
142 |
|
|
143 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
144 |
;;; nth |
;;; nth |
145 |
|
|
146 |
(deftest nth-1 |
(deftest nth.1 |
147 |
(nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) |
(nth-1-body (loop for i from 1 to 2000 collect (* 4 i))) |
148 |
0) |
0) |
149 |
|
|
150 |
(deftest nth-2 |
(deftest nth.2 |
151 |
(let ((x (loop for i from 1 to 2000 collect i))) |
(let ((x (loop for i from 1 to 2000 collect i))) |
152 |
(loop |
(loop |
153 |
for i from 0 to 1999 do |
for i from 0 to 1999 do |
156 |
t) |
t) |
157 |
|
|
158 |
;;; Test side effects, evaluation order in assignment to NTH |
;;; Test side effects, evaluation order in assignment to NTH |
159 |
(deftest nth-3 |
(deftest nth.3 |
160 |
(let ((i 0) |
(let ((i 0) |
161 |
(x (list 'a 'b 'c 'd)) |
(x (list 'a 'b 'c 'd)) |
162 |
y z) |
y z) |
168 |
x)) |
x)) |
169 |
(a z c d)) |
(a z c d)) |
170 |
|
|
171 |
|
(deftest nth.4 |
172 |
|
(let ((i 0) x y (z '(a b c d e))) |
173 |
|
(values |
174 |
|
(nth (progn (setf x (incf i)) 1) |
175 |
|
(progn (setf y (incf i)) z)) |
176 |
|
i x y)) |
177 |
|
b 2 1 2) |
178 |
|
|
179 |
(deftest nth.error.1 |
(deftest nth.error.1 |
180 |
(classify-error (nth)) |
(classify-error (nth)) |
181 |
program-error) |
program-error) |