1.0.17.32: faster ADD-METHOD to PRINT-OBJECT

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

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 83475d0..3549268 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -671,5 +671,69 @@
                            (aref (vector x) (incf i)))
                   (bug-348-x x))))
 
-;;; success
-(format t "~&/returning success~%")
+;;; 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))))))
+
+;; EQUALP didn't work for structures with float slots (reported by
+;; Vjacheslav Fyodorov).
+(defstruct raw-slot-equalp-bug
+  (b 0s0 :type single-float)
+  c
+  (a 0d0 :type double-float))
+
+(with-test (:name raw-slot-equalp)
+  (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
+                  (make-raw-slot-equalp-bug :a 1d0 :b 2s0)))
+  (assert (equalp (make-raw-slot-equalp-bug :a 1d0 :b 0s0)
+                  (make-raw-slot-equalp-bug :a 1d0 :b -0s0)))
+  (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
+                       (make-raw-slot-equalp-bug :a 1d0 :b 3s0))))
+  (assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
+                       (make-raw-slot-equalp-bug :a 2d0 :b 2s0)))))
+
+;;; Check that all slot types (non-raw and raw) can be initialized with
+;;; constant arguments.
+(defstruct constant-arg-inits
+  (a 42 :type t)
+  (b 1 :type fixnum)
+  (c 2 :type sb-vm:word)
+  (d 3.0 :type single-float)
+  (e 4.0d0 :type double-float)
+  (f #c(5.0 5.0) :type (complex single-float))
+  (g #c(6.0d0 6.0d0) :type (complex double-float)))
+(defun test-constant-arg-inits ()
+  (let ((foo (make-constant-arg-inits)))
+    (declare (dynamic-extent foo))
+    (assert (eql 42 (constant-arg-inits-a foo)))
+    (assert (eql 1 (constant-arg-inits-b foo)))
+    (assert (eql 2 (constant-arg-inits-c foo)))
+    (assert (eql 3.0 (constant-arg-inits-d foo)))
+    (assert (eql 4.0d0 (constant-arg-inits-e foo)))
+    (assert (eql #c(5.0 5.0) (constant-arg-inits-f foo)))
+    (assert (eql #c(6.0d0 6.0d0) (constant-arg-inits-g foo)))))
+(make-constant-arg-inits)