X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmop.impure.lisp;h=d6824505cd1707ced1933c0cdcc971ed98ebfdcb;hb=b9a60d8c091096ce7f90073de9b3d26ec7433387;hp=d5116f999bca40a8a6d59e87d26a0acebbce8449;hpb=310d5f86d736ecf9525711b087b04797c549879c;p=sbcl.git

diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index d5116f9..d682450 100644
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -170,5 +170,121 @@
 (assert (= (substandard-defgeneric 1 2) 3))
 (assert (string= (substandard-defgeneric "1" "2") "12"))
 
+(let* ((x (find-class 'pathname))
+       (xs (class-direct-subclasses x)))
+  (assert (>= (length xs) 1))
+  (assert (member (find-class 'logical-pathname) xs)))
+
+;;; BUG 338: "MOP specializers as type specifiers"
+;;;  (reported by Bruno Haible sbcl-devel 2004-06-11)
+(let* ((m (defmethod eql-specialized-method ((x (eql 4.0))) 3.0))
+       (spec (first (sb-mop:method-specializers m))))
+  (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)))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)