Skip to content
Snippets Groups Projects
Commit f3bad3ed authored by rtoy's avatar rtoy
Browse files

Fix for compute-slots, from Gerd, cmucl-imp, 2005-05-28. The test

case reported by Bruno is:

#+CMU (use-package "PCL")
(defclass b (a) ())
(defmethod compute-slots ((class (eql (find-class 'b))))
  (append (call-next-method)
          (list (make-instance 'standard-effective-slot-definition
                  :name 'y
                  :allocation :instance))))
(defclass a () ((x :allocation :class)))
;; A should now have a shared slot, X, and a local slot, Y.
(mapcar #'slot-definition-location (class-slots (find-class 'b)))

Instead of an error about no matching method, we get

((X . PCL::..SLOT-UNBOUND..) 0)
parent 67fa1b75
No related branches found
No related tags found
No related merge requests found
...@@ -26,7 +26,7 @@ ...@@ -26,7 +26,7 @@
;;; ;;;
(file-comment (file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.77 2005/05/23 16:10:24 rtoy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.78 2005/05/31 18:10:05 rtoy Exp $")
(in-package :pcl) (in-package :pcl)
...@@ -999,23 +999,46 @@ ...@@ -999,23 +999,46 @@
(defmethod compute-slots ((class standard-class)) (defmethod compute-slots ((class standard-class))
(call-next-method)) (call-next-method))
(defmethod compute-slots :around ((class standard-class)) (defmethod compute-slots :around ((class standard-class))
(loop with slotds = (call-next-method) and location = -1 (let ((eslotds (call-next-method))
for slot in slotds do (location -1)
(setf (slot-definition-location slot) (slot-names ()))
(case (slot-definition-allocation slot) (dolist (eslotd eslotds eslotds)
(:instance (let ((allocation (slot-definition-allocation eslotd))
(incf location)) (name (slot-definition-name eslotd)))
(:class ;;
(let* ((name (slot-definition-name slot)) ;; Users are free to override COMPUTE-SLOTS, and they are
(from-class (slot-definition-allocation-class slot)) ;; arguably free to MAKE-INSTANCE effective slot definition
(cell (assq name (class-slot-cells from-class)))) ;; metaobjects. Such objects won't be initialized completely,
(assert (consp cell)) ;; from the standpoint of PCL, so we have to fix them.
cell)))) ;;
(initialize-internal-slot-functions slot) ;; If such an effective slot definition has the same name as
finally ;; another slot, we certainly lose, at least if it's a class
(return slotds))) ;; slot. I'm deliberately ignoring that for now.
;;
;; Note that COMPUTE-SLOTS can be called multiple times.
;; We don't want to create a new class slot cell every time
;; around.
(when (null (slot-definition-class eslotd))
(setf (slot-definition-class eslotd) class)
(when (eq allocation :class)
(unless (assq name (class-slot-cells class))
(push (cons name +slot-unbound+)
(plist-value class 'class-slot-cells)))
(setf (slot-definition-allocation-class eslotd) class)))
;;
;; Assign slot locations.
(setf (slot-definition-location eslotd)
(case allocation
(:instance
(incf location))
(:class
(let* ((from-class (slot-definition-allocation-class eslotd))
(cell (assq name (class-slot-cells from-class))))
(assert (consp cell))
cell))))
(initialize-internal-slot-functions eslotd)))))
(defmethod compute-slots ((class funcallable-standard-class)) (defmethod compute-slots ((class funcallable-standard-class))
(call-next-method)) (call-next-method))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment