X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmop.impure.lisp;h=0382ddb5e2e5c0e010781a9378a01b3588a29da4;hb=964e644f3f1ec2c169b1def87f11e2f5b09a748e;hp=f14f7f1c00010b7a2d5836a870c6c52b7b43ddab;hpb=76874d05d623e0001cfcf23d2c74f78295ba6cee;p=sbcl.git

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)