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

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

ENSURE-CLASS, ENSURE-CLASS-FOR-DEFCLASS: observe *SEALED-CLOS-WORLD*.

SNAP-READER-METHODS sets *SEALED-CLOS-WORLD*.

New function PESSIMIZE-CLOS tries to undo GF and MAKE-INSTANCE
optimizations, then clears *SEALED-CLOS-WORLD*.

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