From f3bad3ed853861cfbad9a8b7aa8b492750f6073f Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 31 May 2005 18:10:05 +0000
Subject: [PATCH] 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)
---
 pcl/std-class.lisp | 57 ++++++++++++++++++++++++++++++++--------------
 1 file changed, 40 insertions(+), 17 deletions(-)

diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 1b6b75ca9..2a9797904 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (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)
 
@@ -999,23 +999,46 @@
 
 (defmethod compute-slots ((class standard-class))
   (call-next-method))
-  
+
 (defmethod compute-slots :around ((class standard-class))
-  (loop with slotds = (call-next-method) and location = -1
-	for slot in slotds do
-	  (setf (slot-definition-location slot)
-		(case (slot-definition-allocation slot)
-		  (:instance
-		   (incf location))
-		  (:class
-		   (let* ((name (slot-definition-name slot))
-			  (from-class (slot-definition-allocation-class slot))
-			  (cell (assq name (class-slot-cells from-class))))
-		     (assert (consp cell))
-		     cell))))
-	  (initialize-internal-slot-functions slot)
-	finally
-	  (return slotds)))
+  (let ((eslotds (call-next-method))
+	(location -1)
+	(slot-names ()))
+    (dolist (eslotd eslotds eslotds)
+      (let ((allocation (slot-definition-allocation eslotd))
+	    (name (slot-definition-name eslotd)))
+	;;
+	;; Users are free to override COMPUTE-SLOTS, and they are
+	;; arguably free to MAKE-INSTANCE effective slot definition
+	;; metaobjects.  Such objects won't be initialized completely,
+	;; from the standpoint of PCL, so we have to fix them.
+	;;
+	;; If such an effective slot definition has the same name as
+	;; another slot, we certainly lose, at least if it's a class
+	;; 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))
   (call-next-method))
-- 
GitLab