/[gcl]/gcl/ansi-tests/structures-03.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/structures-03.lsp

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

revision 1.4 by pfdietz, Thu Jan 9 13:51:00 2003 UTC revision 1.5 by pfdietz, Fri Jan 10 04:07:00 2003 UTC
# Line 7  Line 7 
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
# Line 23  Line 24 
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))
# Line 51  Line 52 
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
# Line 65  Line 66 
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
# Line 79  Line 80 
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
# Line 103  Line 104 
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
# Line 129  Line 130 
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)
# Line 155  Line 156 
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)
# Line 206  Line 203 
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    

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

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