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

Last change on this file since 8853 was 8853, checked in by gz, 12 years ago

More detailed error messages for class forward references, make-condition

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