/[gcl]/gcl/ansi-tests/psetf.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/psetf.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by pfdietz, Sat May 10 02:01:57 2003 UTC revision 1.3 by pfdietz, Sat Jun 25 17:53:46 2005 UTC
# Line 113  Line 113 
113    0 10 nil 10 0)    0 10 nil 10 0)
114    
115  (def-macro-test psetf.error.1 (psetf))  (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: first,...,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    ;;; TODO: logical-pathname-translations, readtable-case

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26