source: trunk/source/tests/ansi-tests/psetf.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: 8.6 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Apr 20 15:38:30 2003
4;;;; Contains: Tests of PSETF
5
6(in-package :cl-test)
7
8(deftest psetf.order.1
9  (let ((x (vector nil nil nil nil))
10        (i 0))
11    (psetf (aref x (incf i)) (incf i))
12    (values x i))
13  #(nil 2 nil nil) 2)
14
15(deftest psetf.order.2
16  (let ((x (vector nil nil nil nil))
17        (i 0))
18    (psetf (aref x (incf i)) (incf i)
19           (aref x (incf i)) (incf i 10))
20    (values x i))
21  #(nil 2 nil 13) 13)
22
23(deftest psetf.1
24  (psetf)
25  nil)
26
27(deftest psetf.2
28  (let ((x 0))
29    (values (psetf x 1) x))
30  nil 1)
31
32(deftest psetf.3
33  (let ((x 0) (y 1))
34    (values (psetf x y y x) x y))
35  nil 1 0)
36
37(deftest psetf.4
38  (let ((x 0))
39    (values
40     (symbol-macrolet ((x y))
41       (let ((y 1))
42         (psetf x 2)
43         y))
44     x))
45  2 0)
46
47(deftest psetf.5
48  (let ((w (list nil)))
49    (values
50     (symbol-macrolet ((x (car w)))
51       (psetf x 2))
52     w))
53  nil (2))
54
55(deftest psetf.6
56  (let ((c 0) x y)
57    (psetf x (incf c)
58           y (incf c))
59    (values c x y))
60  2 1 2)
61
62;;; According to the standard, the forms to be assigned and
63;;; the subforms in the places to be assigned to are evaluated
64;;; from left to right.  Therefore, PSETF.7 and PSETF.8 should
65;;; do the same thing to A as PSETF.9 does.
66;;; (See the page for PSETF)
67
68(deftest psetf.7
69  (symbol-macrolet ((x (aref a (incf i)))
70                    (y (aref a (incf i))))
71    (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
72          (i 0))
73      (psetf x (aref a (incf i))
74             y (aref a (incf i)))
75      (values a i)))
76  #(0 2 2 4 4 5 6 7 8 9)
77  4)
78
79(deftest psetf.8
80  (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
81        (i 0))
82    (psetf (aref a (incf i)) (aref a (incf i))
83           (aref a (incf i)) (aref a (incf i)))
84    (values a i))
85  #(0 2 2 4 4 5 6 7 8 9)
86  4)
87
88(deftest psetf.9
89  (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))))
90    (psetf (aref a 1) (aref a 2)
91           (aref a 3) (aref a 4))
92    a)
93  #(0 2 2 4 4 5 6 7 8 9))
94
95(deftest psetf.10
96  (let ((*x* 0) (*y* 10))
97    (declare (special *x* *y*))
98    (values
99     *x* *y*
100     (psetf *x* 6
101            *y* 15)
102     *x* *y*))
103  0 10 nil 6 15)
104
105(deftest psetf.11
106  (let ((*x* 0) (*y* 10))
107    (declare (special *x* *y*))
108    (values
109     *x* *y*
110     (psetf *x* *y*
111            *y* *x*)
112     *x* *y*))
113  0 10 nil 10 0)
114
115(def-macro-test psetf.error.1 (psetf))
116
117;;; PSETF is a good testbed for finding conflicts in setf expansions
118;;; These tests apply psetf to various accessors
119
120(deftest psetf.12
121  (let* ((x (list 'a 'b))
122         (y (list 'c 'd)))
123    (psetf (car x) 1 (car y) 2)
124    (values x y))
125  (1 b) (2 d))
126
127(deftest psetf.12a
128  (let* ((x (list 'a 'b))
129         (y (list 'c 'd)))
130    (psetf (first x) 1 (first y) 2)
131    (values x y))
132  (1 b) (2 d))
133
134(deftest psetf.13
135  (let* ((x (list 'a 'b))
136         (y (list 'c 'd)))
137    (psetf (cdr x) 1 (cdr y) 2)
138    (values x y))
139  (a . 1) (c . 2))
140
141(deftest psetf.13a
142  (let* ((x (list 'a 'b))
143         (y (list 'c 'd)))
144    (psetf (rest x) 1 (rest y) 2)
145    (values x y))
146  (a . 1) (c . 2))
147
148(deftest psetf.14
149  (let* ((x (list 'a 'b))
150         (y (list 'c 'd)))
151    (psetf (cadr x) 1 (cadr y) 2)
152    (values x y))
153  (a 1) (c 2))
154
155(deftest psetf.15
156  (let* ((x (list 'a 'b))
157         (y (list 'c 'd)))
158    (psetf (cddr x) 1 (cddr y) 2)
159    (values x y))
160  (a b . 1) (c d . 2))
161
162(deftest psetf.16
163  (let* ((x (list (list 'a)))
164         (y (list (list 'c))))
165    (psetf (caar x) 1 (caar y) 2)
166    (values x y))
167  ((1)) ((2)))
168
169(deftest psetf.17
170  (let* ((x (list (list 'a)))
171         (y (list (list 'c))))
172    (psetf (cdar x) 1 (cdar y) 2)
173    (values x y))
174  ((a . 1)) ((c . 2)))
175
176;;; TODO: c*r accessors with > 2 a/d
177;;; TODO: third,...,tenth
178
179(deftest psetf.18
180  (let* ((x (vector 'a 'b))
181         (y (vector 'c 'd)))
182    (psetf (aref x 0) 1 (aref y 0) 2)
183    (values x y))
184  #(1 b) #(2 d))
185
186(deftest psetf.18a
187  (let* ((x (vector 'a 'b))
188         (y (vector 'c 'd)))
189    (psetf (svref x 0) 1 (svref y 0) 2)
190    (values x y))
191  #(1 b) #(2 d))
192
193(deftest psetf.19
194  (let* ((x (copy-seq #*11000))
195         (y (copy-seq #*11100)))
196    (psetf (bit x 1) 0 (bit x 2) 1 (bit y 4) 1 (bit y 0) 0)
197    (values x y))
198  #*10100 #*01101)
199
200(deftest psetf.20
201  (let* ((x (copy-seq "abcde"))
202         (y (copy-seq "fghij")))
203    (psetf (char x 1) #\X (char y 2) #\Y)
204    (values x y))
205  "aXcde" "fgYij")
206
207(deftest psetf.21
208  (let* ((x (copy-seq #*11000))
209         (y (copy-seq #*11100)))
210    (psetf (sbit x 1) 0 (sbit x 2) 1 (sbit y 4) 1 (sbit y 0) 0)
211    (values x y))
212  #*10100 #*01101)
213
214(deftest psetf.22
215  (let* ((x (copy-seq "abcde"))
216         (y (copy-seq "fghij")))
217    (psetf (schar x 1) #\X (schar y 2) #\Y)
218    (values x y))
219  "aXcde" "fgYij")
220
221(deftest psetf.23
222  (let* ((x (copy-seq '(a b c d e)))
223         (y (copy-seq '(f g h i j))))
224    (psetf (elt x 1) 'u (elt y 2) 'v)
225    (values x y))
226  (a u c d e) (f g v i j))
227
228(deftest psetf.24
229  (let ((x #b110110001)
230        (y #b101001100))
231    (psetf (ldb (byte 5 1) x) #b10110
232           (ldb (byte 3 6) y) #b10)
233    (values x y))
234  #b110101101
235  #b010001100)
236
237(deftest psetf.25
238  (let* ((f1 (gensym))
239         (f2 (gensym))
240         (fn1 (constantly :foo))
241         (fn2 (constantly :bar)))
242    (psetf (fdefinition f1) fn1
243           (fdefinition f2) fn2)
244    (values (funcall f1) (funcall f2)))
245  :foo :bar)
246
247(deftest psetf.26
248  (let* ((a1 (make-array '(10) :fill-pointer 5))
249         (a2 (make-array '(20) :fill-pointer 7)))
250    (psetf (fill-pointer a1) (1+ (fill-pointer a2))
251           (fill-pointer a2) (1- (fill-pointer a1)))
252    (values (fill-pointer a1) (fill-pointer a2)))
253  8 4)
254
255(deftest psetf.27
256  (let* ((x (list 'a 'b 'c 'd))
257         (y (list 'd 'e 'f 'g))
258         (n1 1) (n2 2)
259         (v1 :foo) (v2 :bar))
260    (psetf (nth n1 x) v1
261           (nth n2 y) v2)
262    (values x y))
263  (a :foo c d)
264  (d e :bar g))
265
266(deftest psetf.28
267  (let* ((f1 (gensym))
268         (f2 (gensym))
269         (fn1 (constantly :foo))
270         (fn2 (constantly :bar)))
271    (psetf (symbol-function f1) fn1
272           (symbol-function f2) fn2)
273    (values (funcall f1) (funcall f2)))
274  :foo :bar)
275
276(deftest psetf.29
277  (let* ((s1 (gensym))
278         (s2 (gensym))
279         (v1 :foo)
280         (v2 :bar))
281    (psetf (symbol-value s1) v1
282           (symbol-value s2) v2)
283    (values (symbol-value s1) (symbol-value s2)))
284  :foo :bar)
285
286(deftest psetf.30
287  (let* ((s1 (gensym))
288         (s2 (gensym))
289         (v1 (list :foo 1))
290         (v2 (list :bar 2)))
291    (psetf (symbol-plist s1) v1
292           (symbol-plist s2) v2)
293    (values (symbol-plist s1) (symbol-plist s2)))
294  (:foo 1) (:bar 2))
295
296(deftest psetf.31
297  (let* ((x (list 'a 'b 'c 'd 'e))
298         (y (list 'f 'g 'h 'i 'j))
299         (v1 (list 1 2))
300         (v2 (list 3 4 5))
301         (p1 1) (p2 2)
302         (l1 (length v1))
303         (l2 (length v2)))
304    (psetf (subseq x p1 (+ p1 l1)) v1
305           (subseq y p2 (+ p2 l2)) v2)
306    (values x y))
307  (a 1 2 d e)
308  (f g 3 4 5))
309
310(deftest psetf.32
311  (let* ((x (gensym))
312         (y (gensym))
313         (k1 :foo)
314         (k2 :bar)
315         (v1 1)
316         (v2 2))
317    (psetf (get x k1) v1 (get y k2) v2)
318    (values (symbol-plist x) (symbol-plist y)))
319  (:foo 1) (:bar 2))
320
321(deftest psetf.33
322  (let* ((x nil)
323         (y nil)
324         (k1 :foo)
325         (k2 :bar)
326         (v1 1)
327         (v2 2))
328    (psetf (getf x k1) v1 (getf y k2) v2)
329    (values x y))
330  (:foo 1) (:bar 2))
331
332(deftest psetf.34
333  (let* ((ht1 (make-hash-table))
334         (ht2 (make-hash-table))
335         (k1 :foo) (v1 1)
336         (k2 :bar) (v2 2))
337    (psetf (gethash k1 ht1) v1
338           (gethash k2 ht2) v2)
339    (values (gethash k1 ht1) (gethash k2 ht2)))
340  1 2)
341
342(deftest psetf.35
343  (let ((n1 (gensym))
344        (n2 (gensym))
345        (n3 (gensym))
346        (n4 (gensym)))
347    (eval `(defclass ,n1 () ()))
348    (eval `(defclass ,n2 () ()))
349    (psetf (find-class n3) (find-class n1)
350           (find-class n4) (find-class n2))
351    (values (eqlt (find-class n1) (find-class n3))
352            (eqlt (find-class n2) (find-class n4))))
353  t t)
354
355(deftest psetf.36
356  (let ((fn1 (constantly :foo))
357        (fn2 (constantly :bar))
358        (n1 (gensym))
359        (n2 (gensym)))
360    (psetf (macro-function n1) fn1
361           (macro-function n2) fn2)
362    (values (eval `(,n1)) (eval `(,n2))))
363  :foo :bar)
364
365(deftest psetf.37
366  (let ((b1 (byte 3 1))
367        (b2 (byte 4 2))
368        (x #b1100101011010101)
369        (y #b11010101000110)
370        (m1 #b101010101101101)
371        (m2 #b11110010110101))
372    (psetf (mask-field b1 x) m1
373           (mask-field b2 y) m2)
374    (values x y))
375  #b1100101011011101
376  #b11010101110110)
377
378(deftest psetf.38
379  (let* ((a1 (make-array '(2 3) :initial-contents '((a b c)(d e f))))
380         (a2 (make-array '(3 4) :initial-contents
381                         '((1 2 3 4) (5 6 7 8) (9 10 11 12))))
382         (i1 2) (i2 5)
383         (v1 'u) (v2 'v))
384    (psetf (row-major-aref a1 i1) v1
385           (row-major-aref a2 i2) v2)
386    (values a1 a2))
387  #2a((a b u)(d e f))
388  #2a((1 2 3 4)(5 v 7 8)(9 10 11 12)))
389
390;;; Test that explicit calls to macroexpand in subforms
391;;; are done in the correct environment
392
393(deftest psetf.39
394  (macrolet
395   ((%m (z) z))
396   (let ((x 1) (y 2))
397     (values
398      (psetf (expand-in-current-env (%m x)) y
399             y x)
400      x y)))
401  nil 2 1)
402
403(deftest psetf.40
404  (macrolet
405   ((%m (z) z))
406   (let ((x 1) (y 2))
407     (values
408      (psetf x (expand-in-current-env (%m y))
409             y x)
410      x y)))
411  nil 2 1)
412
413;;; TODO: logical-pathname-translations, readtable-case
Note: See TracBrowser for help on using the repository browser.