source: trunk/source/tests/ansi-tests/places.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: 6.0 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Mon Oct  7 19:20:17 2002
4;;;; Contains: Tests of various kinds of places (section 5.1)
5
6(in-package :cl-test)
7
8;;; Section 5.1.1.1
9
10(deftest setf.order.1
11  (let ((x (vector nil nil nil nil))
12        (i 0))
13    (setf (aref x (incf i)) (incf i))
14    (values x i))
15  #(nil 2 nil nil) 2)
16
17(deftest setf.order.2
18  (let ((x (vector nil nil nil nil))
19        (i 0))
20    (setf (aref x (incf i)) (incf i)
21          (aref x (incf i)) (incf i 10))
22    (values x i))
23  #(nil 2 nil 13) 13)
24
25(deftest incf.order.1
26  (let ((x (copy-seq #(0 0 0 0 0)))
27        (i 1))
28    (values
29     (incf (aref x (incf i)) (incf i))
30     x i))
31  3 #(0 0 3 0 0) 3)
32
33(deftest decf.order.1
34  (let ((x (copy-seq #(0 0 0 0 0)))
35        (i 1))
36    (values
37     (decf (aref x (incf i)) (incf i))
38     x i))
39  -3 #(0 0 -3 0 0) 3)
40
41   
42;;; Section 5.1.2.1
43(deftest setf-var
44  (let ((x nil))
45    (setf x 'a)
46    x)
47  a)
48
49;;; Section 5.1.2.2
50;;; See SETF forms at various accessor functions
51
52;;; Section 5.1.2.3
53(deftest setf-values.1
54  (let ((x nil) (y nil) (z nil))
55    (setf (values x y z) (values 1 2 3)))
56  1 2 3)
57
58(deftest setf-values.2
59  (let ((x nil) (y nil) (z nil))
60    (setf (values x y z) (values 1 2 3))
61    (values z y x))
62  3 2 1)
63
64(deftest setf-values.3
65  (let ((x nil) (y nil) (z nil))
66    (setf (values x x x) (values 1 2 3))
67    x)
68  3)
69
70;;; Test that the subplaces of a VALUES place can be
71;;; complex, and that the various places' subforms are
72;;; evaluated in the correct (left-to-right) order.
73
74(deftest setf-values.4
75  (let ((x (list 'a 'b)))
76    (setf (values (car x) (cadr x)) (values 1 2))
77    x)
78  (1 2))
79
80(deftest setf-values.5
81  (let ((a (vector nil nil))
82        (i 0)
83        x y z)
84    (setf (values (aref a (progn (setf x (incf i)) 0))
85                  (aref a (progn (setf y (incf i)) 1)))
86          (progn
87            (setf z (incf i))
88            (values 'foo 'bar)))
89    (values a i x y z))
90  #(foo bar) 3 1 2 3)
91
92(deftest setf-values.6
93  (setf (values) (values)))
94
95;;; Section 5.1.2.4
96(deftest setf-the.1
97  (let ((x 1))
98    (setf (the integer x) 2)
99    x)
100  2)
101
102(deftest setf-the.2
103  (let ((x (list 'a)))
104    (values
105     (setf (the symbol (car x)) 'b)
106     x))
107  b (b))
108
109;;; Section 5.1.2.5
110(deftest setf-apply.1
111  (let ((x (vector 0 1 2 3 4 5)))
112    (setf (apply #'aref x '(0)) 10)
113    x)
114  #(10 1 2 3 4 5))
115
116(deftest setf-apply.2
117  (let ((a (make-array '(2 2) :initial-contents '((0 0)(0 0)))))
118    (setf (apply #'aref a 1 1 nil) 'a)
119    (equalp a (make-array '(2 2) :initial-contents '((0 0)(0 a)))))
120  t)
121
122(deftest setf-apply.3
123  (let ((bv (copy-seq #*0000000000)))
124    (setf (apply #'bit bv 4 nil) 1)
125    bv)
126  #*0000100000)
127
128(deftest setf-apply.4
129  (let ((bv (copy-seq #*0000000000)))
130    (setf (apply #'sbit bv 4 nil) 1)
131    bv)
132  #*0000100000)
133
134;;; Section 5.1.2.6
135(defun accessor-5-1-2-6-update-fn (x y)
136  (setf (car x) y)
137  y)
138
139(defsetf accessor-5-1-2-6 accessor-5-1-2-6-update-fn)
140
141(deftest setf-expander.1
142  (let ((x (list 1)))
143    (values (setf (accessor-5-1-2-6 x) 2)
144            (1+ (car x))))
145  2 3)
146
147;;; Section 5.1.2.7
148
149(defmacro accessor-5-1-2-7 (x) `(car ,x))
150(deftest setf-macro.1
151  (let ((x (list 1)))
152    (values (setf (accessor-5-1-2-7 x) 2)
153            (1+ (car x))))
154  2 3)
155
156(defun accessor-5-1-2-7a-update-fn (x y)
157  (declare (special *x*))
158  (setf (car x) y)
159  (setf *x* 'boo)
160  y)
161
162(defmacro accessor-5-1-2-7a (x) `(car ,x))
163(defsetf accessor-5-1-2-7a accessor-5-1-2-7a-update-fn)
164;; Test that the defsetf override the macro expansion
165(deftest setf-macro.2
166  (let ((x (list 1))
167        (*x* nil))
168     (declare (special *x*))
169    (values (setf (accessor-5-1-2-7a x) 2)
170            *x*
171            (1+ (car x))))
172  2 boo 3)
173
174(defmacro accessor-5-1-2-7b (x) `(accessor-5-1-2-7 ,x))
175;; Test that the macroexpansion occurs more than once
176(deftest setf-macro.3
177  (let ((x (list 1)))
178    (values (setf (accessor-5-1-2-7b x) 2)
179            (1+ (car x))))
180  2 3)
181
182;; Macroexpansion from a macrolet
183(deftest setf-macro.4
184  (macrolet ((%m (y) `(car ,y)))
185    (let ((x (list 1)))
186      (values (setf (%m x) 2)
187              (1+ (car x)))))
188  2 3)
189
190;;; section 5.1.2.8 -- symbol macros
191(deftest setf-symbol-macro.1
192  (symbol-macrolet ((x y))
193    (let ((y nil))
194      (values (setf x 1) x y)))
195  1 1 1)
196
197;;; Symbol macros in SETQs are treated as if the form were a SETF
198(deftest setf-symbol-macro.2
199  (symbol-macrolet ((x y))
200    (let ((y nil))
201      (values (setq x 1) x y)))
202  1 1 1)
203
204;;; Tests that, being treated like SETF, this causes multiple values
205;;; to be assigned to (values y z)
206(deftest setf-symbol-macro.3
207  (symbol-macrolet ((x (values y z)))
208    (let ((y nil) (z nil))
209      (values (setq x (values 1 2)) x y z)))
210  1 1 1 2)
211
212(deftest setq.1
213  (setq)
214  nil)
215
216(deftest setq.2
217  (let ((x 0) (y 0))
218    (values (setq x 1 y 2) x y))
219  2 1 2)
220
221(deftest setq.3
222  (let ((x 0) (y 0))
223    (values (setq x (values 1 3) y (values 2 4)) x y))
224  2 1 2)
225
226(deftest setq.4
227  (let (x) (setq x (values 1 2)))
228  1)
229
230(deftest setq.5
231  (let ((*x* 0))
232    (declare (special *x*))
233    (values *x* (setq *x* 1) *x*))
234  0 1 1)
235
236(deftest setq.6
237  (let ((*x* 0))
238    (declare (special *x*))
239    (setq *x* 1))
240  1)
241
242;;; Test that explicit calls to macroexpand in subforms
243;;; are done in the correct environment
244
245(deftest setq.7
246  (macrolet
247   ((%m (z) z))
248   (let ((x nil))
249     (values (setq x (expand-in-current-env (%m :good)))
250             x)))
251  :good :good)
252
253;;; Tests of SETF   
254
255(deftest setf.1
256  (setf)
257  nil)
258
259(deftest setf.2
260  (let ((x 0) (y 0))
261    (values (setf x 1 y 2) x y))
262  2 1 2)
263
264(deftest setf.3
265  (let ((x 0) (y 0))
266    (values (setf x (values 1 3) y (values 2 4)) x y))
267  2 1 2)
268
269(deftest setf.4
270  (let (x) (setf x (values 1 2)))
271  1)
272
273(deftest setf.5
274  (let ((*x* 0))
275    (declare (special *x*))
276    (values *x* (setf *x* 1) *x*))
277  0 1 1)
278
279(deftest setf.6
280  (let ((*x* 0))
281    (declare (special *x*))
282    (setf *x* 1))
283  1)
284
285;;; Test that explicit calls to macroexpand in subforms
286;;; are done in the correct environment
287
288(deftest setf.7
289  (macrolet
290   ((%m (z) z))
291   (let ((x nil))
292     (values x (setf (expand-in-current-env (%m x)) t) x)))
293  nil t t)
294
295(deftest setf.8
296  (macrolet
297   ((%m (z) z))
298   (let ((x nil))
299     (values x (setf x (expand-in-current-env (%m t))) x)))
300  nil t t)
Note: See TracBrowser for help on using the repository browser.