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

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

Propagate r10938:r10941 (duplicate definition warnings) to trunk

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