X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=8ab2a975635d705b8b18293d9ab26b858b61d960;hb=fe962ba01d267b92f638c8f0d19be41054219f04;hp=d5edc2e73410ca7aa92134b5a093714b7efbecaa;hpb=23ce012234d40a8d9ad34644d20496d062713352;p=sbcl.git

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index d5edc2e..8ab2a97 100644
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -430,11 +430,11 @@
 ;;; confusing.
 (with-test (:name (:ctor :typep-function))
   (assert (eval '(typep (sb-pcl::ensure-ctor
-                         (list 'sb-pcl::ctor (gensym)) nil nil)
+                         (list 'sb-pcl::ctor (gensym)) nil nil nil)
                         'function))))
 (with-test (:name (:ctor :functionp))
   (assert (functionp (sb-pcl::ensure-ctor
-                      (list 'sb-pcl::ctor (gensym)) nil nil))))
+                      (list 'sb-pcl::ctor (gensym)) nil nil nil))))
 
 ;;; from PFD ansi-tests
 (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons)
@@ -486,5 +486,76 @@
   (assert-t-t (subtypep `(and (member ,misc-629c)
                           sb-kernel:instance)
                         nil)))
+
+;;; 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))
+
+;;; 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)))
+
+;;; 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)))
+
+;;; precise unions of array types (was bug 306a)
+(defun bug-306-a (x)
+  (declare (optimize speed)
+           (type (or (array cons) (array vector)) x))
+  (elt (aref x 0) 0))
+(assert (= 0 (bug-306-a #((0)))))
+
+;;; FUNCALLABLE-INSTANCE is a subtype of function.
+(assert-t-t (subtypep '(and pathname function) nil))
+(assert-t-t (subtypep '(and pathname sb-kernel:funcallable-instance) nil))
+(assert (not (subtypep '(and stream function) nil)))
+(assert (not (subtypep '(and stream sb-kernel:funcallable-instance) nil)))
+(assert (not (subtypep '(and function standard-object) nil)))
+(assert (not (subtypep '(and sb-kernel:funcallable-instance standard-object) nil)))
+
+;;; also, intersections of classes with INSTANCE should not be too
+;;; general
+(assert (not (typep #'print-object '(and standard-object sb-kernel:instance))))
+(assert (not (subtypep 'standard-object '(and standard-object sb-kernel:instance))))
+
+(assert-t-t
+ (subtypep '(or simple-array simple-string) '(or simple-string simple-array)))
+(assert-t-t
+ (subtypep '(or simple-string simple-array) '(or simple-array simple-string)))
+(assert-t-t
+ (subtypep '(or fixnum simple-string end-of-file parse-error fixnum vector)
+           '(or fixnum vector end-of-file parse-error fixnum simple-string)))
+
+#+sb-eval
+(assert-t-t
+ (subtypep '(and function (not compiled-function)
+             (not sb-eval:interpreted-function))
+           nil))
 
 ;;; success