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

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

Don't use DCODE-FOR-UNIVERSALLY-APPLICABLE-SINGLETON if method-function
has &key.

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