/[cmucl]/src/pcl/ctor.lisp
ViewVC logotype

Contents of /src/pcl/ctor.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Fri Mar 19 15:19:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.18: +3 -2 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; Copyright (C) 2002, 2003 Gerd Moellmann <gerd.moellmann@t-online.de>
2 ;;; All rights reserved.
3 ;;;
4 ;;; Redistribution and use in source and binary forms, with or without
5 ;;; modification, are permitted provided that the following conditions
6 ;;; are met:
7 ;;;
8 ;;; 1. Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
10 ;;; 2. Redistributions in binary form must reproduce the above copyright
11 ;;; notice, this list of conditions and the following disclaimer in the
12 ;;; documentation and/or other materials provided with the distribution.
13 ;;; 3. The name of the author may not be used to endorse or promote
14 ;;; products derived from this software without specific prior written
15 ;;; permission.
16 ;;;
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
21 ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
22 ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
23 ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
24 ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
25 ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
26 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
27 ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
28 ;;; DAMAGE.
29
30 ;;; ***************
31 ;;; Overview *****
32 ;;; ***************
33 ;;;
34 ;;; Compiler macro for MAKE-INSTANCE, and load-time generation of
35 ;;; optimized instance constructor functions.
36 ;;;
37 ;;; ********************
38 ;;; Entry Points ******
39 ;;; ********************
40 ;;;
41 ;;; UPDATE-CTORS must be called when methods are added/removed,
42 ;;; classes are changed, etc., which affect instance creation.
43 ;;;
44 ;;; PRECOMPILE-CTORS can be called to precompile constructor functions
45 ;;; for classes whose definitions are known at the time the function
46 ;;; is called.
47
48 (file-comment
49 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/ctor.lisp,v 1.19 2010/03/19 15:19:03 rtoy Rel $")
50
51 (in-package "PCL")
52 (intl:textdomain "cmucl")
53
54 ;;; ******************
55 ;;; Utilities *******
56 ;;; ******************
57
58 (defun quote-plist-keys (plist)
59 (loop for (key . more) on plist by #'cddr
60 if (null more) do
61 (error "Not a property list: ~S" plist)
62 else
63 collect `(quote ,key)
64 and collect (car more)))
65
66
67 (defun plist-keys (plist &key test)
68 (loop for (key . more) on plist by #'cddr
69 if (null more) do
70 (error _"~@<Not a property list: ~S.~@:>" plist)
71 else if (or (null test) (funcall test key))
72 collect key))
73
74
75 ;;; *****************
76 ;;; CTORS *********
77 ;;; *****************
78 ;;;
79 ;;; Ctors are funcallable instances whose initial function is a
80 ;;; function computing an optimized constructor function when called.
81 ;;; When the optimized function is computed, the function of the
82 ;;; funcallable instance is set to it.
83 ;;;
84 (defstruct (ctor (:include pcl-funcallable-instance)
85 (:type kernel:funcallable-structure)
86 (:constructor %make-ctor))
87 ;;
88 ;; The function name whose function definition is this CTOR.
89 (function-name nil :type list)
90 ;;
91 ;; The name of the class for which this CTOR constructs instances.
92 ;; We have to know the name here because only when the constructor
93 ;; function is actually called, we can assume that the class is
94 ;; actually defined (and throw an error if not).
95 (class-name nil :type symbol)
96 ;;
97 ;; The actual class object iff the optimized constructor function
98 ;; has been built and set as the funcallable-instance function
99 ;; of this ctor.
100 (class nil :type (or null class))
101 ;;
102 ;; Property list of keywords and either constant values, from the
103 ;; MAKE-INSTANCE form for which this CTOR was constructed, or
104 ;; constructor function parameter names for non-constant values.
105 (initargs () :type list)
106 ;;
107 ;; The state of the ctor object. NIL if the the constructor function
108 ;; hasn't been generated yet. OPTIMIZED if an optimized constructor
109 ;; function has been generated. FALLBACK if an unoptimized constructor
110 ;; function has been generated.
111 (state 'initial :type (member initial optimized fallback)))
112
113 ;;; List of all defined ctors.
114
115 (defvar *all-ctors* ())
116
117 (defun make-ctor-parameter-list (ctor)
118 (loop for (key value) on (ctor-initargs ctor) by #'cddr
119 unless (constantp value) collect value))
120
121 (eval-when (:compile-toplevel :load-toplevel :execute)
122 (define-function-name-syntax ctor (name)
123 (when (symbolp (cadr name))
124 (values t (cadr name))))
125
126 (define-function-name-syntax make-instance (name)
127 (when (symbolp (cadr name))
128 (values t (cadr name)))))
129
130 (defun make-ctor-function-name (class-name initargs)
131 (list* 'ctor class-name initargs))
132
133 ;;;
134 ;;; Reset CTOR to use a default function that will compute an
135 ;;; optimized constructor function when called.
136 ;;;
137 (defun install-initial-constructor (ctor &key force-p)
138 (when (or force-p (ctor-class ctor))
139 (setf (ctor-class ctor) nil)
140 (setf (ctor-state ctor) 'initial)
141 (setf (kernel:funcallable-instance-function ctor)
142 #'(kernel:instance-lambda (&rest args)
143 (install-optimized-constructor ctor)
144 (apply ctor args)))
145 (setf (kernel:%funcallable-instance-info ctor 1)
146 (ctor-function-name ctor))))
147
148 ;;;
149 ;;; Keep this a separate function for testing.
150 ;;;
151 (defun ensure-ctor (function-name class-name initargs)
152 (unless (fboundp function-name)
153 (make-ctor function-name class-name initargs)))
154
155 ;;;
156 ;;; Keep this a separate function for testing.
157 ;;;
158 (defun make-ctor (function-name class-name initargs)
159 (let ((ctor (%make-ctor :function-name function-name
160 :class-name class-name
161 :initargs initargs)))
162 (push ctor *all-ctors*)
163 (setf (fdefinition function-name) ctor)
164 (install-initial-constructor ctor :force-p t)
165 ctor))
166
167
168 ;;; ***********************************************
169 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
170 ;;; ***********************************************
171
172 (define-compiler-macro make-instance (&whole form &rest args)
173 (declare (ignore args))
174 (or (make-instance->constructor-call form)
175 form))
176
177 (defun make-instance->constructor-call (form)
178 (destructuring-bind (fn class-name &rest args) form
179 (declare (ignore fn))
180 (labels ((constant-symbol-p (form)
181 (and (constantp form)
182 (let ((constant (eval form)))
183 (and (symbolp constant)
184 (not (null (symbol-package constant)))))))
185 ;;
186 ;; Return the name of parameter number I of a constructor
187 ;; function.
188 (parameter-name (i)
189 (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.)))
190 (if (array-in-bounds-p ps i)
191 (aref ps i)
192 (make-.variable. 'p i))))
193 ;;
194 ;; Check if CLASS-NAME is a constant symbol. Give up if
195 ;; not.
196 (check-class ()
197 (unless (and class-name (constant-symbol-p class-name))
198 (return-from make-instance->constructor-call nil)))
199 ;;
200 ;; Check if ARGS are suitable for an optimized constructor.
201 ;; Return NIL from the outer function if not.
202 (check-args ()
203 (loop for (key . more) on args by #'cddr do
204 (when (or (null more)
205 (not (constant-symbol-p key))
206 (eq :allow-other-keys (eval key)))
207 (return-from make-instance->constructor-call nil)))))
208 (check-class)
209 (check-args)
210 ;;
211 ;; Collect a plist of initargs and constant values/parameter names
212 ;; in INITARGS. Collect non-constant initialization forms in
213 ;; VALUE-FORMS.
214 (multiple-value-bind (initargs value-forms)
215 (loop for (key value) on args by #'cddr and i from 0
216 collect (eval key) into initargs
217 if (constantp value)
218 collect value into initargs
219 else
220 collect (parameter-name i) into initargs
221 and collect value into value-forms
222 finally
223 (return (values initargs value-forms)))
224 (let* ((class-name (eval class-name))
225 (function-name (make-ctor-function-name class-name initargs)))
226 ;;
227 ;; Prevent compiler warnings for calling the ctor.
228 (c::define-function-name function-name)
229 (when (eq (info function where-from function-name) :assumed)
230 (setf (info function where-from function-name) :defined)
231 (when (info function assumed-type function-name)
232 (setf (info function assumed-type function-name) nil)))
233 ;;
234 ;; Return code constructing a ctor at load time, which, when
235 ;; called, will set its funcallable instance function to an
236 ;; optimized constructor function.
237 `(let ((.x. (load-time-value
238 (ensure-ctor ',function-name ',class-name ',initargs))))
239 (declare (ignore .x.))
240 (funcall (function ,function-name) ,@value-forms)))))))
241
242
243 ;;; **************************************************
244 ;;; Load-Time Constructor Function Generation *******
245 ;;; **************************************************
246
247 ;;;
248 ;;; The system-supplied primary INITIALIZE-INSTANCE and
249 ;;; SHARED-INITIALIZE methods. One cannot initialized these variables
250 ;;; to the right values here because said functions don't exist yet
251 ;;; when this file is first loaded.
252 ;;;
253 (defvar *the-system-ii-method* nil)
254 (defvar *the-system-si-method* nil)
255
256 (defun install-optimized-constructor (ctor)
257 (labels ((lambda-name (ctor)
258 (cons 'make-instance
259 (cdr (ctor-function-name ctor))))
260 (install (optimized-p)
261 (without-package-locks
262 (multiple-value-bind (lambda fn)
263 (if optimized-p
264 (constructor-function-form ctor)
265 (fallback-generator ctor))
266 (setf (kernel:funcallable-instance-function ctor)
267 (or fn
268 (letf (((compiler-macro-function 'make-instance) nil))
269 (compile-lambda lambda :name (lambda-name ctor)))))))))
270 (let ((class (find-class (ctor-class-name ctor) nil)))
271 (setf (ctor-class ctor) class)
272 (cond ((null class)
273 (install nil))
274 (t
275 (unless (class-finalized-p class)
276 (finalize-inheritance class))
277 (pushnew ctor (plist-value class 'ctors))
278 (install (null *cold-boot-state*)))))))
279
280 (defun constructor-function-form (ctor)
281 (let* ((class (ctor-class ctor))
282 (proto (class-prototype class))
283 (make-instance-methods
284 (compute-applicable-methods #'make-instance (list class)))
285 (allocate-instance-methods
286 (compute-applicable-methods #'allocate-instance (list class)))
287 (ii-methods
288 (compute-applicable-methods #'initialize-instance (list proto)))
289 (si-methods
290 (compute-applicable-methods #'shared-initialize (list proto t))))
291 ;;
292 ;; Cannot initialize these variables earlier because the generic
293 ;; functions don't exist when PCL is built.
294 (when (null *the-system-si-method*)
295 (setq *the-system-si-method*
296 (find-method #'shared-initialize
297 () (list *the-class-slot-object* *the-class-t*)))
298 (setq *the-system-ii-method*
299 (find-method #'initialize-instance
300 () (list *the-class-slot-object*))))
301 ;;
302 ;; Note that when there are user-defined applicable methods on
303 ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
304 ;; together with the system-defined ones in what
305 ;; COMPUTE-APPLICABLE-METHODS returns.
306 (or (and (not (condition-class-p class))
307 (null (cdr make-instance-methods))
308 (null (cdr allocate-instance-methods))
309 (null (check-initargs class (plist-keys (ctor-initargs ctor))
310 (append ii-methods si-methods) nil nil))
311 (not (around-or-nonstandard-primary-method-p
312 ii-methods *the-system-ii-method*))
313 (not (around-or-nonstandard-primary-method-p
314 si-methods *the-system-si-method*))
315 (optimizing-generator ctor ii-methods si-methods))
316 (fallback-generator ctor))))
317
318 (defun around-or-nonstandard-primary-method-p
319 (methods &optional standard-method)
320 (loop with primary-checked-p = nil
321 for method in methods
322 as qualifiers = (method-qualifiers method)
323 when (or (eq :around (car qualifiers))
324 (and (null qualifiers)
325 (not primary-checked-p)
326 (not (null standard-method))
327 (not (eq standard-method method))))
328 return t
329 when (null qualifiers) do
330 (setq primary-checked-p t)))
331
332 (defun fallback-generator (ctor)
333 (setf (ctor-state ctor) 'fallback)
334 (if (null *cold-boot-state*)
335 (if (ctor-class ctor)
336 `(kernel:instance-lambda ,(make-ctor-parameter-list ctor)
337 (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor)))
338 `(kernel:instance-lambda ,(make-ctor-parameter-list ctor)
339 (make-instance ',(ctor-class-name ctor) ,@(ctor-initargs ctor))))
340 (let ((class (ctor-class-name ctor))
341 (params (copy-list (ctor-initargs ctor)))
342 (value-cells ()))
343 (loop for cell on (cdr params) by #'cddr do
344 (if (constantp (car cell))
345 (setf (car cell) (eval (car cell)))
346 (push cell value-cells)))
347 (setq value-cells (nreverse value-cells))
348 (values nil
349 #'(kernel:instance-lambda (&rest args)
350 (dolist (cell value-cells)
351 (setf (car cell) (pop args)))
352 (apply #'make-instance class params))))))
353
354 (defun optimizing-generator (ctor ii-methods si-methods)
355 (multiple-value-bind (body before-method-p)
356 (fake-initialization-emf ctor ii-methods si-methods)
357 (setf (ctor-state ctor) 'optimized)
358 `(kernel:instance-lambda ,(make-ctor-parameter-list ctor)
359 ,(wrap-in-allocate-forms ctor body before-method-p))))
360
361 ;;;
362 ;;; Return a form wrapped around BODY that allocates an instance
363 ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run
364 ;;; before-methods, in which case we initialize instance slots to
365 ;;; +SLOT-UNBOUND+. The resulting form binds the local variables
366 ;;; .INSTANCE. to the instance. For non-structure instances,
367 ;;; .SLOTS. is bound to the instance's slot vector around BODY.
368 ;;;
369 (defun wrap-in-allocate-forms (ctor body before-method-p)
370 (let ((class (ctor-class ctor)))
371 (if (structure-class-p class)
372 (let ((allocation-function (class-defstruct-constructor class)))
373 `(let ((.instance. (,allocation-function)))
374 ,body
375 .instance.))
376 (let ((wrapper (class-wrapper class))
377 (allocation-function (raw-instance-allocator class))
378 (slots-fetcher (slots-fetcher class)))
379 (if (eq allocation-function 'allocate-standard-instance)
380 `(let ((.instance. (%%allocate-instance--class))
381 (.slots. (make-array ,(kernel:layout-length wrapper)
382 ,@(when before-method-p
383 '(:initial-element
384 +slot-unbound+)))))
385 (setf (std-instance-wrapper .instance.) ,wrapper)
386 (setf (std-instance-slots .instance.) .slots.)
387 ,body
388 .instance.)
389 `(let* ((.instance. (,allocation-function ,wrapper))
390 (.slots. (,slots-fetcher .instance.)))
391 ,body
392 .instance.))))))
393
394 ;;;
395 ;;; Return a form that is sort of an effective method comprising all
396 ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would
397 ;;; normally have taken place when calling MAKE-INSTANCE.
398 ;;;
399 (defun fake-initialization-emf (ctor ii-methods si-methods)
400 (multiple-value-bind (ii-around ii-before ii-primary ii-after)
401 (standard-sort-methods ii-methods)
402 (declare (ignore ii-primary))
403 (multiple-value-bind (si-around si-before si-primary si-after)
404 (standard-sort-methods si-methods)
405 (declare (ignore si-primary))
406 (assert (and (null ii-around) (null si-around)))
407 (let ((initargs (ctor-initargs ctor)))
408 (multiple-value-bind (slot-inits defaulted-initargs)
409 (slot-init-forms ctor (or ii-before si-before))
410 (flet ((method-calls (methods args)
411 (loop for method in methods
412 as fn = (method-function method)
413 collect `(funcall (truly-the function ,fn) ,args ()))))
414 (let ((let (car slot-inits))
415 (bindings (cadr slot-inits))
416 (body (cddr slot-inits)))
417 (assert (eq let 'let))
418 (multiple-value-bind (slot-init-forms decls doc-string)
419 (sys:parse-body body nil nil)
420 (declare (ignore doc-string))
421 (values
422 `(let* (,@bindings
423 ,@(when (or ii-before ii-after)
424 `((.ii-args.
425 (list .instance. ,@(quote-plist-keys initargs) ,@defaulted-initargs))))
426 ,@(when (or si-before si-after)
427 `((.si-args.
428 (list .instance. t ,@(quote-plist-keys initargs) ,@defaulted-initargs)))))
429 ,@decls
430 ,@(method-calls ii-before '.ii-args.)
431 ,@(method-calls si-before '.si-args.)
432 ,@slot-init-forms
433 ,@(method-calls si-after '.si-args.)
434 ,@(method-calls ii-after '.ii-args.))
435 (or ii-before si-before))))))))))
436
437 ;;;
438 ;;; Return four values from APPLICABLE-METHODS: around methods, before
439 ;;; methods, the applicable primary method, and applicable after
440 ;;; methods. Before and after methods are sorted in the order they
441 ;;; must be called.
442 ;;;
443 (defun standard-sort-methods (applicable-methods)
444 (loop for method in applicable-methods
445 as qualifiers = (method-qualifiers method)
446 if (null qualifiers)
447 collect method into primary
448 else if (eq :around (car qualifiers))
449 collect method into around
450 else if (eq :after (car qualifiers))
451 collect method into after
452 else if (eq :before (car qualifiers))
453 collect method into before
454 finally
455 (return (values around before (first primary) (nreverse after)))))
456
457
458 ;;;
459 ;;; Return the declared type of slot TYPE, or T if we don't want
460 ;;; to use slot types.
461 ;;;
462 (declaim (inline slot-type-or-t))
463 (defun slot-type-or-t (slot)
464 (declare (special *use-slot-types-p*))
465 (if *use-slot-types-p*
466 (slot-definition-type slot)
467 t))
468
469 ;;;
470 ;;; Return a form initializing instance and class slots of an object
471 ;;; costructed by CTOR. The variable .SLOTS. is assumed to bound to a
472 ;;; non-structure instance's slot vector. The variable .INSTANCE. is
473 ;;; assumed to be bound in case of a structure instance.
474 ;;;
475 ;;; BEFORE-METHOD-P T means before-methods will be called, which, for
476 ;;; not-structures, means that 1) other code will initialize instance
477 ;;; slots to +SLOT-UNBOUND+ before the before-methods are run, and 2)
478 ;;; that we have to check if these before-methods have set slots.
479 ;;; For structures the consequences are likewise.
480 ;;;
481 ;;; madhu 061211 second return value is a list of default initargs.
482 ;;;
483 (defun slot-init-forms (ctor before-method-p)
484 (let* ((class (ctor-class ctor))
485 (structure-p (structure-class-p class))
486 (initargs (ctor-initargs ctor))
487 (initkeys (plist-keys initargs))
488 (slot-vector
489 (unless structure-p
490 (make-array (kernel:layout-length (class-wrapper class))
491 :initial-element nil)))
492 (class-inits ())
493 (structure-inits ())
494 (default-inits ())
495 (defaulted-initargs ())
496 (default-initargs (class-default-initargs class))
497 ;;
498 ;; Note that the locations are actually defstruct slot
499 ;; accessors for structures.
500 (locations (compute-initarg-locations
501 class
502 (append initkeys (mapcar #'car default-initargs)))))
503 (labels ((locations (key)
504 (cdr (assoc key locations :test #'eq)))
505
506 (initialized-p (location)
507 (cond (structure-p
508 (assq location structure-inits))
509 ((integerp location)
510 (not (null (aref slot-vector location))))
511 (t
512 (assoc location class-inits :test #'eq))))
513
514 (class-init (location type val slot-type)
515 (assert (consp location))
516 (assert (not structure-p))
517 (unless (initialized-p location)
518 (push (list location type val slot-type) class-inits)))
519
520 (instance-init (location type val slot-type)
521 (unless (initialized-p location)
522 (cond (structure-p
523 (assert (symbolp location))
524 (push (list location type val slot-type)
525 structure-inits))
526 (t
527 (assert (integerp location))
528 (setf (aref slot-vector location)
529 (list type val slot-type))))))
530
531 (default-init-variable-name (i)
532 (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
533 (if (array-in-bounds-p ps i)
534 (aref ps i)
535 (make-.variable. 'd i)))))
536 ;;
537 ;; Loop over supplied initargs and values and record which
538 ;; instance and class slots they initialize.
539 (loop for (key value) on initargs by #'cddr
540 as type = (if (constantp value) 'constant 'param) do
541 (loop for (location . slot-type) in (locations key) do
542 (if (consp location)
543 (class-init location type value slot-type)
544 (instance-init location type value slot-type))))
545 ;;
546 ;; Loop over default initargs of the class, recording
547 ;; initializations of slots that have not been initialized
548 ;; above. Default initargs which are not in the supplied
549 ;; initargs are treated as if they were appended to supplied
550 ;; initargs, that is, their values must be evaluated even
551 ;; if not actually used for initializing a slot.
552 (loop for (key initfn initform) in default-initargs and i from 0
553 unless (memq key initkeys) do
554 (let* ((type (cond ((constantp initform)
555 (push key defaulted-initargs)
556 (push initform defaulted-initargs)
557 'constant)
558 (t (push key defaulted-initargs)
559 (push (default-init-variable-name i) defaulted-initargs)
560 'var)))
561 (init (if (eq type 'var) initfn initform)))
562 (when (eq type 'var)
563 (let ((init-var (default-init-variable-name i)))
564 (setq init init-var)
565 (push (cons init-var initfn) default-inits)))
566 (loop for (location . slot-type) in (locations key) do
567 (if (consp location)
568 (class-init location type init slot-type)
569 (instance-init location type init slot-type)))))
570 ;;
571 ;; Loop over all slots of the class, filling in the rest from
572 ;; slot initforms.
573 (loop for slotd in (class-slots class)
574 as location
575 = (if structure-p
576 (slot-definition-defstruct-accessor-symbol slotd)
577 (slot-definition-location slotd))
578 as allocation = (slot-definition-allocation slotd)
579 as initfn = (slot-definition-initfunction slotd)
580 as slot-type = (slot-type-or-t slotd)
581 as initform = (slot-definition-initform slotd)
582 if (eq allocation :class) do
583 (when (and initfn (not (initialized-p location)))
584 (if (constantp initform)
585 (class-init location 'constant-if-unbound
586 initform slot-type)
587 (class-init location 'initfn-if-unbound
588 initfn slot-type)))
589 else do
590 (unless (or (and (not structure-p)
591 (null initfn))
592 (initialized-p location))
593 (if (constantp initform)
594 (instance-init location 'initform initform slot-type)
595 (instance-init location 'initform/initfn initfn
596 slot-type))))
597 ;;
598 ;; Generate the forms for initializing instance and class slots.
599 (let ((instance-init-forms
600 (delete nil
601 (if structure-p
602 (structure-init-forms structure-inits before-method-p)
603 (instance-init-forms slot-vector before-method-p))))
604 (class-init-forms
605 (unless structure-p
606 (collect ((forms))
607 (dolist (init class-inits (forms))
608 (destructuring-bind (location type value slot-type) init
609 (forms
610 (ecase type
611 (constant
612 `(setf (cdr ',location)
613 (the ,slot-type ',(eval value))))
614 ((param var)
615 `(setf (cdr ',location)
616 (the ,slot-type ,value)))
617 (initfn
618 `(setf (cdr ',location)
619 (the ,slot-type (funcall ,value))))
620 (initfn-if-unbound
621 `(when (eq +slot-unbound+ (cdr ',location))
622 (setf (cdr ',location)
623 (the ,slot-type (funcall ,value)))))
624 (constant-if-unbound
625 `(when (eq +slot-unbound+ (cdr ',location))
626 (setf (cdr ',location)
627 (the ,slot-type ',(eval value)))))))))))))
628 (multiple-value-bind (vars bindings)
629 (loop for (var . initfn) in (nreverse default-inits)
630 collect var into vars
631 collect `(,var (funcall ,initfn)) into bindings
632 finally (return (values vars bindings)))
633 (values
634 `(let ,bindings
635 (declare (ignorable ,@vars) (optimize (safety 3)))
636 ,@instance-init-forms
637 ,@class-init-forms)
638 (nreverse defaulted-initargs)))))))
639
640 ;;;
641 ;;; Return an alist of lists (KEY LOCATION ...) telling, for each key
642 ;;; in INITKEYS, which locations the initarg initializes. For
643 ;;; structures, defstruct slot accessor symbols are used as location.
644 ;;; CLASS is the class of the instance being initialized.
645 ;;;
646 (defun compute-initarg-locations (class initkeys)
647 (let ((get-location-fn (if (structure-class-p class)
648 #'slot-definition-defstruct-accessor-symbol
649 #'slot-definition-location)))
650 (loop with slots = (class-slots class)
651 for key in initkeys
652 collect
653 (loop for slot in slots
654 if (memq key (slot-definition-initargs slot))
655 collect (cons (funcall get-location-fn slot)
656 (slot-type-or-t slot))
657 into locations
658 else
659 collect slot into remaining-slots
660 finally
661 (setq slots remaining-slots)
662 (return (cons key locations))))))
663
664 ;;;
665 ;;; Return a list of forms for initializing instance slots as
666 ;;; described by SLOT-VECTOR. Each element of SLOT-VECTOR is a list
667 ;;; (TYPE VALUE SLOT-TYPE). See function SLOT-INIT-FORMS.
668 ;;; BEFORE-METHOD-P true means before-methods are run; we can assume
669 ;;; in that case that all slots are initialized to +SLOT-UNBOUND+ when
670 ;;; the instance is allocated.
671 ;;;
672 (defun instance-init-forms (slot-vector before-method-p)
673 (loop for slot-entry across slot-vector and i from 0
674 as (type value slot-type) = slot-entry
675 collect
676 (ecase type
677 ((nil)
678 (unless before-method-p
679 `(setf (svref .slots. ,i) +slot-unbound+)))
680 ((param var)
681 `(setf (svref .slots. ,i) (the ,slot-type ,value)))
682 (initfn
683 `(setf (svref .slots. ,i)
684 (the ,slot-type (funcall ,value))))
685 (initform/initfn
686 (if before-method-p
687 `(when (eq (svref .slots. ,i) +slot-unbound+)
688 (setf (svref .slots. ,i)
689 (the ,slot-type (funcall ,value))))
690 `(setf (svref .slots. ,i)
691 (the ,slot-type (funcall ,value)))))
692 (initform
693 (if before-method-p
694 `(when (eq (svref .slots. ,i) +slot-unbound+)
695 (setf (svref .slots. ,i)
696 (the ,slot-type ',(eval value))))
697 `(setf (svref .slots. ,i)
698 (the ,slot-type ',(eval value)))))
699 (constant
700 `(setf (svref .slots. ,i)
701 (the ,slot-type ',(eval value)))))))
702
703 ;;;
704 ;;; Like INSTANCE-INIT-FORMS, but for a structure instance.
705 ;;; INITS is a list describing the slots to initialize.
706 ;;;
707 (defun structure-init-forms (inits before-method-p)
708 (loop for (accessor type value slot-type) in inits
709 collect
710 (ecase type
711 ((nil)
712 (if before-method-p
713 `(when (eq (,accessor .instance.) '.unbound.)
714 (setf (,accessor .instance.) nil))
715 `(setf (,accessor .instance.) nil)))
716 ((param var)
717 `(setf (,accessor .instance.) (the ,slot-type ,value)))
718 (initfn
719 `(setf (,accessor .instance.)
720 (the ,slot-type (funcall ,value))))
721 (initform/initfn
722 (if before-method-p
723 `(when (eq (,accessor .instance.) '.unbound.)
724 (setf (,accessor .instance.)
725 (the ,slot-type (funcall ,value))))
726 `(setf (,accessor .instance.)
727 (the ,slot-type (funcall ,value)))))
728 (initform
729 (if before-method-p
730 `(when (eq (,accessor .instance.) '.unbound.)
731 (setf (,accessor .instance.)
732 (the ,slot-type ',(eval value))))
733 `(setf (,accessor .instance.)
734 (the ,slot-type ',(eval value)))))
735 (constant
736 `(setf (,accessor .instance.)
737 (the ,slot-type ',(eval value)))))))
738
739
740 ;;; *******************************
741 ;;; External Entry Points ********
742 ;;; *******************************
743
744 (defun update-ctors (reason &key class name generic-function method)
745 (labels ((reset (class &optional ri-cache-p (ctors-p t))
746 (when ctors-p
747 (dolist (ctor (plist-value class 'ctors))
748 (install-initial-constructor ctor)))
749 (when ri-cache-p
750 (setf (plist-value class 'ri-initargs) ()))
751 (dolist (subclass (class-direct-subclasses class))
752 (reset subclass ri-cache-p ctors-p))))
753 (ecase reason
754 ;;
755 ;; CLASS must have been specified.
756 (finalize-inheritance
757 (reset class t))
758 ;;
759 ;; NAME must have been specified.
760 (setf-find-class
761 (loop for ctor in *all-ctors*
762 when (eq (ctor-class-name ctor) name) do
763 (when (ctor-class ctor)
764 (reset (ctor-class ctor)))
765 (loop-finish)))
766 ;;
767 ;; GENERIC-FUNCTION and METHOD must have been specified.
768 ((add-method remove-method)
769 (flet ((class-of-1st-method-param (method)
770 (type-class (first (method-specializers method)))))
771 (case (generic-function-name generic-function)
772 ((make-instance allocate-instance initialize-instance
773 shared-initialize)
774 (reset (class-of-1st-method-param method) t t))
775 ((reinitialize-instance)
776 (reset (class-of-1st-method-param method) t nil))))))))
777
778 (defun precompile-ctors ()
779 (dolist (ctor *all-ctors*)
780 (when (null (ctor-class ctor))
781 (let ((class (find-class (ctor-class-name ctor) nil)))
782 (when (and class (class-finalized-p class))
783 (install-optimized-constructor ctor))))))
784
785 ;;;
786 ;;; Try to call a CTOR of class CLASS to construct an instance of CLASS
787 ;;; with given initargs. Value is an instance of CLASS if a suitable
788 ;;; ctor is found, NIL otherwise.
789 ;;;
790 ;;; This is called from MAKE-INSTANCE.
791 ;;;
792 (defun call-ctor (class initargs)
793 (flet (;;
794 ;; Return two values ARGS, MATCH-P. ARGS is a list of values
795 ;; from INITARGS with which the ctor can be invoked. MATCH-P
796 ;; true means the ctor can be used.
797 (call-args (ctor)
798 (collect ((args))
799 (let ((ctail (ctor-initargs ctor))
800 (itail initargs))
801 (loop
802 (when (or (null ctail) (null itail))
803 (return (values (args) (and (null ctail) (null itail)))))
804 (unless (eq (pop ctail) (pop itail))
805 (return nil))
806 (let ((ival (pop itail)) (cval (pop ctail)))
807 (if (constantp cval)
808 (unless (eql cval ival)
809 (return nil))
810 (args ival))))))))
811 ;;
812 ;; Loop over all ctors of CLASS looking for a ctor that can be
813 ;; used to construct an instance with the given initargs. If one
814 ;; is found, invoke it and return its value.
815 (dolist (ctor (plist-value class 'ctors))
816 (when (eq (ctor-state ctor) 'optimized)
817 (multiple-value-bind (args match-p)
818 (call-args ctor)
819 (when match-p
820 (return (apply ctor args))))))))
821
822 ;;;
823 ;;; REINITIALIZE-INSTANCE initargs checking with memoization.
824 ;;; INSTANCE is the instance being reinitialized, INITARGS are the
825 ;;; initargs passed to REINITIALIZE-INSTANCE.
826 ;;;
827 ;;; The function UPDATE-CTORS clears the memoization cache.
828 ;;;
829 (defun check-ri-initargs (instance initargs)
830 (let* ((class (class-of instance))
831 (keys (plist-keys initargs))
832 (cached (assoc keys (plist-value class 'ri-initargs)
833 :test #'equal))
834 (invalid-keys
835 (if (consp cached)
836 (cdr cached)
837 (let ((invalid (check-initargs
838 class initargs
839 (list (list* 'reinitialize-instance
840 instance initargs)
841 (list* 'shared-initialize
842 instance nil initargs))
843 t nil)))
844 (setf (plist-value class 'ri-initargs)
845 (acons keys invalid cached))
846 invalid))))
847 (when invalid-keys
848 (invalid-initargs-error class invalid-keys))))
849
850 ;;; end of ctor.lisp

  ViewVC Help
Powered by ViewVC 1.1.5