source: branches/1.2/devel/source/level-1/l1-clos.lisp @ 8130

Last change on this file since 8130 was 8130, checked in by gb, 13 years ago

Merge changes from working-0711 branch

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