X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=b5e981f76f7a4881c8e5927bec43940c2a380b3f;hb=c589b9363d23ec9133e5396adaf4240cb0a8bd18;hp=b2ac327a957282f2dbe57a31dabc8d3ed9ccb1f6;hpb=34664ac9b1d27f0dff2514c388cf10813a9b1108;p=sbcl.git diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index b2ac327..b5e981f 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -354,7 +354,6 @@ (mapcar #'find-class '(simple-condition condition sb-pcl::slot-object - sb-kernel:instance t)))) ;; stream classes @@ -372,18 +371,15 @@ 'fundamental-stream)) (mapcar #'find-class '(fundamental-stream standard-object - sb-pcl::std-object sb-pcl::slot-object stream - sb-kernel:instance t)))) (assert (equal (sb-pcl:class-precedence-list (find-class 'fundamental-stream)) (mapcar #'find-class '(fundamental-stream standard-object - sb-pcl::std-object sb-pcl::slot-object stream - sb-kernel:instance t)))) + t)))) (assert (subtypep (find-class 'stream) (find-class t))) (assert (subtypep (find-class 'fundamental-stream) 'stream)) (assert (not (subtypep 'stream 'fundamental-stream))))) @@ -434,10 +430,161 @@ ;;; 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))))) + +;;; from PFD ansi-tests +(let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) + (integer -234496 215373)) + integer)) + (t2 '(cons (cons (cons integer integer) + (integer -234496 215373)) + t))) + (assert (null (values (subtypep `(not ,t2) `(not ,t1)))))) + +(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))) + +;;; 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)) + +;;; 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