0.7.9.48:

	Fix COMPUTE-SLOTS :AROUND to do predictable things on
		STANDARD-CLASS
	... put a new slot (ALLOCATION-CLASS) into slotds, to be
		initialized to the relevant class if the allocation of
		the slot is :CLASS
	... use SLOT-ALLOCATION-CLASS where SLOT-ALLOCATION was used in
		the case of a :CLASS allocation
	... divide the COMPUTE-SLOTS :AROUND method into two, and leave
		the FUNCALLABLE-INSTANCE one alone

diff --git a/NEWS b/NEWS
index 01cdabb..8046d33 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1373,6 +1373,9 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9:
        lambda lists are added to generic functions;
     ** COMPUTE-CLASS-PRECEDENCE-LIST now has a method specialized on
        CLASS, as specified in AMOP;
+    ** COMPUTE-SLOTS :AROUND now assigns locations sequentially based
+       on the order returned by the primary method for classes of
+       class STANDARD-CLASS;
   * fixed some bugs shown by Paul Dietz' test suite:
     ** DOLIST puts its body in TAGBODY
     ** SET-EXCLUSIVE-OR sends arguments to :TEST function in the

diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index ebf2eff..fe77969 100644 (file)
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -645,7 +645,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/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index bed8169..a34f739 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -499,10 +499,10 @@
                  (lambda (dependent)
                    (apply #'update-dependent class dependent initargs))))
 
-(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.")))
 
@@ -789,27 +789,6 @@
             collect))
     (nreverse collect)))
 
-(defun compute-layout (cpl instance-eslotds)
-  (let* ((names
-          (let (collect)
-            (dolist (eslotd instance-eslotds)
-              (when (eq (slot-definition-allocation eslotd) :instance)
-                (push (slot-definition-name eslotd) collect)))
-             (nreverse collect)))
-        (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)))
@@ -863,38 +842,83 @@
   ;; The list is in most-specific-first order.
   (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)
-      (let ((alloc (slot-definition-allocation eslotd)))
-       (case alloc
-          (: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)
+       (location -1))
+    (dolist (eslotd eslotds eslotds)
       (setf (slot-definition-location eslotd)
-           (assoc (slot-definition-name eslotd)
-                  (class-slot-cells (slot-definition-class eslotd)))))
-    (mapc #'initialize-internal-slot-functions eslotds)
-    eslotds))
+           (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))))
+                (aver (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)))
+         (aver (consp (slot-definition-location slotd)))
+         (initialize-internal-slot-functions slotd)))
+      all-slotds)))
 
 (defmethod compute-slots ((class structure-class))
   (mapcan (lambda (superclass)
@@ -929,6 +953,7 @@
         (initform nil)
         (initargs nil)
         (allocation nil)
+        (allocation-class nil)
         (type t)
         (namep  nil)
         (initp  nil)
@@ -946,6 +971,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)))
@@ -957,6 +983,7 @@
          :initfunction initfunction
          :initargs initargs
          :allocation allocation
+         :allocation-class allocation-class
          :type type
          :class class)))
 

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 174fe3d..dc33bd5 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -428,6 +428,13 @@
   (assert (null result))
   (assert (typep error 'error)))
 \f
+;;; Classes with :ALLOCATION :CLASS slots should be subclassable (and
+;;; weren't for a while in sbcl-0.7.9.xx)
+(defclass superclass-with-slot ()
+  ((a :allocation :class)))
+(defclass subclass-for-class-allocation (superclass-with-slot) ())
+(make-instance 'subclass-for-class-allocation)
+\f
 ;;;; success
 
 (sb-ext:quit :unix-status 104)

diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index e038b6c..6735c81 100644 (file)
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -87,5 +87,13 @@
 (make-instance 'finalization-test-2)
 (assert (= (get-count) 3))
 \f
+;;; Bits of FUNCALLABLE-STANDARD-CLASS are easy to break; make sure
+;;; that it is at least possible to define classes with that as a
+;;; metaclass.
+(defclass gf-class (standard-generic-function) ()
+  (:metaclass sb-pcl::funcallable-standard-class))
+(defgeneric g (a b c)
+  (:generic-function-class gf-class))
+\f
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index e24e8ee..4c28256 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.47"
+"0.7.9.48"