source: trunk/source/tests/ansi-tests/structures-03.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 9.9 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Fri Dec 20 05:58:06 2002
4;;;; Contains: BOA Constructor Tests
5
6(in-package :cl-test)
7
8(defun sbt-slots (sname s &rest slots)
9  (loop for slotname in slots collect
10        (let ((fun (intern (concatenate 'string (string sname)
11                                        "-" (string slotname))
12                           :cl-test)))
13          (funcall (symbol-function fun) s))))
14
15;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists)
16
17(defstruct* (sbt-01 (:constructor sbt-01-con (b a c)))
18  a b c)
19
20(deftest structure-boa-test-01/1
21  (let ((s (sbt-01-con 1 2 3)))
22    (values (sbt-01-a s)
23            (sbt-01-b s)
24            (sbt-01-c s)))
25  2 1 3)
26
27(defstruct* (sbt-02 (:constructor sbt-02-con (a b c))
28                   (:constructor sbt-02-con-2 (a b))
29                   (:constructor sbt-02-con-3 ()))
30  (a 'x) (b 'y) (c 'z))
31
32(deftest structure-boa-test-02/1
33  (let ((s (sbt-02-con 1 2 3)))
34    (values (sbt-02-a s)
35            (sbt-02-b s)
36            (sbt-02-c s)))
37  1 2 3)
38
39(deftest structure-boa-test-02/2
40  (let ((s (sbt-02-con-2 'p 'q)))
41    (values (sbt-02-a s)
42            (sbt-02-b s)
43            (sbt-02-c s)))
44  p q z)
45
46(deftest structure-boa-test-02/3
47  (let ((s (sbt-02-con-3)))
48    (values (sbt-02-a s)
49            (sbt-02-b s)
50            (sbt-02-c s)))
51  x y z)
52
53;;; &optional in BOA LL
54
55(defstruct* (sbt-03 (:constructor sbt-03-con (a b &optional c)))
56  c b a)
57
58(deftest structure-boa-test-03/1
59  (let ((s (sbt-03-con 1 2)))
60    (values (sbt-03-a s) (sbt-03-b s)))
61  1 2)
62
63(deftest structure-boa-test-03/2
64  (let ((s (sbt-03-con 1 2 3)))
65    (values (sbt-03-a s) (sbt-03-b s) (sbt-03-c s)))
66  1 2 3)
67
68
69(defstruct* (sbt-04 (:constructor sbt-04-con (a b &optional c)))
70  (c nil) b (a nil))
71
72(deftest structure-boa-test-04/1
73  (let ((s (sbt-04-con 1 2)))
74    (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s)))
75  1 2 nil)
76
77(deftest structure-boa-test-04/2
78  (let ((s (sbt-04-con 1 2 4)))
79    (values (sbt-04-a s) (sbt-04-b s) (sbt-04-c s)))
80  1 2 4)
81
82
83(defstruct* (sbt-05 (:constructor sbt-05-con (&optional a b c)))
84  (c 1) (b 2) (a 3))
85
86(deftest structure-boa-test-05/1
87  (let ((s (sbt-05-con)))
88    (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s)))
89  3 2 1)
90
91(deftest structure-boa-test-05/2
92  (let ((s (sbt-05-con 'x)))
93    (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s)))
94  x 2 1)
95
96(deftest structure-boa-test-05/3
97  (let ((s (sbt-05-con 'x 'y)))
98    (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s)))
99  x y 1)
100
101(deftest structure-boa-test-05/4
102  (let ((s (sbt-05-con 'x 'y 'z)))
103    (values (sbt-05-a s) (sbt-05-b s) (sbt-05-c s)))
104  x y z)
105
106
107(defstruct* (sbt-06 (:constructor sbt-06-con (&optional (a 'p) (b 'q) (c 'r))))
108  (c 1) (b 2) (a 3))
109
110(deftest structure-boa-test-06/1
111  (let ((s (sbt-06-con)))
112    (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s)))
113  p q r)
114
115(deftest structure-boa-test-06/2
116  (let ((s (sbt-06-con 'x)))
117    (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s)))
118  x q r)
119
120(deftest structure-boa-test-06/3
121  (let ((s (sbt-06-con 'x 'y)))
122    (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s)))
123  x y r)
124
125(deftest structure-boa-test-06/4
126  (let ((s (sbt-06-con 'x 'y 'z)))
127    (values (sbt-06-a s) (sbt-06-b s) (sbt-06-c s)))
128  x y z)
129
130
131;;; Test presence flag in optional parameters
132
133(defstruct* (sbt-07 (:constructor sbt-07-con
134                                 (&optional (a 'p a-p) (b 'q b-p) (c 'r c-p)
135                                            &aux (d (list (notnot a-p)
136                                                          (notnot b-p)
137                                                          (notnot c-p))))))
138  a b c d)
139
140(deftest structure-boa-test-07/1
141  (sbt-slots 'sbt-07 (sbt-07-con) :a :b :c :d)
142  (p q r (nil nil nil)))
143
144(deftest structure-boa-test-07/2
145  (sbt-slots 'sbt-07 (sbt-07-con 'x) :a :b :c :d)
146  (x q r (t nil nil)))
147
148(deftest structure-boa-test-07/3
149  (sbt-slots 'sbt-07 (sbt-07-con 'x 'y) :a :b :c :d)
150  (x y r (t t nil)))
151
152(deftest structure-boa-test-07/4
153  (sbt-slots 'sbt-07 (sbt-07-con 'x 'y 'z) :a :b :c :d)
154  (x y z (t t t)))
155
156
157;;; Keyword arguments
158
159(defstruct* (sbt-08 (:constructor sbt-08-con
160                                 (&key ((:foo a)))))
161  a)
162
163(deftest structure-boa-test-08/1
164  (sbt-slots 'sbt-08 (sbt-08-con :foo 10) :a)
165  (10))
166
167(defstruct* (sbt-09 (:constructor sbt-09-con
168                                 (&key (a 'p a-p)
169                                       ((:x b) 'q)
170                                       (c 'r)
171                                       d
172                                       ((:y e))
173                                       ((:z f) 's z-p)
174                                       &aux (g (list (notnot a-p)
175                                                     (notnot z-p))))))
176  a b c d e f g)
177
178(deftest structure-boa-test-09/1
179  (sbt-slots 'sbt-09 (sbt-09-con) :a :b :c :f :g)
180  (p q r s (nil nil)))
181
182(deftest structure-boa-test-09/2
183  (sbt-slots 'sbt-09 (sbt-09-con :d 1) :a :b :c :d :f :g)
184  (p q r 1 s (nil nil)))
185
186(deftest structure-boa-test-09/3
187  (sbt-slots 'sbt-09 (sbt-09-con :a 1) :a :b :c :f :g)
188  (1 q r s (t nil)))
189
190(deftest structure-boa-test-09/4
191  (sbt-slots 'sbt-09 (sbt-09-con :x 1) :a :b :c :f :g)
192  (p 1 r s (nil nil)))
193
194(deftest structure-boa-test-09/5
195  (sbt-slots 'sbt-09 (sbt-09-con :c 1) :a :b :c :f :g)
196  (p q 1 s (nil nil)))
197
198(deftest structure-boa-test-09/6
199  (sbt-slots 'sbt-09 (sbt-09-con :y 1) :a :b :c :e :f :g)
200  (p q r 1 s (nil nil)))
201
202(deftest structure-boa-test-09/7
203  (sbt-slots 'sbt-09 (sbt-09-con :z 1) :a :b :c :f :g)
204  (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
310;;; Keywords are in the correct package, and slot names are not
311;;; keyword parameters if not specified.
312
313(defstruct* (sbt-15 (:constructor sbt-15-con
314                                  (&key ((:x a) nil)
315                                        ((y  b) nil)
316                                        (c nil))))
317  a b c)
318
319(deftest structure-boa-test-15/1
320  (sbt-slots 'sbt-15 (sbt-15-con :x 1 'y 2 :c 3) :a :b :c)
321  (1 2 3))
322
323(deftest structure-boa-test-15/2
324  (signals-error (sbt-15-con :a 1) program-error)
325  t)
326
327(deftest structure-boa-test-15/3
328  (signals-error (sbt-15-con :b 1) program-error)
329  t)
330
331(deftest structure-boa-test-15/4
332  (signals-error (sbt-15-con 'x 1) program-error)
333  t)
334
335(deftest structure-boa-test-15/5
336  (signals-error (sbt-15-con :y 1) program-error)
337  t)
338
339(deftest structure-boa-test-15/6
340  (signals-error (sbt-15-con 'c 1) program-error)
341  t)
342
343(deftest structure-boa-test-15/7
344  (signals-error (sbt-15-con 'a 1) program-error)
345  t)
346
347(deftest structure-boa-test-15/8
348  (signals-error (sbt-15-con 'b 1) program-error)
349  t)
350
351
352;;; Default constructor w. BOA constructor, and error cases
353
354(defstruct* (sbt-16 (:constructor)
355                    (:constructor sbt-16-con (a b c)))
356   a b c)
357
358(deftest structure-boa-test-16/1
359  (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3) :a :b :c)
360  (1 2 3))
361
362(deftest structure-boa-test-16/2
363  (sbt-slots 'sbt-16 (sbt-16-con 4 5 6) :a :b :c)
364  (4 5 6))
365
366(deftest structure-boa-test-16/3
367  (signals-error (make-sbt-16 :d 1) program-error)
368  t)
369
370(deftest structure-boa-test-16/4
371  (signals-error (make-sbt-16 :a) program-error)
372  t)
373
374(deftest structure-boa-test-16/5
375  (signals-error (make-sbt-16 'a) program-error)
376  t)
377
378(deftest structure-boa-test-16/6
379  (signals-error (make-sbt-16 1 1) program-error)
380  t)
381
382(deftest structure-boa-test-16/7
383  (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3 :d 5 :allow-other-keys t)
384             :a :b :c)
385  (1 2 3))
386
387(deftest structure-boa-test-16/8
388  (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 1 :b 2 :c 3 :d 5)
389             :a :b :c)
390  (1 2 3))
391
392;;; :allow-other-keys turns off keyword error checking, including
393;;; invalid (nonsymbol) keyword arguments
394;;;(deftest structure-boa-test-16/9
395;;;  (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t
396;;;                                  :a 3 :b 6 :c 9 1000 1000)
397;;;          :a :b :c)
398;;;  (3 6 9))
399
400;;; Repeated keyword arguments are allowed; the leftmost one is used
401(deftest structure-boa-test-16/10
402  (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :a 2 :b 3 :b 4 :c 5 :c 6) :a :b :c)
403  (1 3 5))
404
405(deftest structure-boa-test-16/11
406  (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t
407                                  :allow-other-keys nil
408                                  :a 1 :b 2 :c 3 :d 5)
409             :a :b :c)
410  (1 2 3))
411
412;; Checking of # of keywords is suppressed when :allow-other-keys is true
413;;;(deftest structure-boa-test-16/12
414;;;  (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 3 :b 6 :c 9 :a)
415;;;          :a :b :c)
416;;;  (3 6 9))
417
418
419;;; Error test
420
421(def-macro-test struct.error.1 (defstruct nonexistent-structure-type a b c))
Note: See TracBrowser for help on using the repository browser.