0.8.12.7: Merge package locks, AKA "what can go wrong with a 3783 line patch?"
[sbcl.git] / src / pcl / ctor.lisp
1 ;;;; This file contains the optimization machinery for make-instance.
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5
6 ;;;; This software is derived from software originally released by
7 ;;;; Gerd Moellmann.  Copyright and release statements follow.  Later
8 ;;;; modifications to the software are in the public domain and are
9 ;;;; provided with absolutely no warranty.  See the COPYING and
10 ;;;; CREDITS files for more information.
11
12 ;;; Copyright (C) 2002 Gerd Moellmann <gerd.moellmann@t-online.de>
13 ;;; All rights reserved.
14 ;;;
15 ;;; Redistribution and use in source and binary forms, with or without
16 ;;; modification, are permitted provided that the following conditions
17 ;;; are met:
18 ;;;
19 ;;; 1. Redistributions of source code must retain the above copyright
20 ;;;    notice, this list of conditions and the following disclaimer.
21 ;;; 2. Redistributions in binary form must reproduce the above copyright
22 ;;;    notice, this list of conditions and the following disclaimer in the
23 ;;;    documentation and/or other materials provided with the distribution.
24 ;;; 3. The name of the author may not be used to endorse or promote
25 ;;;    products derived from this software without specific prior written
26 ;;;    permission.
27 ;;;
28 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
29 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
30 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
31 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
32 ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
33 ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
34 ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
35 ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
36 ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
37 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
38 ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
39 ;;; DAMAGE.
40
41 ;;; ***************
42 ;;; Overview  *****
43 ;;; ***************
44 ;;;
45 ;;; Compiler macro for MAKE-INSTANCE, and load-time generation of
46 ;;; optimized instance constructor functions.
47 ;;;
48 ;;; ********************
49 ;;; Entry Points  ******
50 ;;; ********************
51 ;;;
52 ;;; UPDATE-CTORS must be called when methods are added/removed,
53 ;;; classes are changed, etc., which affect instance creation.
54 ;;;
55 ;;; PRECOMPILE-CTORS can be called to precompile constructor functions
56 ;;; for classes whose definitions are known at the time the function
57 ;;; is called.
58
59 (in-package "SB-PCL")
60
61 ;;; ******************
62 ;;; Utilities  *******
63 ;;; ******************
64
65 (defun plist-keys (plist &key test)
66   (loop for (key . more) on plist by #'cddr
67         if (null more) do
68           (error "Not a property list: ~S" plist)
69         else if (or (null test) (funcall test key))
70           collect key))
71
72 (defun plist-values (plist &key test)
73   (loop for (key . more) on plist by #'cddr
74         if (null more) do
75           (error "Not a property list: ~S" plist)
76         else if (or (null test) (funcall test (car more)))
77           collect (car more)))
78
79 (defun constant-symbol-p (form)
80   (and (constantp form)
81        (let ((constant (eval form)))
82          (and (symbolp constant)
83               (not (null (symbol-package constant)))))))
84
85 \f
86 ;;; *****************
87 ;;; CTORS   *********
88 ;;; *****************
89 ;;;
90 ;;; Ctors are funcallable instances whose initial function is a
91 ;;; function computing an optimized constructor function when called.
92 ;;; When the optimized function is computed, the function of the
93 ;;; funcallable instance is set to it.
94 ;;;
95 (!defstruct-with-alternate-metaclass ctor
96   :slot-names (function-name class-name class initargs)
97   :boa-constructor %make-ctor
98   :superclass-name pcl-funcallable-instance
99   :metaclass-name random-pcl-classoid
100   :metaclass-constructor make-random-pcl-classoid
101   :dd-type funcallable-structure
102   :runtime-type-checks-p nil)
103
104 ;;; List of all defined ctors.
105
106 (defvar *all-ctors* ())
107
108 (defun make-ctor-parameter-list (ctor)
109   (plist-values (ctor-initargs ctor) :test (complement #'constantp)))
110
111 ;;;
112 ;;; Reset CTOR to use a default function that will compute an
113 ;;; optimized constructor function when called.
114 ;;;
115 (defun install-initial-constructor (ctor &key force-p)
116   (when (or force-p (ctor-class ctor))
117     (setf (ctor-class ctor) nil)
118     (setf (funcallable-instance-fun ctor)
119           #'(instance-lambda (&rest args)
120               (install-optimized-constructor ctor)
121               (apply ctor args)))
122     (setf (%funcallable-instance-info ctor 1)
123           (ctor-function-name ctor))))
124
125 ;;;
126 ;;; Keep this a separate function for testing.
127 ;;;
128 (defun make-ctor-function-name (class-name initargs)
129   (let ((*package* *pcl-package*)
130         (*print-case* :upcase)
131         (*print-pretty* nil)
132         (*print-gensym* t))
133     (format-symbol *pcl-package* "CTOR ~S::~S ~S ~S"
134                    (package-name (symbol-package class-name))
135                    (symbol-name class-name)
136                    (plist-keys initargs)
137                    (plist-values initargs :test #'constantp))))
138
139 ;;;
140 ;;; Keep this a separate function for testing.
141 ;;;
142 (defun ensure-ctor (function-name class-name initargs)
143   (unless (fboundp function-name)
144     (make-ctor function-name class-name initargs)))
145
146 ;;;
147 ;;; Keep this a separate function for testing.
148 ;;;
149 (defun make-ctor (function-name class-name initargs)
150   (without-package-locks ; for (setf symbol-function)
151    (let ((ctor (%make-ctor function-name class-name nil initargs)))
152      (push ctor *all-ctors*)
153      (setf (symbol-function function-name) ctor)
154      (install-initial-constructor ctor :force-p t)
155      ctor)))
156
157 \f
158 ;;; ***********************************************
159 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
160 ;;; ***********************************************
161
162 (define-compiler-macro make-instance (&whole form &rest args)
163   (declare (ignore args))
164   (or (make-instance->constructor-call form)
165       form))
166
167 (defun make-instance->constructor-call (form)
168   (destructuring-bind (fn class-name &rest args) form
169     (declare (ignore fn))
170     (flet (;;
171            ;; Return the name of parameter number I of a constructor
172            ;; function.
173            (parameter-name (i)
174              (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.)))
175                (if (array-in-bounds-p ps i)
176                    (aref ps i)
177                    (format-symbol *pcl-package* ".P~D." i))))
178            ;;
179            ;; Check if CLASS-NAME is a constant symbol.  Give up if
180            ;; not.
181            (check-class ()
182              (unless (and class-name (constant-symbol-p class-name))
183                (return-from make-instance->constructor-call nil)))
184            ;;
185            ;; Check if ARGS are suitable for an optimized constructor.
186            ;; Return NIL from the outer function if not.
187            (check-args ()
188              (loop for (key . more) on args by #'cddr do
189                      (when (or (null more)
190                                (not (constant-symbol-p key))
191                                (eq :allow-other-keys (eval key)))
192                        (return-from make-instance->constructor-call nil)))))
193       (check-class)
194       (check-args)
195       ;;
196       ;; Collect a plist of initargs and constant values/parameter names
197       ;; in INITARGS.  Collect non-constant initialization forms in
198       ;; VALUE-FORMS.
199       (multiple-value-bind (initargs value-forms)
200           (loop for (key value) on args by #'cddr and i from 0
201                 collect (eval key) into initargs
202                 if (constantp value)
203                   collect value into initargs
204                 else
205                   collect (parameter-name i) into initargs
206                   and collect value into value-forms
207                 finally
208                   (return (values initargs value-forms)))
209         (let* ((class-name (eval class-name))
210                (function-name (make-ctor-function-name class-name initargs)))
211           ;;
212           ;; Prevent compiler warnings for calling the ctor.
213           (proclaim-as-fun-name function-name)
214           (note-name-defined function-name :function)
215           (when (eq (info :function :where-from function-name) :assumed)
216             (setf (info :function :where-from function-name) :defined)
217             (when (info :function :assumed-type function-name)
218               (setf (info :function :assumed-type function-name) nil)))
219           ;;
220           ;; Return code constructing a ctor at load time, which, when
221           ;; called, will set its funcallable instance function to an
222           ;; optimized constructor function.
223           `(locally 
224                (declare (disable-package-locks ,function-name))
225             (let ((.x. (load-time-value
226                         (ensure-ctor ',function-name ',class-name ',initargs))))
227               (declare (ignore .x.))
228               ;; ??? check if this is worth it.
229               (declare
230                (ftype (or (function ,(make-list (length value-forms)
231                                                 :initial-element t)
232                                     t)
233                           (function (&rest t) t))
234                       ,function-name))
235               (,function-name ,@value-forms))))))))
236
237 \f
238 ;;; **************************************************
239 ;;; Load-Time Constructor Function Generation  *******
240 ;;; **************************************************
241
242 ;;;
243 ;;; The system-supplied primary INITIALIZE-INSTANCE and
244 ;;; SHARED-INITIALIZE methods.  One cannot initialized these variables
245 ;;; to the right values here because said functions don't exist yet
246 ;;; when this file is first loaded.
247 ;;;
248 (defvar *the-system-ii-method* nil)
249 (defvar *the-system-si-method* nil)
250
251 (defun install-optimized-constructor (ctor)
252   (let ((class (find-class (ctor-class-name ctor))))
253     (unless (class-finalized-p class)
254       (finalize-inheritance class))
255     (setf (ctor-class ctor) class)
256     (pushnew ctor (plist-value class 'ctors))
257     (setf (funcallable-instance-fun ctor)
258           ;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL
259           ;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't
260           ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA
261           ;; expressions.  The below should be equivalent, since we
262           ;; have a compiler-only implementation.
263           (eval `(function ,(constructor-function-form ctor))))))
264               
265 (defun constructor-function-form (ctor)
266   (let* ((class (ctor-class ctor))
267          (proto (class-prototype class))
268          (make-instance-methods
269           (compute-applicable-methods #'make-instance (list class)))
270          (allocate-instance-methods
271           (compute-applicable-methods #'allocate-instance (list class)))
272          (ii-methods
273           (compute-applicable-methods #'initialize-instance (list proto)))
274          (si-methods
275           (compute-applicable-methods #'shared-initialize (list proto t))))
276     ;; Cannot initialize these variables earlier because the generic
277     ;; functions don't exist when PCL is built.
278     (when (null *the-system-si-method*)
279       (setq *the-system-si-method*
280             (find-method #'shared-initialize
281                          () (list *the-class-slot-object* *the-class-t*)))
282       (setq *the-system-ii-method*
283             (find-method #'initialize-instance
284                          () (list *the-class-slot-object*))))
285     ;; Note that when there are user-defined applicable methods on
286     ;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
287     ;; together with the system-defined ones in what
288     ;; COMPUTE-APPLICABLE-METHODS returns.
289     (or (and (not (structure-class-p class))
290              (not (condition-class-p class))
291              (null (cdr make-instance-methods))
292              (null (cdr allocate-instance-methods))
293              (null (check-initargs-1 class (plist-keys (ctor-initargs ctor))
294                                      (append ii-methods si-methods) nil nil))
295              (not (around-or-nonstandard-primary-method-p
296                    ii-methods *the-system-ii-method*))
297              (not (around-or-nonstandard-primary-method-p
298                    si-methods *the-system-si-method*))
299              (optimizing-generator ctor ii-methods si-methods))
300         (fallback-generator ctor ii-methods si-methods))))
301
302 (defun around-or-nonstandard-primary-method-p
303     (methods &optional standard-method)
304   (loop with primary-checked-p = nil
305         for method in methods
306         as qualifiers = (method-qualifiers method)
307         when (or (eq :around (car qualifiers))
308                  (and (null qualifiers)
309                       (not primary-checked-p)
310                       (not (null standard-method))
311                       (not (eq standard-method method))))
312           return t
313         when (null qualifiers) do
314           (setq primary-checked-p t)))
315
316 (defun fallback-generator (ctor ii-methods si-methods)
317   (declare (ignore ii-methods si-methods))
318   `(instance-lambda ,(make-ctor-parameter-list ctor)
319      (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor))))
320
321 (defun optimizing-generator (ctor ii-methods si-methods)
322   (multiple-value-bind (body before-method-p)
323       (fake-initialization-emf ctor ii-methods si-methods)
324     `(instance-lambda ,(make-ctor-parameter-list ctor)
325        (declare #.*optimize-speed*)
326        ,(wrap-in-allocate-forms ctor body before-method-p))))
327
328 ;;;
329 ;;; Return a form wrapped around BODY that allocates an instance
330 ;;; constructed by CTOR.  BEFORE-METHOD-P set means we have to run
331 ;;; before-methods, in which case we initialize instance slots to
332 ;;; +SLOT-UNBOUND+.  The resulting form binds the local variables
333 ;;; .INSTANCE. to the instance, and .SLOTS. to the instance's slot
334 ;;; vector around BODY.
335 ;;;
336 (defun wrap-in-allocate-forms (ctor body before-method-p)
337   (let* ((class (ctor-class ctor))
338          (wrapper (class-wrapper class))
339          (allocation-function (raw-instance-allocator class))
340          (slots-fetcher (slots-fetcher class)))
341     (if (eq allocation-function 'allocate-standard-instance)
342         `(let ((.instance. (%make-standard-instance nil
343                                                     (get-instance-hash-code)))
344                (.slots. (make-array
345                          ,(layout-length wrapper)
346                          ,@(when before-method-p
347                              '(:initial-element +slot-unbound+)))))
348            (setf (std-instance-wrapper .instance.) ,wrapper)
349            (setf (std-instance-slots .instance.) .slots.)
350            ,body
351            .instance.)
352         `(let* ((.instance. (,allocation-function ,wrapper))
353                 (.slots. (,slots-fetcher .instance.)))
354            ,body
355            .instance.))))
356
357 ;;;
358 ;;; Return a form for invoking METHOD with arguments from ARGS.  As
359 ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method
360 ;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...).  We could
361 ;;; call fast method functions directly here, but benchmarks show that
362 ;;; there's no speed to gain, so lets avoid the hair here.
363 ;;;
364 (defmacro invoke-method (method args)
365   `(funcall ,(method-function method) ,args ()))
366
367 ;;;
368 ;;; Return a form that is sort of an effective method comprising all
369 ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would
370 ;;; normally have taken place when calling MAKE-INSTANCE.
371 ;;;
372 (defun fake-initialization-emf (ctor ii-methods si-methods)
373   (multiple-value-bind (ii-around ii-before ii-primary ii-after)
374       (standard-sort-methods ii-methods)
375     (declare (ignore ii-primary))
376     (multiple-value-bind (si-around si-before si-primary si-after)
377         (standard-sort-methods si-methods)
378       (declare (ignore si-primary))
379       (aver (and (null ii-around) (null si-around)))
380       (let ((initargs (ctor-initargs ctor))
381             (slot-inits (slot-init-forms ctor (or ii-before si-before))))
382         (values
383          `(let (,@(when (or ii-before ii-after)
384                    `((.ii-args. (list .instance. ,@initargs))))
385                 ,@(when (or si-before si-after)
386                    `((.si-args. (list .instance. t ,@initargs)))))
387             ,@(loop for method in ii-before
388                     collect `(invoke-method ,method .ii-args.))
389             ,@(loop for method in si-before
390                     collect `(invoke-method ,method .si-args.))
391             ,slot-inits
392             ,@(loop for method in si-after
393                     collect `(invoke-method ,method .si-args.))
394             ,@(loop for method in ii-after
395                     collect `(invoke-method ,method .ii-args.)))
396          (or ii-before si-before))))))
397
398 ;;;
399 ;;; Return four values from APPLICABLE-METHODS: around methods, before
400 ;;; methods, the applicable primary method, and applicable after
401 ;;; methods.  Before and after methods are sorted in the order they
402 ;;; must be called.
403 ;;;
404 (defun standard-sort-methods (applicable-methods)
405   (loop for method in applicable-methods
406         as qualifiers = (method-qualifiers method)
407         if (null qualifiers)
408           collect method into primary
409         else if (eq :around (car qualifiers))
410           collect method into around
411         else if (eq :after (car qualifiers))
412           collect method into after
413         else if (eq :before (car qualifiers))
414           collect method into before
415         finally
416           (return (values around before (first primary) (reverse after)))))
417
418 ;;;
419 ;;; Return a form initializing instance and class slots of an object
420 ;;; costructed by CTOR.  The variable .SLOTS. is assumed to bound to
421 ;;; the instance's slot vector.  BEFORE-METHOD-P T means
422 ;;; before-methods will be called, which means that 1) other code will
423 ;;; initialize instance slots to +SLOT-UNBOUND+ before the
424 ;;; before-methods are run, and that we have to check if these
425 ;;; before-methods have set slots.
426 ;;;
427 (defun slot-init-forms (ctor before-method-p)
428   (let* ((class (ctor-class ctor))
429          (initargs (ctor-initargs ctor))
430          (initkeys (plist-keys initargs))
431          (slot-vector
432           (make-array (layout-length (class-wrapper class))
433                       :initial-element nil))
434          (class-inits ())
435          (default-inits ())
436          (default-initargs (class-default-initargs class))
437          (initarg-locations
438           (compute-initarg-locations
439            class (append initkeys (mapcar #'car default-initargs)))))
440     (labels ((initarg-locations (initarg)
441                (cdr (assoc initarg initarg-locations :test #'eq)))
442              (initializedp (location)
443                (cond
444                  ((consp location)
445                   (assoc location class-inits :test #'eq))
446                  ((integerp location)
447                   (not (null (aref slot-vector location))))
448                  (t (bug "Weird location in ~S" 'slot-init-forms))))
449              (class-init (location type val)
450                (aver (consp location))
451                (unless (initializedp location)
452                  (push (list location type val) class-inits)))
453              (instance-init (location type val)
454                (aver (integerp location))
455                (unless (initializedp location)
456                  (setf (aref slot-vector location) (list type val))))
457              (default-init-var-name (i)
458                (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
459                  (if (array-in-bounds-p ps i)
460                      (aref ps i)
461                      (format-symbol *pcl-package* ".D~D." i)))))
462       ;; Loop over supplied initargs and values and record which
463       ;; instance and class slots they initialize.
464       (loop for (key value) on initargs by #'cddr
465             as locations = (initarg-locations key) do
466               (if (constantp value)
467                   (dolist (location locations)
468                     (if (consp location)
469                         (class-init location 'constant value)
470                         (instance-init location 'constant value)))
471                     (dolist (location locations)
472                       (if (consp location)
473                           (class-init location 'param value)
474                           (instance-init location 'param value)))))
475       ;;
476       ;; Loop over default initargs of the class, recording
477       ;; initializations of slots that have not been initialized
478       ;; above.  Default initargs which are not in the supplied
479       ;; initargs are treated as if they were appended to supplied
480       ;; initargs, that is, their values must be evaluated even
481       ;; if not actually used for initializing a slot.
482       ;;
483       (loop for (key initfn initform) in default-initargs and i from 0
484             unless (member key initkeys :test #'eq) do
485             (let* ((type (if (constantp initform) 'constant 'var))
486                    (init (if (eq type 'var) initfn initform)))
487               (when (eq type 'var)
488                 (let ((init-var (default-init-var-name i)))
489                   (setq init init-var)
490                   (push (cons init-var initfn) default-inits)))
491               (dolist (location (initarg-locations key))
492                 (if (consp location)
493                     (class-init location type init)
494                     (instance-init location type init)))))
495       ;; Loop over all slots of the class, filling in the rest from
496       ;; slot initforms.
497       (loop for slotd in (class-slots class)
498             as location = (slot-definition-location slotd)
499             as allocation = (slot-definition-allocation slotd)
500             as initfn = (slot-definition-initfunction slotd)
501             as initform = (slot-definition-initform slotd) do
502               (unless (or (eq allocation :class)
503                           (null initfn)
504                           (initializedp location))
505                 (if (constantp initform)
506                     (instance-init location 'initform initform)
507                     (instance-init location 'initform/initfn initfn))))
508       ;; Generate the forms for initializing instance and class slots.
509       (let ((instance-init-forms
510              (loop for slot-entry across slot-vector and i from 0
511                    as (type value) = slot-entry collect
512                      (ecase type
513                        ((nil)
514                         (unless before-method-p
515                           `(setf (clos-slots-ref .slots. ,i) +slot-unbound+)))
516                        ((param var)
517                         `(setf (clos-slots-ref .slots. ,i) ,value))
518                        (initfn
519                         `(setf (clos-slots-ref .slots. ,i) (funcall ,value)))
520                        (initform/initfn
521                         (if before-method-p
522                             `(when (eq (clos-slots-ref .slots. ,i)
523                                        +slot-unbound+)
524                                (setf (clos-slots-ref .slots. ,i)
525                                      (funcall ,value)))
526                             `(setf (clos-slots-ref .slots. ,i)
527                                    (funcall ,value))))
528                        (initform
529                         (if before-method-p
530                             `(when (eq (clos-slots-ref .slots. ,i)
531                                        +slot-unbound+)
532                                (setf (clos-slots-ref .slots. ,i)
533                                      ',(eval value)))
534                             `(setf (clos-slots-ref .slots. ,i)
535                                    ',(eval value))))
536                        (constant
537                         `(setf (clos-slots-ref .slots. ,i) ',(eval value))))))
538             (class-init-forms
539              (loop for (location type value) in class-inits collect
540                      `(setf (cdr ',location)
541                             ,(ecase type
542                                (constant `',(eval value))
543                                ((param var) `,value)
544                                (initfn `(funcall ,value)))))))
545         (multiple-value-bind (vars bindings)
546             (loop for (var . initfn) in (nreverse default-inits)
547                   collect var into vars
548                   collect `(,var (funcall ,initfn)) into bindings
549                   finally (return (values vars bindings)))
550           `(let ,bindings
551              (declare (ignorable ,@vars))
552              ,@(delete nil instance-init-forms)
553              ,@class-init-forms))))))
554
555 ;;;
556 ;;; Return an alist of lists (KEY LOCATION ...) telling, for each
557 ;;; key in INITKEYS, which locations the initarg initializes.
558 ;;; CLASS is the class of the instance being initialized.
559 ;;;
560 (defun compute-initarg-locations (class initkeys)
561   (loop with slots = (class-slots class)
562         for key in initkeys collect
563           (loop for slot in slots
564                 if (memq key (slot-definition-initargs slot))
565                   collect (slot-definition-location slot) into locations
566                 else
567                   collect slot into remaining-slots
568                 finally
569                   (setq slots remaining-slots)
570                   (return (cons key locations)))))
571
572 \f
573 ;;; *******************************
574 ;;; External Entry Points  ********
575 ;;; *******************************
576
577 (defun update-ctors (reason &key class name generic-function method)
578   (labels ((reset (class &optional ri-cache-p (ctorsp t))
579              (when ctorsp
580                (dolist (ctor (plist-value class 'ctors))
581                  (install-initial-constructor ctor)))
582              (when ri-cache-p
583                (setf (plist-value class 'ri-initargs) ()))
584              (dolist (subclass (class-direct-subclasses class))
585                (reset subclass ri-cache-p ctorsp))))
586     (ecase reason
587       ;;
588       ;; CLASS must have been specified.
589       (finalize-inheritance
590        (reset class t))
591       ;;
592       ;; NAME must have been specified.
593       (setf-find-class
594        (loop for ctor in *all-ctors*
595              when (eq (ctor-class-name ctor) name) do
596              (when (ctor-class ctor)
597                (reset (ctor-class ctor)))
598              (loop-finish)))
599       ;;
600       ;; GENERIC-FUNCTION and METHOD must have been specified.
601       ((add-method remove-method)
602        (flet ((class-of-1st-method-param (method)
603                 (type-class (first (method-specializers method)))))
604          (case (generic-function-name generic-function)
605            ((make-instance allocate-instance
606              initialize-instance shared-initialize)
607             (reset (class-of-1st-method-param method) t t))
608            ((reinitialize-instance)
609             (reset (class-of-1st-method-param method) t nil))))))))
610
611 (defun precompile-ctors ()
612   (dolist (ctor *all-ctors*)
613     (when (null (ctor-class ctor))
614       (let ((class (find-class (ctor-class-name ctor) nil)))
615         (when (and class (class-finalized-p class))
616           (install-optimized-constructor ctor))))))
617
618 (defun check-ri-initargs (instance initargs)
619   (let* ((class (class-of instance))
620          (keys (plist-keys initargs))
621          (cached (assoc keys (plist-value class 'ri-initargs)
622                         :test #'equal))
623          (invalid-keys
624           (if (consp cached)
625               (cdr cached)
626               (let ((invalid
627                      ;; FIXME: give CHECK-INITARGS-1 and friends a
628                      ;; more mnemonic name and (possibly) a nicer,
629                      ;; more orthogonal interface.
630                      (check-initargs-1
631                       class initargs
632                       (list (list* 'reinitialize-instance instance initargs)
633                             (list* 'shared-initialize instance nil initargs))
634                       t nil)))
635                 (setf (plist-value class 'ri-initargs)
636                       (acons keys invalid cached))
637                 invalid))))
638     (when invalid-keys
639       (error 'initarg-error :class class :initargs invalid-keys))))
640
641 ;;; end of ctor.lisp