diff --git a/pcl/defs.lisp b/pcl/defs.lisp
index 0f7ea9169ace4397d937be783fc52b7ad3f7dc58..97a3d8dd5b585cff2bbb2e1aa4631128796ccdb3 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 3021b1a820ceecd7a32fc4e7cbe8ec0a8f7d8e61..ca7d167df7a3b4133221bdce240eda70ab97bb53 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 8422f661b748010850cf8222937aba812ff17078..7750a96baa6d424180ca088216a7ce68ba42cbfb 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)))