124 |
5 37 213) |
5 37 213) |
125 |
|
|
126 |
|
|
127 |
|
;;; Initforms in the lexical environment of the defclass |
128 |
|
|
129 |
|
(declaim (special *shared-init-var-02-init* |
130 |
|
*shared-init-var-02-query*)) |
131 |
|
|
132 |
|
(let ((ainit 0) (binit 0)) |
133 |
|
(flet ((%init (a b) (setf ainit a binit b)) |
134 |
|
(%query () (list ainit binit))) |
135 |
|
(setf *shared-init-var-02-init* #'%init |
136 |
|
*shared-init-var-02-query* #'%query) |
137 |
|
(defclass shared-init-class-02 () |
138 |
|
((a :initform (incf ainit) :initarg :a) |
139 |
|
(b :initform (incf binit) :initarg :b) |
140 |
|
(c :initarg :c) |
141 |
|
(d)) |
142 |
|
(:default-initargs :c 100)))) |
143 |
|
|
144 |
|
(deftest shared-initialize.10 |
145 |
|
(progn |
146 |
|
(funcall *shared-init-var-02-init* 5 10) |
147 |
|
(let ((obj (allocate-instance (find-class 'shared-init-class-02)))) |
148 |
|
(values |
149 |
|
(funcall *shared-init-var-02-query*) |
150 |
|
(eqt obj (shared-initialize obj t)) |
151 |
|
(slot-value obj 'a) |
152 |
|
(slot-value obj 'b) |
153 |
|
(map-slot-boundp* obj '(a b c d)) |
154 |
|
(funcall *shared-init-var-02-query*)))) |
155 |
|
(5 10) |
156 |
|
t |
157 |
|
6 11 |
158 |
|
(t t nil nil) |
159 |
|
(6 11)) |
160 |
|
|
161 |
|
(deftest shared-initialize.11 |
162 |
|
(progn |
163 |
|
(funcall *shared-init-var-02-init* 5 10) |
164 |
|
(let ((obj (allocate-instance (find-class 'shared-init-class-02)))) |
165 |
|
(values |
166 |
|
(funcall *shared-init-var-02-query*) |
167 |
|
(eqt obj (shared-initialize obj nil)) |
168 |
|
(map-slot-boundp* obj '(a b c d)) |
169 |
|
(funcall *shared-init-var-02-query*)))) |
170 |
|
(5 10) |
171 |
|
t |
172 |
|
(nil nil nil nil) |
173 |
|
(5 10)) |
174 |
|
|
175 |
|
(deftest shared-initialize.12 |
176 |
|
(progn |
177 |
|
(funcall *shared-init-var-02-init* 5 10) |
178 |
|
(let ((obj (allocate-instance (find-class 'shared-init-class-02)))) |
179 |
|
(values |
180 |
|
(funcall *shared-init-var-02-query*) |
181 |
|
(eqt obj (shared-initialize obj '(a))) |
182 |
|
(slot-value obj 'a) |
183 |
|
(map-slot-boundp* obj '(a b c d)) |
184 |
|
(funcall *shared-init-var-02-query*)))) |
185 |
|
(5 10) |
186 |
|
t |
187 |
|
6 |
188 |
|
(t nil nil nil) |
189 |
|
(6 10)) |
190 |
|
|
191 |
|
(deftest shared-initialize.13 |
192 |
|
(progn |
193 |
|
(funcall *shared-init-var-02-init* 5 10) |
194 |
|
(let ((obj (allocate-instance (find-class 'shared-init-class-02)))) |
195 |
|
(values |
196 |
|
(funcall *shared-init-var-02-query*) |
197 |
|
(eqt obj (shared-initialize obj '(b))) |
198 |
|
(slot-value obj 'b) |
199 |
|
(map-slot-boundp* obj '(a b c d)) |
200 |
|
(funcall *shared-init-var-02-query*)))) |
201 |
|
(5 10) |
202 |
|
t |
203 |
|
11 |
204 |
|
(nil t nil nil) |
205 |
|
(5 11)) |
206 |
|
|
207 |
|
(deftest shared-initialize.14 |
208 |
|
(progn |
209 |
|
(funcall *shared-init-var-02-init* 5 10) |
210 |
|
(let ((obj (allocate-instance (find-class 'shared-init-class-02)))) |
211 |
|
(values |
212 |
|
(funcall *shared-init-var-02-query*) |
213 |
|
(eqt obj (shared-initialize obj t :a 34 :b 49)) |
214 |
|
(map-slot-value obj '(a b)) |
215 |
|
(map-slot-boundp* obj '(a b c d)) |
216 |
|
(funcall *shared-init-var-02-query*)))) |
217 |
|
(5 10) |
218 |
|
t |
219 |
|
(34 49) |
220 |
|
(t t nil nil) |
221 |
|
(5 10)) |
222 |
|
|
223 |
|
(deftest shared-initialize.15 |
224 |
|
(progn |
225 |
|
(funcall *shared-init-var-02-init* 5 10) |
226 |
|
(let ((obj (allocate-instance (find-class 'shared-init-class-02)))) |
227 |
|
(values |
228 |
|
(funcall *shared-init-var-02-query*) |
229 |
|
(eqt obj (shared-initialize obj '(a b c d) :a 34 :b 49)) |
230 |
|
(map-slot-value obj '(a b)) |
231 |
|
(map-slot-boundp* obj '(a b c d)) |
232 |
|
(funcall *shared-init-var-02-query*)))) |
233 |
|
(5 10) |
234 |
|
t |
235 |
|
(34 49) |
236 |
|
(t t nil nil) |
237 |
|
(5 10)) |
238 |
|
|
239 |
|
;;; Defining new methods on shared-initialize |
240 |
|
|
241 |
|
(defstruct shared-init-class-03 |
242 |
|
a b c) |
243 |
|
|
244 |
|
(defmethod shared-initialize ((obj shared-init-class-03) |
245 |
|
slots-to-init |
246 |
|
&key |
247 |
|
(a nil a-p) |
248 |
|
(b nil b-p) |
249 |
|
(c nil c-p) |
250 |
|
&allow-other-keys) |
251 |
|
(declare (ignore slots-to-init)) |
252 |
|
(when a-p (setf (slot-value obj 'a) a)) |
253 |
|
(when b-p (setf (slot-value obj 'b) b)) |
254 |
|
(when c-p (setf (slot-value obj 'c) c)) |
255 |
|
obj) |
256 |
|
|
257 |
|
(deftest shared-initialize.16 |
258 |
|
(let ((obj (make-shared-init-class-03))) |
259 |
|
(values |
260 |
|
(eqt obj (shared-initialize obj nil :a 1 :b 5 :c 19)) |
261 |
|
(shared-init-class-03-a obj) |
262 |
|
(shared-init-class-03-b obj) |
263 |
|
(shared-init-class-03-c obj))) |
264 |
|
t 1 5 19) |
265 |
|
|
266 |
|
|