7 |
|
|
8 |
(defun sbt-slots (sname s &rest slots) |
(defun sbt-slots (sname s &rest slots) |
9 |
(loop for slotname in slots collect |
(loop for slotname in slots collect |
10 |
(let ((fun (intern (concatenate 'string (string sname) "-" (string slotname)) |
(let ((fun (intern (concatenate 'string (string sname) |
11 |
|
"-" (string slotname)) |
12 |
:cl-test))) |
:cl-test))) |
13 |
(funcall (symbol-function fun) s)))) |
(funcall (symbol-function fun) s)))) |
14 |
|
|
15 |
;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists) |
;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists) |
16 |
|
|
17 |
(defstruct (sbt-01 (:constructor sbt-01-con (b a c))) |
(defstruct* (sbt-01 (:constructor sbt-01-con (b a c))) |
18 |
a b c) |
a b c) |
19 |
|
|
20 |
(deftest structure-boa-test-01/1 |
(deftest structure-boa-test-01/1 |
24 |
(sbt-01-c s))) |
(sbt-01-c s))) |
25 |
2 1 3) |
2 1 3) |
26 |
|
|
27 |
(defstruct (sbt-02 (:constructor sbt-02-con (a b c)) |
(defstruct* (sbt-02 (:constructor sbt-02-con (a b c)) |
28 |
(:constructor sbt-02-con-2 (a b)) |
(:constructor sbt-02-con-2 (a b)) |
29 |
(:constructor sbt-02-con-3 ())) |
(:constructor sbt-02-con-3 ())) |
30 |
(a 'x) (b 'y) (c 'z)) |
(a 'x) (b 'y) (c 'z)) |
52 |
|
|
53 |
;;; &optional in BOA LL |
;;; &optional in BOA LL |
54 |
|
|
55 |
(defstruct (sbt-03 (:constructor sbt-03-con (a b &optional c))) |
(defstruct* (sbt-03 (:constructor sbt-03-con (a b &optional c))) |
56 |
c b a) |
c b a) |
57 |
|
|
58 |
(deftest structure-boa-test-03/1 |
(deftest structure-boa-test-03/1 |
66 |
1 2 3) |
1 2 3) |
67 |
|
|
68 |
|
|
69 |
(defstruct (sbt-04 (:constructor sbt-04-con (a b &optional c))) |
(defstruct* (sbt-04 (:constructor sbt-04-con (a b &optional c))) |
70 |
(c nil) b (a nil)) |
(c nil) b (a nil)) |
71 |
|
|
72 |
(deftest structure-boa-test-04/1 |
(deftest structure-boa-test-04/1 |
80 |
1 2 4) |
1 2 4) |
81 |
|
|
82 |
|
|
83 |
(defstruct (sbt-05 (:constructor sbt-05-con (&optional a b c))) |
(defstruct* (sbt-05 (:constructor sbt-05-con (&optional a b c))) |
84 |
(c 1) (b 2) (a 3)) |
(c 1) (b 2) (a 3)) |
85 |
|
|
86 |
(deftest structure-boa-test-05/1 |
(deftest structure-boa-test-05/1 |
104 |
x y z) |
x y z) |
105 |
|
|
106 |
|
|
107 |
(defstruct (sbt-06 (:constructor sbt-06-con (&optional (a 'p) (b 'q) (c 'r)))) |
(defstruct* (sbt-06 (:constructor sbt-06-con (&optional (a 'p) (b 'q) (c 'r)))) |
108 |
(c 1) (b 2) (a 3)) |
(c 1) (b 2) (a 3)) |
109 |
|
|
110 |
(deftest structure-boa-test-06/1 |
(deftest structure-boa-test-06/1 |
130 |
|
|
131 |
;;; Test presence flag in optional parameters |
;;; Test presence flag in optional parameters |
132 |
|
|
133 |
(defstruct (sbt-07 (:constructor sbt-07-con |
(defstruct* (sbt-07 (:constructor sbt-07-con |
134 |
(&optional (a 'p a-p) (b 'q b-p) (c 'r c-p) |
(&optional (a 'p a-p) (b 'q b-p) (c 'r c-p) |
135 |
&aux (d (list (notnot a-p) |
&aux (d (list (notnot a-p) |
136 |
(notnot b-p) |
(notnot b-p) |
156 |
|
|
157 |
;;; Keyword arguments |
;;; Keyword arguments |
158 |
|
|
159 |
(eval-when (compile load eval) |
(defstruct* (sbt-08 (:constructor sbt-08-con |
160 |
(ignore-errors |
(&key ((foo a))))) |
161 |
(defstruct (sbt-08 (:constructor sbt-08-con |
a) |
|
(&key ((foo a))))) |
|
|
a))) |
|
162 |
|
|
163 |
(deftest structure-boa-test-08/1 |
(deftest structure-boa-test-08/1 |
164 |
(sbt-slots 'sbt-08 (sbt-08-con :foo 10) :a) |
(sbt-slots 'sbt-08 (sbt-08-con :foo 10) :a) |
165 |
(10)) |
(10)) |
166 |
|
|
167 |
(eval-when (compile load eval) |
(defstruct* (sbt-09 (:constructor sbt-09-con |
168 |
(ignore-errors |
(&key (a 'p a-p) |
169 |
(defstruct (sbt-09 (:constructor sbt-09-con |
((x b) 'q) |
170 |
(&key (a 'p a-p) |
(c 'r) |
171 |
((x b) 'q) |
d |
172 |
(c 'r) |
((y e)) |
173 |
d |
((z f) 's z-p) |
174 |
((y e)) |
&aux (g (list (notnot a-p) |
175 |
((z f) 's z-p) |
(notnot z-p)))))) |
176 |
&aux (g (list (notnot a-p) |
a b c d e f g) |
|
(notnot z-p)))))) |
|
|
a b c d e f g))) |
|
177 |
|
|
178 |
(deftest structure-boa-test-09/1 |
(deftest structure-boa-test-09/1 |
179 |
(sbt-slots 'sbt-09 (sbt-09-con) :a :b :c :f :g) |
(sbt-slots 'sbt-09 (sbt-09-con) :a :b :c :f :g) |
203 |
(sbt-slots 'sbt-09 (sbt-09-con :z 1) :a :b :c :f :g) |
(sbt-slots 'sbt-09 (sbt-09-con :z 1) :a :b :c :f :g) |
204 |
(p q r 1 (nil t))) |
(p q r 1 (nil t))) |
205 |
|
|
206 |
|
;;; Aux variable overriding a default value |
207 |
|
|
208 |
|
(defstruct* (sbt-10 (:constructor sbt-10-con (&aux (a 10) |
209 |
|
(b (1+ a))))) |
210 |
|
(a 1) (b 2)) |
211 |
|
|
212 |
|
(deftest structure-boa-test-10/1 |
213 |
|
(sbt-slots 'sbt-10 (sbt-10-con) :a :b) |
214 |
|
(10 11)) |
215 |
|
|
216 |
|
;;; Aux variables with no value |
217 |
|
|
218 |
|
(defstruct* (sbt-11 (:constructor sbt-11-con (&aux a b))) |
219 |
|
a (b 0 :type integer)) |
220 |
|
|
221 |
|
(deftest structure-boa-test-11/1 |
222 |
|
(let ((s (sbt-11-con))) |
223 |
|
(setf (sbt-11-a s) 'p) |
224 |
|
(setf (sbt-11-b s) 10) |
225 |
|
(sbt-slots 'sbt-11 s :a :b)) |
226 |
|
(p 10)) |
227 |
|
|
228 |
|
;;; Arguments that correspond to no slots |
229 |
|
|
230 |
|
(defstruct* (sbt-12 (:constructor sbt-12-con (a &optional (b 1) |
231 |
|
&rest c |
232 |
|
&aux (d (list a b c))))) |
233 |
|
d) |
234 |
|
|
235 |
|
(deftest structure-boa-12/1 |
236 |
|
(sbt-12-d (sbt-12-con 'x)) |
237 |
|
(x 1 nil)) |
238 |
|
|
239 |
|
(deftest structure-boa-12/2 |
240 |
|
(sbt-12-d (sbt-12-con 'x 'y)) |
241 |
|
(x y nil)) |
242 |
|
|
243 |
|
(deftest structure-boa-12/3 |
244 |
|
(sbt-12-d (sbt-12-con 'x 'y 1 2 3)) |
245 |
|
(x y (1 2 3))) |
246 |
|
|
247 |
|
|
248 |
|
(defstruct* (sbt-13 (:constructor sbt-13-con |
249 |
|
(&key (a 1) (b 2) c &aux (d (list a b c))))) |
250 |
|
d) |
251 |
|
|
252 |
|
(deftest structure-boa-test-13/1 |
253 |
|
(sbt-13-d (sbt-13-con)) |
254 |
|
(1 2 nil)) |
255 |
|
|
256 |
|
(deftest structure-boa-test-13/2 |
257 |
|
(sbt-13-d (sbt-13-con :a 10)) |
258 |
|
(10 2 nil)) |
259 |
|
|
260 |
|
(deftest structure-boa-test-13/3 |
261 |
|
(sbt-13-d (sbt-13-con :b 10)) |
262 |
|
(1 10 nil)) |
263 |
|
|
264 |
|
(deftest structure-boa-test-13/4 |
265 |
|
(sbt-13-d (sbt-13-con :c 10)) |
266 |
|
(1 2 10)) |
267 |
|
|
268 |
|
(deftest structure-boa-test-13/5 |
269 |
|
(sbt-13-d (sbt-13-con :c 10 :a 3)) |
270 |
|
(3 2 10)) |
271 |
|
|
272 |
|
(deftest structure-boa-test-13/6 |
273 |
|
(sbt-13-d (sbt-13-con :c 10 :b 3)) |
274 |
|
(1 3 10)) |
275 |
|
|
276 |
|
(deftest structure-boa-test-13/7 |
277 |
|
(sbt-13-d (sbt-13-con :a 10 :b 3)) |
278 |
|
(10 3 nil)) |
279 |
|
|
280 |
|
(deftest structure-boa-test-13/8 |
281 |
|
(sbt-13-d (sbt-13-con :a 10 :c 'a :b 3)) |
282 |
|
(10 3 a)) |
283 |
|
|
284 |
|
|
285 |
|
;;; Allow other keywords |
286 |
|
|
287 |
|
(defstruct* (sbt-14 (:constructor sbt-14-con (&key a b c &allow-other-keys))) |
288 |
|
(a 1) (b 2) (c 3)) |
289 |
|
|
290 |
|
(deftest structure-boa-test-14/1 |
291 |
|
(sbt-slots 'sbt-14 (sbt-14-con) :a :b :c) |
292 |
|
(1 2 3)) |
293 |
|
|
294 |
|
(deftest structure-boa-test-14/2 |
295 |
|
(sbt-slots 'sbt-14 (sbt-14-con :a 9) :a :b :c) |
296 |
|
(9 2 3)) |
297 |
|
|
298 |
|
(deftest structure-boa-test-14/3 |
299 |
|
(sbt-slots 'sbt-14 (sbt-14-con :b 9) :a :b :c) |
300 |
|
(1 9 3)) |
301 |
|
|
302 |
|
(deftest structure-boa-test-14/4 |
303 |
|
(sbt-slots 'sbt-14 (sbt-14-con :c 9) :a :b :c) |
304 |
|
(1 2 9)) |
305 |
|
|
306 |
|
(deftest structure-boa-test-14/5 |
307 |
|
(sbt-slots 'sbt-14 (sbt-14-con :d 9) :a :b :c) |
308 |
|
(1 2 3)) |
309 |
|
|