X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=71706194aa516fcfeb39d8eeabcee7dcb02e5d0a;hb=bfa4310e41dcd011ca9d139f29be1c5757b41378;hp=2b89eebca35ed6123dca5ee94a0ba053de753b0c;hpb=3a8bfcb01abe4d8eeb9ef1343d623dbbf57c19d9;p=sbcl.git diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 2b89eeb..7170619 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -102,10 +102,24 @@ (assert-nil-nil (subtypep '(vector t) '(vector utype-2))) ;;; ANSI specifically disallows bare AND and OR symbols as type specs. -#| ; Alas, this is part of bug 10, still unfixed as of sbcl-0.7.2. (assert (raises-error? (typep 11 'and))) (assert (raises-error? (typep 11 'or))) -|# +(assert (raises-error? (typep 11 'member))) +(assert (raises-error? (typep 11 'values))) +(assert (raises-error? (typep 11 'eql))) +(assert (raises-error? (typep 11 'satisfies))) +(assert (raises-error? (typep 11 'not))) +;;; and while it doesn't specifically disallow illegal compound +;;; specifiers from the CL package, we don't have any. +(assert (raises-error? (subtypep 'fixnum '(fixnum 1)))) +(assert (raises-error? (subtypep 'class '(list)))) +(assert (raises-error? (subtypep 'foo '(ratio 1/2 3/2)))) +(assert (raises-error? (subtypep 'character '(character 10)))) +#+nil ; doesn't yet work on PCL-derived internal types +(assert (raises-error? (subtypep 'lisp '(class)))) +#+nil +(assert (raises-error? (subtypep 'bar '(method number number)))) + ;;; Of course empty lists of subtypes are still OK. (assert (typep 11 '(and))) (assert (not (typep 11 '(or)))) @@ -198,6 +212,37 @@ ;;; uncertainty, to wit: (assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912))) '(mod 536870911))) ; aka SB-INT:INDEX. +;;; floating point types can be tricky. +(assert-t-t (subtypep '(member 0.0) '(single-float 0.0 0.0))) +(assert-t-t (subtypep '(member -0.0) '(single-float 0.0 0.0))) +(assert-t-t (subtypep '(member 0.0) '(single-float -0.0 0.0))) +(assert-t-t (subtypep '(member -0.0) '(single-float 0.0 -0.0))) +(assert-t-t (subtypep '(member 0.0d0) '(double-float 0.0d0 0.0d0))) +(assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 0.0d0))) +(assert-t-t (subtypep '(member 0.0d0) '(double-float -0.0d0 0.0d0))) +(assert-t-t (subtypep '(member -0.0d0) '(double-float 0.0d0 -0.0d0))) + +(assert-nil-t (subtypep '(single-float 0.0 0.0) '(member 0.0))) +(assert-nil-t (subtypep '(single-float 0.0 0.0) '(member -0.0))) +(assert-nil-t (subtypep '(single-float -0.0 0.0) '(member 0.0))) +(assert-nil-t (subtypep '(single-float 0.0 -0.0) '(member -0.0))) +(assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0))) +(assert-nil-t (subtypep '(double-float 0.0d0 0.0d0) '(member -0.0d0))) +(assert-nil-t (subtypep '(double-float -0.0d0 0.0d0) '(member 0.0d0))) +(assert-nil-t (subtypep '(double-float 0.0d0 -0.0d0) '(member -0.0d0))) + +(assert-t-t (subtypep '(member 0.0 -0.0) '(single-float 0.0 0.0))) +(assert-t-t (subtypep '(single-float 0.0 0.0) '(member 0.0 -0.0))) +(assert-t-t (subtypep '(member 0.0d0 -0.0d0) '(double-float 0.0d0 0.0d0))) +(assert-t-t (subtypep '(double-float 0.0d0 0.0d0) '(member 0.0d0 -0.0d0))) + +(assert-t-t (subtypep '(not (single-float 0.0 0.0)) '(not (member 0.0)))) +(assert-t-t (subtypep '(not (double-float 0.0d0 0.0d0)) '(not (member 0.0d0)))) + +(assert-t-t (subtypep '(float -0.0) '(float 0.0))) +(assert-t-t (subtypep '(float 0.0) '(float -0.0))) +(assert-t-t (subtypep '(float (0.0)) '(float (-0.0)))) +(assert-t-t (subtypep '(float (-0.0)) '(float (0.0)))) ;;;; Douglas Thomas Crosher rewrote the CMU CL type test system to ;;;; allow inline type tests for CONDITIONs and STANDARD-OBJECTs, and @@ -286,62 +331,58 @@ (assert (subtypep 'simple-error 'error)) (assert (not (subtypep 'condition 'simple-condition))) (assert (not (subtypep 'error 'simple-error))) - (assert (eq (car (sb-kernel:class-direct-superclasses + (assert (eq (car (sb-pcl:class-direct-superclasses (find-class 'simple-condition))) (find-class 'condition))) - - (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class - 'simple-condition))) - (sb-pcl:find-class 'condition))) - - (let ((subclasses (mapcar #'sb-pcl:find-class - '(simple-type-error - simple-error - simple-warning - sb-int:simple-file-error - sb-int:simple-style-warning)))) - (assert (null (set-difference - (sb-pcl:class-direct-subclasses (sb-pcl:find-class - 'simple-condition)) - subclasses)))) - + + #+nil ; doesn't look like a good test + (let ((subclasses (mapcar #'find-class + '(simple-type-error + simple-error + simple-warning + sb-int:simple-file-error + sb-int:simple-style-warning)))) + (assert (null (set-difference + (sb-pcl:class-direct-subclasses (find-class + 'simple-condition)) + subclasses)))) + ;; precedence lists - (assert (equal (sb-pcl:class-precedence-list - (sb-pcl:find-class 'simple-condition)) - (mapcar #'sb-pcl:find-class '(simple-condition - condition - sb-kernel:instance - t)))) + (assert (equal (sb-pcl:class-precedence-list + (find-class 'simple-condition)) + (mapcar #'find-class '(simple-condition + condition + sb-pcl::slot-object + sb-kernel:instance + t)))) ;; stream classes - (assert (null (sb-kernel:class-direct-superclasses - (find-class 'fundamental-stream)))) - (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class + (assert (equal (sb-pcl:class-direct-superclasses (find-class 'fundamental-stream)) - (mapcar #'sb-pcl:find-class '(standard-object stream)))) + (mapcar #'find-class '(standard-object stream)))) (assert (null (set-difference - (sb-pcl:class-direct-subclasses (sb-pcl:find-class + (sb-pcl:class-direct-subclasses (find-class 'fundamental-stream)) - (mapcar #'sb-pcl:find-class '(fundamental-binary-stream - fundamental-character-stream - fundamental-output-stream - fundamental-input-stream))))) - (assert (equal (sb-pcl:class-precedence-list (sb-pcl:find-class + (mapcar #'find-class '(fundamental-binary-stream + fundamental-character-stream + fundamental-output-stream + fundamental-input-stream))))) + (assert (equal (sb-pcl:class-precedence-list (find-class 'fundamental-stream)) - (mapcar #'sb-pcl: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 (sb-pcl:find-class + (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 #'sb-pcl:find-class '(fundamental-stream - standard-object - sb-pcl::std-object - sb-pcl::slot-object stream - sb-kernel:instance t)))) + (mapcar #'find-class '(fundamental-stream + standard-object + sb-pcl::std-object + sb-pcl::slot-object stream + sb-kernel:instance t)))) (assert (subtypep (find-class 'stream) (find-class t))) (assert (subtypep (find-class 'fundamental-stream) 'stream)) (assert (not (subtypep 'stream 'fundamental-stream))))) @@ -372,6 +413,21 @@ (deftype bar () 'single-float) (assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0)) 0.0f0)) + +;;; bug 260a +(assert-t-t + (let* ((s (gensym)) + (t1 (sb-kernel:specifier-type s))) + (eval `(defstruct ,s)) + (sb-kernel:type= t1 (sb-kernel:specifier-type s)))) + +;;; bug found by PFD's random subtypep tester +(let ((t1 '(cons rational (cons (not rational) (cons integer t)))) + (t2 '(not (cons (integer 0 1) (cons single-float long-float))))) + (assert-t-t (subtypep t1 t2)) + (assert-nil-t (subtypep t2 t1)) + (assert-t-t (subtypep `(not ,t2) `(not ,t1))) + (assert-nil-t (subtypep `(not ,t1) `(not ,t2)))) ;;; success (quit :unix-status 104)