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

Last change on this file since 15265 was 15265, checked in by gb, 7 years ago

When we optimize a GF via %SNAP-READER-METHOD, we store the GF's
original dcode in the dispatch-table's GF slot so that we can
restore it if/when we undo the optimization; this is done under
the assumption that the optimized dcode doesn't need access to
the GF for method dispatch, but it does need it in order to
report NO-APPLICABLE-METHOD sanely. Store a CONS of (gf . dcode)
in the dispatch table's GF slot, access the car of that cons
when reporting no-applicable-method, and dtrt when undoing the
optimization.

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