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.

diff --git a/BUGS b/BUGS
index 9d23422..c5ccffd 100644 (file)
--- 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
-      #<STANDARD-GENERIC-FUNCTION CLASS-SLOTS (3)>
-    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
-      #<STANDARD-GENERIC-FUNCTION SB-PCL::CLASS-SLOT-CELLS (1)>
-    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 (file)
--- 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 (file)
--- 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 (file)
--- 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))
 \f
 ;;;; 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 (file)
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -182,5 +182,68 @@
   (assert (not (typep 1 spec)))
   (assert (typep 4.0 spec)))
 \f
+;;; 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))))
+\f
 ;;;; success
 (sb-ext:quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index ad18e79..3fb87a7 100644 (file)
--- 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"