1.0.21.1: address TYPE-WARNING in CLOS allocator for funcallable structures

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

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index bf0bd45..b5e981f 100644 (file)
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -430,11 +430,17 @@
 ;;; 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))))
+;;; some new (2008-10-03) ways of going wrong...
+(with-test (:name (:ctor-allocate-instance :typep-function))
+  (assert (eval '(typep (allocate-instance (find-class 'sb-pcl::ctor))
+                        'function))))
+(with-test (:name (:ctor-allocate-instance :functionp))
+  (assert (functionp (allocate-instance (find-class 'sb-pcl::ctor)))))
 \f
 ;;; from PFD ansi-tests
 (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons)
@@ -511,7 +517,7 @@
   (assert win))
 
 ;; See FIXME in type method for CONS :SIMPLE-TYPE-=
-#+nil 
+#+nil
 (multiple-value-bind (ok win)
     (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer))
                      (sb-kernel:specifier-type '(cons goldbach1 single-float)))
@@ -523,4 +529,62 @@
                      (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)))))
+\f
+;;; 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))))
+\f
+(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))
+
+;;; weakening of union type checks
+(defun weaken-union-1 (x)
+  (declare (optimize speed))
+  (car x))
+(multiple-value-bind (res err)
+    (ignore-errors (weaken-union-1 "askdjhasdkj"))
+  (assert (not res))
+  (assert (typep err 'type-error)))
+(defun weaken-union-2 (x)
+  (declare (optimize speed)
+           (type (or cons fixnum) x))
+  (etypecase x
+    (fixnum x)
+    (cons
+     (setf (car x) 3)
+     x)))
+(multiple-value-bind (res err)
+    (ignore-errors (weaken-union-2 "asdkahsdkhj"))
+  (assert (not res))
+  (assert (typep err 'type-error))
+  (assert (or (equal '(or cons fixnum) (type-error-expected-type err))
+              (equal '(or fixnum cons) (type-error-expected-type err)))))
+
 ;;; success