1 |
|
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- |
2 |
|
;;; |
3 |
|
;;; ************************************************************************* |
4 |
|
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
5 |
|
;;; All rights reserved. |
6 |
|
;;; |
7 |
|
;;; Use and copying of this software and preparation of derivative works |
8 |
|
;;; based upon this software are permitted. Any distribution of this |
9 |
|
;;; software or derivative works must comply with all applicable United |
10 |
|
;;; States export control laws. |
11 |
|
;;; |
12 |
|
;;; This software is made available AS IS, and Xerox Corporation makes no |
13 |
|
;;; warranty about the software, its performance or its conformity to any |
14 |
|
;;; specification. |
15 |
|
;;; |
16 |
|
;;; Any person obtaining a copy of this software is requested to send their |
17 |
|
;;; name and post office or electronic mail address to: |
18 |
|
;;; CommonLoops Coordinator |
19 |
|
;;; Xerox PARC |
20 |
|
;;; 3333 Coyote Hill Rd. |
21 |
|
;;; Palo Alto, CA 94304 |
22 |
|
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
23 |
|
;;; |
24 |
|
;;; Suggestions, comments and requests for improvements are also welcome. |
25 |
|
;;; ************************************************************************* |
26 |
|
;;; |
27 |
|
;;; |
28 |
|
;;; This file defines the optimized make-instance functions. |
29 |
|
;;; |
30 |
|
|
31 |
|
(in-package :pcl) |
32 |
|
|
33 |
|
(defvar *compile-make-instance-functions-p* nil) |
34 |
|
|
35 |
|
(defun update-make-instance-function-table (&optional (class *the-class-t*)) |
36 |
|
(when (symbolp class) (setq class (find-class class))) |
37 |
|
(when (eq class *the-class-t*) (setq class *the-class-slot-object*)) |
38 |
|
(when (memq *the-class-slot-object* (class-precedence-list class)) |
39 |
|
(map-all-classes #'reset-class-initialize-info class))) |
40 |
|
|
41 |
|
(defun constant-symbol-p (form) |
42 |
|
(and (constantp form) |
43 |
|
(let ((object (eval form))) |
44 |
|
(and (symbolp object) |
45 |
|
(symbol-package object))))) |
46 |
|
|
47 |
|
(defvar *make-instance-function-keys* nil) |
48 |
|
|
49 |
|
(defun expand-make-instance-form (form) |
50 |
|
(let ((class (cadr form)) (initargs (cddr form)) |
51 |
|
(keys nil)(allow-other-keys-p nil) key value) |
52 |
|
(when (and (constant-symbol-p class) |
53 |
|
(let ((initargs-tail initargs)) |
54 |
|
(loop (when (null initargs-tail) (return t)) |
55 |
|
(unless (constant-symbol-p (car initargs-tail)) |
56 |
|
(return nil)) |
57 |
|
(setq key (eval (pop initargs-tail))) |
58 |
|
(setq value (pop initargs-tail)) |
59 |
|
(when (eq ':allow-other-keys key) |
60 |
|
(setq allow-other-keys-p value)) |
61 |
|
(push key keys)))) |
62 |
|
(let* ((class (eval class)) |
63 |
|
(keys (nreverse keys)) |
64 |
|
(key (list class keys allow-other-keys-p)) |
65 |
|
(sym (make-instance-function-symbol key))) |
66 |
|
(push key *make-instance-function-keys*) |
67 |
|
(when sym |
68 |
|
`(,sym ',class ,@initargs)))))) |
69 |
|
|
70 |
|
(defmacro expanding-make-instance-top-level (&rest forms &environment env) |
71 |
|
(let* ((*make-instance-function-keys* nil) |
72 |
|
(form (macroexpand `(expanding-make-instance ,@forms) env))) |
73 |
|
`(progn |
74 |
|
,@(when *make-instance-function-keys* |
75 |
|
`((get-make-instance-functions ',*make-instance-function-keys*))) |
76 |
|
,form))) |
77 |
|
|
78 |
|
(defmacro expanding-make-instance (&rest forms &environment env) |
79 |
|
`(progn |
80 |
|
,@(mapcar #'(lambda (form) |
81 |
|
(walk-form form env |
82 |
|
#'(lambda (subform context env) |
83 |
|
(declare (ignore env)) |
84 |
|
(or (and (eq context ':eval) |
85 |
|
(consp subform) |
86 |
|
(eq (car subform) 'make-instance) |
87 |
|
(expand-make-instance-form subform)) |
88 |
|
subform)))) |
89 |
|
forms))) |
90 |
|
|
91 |
|
(defmacro defconstructor |
92 |
|
(name class lambda-list &rest initialization-arguments) |
93 |
|
`(expanding-make-instance-top-level |
94 |
|
(defun ,name ,lambda-list |
95 |
|
(make-instance ',class ,@initialization-arguments)))) |
96 |
|
|
97 |
|
(defun get-make-instance-functions (key-list) |
98 |
|
(dolist (key key-list) |
99 |
|
(let* ((cell (find-class-cell (car key))) |
100 |
|
(make-instance-function-keys |
101 |
|
(find-class-cell-make-instance-function-keys cell)) |
102 |
|
(mif-key (cons (cadr key) (caddr key)))) |
103 |
|
(unless (find mif-key make-instance-function-keys |
104 |
|
:test #'equal) |
105 |
|
(push mif-key (find-class-cell-make-instance-function-keys cell)) |
106 |
|
(let ((class (find-class-cell-class cell))) |
107 |
|
(when (and class (not (forward-referenced-class-p class))) |
108 |
|
(update-initialize-info-internal |
109 |
|
(initialize-info class (car mif-key) nil (cdr mif-key)) |
110 |
|
'make-instance-function))))))) |
111 |
|
|
112 |
|
(defun make-instance-function-symbol (key) |
113 |
|
(let* ((class (car key)) |
114 |
|
(symbolp (symbolp class))) |
115 |
|
(when (or symbolp (classp class)) |
116 |
|
(let* ((class-name (if (symbolp class) class (class-name class))) |
117 |
|
(keys (cadr key)) |
118 |
|
(allow-other-keys-p (caddr key))) |
119 |
|
(when (and (or symbolp |
120 |
|
(and (symbolp class-name) |
121 |
|
(eq class (find-class class-name nil)))) |
122 |
|
(symbol-package class-name)) |
123 |
|
(let ((*package* *the-pcl-package*) |
124 |
|
(*print-length* nil) (*print-level* nil) |
125 |
|
(*print-circle* nil) (*print-case* :upcase) |
126 |
|
(*print-pretty* nil)) |
127 |
|
(intern (format nil "MAKE-INSTANCE ~S ~S ~S" |
128 |
|
class-name keys allow-other-keys-p)))))))) |
129 |
|
|
130 |
|
(defun make-instance-1 (class &rest initargs) |
131 |
|
(apply #'make-instance class initargs)) |
132 |
|
|
133 |
|
(defmacro define-cached-reader (type name trap) |
134 |
|
(let ((reader-name (intern (format nil "~A-~A" type name))) |
135 |
|
(cached-name (intern (format nil "~A-CACHED-~A" type name)))) |
136 |
|
`(defmacro ,reader-name (info) |
137 |
|
`(let ((value (,',cached-name ,info))) |
138 |
|
(if (eq value ':unknown) |
139 |
|
(progn |
140 |
|
(,',trap ,info ',',name) |
141 |
|
(,',cached-name ,info)) |
142 |
|
value))))) |
143 |
|
|
144 |
|
(eval-when (compile load eval) |
145 |
|
(defparameter initialize-info-cached-slots |
146 |
|
'(valid-p ; t or (:invalid key) |
147 |
|
ri-valid-p |
148 |
|
initargs-form-list |
149 |
|
combined-initargs-form-list |
150 |
|
new-keys |
151 |
|
default-initargs-function |
152 |
|
shared-initialize-t-function |
153 |
|
shared-initialize-nil-function |
154 |
|
constants |
155 |
|
combined-initialize-function ; allocate-instance + shared-initialize |
156 |
|
make-instance-function ; nil means use gf |
157 |
|
make-instance-function-symbol))) |
158 |
|
|
159 |
|
(defmacro define-initialize-info () |
160 |
|
(let ((cached-slot-names |
161 |
|
(mapcar #'(lambda (name) |
162 |
|
(intern (format nil "CACHED-~A" name))) |
163 |
|
initialize-info-cached-slots)) |
164 |
|
(cached-names |
165 |
|
(mapcar #'(lambda (name) |
166 |
|
(intern (format nil "~A-CACHED-~A" |
167 |
|
'initialize-info name))) |
168 |
|
initialize-info-cached-slots))) |
169 |
|
`(progn |
170 |
|
(defstruct initialize-info |
171 |
|
key wrapper |
172 |
|
,@(mapcar #'(lambda (name) |
173 |
|
`(,name :unknown)) |
174 |
|
cached-slot-names)) |
175 |
|
(defmacro reset-initialize-info-internal (info) |
176 |
|
`(progn |
177 |
|
,@(mapcar #'(lambda (cname) |
178 |
|
`(setf (,cname ,info) ':unknown)) |
179 |
|
',cached-names))) |
180 |
|
(defun initialize-info-bound-slots (info) |
181 |
|
(let ((slots nil)) |
182 |
|
,@(mapcar #'(lambda (name cached-name) |
183 |
|
`(unless (eq ':unknown (,cached-name info)) |
184 |
|
(push ',name slots))) |
185 |
|
initialize-info-cached-slots cached-names) |
186 |
|
slots)) |
187 |
|
,@(mapcar #'(lambda (name) |
188 |
|
`(define-cached-reader initialize-info ,name |
189 |
|
update-initialize-info-internal)) |
190 |
|
initialize-info-cached-slots)))) |
191 |
|
|
192 |
|
(define-initialize-info) |
193 |
|
|
194 |
|
(defvar *initialize-info-cache-class* nil) |
195 |
|
(defvar *initialize-info-cache-initargs* nil) |
196 |
|
(defvar *initialize-info-cache-info* nil) |
197 |
|
|
198 |
|
(defvar *revert-initialize-info-p* nil) |
199 |
|
|
200 |
|
(defun reset-initialize-info (info) |
201 |
|
(setf (initialize-info-wrapper info) |
202 |
|
(class-wrapper (car (initialize-info-key info)))) |
203 |
|
(let ((slots-to-revert (if *revert-initialize-info-p* |
204 |
|
(initialize-info-bound-slots info) |
205 |
|
'(make-instance-function)))) |
206 |
|
(reset-initialize-info-internal info) |
207 |
|
(dolist (slot slots-to-revert) |
208 |
|
(update-initialize-info-internal info slot)) |
209 |
|
info)) |
210 |
|
|
211 |
|
(defun reset-class-initialize-info (class) |
212 |
|
(reset-class-initialize-info-1 (class-initialize-info class))) |
213 |
|
|
214 |
|
(defun reset-class-initialize-info-1 (cell) |
215 |
|
(when (consp cell) |
216 |
|
(when (car cell) |
217 |
|
(reset-initialize-info (car cell))) |
218 |
|
(let ((alist (cdr cell))) |
219 |
|
(dolist (a alist) |
220 |
|
(reset-class-initialize-info-1 (cdr a)))))) |
221 |
|
|
222 |
|
(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg) |
223 |
|
(let ((info nil)) |
224 |
|
(if (and (eq *initialize-info-cache-class* class) |
225 |
|
(eq *initialize-info-cache-initargs* initargs)) |
226 |
|
(setq info *initialize-info-cache-info*) |
227 |
|
(let ((initargs-tail initargs) |
228 |
|
allow-other-keys-p |
229 |
|
(cell (or (class-initialize-info class) |
230 |
|
(setf (class-initialize-info class) (cons nil nil))))) |
231 |
|
(loop (when (null initargs-tail) (return nil)) |
232 |
|
(let ((keyword (pop initargs-tail)) |
233 |
|
(alist-cell cell)) |
234 |
|
(when plist-p |
235 |
|
;; leftmost occurrence only |
236 |
|
;; FIXME check that this is correct |
237 |
|
(if (and (not allow-other-keys-p) (eq keyword :allow-other-keys)) |
238 |
|
(progn |
239 |
|
(setq allow-other-keys-arg (pop initargs-tail)) |
240 |
|
(setq allow-other-keys-p t)) |
241 |
|
(pop initargs-tail))) |
242 |
|
(loop (let ((alist (cdr alist-cell))) |
243 |
|
(when (null alist) |
244 |
|
(setq cell (cons nil nil)) |
245 |
|
(setf (cdr alist-cell) (list (cons keyword cell))) |
246 |
|
(return nil)) |
247 |
|
(when (eql keyword (caar alist)) |
248 |
|
(setq cell (cdar alist)) |
249 |
|
(return nil)) |
250 |
|
(setq alist-cell alist))))) |
251 |
|
(setq info (or (car cell) |
252 |
|
(setf (car cell) (make-initialize-info)))))) |
253 |
|
(let ((wrapper (initialize-info-wrapper info))) |
254 |
|
(unless (eq wrapper (class-wrapper class)) |
255 |
|
(unless wrapper |
256 |
|
(let* ((initargs-tail initargs) |
257 |
|
(klist-cell (list nil)) |
258 |
|
(klist-tail klist-cell)) |
259 |
|
(loop (when (null initargs-tail) (return nil)) |
260 |
|
(let ((key (pop initargs-tail))) |
261 |
|
(setf (cdr klist-tail) (list key))) |
262 |
|
(setf klist-tail (cdr klist-tail)) |
263 |
|
(when plist-p (pop initargs-tail))) |
264 |
|
(setf (initialize-info-key info) |
265 |
|
(list class (cdr klist-cell) allow-other-keys-arg)))) |
266 |
|
(reset-initialize-info info))) |
267 |
|
(setq *initialize-info-cache-class* class) |
268 |
|
(setq *initialize-info-cache-initargs* initargs) |
269 |
|
(setq *initialize-info-cache-info* info) |
270 |
|
info)) |
271 |
|
|
272 |
|
(defun update-initialize-info-internal (info name) |
273 |
|
(let* ((key (initialize-info-key info)) |
274 |
|
(class (car key)) |
275 |
|
(keys (cadr key)) |
276 |
|
(allow-other-keys-arg (caddr key))) |
277 |
|
(ecase name |
278 |
|
((initargs-form-list new-keys) |
279 |
|
(multiple-value-bind (initargs-form-list new-keys) |
280 |
|
(make-default-initargs-form-list class keys) |
281 |
|
(setf (initialize-info-cached-initargs-form-list info) initargs-form-list) |
282 |
|
(setf (initialize-info-cached-new-keys info) new-keys))) |
283 |
|
((combined-initargs-form-list) |
284 |
|
(multiple-value-bind (initargs-form-list new-keys) |
285 |
|
(make-default-initargs-form-list class keys nil) |
286 |
|
(setf (initialize-info-cached-combined-initargs-form-list info) |
287 |
|
initargs-form-list) |
288 |
|
(setf (initialize-info-cached-new-keys info) new-keys))) |
289 |
|
((default-initargs-function) |
290 |
|
(let ((initargs-form-list (initialize-info-initargs-form-list info))) |
291 |
|
(setf (initialize-info-cached-default-initargs-function info) |
292 |
|
(initialize-instance-simple-function |
293 |
|
'default-initargs-function info |
294 |
|
class initargs-form-list)))) |
295 |
|
((valid-p ri-valid-p) |
296 |
|
(flet ((compute-valid-p (methods) |
297 |
|
(or (not (null allow-other-keys-arg)) |
298 |
|
(multiple-value-bind (legal allow-other-keys) |
299 |
|
(check-initargs-values class methods) |
300 |
|
(or (not (null allow-other-keys)) |
301 |
|
(dolist (key keys t) |
302 |
|
(unless (or (member key legal) (eq key :allow-other-keys)) |
303 |
|
(return (cons :invalid key))))))))) |
304 |
|
(let ((proto (class-prototype class))) |
305 |
|
(setf (initialize-info-cached-valid-p info) |
306 |
|
(compute-valid-p |
307 |
|
(list (list* 'allocate-instance class nil) |
308 |
|
(list* 'initialize-instance proto nil) |
309 |
|
(list* 'shared-initialize proto t nil)))) |
310 |
|
(setf (initialize-info-cached-ri-valid-p info) |
311 |
|
(compute-valid-p |
312 |
|
(list (list* 'reinitialize-instance proto nil) |
313 |
|
(list* 'shared-initialize proto nil nil))))))) |
314 |
|
((shared-initialize-t-function) |
315 |
|
(multiple-value-bind (initialize-form-list ignore) |
316 |
|
(make-shared-initialize-form-list class keys t nil) |
317 |
|
(declare (ignore ignore)) |
318 |
|
(setf (initialize-info-cached-shared-initialize-t-function info) |
319 |
|
(initialize-instance-simple-function |
320 |
|
'shared-initialize-t-function info |
321 |
|
class initialize-form-list)))) |
322 |
|
((shared-initialize-nil-function) |
323 |
|
(multiple-value-bind (initialize-form-list ignore) |
324 |
|
(make-shared-initialize-form-list class keys nil nil) |
325 |
|
(declare (ignore ignore)) |
326 |
|
(setf (initialize-info-cached-shared-initialize-nil-function info) |
327 |
|
(initialize-instance-simple-function |
328 |
|
'shared-initialize-nil-function info |
329 |
|
class initialize-form-list)))) |
330 |
|
((constants combined-initialize-function) |
331 |
|
(let ((initargs-form-list (initialize-info-combined-initargs-form-list info)) |
332 |
|
(new-keys (initialize-info-new-keys info))) |
333 |
|
(multiple-value-bind (initialize-form-list constants) |
334 |
|
(make-shared-initialize-form-list class new-keys t t) |
335 |
|
(setf (initialize-info-cached-constants info) constants) |
336 |
|
(setf (initialize-info-cached-combined-initialize-function info) |
337 |
|
(initialize-instance-simple-function |
338 |
|
'combined-initialize-function info |
339 |
|
class (append initargs-form-list initialize-form-list)))))) |
340 |
|
((make-instance-function-symbol) |
341 |
|
(setf (initialize-info-cached-make-instance-function-symbol info) |
342 |
|
(make-instance-function-symbol key))) |
343 |
|
((make-instance-function) |
344 |
|
(let* ((function (get-make-instance-function key)) |
345 |
|
(symbol (initialize-info-make-instance-function-symbol info))) |
346 |
|
(setf (initialize-info-cached-make-instance-function info) function) |
347 |
|
(when symbol (setf (gdefinition symbol) |
348 |
|
(or function #'make-instance-1))))))) |
349 |
|
info) |
350 |
|
|
351 |
|
(defun get-make-instance-function (key) |
352 |
|
(let* ((class (car key)) |
353 |
|
(keys (cadr key))) |
354 |
|
(unless (eq *boot-state* 'complete) |
355 |
|
(return-from get-make-instance-function nil)) |
356 |
|
(when (symbolp class) |
357 |
|
(setq class (find-class class))) |
358 |
|
(when (classp class) |
359 |
|
(unless (class-finalized-p class) (finalize-inheritance class))) |
360 |
|
(let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys)) |
361 |
|
(class-and-initargs (list* class initargs)) |
362 |
|
(make-instance (gdefinition 'make-instance)) |
363 |
|
(make-instance-methods |
364 |
|
(compute-applicable-methods make-instance class-and-initargs)) |
365 |
|
(std-mi-meth (find-standard-ii-method make-instance-methods 'class)) |
366 |
|
(class+initargs (list class initargs)) |
367 |
|
(default-initargs (gdefinition 'default-initargs)) |
368 |
|
(default-initargs-methods |
369 |
|
(compute-applicable-methods default-initargs class+initargs)) |
370 |
|
(proto (and (classp class) (class-prototype class))) |
371 |
|
(initialize-instance-methods |
372 |
|
(when proto |
373 |
|
(compute-applicable-methods (gdefinition 'initialize-instance) |
374 |
|
(list* proto initargs)))) |
375 |
|
(shared-initialize-methods |
376 |
|
(when proto |
377 |
|
(compute-applicable-methods (gdefinition 'shared-initialize) |
378 |
|
(list* proto t initargs))))) |
379 |
|
(when (null make-instance-methods) |
380 |
|
(return-from get-make-instance-function |
381 |
|
#'(lambda (class &rest initargs) |
382 |
|
(apply #'no-applicable-method make-instance class initargs)))) |
383 |
|
(unless (and (null (cdr make-instance-methods)) |
384 |
|
(eq (car make-instance-methods) std-mi-meth) |
385 |
|
(null (cdr default-initargs-methods)) |
386 |
|
(eq (car (method-specializers (car default-initargs-methods))) |
387 |
|
*the-class-slot-class*) |
388 |
|
(flet ((check-meth (meth) |
389 |
|
(let ((quals (method-qualifiers meth))) |
390 |
|
(if (null quals) |
391 |
|
(eq (car (method-specializers meth)) |
392 |
|
*the-class-slot-object*) |
393 |
|
(and (null (cdr quals)) |
394 |
|
(or (eq (car quals) ':before) |
395 |
|
(eq (car quals) ':after))))))) |
396 |
|
(and (every #'check-meth initialize-instance-methods) |
397 |
|
(every #'check-meth shared-initialize-methods)))) |
398 |
|
(return-from get-make-instance-function nil)) |
399 |
|
(get-make-instance-function-internal |
400 |
|
class key (default-initargs class initargs) |
401 |
|
initialize-instance-methods shared-initialize-methods)))) |
402 |
|
|
403 |
|
(defun get-make-instance-function-internal (class key initargs |
404 |
|
initialize-instance-methods |
405 |
|
shared-initialize-methods) |
406 |
|
(let* (#|(class-key (car key))|# |
407 |
|
(keys (cadr key)) |
408 |
|
(allow-other-keys-p (caddr key)) |
409 |
|
(allocate-instance-methods |
410 |
|
(compute-applicable-methods (gdefinition 'allocate-instance) |
411 |
|
(list* class initargs)))) |
412 |
|
(unless allow-other-keys-p |
413 |
|
(unless (check-initargs-1 |
414 |
|
class initargs |
415 |
|
(append allocate-instance-methods |
416 |
|
initialize-instance-methods |
417 |
|
shared-initialize-methods) |
418 |
|
t nil) |
419 |
|
(return-from get-make-instance-function-internal nil))) |
420 |
|
(cond ((or (cdr allocate-instance-methods) |
421 |
|
(some #'complicated-instance-creation-method |
422 |
|
initialize-instance-methods) |
423 |
|
(some #'complicated-instance-creation-method |
424 |
|
shared-initialize-methods)) |
425 |
|
(make-instance-function-complex |
426 |
|
key class keys |
427 |
|
initialize-instance-methods shared-initialize-methods)) |
428 |
|
(t #|(or (not (standard-class-p class)) (not (symbolp class-key)) |
429 |
|
initialize-instance-methods shared-initialize-methods)|# |
430 |
|
(make-instance-function-simple |
431 |
|
key class keys |
432 |
|
initialize-instance-methods shared-initialize-methods)) |
433 |
|
#|(t |
434 |
|
(make-instance-function-basic |
435 |
|
key class keys))|#))) |
436 |
|
|
437 |
|
(defun complicated-instance-creation-method (m) |
438 |
|
(let ((qual (method-qualifiers m))) |
439 |
|
(if qual |
440 |
|
(not (and (null (cdr qual)) (eq (car qual) ':after))) |
441 |
|
(let ((specl (car (method-specializers m)))) |
442 |
|
(or (not (classp specl)) |
443 |
|
(not (eq 'slot-object (class-name specl)))))))) |
444 |
|
|
445 |
|
(defun find-standard-ii-method (methods class-names) |
446 |
|
(dolist (m methods) |
447 |
|
(when (null (method-qualifiers m)) |
448 |
|
(let ((specl (car (method-specializers m)))) |
449 |
|
(when (and (classp specl) |
450 |
|
(if (listp class-names) |
451 |
|
(member (class-name specl) class-names) |
452 |
|
(eq (class-name specl) class-names))) |
453 |
|
(return m)))))) |
454 |
|
|
455 |
|
(defmacro call-initialize-function (initialize-function instance initargs) |
456 |
|
`(let ((.function. ,initialize-function)) |
457 |
|
(if (and (consp .function.) |
458 |
|
(eq (car .function.) 'call-initialize-instance-simple)) |
459 |
|
(initialize-instance-simple (cadr .function.) (caddr .function.) |
460 |
|
,instance ,initargs) |
461 |
|
(funcall (the function .function.) ,instance ,initargs)))) |
462 |
|
|
463 |
|
(defmacro copy-slots (slots-init) |
464 |
|
#-(or lucid cmu17) |
465 |
|
`(copy-seq ,slots-init) |
466 |
|
#+(or lucid cmu17) |
467 |
|
`(let* ((init ,slots-init) |
468 |
|
(len (length init)) |
469 |
|
(v #+lucid (system:new-simple-vector len) |
470 |
|
#+cmu17 (lisp::allocate-vector #.vm:simple-vector-type len len))) |
471 |
|
(declare (simple-vector init v) |
472 |
|
(type #-cmu fixnum #+cmu lisp::index len)) |
473 |
|
(dotimes (i len v) |
474 |
|
(declare (type #-cmu fixnum #+cmu lisp::index i)) |
475 |
|
(setf (svref v i) (svref init i))))) |
476 |
|
|
477 |
|
(defmacro allocate-standard-instance--macro (wrapper slots-init) |
478 |
|
#-new-kcl-wrapper |
479 |
|
`(let ((instance (%%allocate-instance--class))) |
480 |
|
(setf (std-instance-wrapper instance) ,wrapper) |
481 |
|
(setf (std-instance-slots instance) (copy-slots ,slots-init)) |
482 |
|
instance) |
483 |
|
#+new-kcl-wrapper |
484 |
|
`(allocate-standard-instance ,wrapper ,slots-init)) |
485 |
|
|
486 |
|
(defmacro with-make-instance-function-valid-p-check (initargs-form &body body) |
487 |
|
`(let ((current-class (if class-cell |
488 |
|
(find-class-from-cell class-key class-cell) |
489 |
|
class-symbol))) |
490 |
|
(if (or (not (eq current-class class-symbol)) |
491 |
|
(invalid-wrapper-p wrapper)) |
492 |
|
(make-instance-function-trap current-class ,initargs-form) |
493 |
|
(progn ,@body)))) |
494 |
|
|
495 |
|
(defun make-instance-function-trap (class-symbol initargs) |
496 |
|
(let* ((info (initialize-info class-symbol initargs)) |
497 |
|
(fn (initialize-info-make-instance-function info))) |
498 |
|
(declare (type function fn)) |
499 |
|
(funcall fn class-symbol initargs))) |
500 |
|
|
501 |
|
(defun make-instance-function-simple (key class keys |
502 |
|
initialize-instance-methods |
503 |
|
shared-initialize-methods) |
504 |
|
(let* ((class-key (car key)) |
505 |
|
(class-cell (when (symbolp class-key) |
506 |
|
(find-class-cell class-key nil))) |
507 |
|
(wrapper (class-wrapper class)) |
508 |
|
(lwrapper (list wrapper)) |
509 |
|
(allocate-function |
510 |
|
(cond ((structure-class-p class) |
511 |
|
#'allocate-structure-instance) |
512 |
|
((standard-class-p class) |
513 |
|
#'allocate-standard-instance) |
514 |
|
((funcallable-standard-class-p class) |
515 |
|
#'allocate-funcallable-instance) |
516 |
|
(t |
517 |
|
(error "error in make-instance-function-simple")))) |
518 |
|
(allocate-macro |
519 |
|
(cond ((standard-class-p class) |
520 |
|
'allocate-standard-instance--macro))) |
521 |
|
(std-si-meth (find-standard-ii-method shared-initialize-methods |
522 |
|
'slot-object)) |
523 |
|
(shared-initfns |
524 |
|
(nreverse (mapcar #'(lambda (method) |
525 |
|
(make-effective-method-function |
526 |
|
#'shared-initialize |
527 |
|
`(call-method ,method nil) |
528 |
|
nil lwrapper)) |
529 |
|
(remove std-si-meth shared-initialize-methods)))) |
530 |
|
(std-ii-meth (find-standard-ii-method initialize-instance-methods |
531 |
|
'slot-object)) |
532 |
|
(initialize-initfns |
533 |
|
(nreverse (mapcar #'(lambda (method) |
534 |
|
(make-effective-method-function |
535 |
|
#'initialize-instance |
536 |
|
`(call-method ,method nil) |
537 |
|
nil lwrapper)) |
538 |
|
(remove std-ii-meth |
539 |
|
initialize-instance-methods))))) |
540 |
|
(multiple-value-bind (initialize-function constants) |
541 |
|
(get-simple-initialization-function class keys (caddr key)) |
542 |
|
(if (eq allocate-macro 'allocate-standard-instance--macro) |
543 |
|
#'(lambda (class-symbol &rest initargs) |
544 |
|
(with-make-instance-function-valid-p-check initargs |
545 |
|
(let ((instance |
546 |
|
(allocate-standard-instance--macro wrapper constants))) |
547 |
|
(call-initialize-function initialize-function instance initargs) |
548 |
|
(dolist (fn shared-initfns) |
549 |
|
(invoke-effective-method-function fn t instance t initargs)) |
550 |
|
(dolist (fn initialize-initfns) |
551 |
|
(invoke-effective-method-function fn t instance initargs)) |
552 |
|
instance))) |
553 |
|
#'(lambda (class-symbol &rest initargs) |
554 |
|
(with-make-instance-function-valid-p-check initargs |
555 |
|
(let* ((instance (funcall allocate-function wrapper constants)) |
556 |
|
(initargs (call-initialize-function initialize-function |
557 |
|
instance initargs))) |
558 |
|
(dolist (fn shared-initfns) |
559 |
|
(invoke-effective-method-function fn t instance t initargs)) |
560 |
|
(dolist (fn initialize-initfns) |
561 |
|
(invoke-effective-method-function fn t instance initargs)) |
562 |
|
instance))))))) |
563 |
|
|
564 |
|
(defun make-instance-function-complex (key class keys |
565 |
|
initialize-instance-methods |
566 |
|
shared-initialize-methods) |
567 |
|
(multiple-value-bind (initargs-function initialize-function) |
568 |
|
(get-complex-initialization-functions class keys (caddr key)) |
569 |
|
(let* ((class-key (car key)) |
570 |
|
(class-cell (when (symbolp class-key) |
571 |
|
(find-class-cell class-key nil))) |
572 |
|
(wrapper (class-wrapper class)) |
573 |
|
(shared-initialize |
574 |
|
(get-secondary-dispatch-function |
575 |
|
#'shared-initialize shared-initialize-methods |
576 |
|
`((class-eq ,class) t t) |
577 |
|
`((,(find-standard-ii-method shared-initialize-methods 'slot-object) |
578 |
|
,#'(lambda (instance init-type &rest initargs) |
579 |
|
(declare (ignore init-type)) |
580 |
|
#+copy-&rest-arg (setq initargs (copy-list initargs)) |
581 |
|
(call-initialize-function initialize-function |
582 |
|
instance initargs) |
583 |
|
instance))) |
584 |
|
(list wrapper *the-wrapper-of-t* *the-wrapper-of-t*))) |
585 |
|
(initialize-instance |
586 |
|
(get-secondary-dispatch-function |
587 |
|
#'initialize-instance initialize-instance-methods |
588 |
|
`((class-eq ,class) t) |
589 |
|
`((,(find-standard-ii-method initialize-instance-methods 'slot-object) |
590 |
|
,#'(lambda (instance &rest initargs) |
591 |
|
#+copy-&rest-arg (setq initargs (copy-list initargs)) |
592 |
|
(invoke-effective-method-function |
593 |
|
shared-initialize t instance t initargs)))) |
594 |
|
(list wrapper *the-wrapper-of-t*)))) |
595 |
|
#'(lambda (class-symbol &rest initargs) |
596 |
|
(with-make-instance-function-valid-p-check initargs |
597 |
|
(let* ((initargs (call-initialize-function initargs-function |
598 |
|
nil initargs)) |
599 |
|
(instance (apply #'allocate-instance class initargs))) |
600 |
|
(invoke-effective-method-function |
601 |
|
initialize-instance t instance initargs) |
602 |
|
instance)))))) |
603 |
|
|
604 |
|
#| |
605 |
|
(defmacro call-initialize-function (initialize-function instance initargs) |
606 |
|
`(let ((.function. ,initialize-function)) |
607 |
|
(if (and (consp .function.) |
608 |
|
(eq (car .function.) 'call-initialize-instance-simple)) |
609 |
|
(initialize-instance-simple (cadr .function.) (caddr .function.) |
610 |
|
,instance ,initargs) |
611 |
|
(funcall (the function .function.) ,instance ,initargs)))) |
612 |
|
|
613 |
|
(defun make-instance-function-basic (key class keys) |
614 |
|
(let* ((class-key (car key)) |
615 |
|
(class-cell (find-class-cell class-key nil)) |
616 |
|
(wrapper (class-wrapper class))) |
617 |
|
(multiple-value-bind (initialize-function constants) |
618 |
|
(get-simple-initialization-function class keys (caddr key)) |
619 |
|
#'(lambda (class-symbol &rest initargs) |
620 |
|
(let ((current-class (find-class-from-cell class-key class-cell))) |
621 |
|
(if (or (not (eq current-class class-symbol)) |
622 |
|
(invalid-wrapper-p wrapper)) |
623 |
|
(make-instance-function-trap current-class initargs-form) |
624 |
|
(let ((instance |
625 |
|
(allocate-standard-instance--macro wrapper constants))) |
626 |
|
(call-initialize-function initialize-function instance initargs) |
627 |
|
instance))))))) |
628 |
|
|# |
629 |
|
|
630 |
|
(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg) |
631 |
|
(let ((info (initialize-info class keys nil allow-other-keys-arg))) |
632 |
|
(values (initialize-info-combined-initialize-function info) |
633 |
|
(initialize-info-constants info)))) |
634 |
|
|
635 |
|
(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg |
636 |
|
separate-p) |
637 |
|
(let* ((info (initialize-info class keys nil allow-other-keys-arg)) |
638 |
|
(default-initargs-function (initialize-info-default-initargs-function info))) |
639 |
|
(if separate-p |
640 |
|
(values default-initargs-function |
641 |
|
(initialize-info-shared-initialize-t-function info)) |
642 |
|
(values default-initargs-function |
643 |
|
(initialize-info-shared-initialize-t-function |
644 |
|
(initialize-info class (initialize-info-new-keys info) |
645 |
|
nil allow-other-keys-arg)))))) |
646 |
|
|
647 |
|
(defun add-forms (forms forms-list) |
648 |
|
(when forms |
649 |
|
(setq forms (copy-list forms)) |
650 |
|
(if (null (car forms-list)) |
651 |
|
(setf (car forms-list) forms) |
652 |
|
(setf (cddr forms-list) forms)) |
653 |
|
(setf (cdr forms-list) (last forms))) |
654 |
|
(car forms-list)) |
655 |
|
|
656 |
|
(defun make-default-initargs-form-list (class keys &optional (separate-p t)) |
657 |
|
(let ((initargs-form-list (cons nil nil)) |
658 |
|
(default-initargs (class-default-initargs class)) |
659 |
|
(nkeys keys) |
660 |
|
(slots-alist |
661 |
|
(mapcan #'(lambda (slot) |
662 |
|
(mapcar #'(lambda (arg) |
663 |
|
(cons arg slot)) |
664 |
|
(slot-definition-initargs slot))) |
665 |
|
(class-slots class))) |
666 |
|
(nslots nil)) |
667 |
|
(dolist (key nkeys) |
668 |
|
(pushnew (cdr (assoc key slots-alist)) nslots)) |
669 |
|
(dolist (default default-initargs) |
670 |
|
(let* ((key (car default)) |
671 |
|
(slot (cdr (assoc key slots-alist))) |
672 |
|
(function (cadr default))) |
673 |
|
(unless (member slot nslots) |
674 |
|
(add-forms `((funcall ,function) (push-initarg ,key)) |
675 |
|
initargs-form-list) |
676 |
|
(push key nkeys) |
677 |
|
(push slot nslots)))) |
678 |
|
(when separate-p |
679 |
|
(add-forms `((update-initialize-info-cache |
680 |
|
,class ,(initialize-info class nkeys nil))) |
681 |
|
initargs-form-list)) |
682 |
|
(add-forms `((finish-pushing-initargs)) |
683 |
|
initargs-form-list) |
684 |
|
(values (car initargs-form-list) nkeys))) |
685 |
|
|
686 |
|
(defun make-shared-initialize-form-list (class keys si-slot-names simple-p) |
687 |
|
(let* ((initialize-form-list (cons nil nil)) |
688 |
|
(type (cond ((structure-class-p class) |
689 |
|
'structure) |
690 |
|
((standard-class-p class) |
691 |
|
'standard) |
692 |
|
((funcallable-standard-class-p class) |
693 |
|
'funcallable) |
694 |
|
(t (error "error in make-shared-initialize-form-list")))) |
695 |
|
(wrapper (class-wrapper class)) |
696 |
|
(constants (when simple-p |
697 |
|
(make-array (wrapper-no-of-instance-slots wrapper) |
698 |
|
':initial-element *slot-unbound*))) |
699 |
|
(slots (class-slots class)) |
700 |
|
(slot-names (mapcar #'slot-definition-name slots)) |
701 |
|
(slots-key (mapcar #'(lambda (slot) |
702 |
|
(let ((index most-positive-fixnum)) |
703 |
|
(dolist (key (slot-definition-initargs slot)) |
704 |
|
(let ((pos (position key keys))) |
705 |
|
(when pos (setq index (min index pos))))) |
706 |
|
(cons slot index))) |
707 |
|
slots)) |
708 |
|
(slots (stable-sort slots-key #'< :key #'cdr))) |
709 |
|
(let ((n-popped 0)) |
710 |
|
(declare (fixnum n-popped)) |
711 |
|
(dolist (slot+index slots) |
712 |
|
(let* ((slot (car slot+index)) |
713 |
|
(name (slot-definition-name slot)) |
714 |
|
(npop (1+ (- (the fixnum (cdr slot+index)) n-popped)))) |
715 |
|
(declare (fixnum npop)) |
716 |
|
(unless (eql (cdr slot+index) most-positive-fixnum) |
717 |
|
(let* ((pv-offset (1+ (position name slot-names)))) |
718 |
|
(add-forms `(,@(when (plusp npop) |
719 |
|
`((pop-initargs ,(the fixnum (* 2 npop))))) |
720 |
|
(instance-set ,pv-offset ,slot)) |
721 |
|
initialize-form-list)) |
722 |
|
(incf n-popped npop))))) |
723 |
|
(dolist (slot+index slots) |
724 |
|
(let* ((slot (car slot+index)) |
725 |
|
(name (slot-definition-name slot))) |
726 |
|
(when (and (eql (cdr slot+index) most-positive-fixnum) |
727 |
|
(or (eq si-slot-names 't) |
728 |
|
(member name si-slot-names))) |
729 |
|
(let* ((initform (slot-definition-initform slot)) |
730 |
|
(initfunction (slot-definition-initfunction slot)) |
731 |
|
(location (unless (eq type 'structure) |
732 |
|
(slot-definition-location slot))) |
733 |
|
(pv-offset (1+ (position name slot-names))) |
734 |
|
(forms (cond ((null initfunction) |
735 |
|
nil) |
736 |
|
((constantp initform) |
737 |
|
(let ((value (funcall initfunction))) |
738 |
|
(if (and simple-p (integerp location)) |
739 |
|
(progn (setf (svref constants location) value) |
740 |
|
nil) |
741 |
|
`((const ,value) |
742 |
|
(instance-set ,pv-offset ,slot))))) |
743 |
|
(t |
744 |
|
`((funcall ,(slot-definition-initfunction slot)) |
745 |
|
(instance-set ,pv-offset ,slot)))))) |
746 |
|
(add-forms `(,@(unless (or simple-p (null forms)) |
747 |
|
`((skip-when-instance-boundp ,pv-offset ,slot |
748 |
|
,(length forms)))) |
749 |
|
,@forms) |
750 |
|
initialize-form-list))))) |
751 |
|
(values (car initialize-form-list) constants))) |
752 |
|
|
753 |
|
(defvar *class-pv-table-table* (make-hash-table :test 'eq)) |
754 |
|
|
755 |
|
(defun get-pv-cell-for-class (class) |
756 |
|
(let* ((slot-names (mapcar #'slot-definition-name (class-slots class))) |
757 |
|
(slot-name-lists (list (cons nil slot-names))) |
758 |
|
(pv-table (gethash class *class-pv-table-table*))) |
759 |
|
(unless (and pv-table |
760 |
|
(equal slot-name-lists (pv-table-slot-name-lists pv-table))) |
761 |
|
(setq pv-table (intern-pv-table :slot-name-lists slot-name-lists)) |
762 |
|
(setf (gethash class *class-pv-table-table*) pv-table)) |
763 |
|
(pv-table-lookup pv-table (class-wrapper class)))) |
764 |
|
|
765 |
|
(defvar *initialize-instance-simple-alist* nil) |
766 |
|
(defvar *note-iis-entry-p* nil) |
767 |
|
|
768 |
|
(defvar *compiled-initialize-instance-simple-functions* |
769 |
|
(make-hash-table :test #'equal)) |
770 |
|
|
771 |
|
(defun initialize-instance-simple-function (use info class form-list) |
772 |
|
(let* ((pv-cell (get-pv-cell-for-class class)) |
773 |
|
(key (initialize-info-key info)) |
774 |
|
(sf-key (list* use (class-name (car key)) (cdr key)))) |
775 |
|
(if (or *compile-make-instance-functions-p* |
776 |
|
(gethash sf-key *compiled-initialize-instance-simple-functions*)) |
777 |
|
(multiple-value-bind (form args) |
778 |
|
(form-list-to-lisp pv-cell form-list) |
779 |
|
(let ((entry (assoc form *initialize-instance-simple-alist* |
780 |
|
:test #'equal))) |
781 |
|
(setf (gethash sf-key |
782 |
|
*compiled-initialize-instance-simple-functions*) |
783 |
|
t) |
784 |
|
(if entry |
785 |
|
(setf (cdddr entry) (union (list sf-key) (cdddr entry) |
786 |
|
:test #'equal)) |
787 |
|
(progn |
788 |
|
(setq entry (list* form nil nil (list sf-key))) |
789 |
|
(setq *initialize-instance-simple-alist* |
790 |
|
(nconc *initialize-instance-simple-alist* |
791 |
|
(list entry))))) |
792 |
|
(unless (or *note-iis-entry-p* (cadr entry)) |
793 |
|
(setf (cadr entry) (compile-lambda (car entry)))) |
794 |
|
(if (cadr entry) |
795 |
|
(apply (the function (cadr entry)) args) |
796 |
|
`(call-initialize-instance-simple ,pv-cell ,form-list)))) |
797 |
|
#|| |
798 |
|
#'(lambda (instance initargs) |
799 |
|
(initialize-instance-simple pv-cell form-list instance initargs)) |
800 |
|
||# |
801 |
|
`(call-initialize-instance-simple ,pv-cell ,form-list)))) |
802 |
|
|
803 |
|
(defun load-precompiled-iis-entry (form function system uses) |
804 |
|
(let ((entry (assoc form *initialize-instance-simple-alist* |
805 |
|
:test #'equal))) |
806 |
|
(unless entry |
807 |
|
(setq entry (list* form nil nil nil)) |
808 |
|
(setq *initialize-instance-simple-alist* |
809 |
|
(nconc *initialize-instance-simple-alist* |
810 |
|
(list entry)))) |
811 |
|
(setf (cadr entry) function) |
812 |
|
(setf (caddr entry) system) |
813 |
|
(dolist (use uses) |
814 |
|
(setf (gethash use *compiled-initialize-instance-simple-functions*) t)) |
815 |
|
(setf (cdddr entry) (union uses (cdddr entry) |
816 |
|
:test #'equal)))) |
817 |
|
|
818 |
|
(defmacro precompile-iis-functions (&optional system) |
819 |
|
(let ((index -1)) |
820 |
|
`(progn |
821 |
|
,@(gathering1 (collecting) |
822 |
|
(dolist (iis-entry *initialize-instance-simple-alist*) |
823 |
|
(when (or (null (caddr iis-entry)) |
824 |
|
(eq (caddr iis-entry) system)) |
825 |
|
(when system (setf (caddr iis-entry) system)) |
826 |
|
(gather1 |
827 |
|
(make-top-level-form |
828 |
|
`(precompile-initialize-instance-simple ,system ,(incf index)) |
829 |
|
'(load) |
830 |
|
`(load-precompiled-iis-entry |
831 |
|
',(car iis-entry) |
832 |
|
#',(car iis-entry) |
833 |
|
',system |
834 |
|
',(cdddr iis-entry)))))))))) |
835 |
|
|
836 |
|
(defun compile-iis-functions (after-p) |
837 |
|
(let ((*compile-make-instance-functions-p* t) |
838 |
|
(*revert-initialize-info-p* t) |
839 |
|
(*note-iis-entry-p* (not after-p))) |
840 |
|
(declare (special *compile-make-instance-functions-p*)) |
841 |
|
(when (eq *boot-state* 'complete) |
842 |
|
(update-make-instance-function-table)))) |
843 |
|
|
844 |
|
|
845 |
|
;(const const) |
846 |
|
;(funcall function) |
847 |
|
;(push-initarg const) |
848 |
|
;(pop-supplied count) ; a positive odd number |
849 |
|
;(instance-set pv-offset slotd) |
850 |
|
;(skip-when-instance-boundp pv-offset slotd n) |
851 |
|
|
852 |
|
(defun initialize-instance-simple (pv-cell form-list instance initargs) |
853 |
|
(let ((pv (car pv-cell)) |
854 |
|
(initargs-tail initargs) |
855 |
|
(slots (get-slots-or-nil instance)) |
856 |
|
(class (class-of instance)) |
857 |
|
value) |
858 |
|
(loop (when (null form-list) (return nil)) |
859 |
|
(let ((form (pop form-list))) |
860 |
|
(ecase (car form) |
861 |
|
(push-initarg |
862 |
|
(push value initargs) |
863 |
|
(push (cadr form) initargs)) |
864 |
|
(const |
865 |
|
(setq value (cadr form))) |
866 |
|
(funcall |
867 |
|
(setq value (funcall (the function (cadr form))))) |
868 |
|
(pop-initargs |
869 |
|
(setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail)) |
870 |
|
(setq value (pop initargs-tail))) |
871 |
|
(instance-set |
872 |
|
(instance-write-internal |
873 |
|
pv slots (cadr form) value |
874 |
|
(setf (slot-value-using-class class instance (caddr form)) value))) |
875 |
|
(skip-when-instance-boundp |
876 |
|
(when (instance-boundp-internal |
877 |
|
pv slots (cadr form) |
878 |
|
(slot-boundp-using-class class instance (caddr form))) |
879 |
|
(dotimes (i (cadddr form)) |
880 |
|
(pop form-list)))) |
881 |
|
(update-initialize-info-cache |
882 |
|
(when (consp initargs) |
883 |
|
(setq initargs (cons (car initargs) (cdr initargs)))) |
884 |
|
(setq *initialize-info-cache-class* (cadr form)) |
885 |
|
(setq *initialize-info-cache-initargs* initargs) |
886 |
|
(setq *initialize-info-cache-info* (caddr form))) |
887 |
|
(finish-pushing-initargs |
888 |
|
(setq initargs-tail initargs))))) |
889 |
|
initargs)) |
890 |
|
|
891 |
|
(defun add-to-cvector (cvector constant) |
892 |
|
(or (position constant cvector) |
893 |
|
(prog1 (fill-pointer cvector) |
894 |
|
(vector-push-extend constant cvector)))) |
895 |
|
|
896 |
|
(defvar *inline-iis-instance-locations-p* t) |
897 |
|
|
898 |
|
(defun first-form-to-lisp (forms cvector pv) |
899 |
|
(flet ((const (constant) |
900 |
|
(cond ((or (numberp constant) (characterp constant)) |
901 |
|
constant) |
902 |
|
((and (symbolp constant) (symbol-package constant)) |
903 |
|
`',constant) |
904 |
|
(t |
905 |
|
`(svref cvector ,(add-to-cvector cvector constant)))))) |
906 |
|
(let ((form (pop (car forms)))) |
907 |
|
(ecase (car form) |
908 |
|
(push-initarg |
909 |
|
`((push value initargs) |
910 |
|
(push ,(const (cadr form)) initargs))) |
911 |
|
(const |
912 |
|
`((setq value ,(const (cadr form))))) |
913 |
|
(funcall |
914 |
|
`((setq value (funcall (the function ,(const (cadr form))))))) |
915 |
|
(pop-initargs |
916 |
|
`((setq initargs-tail (,@(let ((pop (1- (cadr form)))) |
917 |
|
(case pop |
918 |
|
(1 `(cdr)) |
919 |
|
(3 `(cdddr)) |
920 |
|
(t `(nthcdr ,pop)))) |
921 |
|
initargs-tail)) |
922 |
|
(setq value (pop initargs-tail)))) |
923 |
|
(instance-set |
924 |
|
(let* ((pv-offset (cadr form)) |
925 |
|
(location (pvref pv pv-offset)) |
926 |
|
(default `(setf (slot-value-using-class class instance |
927 |
|
,(const (caddr form))) |
928 |
|
value))) |
929 |
|
(if *inline-iis-instance-locations-p* |
930 |
|
(typecase location |
931 |
|
(fixnum `((setf (%instance-ref slots ,(const location)) value))) |
932 |
|
(cons `((setf (cdr ,(const location)) value))) |
933 |
|
(t `(,default))) |
934 |
|
`((instance-write-internal pv slots ,(const pv-offset) value |
935 |
|
,default |
936 |
|
,(typecase location |
937 |
|
(fixnum ':instance) |
938 |
|
(cons ':class) |
939 |
|
(t ':default))))))) |
940 |
|
(skip-when-instance-boundp |
941 |
|
(let* ((pv-offset (cadr form)) |
942 |
|
(location (pvref pv pv-offset)) |
943 |
|
(default `(slot-boundp-using-class class instance |
944 |
|
,(const (caddr form))))) |
945 |
|
`((unless ,(if *inline-iis-instance-locations-p* |
946 |
|
(typecase location |
947 |
|
(fixnum `(not (eq (%instance-ref slots ,(const location)) |
948 |
|
',*slot-unbound*))) |
949 |
|
(cons `(not (eq (cdr ,(const location)) ',*slot-unbound*))) |
950 |
|
(t default)) |
951 |
|
`(instance-boundp-internal pv slots ,(const pv-offset) |
952 |
|
,default |
953 |
|
,(typecase (pvref pv pv-offset) |
954 |
|
(fixnum ':instance) |
955 |
|
(cons ':class) |
956 |
|
(t ':default)))) |
957 |
|
,@(let ((sforms (cons nil nil))) |
958 |
|
(dotimes (i (cadddr form) (car sforms)) |
959 |
|
(add-forms (first-form-to-lisp forms cvector pv) sforms))))))) |
960 |
|
(update-initialize-info-cache |
961 |
|
`((when (consp initargs) |
962 |
|
(setq initargs (cons (car initargs) (cdr initargs)))) |
963 |
|
(setq *initialize-info-cache-class* ,(const (cadr form))) |
964 |
|
(setq *initialize-info-cache-initargs* initargs) |
965 |
|
(setq *initialize-info-cache-info* ,(const (caddr form))))) |
966 |
|
(finish-pushing-initargs |
967 |
|
`((setq initargs-tail initargs))))))) |
968 |
|
|
969 |
|
(defmacro iis-body (&body forms) |
970 |
|
(let ((vars '(initargs-tail pv slots wrapper class value))) |
971 |
|
`(let ((initargs-tail initargs) |
972 |
|
(pv (car pv-cell)) |
973 |
|
(slots nil) |
974 |
|
(wrapper #+cmu17 (kernel:layout-of instance) #-cmu17 nil) |
975 |
|
class |
976 |
|
value) |
977 |
|
,@(progn |
978 |
|
#-cmu vars |
979 |
|
#+cmu `((declare (ignorable ,@vars)))) |
980 |
|
#+cmu17 |
981 |
|
(cond ((not (typep wrapper 'wrapper))) |
982 |
|
((std-instance-p instance) |
983 |
|
(setq slots (std-instance-slots instance))) |
984 |
|
(t |
985 |
|
(setq slots (fsc-instance-slots instance)))) |
986 |
|
#-cmu17 |
987 |
|
(cond ((std-instance-p instance) |
988 |
|
(setq slots (std-instance-slots instance)) |
989 |
|
(setq wrapper (std-instance-wrapper instance))) |
990 |
|
((fsc-instance-p instance) |
991 |
|
(setq slots (fsc-instance-slots instance)) |
992 |
|
(setq wrapper (fsc-instance-wrapper instance))) |
993 |
|
(t |
994 |
|
(setq wrapper (wrapper-of instance)))) |
995 |
|
(setq class (wrapper-class wrapper)) |
996 |
|
,@forms))) |
997 |
|
|
998 |
|
(defun form-list-to-lisp (pv-cell form-list) |
999 |
|
(let* ((forms (list form-list)) |
1000 |
|
(cvector (make-array (floor (length form-list) 2) |
1001 |
|
:fill-pointer 0 :adjustable t)) |
1002 |
|
(pv (car pv-cell)) |
1003 |
|
(body (let ((rforms (cons nil nil))) |
1004 |
|
(loop (when (null (car forms)) (return (car rforms))) |
1005 |
|
(add-forms (first-form-to-lisp forms cvector pv) |
1006 |
|
rforms)))) |
1007 |
|
(cvector-type `(simple-vector ,(length cvector)))) |
1008 |
|
(values |
1009 |
|
`(lambda (pv-cell cvector) |
1010 |
|
(declare (type ,cvector-type cvector)) |
1011 |
|
#+cmu |
1012 |
|
(declare (ignorable pv-cell cvector)) |
1013 |
|
#'(lambda (instance initargs) |
1014 |
|
(declare #.*optimize-speed*) |
1015 |
|
#+cmu |
1016 |
|
(declare (ignorable instance initargs)) |
1017 |
|
(iis-body ,@body) |
1018 |
|
initargs)) |
1019 |
|
(list pv-cell (coerce cvector cvector-type))))) |
1020 |
|
|
1021 |
|
|
1022 |
|
;The effect of this is to cause almost all of the overhead of make-instance |
1023 |
|
;to happen at load time (or maybe at precompile time, as explained in a |
1024 |
|
;previous message) rather than the first time make-instance is called with |
1025 |
|
;a given class-name and sequence of keywords. |
1026 |
|
|
1027 |
|
;This optimization applys only when the first argument and all the even |
1028 |
|
;numbered arguments are constants evaluating to interned symbols. |
1029 |
|
|
1030 |
|
#+cmu |
1031 |
|
(declaim (ftype (function (t) symbol) get-make-instance-function-symbol)) |
1032 |
|
|
1033 |
|
; Use this definition in any CL implementation supporting |
1034 |
|
; both define-compiler-macro and load-time-value. |
1035 |
|
#+cmu |
1036 |
|
(define-compiler-macro make-instance (&whole form &rest args) |
1037 |
|
(declare (ignore args)) |
1038 |
|
(let* ((*make-instance-function-keys* nil) |
1039 |
|
(expanded-form (expand-make-instance-form form))) |
1040 |
|
(if expanded-form |
1041 |
|
`(funcall (the function |
1042 |
|
(symbol-function |
1043 |
|
;; The symbol is guaranteed to be fbound. |
1044 |
|
;; Is there a way to declare this? |
1045 |
|
(load-time-value |
1046 |
|
(get-make-instance-function-symbol |
1047 |
|
',(first *make-instance-function-keys*))))) |
1048 |
|
,@(cdr expanded-form)) |
1049 |
|
form))) |
1050 |
|
|
1051 |
|
(defun get-make-instance-function-symbol (key) |
1052 |
|
(get-make-instance-functions (list key)) |
1053 |
|
(make-instance-function-symbol key)) |