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

Last change on this file since 11465 was 11465, checked in by gb, 11 years ago

In the SHARED-INITIALIZE :AFTER method on SLOTS-CLASS, default the
DIRECT-SUPERCLASSES argument if the initarg is provided or if SLOT-NAMES
is T (the INITIALIZE-INSTANCE case).

  • 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  (if (or direct-superclasses-p (eq slot-names t))
689    (progn
690      (setq direct-superclasses
691            (or direct-superclasses
692                (list (if (typep class 'funcallable-standard-class)
693                        *funcallable-standard-object-class*
694                        *standard-object-class*))))
695      (dolist (superclass direct-superclasses)
696        (unless (validate-superclass class superclass)
697          (error "The class ~S was specified as a~%super-class of the class ~S;~%~
698                    but the meta-classes ~S and~%~S are incompatible."
699                 superclass class (class-of superclass) (class-of class))))
700      (setf (%class-direct-superclasses class) direct-superclasses))
701    (setq direct-superclasses (%class-direct-superclasses class)))
702  (setq direct-slots
703        (if direct-slots-p
704          (setf (%class-direct-slots class)
705                (mapcar #'(lambda (initargs)
706                            (make-direct-slot-definition class initargs))
707                        direct-slots))
708          (%class-direct-slots class)))
709  (if direct-default-initargs-p
710    (setf (%class-direct-default-initargs class)  direct-default-initargs)
711    (setq direct-default-initargs (%class-direct-default-initargs class)))
712  (let* ((new-class-slot-cells ())
713         (old-class-slot-cells (%class-get class :class-slots)))
714    (dolist (slot direct-slots)
715      (when (eq (%slot-definition-allocation slot) :class)
716        (let* ((slot-name (%slot-definition-name slot))
717               (pair (assq slot-name old-class-slot-cells)))
718          ;;; If the slot existed as a class slot in the old
719          ;;; class, retain the definition (even if it's unbound.)
720          (unless pair
721            (let* ((initfunction (%slot-definition-initfunction slot)))
722              (setq pair (cons slot-name
723                               (if initfunction
724                                 (funcall initfunction)
725                                 (%slot-unbound-marker))))))
726          (push pair new-class-slot-cells))))
727    (when new-class-slot-cells
728      (setf (%class-get class :class-slots) new-class-slot-cells)))
729  (when doc-p
730    (set-documentation class 'type documentation))
731  (when primary-p-p
732    (setf (class-primary-p class) primary-p))
733
734  (add-direct-subclasses class direct-superclasses)
735  (update-class class nil)
736  (add-accessor-methods class direct-slots))
737
738(defmethod initialize-instance :before ((class class) &key &allow-other-keys)
739  (setf (%class-ordinal class) (%next-class-ordinal))
740  (setf (%class.ctype class) (make-class-ctype class)))
741
742(defun ensure-class-metaclass-and-initargs (class args)
743  (let* ((initargs (copy-list args))
744         (missing (cons nil nil))
745         (supplied-meta (getf initargs :metaclass missing))
746         (supplied-supers (getf initargs :direct-superclasses missing))
747         (supplied-slots (getf initargs :direct-slots missing))
748         (metaclass (cond ((not (eq supplied-meta missing))
749                           (if (typep supplied-meta 'class)
750                             supplied-meta
751                             (find-class supplied-meta)))
752                          ((or (null class)
753                               (typep class 'forward-referenced-class))
754                           *standard-class-class*)
755                          (t (class-of class)))))
756    (declare (dynamic-extent missing))
757    (flet ((fix-super (s)
758             (cond ((classp s) s)
759                   ((not (and s (symbolp s)))
760                    (error "~s is not a class or a legal class name." s))
761                   (t
762                    (or (find-class s nil)
763                        (setf (find-class s)
764                              (make-instance 'forward-referenced-class :name s))))))
765           (excise-all (keys)
766             (dolist (key keys)
767               (loop (unless (remf initargs key) (return))))))
768      (excise-all '(:metaclass :direct-superclasses :direct-slots))
769      (values metaclass
770              `(,@ (unless (eq supplied-supers missing)
771                     `(:direct-superclasses ,(mapcar #'fix-super supplied-supers)))
772                ,@ (unless (eq supplied-slots missing)
773                     `(:direct-slots ,supplied-slots))
774               ,@initargs)))))
775
776
777;;; This defines a new class.
778(defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys)
779  (multiple-value-bind (metaclass initargs)
780      (ensure-class-metaclass-and-initargs class keys)
781    (let* ((class (apply #'make-instance metaclass :name name initargs)))
782      (setf (find-class name) class))))
783
784(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys)
785  (multiple-value-bind (metaclass initargs)
786      (ensure-class-metaclass-and-initargs class keys)
787    (apply #'change-class class metaclass initargs)
788    (apply #'reinitialize-instance class initargs)
789    (setf (find-class name) class)))
790           
791;; Can't go with optimize-make-instance-for-class-name because
792;; ensure-class-using-class is called before that is defined.
793(defun pessimize-make-instance-for-class-name (class-name)
794  (let ((cell (find-class-cell class-name nil)))
795    (when cell
796      (init-class-cell-instantiator cell))))
797
798(defun init-class-cell-instantiator (cell)
799  (when cell
800    (setf (class-cell-instantiate cell) '%make-instance)
801    (setf (class-cell-extra cell) nil)))
802
803;;; Redefine an existing (not forward-referenced) class.
804(defmethod ensure-class-using-class ((class class) name &rest keys &key)
805  (multiple-value-bind (metaclass initargs)
806      (ensure-class-metaclass-and-initargs class keys)
807    (unless (eq (class-of class) metaclass)
808      (error "Can't change metaclass of ~s to ~s." class metaclass))
809    (apply #'reinitialize-instance class initargs)
810    (setf (find-class name) class)))
811
812
813(defun ensure-class (name &rest keys &key &allow-other-keys)
814  (declare (dynamic-extent keys))
815  (apply #'ensure-class-using-class (find-class name nil) name keys))
816
817(defparameter *defclass-redefines-improperly-named-classes-pedantically* 
818   t
819  "ANSI CL expects DEFCLASS to redefine an existing class only when
820the existing class is properly named, the MOP function ENSURE-CLASS
821redefines existing classes regardless of their CLASS-NAME.  This variable
822governs whether DEFCLASS makes that distinction or not.")
823
824(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
825  (declare (dynamic-extent keys))
826  (record-source-file name 'class)
827  (let* ((existing-class (find-class name nil)))
828    (when (and *defclass-redefines-improperly-named-classes-pedantically* 
829               existing-class 
830               (not (eq (class-name existing-class) name)))
831      ;; Class isn't properly named; act like it didn't exist
832      (setq existing-class nil))
833    (apply #'ensure-class-using-class existing-class name keys)))
834
835
836
837
838(defmethod method-slot-name ((m standard-accessor-method))
839  (standard-direct-slot-definition.name (%accessor-method.slot-definition m)))
840
841
842(defun %ensure-class-preserving-wrapper (&rest args)
843  (declare (dynamic-extent args))
844  (let* ((*update-slots-preserve-existing-wrapper* t))
845    (apply #'ensure-class args)))
846
847(defun %find-direct-slotd (class name)
848  (dolist (dslotd (%class-direct-slots class)
849           (error "Direct slot definition for ~s not found in ~s" name class))
850    (when (eq (%slot-definition-name dslotd) name)
851      (return dslotd))))
852
853(defun %add-slot-readers (class-name pairs)
854  (let* ((class (find-class class-name)))
855    (dolist (pair pairs)
856      (destructuring-bind (slot-name &rest readers) pair
857        (setf (%slot-definition-readers (%find-direct-slotd class slot-name)) readers)))
858    (add-accessor-methods class (%class-direct-slots class))))
859
860(defun %add-slot-writers (class-name pairs)
861  (let* ((class (find-class class-name)))
862    (dolist (pair pairs)
863      (destructuring-bind (slot-name &rest readers) pair
864        (setf (%slot-definition-writers (%find-direct-slotd class slot-name)) readers)))
865    (add-accessor-methods class (%class-direct-slots class))))
866
867
868(%ensure-class-preserving-wrapper
869 'standard-method
870 :direct-superclasses '(method)
871 :direct-slots `((:name qualifiers :initargs (:qualifiers) :initfunction ,#'false :initform nil)
872                 (:name specializers :initargs (:specializers) :initfunction ,#'false :initform nil)
873                 (:name function :initargs (:function))
874                 (:name generic-function :initargs (:generic-function) :initfunction ,#'false :initform nil)
875                 (:name name :initargs (:name) :initfunction ,#'false :initform nil)
876                 (:name lambda-list :initform nil :initfunction ,#'false
877                  :initargs (:lambda-list)))
878 :primary-p t)
879
880(defmethod shared-initialize :after ((method standard-method)
881                                     slot-names
882                                     &key function &allow-other-keys)
883  (declare (ignore slot-names))
884  (when function
885    (let* ((inner (closure-function function)))
886      (unless (eq inner function)
887        (copy-method-function-bits inner function)))   
888    (lfun-name function method)))
889
890;;; Reader & writer methods classes.
891(%ensure-class-preserving-wrapper
892 'standard-accessor-method
893 :direct-superclasses '(standard-method)
894 :direct-slots '((:name slot-definition :initargs (:slot-definition)))
895 :primary-p t)
896
897(%ensure-class-preserving-wrapper
898 'standard-reader-method
899 :direct-superclasses '(standard-accessor-method))
900
901(%ensure-class-preserving-wrapper
902 'standard-writer-method
903 :direct-superclasses '(standard-accessor-method))
904
905(defmethod reader-method-class ((class standard-class)
906                                (dslotd standard-direct-slot-definition)
907                                &rest initargs)
908  (declare (ignore initargs))
909  *standard-reader-method-class*)
910
911(defmethod reader-method-class ((class funcallable-standard-class)
912                                (dslotd standard-direct-slot-definition)
913                                &rest initargs)
914  (declare (ignore  initargs))
915  *standard-reader-method-class*)
916
917(defmethod add-reader-method ((class slots-class) gf dslotd)
918  (let* ((initargs
919          `(:qualifiers nil
920            :specializers ,(list class)
921            :lambda-list (,(or (%class-name class) 'instance))
922            :name ,(function-name gf)
923            :slot-definition ,dslotd))
924         (reader-method-class
925          (apply #'reader-method-class class dslotd initargs))
926         (method-function (create-reader-method-function
927                           class (class-prototype reader-method-class) dslotd))
928         (method (apply #'make-instance reader-method-class
929                        :function method-function
930                        initargs)))
931    (declare (dynamic-extent initargs))
932    (record-source-file method 'reader-method)
933    (add-method gf method)))
934
935(defmethod remove-reader-method ((class std-class) gf)
936  (let* ((method (find-method gf () (list class) nil)))
937    (when method (remove-method gf method))))
938
939(defmethod writer-method-class ((class standard-class)
940                                (dslotd standard-direct-slot-definition)
941                                &rest initargs)
942  (declare (ignore initargs))
943  *standard-writer-method-class*)
944
945(defmethod writer-method-class ((class funcallable-standard-class)
946                                (dslotd standard-direct-slot-definition)
947                                &rest initargs)
948  (declare (ignore initargs))
949  *standard-writer-method-class*)
950
951
952(defmethod add-writer-method ((class slots-class) gf dslotd)
953  (let* ((initargs
954          `(:qualifiers nil
955            :specializers ,(list *t-class* class)
956            :lambda-list (new-value ,(or (%class-name class) 'instance))
957            :name ,(function-name gf)
958            :slot-definition ,dslotd))
959         (method-class (apply #'writer-method-class class dslotd initargs))
960         (method 
961          (apply #'make-instance
962                 method-class
963                 :function (create-writer-method-function
964                            class
965                            (class-prototype method-class)
966                            dslotd)
967                 initargs)))
968    (declare (dynamic-extent initargs))
969    (record-source-file method 'writer-method)
970    (add-method gf method)))
971
972(defmethod remove-writer-method ((class std-class) gf)
973  (let* ((method (find-method gf () (list *t-class* class) nil)))
974    (when method (remove-method gf method))))
975
976;;; We can now define accessors.  Fix up the slots in the classes defined
977;;; thus far.
978
979(%add-slot-readers 'standard-method '((qualifiers method-qualifiers)
980                                      (specializers method-specializers)
981                                      (name method-name)
982                                      ;(function method-function)
983                                      (generic-function method-generic-function)
984                                      (lambda-list method-lambda-list)))
985
986(%add-slot-writers 'standard-method '((function (setf method-function))
987                                      (generic-function (setf method-generic-function))))
988
989
990(defmethod method-function ((m standard-method))
991  (%method.function m))
992
993
994(%add-slot-readers 'standard-accessor-method
995                   '((slot-definition accessor-method-slot-definition)))
996
997
998(%ensure-class-preserving-wrapper
999 'specializer
1000 :direct-superclasses '(metaobject)
1001 :direct-slots `((:name direct-methods
1002                  :readers (specializer-direct-methods)
1003                  :initform nil :initfunction ,#'false))
1004 :primary-p t)
1005                 
1006(%ensure-class-preserving-wrapper
1007 'eql-specializer
1008 :direct-superclasses '(specializer)
1009 :direct-slots '((:name object :initargs (:object) :readers (eql-specializer-object)))
1010 :primary-p t)
1011
1012
1013(%ensure-class-preserving-wrapper
1014 'class
1015 :direct-superclasses '(specializer)
1016 :direct-slots
1017 `((:name prototype :initform nil :initfunction ,#'false)
1018   (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name))
1019   (:name precedence-list :initform nil  :initfunction ,#'false)
1020   (:name own-wrapper :initform nil  :initfunction ,#'false :readers (class-own-wrapper) :writers ((setf class-own-wrapper)))
1021   (:name direct-superclasses  :initform nil  :initfunction ,#'false :readers (class-direct-superclasses))
1022   (:name direct-subclasses  :initform nil  :initfunction ,#'false :readers (class-direct-subclasses))
1023   (:name dependents :initform nil :initfunction ,#'false)
1024   (:name class-ctype :initform nil :initfunction ,#'false)
1025   (:name direct-slots :initform nil :initfunction ,#'false
1026                  :readers (class-direct-slots)
1027                  :writers ((setf class-direct-slots)))
1028   (:name slots :initform nil :initfunction ,#'false
1029    :readers (class-slots)
1030    :writers ((setf class-slots)))
1031   (:name info :initform (cons nil nil) :initfunction ,(lambda () (cons nil nil)) :readers (class-info))
1032   (:name direct-default-initargs  :initform nil  :initfunction ,#'false :readers (class-direct-default-initargs))
1033   (:name default-initargs :initform nil  :initfunction ,#'false :readers (class-default-initargs)))
1034 :primary-p t)
1035
1036(%ensure-class-preserving-wrapper
1037 'forward-referenced-class
1038 :direct-superclasses '(class))
1039
1040
1041
1042(%ensure-class-preserving-wrapper
1043 'built-in-class
1044 :direct-superclasses '(class))
1045
1046
1047(%ensure-class-preserving-wrapper
1048 'slots-class
1049 :direct-superclasses '(class)
1050 :direct-slots `((:name alist :initform nil  :initfunction ,#'false))
1051 :primary-p t)
1052
1053;;; This class exists only so that standard-class & funcallable-standard-class
1054;;; can inherit its slots.
1055(%ensure-class-preserving-wrapper
1056 'std-class
1057 :direct-superclasses '(slots-class)
1058 :direct-slots `(
1059                 (:name make-instance-initargs :initform nil  :initfunction ,#'false)
1060                 (:name reinit-initargs :initform nil  :initfunction ,#'false)
1061                 (:name redefined-initargs :initform nil :initfunction ,#'false)
1062                 (:name changed-initargs :initform nil  :initfunction ,#'false))
1063 :primary-p t)
1064
1065
1066
1067(%ensure-class-preserving-wrapper
1068 'standard-class
1069 :direct-superclasses '(std-class))
1070
1071(%ensure-class-preserving-wrapper
1072 'funcallable-standard-class
1073 :direct-superclasses '(std-class))
1074
1075
1076(%ensure-class-preserving-wrapper
1077 'funcallable-standard-object
1078#||
1079 :direct-superclasses '(standard-object function)
1080||#
1081 :direct-slots `((:name name :initargs (:name) :readers (generic-function-name)))
1082 :metaclass 'funcallable-standard-class)
1083
1084(%ensure-class-preserving-wrapper
1085 'generic-function
1086 :direct-superclasses '(metaobject funcallable-standard-object)
1087 :direct-slots `(
1088                 (:name method-combination :initargs (:method-combination)
1089                  :initform *standard-method-combination*
1090                  :initfunction ,#'(lambda () *standard-method-combination*)
1091                  :readers (generic-function-method-combination))
1092                 (:name method-class :initargs (:method-class)
1093                  :initform *standard-method-class*
1094                  :initfunction ,#'(lambda () *standard-method-class*)
1095                  :readers (generic-function-method-class))
1096                 (:name methods :initargs (:methods)
1097                  :initform nil :initfunction ,#'false
1098                  :readers (generic-function-methods))
1099                 (:name declarations
1100                  :initargs (:declarations)
1101                  :initform nil :initfunction ,#'false
1102                  :readers (generic-function-declarations))
1103                 (:name %lambda-list
1104                  :initform :unspecified
1105                  :initfunction ,(constantly :unspecified))
1106                 (:name dependents
1107                  :initform nil :initfunction ,#'false)) 
1108 :metaclass 'funcallable-standard-class)
1109
1110
1111
1112(%ensure-class-preserving-wrapper
1113 'standard-generic-function
1114 :direct-superclasses '(generic-function)
1115
1116 :metaclass 'funcallable-standard-class
1117 :primary-p t)
1118
1119(%ensure-class-preserving-wrapper
1120 'standard-generic-function
1121 :direct-superclasses '(generic-function)
1122
1123 :metaclass 'funcallable-standard-class)
1124
1125(%ensure-class-preserving-wrapper
1126 'structure-class
1127 :direct-superclasses '(slots-class))
1128
1129(%ensure-class-preserving-wrapper
1130 'slot-definition
1131 :direct-superclasses '(metaobject)
1132  :direct-slots `((:name name :initargs (:name) :readers (slot-definition-name)
1133                  :initform nil :initfunction ,#'false)
1134                 (:name type :initargs (:type) :readers (slot-definition-type)
1135                  :initform t :initfunction ,#'true)
1136                 (:name initfunction :initargs (:initfunction) :readers (slot-definition-initfunction)
1137                  :initform nil :initfunction ,#'false)
1138                 (:name initform :initargs (:initform) :readers (slot-definition-initform)
1139                  :initform nil :initfunction ,#'false)
1140                 (:name initargs :initargs (:initargs) :readers (slot-definition-initargs)
1141                  :initform nil :initfunction ,#'false)
1142                 (:name allocation :initargs (:allocation) :readers (slot-definition-allocation)
1143                  :initform :instance :initfunction ,(constantly :instance))
1144                 (:name documentation :initargs (:documentation) :readers (slot-definition-documentation)
1145                  :initform nil :initfunction ,#'false)
1146                 (:name class :initargs (:class) :readers (slot-definition-class)))
1147 
1148 :primary-p t)
1149
1150(%ensure-class-preserving-wrapper
1151 'direct-slot-definition
1152 :direct-superclasses '(slot-definition)
1153 :direct-slots `((:name readers :initargs (:readers) :initform nil
1154                  :initfunction ,#'false :readers (slot-definition-readers))
1155                 (:name writers :initargs (:writers) :initform nil
1156                  :initfunction ,#'false :readers (slot-definition-writers))))
1157
1158(%ensure-class-preserving-wrapper
1159 'effective-slot-definition
1160 :direct-superclasses '(slot-definition)
1161 :direct-slots `((:name location :initform nil :initfunction ,#'false
1162                  :readers (slot-definition-location))
1163                 (:name slot-id :initform nil :initfunction ,#'false
1164                  :readers (slot-definition-slot-id))
1165                 (:name type-predicate :initform nil
1166                  :initfunction ,#'false
1167                  :readers (slot-definition-predicate))
1168                 )
1169 
1170 :primary-p t)
1171
1172(%ensure-class-preserving-wrapper
1173 'standard-slot-definition
1174 :direct-superclasses '(slot-definition)
1175)
1176
1177
1178
1179
1180
1181
1182
1183(%ensure-class-preserving-wrapper
1184 'standard-direct-slot-definition
1185 :direct-superclasses '(standard-slot-definition direct-slot-definition)
1186)
1187
1188(%ensure-class-preserving-wrapper
1189 'standard-effective-slot-definition
1190 :direct-superclasses '(standard-slot-definition effective-slot-definition))
1191
1192                 
1193
1194
1195     
1196                             
1197
1198
1199
1200;;; Fake method-combination, redefined in lib;method-combination.
1201(defclass method-combination (metaobject) 
1202  ((name :initarg :name)))
1203
1204
1205
1206
1207(defclass standard-method-combination (method-combination) ())
1208
1209(initialize-instance *standard-method-combination* :name 'standard)
1210
1211(setq *standard-kernel-method-class*
1212  (defclass standard-kernel-method (standard-method)
1213    ()))
1214
1215(unless *standard-method-combination*
1216  (setq *standard-method-combination*
1217        (make-instance 'standard-method-combination :name 'standard)))
1218
1219;;; For %compile-time-defclass
1220(defclass compile-time-class (class) ())
1221
1222(defmethod compile-time-class-p ((class compile-time-class))
1223  t)
1224
1225(defmethod class-finalized-p ((class compile-time-class))
1226  nil)
1227
1228
1229(defclass structure-slot-definition (slot-definition) ())
1230(defclass structure-effective-slot-definition (structure-slot-definition
1231                                               effective-slot-definition)
1232    ())
1233
1234(defclass structure-direct-slot-definition (structure-slot-definition
1235                                            direct-slot-definition)
1236    ())
1237
1238(defmethod shared-initialize :after ((class structure-class)
1239                                     slot-names
1240                                     &key
1241                                     (direct-superclasses nil direct-superclasses-p)
1242                                     &allow-other-keys)
1243  (declare (ignore slot-names))
1244  (labels ((obsolete (class)
1245             (dolist (sub (%class-direct-subclasses class)) (obsolete sub))
1246             ;;Need to save old class info in wrapper for obsolete
1247             ;;instance access...
1248             (setf (%class.cpl class) nil)))
1249    (obsolete class)
1250    (when direct-superclasses-p
1251      (let* ((old-supers (%class-direct-superclasses class))
1252             (new-supers direct-superclasses))
1253        (dolist (c old-supers)
1254          (unless (memq c new-supers)
1255            (remove-direct-subclass c class)))
1256        (dolist (c new-supers)
1257          (unless (memq c old-supers)
1258            (add-direct-subclass c class)))
1259        (setf (%class.local-supers class) new-supers)))
1260    (let* ((wrapper (or (%class-own-wrapper class)
1261                        (setf (%class-own-wrapper class) (%cons-wrapper class))))
1262           (cpl (compute-cpl class)))
1263      (setf (%class.cpl class) cpl)
1264      (setf (%wrapper-cpl wrapper) cpl
1265            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)))))
1266             
1267
1268                                     
1269                                     
1270;;; Called from DEFSTRUCT expansion.
1271(defun %define-structure-class (sd)
1272  (let* ((dslots ()))
1273    (dolist (ssd (cdr (sd-slots sd)) (setq dslots (nreverse dslots)))
1274      (let* ((type (ssd-type ssd))
1275             (refinfo (ssd-refinfo ssd)))
1276        (unless (logbitp $struct-inherited refinfo)
1277          (let* ((name (ssd-name ssd))
1278                 (initform (cadr ssd))
1279                 (initfunction (constantly initform)))
1280            (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction) dslots)))))
1281    (ensure-class (sd-name sd)
1282                  :metaclass 'structure-class
1283                  :direct-superclasses (list (or (cadr (sd-superclasses sd)) 'structure-object))
1284                  :direct-slots  dslots 
1285                  )))
1286
1287
1288(defun standard-instance-access (instance location)
1289  (etypecase location
1290    (fixnum (%standard-instance-instance-location-access instance location))
1291    (cons (%cdr location))))
1292
1293(defun (setf standard-instance-access) (new instance location)
1294  (etypecase location
1295    (fixnum (setf (standard-instance-instance-location-access instance location)
1296                  new))
1297    (cons (setf (%cdr location) new))))
1298
1299(defun funcallable-standard-instance-access (instance location)
1300  (etypecase location
1301    (fixnum (%standard-generic-function-instance-location-access instance location))
1302    (cons (%cdr location))))
1303
1304(defun (setf funcallable-standard-instance-access) (new instance location)
1305  (etypecase location
1306    (fixnum (setf (%standard-generic-function-instance-location-access instance location) new))
1307    (cons (setf (%cdr location) new))))
1308
1309;;; Handle a trap from %slot-ref
1310(defun %slot-unbound-trap (slotv idx frame-ptr)
1311  (let* ((instance nil)
1312         (class nil)
1313         (slot nil))
1314    (if (and (eq (typecode slotv) target::subtag-slot-vector)
1315             (setq instance (slot-vector.instance slotv))
1316             (setq slot
1317                   (find idx (class-slots (setq class (class-of instance)))
1318                         :key #'slot-definition-location)))
1319      (slot-unbound class instance (slot-definition-name slot))
1320      (%error "Unbound slot at index ~d in ~s" (list idx slotv) frame-ptr))))
1321
1322
1323;;;
1324;;; Now that CLOS is nominally bootstrapped, it's possible to redefine some
1325;;; of the functions that really should have been generic functions ...
1326(setf (fdefinition '%class-name) #'class-name
1327      (fdefinition '%class-default-initargs) #'class-default-initargs
1328      (fdefinition '%class-direct-default-initargs) #'class-direct-default-initargs
1329      (fdefinition '(setf %class-direct-default-initargs))
1330      #'(lambda (new class)
1331          (if (typep class 'slots-class)
1332            (setf (slot-value class 'direct-default-initargs) new)
1333            new))
1334      (fdefinition '%class-direct-slots) #'class-direct-slots
1335      (fdefinition '(setf %class-direct-slots))
1336                   #'(setf class-direct-slots)
1337      (fdefinition '%class-slots) #'class-slots
1338      (fdefinition '%class-direct-superclasses) #'class-direct-superclasses
1339      (fdefinition '(setf %class-direct-superclasses))
1340      #'(lambda (new class)
1341          (setf (slot-value class 'direct-superclasses) new))
1342      (fdefinition '%class-direct-subclasses) #'class-direct-subclasses
1343      ;(fdefinition '%class-own-wrapper) #'class-own-wrapper
1344      (fdefinition '(setf %class-own-wrapper)) #'(setf class-own-wrapper)
1345)
1346
1347
1348
1349(setf (fdefinition '%slot-definition-name) #'slot-definition-name
1350      (fdefinition '%slot-definition-type) #'slot-definition-type
1351      (fdefinition '%slot-definition-initargs) #'slot-definition-initargs
1352      (fdefinition '%slot-definition-allocation) #'slot-definition-allocation
1353      (fdefinition '%slot-definition-location) #'slot-definition-location
1354      (fdefinition '%slot-definition-readers) #'slot-definition-readers
1355      (fdefinition '%slot-definition-writers) #'slot-definition-writers)
1356
1357
1358(setf (fdefinition '%method-qualifiers) #'method-qualifiers
1359      (fdefinition '%method-specializers) #'method-specializers
1360      (fdefinition '%method-function) #'method-function
1361      (fdefinition '(setf %method-function)) #'(setf method-function)
1362      (fdefinition '%method-gf) #'method-generic-function
1363      (fdefinition '(setf %method-gf)) #'(setf method-generic-function)
1364      (fdefinition '%method-name) #'method-name
1365      (fdefinition '%method-lambda-list) #'method-lambda-list
1366      )
1367
1368(setf (fdefinition '%add-method) #'add-method)
1369                   
1370     
1371;;; Make a direct-slot-definition of the appropriate class.
1372(defun %make-direct-slotd (slotd-class &rest initargs)
1373  (declare (dynamic-extent initargs))
1374  (apply #'make-instance slotd-class initargs))
1375
1376;;; Likewise, for an effective-slot-definition.
1377(defun %make-effective-slotd (slotd-class &rest initargs)
1378  (declare (dynamic-extent initargs))
1379  (apply #'make-instance slotd-class initargs))
1380
1381;;; Likewise, for methods
1382(defun %make-method-instance (class &rest initargs)
1383  (apply #'make-instance class initargs))
1384
1385(defmethod initialize-instance :after ((slotd effective-slot-definition) &key name)
1386  (setf (standard-effective-slot-definition.slot-id slotd)
1387        (ensure-slot-id name)))
1388
1389 
1390(defmethod specializer-direct-generic-functions ((s specializer))
1391  (let* ((gfs ())
1392         (methods (specializer-direct-methods s)))
1393    (dolist (m methods gfs)
1394      (let* ((gf (method-generic-function m)))
1395        (when gf (pushnew gf gfs))))))
1396
1397(defmethod generic-function-lambda-list ((gf standard-generic-function))
1398  (%maybe-compute-gf-lambda-list gf (car (generic-function-methods gf))))
1399
1400(defmethod generic-function-argument-precedence-order
1401    ((gf standard-generic-function))
1402  (let* ((req (required-lambda-list-args (generic-function-lambda-list gf)))
1403         (apo (%gf-dispatch-table-precedence-list
1404               (%gf-dispatch-table gf))))
1405    (if (null apo)
1406      req
1407      (mapcar #'(lambda (n) (nth n req)) apo))))
1408
1409(defun normalize-egf-keys (keys gf)
1410  (let* ((missing (cons nil nil))
1411         (env (getf keys :environment nil)))
1412    (declare (dynamic-extent missing))
1413    (remf keys :environment)
1414    (let* ((gf-class (getf keys :generic-function-class missing))
1415           (mcomb (getf keys :method-combination missing))
1416           (method-class (getf keys :method-class missing)))
1417      (if (eq gf-class missing)
1418        (setf gf-class (if gf (class-of gf) *standard-generic-function-class*))
1419        (progn
1420          (remf keys :generic-function-class)
1421          (if (typep gf-class 'symbol)
1422            (setq gf-class
1423                  (find-class gf-class t env)))
1424          (unless (or (eq gf-class *standard-generic-function-class*)
1425                      (subtypep gf-class *generic-function-class*))
1426            (error "Class ~S is not a subclass of ~S"
1427                   gf-class *generic-function-class*))))
1428      (unless (eq mcomb missing)
1429        (unless (typep mcomb 'method-combination)
1430          (setf (getf keys :method-combination)
1431                (find-method-combination (class-prototype gf-class)
1432                                         (car mcomb)
1433                                         (cdr mcomb)))))
1434      (unless (eq method-class missing)
1435        (if (typep method-class 'symbol)
1436          (setq method-class (find-class method-class t env)))
1437        (unless (subtypep method-class *method-class*)
1438          (error "~s is not a subclass of ~s" method-class *method-class*))
1439        (setf (getf keys :method-class) method-class))
1440      (values gf-class keys))))
1441   
1442(defmethod ensure-generic-function-using-class
1443    ((gf null)
1444     function-name
1445     &rest keys
1446     &key
1447     &allow-other-keys)
1448  (declare (dynamic-extent keys))
1449  (multiple-value-bind (gf-class initargs)
1450      (normalize-egf-keys keys nil)
1451    (let* ((gf (apply #'make-instance gf-class
1452                      :name function-name
1453                      initargs)))
1454      (setf (fdefinition function-name) gf))))
1455
1456(defparameter *error-on-gf-class-redefinition* nil
1457  "The MOP spec requires ENSURE-GENERIC-FUNCTION-USING-CLASS of an
1458   existing gf to signal an error if the :GENERIC-FUNCTION-CLASS
1459   argument specifies a class other than the existing gf's class.
1460   ANSI CL allows this kind of redefinition if the classes are
1461   \"compatible\", but doesn't define what compatibility means
1462   in this case.  When *ERROR-ON-GF-CLASS-REDEFINITION* is true,
1463   a continuable error is signaled.
1464
1465   Historically, Clozure CL CERRORed, but didn't offer a useful
1466   CHANGE-CLASS method that would change the GF's class")
1467
1468(defmethod ensure-generic-function-using-class
1469    ((gf generic-function)
1470     function-name
1471     &rest keys
1472     &key
1473     &allow-other-keys)
1474  (declare (dynamic-extent keys) (ignorable function-name))
1475  (multiple-value-bind (gf-class initargs)
1476      (normalize-egf-keys keys gf)
1477    (unless (eq gf-class (class-of gf))
1478      (when *error-on-gf-class-redefinition*
1479        (cerror (format nil "Change the class of ~s to ~s." gf gf-class)
1480                "The class of the existing generic function ~s is not ~s"
1481                gf gf-class))
1482      (change-class gf gf-class))
1483    (apply #'reinitialize-instance gf initargs)))
1484
1485
1486(defmethod initialize-instance :before ((instance generic-function)
1487                                       &key &allow-other-keys)
1488  (setf (%gf-dcode instance)  #'%%0-arg-dcode))
1489
1490(defmethod initialize-instance :after ((gf standard-generic-function)
1491                                       &key
1492                                       (lambda-list nil ll-p)
1493                                       (argument-precedence-order nil apo-p)
1494                                       &allow-other-keys)
1495  (if (and apo-p (not ll-p))
1496    (error
1497     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1498  (if ll-p
1499    (progn
1500      (unless (verify-lambda-list lambda-list)
1501        (error "~s is not a valid generic function lambda list" lambda-list))
1502      (if apo-p
1503        (set-gf-arg-info gf :lambda-list lambda-list
1504                         :argument-precedence-order argument-precedence-order)
1505        (set-gf-arg-info gf :lambda-list lambda-list)))
1506    (set-gf-arg-info gf))
1507  (if (gf-arg-info-valid-p gf)
1508    (compute-dcode gf (%gf-dispatch-table gf)))
1509  gf)
1510
1511(defmethod reinitialize-instance :after ((gf standard-generic-function)
1512                                         &rest args
1513                                         &key
1514                                         (lambda-list nil ll-p)
1515                                         (argument-precedence-order nil apo-p)
1516                                         &allow-other-keys)
1517  (if (and apo-p (not ll-p))
1518    (error
1519     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1520  (if ll-p
1521    (progn
1522      (unless (verify-lambda-list lambda-list)
1523        (error "~s is not a valid generic function lambda list" lambda-list))
1524      (if apo-p
1525        (set-gf-arg-info gf :lambda-list lambda-list
1526                         :argument-precedence-order argument-precedence-order)
1527        (set-gf-arg-info gf :lambda-list lambda-list)))
1528    (set-gf-arg-info gf))
1529  (if (and (gf-arg-info-valid-p gf)
1530           args
1531           (or ll-p (cddr args)))
1532    (compute-dcode gf (%gf-dispatch-table gf)))
1533  (when (sgf.dependents gf)
1534    (map-dependents gf #'(lambda (d)
1535                           (apply #'update-dependent gf d args))))
1536  gf)
1537 
1538
1539(defun decode-method-lambda-list (method-lambda-list)
1540  (flet ((bad ()
1541           (error "Invalid lambda-list syntax in ~s" method-lambda-list)))
1542    (collect ((specnames)
1543                    (required))
1544       (do* ((tail method-lambda-list (cdr tail))
1545             (head (car tail) (car tail)))
1546            ((or (null tail) (member head lambda-list-keywords))
1547             (if (verify-lambda-list tail)
1548               (values (required) tail (specnames))
1549               (bad)))
1550         (cond ((atom head)
1551                (unless (typep head 'symbol) (bad))
1552                (required head)
1553                (specnames t))
1554               (t
1555                (unless (and (typep (car head) 'symbol)
1556                             (consp (cdr head))
1557                             (null (cddr head)))
1558                  (bad))
1559                (required (car head))
1560                (specnames (cadr head))))))))
1561 
1562(defun extract-specializer-names (method-lambda-list)
1563  (nth-value 2 (decode-method-lambda-list method-lambda-list)))
1564
1565(defun extract-lambda-list (method-lambda-list)
1566  (multiple-value-bind (required tail)
1567      (decode-method-lambda-list method-lambda-list)
1568    (nconc required tail)))
1569
1570(setf (fdefinition '%ensure-generic-function-using-class)
1571      #'ensure-generic-function-using-class)
1572
1573
1574(defmethod shared-initialize :after ((gf generic-function) slot-names
1575                                     &key
1576                                     (documentation nil doc-p))
1577  (declare (ignore slot-names))
1578  (when doc-p
1579    (if documentation (check-type documentation string))
1580    (set-documentation gf t documentation)))
1581
1582
1583
1584
1585(defmethod allocate-instance ((b built-in-class) &rest initargs)
1586  (declare (ignore initargs))
1587  (error "Can't allocate instances of BUILT-IN-CLASS."))
1588
1589(defmethod reinitialize-instance ((m method) &rest initargs)
1590  (declare (ignore initargs))
1591  (error "Can't reinitialze ~s ~s" (class-of m) m))
1592
1593(defmethod add-dependent ((class class) dependent)
1594  (pushnew dependent (%class.dependents class)))
1595
1596(defmethod add-dependent ((gf standard-generic-function) dependent)
1597  (pushnew dependent (sgf.dependents gf)))
1598
1599(defmethod remove-dependent ((class class) dependent)
1600  (setf (%class.dependents class)
1601        (delete dependent (%class.dependents class))))
1602
1603(defmethod remove-dependent ((gf standard-generic-function) dependent)
1604  (setf (sgf.dependents gf)
1605        (delete dependent (sgf.dependents gf))))
1606
1607(defmethod map-dependents ((class class) function)
1608  (dolist (d (%class.dependents class))
1609    (funcall function d)))
1610
1611(defmethod map-dependents ((gf standard-generic-function) function)
1612  (dolist (d (sgf.dependents gf))
1613    (funcall function d)))
1614
1615(defgeneric update-dependent (metaobject dependent &rest initargs))
1616
1617(defmethod reinitialize-instance :after ((class std-class) &rest initargs)
1618  (map-dependents class #'(lambda (d)
1619                            (apply #'update-dependent class d initargs))))
1620
1621
1622(defun %allocate-gf-instance (class)
1623  (unless (class-finalized-p class)
1624    (finalize-inheritance class))
1625  (let* ((wrapper (%class.own-wrapper class))
1626         (gf-p (member *generic-function-class* (%class-cpl class)))
1627         (len (length (%wrapper-instance-slots wrapper)))
1628         (dt (if gf-p (make-gf-dispatch-table)))
1629         (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))
1630         (fn
1631          #+ppc-target
1632           (gvector :function
1633                    *unset-fin-code*
1634                    wrapper
1635                    slots
1636                    dt
1637                    #'false
1638                    0
1639                    (logior (ash 1 $lfbits-gfn-bit)
1640                            (ash 1 $lfbits-aok-bit)))
1641           #+x86-target
1642           (%clone-x86-function #'unset-fin-trampoline
1643                                wrapper
1644                                slots
1645                                dt
1646                                #'false
1647                                0
1648                                (logior (ash 1 $lfbits-gfn-bit)
1649                                        (ash 1 $lfbits-aok-bit)))))
1650    (setf 
1651          (slot-vector.instance slots) fn)
1652    (when dt
1653      (setf (%gf-dispatch-table-gf dt) fn))
1654    (if gf-p
1655      (push fn (population.data %all-gfs%)))
1656    fn))
1657
1658
1659(defmethod slot-value-using-class ((class structure-class)
1660                                   instance
1661                                   (slotd structure-effective-slot-definition))
1662  (let* ((loc (standard-effective-slot-definition.location slotd)))
1663      (typecase loc
1664        (fixnum
1665         (struct-ref  instance loc))
1666        (t
1667         (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1668                slotd loc (slot-definition-allocation slotd))))))
1669
1670;;; Some STRUCTURE-CLASS leftovers.
1671(defmethod (setf slot-value-using-class)
1672    (new
1673     (class structure-class)
1674     instance
1675     (slotd structure-effective-slot-definition))
1676  (let* ((loc (standard-effective-slot-definition.location slotd))
1677         (type (standard-effective-slot-definition.type slotd)))
1678    (if (and type (not (eq type t)))
1679      (unless (or (eq new (%slot-unbound-marker))
1680                  (typep new type))
1681        (setq new (require-type new type))))
1682    (typecase loc
1683      (fixnum
1684       (setf (struct-ref instance loc) new))
1685      (t
1686       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1687              slotd loc (slot-definition-allocation slotd))))))
1688
1689(defmethod slot-boundp-using-class ((class structure-class)
1690                                    instance
1691                                    (slotd structure-effective-slot-definition))
1692  (declare (ignore instance))
1693  t)
1694
1695;;; This has to be somewhere, so it might as well be here.
1696(defmethod make-load-form ((s slot-id) &optional env)
1697  (declare (ignore env))
1698  `(ensure-slot-id ,(slot-id.name s)))
1699
1700(defmethod make-load-form ((c class-cell) &optional env)
1701  (declare (ignore env))
1702  `(find-class-cell ',(class-cell-name c) t))
1703
1704
1705
1706(defmethod (setf class-name) (new (class class))
1707  (check-type new symbol)
1708  (when (and (standard-instance-p class)
1709             (%class-kernel-p class)
1710             (not (eq new (%class.name class)))
1711             *warn-if-redefine-kernel*)
1712    (cerror "Change the name of ~s to ~s."
1713            "The class ~s may be a critical part of the system;
1714changing its name to ~s may have serious consequences." class new))
1715  (let* ((old-name (class-name class)))
1716    (if (eq (find-class old-name nil) class)
1717      (progn
1718        (setf (info-type-kind old-name) nil)
1719        (clear-type-cache))))
1720  (when (eq (find-class new nil) class)
1721    (when (%deftype-expander new)
1722      (cerror "Change the name of ~S anyway, removing the DEFTYPE definition."
1723              "Changing the name of ~S to ~S would conflict with the type defined by DEFTYPE."
1724              class new)
1725      (%deftype new nil nil))
1726    (setf (info-type-kind new) :instance)
1727    (clear-type-cache))
1728  (reinitialize-instance class :name new)
1729  (setf (%class-proper-name class)
1730        (if (eq (find-class new nil) class)
1731          new))
1732  new)
1733
1734
1735;;; From Tim Moore, as part of a set of patches to support funcallable
1736;;; instances.
1737
1738;;; Support for objects with metaclass funcallable-instance-class that are not
1739;;; standard-generic-function. The objects still look a lot like generic
1740;;; functions, complete with vestigial dispatch
1741;;; tables. set-funcallable-instance-function will work on generic functions,
1742;;; though after that it won't be much of a generic function.
1743
1744
1745
1746
1747
1748(defun set-funcallable-instance-function (funcallable-instance function)
1749  (unless (typep funcallable-instance 'funcallable-standard-object)
1750    (error "~S is not a funcallable instance" funcallable-instance))
1751  (unless (functionp function)
1752    (error "~S is not a function" function))
1753  (setf (%gf-dcode funcallable-instance) function))
1754
1755(defmethod reinitialize-instance ((slotd slot-definition) &key &allow-other-keys)
1756  (error "Can't reinitialize ~s" slotd))
1757
1758(defmethod (setf generic-function-name) (new-name (gf generic-function))
1759  (reinitialize-instance gf :name new-name))
1760
1761;;; Are we CLOS yet ?
1762
1763(defun %shared-initialize (instance slot-names initargs)
1764  (unless (or (listp slot-names) (eq slot-names t))
1765    (report-bad-arg slot-names '(or list (eql t))))
1766  ;; Check that initargs contains valid key/value pairs,
1767  ;; signal a PROGRAM-ERROR otherwise.  (Yes, this is
1768  ;; an obscure way to do so.)
1769  (destructuring-bind (&key &allow-other-keys) initargs)
1770  ;; I'm not sure if there's a more portable way of detecting
1771  ;; obsolete instances.  This'll eventually call
1772  ;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS if it needs to.
1773  (let* ((wrapper (if (eq (typecode instance) target::subtag-instance)
1774                    (instance.class-wrapper instance)
1775                    (instance-class-wrapper instance)))
1776         (class (%wrapper-class wrapper)))
1777    (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete
1778      (update-obsolete-instance instance))
1779    ;; Now loop over all of the class's effective slot definitions.
1780    (dolist (slotd (class-slots class))
1781      ;; Anything that inherits from STANDARD-EFFECTIVE-SLOT-DEFINITION
1782      ;; in OpenMCL will have a CCL::TYPE-PREDICATE slot.  It's not
1783      ;; well-defined to inherit from EFFECTIVE-SLOT-DEFINITION without
1784      ;; also inheriting from STANDARD-EFFECTIVE-SLOT-DEFINITION,
1785      ;; and I'd rather not check here.  If you really want to
1786      ;; create that kind of slot definition, write your own SHARED-INITIALIZE
1787      ;; method for classes that use such slot definitions ...
1788      (let* ((predicate (slot-definition-predicate slotd)))
1789        (multiple-value-bind (ignore new-value foundp)
1790            (get-properties initargs (slot-definition-initargs slotd))
1791          (declare (ignore ignore))
1792          (cond (foundp
1793                 ;; an initarg for the slot was passed to this function
1794                 ;; Typecheck the new-value, then call
1795                 ;; (SETF SLOT-VALUE-USING-CLASS)
1796                 (unless (or (null predicate)
1797                             (funcall predicate new-value))
1798                   (error 'bad-slot-type-from-initarg
1799                          :slot-definition slotd
1800                          :instance instance
1801                          :datum new-value
1802                          :expected-type  (slot-definition-type slotd)
1803                          :initarg-name (car foundp)))
1804                 (setf (slot-value-using-class class instance slotd) new-value))
1805                ((and (or (eq slot-names t)
1806                          (member (slot-definition-name slotd)
1807                                  slot-names
1808                                  :test #'eq))
1809                      (not (slot-boundp-using-class class instance slotd)))
1810                 ;; If the slot name is among the specified slot names, or
1811                 ;; we're reinitializing all slots, and the slot is currently
1812                 ;; unbound in the instance, set the slot's value based
1813                 ;; on the initfunction (which captures the :INITFORM).
1814                 (let* ((initfunction (slot-definition-initfunction slotd)))
1815                   (if initfunction
1816                     (let* ((newval (funcall initfunction)))
1817                       (unless (or (null predicate)
1818                                   (funcall predicate newval))
1819                         (error 'bad-slot-type-from-initform
1820                                :slot-definition slotd
1821                                :expected-type (slot-definition-type slotd)
1822                                :datum newval
1823                                :instance instance))
1824                       (setf (slot-value-using-class class instance slotd)
1825                             newval))))))))))
1826  instance)
1827
1828;;; Sometimes you can do a lot better at generic function dispatch than the
1829;;; default. This supports that for the one-arg-dcode case.
1830(defmethod override-one-method-one-arg-dcode ((generic-function t) (method t))
1831  nil)
1832
1833(defun optimize-generic-function-dispatching ()
1834  (dolist (gf (population.data %all-gfs%))
1835    (optimize-dispatching-for-gf gf)))
1836
1837(defun optimize-dispatching-for-gf (gf)
1838  (let* ((dcode (%gf-dcode gf))
1839         (name (function-name dcode)))
1840    (when (or (eq name '%%one-arg-dcode)
1841              (eq name '%%nth-arg-dcode))
1842      (let ((methods (generic-function-methods gf)))
1843        (when (and methods (null (cdr methods)))
1844          (when (or (eq #'%%one-arg-dcode dcode)
1845                    (and (eq #'%%nth-arg-dcode dcode)
1846                         (let ((spec (method-specializers (car methods)))
1847                               (argnum (%gf-dispatch-table-argnum
1848                                        (%gf-dispatch-table gf))))
1849                           (and (eql 2 (length spec))
1850                                (and (eql argnum 1) (eq (car spec) *t-class*))))))
1851            (override-one-method-one-arg-dcode gf (car methods))))))))
1852
1853(defparameter *unique-reader-dcode-functions* t)
1854
1855;;; dcode for a GF with a single reader method which accesses
1856;;; a slot in a class that has no subclasses (that restriction
1857;;; makes typechecking simpler and also ensures that the slot's
1858;;; location is correct.)
1859(defun singleton-reader-dcode (dt instance)
1860  (declare (optimize (speed 3) (safety 0)))
1861  (let* ((wrapper (%svref dt %gf-dispatch-table-first-data))
1862         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
1863    (if (eq (if (eq (typecode instance) target::subtag-instance)
1864              (instance.class-wrapper instance))
1865            wrapper)
1866      (%slot-ref (instance.slots instance) location)
1867      (cond ((and (eq (typecode instance) target::subtag-instance)
1868                  (eq 0 (%wrapper-hash-index (instance.class-wrapper instance)))
1869                  (progn (update-obsolete-instance instance)
1870                         (eq (instance.class-wrapper instance) wrapper)))
1871             (%slot-ref (instance.slots instance) location))
1872            (t (no-applicable-method (%gf-dispatch-table-gf dt) instance))))))
1873(register-dcode-proto #'singleton-reader-dcode *gf-proto-one-arg*)
1874
1875;;; Dcode for a GF whose methods are all reader-methods which access a
1876;;; slot in one or more classes which have multiple subclasses, all of
1877;;; which (by luck or design) have the same slot-definition location.
1878(defun reader-constant-location-dcode (dt instance)
1879  (declare (optimize (speed 3) (safety 0)))
1880    (if (memq (if (eq (typecode instance) target::subtag-instance)
1881              (%class-of-instance instance))
1882              (%svref dt %gf-dispatch-table-first-data))
1883      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
1884      (no-applicable-method (%gf-dispatch-table-gf dt) instance)))
1885(register-dcode-proto #'reader-constant-location-dcode *gf-proto-one-arg*)
1886
1887;;; Dcode for a GF whose methods are all reader-methods which access a
1888;;; slot in one or more classes which have multiple subclasses, all of
1889;;; which (by luck or design) have the same slot-definition location.
1890;;; The number of classes for which the method is applicable is
1891;;; potentially large, but all are subclasses of a single class
1892(defun reader-constant-location-inherited-from-single-class-dcode (dt instance)
1893  (declare (optimize (speed 3) (safety 0)))
1894  (let* ((defining-class-ordinal (%svref dt %gf-dispatch-table-first-data))
1895         (bits  (let* ((wrapper
1896                        (if (eq (typecode instance) target::subtag-instance)
1897                          (instance.class-wrapper instance))))
1898                  (when wrapper (or (%wrapper-cpl-bits wrapper)
1899                                    (make-cpl-bits (%inited-class-cpl
1900                                                    (%wrapper-class wrapper))))))))
1901    (declare (fixnum defining-class-ordinal))
1902    (if (and bits
1903             (< defining-class-ordinal (the fixnum (uvsize bits)))
1904             (not (eql 0 (sbit bits defining-class-ordinal))))
1905      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
1906      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
1907(register-dcode-proto #'reader-constant-location-inherited-from-single-class-dcode *gf-proto-one-arg*)
1908
1909;;; It may be faster to make individual functions that take their
1910;;; "parameters" (defining class ordinal, slot location) as constants.
1911;;; It may not be.  Use *unique-reader-dcode-functions* to decide
1912;;; whether or not to do so.
1913(defun make-reader-constant-location-inherited-from-single-class-dcode
1914    (defining-class-ordinal location gf)
1915  (if *unique-reader-dcode-functions*
1916    (let* ((gf-name (function-name gf)))
1917      (values
1918       (%make-function 
1919        `(slot-reader for ,gf-name)
1920        `(lambda (instance)
1921          (locally (declare (optimize (speed 3) (safety 0)))
1922            (let* ((bits (let* ((wrapper
1923                                 (if (eq (typecode instance) target::subtag-instance)
1924                                   (instance.class-wrapper instance))))
1925                           (when wrapper (or (%wrapper-cpl-bits wrapper)
1926                                             (make-cpl-bits (%inited-class-cpl
1927                                                             (%wrapper-class wrapper))))))))
1928              (if (and bits
1929                       (< ,defining-class-ordinal (the fixnum (uvsize bits)))
1930                       (not (eql 0 (sbit bits ,defining-class-ordinal))))
1931                (%slot-ref (instance.slots instance) ,location)
1932                (no-applicable-method (function ,gf-name) instance)))))
1933        nil)
1934       #'funcallable-trampoline))
1935    (let* ((dt (gf.dispatch-table gf)))
1936      (setf (%svref dt %gf-dispatch-table-first-data)
1937            defining-class-ordinal
1938            (%svref dt (1+ %gf-dispatch-table-first-data))
1939            location)
1940      (values
1941       (dcode-for-gf gf #'reader-constant-location-inherited-from-single-class-dcode)
1942       (cdr (assq #'reader-constant-location-inherited-from-single-class-dcode dcode-proto-alist))))))
1943
1944;;; Dcode for a GF whose methods are all reader-methods which access a
1945;;; slot in one or more classes which have multiple subclasses, all of
1946;;; which (by luck or design) have the same slot-definition location.
1947;;; The number of classes is for which the method is applicable is
1948;;; large, but all are subclasses of one of a (small) set of defining classes.
1949(defun reader-constant-location-inherited-from-multiple-classes-dcode (dt instance)
1950  (declare (optimize (speed 3) (safety 0)))
1951  (let* ((wrapper (if (eq (typecode instance) target::subtag-instance)
1952                    (instance.class-wrapper instance)))
1953         (bits (if wrapper (or (%wrapper-cpl-bits wrapper)
1954                               (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
1955         (nbits (if bits (uvsize bits) 0)))
1956    (declare (fixnum nbits))
1957    (if (dolist (ordinal (%svref dt %gf-dispatch-table-first-data))
1958          (declare (fixnum ordinal))
1959          (when (and (< ordinal nbits)
1960                     (not (eql 0 (sbit bits ordinal))))
1961            (return t)))
1962      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
1963      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
1964(register-dcode-proto #'reader-constant-location-inherited-from-multiple-classes-dcode *gf-proto-one-arg*)
1965
1966
1967;;; Similar to the case above, but we use an alist to map classes
1968;;; to their non-constant locations.
1969(defun reader-variable-location-dcode (dt instance)
1970  (declare (optimize (speed 3) (safety 0)))
1971  (let* ((alist (%svref dt %gf-dispatch-table-first-data))
1972         (location (cdr
1973                    (assq
1974                     (if (eq (typecode instance) target::subtag-instance)
1975                       (%class-of-instance instance))
1976                     alist))))
1977    (if location
1978      (%slot-ref (instance.slots instance) location)
1979      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
1980(register-dcode-proto #'reader-variable-location-dcode *gf-proto-one-arg*)
1981
1982(defun class-and-slot-location-alist (classes slot-name)
1983  (let* ((alist nil))
1984    (labels ((add-class (c)
1985               (unless (assq c alist)
1986                 (let* ((slots (class-slots c)))
1987                   (unless slots
1988                     (finalize-inheritance c)
1989                     (setq slots (class-slots c)))
1990                   (push (cons c (slot-definition-location (find-slotd slot-name slots))) alist))
1991                 (dolist (sub (class-direct-subclasses c))
1992                   (add-class sub)))))
1993      (dolist (class classes) (add-class class))
1994      ;; Building the alist the way that we have should often approximate
1995      ;; this ordering; the idea is that leaf classes are more likely to
1996      ;; be instantiated than non-leaves.
1997      (sort alist (lambda (c1 c2)
1998                    (< (length (class-direct-subclasses c1))
1999                       (length (class-direct-subclasses c2))))
2000            :key #'car))))
2001
2002;;; Return a list of all classes in CLASS-LIST that aren't subclasses
2003;;; of any other class in the list.
2004(defun remove-subclasses-from-class-list (class-list)
2005  (if (null (cdr class-list))
2006    class-list
2007    (collect ((unique))
2008      (dolist (class class-list (unique))
2009        (when (dolist (other class-list t)
2010                (unless (eq class other)
2011                  (when (subtypep class other) (return nil))))
2012          (unique class))))))
2013
2014
2015;;; Try to replace gf dispatch with something faster in f.
2016(defun %snap-reader-method (f &key (redefinable t))
2017  (when (slot-boundp f 'methods)
2018    (let* ((methods (generic-function-methods f)))
2019      (when (and methods
2020                 (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods)
2021                 (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods)
2022                 (every (lambda (m) (null (method-qualifiers m))) methods))
2023        (let* ((m0 (car methods))
2024               (name (slot-definition-name (accessor-method-slot-definition m0))))
2025          (when (every (lambda (m)
2026                         (eq name (slot-definition-name (accessor-method-slot-definition m))))
2027                       (cdr methods))
2028            ;; All methods are *STANDARD-READER-METHODS* that
2029            ;; access the same slot name.  Build an alist of
2030            ;; mapping all subclasses of all classes on which those
2031            ;; methods are specialized to the effective slot's
2032            ;; location in that subclass.
2033            (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m)))
2034                                    methods))
2035                   (alist (class-and-slot-location-alist classes name))
2036                   (loc (cdar alist))
2037                   (dt (gf.dispatch-table f)))
2038              ;; Only try to handle the case where all slots have
2039              ;; :allocation :instance (and all locations - the CDRs
2040              ;; of the alist pairs - are small, positive fixnums.
2041              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
2042                (when redefinable
2043                  (loop for (c . nil) in alist
2044                        do (note-class-dependent c f)))
2045                (clear-gf-dispatch-table dt)
2046                (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
2047                (cond ((null (cdr alist))
2048                       ;; Method is only applicable to a single class.
2049                       (destructuring-bind (class . location) (car alist)
2050                         (setf (%svref dt %gf-dispatch-table-first-data) (%class.own-wrapper class)
2051                               (%svref dt (1+ %gf-dispatch-table-first-data)) location
2052                               (gf.dcode f) (dcode-for-gf f #'singleton-reader-dcode))))
2053                      ((dolist (other (cdr alist) t)
2054                         (unless (eq (cdr other) loc)
2055                           (return)))
2056                       ;; All classes have the slot in the same location,
2057                       ;; by luck or design.
2058                       (cond
2059                         ((< (length alist) 10)
2060                          ;; Only a small number of classes, just do MEMQ
2061                          (setf (%svref dt %gf-dispatch-table-first-data)
2062                                (mapcar #'car alist)
2063                                (%svref dt (1+ %gf-dispatch-table-first-data))
2064                                loc
2065                                (gf.dcode f) (dcode-for-gf f #'reader-constant-location-dcode)))
2066                         ((null (cdr (setq classes (remove-subclasses-from-class-list classes))))
2067                          ;; Lots of classes, all subclasses of a single class
2068                          (multiple-value-bind (dcode trampoline)
2069                              (make-reader-constant-location-inherited-from-single-class-dcode (%class-ordinal (car classes)) loc f)
2070                            (setf (gf.dcode f) dcode)
2071                            (replace-function-code f trampoline)))
2072                         (t
2073                          ;; Multple classes.  We should probably check
2074                          ;; to see they're disjoint
2075                          (setf (%svref dt %gf-dispatch-table-first-data)
2076                                (mapcar #'%class-ordinal classes)
2077                                (%svref dt (1+ %gf-dispatch-table-first-data))
2078                                loc
2079                                (gf.dcode f)
2080                                (dcode-for-gf f #'reader-constant-location-inherited-from-multiple-classes-dcode)))))
2081                      (t
2082                       ;; Multiple classes; the slot's location varies.
2083                       (setf (%svref dt %gf-dispatch-table-first-data)
2084                             alist
2085                             
2086                             (gf.dcode f) (dcode-for-gf f #'reader-variable-location-dcode))))))))))))
2087
2088;;; Hack-o-rama: GF has nothing but primary methods, first (and only non-T)
2089;;; specializers are all EQL specializers whose objects are symbols.
2090;;; The effective method applicable for each symbol is stored on the
2091;;; plist of the symbol under a property EQ to the dispatch table (which
2092;;; is mostly ignored, otherwise.)
2093(defun %%1st-arg-eql-method-hack-dcode (dt args)
2094  (let* ((sym (if (listp args) (car args)(%lexpr-ref args (%lexpr-count args) 0)))
2095         (mf (if (symbolp sym) (get sym dt))))
2096    (if mf
2097      (if (listp args)
2098        (apply mf args)
2099        (%apply-lexpr-tail-wise mf args))
2100      ;;; Let %%1st-arg-dcode deal with it.
2101      (%%1st-arg-dcode dt args))))
2102(register-dcode-proto #'%%1st-arg-eql-method-hack-dcode *gf-proto*)
2103
2104(defun %%1st-two-arg-eql-method-hack-dcode (dt arg1 arg2)
2105  (let* ((mf (if (typep arg1 'symbol) (get arg1 dt))))
2106    (if mf
2107      (funcall mf arg1 arg2)
2108      (%%1st-two-arg-dcode dt arg1 arg2))))
2109(register-dcode-proto #'%%1st-two-arg-eql-method-hack-dcode *gf-proto-two-arg*)
2110
2111(defun %%one-arg-eql-method-hack-dcode (dt arg)
2112  (let* ((mf (if (typep arg 'symbol) (get arg dt))))
2113    (if mf
2114      (funcall mf arg))))
2115(register-dcode-proto #'%%one-arg-eql-method-hack-dcode *gf-proto-one-arg*)
2116
2117(defun install-eql-method-hack-dcode (gf)
2118  (let* ((bits (inner-lfun-bits gf))
2119         (nreq (ldb $lfbits-numreq bits))
2120         (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits)))
2121                          (logbitp $lfbits-rest-bit bits)
2122                          (logbitp $lfbits-restv-bit bits)
2123                          (logbitp $lfbits-keys-bit bits)
2124                          (logbitp $lfbits-aok-bit bits))))
2125    (setf (%gf-dcode gf)
2126          (dcode-for-gf gf
2127                        (cond ((and (eql nreq 1) (null other-args?))
2128                               #'%%one-arg-eql-method-hack-dcode)
2129                              ((and (eql nreq 2) (null other-args?))
2130                               #'%%1st-two-arg-eql-method-hack-dcode)
2131                              (t
2132                               #'%%1st-arg-eql-method-hack-dcode))))))
2133
2134(defun maybe-hack-eql-methods (gf)
2135  (let* ((methods (generic-function-methods gf)))
2136    (when (and methods
2137               (every #'(lambda (method)
2138                          (let* ((specializers (method-specializers method))
2139                                      (first (car specializers)))
2140                                 (and (typep first 'eql-specializer)
2141                                      (typep (eql-specializer-object first) 'symbol)
2142                                      (dolist (s (cdr specializers) t)
2143                                        (unless (eq s *t-class*)
2144                                          (return nil)))
2145                                      (null (cdr (compute-applicable-methods gf (cons (eql-specializer-object first) (make-list (length (cdr specializers))))))))))
2146                      methods))
2147      (let* ((dt (%gf-dispatch-table gf)))
2148        (dolist (m methods)
2149          (let* ((sym (eql-specializer-object (car (method-specializers m))))
2150                 (f (method-function m)))
2151            (setf (get sym dt) f)))
2152        (install-eql-method-hack-dcode gf)
2153        t))))
2154
2155
2156           
2157                           
2158;;; Return a list of :after methods for INITIALIZE-INSTANCE on the
2159;;; class's prototype, and a boolean that's true if no other qualified
2160;;; methods are defined and at most one primary one.
2161(defun initialize-instance-after-methods (proto class)
2162  (let* ((method-list (compute-method-list (sort-methods
2163                            (compute-applicable-methods #'initialize-instance (list proto))
2164                            (list (class-precedence-list class))))))
2165    (if (atom method-list)
2166      (values nil t)
2167      (if (and (null (car method-list))
2168               (null (cdddr method-list)))
2169        (values (cadr method-list) t)
2170        ;; :around or :before methods, or more than one primary method, give up
2171        (values nil nil)))))
2172
2173(defparameter *typecheck-slots-in-optimized-make-instance* t)
2174
2175
2176;;; Return a lambda form or NIL.
2177(defun make-instantiate-lambda-for-class-cell (cell)
2178  (let* ((class (class-cell-class cell))
2179         (after-methods nil))
2180    (when (and (typep class 'standard-class)
2181               (progn (unless (class-finalized-p class)
2182                        (finalize-inheritance class))
2183                      t)
2184               (null (cdr (compute-applicable-methods #'allocate-instance (list class))))
2185               (let* ((proto (class-prototype class)))
2186                 (and (multiple-value-bind (afters ok)
2187                          (initialize-instance-after-methods proto class)
2188                        (when ok
2189                          (setq after-methods afters)
2190                          t))
2191                      (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
2192      (let* ((slotds (sort (copy-list (class-slots class))
2193                           #'(lambda (x y)
2194                               (if (consp x) x (if (consp y) y (< x y))))
2195                           :key #'slot-definition-location))
2196             (default-initargs (class-default-initargs class)))
2197        (collect ((keys)
2198                  (binds)
2199                  (class-binds)
2200                  (ignorable)
2201                  (class-slot-inits)
2202                  (after-method-forms)
2203                  (forms))
2204          (flet ((generate-type-check (form type &optional spvar)
2205                   (if (or (null *typecheck-slots-in-optimized-make-instance*)
2206                           (eq type t)
2207                           (and (quoted-form-p type) (eq (cadr type) t)))
2208                     form
2209                     (if spvar
2210                       `(if ,spvar
2211                         (require-type ,form ',type)
2212                         ,form)
2213                       `(require-type ,form ',type)))))
2214            (dolist (slot slotds)
2215              (let* ((initargs (slot-definition-initargs slot))
2216                     (initfunction (slot-definition-initfunction slot))
2217                     (initform (slot-definition-initform slot))
2218                     (location (slot-definition-location slot))
2219                     (location-var nil)
2220                     (class-init-p nil)
2221                     (one-initarg-p (null (cdr initargs)))
2222                     (name (slot-definition-name slot))
2223                     (type (slot-definition-type slot)))
2224                (when (consp location)
2225                  (setq location-var (gensym "LOCATION")))
2226                (when initfunction
2227                  (setq initform
2228                        (if (self-evaluating-p initform)
2229                            initform
2230                            `(funcall ,initfunction))))
2231                (cond ((null initargs)
2232                       (let ((initial-value-form
2233                              (if initfunction
2234                                  (generate-type-check initform type)
2235                                  `(%slot-unbound-marker))))
2236                         (if location-var
2237                             (when initfunction
2238                               (setq class-init-p t)
2239                               (class-slot-inits
2240                                `(when (eq (%slot-unbound-marker) (cdr ,location-var))
2241                                   (setf (cdr ,location-var) ,initial-value-form))))
2242                             (forms initial-value-form))))
2243                      (t (collect ((cond-clauses))
2244                           (let ((last-cond-clause nil))
2245                             (dolist (initarg initargs)
2246                               (let* ((spvar nil)
2247                                      (name (if one-initarg-p
2248                                                name
2249                                                (gensym (string name))))
2250                                      (initial-value-form
2251                                       (if (and initfunction
2252                                                one-initarg-p
2253                                                (null location-var))
2254                                           initform
2255                                           (progn
2256                                             (when initarg
2257                                               (setq spvar (make-symbol
2258                                                            (concatenate
2259                                                             'string
2260                                                             (string initarg)
2261                                                             "-P"))))
2262                                             (and one-initarg-p
2263                                                  (null location-var)
2264                                                  (if initfunction
2265                                                      initform
2266                                                      `(%slot-unbound-marker))))))
2267                                      (default (assq initarg default-initargs)))
2268                                 (when spvar (ignorable spvar))
2269                                 (when default
2270                                   (destructuring-bind (form function)
2271                                       (cdr default)
2272                                     (setq default
2273                                           (if (self-evaluating-p form)
2274                                               form
2275                                               `(funcall ,function)))))
2276                                 (keys (list*
2277                                        (list initarg name)
2278                                        (if (and default one-initarg-p (null location-var))
2279                                            default
2280                                            initial-value-form)
2281                                        (if spvar (list spvar))))
2282                                 (if one-initarg-p
2283                                   (if location-var
2284                                     (progn
2285                                       (setq class-init-p t)
2286                                       (class-slot-inits
2287                                        `(if ,spvar
2288                                           (setf (cdr ,location-var)
2289                                                 ,(generate-type-check
2290                                                   name type))
2291                                           ,(if default
2292                                              `(setf (cdr ,location-var)
2293                                                     ,(generate-type-check
2294                                                       default type))
2295                                              (when initfunction
2296                                                `(when (eq (%slot-unbound-marker)
2297                                                           (cdr ,location-var))
2298                                                   (setf (cdr ,location-var)
2299                                                         ,(generate-type-check
2300                                                           initform type))))))))
2301                                     (forms `,(generate-type-check name type spvar)))
2302                                     (progn (cond-clauses `(,spvar ,name))
2303                                            (when (and default (null last-cond-clause))
2304                                              (setq last-cond-clause
2305                                                    `(t ,default)))))))
2306                             (when (cond-clauses)
2307                               (when last-cond-clause
2308                                 (cond-clauses last-cond-clause))
2309                               (cond ((null location-var)
2310                                      (unless last-cond-clause
2311                                        (cond-clauses `(t ,initform)))
2312                                      (forms (generate-type-check
2313                                              `(cond ,@(cond-clauses))
2314                                              type)))
2315                                     (t
2316                                      (let ((initform-p-var
2317                                             (unless last-cond-clause
2318                                               (make-symbol "INITFORM-P")))
2319                                            (value-var (make-symbol "VALUE")))
2320                                        (unless last-cond-clause
2321                                          (cond-clauses
2322                                           `(t (setq ,initform-p-var t)
2323                                               ,(if initfunction
2324                                                    initform
2325                                                    `(%slot-unbound-marker)))))
2326                                        (setq class-init-p t)
2327                                        (class-slot-inits
2328                                         `(let* (,@(and initform-p-var
2329                                                        (list `(,initform-p-var nil)))
2330                                                 (,value-var
2331                                                  ,(generate-type-check
2332                                                    `(cond ,@(cond-clauses)) type)))
2333                                            (when
2334                                                ,(if initform-p-var
2335                                                     `(or (null ,initform-p-var)
2336                                                          (and (eq (cdr ,location-var)
2337                                                                   (%slot-unbound-marker))
2338                                                               (not (eq ,value-var
2339                                                                        (%slot-unbound-marker)))))
2340                                                     t)
2341                                                (setf (cdr ,location-var) ,value-var))))))))))))
2342                (when class-init-p
2343                  (class-binds `(,location-var
2344                                 (load-time-value
2345                                  (slot-definition-location ',slot))))))))
2346          (let* ((cell (make-symbol "CLASS-CELL"))
2347                 (args (make-symbol "ARGS"))
2348                 (slots (make-symbol "SLOTS"))
2349                 (instance (make-symbol "INSTANCE")))
2350            (dolist (after after-methods)
2351              (after-method-forms `(apply ,(method-function after) ,instance ,args)))
2352            (when after-methods
2353              (after-method-forms instance))
2354            (binds `(,slots (gvector :slot-vector nil ,@(forms))))
2355            (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots)))
2356            `(lambda (,cell ,@(when after-methods `(&rest ,args)) &key ,@(keys) ,@(when after-methods '(&allow-other-keys)))
2357              (declare (ignorable ,@(ignorable)))
2358              ,@(when after-methods `((declare (dynamic-extent ,args))))
2359              (let (,@(class-binds))
2360                ,@(class-slot-inits))
2361              (let* (,@(binds))
2362                (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)
2363                      (%svref ,slots 0) ,instance)
2364                ,@(after-method-forms)))))))))
2365
2366(defun optimize-make-instance-for-class-cell (cell)
2367  (init-class-cell-instantiator cell)
2368  (let* ((lambda (make-instantiate-lambda-for-class-cell cell)))
2369    (when lambda
2370      (setf (class-cell-instantiate cell) (compile nil lambda)
2371            (class-cell-extra cell) (%class.own-wrapper
2372                                     (class-cell-class cell)))
2373      t)))
2374
2375(defun optimize-make-instance-for-class-name (class-name)
2376  (optimize-make-instance-for-class-cell (find-class-cell class-name t)))
2377
2378(defun optimize-named-class-make-instance-methods ()
2379  (maphash (lambda (class-name class-cell)
2380             (handler-case (optimize-make-instance-for-class-cell class-cell)
2381               (error (c)
2382                      (warn "error optimizing make-instance for ~s:~&~a"
2383                            class-name c))))
2384           %find-classes%))
2385
2386;; Redefined from bootstrapping verison in l1-clos-boot.lisp
2387;; Remove the make-instance optimization if the user is adding
2388;; a method on initialize-instance, allocate-instance, or shared-initialize
2389(defun maybe-remove-make-instance-optimization (gfn method)
2390  (when (or (eq gfn #'allocate-instance)
2391            (eq gfn #'initialize-instance)
2392            (eq gfn #'shared-initialize))
2393    (let ((specializer (car (method-specializers method))))
2394      (when (typep specializer 'class)
2395        (labels ((clear (class)
2396                   (pessimize-make-instance-for-class-name (class-name class))
2397                   (dolist (sub (%class-direct-subclasses class))
2398                     (clear sub))))
2399          (clear specializer))))))
2400
2401;;; Iterate over all known GFs; try to optimize their dcode in cases
2402;;; involving reader methods.
2403
2404(defun snap-reader-methods (&key known-sealed-world
2405                                 (check-conflicts t)
2406                                 (optimize-make-instance t))
2407  (declare (ignore check-conflicts)
2408           (ignore known-sealed-world))
2409  (when optimize-make-instance
2410    (optimize-named-class-make-instance-methods))
2411  (let* ((ngf 0)
2412         (nwin 0))
2413    (dolist (f (population.data %all-gfs%))
2414      (incf ngf)
2415      (when (%snap-reader-method f)
2416        (incf nwin)))
2417    (values ngf nwin 0)))
2418
2419(defun register-non-dt-dcode-function (f)
2420  (flet ((symbol-or-function-name (x)
2421           (etypecase x
2422             (symbol x)
2423             (function (function-name x)))))
2424    (let* ((already (member (symbol-or-function-name f) *non-dt-dcode-functions* :key #'symbol-or-function-name)))
2425      (if already
2426        (setf (car already) f)
2427        (push f *non-dt-dcode-functions*))
2428      f)))
2429
2430(defun pessimize-clos ()
2431  ;; Undo MAKE-INSTANCE optimization
2432  (maphash (lambda (class-name class-cell)
2433             (declare (ignore class-name))
2434             (init-class-cell-instantiator class-cell))
2435           %find-classes%)
2436  ;; Un-snap reader methods, undo other GF optimizations.
2437  (dolist (f (population-data %all-gfs%))
2438    (let* ((dt (%gf-dispatch-table f)))
2439      (clear-gf-dispatch-table dt)
2440      (compute-dcode f))))
2441
2442;;; If there's a single method (with standard method combination) on
2443;;; GF and all of that method's arguments are specialized to the T
2444;;; class - and if the method doesn't accept &key - we can just have
2445;;; the generic function call the method-function
2446(defun dcode-for-universally-applicable-singleton (gf)
2447  (when (eq (generic-function-method-combination gf)
2448            *standard-method-combination*)
2449    (let* ((methods (generic-function-methods gf))
2450           (method (car methods)))
2451      (when (and method
2452                 (null (cdr methods))
2453                 (null (method-qualifiers method))
2454                 (not (logbitp $lfbits-keys-bit (lfun-bits (method-function method))))
2455                 (dolist (spec (method-specializers method) t)
2456                   (unless (eq spec *t-class*)
2457                     (return nil))))
2458        (method-function method)))))
2459
2460(register-non-dt-dcode-function #'dcode-for-universally-applicable-singleton)
Note: See TracBrowser for help on using the repository browser.