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

diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index f14f7f1..ddc2e9b 100644
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -182,5 +182,193 @@
   (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))))
+
+;;;; the CTOR optimization was insufficiently careful about its
+;;;; assumptions: firstly, it failed with a failed AVER for
+;;;; non-standard-allocation slots:
+(defclass class-with-frob-slot ()
+  ((frob-slot :initarg :frob-slot :allocation :frob)))
+(handler-case
+    (funcall (compile nil '(lambda ()
+			    (make-instance 'class-with-frob-slot
+			     :frob-slot 1))))
+  (sb-int:bug (c) (error c))
+  (error () "Probably OK: haven't implemented SLOT-BOUNDP-USING-CLASS"))
+;;; secondly, it failed to take account of the fact that we might wish
+;;; to customize (setf slot-value-using-class)
+(defclass class-with-special-ssvuc ()
+  ((some-slot :initarg :some-slot)))
+(defvar *special-ssvuc-counter* 0)
+(defmethod (setf slot-value-using-class) :before
+    (new-value class (instance class-with-special-ssvuc) slotd)
+  (incf *special-ssvuc-counter*))
+(let ((fun (compile nil '(lambda () (make-instance 'class-with-special-ssvuc
+				     :some-slot 1)))))
+  (assert (= *special-ssvuc-counter* 0))
+  (funcall fun)
+  (assert (= *special-ssvuc-counter* 1))
+  (funcall fun)
+  (assert (= *special-ssvuc-counter* 2)))
+;;; and now with the customization after running the function once
+(defclass class-with-special-ssvuc-2 ()
+  ((some-slot :initarg :some-slot)))
+(defvar *special-ssvuc-counter-2* 0)
+(let ((fun (compile nil '(lambda () (make-instance 'class-with-special-ssvuc-2
+				     :some-slot 1)))))
+  (assert (= *special-ssvuc-counter-2* 0))
+  (funcall fun)
+  (assert (= *special-ssvuc-counter-2* 0))
+  (defmethod (setf slot-value-using-class) :before
+      (new-value class (instance class-with-special-ssvuc-2) slotd)
+    (incf *special-ssvuc-counter-2*))
+  (funcall fun)
+  (assert (= *special-ssvuc-counter-2* 1)))
+
+;;; vicious metacycle detection and resolution wasn't good enough: it
+;;; didn't take account that the slots (and hence the slot readers)
+;;; might be inherited from superclasses.  This example, due to Bruno
+;;; Haible, also tests programmatic addition of accessors.
+(defclass auto-accessors-direct-slot-definition-class (standard-class)
+  ((containing-class-name :initarg :containing-class-name)))
+(defmethod validate-superclass
+    ((c1 auto-accessors-direct-slot-definition-class) (c2 standard-class))
+  t)
+(defclass auto-accessors-class (standard-class)
+  ())
+(defmethod direct-slot-definition-class ((class auto-accessors-class)
+					 &rest initargs)
+  (let ((dsd-class-name (gensym)))
+    (sb-pcl:ensure-class
+     dsd-class-name
+     :metaclass 'auto-accessors-direct-slot-definition-class
+     :direct-superclasses (list (find-class 'standard-direct-slot-definition))
+     :containing-class-name (class-name class))
+    (eval `(defmethod initialize-instance :after ((dsd ,dsd-class-name)
+						  &rest args)
+	    (when (and (null (slot-definition-readers dsd))
+		       (null (slot-definition-writers dsd)))
+	      (let* ((containing-class-name
+		      (slot-value (class-of dsd) 'containing-class-name))
+		     (accessor-name
+		      (intern
+		       (concatenate 'string
+				    (symbol-name containing-class-name)
+				    "-"
+				    (symbol-name (slot-definition-name dsd)))
+		       (symbol-package containing-class-name))))
+		(setf (slot-definition-readers dsd) (list accessor-name))
+		(setf (slot-definition-writers dsd)
+		      (list (list 'setf accessor-name)))))))
+    (find-class dsd-class-name)))
+(defmethod validate-superclass ((c1 auto-accessors-class) (c2 standard-class))
+  t)
+(defclass testclass15 ()
+  ((x :initarg :x) (y))
+  (:metaclass auto-accessors-class))
+(let ((inst (make-instance 'testclass15 :x 12)))
+  (assert (equal (list (testclass15-x inst) (setf (testclass15-y inst) 13))
+		 '(12 13))))
+
+;;; bug reported by Bruno Haible on sbcl-devel 2004-11-17: incorrect
+;;; handling of multiple values for non-standard slot-options
+(progn
+  (defclass option-slot-definition (sb-mop:standard-direct-slot-definition)
+    ((option :accessor sl-option :initarg :my-option)))
+  (defclass option-slot-class (standard-class)
+    ())
+  (defmethod sb-mop:direct-slot-definition-class 
+      ((c option-slot-class) &rest args)
+    (declare (ignore args))
+    (find-class 'option-slot-definition))
+  (defmethod sb-mop:validate-superclass 
+      ((c1 option-slot-class) (c2 standard-class))
+    t)
+  (eval '(defclass test-multiple-slot-option-bug ()
+          ((x :my-option bar :my-option baz))
+          (:metaclass option-slot-class)))
+  (assert (null (set-difference 
+                 '(bar baz)
+                 (sl-option (first (sb-mop:class-direct-slots 
+                                    (find-class 'test-multiple-slot-option-bug))))))))
+
+;;; bug reported by Bruno Haibel on sbcl-devel 2004-11-19: AMOP requires
+;;; that CLASS-PROTOYPE signals an error if the class is not yet finalized
+(defclass prototype-not-finalized-sub (prototype-not-finalized-super) ())
+(multiple-value-bind (val err)
+    (ignore-errors (sb-mop:class-prototype (find-class 'prototype-not-finalized-super)))
+  (assert (null val))
+  (assert (typep err 'error)))
+
+;;; AMOP says so
+(find-method (fdefinition 'sb-mop:allocate-instance) () '(built-in-class))
+(dolist (class-name '(fixnum bignum symbol))
+  (let ((class (find-class class-name)))
+    (multiple-value-bind (value error) (ignore-errors (allocate-instance class))
+      (assert (null value))
+      (assert (typep error 'error)))))
+
+
 ;;;; success
 (sb-ext:quit :unix-status 104)