X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdefstruct.impure.lisp;h=7e5fad911510fedbba1f5103e68f6a1b0e0925a7;hb=81e608991b9f616a412564b26186fa29933d814c;hp=abd655ea79eef01f3eaede5ddb425879b4227af2;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index abd655e..7e5fad9 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -19,7 +19,10 @@
 ;;; somewhat bogus, but the requirement is clear.)
 (defstruct person age (name 007 :type string)) ; not an error until 007 used
 (make-person :name "James") ; not an error, 007 not used
+
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 (assert (raises-error? (make-person) type-error))
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 (assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
                        type-error))
 
@@ -43,6 +46,8 @@
   (assert (eql (boa-saux-c s) 5)))
                                         ; these two checks should be
                                         ; kept separated
+
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 (let ((s (make-boa-saux)))
   (locally (declare (optimize (safety 0))
                     (inline boa-saux-a))
@@ -216,6 +221,8 @@
 ;;; debugger is having a bad day
 (defvar *instance*)
 
+(declaim (optimize (debug 2)))
+
 (defmacro test-variant (defstructname &key colontype boa-constructor-p)
   `(progn
 
@@ -575,7 +582,9 @@
 (assert (not (vector-struct-p nil)))
 (assert (not (vector-struct-p #())))
 
+
 ;;; bug 3d: type safety with redefined type constraints on slots
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
 (macrolet
     ((test (type)
        (let* ((base-name (intern (format nil "bug3d-~A" type)))
@@ -644,8 +653,8 @@
 (catch :ok
   (handler-bind ((error (lambda (c)
                           ;; Used to cause stack-exhaustion
-                          (unless (typep c 'storege-condition)
-                            (throw :ok)))))
+                          (unless (typep c 'storage-condition)
+                            (throw :ok t)))))
     (eval '(progn
             (defstruct foo a)
             (setf (find-class 'foo) nil)
@@ -662,6 +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~%")
-(quit :unix-status 104)