+ (case (slot-definition-allocation eslotd)
+ (:instance
+ (incf location))
+ (:class
+ (let* ((name (slot-definition-name eslotd))
+ (from-class
+ (or
+ (slot-definition-allocation-class eslotd)
+ ;; we get here if the user adds an extra slot
+ ;; himself...
+ (setf (slot-definition-allocation-class eslotd)
+ class)))
+ ;; which raises the question of what we should
+ ;; do if we find that said user has added a slot
+ ;; with the same name as another slot...
+ (cell (or (assq name (class-slot-cells from-class))
+ (setf (class-slot-cells from-class)
+ (cons (cons name +slot-unbound+)
+ (class-slot-cells from-class))))))
+ (aver (consp cell))
+ (if (eq +slot-unbound+ (cdr cell))
+ ;; We may have inherited an initfunction
+ (let ((initfun (slot-definition-initfunction eslotd)))
+ (if initfun
+ (rplacd cell (funcall initfun))
+ cell))
+ cell)))))
+ (unless (slot-definition-class eslotd)
+ (setf (slot-definition-class eslotd) class))
+ (initialize-internal-slot-functions eslotd))))
+
+(defmethod compute-slots ((class funcallable-standard-class))
+ (call-next-method))
+
+(defmethod compute-slots :around ((class funcallable-standard-class))
+ (labels ((instance-slot-names (slotds)
+ (let (collect)
+ (dolist (slotd slotds (nreverse collect))
+ (when (eq (slot-definition-allocation slotd) :instance)
+ (push (slot-definition-name slotd) collect)))))
+ ;; This sorts slots so that slots of classes later in the CPL
+ ;; come before slots of other classes. This is crucial for
+ ;; funcallable instances because it ensures that the slots of
+ ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
+ ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
+ ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
+ ;; a funcallable instance.
+ (compute-layout (eslotds)
+ (let ((first ())
+ (names (instance-slot-names eslotds)))
+ (dolist (class
+ (reverse (class-precedence-list class))
+ (nreverse (nconc names first)))
+ (dolist (ss (class-slots class))
+ (let ((name (slot-definition-name ss)))
+ (when (member name names)
+ (push name first)
+ (setq names (delete name names)))))))))
+ (let ((all-slotds (call-next-method))
+ (instance-slots ())
+ (class-slots ()))
+ (dolist (slotd all-slotds)
+ (case (slot-definition-allocation slotd)
+ (:instance (push slotd instance-slots))
+ (:class (push slotd class-slots))))
+ (let ((layout (compute-layout instance-slots)))
+ (dolist (slotd instance-slots)
+ (setf (slot-definition-location slotd)
+ (position (slot-definition-name slotd) layout))
+ (initialize-internal-slot-functions slotd)))
+ (dolist (slotd class-slots)
+ (let ((name (slot-definition-name slotd))
+ (from-class (slot-definition-allocation-class slotd)))
+ (setf (slot-definition-location slotd)
+ (assoc name (class-slot-cells from-class)))
+ (aver (consp (slot-definition-location slotd)))
+ (initialize-internal-slot-functions slotd)))
+ all-slotds)))