Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv17852/tests
Modified Files:
defstruct.impure.lisp
Log Message:
1.0.7.7: slightly less broken handling of obsolete structures
* Trap them correctly in PCL.
* Correct package so that CLASSOID-TYPEP signals the correct error
instead of running into an undefined function.
* Tests.
Index: defstruct.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/defstruct.impure.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- defstruct.impure.lisp 13 Sep 2006 15:59:33 -0000 1.29
+++ defstruct.impure.lisp 1 Jul 2007 16:35:06 -0000 1.30
@@ -671,5 +671,33 @@
(aref (vector x) (incf i)))
(bug-348-x x))))
+;;; obsolete instance trapping
+;;;
+;;; FIXME: Both error conditions below should possibly be instances
+;;; of the same class. (Putting this FIXME here, since this is the only
+;;; place where they appear together.)
+
+(with-test (:name obsolete-defstruct/print-object)
+ (eval '(defstruct born-to-change))
+ (let ((x (make-born-to-change)))
+ (handler-bind ((error 'continue))
+ (eval '(defstruct born-to-change slot)))
+ (assert (eq :error
+ (handler-case
+ (princ-to-string x)
+ (sb-pcl::obsolete-structure ()
+ :error))))))
+
+(with-test (:name obsolete-defstruct/typep)
+ (eval '(defstruct born-to-change-2))
+ (let ((x (make-born-to-change-2)))
+ (handler-bind ((error 'continue))
+ (eval '(defstruct born-to-change-2 slot)))
+ (assert (eq :error2
+ (handler-case
+ (typep x (find-class 'standard-class))
+ (sb-kernel:layout-invalid ()
+ :error2))))))
+
;;; success
(format t "~&/returning success~%")
|