X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=91a1f696a2d1ccd184231bbd1a6d7b3be41c52b7;hb=6b8604ad86a30578a776d706d01b2f3ab3fac8f2;hp=aedea6b3c5139a9b223b4dd1fe0f8ab4ddb7ff96;hpb=2dbee6e782b54f8780933790d61a24cdb67b8d04;p=sbcl.git

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index aedea6b..91a1f69 100644
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -697,4 +697,67 @@
                      ftype )
              (error "FAILURE")))))))
 
+(with-test (:name (:bug-309128 1))
+  (let* ((s (gensym))
+         (t1 (sb-kernel:specifier-type s)))
+    (eval `(defstruct ,s))
+    (multiple-value-bind (ok sure)
+        (sb-kernel:csubtypep t1 (sb-kernel:specifier-type s))
+      (assert (and ok sure)))))
+
+(with-test (:name (:bug-309128 2))
+  (let* ((s (gensym))
+         (t1 (sb-kernel:specifier-type s)))
+    (eval `(defstruct ,s))
+    (multiple-value-bind (ok sure)
+        (sb-kernel:csubtypep (sb-kernel:specifier-type s) t1)
+      (assert (and ok sure)))))
+
+(with-test (:name (:bug-309128 3))
+  (let* ((s (gensym))
+         (t1 (sb-kernel:specifier-type s))
+         (s2 (gensym))
+         (t2 (sb-kernel:specifier-type s2)))
+    (eval `(deftype ,s2 () ',s))
+    (eval `(defstruct ,s))
+    (multiple-value-bind (ok sure) (sb-kernel:csubtypep t1 t2)
+      (assert (and ok sure)))))
+
+(with-test (:name :unknown-type-not=-for-sure)
+  (let* ((type (gensym "FOO"))
+         (spec1 (sb-kernel:specifier-type `(vector ,type)))
+         (spec2 (sb-kernel:specifier-type `(vector single-float))))
+    (eval `(deftype ,type () 'double-float))
+    (multiple-value-bind (ok sure) (sb-kernel:type= spec1 spec2)
+      (assert (not ok))
+      (assert sure))))
+
+(defclass subtypep-fwd-test1 (subtypep-fwd-test-unknown1) ())
+(defclass subtypep-fwd-test2 (subtypep-fwd-test-unknown2) ())
+(defclass subtypep-fwd-testb1 (subtypep-fwd-testb-unknown1) ())
+(defclass subtypep-fwd-testb2 (subtypep-fwd-testb-unknown2 subtypep-fwd-testb1) ())
+(with-test (:name (:subtypep :forward-referenced-classes))
+  (flet ((test (c1 c2 b1 b2)
+           (multiple-value-bind (x1 x2) (subtypep c1 c2)
+             (unless (and (eq b1 x1) (eq b2 x2))
+               (error "(subtypep ~S ~S) => ~S, ~S but wanted ~S, ~S"
+                      c1 c2 x1 x2 b1 b2)))))
+    (test 'subtypep-fwd-test1 'subtypep-fwd-test1 t t)
+    (test 'subtypep-fwd-test2 'subtypep-fwd-test2 t t)
+    (test 'subtypep-fwd-test1 'subtypep-fwd-test2 nil nil)
+    (test 'subtypep-fwd-test2 'subtypep-fwd-test1 nil nil)
+
+    (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown1 t t)
+    (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown2 t t)
+    (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown2 nil nil)
+    (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown1 nil nil)
+
+    (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown2 t t)
+    (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown1 t t)
+    (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown2 nil nil)
+    (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown1 nil nil)
+
+    (test 'subtypep-fwd-testb1 'subtypep-fwd-testb2 nil nil)
+    (test 'subtypep-fwd-testb2 'subtypep-fwd-testb1 t t)))
+
 ;;; success