X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.before-xc.lisp;h=90d8f1df8a9771db63fbd2a22442b571e3af3159;hb=3a2c2a2217f77e0d1a44a581c83e0311ebc2594a;hp=c08085d876665a194a55432ef199230d37387ed2;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp index c08085d..90d8f1d 100644 --- a/tests/type.before-xc.lisp +++ b/tests/type.before-xc.lisp @@ -58,6 +58,23 @@ (type-intersection (specifier-type '(satisfies keywordp)) *empty-type*))) +(assert (type= (specifier-type 'list) + (type-union (specifier-type 'cons) (specifier-type 'null)))) +(assert (type= (specifier-type 'list) + (type-union (specifier-type 'null) (specifier-type 'cons)))) +(assert (type= (specifier-type 'sequence) + (type-union (specifier-type 'list) (specifier-type 'vector)))) +(assert (type= (specifier-type 'sequence) + (type-union (specifier-type 'vector) (specifier-type 'list)))) +(assert (type= (specifier-type 'list) + (type-union (specifier-type 'cons) (specifier-type 'list)))) +(assert (not (csubtypep (type-union (specifier-type 'list) + (specifier-type '(satisfies foo))) + (specifier-type 'list)))) +(assert (csubtypep (specifier-type 'list) + (type-union (specifier-type 'list) + (specifier-type '(satisfies foo))))) + ;;; Identities should be identities. (dolist (type-specifier '(nil t @@ -87,26 +104,19 @@ (assert (type= ctype (type-intersection2 ctype *universal-type*))) (assert (type= ctype (type-intersection2 *universal-type* ctype))) - ;; FIXME: TYPE-UNION still acts CMU-CL-ish as of 0.6.11.13, so - ;; e.g. (TYPE-UNION # *EMPTY-TYPE*) - ;; returns a UNION-TYPE instead of the HAIRY-TYPE. When that's - ;; fixed, these tests should be enabled. - ;;(assert (eql ctype (type-union ctype *empty-type*))) - ;;(assert (eql ctype (type-union *empty-type* ctype))) - - ;; FIXME: TYPE-UNION2 is not defined yet as of 0.6.11.13, and when - ;; it's defined, these tests should be enabled. - ;;(assert (eql *empty-type* (type-union2 ctype *empty-type*))) - ;;(assert (eql *empty-type* (type-union2 *empty-type* ctype))) - - ;;(assert (eql *universal-type* (type-union ctype *universal-type*))) - ;;(assert (eql *universal-type* (type-union *universal-type* ctype))) - ;;(assert (eql ctype (type-union2 ctype *universal-type*))) - ;;(assert (eql ctype (type-union2 *universal-type* ctype))) + (assert (eql *universal-type* (type-union ctype *universal-type*))) + (assert (eql *universal-type* (type-union *universal-type* ctype))) + (assert (eql *universal-type* (type-union2 ctype *universal-type*))) + (assert (eql *universal-type* (type-union2 *universal-type* ctype))) + + (assert (type= ctype (type-union ctype *empty-type*))) + (assert (type= ctype (type-union *empty-type* ctype))) + (assert (type= ctype (type-union2 ctype *empty-type*))) + (assert (type= ctype (type-union2 *empty-type* ctype))) (assert (csubtypep *empty-type* ctype)) (assert (csubtypep ctype *universal-type*)))) -(/show "done with identities-should-be-identities block") +(/show "finished with identities-should-be-identities block") (assert (sb-xc:subtypep 'simple-vector 'vector)) (assert (sb-xc:subtypep 'simple-vector 'simple-array)) @@ -118,14 +128,39 @@ (assert-secondnil (sb-xc:subtypep t '(satisfies foo))) (assert-secondnil (sb-xc:subtypep t '(and (satisfies foo) (satisfies bar)))) (assert-secondnil (sb-xc:subtypep t '(or (satisfies foo) (satisfies bar)))) - ;; FIXME: Enable these tests when bug 84 is fixed. - #| (assert-secondnil (sb-xc:subtypep '(satisfies foo) nil)) (assert-secondnil (sb-xc:subtypep '(and (satisfies foo) (satisfies bar)) nil)) (assert-secondnil (sb-xc:subtypep '(or (satisfies foo) (satisfies bar)) - nil)) - |#) + nil))) + +;;; tests of 2-value quantifieroids FOO/TYPE +(macrolet ((2= (v1 v2 expr2) + (let ((x1 (gensym)) + (x2 (gensym))) + `(multiple-value-bind (,x1 ,x2) ,expr2 + (unless (and (eql ,x1 ,v1) (eql ,x2 ,v2)) + (error "mismatch for EXPR2=~S" ',expr2)))))) + (flet (;; SUBTYPEP running in the cross-compiler + (xsubtypep (x y) + (csubtypep (specifier-type x) + (specifier-type y)))) + (2= t t (any/type #'xsubtypep 'fixnum '(real integer))) + (2= t t (any/type #'xsubtypep 'fixnum '(real cons))) + (2= nil t (any/type #'xsubtypep 'fixnum '(cons vector))) + (2= nil nil (any/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo))) + (2= nil nil (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons))) + (2= t t (any/type #'xsubtypep 'fixnum '(some-unknown-type-foo real))) + (2= t t (any/type #'xsubtypep 'fixnum '(real some-unknown-type-foo))) + (2= nil t (any/type #'xsubtypep 'fixnum '())) + (2= t t (every/type #'xsubtypep 'fixnum '())) + (2= nil nil (every/type #'xsubtypep 'fixnum '(real some-unknown-type-foo))) + (2= nil nil (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo real))) + (2= nil t (every/type #'xsubtypep 'fixnum '(some-unknown-type-foo cons))) + (2= nil t (every/type #'xsubtypep 'fixnum '(cons some-unknown-type-foo))) + (2= t t (every/type #'xsubtypep 'fixnum '(real integer))) + (2= nil t (every/type #'xsubtypep 'fixnum '(real cons))) + (2= nil t (every/type #'xsubtypep 'fixnum '(cons vector))))) ;;; various dead bugs (assert (union-type-p (type-intersection (specifier-type 'list) @@ -144,5 +179,41 @@ (assert (null (type-intersection2 (specifier-type 'symbol) (specifier-type '(satisfies foo))))) (assert (intersection-type-p (specifier-type '(and symbol (satisfies foo))))) +(assert (ctypep :x86 (specifier-type '(satisfies keywordp)))) +(assert (type= (specifier-type '(member :x86)) + (specifier-type '(and (member :x86) (satisfies keywordp))))) +(let* ((type1 (specifier-type '(member :x86))) + (type2 (specifier-type '(or keyword null))) + (isect (type-intersection type1 type2))) + (assert (type= isect type1)) + (assert (type= isect (type-intersection type2 type1))) + (assert (type= isect (type-intersection type2 type1 type2))) + (assert (type= isect (type-intersection type1 type1 type2 type1))) + (assert (type= isect (type-intersection type1 type2 type1 type2)))) +(let* ((type1 (specifier-type 'keyword)) + (type2 (specifier-type '(or keyword null))) + (isect (type-intersection type1 type2))) + (assert (type= isect type1)) + (assert (type= isect (type-intersection type2 type1))) + (assert (type= isect (type-intersection type2 type1 type2))) + (assert (type= isect (type-intersection type1 type1 type2 type1))) + (assert (type= isect (type-intersection type1 type2 type1 type2)))) +(assert (csubtypep (specifier-type '(or (single-float -1.0 1.0) + (single-float 0.1))) + (specifier-type '(or (real -1 7) + (single-float 0.1) + (single-float -1.0 1.0))))) +(assert (not (csubtypep (specifier-type '(or (real -1 7) + (single-float 0.1) + (single-float -1.0 1.0))) + (specifier-type '(or (single-float -1.0 1.0) + (single-float 0.1)))))) + +(assert (sb-xc:typep #\, 'character)) +(assert (sb-xc:typep #\@ 'character)) + +(assert (type= (type-intersection (specifier-type '(member #\a #\c #\e)) + (specifier-type '(member #\b #\c #\f))) + (specifier-type '(member #\c)))) (/show "done with tests/type.before-xc.lisp")