0.9.15.46: cosmetic cleanups

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

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index be9e55b..f8ab6d2 100644 (file)
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -445,4 +445,82 @@
                  t)))
   (assert (null (values (subtypep `(not ,t2) `(not ,t1))))))
 \f
+(defstruct misc-629a)
+(defclass misc-629b () ())
+(defclass misc-629c () () (:metaclass sb-mop:funcallable-standard-class))
+
+(assert (typep (make-misc-629a) 'sb-kernel:instance))
+(assert-t-t (subtypep `(member ,(make-misc-629a)) 'sb-kernel:instance))
+(assert-nil-t (subtypep `(and (member ,(make-misc-629a)) sb-kernel:instance)
+                        nil))
+(let ((misc-629a (make-misc-629a)))
+  (assert-t-t (subtypep `(member ,misc-629a)
+                        `(and (member ,misc-629a) sb-kernel:instance)))
+  (assert-t-t (subtypep `(and (member ,misc-629a)
+                          sb-kernel:funcallable-instance)
+                        nil)))
+
+(assert (typep (make-instance 'misc-629b) 'sb-kernel:instance))
+(assert-t-t (subtypep `(member ,(make-instance 'misc-629b))
+                      'sb-kernel:instance))
+(assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629b))
+                          sb-kernel:instance)
+                        nil))
+(let ((misc-629b (make-instance 'misc-629b)))
+  (assert-t-t (subtypep `(member ,misc-629b)
+                        `(and (member ,misc-629b) sb-kernel:instance)))
+  (assert-t-t (subtypep `(and (member ,misc-629b)
+                          sb-kernel:funcallable-instance)
+                        nil)))
+
+(assert (typep (make-instance 'misc-629c) 'sb-kernel:funcallable-instance))
+(assert-t-t (subtypep `(member ,(make-instance 'misc-629c))
+                      'sb-kernel:funcallable-instance))
+(assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629c))
+                          sb-kernel:funcallable-instance)
+                        nil))
+(let ((misc-629c (make-instance 'misc-629c)))
+  (assert-t-t (subtypep `(member ,misc-629c)
+                        `(and (member ,misc-629c)
+                          sb-kernel:funcallable-instance)))
+  (assert-t-t (subtypep `(and (member ,misc-629c)
+                          sb-kernel:instance)
+                        nil)))
+\f
+;;; this was broken during the FINALIZE-INHERITANCE rearrangement; the
+;;; MAKE-INSTANCE finalizes the superclass, thus invalidating the
+;;; subclass, so SUBTYPEP must be prepared to deal with
+(defclass ansi-tests-defclass1 () ())
+(defclass ansi-tests-defclass3 (ansi-tests-defclass1) ())
+(make-instance 'ansi-tests-defclass1)
+(assert-t-t (subtypep 'ansi-tests-defclass3 'standard-object))
+\f
+;;; so was this
+(let ((class (eval '(defclass to-be-type-ofed () ()))))
+  (setf (find-class 'to-be-type-ofed) nil)
+  (assert (eq (type-of (make-instance class)) class)))
+\f
+;;; accuracy of CONS :SIMPLE-TYPE-=
+(deftype goldbach-1 () '(satisfies even-and-greater-then-two-p))
+(deftype goldbach-2 () ' (satisfies sum-of-two-primes-p))
+
+(multiple-value-bind (ok win)
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
+                     (sb-kernel:specifier-type '(cons goldbach1 integer)))
+  (assert ok)
+  (assert win))
+
+;; See FIXME in type method for CONS :SIMPLE-TYPE-=
+#+nil
+(multiple-value-bind (ok win)
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
+                     (sb-kernel:specifier-type '(cons goldbach1 single-float)))
+  (assert (not ok))
+  (assert win))
+
+(multiple-value-bind (ok win)
+    (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
+                     (sb-kernel:specifier-type '(cons goldbach2 single-float)))
+  (assert (not ok))
+  (assert (not win)))
 ;;; success