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

Last change on this file since 10423 was 10423, checked in by gb, 12 years ago

Start setting class ordinals. Note that it's assumed that MAX-CLASS-ORDINAL
(1MB) is smaller than the value returned by (STRIP-TAG-TO-FIXNUM instance)
for any (heap-allocated) standard-instance.

Provide support for foreign-class-ordinals, though we don't yet implement
a foreign object domain that uses them.

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