X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.before-xc.lisp;h=7bc61c5df067bfe1b2ad06d0d7e9305f7b6a6ccd;hb=50f728671defadb8f7b1e8691c984cb0e6aba17c;hp=c08085d876665a194a55432ef199230d37387ed2;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp index c08085d..7bc61c5 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)) @@ -127,6 +137,34 @@ 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) (specifier-type '(or list vector))))) @@ -144,5 +182,34 @@ (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)))))) (/show "done with tests/type.before-xc.lisp")