X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=tests%2Ftype.before-xc.lisp;fp=tests%2Ftype.before-xc.lisp;h=c08085d876665a194a55432ef199230d37387ed2;hb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;hp=0000000000000000000000000000000000000000;hpb=53e7a02c819090af8e6db7e47d29cdbb5296814f;p=sbcl.git diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp new file mode 100644 index 0000000..c08085d --- /dev/null +++ b/tests/type.before-xc.lisp @@ -0,0 +1,148 @@ +;;;; tests of the type system, intended to be executed as soon as +;;;; the cross-compiler is built + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package "SB!KERNEL") + +(/show "beginning tests/type.before-xc.lisp") + +(assert (type= (specifier-type '(and fixnum (satisfies foo))) + (specifier-type '(and (satisfies foo) fixnum)))) +(assert (type= (specifier-type '(member 1 2 3)) + (specifier-type '(member 2 3 1)))) +(assert (type= (specifier-type '(and (member 1.0 2 3) single-float)) + (specifier-type '(member 1.0)))) + +(assert (sb-xc:typep #(1 2 3) 'simple-vector)) +(assert (sb-xc:typep #(1 2 3) 'vector)) +(assert (not (sb-xc:typep '(1 2 3) 'vector))) +(assert (not (sb-xc:typep 1 'vector))) + +(assert (sb-xc:typep '(1 2 3) 'list)) +(assert (sb-xc:typep '(1 2 3) 'cons)) +(assert (not (sb-xc:typep '(1 2 3) 'null))) +(assert (not (sb-xc:typep "1 2 3" 'list))) +(assert (not (sb-xc:typep 1 'list))) + +(assert (sb-xc:typep nil 'null)) +(assert (sb-xc:typep nil '(member nil))) +(assert (sb-xc:typep nil '(member 1 2 nil 3))) +(assert (not (sb-xc:typep nil '(member 1 2 3)))) + +(assert (type= *empty-type* + (type-intersection (specifier-type 'list) + (specifier-type 'vector)))) +(assert (eql *empty-type* + (type-intersection (specifier-type 'list) + (specifier-type 'vector)))) +(assert (type= (specifier-type 'null) + (type-intersection (specifier-type 'list) + (specifier-type '(or vector null))))) +(assert (type= (specifier-type 'null) + (type-intersection (specifier-type 'sequence) + (specifier-type 'symbol)))) +(assert (type= (specifier-type 'cons) + (type-intersection (specifier-type 'sequence) + (specifier-type '(or cons number))))) +(assert (eql *empty-type* + (type-intersection (specifier-type '(satisfies keywordp)) + *empty-type*))) + +;;; Identities should be identities. +(dolist (type-specifier '(nil + t + null + (satisfies keywordp) + (satisfies foo) + (not fixnum) + (not null) + (and symbol (satisfies foo)) + (and (satisfies foo) string) + (or symbol sequence) + (or single-float character) + (or float (satisfies bar)) + integer (integer 0 1) + character standard-char + (member 1 2 3))) + (/show type-specifier) + (let ((ctype (specifier-type type-specifier))) + + (assert (eql *empty-type* (type-intersection ctype *empty-type*))) + (assert (eql *empty-type* (type-intersection *empty-type* ctype))) + (assert (eql *empty-type* (type-intersection2 ctype *empty-type*))) + (assert (eql *empty-type* (type-intersection2 *empty-type* ctype))) + + (assert (type= ctype (type-intersection ctype *universal-type*))) + (assert (type= ctype (type-intersection *universal-type* ctype))) + (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 (csubtypep *empty-type* ctype)) + (assert (csubtypep ctype *universal-type*)))) +(/show "done with identities-should-be-identities block") + +(assert (sb-xc:subtypep 'simple-vector 'vector)) +(assert (sb-xc:subtypep 'simple-vector 'simple-array)) +(assert (sb-xc:subtypep 'vector 'array)) +(assert (not (sb-xc:subtypep 'vector 'simple-vector))) +(assert (not (sb-xc:subtypep 'vector 'simple-array))) + +(macrolet ((assert-secondnil (expr) `(assert (null (nth-value 1 ,expr))))) + (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)) + |#) + +;;; various dead bugs +(assert (union-type-p (type-intersection (specifier-type 'list) + (specifier-type '(or list vector))))) +(assert (type= (type-intersection (specifier-type 'list) + (specifier-type '(or list vector))) + (specifier-type 'list))) +(assert (array-type-p (type-intersection (specifier-type 'vector) + (specifier-type '(or list vector))))) +(assert (type= (type-intersection (specifier-type 'vector) + (specifier-type '(or list vector))) + (specifier-type 'vector))) +(assert (type= (type-intersection (specifier-type 'number) + (specifier-type 'integer)) + (specifier-type 'integer))) +(assert (null (type-intersection2 (specifier-type 'symbol) + (specifier-type '(satisfies foo))))) +(assert (intersection-type-p (specifier-type '(and symbol (satisfies foo))))) + +(/show "done with tests/type.before-xc.lisp")