source: trunk/source/level-1/l1-clos.lisp @ 11409

Last change on this file since 11409 was 11409, checked in by gz, 11 years ago

undo make-instance optimizations when class slots change and when classes are renamed. Get rid of *sealed-clos-world* because all the optimizations should now be safe

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 101.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Copyright (C) 2002-2003 Clozure Associates
5;;;   This file is part of OpenMCL.
6;;;
7;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with OpenMCL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17;;;
18
19;;; At this point in the load sequence, the handful of extant basic classes
20;;; exist only in skeletal form (without direct or effective slot-definitions.)
21
22(in-package "CCL")
23
24(defun extract-slotds-with-allocation (allocation slotds)
25  (collect ((right-ones))
26    (dolist (s slotds (right-ones))
27      (if (eq (%slot-definition-allocation s) allocation)
28        (right-ones s)))))
29
30(defun extract-instance-direct-slotds (class)
31  (extract-slotds-with-allocation :instance (%class-direct-slots class)))
32
33(defun extract-class-direct-slotds (class)
34  (extract-slotds-with-allocation :class (%class-direct-slots class)))
35
36(defun extract-instance-effective-slotds (class)
37  (extract-slotds-with-allocation :instance (%class-slots class)))
38
39(defun extract-class-effective-slotds (class)
40  (extract-slotds-with-allocation :class (%class-slots class)))
41
42(defun extract-instance-and-class-slotds (slotds)
43  (collect ((instance-slots)
44            (shared-slots))
45    (dolist (s slotds (values (instance-slots) (shared-slots)))
46      (if (eq (%slot-definition-allocation s) :class)
47        (shared-slots s)
48        (instance-slots s)))))
49
50
51
52(defun direct-instance-and-class-slotds (class)
53  (extract-instance-and-class-slotds (%class-direct-slots class)))
54
55(defun effective-instance-and-class-slotds (class)
56  (extract-instance-and-class-slotds (%class-slots class)))
57
58(defun %early-shared-initialize (instance slot-names initargs)
59  (unless (or (listp slot-names) (eq slot-names t))
60    (report-bad-arg slot-names '(or list (eql t))))
61  ;; Check that initargs contains valid key/value pairs,
62  ;; signal a PROGRAM-ERROR otherwise.  (Yes, this is
63  ;; an obscure way to do so.)
64  (destructuring-bind (&key &allow-other-keys) initargs)
65  (let* ((wrapper (instance-class-wrapper instance))
66         (class (%wrapper-class wrapper)))
67    (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete
68      (update-obsolete-instance instance)
69      (setq wrapper (instance-class-wrapper instance)))
70    (dolist (slotd (%class-slots class))
71      (let* ((loc (%slot-definition-location slotd)))
72        (multiple-value-bind (ignore new-value foundp)
73            (get-properties initargs
74                            (%slot-definition-initargs slotd))
75          (declare (ignore ignore))
76          (if foundp
77            (progn
78              (unless (funcall (standard-effective-slot-definition.type-predicate slotd) new-value)
79                (error 'bad-slot-type-from-initarg
80                       :slot-definition slotd
81                       :instance instance
82                       :datum new-value
83                       :expected-type  (%slot-definition-type slotd)
84                       :initarg-name (car foundp)))
85              (if (consp loc)
86                (rplacd loc new-value)
87                (setf (standard-instance-instance-location-access instance loc)
88                      new-value)))
89            (if (or (eq slot-names t)
90                    (member (%slot-definition-name slotd)
91                            slot-names
92                            :test #'eq))
93              (let* ((curval (if (consp loc)
94                               (cdr loc)
95                               (%standard-instance-instance-location-access
96                                instance loc))))
97                (if (eq curval (%slot-unbound-marker))
98                  (let* ((initfunction (%slot-definition-initfunction slotd)))
99                    (if initfunction
100                      (let* ((newval (funcall initfunction)))
101                        (unless (funcall (standard-effective-slot-definition.type-predicate slotd) newval)
102                          (error 'bad-slot-type-from-initform
103                                 :slot-definition slotd
104                                 :expected-type (%slot-definition-type slotd)
105                                 :datum newval
106                                 :instance instance))
107                        (if (consp loc)
108                          (rplacd loc newval)
109                          (setf (standard-instance-instance-location-access
110                                 instance loc)
111                                newval)))))))))))))
112  instance)
113
114(setf (fdefinition '%shared-initialize) #'%early-shared-initialize)
115
116;;; This is redefined (to call MAKE-INSTANCE) below.
117(setf (fdefinition '%make-direct-slotd)
118      #'(lambda (slotd-class &key
119                             name
120                             initfunction
121                             initform
122                             initargs
123                             (allocation :instance)
124                             class
125                             (type t)
126                             (documentation (%slot-unbound-marker))
127                             readers
128                             writers)
129          (declare (ignore slotd-class))
130          (%instance-vector
131           (%class.own-wrapper *standard-direct-slot-definition-class*)
132           name type initfunction initform initargs allocation
133           documentation class readers writers)))
134
135;;; Also redefined below, after MAKE-INSTANCE is possible.
136(setf (fdefinition '%make-effective-slotd)
137      #'(lambda (slotd-class &key
138                             name
139                             initfunction
140                             initform
141                             initargs
142                             allocation
143                             class
144                             type
145                             documentation)
146          (declare (ignore slotd-class))
147          (%instance-vector
148           (%class.own-wrapper *standard-effective-slot-definition-class*)
149           name type initfunction initform initargs allocation
150           documentation class nil (ensure-slot-id name) #'true)))
151
152
153(defmethod compile-time-class-p ((class class)) nil)
154
155(defmethod direct-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys)
156  (unless (member allocation '(:instance :class))
157    (report-bad-arg allocation '(member (:instance :class))))
158  *standard-direct-slot-definition-class*)
159
160(defmethod effective-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys)
161  (unless (member allocation '(:instance :class))
162    (report-bad-arg allocation '(member (:instance :class))))
163  *standard-effective-slot-definition-class*)
164
165(defun make-direct-slot-definition (class initargs)
166  (apply #'%make-direct-slotd
167         (apply #'direct-slot-definition-class class initargs)
168         :class class
169         initargs))
170
171(defun make-effective-slot-definition (class &rest initargs)
172  (declare (dynamic-extent initargs))
173  (apply #'%make-effective-slotd
174         (apply #'effective-slot-definition-class class initargs)
175         initargs))
176
177;; Bootstrapping version, replaced in l1-typesys
178(fset 'standardized-type-specifier
179      (nlambda bootstrapping-standardized-type-specifier (spec)
180        (when (and (consp spec)
181                   (memq (%car spec) '(and or))
182                   (consp (%cdr spec))
183                   (null (%cddr spec)))
184          (setq spec (%cadr spec)))
185        (if (consp spec)
186          (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec)))
187          (or (cdr (assoc spec '((string . base-string))))
188              spec))))
189
190;;; The type of an effective slot definition is the intersection of
191;;; the types of the direct slot definitions it's initialized from.
192(defun dslotd-type-intersection (direct-slots)
193  (or (dolist (dslotd direct-slots t)
194        (unless (eq t (%slot-definition-type dslotd))
195          (return)))
196      (standardized-type-specifier
197       `(and ,@(mapcar #'(lambda (d) (or (%slot-definition-type d) t))
198                       direct-slots)))))
199
200(defmethod compute-effective-slot-definition ((class slots-class)
201                                              name
202                                              direct-slots)
203 
204  (let* ((initer (dolist (s direct-slots)
205                   (when (%slot-definition-initfunction s)
206                     (return s))))
207         (documentor (dolist (s direct-slots)
208                       (when (%slot-definition-documentation s)
209                         (return s))))
210         (first (car direct-slots))
211         (initargs (let* ((initargs nil))
212                     (dolist (dslot direct-slots initargs)
213                       (dolist (dslot-arg (%slot-definition-initargs  dslot))
214                         (pushnew dslot-arg initargs :test #'eq))))))
215    (make-effective-slot-definition
216     class
217     :name name
218     :allocation (%slot-definition-allocation first)
219     :documentation (when documentor (nth-value
220                                      1
221                                      (%slot-definition-documentation
222                                       documentor)))
223     :class (%slot-definition-class first)
224     :initargs initargs
225     :initfunction (if initer (%slot-definition-initfunction initer))
226     :initform (if initer (%slot-definition-initform initer))
227     :type (dslotd-type-intersection direct-slots))))
228
229(defmethod compute-slots ((class slots-class))
230  (let* ((slot-name-alist ()))
231    (labels ((note-direct-slot (dslot)
232               (let* ((sname (%slot-definition-name dslot))
233                      (pair (assq sname slot-name-alist)))
234                 (if pair
235                   (push dslot (cdr pair))
236                   (push (list sname dslot) slot-name-alist))))
237             (rwalk (tail)
238               (when tail
239                 (rwalk (cdr tail))
240                 (let* ((c (car tail)))
241                   (unless (eq c *t-class*)
242                     (dolist (dslot (%class-direct-slots c))
243                       (note-direct-slot dslot)))))))
244      (rwalk (class-precedence-list class)))
245    (collect ((effective-slotds))
246      (dolist (pair (nreverse slot-name-alist) (effective-slotds))
247        (effective-slotds (compute-effective-slot-definition class (car pair) (cdr pair)))))))
248
249
250(defmethod compute-slots :around ((class std-class))
251  (let* ((cpl (%class.cpl class)))
252    (multiple-value-bind (instance-slots class-slots)
253        (extract-instance-and-class-slotds (call-next-method))
254      (setq instance-slots (sort-effective-instance-slotds instance-slots class cpl))
255      (do* ((loc 1 (1+ loc))
256            (islotds instance-slots (cdr islotds)))
257           ((null islotds))
258        (declare (fixnum loc))
259        (setf (%slot-definition-location (car islotds)) loc))
260      (dolist (eslotd class-slots)
261        (setf (%slot-definition-location eslotd) 
262              (assoc (%slot-definition-name eslotd)
263                     (%class-get (%slot-definition-class eslotd)
264                                 :class-slots)
265                     :test #'eq)))
266      (append instance-slots class-slots))))
267
268(defmethod compute-slots :around ((class structure-class))
269  (let* ((slots (call-next-method))      )
270      (do* ((loc 1 (1+ loc))
271            (islotds slots (cdr islotds)))
272           ((null islotds) slots)
273        (declare (fixnum loc))
274        (setf (%slot-definition-location (car islotds)) loc))))
275
276;;; Should eventually do something here.
277;(defmethod compute-slots ((s structure-class))
278;  (call-next-method))
279
280(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
281  (declare (ignore initargs))
282  (find-class 'structure-direct-slot-definition))
283
284(defmethod effective-slot-definition-class ((class structure-class) &rest  initargs)
285  (declare (ignore initargs))
286  (find-class 'structure-effective-slot-definition))
287
288
289(defmethod compute-default-initargs ((class slots-class))
290  (let* ((initargs ()))
291    (dolist (c (%class-precedence-list class) (nreverse initargs))
292      (if (typep c 'forward-referenced-class)
293        (error
294         "Class precedence list of ~s contains FORWARD-REFERENCED-CLASS ~s ."
295         class c)
296        (dolist (i (%class-direct-default-initargs c))
297          (pushnew i initargs :test #'eq :key #'car))))))
298
299
300
301
302(defvar *update-slots-preserve-existing-wrapper* nil)
303
304(defvar *optimized-dependents* (make-hash-table :test 'eq :weak :key)
305  "Hash table mapping a class to a list of all objects that have been optimized to
306   depend in some way on the layout of the class")
307
308(defun note-class-dependent (class gf)
309  (pushnew gf (gethash class *optimized-dependents*)))
310
311(defun unoptimize-dependents (class)
312  (pessimize-make-instance-for-class-name (%class-name class))
313  (loop for obj in (gethash class *optimized-dependents*)
314        do (etypecase obj
315             (standard-generic-function
316              (clear-gf-dispatch-table (%gf-dispatch-table obj))
317              (compute-dcode obj)))))
318
319(defun update-slots (class eslotds)
320  (let* ((instance-slots (extract-slotds-with-allocation :instance eslotds))
321         (new-ordering
322          (let* ((v (make-array (the fixnum (length instance-slots))))
323                 (i 0))
324            (declare (simple-vector v) (fixnum i))
325            (dolist (e instance-slots v)
326              (setf (svref v i)
327                    (%slot-definition-name e))
328              (incf i))))
329         (old-wrapper (%class-own-wrapper class))
330         (new-wrapper
331          (cond ((null old-wrapper)
332                 (%cons-wrapper class))
333                ((and old-wrapper *update-slots-preserve-existing-wrapper*)
334                 old-wrapper)
335                (t
336                 (unoptimize-dependents class)
337                 (make-instances-obsolete class)
338                 (%cons-wrapper class)))))
339    (setf (%class-slots class) eslotds)
340    (setf (%wrapper-instance-slots new-wrapper) new-ordering
341          (%wrapper-class-slots new-wrapper) (%class-get class :class-slots)
342          (%class-own-wrapper class) new-wrapper)
343    (setup-slot-lookup new-wrapper eslotds)))
344
345
346 
347(defun setup-slot-lookup (wrapper eslotds)
348  (when eslotds
349    (let* ((nslots (length eslotds))
350           (total-slot-ids (current-slot-index))
351           (small (< nslots 255))
352           (map
353            (if small
354              (make-array total-slot-ids :element-type '(unsigned-byte 8))
355              (make-array total-slot-ids :element-type '(unsigned-byte 32))))
356           (table (make-array (the fixnum (1+ nslots))))
357           (i 0))
358      (declare (fixnum nslots total-slot-ids i) (simple-vector table))
359      (setf (svref table 0) nil)
360      (dolist (slotd eslotds)
361        (incf i)
362        (setf (svref table i) slotd)
363        (if small
364          (locally (declare (type (simple-array (unsigned-byte 8) (*)) map))
365            (setf (aref map
366                        (slot-id.index
367                         (standard-effective-slot-definition.slot-id slotd)))
368                  i))
369          (locally (declare (type (simple-array (unsigned-byte 32) (*)) map))
370            (setf (aref map
371                        (slot-id.index
372                         (standard-effective-slot-definition.slot-id slotd)))
373                  i))))
374      (let* ((lookup-f
375              #+ppc-target
376              (gvector :function
377                                (%svref (if small
378                                          #'%small-map-slot-id-lookup
379                                          #'%large-map-slot-id-lookup) 0)
380                                map
381                                table
382                                (dpb 1 $lfbits-numreq
383                                     (ash -1 $lfbits-noname-bit)))
384              #+x86-target
385              (%clone-x86-function (if small
386                                          #'%small-map-slot-id-lookup
387                                          #'%large-map-slot-id-lookup)
388                                   map
389                                   table
390                                   (dpb 1 $lfbits-numreq
391                                     (ash -1 $lfbits-noname-bit))))
392             (class (%wrapper-class wrapper))
393             (get-f
394              #+ppc-target
395              (gvector :function
396                       (%svref (if small
397                                 #'%small-slot-id-value
398                                 #'%large-slot-id-value) 0)
399                       map
400                       table
401                       class
402                       #'%maybe-std-slot-value-using-class
403                       #'%slot-id-ref-missing
404                       (dpb 2 $lfbits-numreq
405                            (ash -1 $lfbits-noname-bit)))
406              #+x86-target
407              (%clone-x86-function (if small
408                                     #'%small-slot-id-value
409                                     #'%large-slot-id-value)
410                                   map
411                                   table
412                                   class
413                                   #'%maybe-std-slot-value-using-class
414                                   #'%slot-id-ref-missing
415                                   (dpb 2 $lfbits-numreq
416                                        (ash -1 $lfbits-noname-bit))))
417             (set-f
418              #+ppc-target
419              (gvector :function
420                       (%svref (if small
421                                 #'%small-set-slot-id-value
422                                 #'%large-set-slot-id-value) 0)
423                       map
424                       table
425                       class
426                       #'%maybe-std-setf-slot-value-using-class
427                       #'%slot-id-set-missing
428                       (dpb 3 $lfbits-numreq
429                            (ash -1 $lfbits-noname-bit)))
430              #+x86-target
431              (%clone-x86-function
432               (if small
433                 #'%small-set-slot-id-value
434                 #'%large-set-slot-id-value)
435               map
436               table
437               class
438               #'%maybe-std-setf-slot-value-using-class
439               #'%slot-id-set-missing
440               (dpb 3 $lfbits-numreq
441                    (ash -1 $lfbits-noname-bit)))))
442        (setf (%wrapper-slot-id->slotd wrapper) lookup-f
443              (%wrapper-slot-id-value wrapper) get-f
444              (%wrapper-set-slot-id-value wrapper) set-f
445              (%wrapper-slot-id-map wrapper) map
446              (%wrapper-slot-definition-table wrapper) table))))
447  wrapper)
448
449                       
450   
451
452(defmethod validate-superclass ((class class) (super class))
453  (or (eq super *t-class*)
454      (let* ((class-of-class (class-of class))
455             (class-of-super (class-of super)))
456        (or (eq class-of-class class-of-super)
457            (and (eq class-of-class *standard-class-class*)
458                 (eq class-of-super *funcallable-standard-class-class*))
459            (and (eq class-of-class *funcallable-standard-class-class*)
460                 (eq class-of-super *standard-class-class*))))))
461
462(defmethod validate-superclass ((class foreign-class) (super standard-class))
463  t)
464
465(defmethod validate-superclass ((class std-class) (super forward-referenced-class))
466  t)
467
468
469(defmethod add-direct-subclass ((class class) (subclass class))
470  (pushnew subclass (%class-direct-subclasses class))
471  subclass)
472
473(defmethod remove-direct-subclass ((class class) (subclass class))
474  (setf (%class-direct-subclasses class)
475        (remove subclass (%class-direct-subclasses class)))
476  subclass)
477
478(defun add-direct-subclasses (class new)
479  (dolist (n new)
480    (unless (memq class (%class-direct-subclasses  class))
481      (add-direct-subclass n class))))
482
483(defun remove-direct-subclasses (class old-supers new-supers)
484  (dolist (o old-supers)
485    (unless (memq o new-supers)
486      (remove-direct-subclass o class))))
487
488;;; Built-in classes are always finalized.
489(defmethod class-finalized-p ((class class))
490  t)
491
492;;; Standard classes are finalized if they have a wrapper and that
493;;; wrapper has an instance-slots vector; that implies that
494;;; both UPDATE-CPL and UPDATE-SLOTS have been called on the class.
495(defmethod class-finalized-p ((class std-class))
496  (let* ((w (%class-own-wrapper class)))
497    (and w (typep (%wrapper-instance-slots w) 'vector))))
498
499(defmethod finalize-inheritance ((class std-class))
500  (update-class class t))
501
502
503(defmethod finalize-inheritance ((class forward-referenced-class))
504  (error "Class ~s can't be finalized." class))
505
506(defmethod class-primary-p ((class slots-class))
507  (%class-primary-p class))
508
509(defmethod (setf class-primary-p) (new (class std-class))
510  (setf (%class-primary-p class) new))
511
512(defmethod class-primary-p ((class class))
513  t)
514
515(defmethod (setf class-primary-p) (new (class class))
516  new)
517
518
519(defun forward-referenced-class-p (class)
520  (and (%standard-instance-p class)
521       (eq (%class-of-instance class) *forward-referenced-class-class*)))
522
523;;; This uses the primary class information to sort the slots of a class.
524(defun sort-effective-instance-slotds (slotds class cpl)
525  (let (primary-slotds
526        primary-slotds-class
527        (primary-slotds-length 0))
528    (declare (fixnum primary-slotds-length))
529    (dolist (sup (cdr cpl))
530      (unless (eq sup *t-class*)     
531        (when (class-primary-p sup)
532          (let ((sup-slotds (extract-instance-effective-slotds sup)))
533            (if (null primary-slotds-class)
534              (setf primary-slotds-class sup
535                    primary-slotds sup-slotds
536                    primary-slotds-length (length sup-slotds))
537              (let ((sup-slotds-length (length sup-slotds)))
538                (do* ((i 0 (1+ i))
539                      (n (min sup-slotds-length primary-slotds-length))
540                      (sup-slotds sup-slotds (cdr sup-slotds))
541                      (primary-slotds primary-slotds (cdr primary-slotds)))
542                     ((= i n))
543                  (unless (eq (%slot-definition-name (car sup-slotds))
544                              (%slot-definition-name (car primary-slotds)))
545                    (error "While initializing ~s:~%~
546                            attempt to mix incompatible primary classes:~%~
547                            ~s and ~s"
548                           class sup primary-slotds-class)))
549                (when (> sup-slotds-length primary-slotds-length)
550                  (setq primary-slotds-class sup
551                        primary-slotds sup-slotds
552                        primary-slotds-length sup-slotds-length))))))))
553    (if (null primary-slotds-class)
554      slotds
555      (flet ((slotd-position (slotd)
556               (let* ((slotd-name (%slot-definition-name slotd)))
557                 (do* ((i 0 (1+ i))
558                       (primary-slotds primary-slotds (cdr primary-slotds)))
559                      ((= i primary-slotds-length) primary-slotds-length)
560                   (declare (fixnum i))
561                   (when (eq slotd-name
562                                (%slot-definition-name (car primary-slotds)))
563                   (return i))))))
564        (declare (dynamic-extent #'slotd-position))
565        (sort-list slotds '< #'slotd-position)))))
566
567
568
569
570(defun update-cpl (class cpl)
571  (if (class-finalized-p class)
572    (unless (equal (%class.cpl class) cpl)
573      (setf (%class.cpl class) cpl)
574      #|(force-cache-flushes class)|#)
575    (setf (%class.cpl class) cpl))
576  cpl)
577
578
579(defun class-has-a-forward-referenced-superclass-p (original)
580  (labels ((scan-forward-refs (class seen)
581             (unless (memq class seen)
582               (or (if (forward-referenced-class-p class) class)
583                   (let ((seen (cons class seen)))
584                     (declare (dynamic-extent seen))
585                     (dolist (s (%class-direct-superclasses class))
586                       (when (eq s original)
587                         (error "circular class hierarchy: the class ~s is a superclass of at least one of its superclasses (~s)." original class))
588                       (let* ((fwdref (scan-forward-refs s seen)))
589                         (when fwdref (return fwdref)))))))))
590    (or (compile-time-class-p original)
591        (scan-forward-refs original ()))))
592
593(defun class-forward-referenced-superclasses (original)
594  (labels ((scan-forward-refs (class seen fwdrefs)
595             (unless (memq class seen)
596               (if (forward-referenced-class-p class)
597                 (push class fwdrefs)
598                 (let ((seen (cons class seen)))
599                   (declare (dynamic-extent seen))
600                   (dolist (s (%class-direct-superclasses class))
601                     (when (eq s original)
602                       (error "circular class hierarchy: the class ~s is a superclass of at least one of its superclasses (~s)." original class))
603                     (setq fwdrefs (scan-forward-refs s seen fwdrefs))))))
604             fwdrefs))
605    (scan-forward-refs original () ())))
606 
607
608
609(defmethod compute-class-precedence-list ((class class))
610  (let* ((fwdrefs (class-forward-referenced-superclasses class)))
611    (if fwdrefs
612      (if (cdr fwdrefs)
613        (error "Class ~s can't be finalized because superclasses ~s are not defined yet"
614               class (mapcar #'%class-name fwdrefs))
615        (error "Class ~s can't be finalized because superclass ~s is not defined yet"
616               class (%class-name (car fwdrefs))))
617      (compute-cpl class))))
618
619;;; Classes that can't be instantiated via MAKE-INSTANCE have no
620;;; initargs caches.
621(defmethod %flush-initargs-caches ((class class))
622  )
623
624;;; Classes that have initargs caches should flush them when the
625;;; class is finalized.
626(defmethod %flush-initargs-caches ((class std-class))
627  (setf (%class.make-instance-initargs class) nil
628        (%class.reinit-initargs class) nil
629        (%class.redefined-initargs class) nil
630        (%class.changed-initargs class) nil))
631
632(defun update-class (class finalizep)
633  ;;
634  ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which
635  ;; makes the class finalized.  When UPDATE-CLASS isn't called from
636  ;; FINALIZE-INHERITANCE, make sure that this finalization invokes
637  ;; FINALIZE-INHERITANCE as per AMOP.  Note, that we can't simply
638  ;; delay the finalization when CLASS has no forward referenced
639  ;; superclasses because that causes bootstrap problems.
640  (when (and (not (or finalizep (class-finalized-p class)))
641             (not (class-has-a-forward-referenced-superclass-p class)))
642    (finalize-inheritance class)
643    (return-from update-class))
644  (when (or finalizep (class-finalized-p class))
645    (let* ((cpl (update-cpl class (compute-class-precedence-list  class))))
646      ;; This -should- be made to work for structure classes
647      (update-slots class (compute-slots class))
648      (setf (%class-default-initargs class) (compute-default-initargs class))
649      (%flush-initargs-caches class)
650      (let* ((wrapper (%class-own-wrapper class)))
651        (when wrapper
652          (setf (%wrapper-cpl wrapper) cpl
653                (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl))))))
654  (unless finalizep
655    (dolist (sub (%class-direct-subclasses class))
656      (update-class sub nil))))
657
658(defun add-accessor-methods (class dslotds)
659  (dolist (dslotd dslotds)
660    (dolist (reader (%slot-definition-readers dslotd))
661      (add-reader-method class
662                         (ensure-generic-function reader)
663                         dslotd))
664    (dolist (writer (%slot-definition-writers dslotd))
665      (add-writer-method class
666                         (ensure-generic-function writer)
667                         dslotd))))
668
669(defun remove-accessor-methods (class dslotds)
670  (dolist (dslotd dslotds)
671    (dolist (reader (%slot-definition-readers dslotd))
672      (remove-reader-method class (ensure-generic-function reader :lambda-list '(x))))
673    (dolist (writer (%slot-definition-writers dslotd))
674      (remove-writer-method class (ensure-generic-function writer :lambda-list '(x y))))))
675
676(defmethod reinitialize-instance :before ((class std-class)  &key direct-superclasses)
677  (remove-accessor-methods class (%class-direct-slots class))
678  (remove-direct-subclasses class (%class-direct-superclasses class) direct-superclasses))
679   
680(defmethod shared-initialize :after
681  ((class slots-class)
682   slot-names &key
683   (direct-superclasses nil direct-superclasses-p)
684   (direct-slots nil direct-slots-p)
685   (direct-default-initargs nil direct-default-initargs-p)
686   (documentation nil doc-p)
687   (primary-p nil primary-p-p))
688  (declare (ignore slot-names))
689  (if direct-superclasses-p
690    (progn
691      (setq direct-superclasses
692            (or direct-superclasses
693                (list (if (typep class 'funcallable-standard-class)
694                        *funcallable-standard-object-class*
695                        *standard-object-class*))))
696      (dolist (superclass direct-superclasses)
697        (unless (validate-superclass class superclass)
698          (error "The class ~S was specified as a~%super-class of the class ~S;~%~
699                    but the meta-classes ~S and~%~S are incompatible."
700                 superclass class (class-of superclass) (class-of class))))
701      (setf (%class-direct-superclasses class) direct-superclasses))
702    (setq direct-superclasses (%class-direct-superclasses class)))
703  (setq direct-slots
704        (if direct-slots-p
705          (setf (%class-direct-slots class)
706                (mapcar #'(lambda (initargs)
707                            (make-direct-slot-definition class initargs))
708                        direct-slots))
709          (%class-direct-slots class)))
710  (if direct-default-initargs-p
711    (setf (%class-direct-default-initargs class)  direct-default-initargs)
712    (setq direct-default-initargs (%class-direct-default-initargs class)))
713  (let* ((new-class-slot-cells ())
714         (old-class-slot-cells (%class-get class :class-slots)))
715    (dolist (slot direct-slots)
716      (when (eq (%slot-definition-allocation slot) :class)
717        (let* ((slot-name (%slot-definition-name slot))
718               (pair (assq slot-name old-class-slot-cells)))
719          ;;; If the slot existed as a class slot in the old
720          ;;; class, retain the definition (even if it's unbound.)
721          (unless pair
722            (let* ((initfunction (%slot-definition-initfunction slot)))
723              (setq pair (cons slot-name
724                               (if initfunction
725                                 (funcall initfunction)
726                                 (%slot-unbound-marker))))))
727          (push pair new-class-slot-cells))))
728    (when new-class-slot-cells
729      (setf (%class-get class :class-slots) new-class-slot-cells)))
730  (when doc-p
731    (set-documentation class 'type documentation))
732  (when primary-p-p
733    (setf (class-primary-p class) primary-p))
734
735  (add-direct-subclasses class direct-superclasses)
736  (update-class class nil)
737  (add-accessor-methods class direct-slots))
738
739(defmethod initialize-instance :before ((class class) &key &allow-other-keys)
740  (setf (%class-ordinal class) (%next-class-ordinal))
741  (setf (%class.ctype class) (make-class-ctype class)))
742
743(defun ensure-class-metaclass-and-initargs (class args)
744  (let* ((initargs (copy-list args))
745         (missing (cons nil nil))
746         (supplied-meta (getf initargs :metaclass missing))
747         (supplied-supers (getf initargs :direct-superclasses missing))
748         (supplied-slots (getf initargs :direct-slots missing))
749         (metaclass (cond ((not (eq supplied-meta missing))
750                           (if (typep supplied-meta 'class)
751                             supplied-meta
752                             (find-class supplied-meta)))
753                          ((or (null class)
754                               (typep class 'forward-referenced-class))
755                           *standard-class-class*)
756                          (t (class-of class)))))
757    (declare (dynamic-extent missing))
758    (flet ((fix-super (s)
759             (cond ((classp s) s)
760                   ((not (and s (symbolp s)))
761                    (error "~s is not a class or a legal class name." s))
762                   (t
763                    (or (find-class s nil)
764                        (setf (find-class s)
765                              (make-instance 'forward-referenced-class :name s))))))
766           (excise-all (keys)
767             (dolist (key keys)
768               (loop (unless (remf initargs key) (return))))))
769      (excise-all '(:metaclass :direct-superclasses :direct-slots))
770      (values metaclass
771              `(,@ (unless (eq supplied-supers missing)
772                     `(:direct-superclasses ,(mapcar #'fix-super supplied-supers)))
773                ,@ (unless (eq supplied-slots missing)
774                     `(:direct-slots ,supplied-slots))
775               ,@initargs)))))
776
777
778;;; This defines a new class.
779(defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys)
780  (multiple-value-bind (metaclass initargs)
781      (ensure-class-metaclass-and-initargs class keys)
782    (let* ((class (apply #'make-instance metaclass :name name initargs)))
783      (setf (find-class name) class))))
784
785(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys)
786  (multiple-value-bind (metaclass initargs)
787      (ensure-class-metaclass-and-initargs class keys)
788    (apply #'change-class class metaclass initargs)
789    (apply #'reinitialize-instance class initargs)
790    (setf (find-class name) class)))
791           
792;; Can't go with optimize-make-instance-for-class-name because
793;; ensure-class-using-class is called before that is defined.
794(defun pessimize-make-instance-for-class-name (class-name)
795  (let ((cell (find-class-cell class-name nil)))
796    (when cell
797      (init-class-cell-instantiator cell))))
798
799(defun init-class-cell-instantiator (cell)
800  (when cell
801    (setf (class-cell-instantiate cell) '%make-instance)
802    (setf (class-cell-extra cell) nil)))
803
804;;; Redefine an existing (not forward-referenced) class.
805(defmethod ensure-class-using-class ((class class) name &rest keys &key)
806  (multiple-value-bind (metaclass initargs)
807      (ensure-class-metaclass-and-initargs class keys)
808    (unless (eq (class-of class) metaclass)
809      (error "Can't change metaclass of ~s to ~s." class metaclass))
810    (apply #'reinitialize-instance class initargs)
811    (setf (find-class name) class)))
812
813
814(defun ensure-class (name &rest keys &key &allow-other-keys)
815  (declare (dynamic-extent keys))
816  (apply #'ensure-class-using-class (find-class name nil) name keys))
817
818(defparameter *defclass-redefines-improperly-named-classes-pedantically* 
819   t
820  "ANSI CL expects DEFCLASS to redefine an existing class only when
821the existing class is properly named, the MOP function ENSURE-CLASS
822redefines existing classes regardless of their CLASS-NAME.  This variable
823governs whether DEFCLASS makes that distinction or not.")
824
825(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
826  (declare (dynamic-extent keys))
827  (record-source-file name 'class)
828  (let* ((existing-class (find-class name nil)))
829    (when (and *defclass-redefines-improperly-named-classes-pedantically* 
830               existing-class 
831               (not (eq (class-name existing-class) name)))
832      ;; Class isn't properly named; act like it didn't exist
833      (setq existing-class nil))
834    (apply #'ensure-class-using-class existing-class name keys)))
835
836
837
838
839(defmethod method-slot-name ((m standard-accessor-method))
840  (standard-direct-slot-definition.name (%accessor-method.slot-definition m)))
841
842
843(defun %ensure-class-preserving-wrapper (&rest args)
844  (declare (dynamic-extent args))
845  (let* ((*update-slots-preserve-existing-wrapper* t))
846    (apply #'ensure-class args)))
847
848(defun %find-direct-slotd (class name)
849  (dolist (dslotd (%class-direct-slots class)
850           (error "Direct slot definition for ~s not found in ~s" name class))
851    (when (eq (%slot-definition-name dslotd) name)
852      (return dslotd))))
853
854(defun %add-slot-readers (class-name pairs)
855  (let* ((class (find-class class-name)))
856    (dolist (pair pairs)
857      (destructuring-bind (slot-name &rest readers) pair
858        (setf (%slot-definition-readers (%find-direct-slotd class slot-name)) readers)))
859    (add-accessor-methods class (%class-direct-slots class))))
860
861(defun %add-slot-writers (class-name pairs)
862  (let* ((class (find-class class-name)))
863    (dolist (pair pairs)
864      (destructuring-bind (slot-name &rest readers) pair
865        (setf (%slot-definition-writers (%find-direct-slotd class slot-name)) readers)))
866    (add-accessor-methods class (%class-direct-slots class))))
867
868
869(%ensure-class-preserving-wrapper
870 'standard-method
871 :direct-superclasses '(method)
872 :direct-slots `((:name qualifiers :initargs (:qualifiers) :initfunction ,#'false :initform nil)
873                 (:name specializers :initargs (:specializers) :initfunction ,#'false :initform nil)
874                 (:name function :initargs (:function))
875                 (:name generic-function :initargs (:generic-function) :initfunction ,#'false :initform nil)
876                 (:name name :initargs (:name) :initfunction ,#'false :initform nil)
877                 (:name lambda-list :initform nil :initfunction ,#'false
878                  :initargs (:lambda-list)))
879 :primary-p t)
880
881(defmethod shared-initialize :after ((method standard-method)
882                                     slot-names
883                                     &key function &allow-other-keys)
884  (declare (ignore slot-names))
885  (when function
886    (let* ((inner (closure-function function)))
887      (unless (eq inner function)
888        (copy-method-function-bits inner function)))   
889    (lfun-name function method)))
890
891;;; Reader & writer methods classes.
892(%ensure-class-preserving-wrapper
893 'standard-accessor-method
894 :direct-superclasses '(standard-method)
895 :direct-slots '((:name slot-definition :initargs (:slot-definition)))
896 :primary-p t)
897
898(%ensure-class-preserving-wrapper
899 'standard-reader-method
900 :direct-superclasses '(standard-accessor-method))
901
902(%ensure-class-preserving-wrapper
903 'standard-writer-method
904 :direct-superclasses '(standard-accessor-method))
905
906(defmethod reader-method-class ((class standard-class)
907                                (dslotd standard-direct-slot-definition)
908                                &rest initargs)
909  (declare (ignore initargs))
910  *standard-reader-method-class*)
911
912(defmethod reader-method-class ((class funcallable-standard-class)
913                                (dslotd standard-direct-slot-definition)
914                                &rest initargs)
915  (declare (ignore  initargs))
916  *standard-reader-method-class*)
917
918(defmethod add-reader-method ((class slots-class) gf dslotd)
919  (let* ((initargs
920          `(:qualifiers nil
921            :specializers ,(list class)
922            :lambda-list (,(or (%class-name class) 'instance))
923            :name ,(function-name gf)
924            :slot-definition ,dslotd))
925         (reader-method-class
926          (apply #'reader-method-class class dslotd initargs))
927         (method-function (create-reader-method-function
928                           class (class-prototype reader-method-class) dslotd))
929         (method (apply #'make-instance reader-method-class
930                        :function method-function
931                        initargs)))
932    (declare (dynamic-extent initargs))
933    (record-source-file method 'reader-method)
934    (add-method gf method)))
935
936(defmethod remove-reader-method ((class std-class) gf)
937  (let* ((method (find-method gf () (list class) nil)))
938    (when method (remove-method gf method))))
939
940(defmethod writer-method-class ((class standard-class)
941                                (dslotd standard-direct-slot-definition)
942                                &rest initargs)
943  (declare (ignore initargs))
944  *standard-writer-method-class*)
945
946(defmethod writer-method-class ((class funcallable-standard-class)
947                                (dslotd standard-direct-slot-definition)
948                                &rest initargs)
949  (declare (ignore initargs))
950  *standard-writer-method-class*)
951
952
953(defmethod add-writer-method ((class slots-class) gf dslotd)
954  (let* ((initargs
955          `(:qualifiers nil
956            :specializers ,(list *t-class* class)
957            :lambda-list (new-value ,(or (%class-name class) 'instance))
958            :name ,(function-name gf)
959            :slot-definition ,dslotd))
960         (method-class (apply #'writer-method-class class dslotd initargs))
961         (method 
962          (apply #'make-instance
963                 method-class
964                 :function (create-writer-method-function
965                            class
966                            (class-prototype method-class)
967                            dslotd)
968                 initargs)))
969    (declare (dynamic-extent initargs))
970    (record-source-file method 'writer-method)
971    (add-method gf method)))
972
973(defmethod remove-writer-method ((class std-class) gf)
974  (let* ((method (find-method gf () (list *t-class* class) nil)))
975    (when method (remove-method gf method))))
976
977;;; We can now define accessors.  Fix up the slots in the classes defined
978;;; thus far.
979
980(%add-slot-readers 'standard-method '((qualifiers method-qualifiers)
981                                      (specializers method-specializers)
982                                      (name method-name)
983                                      ;(function method-function)
984                                      (generic-function method-generic-function)
985                                      (lambda-list method-lambda-list)))
986
987(%add-slot-writers 'standard-method '((function (setf method-function))
988                                      (generic-function (setf method-generic-function))))
989
990
991(defmethod method-function ((m standard-method))
992  (%method.function m))
993
994
995(%add-slot-readers 'standard-accessor-method
996                   '((slot-definition accessor-method-slot-definition)))
997
998
999(%ensure-class-preserving-wrapper
1000 'specializer
1001 :direct-superclasses '(metaobject)
1002 :direct-slots `((:name direct-methods
1003                  :readers (specializer-direct-methods)
1004                  :initform nil :initfunction ,#'false))
1005 :primary-p t)
1006                 
1007(%ensure-class-preserving-wrapper
1008 'eql-specializer
1009 :direct-superclasses '(specializer)
1010 :direct-slots '((:name object :initargs (:object) :readers (eql-specializer-object)))
1011 :primary-p t)
1012
1013
1014(%ensure-class-preserving-wrapper
1015 'class
1016 :direct-superclasses '(specializer)
1017 :direct-slots
1018 `((:name prototype :initform nil :initfunction ,#'false)
1019   (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name))
1020   (:name precedence-list :initform nil  :initfunction ,#'false)
1021   (:name own-wrapper :initform nil  :initfunction ,#'false :readers (class-own-wrapper) :writers ((setf class-own-wrapper)))
1022   (:name direct-superclasses  :initform nil  :initfunction ,#'false :readers (class-direct-superclasses))
1023   (:name direct-subclasses  :initform nil  :initfunction ,#'false :readers (class-direct-subclasses))
1024   (:name dependents :initform nil :initfunction ,#'false)
1025   (:name class-ctype :initform nil :initfunction ,#'false)
1026   (:name direct-slots :initform nil :initfunction ,#'false
1027                  :readers (class-direct-slots)
1028                  :writers ((setf class-direct-slots)))
1029   (:name slots :initform nil :initfunction ,#'false
1030    :readers (class-slots)
1031    :writers ((setf class-slots)))
1032   (:name info :initform (cons nil nil) :initfunction ,(lambda () (cons nil nil)) :readers (class-info))
1033   (:name direct-default-initargs  :initform nil  :initfunction ,#'false :readers (class-direct-default-initargs))
1034   (:name default-initargs :initform nil  :initfunction ,#'false :readers (class-default-initargs)))
1035 :primary-p t)
1036
1037(%ensure-class-preserving-wrapper
1038 'forward-referenced-class
1039 :direct-superclasses '(class))
1040
1041
1042
1043(%ensure-class-preserving-wrapper
1044 'built-in-class
1045 :direct-superclasses '(class))
1046
1047
1048(%ensure-class-preserving-wrapper
1049 'slots-class
1050 :direct-superclasses '(class)
1051 :direct-slots `((:name alist :initform nil  :initfunction ,#'false))
1052 :primary-p t)
1053
1054;;; This class exists only so that standard-class & funcallable-standard-class
1055;;; can inherit its slots.
1056(%ensure-class-preserving-wrapper
1057 'std-class
1058 :direct-superclasses '(slots-class)
1059 :direct-slots `(
1060                 (:name make-instance-initargs :initform nil  :initfunction ,#'false)
1061                 (:name reinit-initargs :initform nil  :initfunction ,#'false)
1062                 (:name redefined-initargs :initform nil :initfunction ,#'false)
1063                 (:name changed-initargs :initform nil  :initfunction ,#'false))
1064 :primary-p t)
1065
1066
1067
1068(%ensure-class-preserving-wrapper
1069 'standard-class
1070 :direct-superclasses '(std-class))
1071
1072(%ensure-class-preserving-wrapper
1073 'funcallable-standard-class
1074 :direct-superclasses '(std-class))
1075
1076
1077(%ensure-class-preserving-wrapper
1078 'funcallable-standard-object
1079#||
1080 :direct-superclasses '(standard-object function)
1081||#
1082 :direct-slots `((:name name :initargs (:name) :readers (generic-function-name)))
1083 :metaclass 'funcallable-standard-class)
1084
1085(%ensure-class-preserving-wrapper
1086 'generic-function
1087 :direct-superclasses '(metaobject funcallable-standard-object)
1088 :direct-slots `(
1089                 (:name method-combination :initargs (:method-combination)
1090                  :initform *standard-method-combination*
1091                  :initfunction ,#'(lambda () *standard-method-combination*)
1092                  :readers (generic-function-method-combination))
1093                 (:name method-class :initargs (:method-class)
1094                  :initform *standard-method-class*
1095                  :initfunction ,#'(lambda () *standard-method-class*)
1096                  :readers (generic-function-method-class))
1097                 (:name methods :initargs (:methods)
1098                  :initform nil :initfunction ,#'false
1099                  :readers (generic-function-methods))
1100                 (:name declarations
1101                  :initargs (:declarations)
1102                  :initform nil :initfunction ,#'false
1103                  :readers (generic-function-declarations))
1104                 (:name %lambda-list
1105                  :initform :unspecified
1106                  :initfunction ,(constantly :unspecified))
1107                 (:name dependents
1108                  :initform nil :initfunction ,#'false)) 
1109 :metaclass 'funcallable-standard-class)
1110
1111
1112
1113(%ensure-class-preserving-wrapper
1114 'standard-generic-function
1115 :direct-superclasses '(generic-function)
1116
1117 :metaclass 'funcallable-standard-class
1118 :primary-p t)
1119
1120(%ensure-class-preserving-wrapper
1121 'standard-generic-function
1122 :direct-superclasses '(generic-function)
1123
1124 :metaclass 'funcallable-standard-class)
1125
1126(%ensure-class-preserving-wrapper
1127 'structure-class
1128 :direct-superclasses '(slots-class))
1129
1130(%ensure-class-preserving-wrapper
1131 'slot-definition
1132 :direct-superclasses '(metaobject)
1133  :direct-slots `((:name name :initargs (:name) :readers (slot-definition-name)
1134                  :initform nil :initfunction ,#'false)
1135                 (:name type :initargs (:type) :readers (slot-definition-type)
1136                  :initform t :initfunction ,#'true)
1137                 (:name initfunction :initargs (:initfunction) :readers (slot-definition-initfunction)
1138                  :initform nil :initfunction ,#'false)
1139                 (:name initform :initargs (:initform) :readers (slot-definition-initform)
1140                  :initform nil :initfunction ,#'false)
1141                 (:name initargs :initargs (:initargs) :readers (slot-definition-initargs)
1142                  :initform nil :initfunction ,#'false)
1143                 (:name allocation :initargs (:allocation) :readers (slot-definition-allocation)
1144                  :initform :instance :initfunction ,(constantly :instance))
1145                 (:name documentation :initargs (:documentation) :readers (slot-definition-documentation)
1146                  :initform nil :initfunction ,#'false)
1147                 (:name class :initargs (:class) :readers (slot-definition-class)))
1148 
1149 :primary-p t)
1150
1151(%ensure-class-preserving-wrapper
1152 'direct-slot-definition
1153 :direct-superclasses '(slot-definition)
1154 :direct-slots `((:name readers :initargs (:readers) :initform nil
1155                  :initfunction ,#'false :readers (slot-definition-readers))
1156                 (:name writers :initargs (:writers) :initform nil
1157                  :initfunction ,#'false :readers (slot-definition-writers))))
1158
1159(%ensure-class-preserving-wrapper
1160 'effective-slot-definition
1161 :direct-superclasses '(slot-definition)
1162 :direct-slots `((:name location :initform nil :initfunction ,#'false
1163                  :readers (slot-definition-location))
1164                 (:name slot-id :initform nil :initfunction ,#'false
1165                  :readers (slot-definition-slot-id))
1166                 (:name type-predicate :initform nil
1167                  :initfunction ,#'false
1168                  :readers (slot-definition-predicate))
1169                 )
1170 
1171 :primary-p t)
1172
1173(%ensure-class-preserving-wrapper
1174 'standard-slot-definition
1175 :direct-superclasses '(slot-definition)
1176)
1177
1178
1179
1180
1181
1182
1183
1184(%ensure-class-preserving-wrapper
1185 'standard-direct-slot-definition
1186 :direct-superclasses '(standard-slot-definition direct-slot-definition)
1187)
1188
1189(%ensure-class-preserving-wrapper
1190 'standard-effective-slot-definition
1191 :direct-superclasses '(standard-slot-definition effective-slot-definition))
1192
1193                 
1194
1195
1196     
1197                             
1198
1199
1200
1201;;; Fake method-combination, redefined in lib;method-combination.
1202(defclass method-combination (metaobject) 
1203  ((name :initarg :name)))
1204
1205
1206
1207
1208(defclass standard-method-combination (method-combination) ())
1209
1210(initialize-instance *standard-method-combination* :name 'standard)
1211
1212(setq *standard-kernel-method-class*
1213  (defclass standard-kernel-method (standard-method)
1214    ()))
1215
1216(unless *standard-method-combination*
1217  (setq *standard-method-combination*
1218        (make-instance 'standard-method-combination :name 'standard)))
1219
1220;;; For %compile-time-defclass
1221(defclass compile-time-class (class) ())
1222
1223(defmethod compile-time-class-p ((class compile-time-class))
1224  t)
1225
1226(defmethod class-finalized-p ((class compile-time-class))
1227  nil)
1228
1229
1230(defclass structure-slot-definition (slot-definition) ())
1231(defclass structure-effective-slot-definition (structure-slot-definition
1232                                               effective-slot-definition)
1233    ())
1234
1235(defclass structure-direct-slot-definition (structure-slot-definition
1236                                            direct-slot-definition)
1237    ())
1238
1239(defmethod shared-initialize :after ((class structure-class)
1240                                     slot-names
1241                                     &key
1242                                     (direct-superclasses nil direct-superclasses-p)
1243                                     &allow-other-keys)
1244  (declare (ignore slot-names))
1245  (labels ((obsolete (class)
1246             (dolist (sub (%class-direct-subclasses class)) (obsolete sub))
1247             ;;Need to save old class info in wrapper for obsolete
1248             ;;instance access...
1249             (setf (%class.cpl class) nil)))
1250    (obsolete class)
1251    (when direct-superclasses-p
1252      (let* ((old-supers (%class-direct-superclasses class))
1253             (new-supers direct-superclasses))
1254        (dolist (c old-supers)
1255          (unless (memq c new-supers)
1256            (remove-direct-subclass c class)))
1257        (dolist (c new-supers)
1258          (unless (memq c old-supers)
1259            (add-direct-subclass c class)))
1260        (setf (%class.local-supers class) new-supers)))
1261    (let* ((wrapper (or (%class-own-wrapper class)
1262                        (setf (%class-own-wrapper class) (%cons-wrapper class))))
1263           (cpl (compute-cpl class)))
1264      (setf (%class.cpl class) cpl)
1265      (setf (%wrapper-cpl wrapper) cpl
1266            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)))))
1267             
1268
1269                                     
1270                                     
1271;;; Called from DEFSTRUCT expansion.
1272(defun %define-structure-class (sd)
1273  (let* ((dslots ()))
1274    (dolist (ssd (cdr (sd-slots sd)) (setq dslots (nreverse dslots)))
1275      (let* ((type (ssd-type ssd))
1276             (refinfo (ssd-refinfo ssd)))
1277        (unless (logbitp $struct-inherited refinfo)
1278          (let* ((name (ssd-name ssd))
1279                 (initform (cadr ssd))
1280                 (initfunction (constantly initform)))
1281            (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction) dslots)))))
1282    (ensure-class (sd-name sd)
1283                  :metaclass 'structure-class
1284                  :direct-superclasses (list (or (cadr (sd-superclasses sd)) 'structure-object))
1285                  :direct-slots  dslots 
1286                  )))
1287
1288
1289(defun standard-instance-access (instance location)
1290  (etypecase location
1291    (fixnum (%standard-instance-instance-location-access instance location))
1292    (cons (%cdr location))))
1293
1294(defun (setf standard-instance-access) (new instance location)
1295  (etypecase location
1296    (fixnum (setf (standard-instance-instance-location-access instance location)
1297                  new))
1298    (cons (setf (%cdr location) new))))
1299
1300(defun funcallable-standard-instance-access (instance location)
1301  (etypecase location
1302    (fixnum (%standard-generic-function-instance-location-access instance location))
1303    (cons (%cdr location))))
1304
1305(defun (setf funcallable-standard-instance-access) (new instance location)
1306  (etypecase location
1307    (fixnum (setf (%standard-generic-function-instance-location-access instance location) new))
1308    (cons (setf (%cdr location) new))))
1309
1310;;; Handle a trap from %slot-ref
1311(defun %slot-unbound-trap (slotv idx frame-ptr)
1312  (let* ((instance nil)
1313         (class nil)
1314         (slot nil))
1315    (if (and (eq (typecode slotv) target::subtag-slot-vector)
1316             (setq instance (slot-vector.instance slotv))
1317             (setq slot
1318                   (find idx (class-slots (setq class (class-of instance)))
1319                         :key #'slot-definition-location)))
1320      (slot-unbound class instance (slot-definition-name slot))
1321      (%error "Unbound slot at index ~d in ~s" (list idx slotv) frame-ptr))))
1322
1323
1324;;;
1325;;; Now that CLOS is nominally bootstrapped, it's possible to redefine some
1326;;; of the functions that really should have been generic functions ...
1327(setf (fdefinition '%class-name) #'class-name
1328      (fdefinition '%class-default-initargs) #'class-default-initargs
1329      (fdefinition '%class-direct-default-initargs) #'class-direct-default-initargs
1330      (fdefinition '(setf %class-direct-default-initargs))
1331      #'(lambda (new class)
1332          (if (typep class 'slots-class)
1333            (setf (slot-value class 'direct-default-initargs) new)
1334            new))
1335      (fdefinition '%class-direct-slots) #'class-direct-slots
1336      (fdefinition '(setf %class-direct-slots))
1337                   #'(setf class-direct-slots)
1338      (fdefinition '%class-slots) #'class-slots
1339      (fdefinition '%class-direct-superclasses) #'class-direct-superclasses
1340      (fdefinition '(setf %class-direct-superclasses))
1341      #'(lambda (new class)
1342          (setf (slot-value class 'direct-superclasses) new))
1343      (fdefinition '%class-direct-subclasses) #'class-direct-subclasses
1344      ;(fdefinition '%class-own-wrapper) #'class-own-wrapper
1345      (fdefinition '(setf %class-own-wrapper)) #'(setf class-own-wrapper)
1346)
1347
1348
1349
1350(setf (fdefinition '%slot-definition-name) #'slot-definition-name
1351      (fdefinition '%slot-definition-type) #'slot-definition-type
1352      (fdefinition '%slot-definition-initargs) #'slot-definition-initargs
1353      (fdefinition '%slot-definition-allocation) #'slot-definition-allocation
1354      (fdefinition '%slot-definition-location) #'slot-definition-location
1355      (fdefinition '%slot-definition-readers) #'slot-definition-readers
1356      (fdefinition '%slot-definition-writers) #'slot-definition-writers)
1357
1358
1359(setf (fdefinition '%method-qualifiers) #'method-qualifiers
1360      (fdefinition '%method-specializers) #'method-specializers
1361      (fdefinition '%method-function) #'method-function
1362      (fdefinition '(setf %method-function)) #'(setf method-function)
1363      (fdefinition '%method-gf) #'method-generic-function
1364      (fdefinition '(setf %method-gf)) #'(setf method-generic-function)
1365      (fdefinition '%method-name) #'method-name
1366      (fdefinition '%method-lambda-list) #'method-lambda-list
1367      )
1368
1369(setf (fdefinition '%add-method) #'add-method)
1370                   
1371     
1372;;; Make a direct-slot-definition of the appropriate class.
1373(defun %make-direct-slotd (slotd-class &rest initargs)
1374  (declare (dynamic-extent initargs))
1375  (apply #'make-instance slotd-class initargs))
1376
1377;;; Likewise, for an effective-slot-definition.
1378(defun %make-effective-slotd (slotd-class &rest initargs)
1379  (declare (dynamic-extent initargs))
1380  (apply #'make-instance slotd-class initargs))
1381
1382;;; Likewise, for methods
1383(defun %make-method-instance (class &rest initargs)
1384  (apply #'make-instance class initargs))
1385
1386(defmethod initialize-instance :after ((slotd effective-slot-definition) &key name)
1387  (setf (standard-effective-slot-definition.slot-id slotd)
1388        (ensure-slot-id name)))
1389
1390 
1391(defmethod specializer-direct-generic-functions ((s specializer))
1392  (let* ((gfs ())
1393         (methods (specializer-direct-methods s)))
1394    (dolist (m methods gfs)
1395      (let* ((gf (method-generic-function m)))
1396        (when gf (pushnew gf gfs))))))
1397
1398(defmethod generic-function-lambda-list ((gf standard-generic-function))
1399  (%maybe-compute-gf-lambda-list gf (car (generic-function-methods gf))))
1400
1401(defmethod generic-function-argument-precedence-order
1402    ((gf standard-generic-function))
1403  (let* ((req (required-lambda-list-args (generic-function-lambda-list gf)))
1404         (apo (%gf-dispatch-table-precedence-list
1405               (%gf-dispatch-table gf))))
1406    (if (null apo)
1407      req
1408      (mapcar #'(lambda (n) (nth n req)) apo))))
1409
1410(defun normalize-egf-keys (keys gf)
1411  (let* ((missing (cons nil nil))
1412         (env (getf keys :environment nil)))
1413    (declare (dynamic-extent missing))
1414    (remf keys :environment)
1415    (let* ((gf-class (getf keys :generic-function-class missing))
1416           (mcomb (getf keys :method-combination missing))
1417           (method-class (getf keys :method-class missing)))
1418      (if (eq gf-class missing)
1419        (setf gf-class (if gf (class-of gf) *standard-generic-function-class*))
1420        (progn
1421          (remf keys :generic-function-class)
1422          (if (typep gf-class 'symbol)
1423            (setq gf-class
1424                  (find-class gf-class t env)))
1425          (unless (or (eq gf-class *standard-generic-function-class*)
1426                      (subtypep gf-class *generic-function-class*))
1427            (error "Class ~S is not a subclass of ~S"
1428                   gf-class *generic-function-class*))))
1429      (unless (eq mcomb missing)
1430        (unless (typep mcomb 'method-combination)
1431          (setf (getf keys :method-combination)
1432                (find-method-combination (class-prototype gf-class)
1433                                         (car mcomb)
1434                                         (cdr mcomb)))))
1435      (unless (eq method-class missing)
1436        (if (typep method-class 'symbol)
1437          (setq method-class (find-class method-class t env)))
1438        (unless (subtypep method-class *method-class*)
1439          (error "~s is not a subclass of ~s" method-class *method-class*))
1440        (setf (getf keys :method-class) method-class))
1441      (values gf-class keys))))
1442   
1443(defmethod ensure-generic-function-using-class
1444    ((gf null)
1445     function-name
1446     &rest keys
1447     &key
1448     &allow-other-keys)
1449  (declare (dynamic-extent keys))
1450  (multiple-value-bind (gf-class initargs)
1451      (normalize-egf-keys keys nil)
1452    (let* ((gf (apply #'make-instance gf-class
1453                      :name function-name
1454                      initargs)))
1455      (setf (fdefinition function-name) gf))))
1456
1457(defparameter *error-on-gf-class-redefinition* nil
1458  "The MOP spec requires ENSURE-GENERIC-FUNCTION-USING-CLASS of an
1459   existing gf to signal an error if the :GENERIC-FUNCTION-CLASS
1460   argument specifies a class other than the existing gf's class.
1461   ANSI CL allows this kind of redefinition if the classes are
1462   \"compatible\", but doesn't define what compatibility means
1463   in this case.  When *ERROR-ON-GF-CLASS-REDEFINITION* is true,
1464   a continuable error is signaled.
1465
1466   Historically, Clozure CL CERRORed, but didn't offer a useful
1467   CHANGE-CLASS method that would change the GF's class")
1468
1469(defmethod ensure-generic-function-using-class
1470    ((gf generic-function)
1471     function-name
1472     &rest keys
1473     &key
1474     &allow-other-keys)
1475  (declare (dynamic-extent keys) (ignorable function-name))
1476  (multiple-value-bind (gf-class initargs)
1477      (normalize-egf-keys keys gf)
1478    (unless (eq gf-class (class-of gf))
1479      (when *error-on-gf-class-redefinition*
1480        (cerror (format nil "Change the class of ~s to ~s." gf gf-class)
1481                "The class of the existing generic function ~s is not ~s"
1482                gf gf-class))
1483      (change-class gf gf-class))
1484    (apply #'reinitialize-instance gf initargs)))
1485
1486
1487(defmethod initialize-instance :before ((instance generic-function)
1488                                       &key &allow-other-keys)
1489  (setf (%gf-dcode instance)  #'%%0-arg-dcode))
1490
1491(defmethod initialize-instance :after ((gf standard-generic-function)
1492                                       &key
1493                                       (lambda-list nil ll-p)
1494                                       (argument-precedence-order nil apo-p)
1495                                       &allow-other-keys)
1496  (if (and apo-p (not ll-p))
1497    (error
1498     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1499  (if ll-p
1500    (progn
1501      (unless (verify-lambda-list lambda-list)
1502        (error "~s is not a valid generic function lambda list" lambda-list))
1503      (if apo-p
1504        (set-gf-arg-info gf :lambda-list lambda-list
1505                         :argument-precedence-order argument-precedence-order)
1506        (set-gf-arg-info gf :lambda-list lambda-list)))
1507    (set-gf-arg-info gf))
1508  (if (gf-arg-info-valid-p gf)
1509    (compute-dcode gf (%gf-dispatch-table gf)))
1510  gf)
1511
1512(defmethod reinitialize-instance :after ((gf standard-generic-function)
1513                                         &rest args
1514                                         &key
1515                                         (lambda-list nil ll-p)
1516                                         (argument-precedence-order nil apo-p)
1517                                         &allow-other-keys)
1518  (if (and apo-p (not ll-p))
1519    (error
1520     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1521  (if ll-p
1522    (progn
1523      (unless (verify-lambda-list lambda-list)
1524        (error "~s is not a valid generic function lambda list" lambda-list))
1525      (if apo-p
1526        (set-gf-arg-info gf :lambda-list lambda-list
1527                         :argument-precedence-order argument-precedence-order)
1528        (set-gf-arg-info gf :lambda-list lambda-list)))
1529    (set-gf-arg-info gf))
1530  (if (and (gf-arg-info-valid-p gf)
1531           args
1532           (or ll-p (cddr args)))
1533    (compute-dcode gf (%gf-dispatch-table gf)))
1534  (when (sgf.dependents gf)
1535    (map-dependents gf #'(lambda (d)
1536                           (apply #'update-dependent gf d args))))
1537  gf)
1538 
1539
1540(defun decode-method-lambda-list (method-lambda-list)
1541  (flet ((bad ()
1542           (error "Invalid lambda-list syntax in ~s" method-lambda-list)))
1543    (collect ((specnames)
1544                    (required))
1545       (do* ((tail method-lambda-list (cdr tail))
1546             (head (car tail) (car tail)))
1547            ((or (null tail) (member head lambda-list-keywords))
1548             (if (verify-lambda-list tail)
1549               (values (required) tail (specnames))
1550               (bad)))
1551         (cond ((atom head)
1552                (unless (typep head 'symbol) (bad))
1553                (required head)
1554                (specnames t))
1555               (t
1556                (unless (and (typep (car head) 'symbol)
1557                             (consp (cdr head))
1558                             (null (cddr head)))
1559                  (bad))
1560                (required (car head))
1561                (specnames (cadr head))))))))
1562 
1563(defun extract-specializer-names (method-lambda-list)
1564  (nth-value 2 (decode-method-lambda-list method-lambda-list)))
1565
1566(defun extract-lambda-list (method-lambda-list)
1567  (multiple-value-bind (required tail)
1568      (decode-method-lambda-list method-lambda-list)
1569    (nconc required tail)))
1570
1571(setf (fdefinition '%ensure-generic-function-using-class)
1572      #'ensure-generic-function-using-class)
1573
1574
1575(defmethod shared-initialize :after ((gf generic-function) slot-names
1576                                     &key
1577                                     (documentation nil doc-p))
1578  (declare (ignore slot-names))
1579  (when doc-p
1580    (if documentation (check-type documentation string))
1581    (set-documentation gf t documentation)))
1582
1583
1584
1585
1586(defmethod allocate-instance ((b built-in-class) &rest initargs)
1587  (declare (ignore initargs))
1588  (error "Can't allocate instances of BUILT-IN-CLASS."))
1589
1590(defmethod reinitialize-instance ((m method) &rest initargs)
1591  (declare (ignore initargs))
1592  (error "Can't reinitialze ~s ~s" (class-of m) m))
1593
1594(defmethod add-dependent ((class class) dependent)
1595  (pushnew dependent (%class.dependents class)))
1596
1597(defmethod add-dependent ((gf standard-generic-function) dependent)
1598  (pushnew dependent (sgf.dependents gf)))
1599
1600(defmethod remove-dependent ((class class) dependent)
1601  (setf (%class.dependents class)
1602        (delete dependent (%class.dependents class))))
1603
1604(defmethod remove-dependent ((gf standard-generic-function) dependent)
1605  (setf (sgf.dependents gf)
1606        (delete dependent (sgf.dependents gf))))
1607
1608(defmethod map-dependents ((class class) function)
1609  (dolist (d (%class.dependents class))
1610    (funcall function d)))
1611
1612(defmethod map-dependents ((gf standard-generic-function) function)
1613  (dolist (d (sgf.dependents gf))
1614    (funcall function d)))
1615
1616(defgeneric update-dependent (metaobject dependent &rest initargs))
1617
1618(defmethod reinitialize-instance :after ((class std-class) &rest initargs)
1619  (map-dependents class #'(lambda (d)
1620                            (apply #'update-dependent class d initargs))))
1621
1622
1623(defun %allocate-gf-instance (class)
1624  (unless (class-finalized-p class)
1625    (finalize-inheritance class))
1626  (let* ((wrapper (%class.own-wrapper class))
1627         (gf-p (member *generic-function-class* (%class-cpl class)))
1628         (len (length (%wrapper-instance-slots wrapper)))
1629         (dt (if gf-p (make-gf-dispatch-table)))
1630         (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))
1631         (fn
1632          #+ppc-target
1633           (gvector :function
1634                    *unset-fin-code*
1635                    wrapper
1636                    slots
1637                    dt
1638                    #'false
1639                    0
1640                    (logior (ash 1 $lfbits-gfn-bit)
1641                            (ash 1 $lfbits-aok-bit)))
1642           #+x86-target
1643           (%clone-x86-function #'unset-fin-trampoline
1644                                wrapper
1645                                slots
1646                                dt
1647                                #'false
1648                                0
1649                                (logior (ash 1 $lfbits-gfn-bit)
1650                                        (ash 1 $lfbits-aok-bit)))))
1651    (setf 
1652          (slot-vector.instance slots) fn)
1653    (when dt
1654      (setf (%gf-dispatch-table-gf dt) fn))
1655    (if gf-p
1656      (push fn (population.data %all-gfs%)))
1657    fn))
1658
1659
1660(defmethod slot-value-using-class ((class structure-class)
1661                                   instance
1662                                   (slotd structure-effective-slot-definition))
1663  (let* ((loc (standard-effective-slot-definition.location slotd)))
1664      (typecase loc
1665        (fixnum
1666         (struct-ref  instance loc))
1667        (t
1668         (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1669                slotd loc (slot-definition-allocation slotd))))))
1670
1671;;; Some STRUCTURE-CLASS leftovers.
1672(defmethod (setf slot-value-using-class)
1673    (new
1674     (class structure-class)
1675     instance
1676     (slotd structure-effective-slot-definition))
1677  (let* ((loc (standard-effective-slot-definition.location slotd))
1678         (type (standard-effective-slot-definition.type slotd)))
1679    (if (and type (not (eq type t)))
1680      (unless (or (eq new (%slot-unbound-marker))
1681                  (typep new type))
1682        (setq new (require-type new type))))
1683    (typecase loc
1684      (fixnum
1685       (setf (struct-ref instance loc) new))
1686      (t
1687       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1688              slotd loc (slot-definition-allocation slotd))))))
1689
1690(defmethod slot-boundp-using-class ((class structure-class)
1691                                    instance
1692                                    (slotd structure-effective-slot-definition))
1693  (declare (ignore instance))
1694  t)
1695
1696;;; This has to be somewhere, so it might as well be here.
1697(defmethod make-load-form ((s slot-id) &optional env)
1698  (declare (ignore env))
1699  `(ensure-slot-id ,(slot-id.name s)))
1700
1701(defmethod make-load-form ((c class-cell) &optional env)
1702  (declare (ignore env))
1703  `(find-class-cell ',(class-cell-name c) t))
1704
1705
1706
1707(defmethod (setf class-name) (new (class class))
1708  (check-type new symbol)
1709  (when (and (standard-instance-p class)
1710             (%class-kernel-p class)
1711             (not (eq new (%class.name class)))
1712             *warn-if-redefine-kernel*)
1713    (cerror "Change the name of ~s to ~s."
1714            "The class ~s may be a critical part of the system;
1715changing its name to ~s may have serious consequences." class new))
1716  (let* ((old-name (class-name class)))
1717    (if (eq (find-class old-name nil) class)
1718      (progn
1719        (setf (info-type-kind old-name) nil)
1720        (clear-type-cache))))
1721  (when (eq (find-class new nil) class)
1722    (when (%deftype-expander new)
1723      (cerror "Change the name of ~S anyway, removing the DEFTYPE definition."
1724              "Changing the name of ~S to ~S would conflict with the type defined by DEFTYPE."
1725              class new)
1726      (%deftype new nil nil))
1727    (setf (info-type-kind new) :instance)
1728    (clear-type-cache))
1729  (reinitialize-instance class :name new)
1730  (setf (%class-proper-name class)
1731        (if (eq (find-class new nil) class)
1732          new))
1733  new)
1734
1735
1736;;; From Tim Moore, as part of a set of patches to support funcallable
1737;;; instances.
1738
1739;;; Support for objects with metaclass funcallable-instance-class that are not
1740;;; standard-generic-function. The objects still look a lot like generic
1741;;; functions, complete with vestigial dispatch
1742;;; tables. set-funcallable-instance-function will work on generic functions,
1743;;; though after that it won't be much of a generic function.
1744
1745
1746
1747
1748
1749(defun set-funcallable-instance-function (funcallable-instance function)
1750  (unless (typep funcallable-instance 'funcallable-standard-object)
1751    (error "~S is not a funcallable instance" funcallable-instance))
1752  (unless (functionp function)
1753    (error "~S is not a function" function))
1754  (setf (%gf-dcode funcallable-instance) function))
1755
1756(defmethod reinitialize-instance ((slotd slot-definition) &key &allow-other-keys)
1757  (error "Can't reinitialize ~s" slotd))
1758
1759(defmethod (setf generic-function-name) (new-name (gf generic-function))
1760  (reinitialize-instance gf :name new-name))
1761
1762;;; Are we CLOS yet ?
1763
1764(defun %shared-initialize (instance slot-names initargs)
1765  (unless (or (listp slot-names) (eq slot-names t))
1766    (report-bad-arg slot-names '(or list (eql t))))
1767  ;; Check that initargs contains valid key/value pairs,
1768  ;; signal a PROGRAM-ERROR otherwise.  (Yes, this is
1769  ;; an obscure way to do so.)
1770  (destructuring-bind (&key &allow-other-keys) initargs)
1771  ;; I'm not sure if there's a more portable way of detecting
1772  ;; obsolete instances.  This'll eventually call
1773  ;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS if it needs to.
1774  (let* ((wrapper (if (eq (typecode instance) target::subtag-instance)
1775                    (instance.class-wrapper instance)
1776                    (instance-class-wrapper instance)))
1777         (class (%wrapper-class wrapper)))
1778    (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete
1779      (update-obsolete-instance instance))
1780    ;; Now loop over all of the class's effective slot definitions.
1781    (dolist (slotd (class-slots class))
1782      ;; Anything that inherits from STANDARD-EFFECTIVE-SLOT-DEFINITION
1783      ;; in OpenMCL will have a CCL::TYPE-PREDICATE slot.  It's not
1784      ;; well-defined to inherit from EFFECTIVE-SLOT-DEFINITION without
1785      ;; also inheriting from STANDARD-EFFECTIVE-SLOT-DEFINITION,
1786      ;; and I'd rather not check here.  If you really want to
1787      ;; create that kind of slot definition, write your own SHARED-INITIALIZE
1788      ;; method for classes that use such slot definitions ...
1789      (let* ((predicate (slot-definition-predicate slotd)))
1790        (multiple-value-bind (ignore new-value foundp)
1791            (get-properties initargs (slot-definition-initargs slotd))
1792          (declare (ignore ignore))
1793          (cond (foundp
1794                 ;; an initarg for the slot was passed to this function
1795                 ;; Typecheck the new-value, then call
1796                 ;; (SETF SLOT-VALUE-USING-CLASS)
1797                 (unless (or (null predicate)
1798                             (funcall predicate new-value))
1799                   (error 'bad-slot-type-from-initarg
1800                          :slot-definition slotd
1801                          :instance instance
1802                          :datum new-value
1803                          :expected-type  (slot-definition-type slotd)
1804                          :initarg-name (car foundp)))
1805                 (setf (slot-value-using-class class instance slotd) new-value))
1806                ((and (or (eq slot-names t)
1807                          (member (slot-definition-name slotd)
1808                                  slot-names
1809                                  :test #'eq))
1810                      (not (slot-boundp-using-class class instance slotd)))
1811                 ;; If the slot name is among the specified slot names, or
1812                 ;; we're reinitializing all slots, and the slot is currently
1813                 ;; unbound in the instance, set the slot's value based
1814                 ;; on the initfunction (which captures the :INITFORM).
1815                 (let* ((initfunction (slot-definition-initfunction slotd)))
1816                   (if initfunction
1817                     (let* ((newval (funcall initfunction)))
1818                       (unless (or (null predicate)
1819                                   (funcall predicate newval))
1820                         (error 'bad-slot-type-from-initform
1821                                :slot-definition slotd
1822                                :expected-type (slot-definition-type slotd)
1823                                :datum newval
1824                                :instance instance))
1825                       (setf (slot-value-using-class class instance slotd)
1826                             newval))))))))))
1827  instance)
1828
1829;;; Sometimes you can do a lot better at generic function dispatch than the
1830;;; default. This supports that for the one-arg-dcode case.
1831(defmethod override-one-method-one-arg-dcode ((generic-function t) (method t))
1832  nil)
1833
1834(defun optimize-generic-function-dispatching ()
1835  (dolist (gf (population.data %all-gfs%))
1836    (optimize-dispatching-for-gf gf)))
1837
1838(defun optimize-dispatching-for-gf (gf)
1839  (let* ((dcode (%gf-dcode gf))
1840         (name (function-name dcode)))
1841    (when (or (eq name '%%one-arg-dcode)
1842              (eq name '%%nth-arg-dcode))
1843      (let ((methods (generic-function-methods gf)))
1844        (when (and methods (null (cdr methods)))
1845          (when (or (eq #'%%one-arg-dcode dcode)
1846                    (and (eq #'%%nth-arg-dcode dcode)
1847                         (let ((spec (method-specializers (car methods)))
1848                               (argnum (%gf-dispatch-table-argnum
1849                                        (%gf-dispatch-table gf))))
1850                           (and (eql 2 (length spec))
1851                                (and (eql argnum 1) (eq (car spec) *t-class*))))))
1852            (override-one-method-one-arg-dcode gf (car methods))))))))
1853
1854(defparameter *unique-reader-dcode-functions* t)
1855
1856;;; dcode for a GF with a single reader method which accesses
1857;;; a slot in a class that has no subclasses (that restriction
1858;;; makes typechecking simpler and also ensures that the slot's
1859;;; location is correct.)
1860(defun singleton-reader-dcode (dt instance)
1861  (declare (optimize (speed 3) (safety 0)))
1862  (let* ((wrapper (%svref dt %gf-dispatch-table-first-data))
1863         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
1864    (if (eq (if (eq (typecode instance) target::subtag-instance)
1865              (instance.class-wrapper instance))
1866            wrapper)
1867      (%slot-ref (instance.slots instance) location)
1868      (cond ((and (eq (typecode instance) target::subtag-instance)
1869                  (eq 0 (%wrapper-hash-index (instance.class-wrapper instance)))
1870                  (progn (update-obsolete-instance instance)
1871                         (eq (instance.class-wrapper instance) wrapper)))
1872             (%slot-ref (instance.slots instance) location))
1873            (t (no-applicable-method (%gf-dispatch-table-gf dt) instance))))))
1874(register-dcode-proto #'singleton-reader-dcode *gf-proto-one-arg*)
1875
1876;;; Dcode for a GF whose methods are all reader-methods which access a
1877;;; slot in one or more classes which have multiple subclasses, all of
1878;;; which (by luck or design) have the same slot-definition location.
1879(defun reader-constant-location-dcode (dt instance)
1880  (declare (optimize (speed 3) (safety 0)))
1881    (if (memq (if (eq (typecode instance) target::subtag-instance)
1882              (%class-of-instance instance))
1883              (%svref dt %gf-dispatch-table-first-data))
1884      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
1885      (no-applicable-method (%gf-dispatch-table-gf dt) instance)))
1886(register-dcode-proto #'reader-constant-location-dcode *gf-proto-one-arg*)
1887
1888;;; Dcode for a GF whose methods are all reader-methods which access a
1889;;; slot in one or more classes which have multiple subclasses, all of
1890;;; which (by luck or design) have the same slot-definition location.
1891;;; The number of classes for which the method is applicable is
1892;;; potentially large, but all are subclasses of a single class
1893(defun reader-constant-location-inherited-from-single-class-dcode (dt instance)
1894  (declare (optimize (speed 3) (safety 0)))
1895  (let* ((defining-class-ordinal (%svref dt %gf-dispatch-table-first-data))
1896         (bits  (let* ((wrapper
1897                        (if (eq (typecode instance) target::subtag-instance)
1898                          (instance.class-wrapper instance))))
1899                  (when wrapper (or (%wrapper-cpl-bits wrapper)
1900                                    (make-cpl-bits (%inited-class-cpl
1901                                                    (%wrapper-class wrapper))))))))
1902    (declare (fixnum defining-class-ordinal))
1903    (if (and bits
1904             (< defining-class-ordinal (the fixnum (uvsize bits)))
1905             (not (eql 0 (sbit bits defining-class-ordinal))))
1906      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
1907      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
1908(register-dcode-proto #'reader-constant-location-inherited-from-single-class-dcode *gf-proto-one-arg*)
1909
1910;;; It may be faster to make individual functions that take their
1911;;; "parameters" (defining class ordinal, slot location) as constants.
1912;;; It may not be.  Use *unique-reader-dcode-functions* to decide
1913;;; whether or not to do so.
1914(defun make-reader-constant-location-inherited-from-single-class-dcode
1915    (defining-class-ordinal location gf)
1916  (if *unique-reader-dcode-functions*
1917    (let* ((gf-name (function-name gf)))
1918      (values
1919       (%make-function 
1920        `(slot-reader for ,gf-name)
1921        `(lambda (instance)
1922          (locally (declare (optimize (speed 3) (safety 0)))
1923            (let* ((bits (let* ((wrapper
1924                                 (if (eq (typecode instance) target::subtag-instance)
1925                                   (instance.class-wrapper instance))))
1926                           (when wrapper (or (%wrapper-cpl-bits wrapper)
1927                                             (make-cpl-bits (%inited-class-cpl
1928                                                             (%wrapper-class wrapper))))))))
1929              (if (and bits
1930                       (< ,defining-class-ordinal (the fixnum (uvsize bits)))
1931                       (not (eql 0 (sbit bits ,defining-class-ordinal))))
1932                (%slot-ref (instance.slots instance) ,location)
1933                (no-applicable-method (function ,gf-name) instance)))))
1934        nil)
1935       #'funcallable-trampoline))
1936    (let* ((dt (gf.dispatch-table gf)))
1937      (setf (%svref dt %gf-dispatch-table-first-data)
1938            defining-class-ordinal
1939            (%svref dt (1+ %gf-dispatch-table-first-data))
1940            location)
1941      (values
1942       (dcode-for-gf gf #'reader-constant-location-inherited-from-single-class-dcode)
1943       (cdr (assq #'reader-constant-location-inherited-from-single-class-dcode dcode-proto-alist))))))
1944
1945;;; Dcode for a GF whose methods are all reader-methods which access a
1946;;; slot in one or more classes which have multiple subclasses, all of
1947;;; which (by luck or design) have the same slot-definition location.
1948;;; The number of classes is for which the method is applicable is
1949;;; large, but all are subclasses of one of a (small) set of defining classes.
1950(defun reader-constant-location-inherited-from-multiple-classes-dcode (dt instance)
1951  (declare (optimize (speed 3) (safety 0)))
1952  (let* ((wrapper (if (eq (typecode instance) target::subtag-instance)
1953                    (instance.class-wrapper instance)))
1954         (bits (if wrapper (or (%wrapper-cpl-bits wrapper)
1955                               (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
1956         (nbits (if bits (uvsize bits) 0)))
1957    (declare (fixnum nbits))
1958    (if (dolist (ordinal (%svref dt %gf-dispatch-table-first-data))
1959          (declare (fixnum ordinal))
1960          (when (and (< ordinal nbits)
1961                     (not (eql 0 (sbit bits ordinal))))
1962            (return t)))
1963      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
1964      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
1965(register-dcode-proto #'reader-constant-location-inherited-from-multiple-classes-dcode *gf-proto-one-arg*)
1966
1967
1968;;; Similar to the case above, but we use an alist to map classes
1969;;; to their non-constant locations.
1970(defun reader-variable-location-dcode (dt instance)
1971  (declare (optimize (speed 3) (safety 0)))
1972  (let* ((alist (%svref dt %gf-dispatch-table-first-data))
1973         (location (cdr
1974                    (assq
1975                     (if (eq (typecode instance) target::subtag-instance)
1976                       (%class-of-instance instance))
1977                     alist))))
1978    (if location
1979      (%slot-ref (instance.slots instance) location)
1980      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
1981(register-dcode-proto #'reader-variable-location-dcode *gf-proto-one-arg*)
1982
1983(defun class-and-slot-location-alist (classes slot-name)
1984  (let* ((alist nil))
1985    (labels ((add-class (c)
1986               (unless (assq c alist)
1987                 (let* ((slots (class-slots c)))
1988                   (unless slots
1989                     (finalize-inheritance c)
1990                     (setq slots (class-slots c)))
1991                   (push (cons c (slot-definition-location (find-slotd slot-name slots))) alist))
1992                 (dolist (sub (class-direct-subclasses c))
1993                   (add-class sub)))))
1994      (dolist (class classes) (add-class class))
1995      ;; Building the alist the way that we have should often approximate
1996      ;; this ordering; the idea is that leaf classes are more likely to
1997      ;; be instantiated than non-leaves.
1998      (sort alist (lambda (c1 c2)
1999                    (< (length (class-direct-subclasses c1))
2000                       (length (class-direct-subclasses c2))))
2001            :key #'car))))
2002
2003;;; Return a list of all classes in CLASS-LIST that aren't subclasses
2004;;; of any other class in the list.
2005(defun remove-subclasses-from-class-list (class-list)
2006  (if (null (cdr class-list))
2007    class-list
2008    (collect ((unique))
2009      (dolist (class class-list (unique))
2010        (when (dolist (other class-list t)
2011                (unless (eq class other)
2012                  (when (subtypep class other) (return nil))))
2013          (unique class))))))
2014
2015
2016;;; Try to replace gf dispatch with something faster in f.
2017(defun %snap-reader-method (f &key (redefinable t))
2018  (when (slot-boundp f 'methods)
2019    (let* ((methods (generic-function-methods f)))
2020      (when (and methods
2021                 (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods)
2022                 (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods)
2023                 (every (lambda (m) (null (method-qualifiers m))) methods))
2024        (let* ((m0 (car methods))
2025               (name (slot-definition-name (accessor-method-slot-definition m0))))
2026          (when (every (lambda (m)
2027                         (eq name (slot-definition-name (accessor-method-slot-definition m))))
2028                       (cdr methods))
2029            ;; All methods are *STANDARD-READER-METHODS* that
2030            ;; access the same slot name.  Build an alist of
2031            ;; mapping all subclasses of all classes on which those
2032            ;; methods are specialized to the effective slot's
2033            ;; location in that subclass.
2034            (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m)))
2035                                    methods))
2036                   (alist (class-and-slot-location-alist classes name))
2037                   (loc (cdar alist))
2038                   (dt (gf.dispatch-table f)))
2039              ;; Only try to handle the case where all slots have
2040              ;; :allocation :instance (and all locations - the CDRs
2041              ;; of the alist pairs - are small, positive fixnums.
2042              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
2043                (when redefinable
2044                  (loop for (c . nil) in alist
2045                        do (note-class-dependent c f)))
2046                (clear-gf-dispatch-table dt)
2047                (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
2048                (cond ((null (cdr alist))
2049                       ;; Method is only applicable to a single class.
2050                       (destructuring-bind (class . location) (car alist)
2051                         (setf (%svref dt %gf-dispatch-table-first-data) (%class.own-wrapper class)
2052                               (%svref dt (1+ %gf-dispatch-table-first-data)) location
2053                               (gf.dcode f) (dcode-for-gf f #'singleton-reader-dcode))))
2054                      ((dolist (other (cdr alist) t)
2055                         (unless (eq (cdr other) loc)
2056                           (return)))
2057                       ;; All classes have the slot in the same location,
2058                       ;; by luck or design.
2059                       (cond
2060                         ((< (length alist) 10)
2061                          ;; Only a small number of classes, just do MEMQ
2062                          (setf (%svref dt %gf-dispatch-table-first-data)
2063                                (mapcar #'car alist)
2064                                (%svref dt (1+ %gf-dispatch-table-first-data))
2065                                loc
2066                                (gf.dcode f) (dcode-for-gf f #'reader-constant-location-dcode)))
2067                         ((null (cdr (setq classes (remove-subclasses-from-class-list classes))))
2068                          ;; Lots of classes, all subclasses of a single class
2069                          (multiple-value-bind (dcode trampoline)
2070                              (make-reader-constant-location-inherited-from-single-class-dcode (%class-ordinal (car classes)) loc f)
2071                            (setf (gf.dcode f) dcode)
2072                            (replace-function-code f trampoline)))
2073                         (t
2074                          ;; Multple classes.  We should probably check
2075                          ;; to see they're disjoint
2076                          (setf (%svref dt %gf-dispatch-table-first-data)
2077                                (mapcar #'%class-ordinal classes)
2078                                (%svref dt (1+ %gf-dispatch-table-first-data))
2079                                loc
2080                                (gf.dcode f)
2081                                (dcode-for-gf f #'reader-constant-location-inherited-from-multiple-classes-dcode)))))
2082                      (t
2083                       ;; Multiple classes; the slot's location varies.
2084                       (setf (%svref dt %gf-dispatch-table-first-data)
2085                             alist
2086                             
2087                             (gf.dcode f) (dcode-for-gf f #'reader-variable-location-dcode))))))))))))
2088
2089;;; Hack-o-rama: GF has nothing but primary methods, first (and only non-T)
2090;;; specializers are all EQL specializers whose objects are symbols.
2091;;; The effective method applicable for each symbol is stored on the
2092;;; plist of the symbol under a property EQ to the dispatch table (which
2093;;; is mostly ignored, otherwise.)
2094(defun %%1st-arg-eql-method-hack-dcode (dt args)
2095  (let* ((sym (if (listp args) (car args)(%lexpr-ref args (%lexpr-count args) 0)))
2096         (mf (if (symbolp sym) (get sym dt))))
2097    (if mf
2098      (if (listp args)
2099        (apply mf args)
2100        (%apply-lexpr-tail-wise mf args))
2101      ;;; Let %%1st-arg-dcode deal with it.
2102      (%%1st-arg-dcode dt args))))
2103(register-dcode-proto #'%%1st-arg-eql-method-hack-dcode *gf-proto*)
2104
2105(defun %%1st-two-arg-eql-method-hack-dcode (dt arg1 arg2)
2106  (let* ((mf (if (typep arg1 'symbol) (get arg1 dt))))
2107    (if mf
2108      (funcall mf arg1 arg2)
2109      (%%1st-two-arg-dcode dt arg1 arg2))))
2110(register-dcode-proto #'%%1st-two-arg-eql-method-hack-dcode *gf-proto-two-arg*)
2111
2112(defun %%one-arg-eql-method-hack-dcode (dt arg)
2113  (let* ((mf (if (typep arg 'symbol) (get arg dt))))
2114    (if mf
2115      (funcall mf arg))))
2116(register-dcode-proto #'%%one-arg-eql-method-hack-dcode *gf-proto-one-arg*)
2117
2118(defun install-eql-method-hack-dcode (gf)
2119  (let* ((bits (inner-lfun-bits gf))
2120         (nreq (ldb $lfbits-numreq bits))
2121         (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits)))
2122                          (logbitp $lfbits-rest-bit bits)
2123                          (logbitp $lfbits-restv-bit bits)
2124                          (logbitp $lfbits-keys-bit bits)
2125                          (logbitp $lfbits-aok-bit bits))))
2126    (setf (%gf-dcode gf)
2127          (dcode-for-gf gf
2128                        (cond ((and (eql nreq 1) (null other-args?))
2129                               #'%%one-arg-eql-method-hack-dcode)
2130                              ((and (eql nreq 2) (null other-args?))
2131                               #'%%1st-two-arg-eql-method-hack-dcode)
2132                              (t
2133                               #'%%1st-arg-eql-method-hack-dcode))))))
2134
2135(defun maybe-hack-eql-methods (gf)
2136  (let* ((methods (generic-function-methods gf)))
2137    (when (and methods
2138               (every #'(lambda (method)
2139                          (let* ((specializers (method-specializers method))
2140                                      (first (car specializers)))
2141                                 (and (typep first 'eql-specializer)
2142                                      (typep (eql-specializer-object first) 'symbol)
2143                                      (dolist (s (cdr specializers) t)
2144                                        (unless (eq s *t-class*)
2145                                          (return nil)))
2146                                      (null (cdr (compute-applicable-methods gf (cons (eql-specializer-object first) (make-list (length (cdr specializers))))))))))
2147                      methods))
2148      (let* ((dt (%gf-dispatch-table gf)))
2149        (dolist (m methods)
2150          (let* ((sym (eql-specializer-object (car (method-specializers m))))
2151                 (f (method-function m)))
2152            (setf (get sym dt) f)))
2153        (install-eql-method-hack-dcode gf)
2154        t))))
2155
2156
2157           
2158                           
2159;;; Return a list of :after methods for INITIALIZE-INSTANCE on the
2160;;; class's prototype, and a boolean that's true if no other qualified
2161;;; methods are defined and at most one primary one.
2162(defun initialize-instance-after-methods (proto class)
2163  (let* ((method-list (compute-method-list (sort-methods
2164                            (compute-applicable-methods #'initialize-instance (list proto))
2165                            (list (class-precedence-list class))))))
2166    (if (atom method-list)
2167      (values nil t)
2168      (if (and (null (car method-list))
2169               (null (cdddr method-list)))
2170        (values (cadr method-list) t)
2171        ;; :around or :before methods, or more than one primary method, give up
2172        (values nil nil)))))
2173
2174(defparameter *typecheck-slots-in-optimized-make-instance* t)
2175
2176
2177;;; Return a lambda form or NIL.
2178(defun make-instantiate-lambda-for-class-cell (cell)
2179  (let* ((class (class-cell-class cell))
2180         (after-methods nil))
2181    (when (and (typep class 'standard-class)
2182               (progn (unless (class-finalized-p class)
2183                        (finalize-inheritance class))
2184                      t)
2185               (null (cdr (compute-applicable-methods #'allocate-instance (list class))))
2186               (let* ((proto (class-prototype class)))
2187                 (and (multiple-value-bind (afters ok)
2188                          (initialize-instance-after-methods proto class)
2189                        (when ok
2190                          (setq after-methods afters)
2191                          t))
2192                      (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
2193      (let* ((slotds (sort (copy-list (class-slots class))
2194                           #'(lambda (x y)
2195                               (if (consp x) x (if (consp y) y (< x y))))
2196                           :key #'slot-definition-location))
2197             (default-initargs (class-default-initargs class)))
2198        (collect ((keys)
2199                  (binds)
2200                  (class-binds)
2201                  (ignorable)
2202                  (class-slot-inits)
2203                  (after-method-forms)
2204                  (forms))
2205          (flet ((generate-type-check (form type &optional spvar)
2206                   (if (or (null *typecheck-slots-in-optimized-make-instance*)
2207                           (eq type t)
2208                           (and (quoted-form-p type) (eq (cadr type) t)))
2209                     form
2210                     (if spvar
2211                       `(if ,spvar
2212                         (require-type ,form ',type)
2213                         ,form)
2214                       `(require-type ,form ',type)))))
2215            (dolist (slot slotds)
2216              (let* ((initargs (slot-definition-initargs slot))
2217                     (initfunction (slot-definition-initfunction slot))
2218                     (initform (slot-definition-initform slot))
2219                     (location (slot-definition-location slot))
2220                     (location-var nil)
2221                     (class-init-p nil)
2222                     (one-initarg-p (null (cdr initargs)))
2223                     (name (slot-definition-name slot))
2224                     (type (slot-definition-type slot)))
2225                (when (consp location)
2226                  (setq location-var (gensym "LOCATION")))
2227                (when initfunction
2228                  (setq initform
2229                        (if (self-evaluating-p initform)
2230                            initform
2231                            `(funcall ,initfunction))))
2232                (cond ((null initargs)
2233                       (let ((initial-value-form
2234                              (if initfunction
2235                                  (generate-type-check initform type)
2236                                  `(%slot-unbound-marker))))
2237                         (if location-var
2238                             (when initfunction
2239                               (setq class-init-p t)
2240                               (class-slot-inits
2241                                `(when (eq (%slot-unbound-marker) (cdr ,location-var))
2242                                   (setf (cdr ,location-var) ,initial-value-form))))
2243                             (forms initial-value-form))))
2244                      (t (collect ((cond-clauses))
2245                           (let ((last-cond-clause nil))
2246                             (dolist (initarg initargs)
2247                               (let* ((spvar nil)
2248                                      (name (if one-initarg-p
2249                                                name
2250                                                (gensym (string name))))
2251                                      (initial-value-form
2252                                       (if (and initfunction
2253                                                one-initarg-p
2254                                                (null location-var))
2255                                           initform
2256                                           (progn
2257                                             (when initarg
2258                                               (setq spvar (make-symbol
2259                                                            (concatenate
2260                                                             'string
2261                                                             (string initarg)
2262                                                             "-P"))))
2263                                             (and one-initarg-p
2264                                                  (null location-var)
2265                                                  (if initfunction
2266                                                      initform
2267                                                      `(%slot-unbound-marker))))))
2268                                      (default (assq initarg default-initargs)))
2269                                 (when spvar (ignorable spvar))
2270                                 (when default
2271                                   (destructuring-bind (form function)
2272                                       (cdr default)
2273                                     (setq default
2274                                           (if (self-evaluating-p form)
2275                                               form
2276                                               `(funcall ,function)))))
2277                                 (keys (list*
2278                                        (list initarg name)
2279                                        (if (and default one-initarg-p (null location-var))
2280                                            default
2281                                            initial-value-form)
2282                                        (if spvar (list spvar))))
2283                                 (if one-initarg-p
2284                                   (if location-var
2285                                     (progn
2286                                       (setq class-init-p t)
2287                                       (class-slot-inits
2288                                        `(if ,spvar
2289                                           (setf (cdr ,location-var)
2290                                                 ,(generate-type-check
2291                                                   name type))
2292                                           ,(if default
2293                                              `(setf (cdr ,location-var)
2294                                                     ,(generate-type-check
2295                                                       default type))
2296                                              (when initfunction
2297                                                `(when (eq (%slot-unbound-marker)
2298                                                           (cdr ,location-var))
2299                                                   (setf (cdr ,location-var)
2300                                                         ,(generate-type-check
2301                                                           initform type))))))))
2302                                     (forms `,(generate-type-check name type spvar)))
2303                                     (progn (cond-clauses `(,spvar ,name))
2304                                            (when (and default (null last-cond-clause))
2305                                              (setq last-cond-clause
2306                                                    `(t ,default)))))))
2307                             (when (cond-clauses)
2308                               (when last-cond-clause
2309                                 (cond-clauses last-cond-clause))
2310                               (cond ((null location-var)
2311                                      (unless last-cond-clause
2312                                        (cond-clauses `(t ,initform)))
2313                                      (forms (generate-type-check
2314                                              `(cond ,@(cond-clauses))
2315                                              type)))
2316                                     (t
2317                                      (let ((initform-p-var
2318                                             (unless last-cond-clause
2319                                               (make-symbol "INITFORM-P")))
2320                                            (value-var (make-symbol "VALUE")))
2321                                        (unless last-cond-clause
2322                                          (cond-clauses
2323                                           `(t (setq ,initform-p-var t)
2324                                               ,(if initfunction
2325                                                    initform
2326                                                    `(%slot-unbound-marker)))))
2327                                        (setq class-init-p t)
2328                                        (class-slot-inits
2329                                         `(let* (,@(and initform-p-var
2330                                                        (list `(,initform-p-var nil)))
2331                                                 (,value-var
2332                                                  ,(generate-type-check
2333                                                    `(cond ,@(cond-clauses)) type)))
2334                                            (when
2335                                                ,(if initform-p-var
2336                                                     `(or (null ,initform-p-var)
2337                                                          (and (eq (cdr ,location-var)
2338                                                                   (%slot-unbound-marker))
2339                                                               (not (eq ,value-var
2340                                                                        (%slot-unbound-marker)))))
2341                                                     t)
2342                                                (setf (cdr ,location-var) ,value-var))))))))))))
2343                (when class-init-p
2344                  (class-binds `(,location-var
2345                                 (load-time-value
2346                                  (slot-definition-location ',slot))))))))
2347          (let* ((cell (make-symbol "CLASS-CELL"))
2348                 (args (make-symbol "ARGS"))
2349                 (slots (make-symbol "SLOTS"))
2350                 (instance (make-symbol "INSTANCE")))
2351            (dolist (after after-methods)
2352              (after-method-forms `(apply ,(method-function after) ,instance ,args)))
2353            (when after-methods
2354              (after-method-forms instance))
2355            (binds `(,slots (gvector :slot-vector nil ,@(forms))))
2356            (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots)))
2357            `(lambda (,cell ,@(when after-methods `(&rest ,args)) &key ,@(keys) ,@(when after-methods '(&allow-other-keys)))
2358              (declare (ignorable ,@(ignorable)))
2359              ,@(when after-methods `((declare (dynamic-extent ,args))))
2360              (let (,@(class-binds))
2361                ,@(class-slot-inits))
2362              (let* (,@(binds))
2363                (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)
2364                      (%svref ,slots 0) ,instance)
2365                ,@(after-method-forms)))))))))
2366
2367(defun optimize-make-instance-for-class-cell (cell)
2368  (init-class-cell-instantiator cell)
2369  (let* ((lambda (make-instantiate-lambda-for-class-cell cell)))
2370    (when lambda
2371      (setf (class-cell-instantiate cell) (compile nil lambda)
2372            (class-cell-extra cell) (%class.own-wrapper
2373                                     (class-cell-class cell)))
2374      t)))
2375
2376(defun optimize-make-instance-for-class-name (class-name)
2377  (optimize-make-instance-for-class-cell (find-class-cell class-name t)))
2378
2379(defun optimize-named-class-make-instance-methods ()
2380  (maphash (lambda (class-name class-cell)
2381             (handler-case (optimize-make-instance-for-class-cell class-cell)
2382               (error (c)
2383                      (warn "error optimizing make-instance for ~s:~&~a"
2384                            class-name c))))
2385           %find-classes%))
2386
2387;; Redefined from bootstrapping verison in l1-clos-boot.lisp
2388;; Remove the make-instance optimization if the user is adding
2389;; a method on initialize-instance, allocate-instance, or shared-initialize
2390(defun maybe-remove-make-instance-optimization (gfn method)
2391  (when (or (eq gfn #'allocate-instance)
2392            (eq gfn #'initialize-instance)
2393            (eq gfn #'shared-initialize))
2394    (let ((specializer (car (method-specializers method))))
2395      (when (typep specializer 'class)
2396        (labels ((clear (class)
2397                   (pessimize-make-instance-for-class-name (class-name class))
2398                   (dolist (sub (%class-direct-subclasses class))
2399                     (clear sub))))
2400          (clear specializer))))))
2401
2402;;; Iterate over all known GFs; try to optimize their dcode in cases
2403;;; involving reader methods.
2404
2405(defun snap-reader-methods (&key known-sealed-world
2406                                 (check-conflicts t)
2407                                 (optimize-make-instance t))
2408  (declare (ignore check-conflicts)
2409           (ignore known-sealed-world))
2410  (when optimize-make-instance
2411    (optimize-named-class-make-instance-methods))
2412  (let* ((ngf 0)
2413         (nwin 0))
2414    (dolist (f (population.data %all-gfs%))
2415      (incf ngf)
2416      (when (%snap-reader-method f)
2417        (incf nwin)))
2418    (values ngf nwin 0)))
2419
2420(defun register-non-dt-dcode-function (f)
2421  (flet ((symbol-or-function-name (x)
2422           (etypecase x
2423             (symbol x)
2424             (function (function-name x)))))
2425    (let* ((already (member (symbol-or-function-name f) *non-dt-dcode-functions* :key #'symbol-or-function-name)))
2426      (if already
2427        (setf (car already) f)
2428        (push f *non-dt-dcode-functions*))
2429      f)))
2430
2431(defun pessimize-clos ()
2432  ;; Undo MAKE-INSTANCE optimization
2433  (maphash (lambda (class-name class-cell)
2434             (declare (ignore class-name))
2435             (init-class-cell-instantiator class-cell))
2436           %find-classes%)
2437  ;; Un-snap reader methods, undo other GF optimizations.
2438  (dolist (f (population-data %all-gfs%))
2439    (let* ((dt (%gf-dispatch-table f)))
2440      (clear-gf-dispatch-table dt)
2441      (compute-dcode f))))
2442
2443;;; If there's a single method (with standard method combination) on
2444;;; GF and all of that method's arguments are specialized to the T
2445;;; class - and if the method doesn't accept &key - we can just have
2446;;; the generic function call the method-function
2447(defun dcode-for-universally-applicable-singleton (gf)
2448  (when (eq (generic-function-method-combination gf)
2449            *standard-method-combination*)
2450    (let* ((methods (generic-function-methods gf))
2451           (method (car methods)))
2452      (when (and method
2453                 (null (cdr methods))
2454                 (null (method-qualifiers method))
2455                 (not (logbitp $lfbits-keys-bit (lfun-bits (method-function method))))
2456                 (dolist (spec (method-specializers method) t)
2457                   (unless (eq spec *t-class*)
2458                     (return nil))))
2459        (method-function method)))))
2460
2461(register-non-dt-dcode-function #'dcode-for-universally-applicable-singleton)
Note: See TracBrowser for help on using the repository browser.