(defmethod initialize-internal-slot-functions ((slotd
effective-slot-definition))
(let* ((name (slot-value slotd 'name))
- (class (slot-value slotd 'class)))
- (let ((table (or (gethash name *name->class->slotd-table*)
- (setf (gethash name *name->class->slotd-table*)
- (make-hash-table :test 'eq :size 5)))))
- (setf (gethash class table) slotd))
+ (class (slot-value slotd '%class)))
(dolist (type '(reader writer boundp))
(let* ((gf-name (ecase type
(reader 'slot-value-using-class)
(defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
type gf)
(let* ((name (slot-value slotd 'name))
- (class (slot-value slotd 'class))
+ (class (slot-value slotd '%class))
(old-slotd (find-slot-definition class name))
(old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
(multiple-value-bind (function std-p)
slot-names
&key)
(declare (ignore slot-names))
- (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
+ (setf (slot-value specl '%type) `(class-eq ,(specializer-class specl))))
(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
(declare (ignore slot-names))
- (setf (slot-value specl 'type)
+ (setf (slot-value specl '%type)
`(eql ,(specializer-object specl)))
(setf (info :type :translator specl)
(constantly (make-member-type :members (list (specializer-object specl))))))
(declare (ignore slot-names name))
;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not,
;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.)
- (setf (slot-value class 'type) `(class ,class))
+ (setf (slot-value class '%type) `(class ,class))
(setf (slot-value class 'class-eq-specializer)
(make-instance 'class-eq-specializer :class class)))
&key direct-slots direct-superclasses)
(declare (ignore slot-names))
(let ((classoid (find-classoid (class-name class))))
- (with-slots (wrapper class-precedence-list cpl-available-p
+ (with-slots (wrapper %class-precedence-list cpl-available-p
prototype (direct-supers direct-superclasses))
class
(setf (slot-value class 'direct-slots)
(setf (classoid-pcl-class classoid) class)
(setq direct-supers direct-superclasses)
(setq wrapper (classoid-layout classoid))
- (setq class-precedence-list (compute-class-precedence-list class))
+ (setq %class-precedence-list (compute-class-precedence-list class))
(setq cpl-available-p t)
(add-direct-subclasses class direct-superclasses)
(setf (slot-value class 'slots) (compute-slots class))))
(compute-effective-slot-definition
class (slot-definition-name dslotd) (list dslotd)))
(class-direct-slots superclass)))
- (reverse (slot-value class 'class-precedence-list))))
+ (reverse (slot-value class '%class-precedence-list))))
(defmethod compute-slots :around ((class condition-class))
(let ((eslotds (call-next-method)))
(setf (slot-value class 'defstruct-constructor)
(make-defstruct-allocation-function class)))
(add-direct-subclasses class direct-superclasses)
- (setf (slot-value class 'class-precedence-list)
+ (setf (slot-value class '%class-precedence-list)
(compute-class-precedence-list class))
(setf (slot-value class 'cpl-available-p) t)
(setf (slot-value class 'slots) (compute-slots class))
(not (class-finalized-p class))
(not (class-has-a-forward-referenced-superclass-p class)))
(finalize-inheritance class)
+ (dolist (sub (class-direct-subclasses class))
+ (update-class sub nil))
(return-from update-class))
(when (or finalizep (class-finalized-p class)
(not (class-has-a-forward-referenced-superclass-p class)))
;; comment from the old CMU CL sources:
;; Need to have the cpl setup before update-lisp-class-layout
;; is called on CMU CL.
- (setf (slot-value class 'class-precedence-list) cpl)
+ (setf (slot-value class '%class-precedence-list) cpl)
(setf (slot-value class 'cpl-available-p) t)
(force-cache-flushes class))
(progn
- (setf (slot-value class 'class-precedence-list) cpl)
+ (setf (slot-value class '%class-precedence-list) cpl)
(setf (slot-value class 'cpl-available-p) t)))
(update-class-can-precede-p cpl))
(defun compute-class-slots (eslotds)
(let (collect)
- (dolist (eslotd eslotds)
- (push (assoc (slot-definition-name eslotd)
- (class-slot-cells (slot-definition-class eslotd)))
- collect))
- (nreverse collect)))
+ (dolist (eslotd eslotds (nreverse collect))
+ (let ((cell (assoc (slot-definition-name eslotd)
+ (class-slot-cells
+ (slot-definition-allocation-class eslotd)))))
+ (aver cell)
+ (push cell collect)))))
(defun update-gfs-of-class (class)
(when (and (class-finalized-p class)
(slot-definition-name dslotd)
(list dslotd)))
(class-direct-slots superclass)))
- (reverse (slot-value class 'class-precedence-list))))
+ (reverse (slot-value class '%class-precedence-list))))
(defmethod compute-slots :around ((class structure-class))
(let ((eslotds (call-next-method)))
;; -- --> local add slot
;; -- --> shared --
- ;; Collect class slots from inherited wrappers. Needed for
- ;; shared -> local transfers of inherited slots.
- (let ((inherited (layout-inherits owrapper)))
- (loop for i from (1- (length inherited)) downto 0
- for layout = (aref inherited i)
- when (typep layout 'wrapper)
- do (dolist (slot (wrapper-class-slots layout))
- (pushnew slot oclass-slots :key #'car))))
-
;; Go through all the old local slots.
(let ((opos 0))
(dolist (name olayout)