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

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

Merge a lot of the CLOS/type-system changes from working-0711 branch
into trunk. Todo: compiler-macros for those changes.

Have -not- yet merged source-tracking changes, new record-source file
from working-0711, but this stuff seems to bootstrap in one swell foop.

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