/[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.3 by pfdietz, Wed Jan 8 01:33:02 2003 UTC revision 1.4 by pfdietz, Thu Jan 9 13:51:00 2003 UTC
# Line 5  Line 5 
5    
6  (in-package :cl-test)  (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) "-" (string slotname))
11                               :cl-test)))
12              (funcall (symbol-function fun) s))))
13    
14  ;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists)  ;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists)
15    
16  (defstruct (sbt-01 (:constructor sbt-01-con (b a c)))  (defstruct (sbt-01 (:constructor sbt-01-con (b a c)))
# Line 121  Line 127 
127    x y z)    x y z)
128    
129    
130    ;;; Test presence flag in optional parameters
131    
132  (defstruct (sbt-07 (:constructor sbt-07-con  (defstruct (sbt-07 (:constructor sbt-07-con
133                                   (&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)
134                                              &aux (d (list (notnot a-p)                                              &aux (d (list (notnot a-p)
# Line 129  Line 137 
137    a b c d)    a b c d)
138    
139  (deftest structure-boa-test-07/1  (deftest structure-boa-test-07/1
140    (let ((s (sbt-07-con)))    (sbt-slots 'sbt-07 (sbt-07-con) :a :b :c :d)
141      (values (sbt-07-a s) (sbt-07-b s) (sbt-07-c s) (sbt-07-d s)))    (p q r (nil nil nil)))
   p q r (nil nil nil))  
142    
143  (deftest structure-boa-test-07/2  (deftest structure-boa-test-07/2
144    (let ((s (sbt-07-con 'x)))    (sbt-slots 'sbt-07 (sbt-07-con 'x) :a :b :c :d)
145      (values (sbt-07-a s) (sbt-07-b s) (sbt-07-c s) (sbt-07-d s)))    (x q r (t nil nil)))
   x q r (t nil nil))  
146    
147  (deftest structure-boa-test-07/3  (deftest structure-boa-test-07/3
148    (let ((s (sbt-07-con 'x 'y)))    (sbt-slots 'sbt-07 (sbt-07-con 'x 'y) :a :b :c :d)
149      (values (sbt-07-a s) (sbt-07-b s) (sbt-07-c s) (sbt-07-d s)))    (x y r (t t nil)))
   x y r (t t nil))  
150    
151  (deftest structure-boa-test-07/4  (deftest structure-boa-test-07/4
152    (let ((s (sbt-07-con 'x 'y 'z)))    (sbt-slots 'sbt-07 (sbt-07-con 'x 'y 'z) :a :b :c :d)
153      (values (sbt-07-a s) (sbt-07-b s) (sbt-07-c s) (sbt-07-d s)))    (x y z (t t t)))
154    x y z (t t t))  
155    
156    ;;; Keyword arguments
157    
158    (eval-when (compile load eval)
159      (ignore-errors
160        (defstruct (sbt-08 (:constructor sbt-08-con
161                                         (&key ((foo a)))))
162          a)))
163    
164    (deftest structure-boa-test-08/1
165      (sbt-slots 'sbt-08 (sbt-08-con :foo 10) :a)
166      (10))
167    
168    (eval-when (compile load eval)
169      (ignore-errors
170        (defstruct (sbt-09 (:constructor sbt-09-con
171                                         (&key (a 'p a-p)
172                                               ((x b) 'q)
173                                               (c 'r)
174                                               d
175                                               ((y e))
176                                               ((z f) 's z-p)
177                                               &aux (g (list (notnot a-p)
178                                                             (notnot z-p))))))
179          a b c d e f g)))
180    
181    (deftest structure-boa-test-09/1
182      (sbt-slots 'sbt-09 (sbt-09-con) :a :b :c :f :g)
183      (p q r s (nil nil)))
184    
185    (deftest structure-boa-test-09/2
186      (sbt-slots 'sbt-09 (sbt-09-con :d 1) :a :b :c :d :f :g)
187      (p q r 1 s (nil nil)))
188    
189    (deftest structure-boa-test-09/3
190      (sbt-slots 'sbt-09 (sbt-09-con :a 1) :a :b :c :f :g)
191      (1 q r s (t nil)))
192    
193    (deftest structure-boa-test-09/4
194      (sbt-slots 'sbt-09 (sbt-09-con :x 1) :a :b :c :f :g)
195      (p 1 r s (nil nil)))
196    
197    (deftest structure-boa-test-09/5
198      (sbt-slots 'sbt-09 (sbt-09-con :c 1) :a :b :c :f :g)
199      (p q 1 s (nil nil)))
200    
201    (deftest structure-boa-test-09/6
202      (sbt-slots 'sbt-09 (sbt-09-con :y 1) :a :b :c :e :f :g)
203      (p q r 1 s (nil nil)))
204    
205    (deftest structure-boa-test-09/7
206      (sbt-slots 'sbt-09 (sbt-09-con :z 1) :a :b :c :f :g)
207      (p q r 1 (nil t)))
208    
209    
210    
211    
212    

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

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