X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.before-xc.lisp;h=1b1f0e2c5f30ca0bfb4b6e9d48d226c26162de9b;hb=a189a69454ef7635149319ae213b337f17c50d20;hp=7bc61c5df067bfe1b2ad06d0d7e9305f7b6a6ccd;hpb=5470bfd1ed062203f4ab009f6ec19e81f8f32066;p=sbcl.git diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp index 7bc61c5..1b1f0e2 100644 --- a/tests/type.before-xc.lisp +++ b/tests/type.before-xc.lisp @@ -1,4 +1,4 @@ -;;;; tests of the type system, intended to be executed as soon as +;;;; 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 @@ -7,7 +7,7 @@ ;;;; 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. @@ -17,11 +17,11 @@ (/show "beginning tests/type.before-xc.lisp") (assert (type= (specifier-type '(and fixnum (satisfies foo))) - (specifier-type '(and (satisfies foo) fixnum)))) + (specifier-type '(and (satisfies foo) fixnum)))) (assert (type= (specifier-type '(member 1 2 3)) - (specifier-type '(member 2 3 1)))) + (specifier-type '(member 2 3 1)))) (assert (type= (specifier-type '(and (member 1.0 2 3) single-float)) - (specifier-type '(member 1.0)))) + (specifier-type '(member 1.0)))) (assert (sb-xc:typep #(1 2 3) 'simple-vector)) (assert (sb-xc:typep #(1 2 3) 'vector)) @@ -40,57 +40,65 @@ (assert (not (sb-xc:typep nil '(member 1 2 3)))) (assert (type= *empty-type* - (type-intersection (specifier-type 'list) - (specifier-type 'vector)))) + (type-intersection (specifier-type 'list) + (specifier-type 'vector)))) (assert (eql *empty-type* - (type-intersection (specifier-type 'list) - (specifier-type 'vector)))) + (type-intersection (specifier-type 'list) + (specifier-type 'vector)))) (assert (type= (specifier-type 'null) - (type-intersection (specifier-type 'list) - (specifier-type '(or vector null))))) + (type-intersection (specifier-type 'list) + (specifier-type '(or vector null))))) (assert (type= (specifier-type 'null) - (type-intersection (specifier-type 'sequence) - (specifier-type 'symbol)))) + (type-intersection (specifier-type 'sequence) + (specifier-type 'symbol)))) (assert (type= (specifier-type 'cons) - (type-intersection (specifier-type 'sequence) - (specifier-type '(or cons number))))) + (type-intersection (specifier-type 'sequence) + (specifier-type '(or cons number))))) +(assert (type= (specifier-type '(simple-array character (*))) + (type-intersection (specifier-type 'sequence) + (specifier-type '(simple-array character))))) +(assert (type= (specifier-type 'list) + (type-intersection (specifier-type 'sequence) + (specifier-type 'list)))) (assert (eql *empty-type* - (type-intersection (specifier-type '(satisfies keywordp)) - *empty-type*))) + (type-intersection (specifier-type '(satisfies keywordp)) + *empty-type*))) (assert (type= (specifier-type 'list) - (type-union (specifier-type 'cons) (specifier-type 'null)))) + (type-union (specifier-type 'cons) (specifier-type 'null)))) (assert (type= (specifier-type 'list) - (type-union (specifier-type 'null) (specifier-type 'cons)))) + (type-union (specifier-type 'null) (specifier-type 'cons)))) +#+nil ; not any more (assert (type= (specifier-type 'sequence) - (type-union (specifier-type 'list) (specifier-type 'vector)))) + (type-union (specifier-type 'list) (specifier-type 'vector)))) +#+nil ; not any more (assert (type= (specifier-type 'sequence) - (type-union (specifier-type 'vector) (specifier-type 'list)))) + (type-union (specifier-type 'vector) (specifier-type 'list)))) (assert (type= (specifier-type 'list) - (type-union (specifier-type 'cons) (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)))) + (specifier-type '(satisfies foo))) + (specifier-type 'list)))) (assert (csubtypep (specifier-type 'list) - (type-union (specifier-type 'list) - (specifier-type '(satisfies foo))))) + (type-union (specifier-type 'list) + (specifier-type '(satisfies foo))))) ;;; 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))) + 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))) @@ -103,7 +111,7 @@ (assert (type= ctype (type-intersection *universal-type* ctype))) (assert (type= ctype (type-intersection2 ctype *universal-type*))) (assert (type= ctype (type-intersection2 *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*))) @@ -128,26 +136,23 @@ (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)) + 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)))))) + (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)))) + (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))) @@ -167,24 +172,24 @@ ;;; various dead bugs (assert (union-type-p (type-intersection (specifier-type 'list) - (specifier-type '(or list vector))))) + (specifier-type '(or list vector))))) (assert (type= (type-intersection (specifier-type 'list) - (specifier-type '(or list vector))) - (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))))) + (specifier-type '(or list vector))))) (assert (type= (type-intersection (specifier-type 'vector) - (specifier-type '(or list vector))) - (specifier-type 'vector))) + (specifier-type '(or list vector))) + (specifier-type 'vector))) (assert (type= (type-intersection (specifier-type 'number) - (specifier-type 'integer)) - (specifier-type 'integer))) + (specifier-type 'integer)) + (specifier-type 'integer))) (assert (null (type-intersection2 (specifier-type 'symbol) - (specifier-type '(satisfies foo))))) + (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))))) + (specifier-type '(and (member :x86) (satisfies keywordp))))) (let* ((type1 (specifier-type '(member :x86))) (type2 (specifier-type '(or keyword null))) (isect (type-intersection type1 type2))) @@ -202,14 +207,137 @@ (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))))) + (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)))))) + (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)))) + +(multiple-value-bind (yes win) + (sb-xc:subtypep 'package 'instance) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'symbol 'instance) + (assert (not yes)) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'package 'funcallable-instance) + (assert (not yes)) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'symbol 'funcallable-instance) + (assert (not yes)) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'funcallable-instance 'function) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'array 'instance) + (assert (not yes)) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'character 'instance) + (assert (not yes)) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'number 'instance) + (assert (not yes)) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'package '(and (or symbol package) instance)) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and (or double-float integer) instance) 'nil) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and (or double-float integer) funcallable-instance) 'nil) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'instance 'type-specifier) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'type-specifier 'instance) + (assert (not yes)) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and (function (t)) funcallable-instance) 'nil) + (assert (not yes))) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and fixnum function) 'nil) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and fixnum hash-table) 'nil) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(function) '(function (t &rest t))) + (assert (not yes)) + (assert win)) +;; Used to run out of stack. +(multiple-value-bind (yes win) + (sb-xc:subtypep 'null '(or unk0 unk1)) + (assert (not yes)) + (assert (not win))) + +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and function instance) nil) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep nil '(and function instance)) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and function funcallable-instance) 'funcallable-instance) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'funcallable-instance '(and function funcallable-instance)) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'stream 'instance) + (assert (not yes))) +(multiple-value-bind (yes win) + (sb-xc:subtypep 'stream 'funcallable-instance) + (assert (not yes)) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and stream instance) 'instance) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and stream funcallable-instance) 'funcallable-instance) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and stream instance) 'stream) + (assert yes) + (assert win)) +(multiple-value-bind (yes win) + (sb-xc:subtypep '(and stream funcallable-instance) 'stream) + (assert yes) + (assert win)) + +(assert (type= (specifier-type 'nil) + (specifier-type '(and symbol funcallable-instance)))) (/show "done with tests/type.before-xc.lisp")