← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/places.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/places.lsp
 
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
 
 
243
(deftest setf.1
 
244
  (setf)
 
245
  nil)
 
246
 
 
247
(deftest setf.2
 
248
  (let ((x 0) (y 0))
 
249
    (values (setf x 1 y 2) x y))
 
250
  2 1 2)
 
251
 
 
252
(deftest setf.3
 
253
  (let ((x 0) (y 0))
 
254
    (values (setf x (values 1 3) y (values 2 4)) x y))
 
255
  2 1 2)
 
256
 
 
257
(deftest setf.4
 
258
  (let (x) (setf x (values 1 2)))
 
259
  1)
 
260
 
 
261
(deftest setf.5
 
262
  (let ((*x* 0))
 
263
    (declare (special *x*))
 
264
    (values *x* (setf *x* 1) *x*))
 
265
  0 1 1)
 
266
 
 
267
(deftest setf.6
 
268
  (let ((*x* 0))
 
269
    (declare (special *x*))
 
270
    (setf *x* 1))
 
271
  1)