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

Last change on this file since 15018 was 15001, checked in by gb, 8 years ago

Move some of the class initialiation code for SLOTS-CLASS from an
:AFTER method on SHARED-INITIALIZE to a new internal method called
from new :AFTER-METHODS on INITIALIZE-INSTANCE and
REINITIALIZE-INSTANCE.

(The SHARED-INITIALIZE :AFTER method only exists to declare initargs
at this point.)

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