From: Christophe Rhodes Date: Thu, 14 Nov 2002 11:31:52 +0000 (+0000) Subject: 0.7.9.48: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3ecee4526a55b3b4e6d7f86d69dc411f074968ec;p=sbcl.git 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 --- 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 --- 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 --- 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 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -428,6 +428,13 @@ (assert (null result)) (assert (typep error 'error))) +;;; 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) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index e038b6c..6735c81 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -87,5 +87,13 @@ (make-instance 'finalization-test-2) (assert (= (get-count) 3)) +;;; 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)) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index e24e8ee..4c28256 100644 --- 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"