source: branches/working-0711/ccl/level-1/l1-clos.lisp @ 11101

Last change on this file since 11101 was 11101, checked in by gz, 13 years ago

Another round of changes from the trunk, mostly just mods in internal mechanisms in support of various recent ports.

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