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

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

Handle class slots in MAKE-INSTANTIATE-LAMBDA-FOR-CLASS-CELL.

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