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

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

Maintain CPL in wrapper ...
Slot type-predicates can be NULL (instead of/interpreted as #'TRUE).
Trust TYPEP/REQUIRE-TYPE a little more in optimized make-instance.

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