From c9d7157587195669bc19ee9e2055dbe77a72f9f8 Mon Sep 17 00:00:00 2001
From: pmai <pmai>
Date: Sun, 22 Dec 2002 14:09:52 +0000
Subject: [PATCH] Entomotomy Bug: slot-definition-allocation-not-amop-compliant

Added needed second half of patch, from Gerd Moellmann via SBCL, to cure
newly introduced problem with inheritance of class slots.  Also committed
modified version (again via SBCL) of Gerd's COMPUTE-SLOTS revamp for more
modular computation of slot locations.
---
 pcl/defs.lisp      |   6 ++-
 pcl/methods.lisp   |   9 ++--
 pcl/std-class.lisp | 119 ++++++++++++++++++++++++++++-----------------
 3 files changed, 85 insertions(+), 49 deletions(-)

diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index 0f7ea9169..97a3d8dd5 100644
--- a/pcl/defs.lisp
+++ b/pcl/defs.lisp
@@ -594,7 +594,11 @@
   ((allocation
     :initform :instance
     :initarg :allocation
-    :accessor slot-definition-allocation)))
+    :accessor slot-definition-allocation)
+   (allocation-class
+    :initform nil
+    :initarg :allocation-class
+    :accessor slot-definition-allocation-class)))
 
 (defclass structure-slot-definition (slot-definition)
   ((defstruct-accessor-symbol 
diff --git a/pcl/methods.lisp b/pcl/methods.lisp
index 3021b1a82..ca7d167df 100644
--- a/pcl/methods.lisp
+++ b/pcl/methods.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.20 2002/12/18 16:29:06 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.21 2002/12/22 14:09:51 pmai Exp $")
 ;;;
 
 (in-package :pcl)
@@ -67,9 +67,10 @@
 ;;;
 ;;;
 ;;;
-(defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names 
-				     &key (allocation :instance))
-  (declare (ignore slot-names))
+(defmethod shared-initialize :after
+    ((slotd structure-slot-definition) slot-names 
+     &key (allocation :instance) allocation-class)
+  (declare (ignore slot-names allocation-class))
   (unless (eq allocation :instance)
     (error "structure slots must have :instance allocation")))
 
diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp
index 8422f661b..7750a96ba 100644
--- a/pcl/std-class.lisp
+++ b/pcl/std-class.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.38 2002/12/18 16:29:06 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.39 2002/12/22 14:09:52 pmai Exp $")
 ;;;
 
 (in-package :pcl)
@@ -751,24 +751,6 @@
 	and class = (slot-definition-class eslotd)
 	collect (assoc name (class-slot-cells class))))
 
-(defun compute-layout (cpl instance-eslotds)
-  (let* ((names (loop for eslotd in instance-eslotds
-		      when (eq (slot-definition-allocation eslotd) :instance)
-		      collect (slot-definition-name eslotd)))
-	 (order ()))
-    (labels ((rwalk (tail)
-	       (when tail
-		 (rwalk (cdr tail))
-		 (dolist (ss (class-slots (car tail)))
-		   (let ((n (slot-definition-name ss)))
-		     (when (member n names)
-		       (setq order (cons n order)
-			     names (remove n names))))))))
-      (rwalk (if (slot-boundp (car cpl) 'slots)
-		 cpl
-		 (cdr cpl)))
-      (reverse (append names order)))))
-
 (defun update-gfs-of-class (class)
   (when (and (class-finalized-p class)
 	     (let ((cpl (class-precedence-list class)))
@@ -833,37 +815,83 @@
   ;;
   (let ((name-dslotds-alist ()))
     (dolist (c (class-precedence-list class))
-      (let ((dslotds (class-direct-slots c)))
-	(dolist (d dslotds)
-	  (let* ((name (slot-definition-name d))
-		 (entry (assq name name-dslotds-alist)))
-	    (if entry
-		(push d (cdr entry))
-		(push (list name d) name-dslotds-alist))))))
+      (dolist (slot (class-direct-slots c))
+	(let* ((name (slot-definition-name slot))
+	       (entry (assq name name-dslotds-alist)))
+	  (if entry
+	      (push slot (cdr entry))
+	      (push (list name slot) name-dslotds-alist)))))
     (mapcar (lambda (direct)
 	      (compute-effective-slot-definition class
 						 (nreverse (cdr direct))))
 	    name-dslotds-alist)))
 
-(defmethod compute-slots :around ((class std-class))
+(defmethod compute-slots ((class standard-class))
+  (call-next-method))
+
+(defmethod compute-slots :around ((class standard-class))
   (let ((eslotds (call-next-method))
-	(cpl (class-precedence-list class))
-	(instance-slots ())
-	(class-slots    ()))
-    (dolist (eslotd eslotds)
-      (ecase (slot-definition-allocation eslotd)
-	(:instance (push eslotd instance-slots))
-	(:class    (push eslotd class-slots))))
-    (let ((nlayout (compute-layout cpl instance-slots)))
-      (dolist (eslotd instance-slots)
-	(setf (slot-definition-location eslotd) 
-	      (position (slot-definition-name eslotd) nlayout))))
-    (dolist (eslotd class-slots)
-      (setf (slot-definition-location eslotd) 
-	    (assoc (slot-definition-name eslotd)
-		   (class-slot-cells (slot-definition-class eslotd)))))
-    (mapc #'initialize-internal-slot-functions eslotds)
-    eslotds))
+	(location -1))
+    (dolist (eslotd eslotds eslotds)
+      (setf (slot-definition-location eslotd)
+	    (ecase (slot-definition-allocation eslotd)
+	      (:instance
+	       (incf location))
+	      (:class
+	       (let* ((name (slot-definition-name eslotd))
+		      (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))
+
+(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)
+	(ecase (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)))
+	  (assert (consp (slot-definition-location slotd)))
+	  (initialize-internal-slot-functions slotd)))
+      all-slotds)))
 
 (defmethod compute-slots ((class structure-class))
   (mapcan (lambda (superclass)
@@ -897,6 +925,7 @@
 	 (initform nil)
 	 (initargs nil)
 	 (allocation nil)
+	 (allocation-class nil)
 	 (type t)
 	 (namep  nil)
 	 (initp  nil)
@@ -914,6 +943,7 @@
 		  initp t)))
 	(unless allocp
 	  (setq allocation (slot-definition-allocation slotd)
+		allocation-class (slot-definition-class slotd)
 		allocp t))
 	(setq initargs (append (slot-definition-initargs slotd) initargs))
 	(let ((slotd-type (slot-definition-type slotd)))
@@ -925,6 +955,7 @@
 	  :initfunction initfunction
 	  :initargs initargs
 	  :allocation allocation
+	  :allocation-class allocation-class
 	  :type type
 	  :class class)))
 
-- 
GitLab