From 964e644f3f1ec2c169b1def87f11e2f5b09a748e Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 2 Jul 2004 08:14:01 +0000 Subject: [PATCH] 0.8.12.16: Fix BUG #334 ... do bookkeeping behind the user's back for effective-slot-defitions generated by the user ... for :class slots, allocate a location and place it in the class' class-slot-cells; ... for :class / :instance slots, set the slot-definition-class slot to the new class; ... add minimal test for reasonable behaviour. --- BUGS | 36 ----------------------- NEWS | 3 ++ src/pcl/generic-functions.lisp | 2 ++ src/pcl/std-class.lisp | 20 +++++++++++-- tests/mop.impure.lisp | 63 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 87 insertions(+), 39 deletions(-) diff --git a/BUGS b/BUGS index 9d23422..c5ccffd 100644 --- a/BUGS +++ b/BUGS @@ -1389,42 +1389,6 @@ WORKAROUND: debugger invoked on a SB-INT:BUG in thread 27726: fasl stack not empty when it should be -334: "COMPUTE-SLOTS used to add slots to classes" - (reported by Bruno Haible sbcl-devel 2004-06-01) - a. Adding a local slot does not work: - (use-package "SB-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))) - yields - There is no applicable method for the generic function - # - when called with arguments - (NIL). - - b. Adding a class slot does not work: - (use-package "SB-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 :class)))) - (defclass a () ((x :allocation :class))) - ;; A should now have two shared slots, X and Y. - (mapcar #'slot-definition-location (class-slots (find-class 'b))) - yields - There is no applicable method for the generic function - # - when called with arguments - (NIL). - 336: "slot-definitions must retain the generic functions of accessors" reported by Tony Martinez: (defclass foo () ((bar :reader foo-bar))) diff --git a/NEWS b/NEWS index f703c4a..b44b189 100644 --- a/NEWS +++ b/NEWS @@ -2572,6 +2572,9 @@ changes in sbcl-0.8.13 relative to sbcl-0.8.12: * fixed bug #340: SETF of VALUES obeys the specification in ANSI 5.1.2.3 for multiple-value place subforms. (reported by Kalle Olavi Niemetalo) + * fixed bug #334: programmatic addition of slots using specialized + methods on SB-MOP:COMPUTE-SLOTS works for :ALLOCATION :INSTANCE + and :ALLOCATION :CLASS slots. * fixed a bug: #\Space (and other whitespace characters) are no longer considered to be macro characters in standard syntax by GET-MACRO-CHARACTER. diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 1b787ca..910e21b 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -317,6 +317,8 @@ (defgeneric add-method (generic-function method)) +(defgeneric (setf class-slot-cells) (new-value class)) + (defgeneric class-slot-value (class slot-name)) (defgeneric compatible-meta-class-change-p (class proto-new-class)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 76edec5..5a86391 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -141,6 +141,8 @@ (defmethod class-slot-cells ((class std-class)) (plist-value class 'class-slot-cells)) +(defmethod (setf class-slot-cells) (new-value (class std-class)) + (setf (plist-value class 'class-slot-cells) new-value)) ;;;; class accessors that are even a little bit more complicated than those ;;;; above. These have a protocol for updating them, we must implement that @@ -1040,8 +1042,20 @@ (incf location)) (:class (let* ((name (slot-definition-name eslotd)) - (from-class (slot-definition-allocation-class eslotd)) - (cell (assq name (class-slot-cells from-class)))) + (from-class + (or + (slot-definition-allocation-class eslotd) + ;; we get here if the user adds an extra slot + ;; himself... + (setf (slot-definition-allocation-class eslotd) + class))) + ;; which raises the question of what we should + ;; do if we find that said user has added a slot + ;; with the same name as another slot... + (cell (or (assq name (class-slot-cells from-class)) + (setf (class-slot-cells from-class) + (cons (cons name +slot-unbound+) + (class-slot-cells from-class)))))) (aver (consp cell)) (if (eq +slot-unbound+ (cdr cell)) ;; We may have inherited an initfunction @@ -1050,6 +1064,8 @@ (rplacd cell (funcall initfun)) cell)) cell))))) + (unless (slot-definition-class eslotd) + (setf (slot-definition-class eslotd) class)) (initialize-internal-slot-functions eslotd)))) (defmethod compute-slots ((class funcallable-standard-class)) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index f14f7f1..0382ddb 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -182,5 +182,68 @@ (assert (not (typep 1 spec))) (assert (typep 4.0 spec))) +;;; BUG #334, relating to programmatic addition of slots to a class +;;; with COMPUTE-SLOTS. +;;; +;;; FIXME: the DUMMY classes here are to prevent class finalization +;;; before the compute-slots method is around. This should probably +;;; be done by defining the COMPUTE-SLOTS methods on a metaclass, +;;; which can be defined before. +;;; +;;; a. adding an :allocation :instance slot +(defclass class-to-add-instance-slot (dummy-ctais) ()) +(defmethod compute-slots ((c (eql (find-class 'class-to-add-instance-slot)))) + (append (call-next-method) + (list (make-instance 'standard-effective-slot-definition + :name 'y + :allocation :instance)))) +(defclass dummy-ctais () ((x :allocation :class))) +(assert (equal (mapcar #'slot-definition-allocation + (class-slots (find-class 'class-to-add-instance-slot))) + ;; FIXME: is the order really guaranteed? + '(:class :instance))) +(assert (typep (slot-definition-location + (cadr (class-slots (find-class 'class-to-add-instance-slot)))) + 'unsigned-byte)) +#| (assert (typep (slot-definition-location (car ...)) '???)) |# +(let ((x (make-instance 'class-to-add-instance-slot))) + (assert (not (slot-boundp x 'x))) + (setf (slot-value x 'x) t) + (assert (not (slot-boundp x 'y))) + (setf (slot-value x 'y) 1) + (assert (= 1 (slot-value x 'y)))) +(let ((x (make-instance 'class-to-add-instance-slot))) + (assert (slot-boundp x 'x)) + (assert (eq t (slot-value x 'x))) + (assert (not (slot-boundp x 'y)))) + +;;; b. adding an :allocation :class slot +(defclass class-to-add-class-slot (dummy-ctacs) ()) +(defmethod compute-slots ((c (eql (find-class 'class-to-add-class-slot)))) + (append (call-next-method) + (list (make-instance 'standard-effective-slot-definition + :name 'y + :allocation :class)))) +(defclass dummy-ctacs () ((x :allocation :class))) +(assert (equal (mapcar #'slot-definition-allocation + (class-slots (find-class 'class-to-add-class-slot))) + '(:class :class))) +(let ((x (make-instance 'class-to-add-class-slot))) + (assert (not (slot-boundp x 'x))) + (setf (slot-value x 'x) nil) + (assert (not (slot-boundp x 'y))) + (setf (slot-value x 'y) 1) + (assert (= 1 (slot-value x 'y)))) +(let ((x (make-instance 'class-to-add-class-slot))) + (assert (slot-boundp x 'x)) + (assert (eq nil (slot-value x 'x))) + (assert (slot-boundp x 'y)) + (assert (= 1 (slot-value x 'y)))) +;; extra paranoia: check that we haven't broken the instance-slot class +(let ((x (make-instance 'class-to-add-instance-slot))) + (assert (slot-boundp x 'x)) + (assert (eq t (slot-value x 'x))) + (assert (not (slot-boundp x 'y)))) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index ad18e79..3fb87a7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.12.15" +"0.8.12.16" -- 1.7.10.4