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))) |
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) |
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 |
|
|