1.0.17.32: faster ADD-METHOD to PRINT-OBJECT

[sbcl.git] / tests / clos.impure.lisp

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 47ad924..3dc1d93 100644 (file)
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -913,6 +913,31 @@
 (assert (= (slot-value *yao-super* 'obs) 3))
 (assert (= (slot-value *yao-sub* 'obs) 3))
 
+;;; one more MIO test: variable slot names
+(defclass mio () ((x :initform 42)))
+(defvar *mio-slot* 'x)
+(defparameter *mio-counter* 0)
+(defmethod update-instance-for-redefined-class ((instance mio) new old plist &key)
+  (incf *mio-counter*))
+
+(let ((x (make-instance 'mio)))
+  (make-instances-obsolete 'mio)
+  (slot-value x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+  (make-instances-obsolete 'mio)
+  (setf (slot-value x *mio-slot*) 13))
+
+(let ((x (make-instance 'mio)))
+  (make-instances-obsolete 'mio)
+  (slot-boundp x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+  (make-instances-obsolete 'mio)
+  (slot-makunbound x *mio-slot*))
+
+(assert (= 4 *mio-counter*))
+
 ;;; shared -> local slot transfers of inherited slots, reported by
 ;;; Bruno Haible
 (let (i)
@@ -1319,7 +1344,7 @@
 (defclass class-with-odd-class-name-method ()
   ((a :accessor class-name)))
 \f
-;;; another case where precomputing (this time on PRINT-OBJET) and
+;;; another case where precomputing (this time on PRINT-OBJECT) and
 ;;; lazily-finalized classes caused problems.  (report from James Y
 ;;; Knight sbcl-devel 20-07-2006)
 
@@ -1545,5 +1570,54 @@
 (assert (equal '(:foo 13)
                (apply #'test-long-form-with-&rest :foo (make-list 13))))
 
+;;;; slot-missing for non-standard classes on SLOT-VALUE
+;;;;
+;;;; FIXME: This is arguably not right, actually: CLHS seems to say
+;;;; we should just signal an error at least for built-in classes, but
+;;;; for a while we were hitting NO-APPLICABLE-METHOD, which is definitely
+;;;; wrong -- so test this for now at least.
+
+(defvar *magic-symbol* (gensym "MAGIC"))
+
+(set *magic-symbol* 42)
+
+(defmethod slot-missing (class instance (slot-name (eql *magic-symbol*)) op
+                         &optional new)
+  (if (eq 'setf op)
+      (setf (symbol-value *magic-symbol*)  new)
+      (symbol-value *magic-symbol*)))
+
+(assert (eql 42 (slot-value (cons t t) *magic-symbol*)))
+(assert (eql 13 (setf (slot-value 123 *magic-symbol*) 13)))
+(assert (eql 13 (slot-value 'foobar *magic-symbol*)))
+
+;;;; Built-in structure and condition layouts should have NIL in
+;;;; LAYOUT-FOR-STD-CLASS-P, and classes should have T.
+
+(assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'warning))))
+(assert (not (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'hash-table))))
+(assert (eq t (sb-pcl::layout-for-std-class-p (sb-pcl::find-layout 'standard-object))))
+
+;;;; bug 402: PCL used to warn about non-standard declarations
+(declaim (declaration bug-402-d))
+(defgeneric bug-402-gf (x))
+(with-test (:name :bug-402)
+  (handler-bind ((warning #'error))
+    (eval '(defmethod bug-402-gf (x)
+            (declare (bug-402-d x))
+            x))))
+
+;;;; non-keyword :default-initargs + :before method on shared initialize
+;;;; interacted badly with CTOR optimizations
+(defclass ctor-default-initarg-problem ()
+  ((slot :initarg slotto))
+  (:default-initargs slotto 123))
+(defmethod shared-initialize :before ((instance ctor-default-initarg-problem) slot-names &rest initargs)
+  (format t "~&Rock on: ~A~%" initargs))
+(defun provoke-ctor-default-initarg-problem ()
+  (make-instance 'ctor-default-initarg-problem))
+(handler-bind ((warning #'error))
+  (assert (= 123 (slot-value (provoke-ctor-default-initarg-problem) 'slot))))
+
 \f
 ;;;; success