X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=38cee279b3c66d36635be49d45ff7d48641c5728;hb=2eee1c446adf860571a0d5e89eb5c547806cda76;hp=bf127c767389019150bdb2de87f477b72eccf81a;hpb=8fa3b333d2b37f45c3702f478f784b8c6f491080;p=sbcl.git diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index bf127c7..38cee27 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -1,6 +1,16 @@ -(in-package :cl-user) +;;;; 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. (load "assertoid.lisp") +(use-package "ASSERTOID") (defmacro assert-nil-nil (expr) `(assert (equal '(nil nil) (multiple-value-list ,expr)))) @@ -80,14 +90,10 @@ ;;; part I: TYPEP (assert (typep #(11) '(simple-array t 1))) (assert (typep #(11) '(simple-array (or integer symbol) 1))) -;;; FIXME: This is broken because of compiler bug 123: the compiler -;;; optimizes the type test to T, so it never gets a chance to raise a -;;; runtime error. (It used to work under the IR1 interpreter just -;;; because the IR1 interpreter doesn't try to optimize TYPEP as hard -;;; as the byte compiler does.) -#+nil (assert (raises-error? (typep #(11) '(simple-array undef-type 1)))) +(assert (raises-error? (typep #(11) '(simple-array undef-type 1)))) (assert (not (typep 11 '(simple-array undef-type 1)))) ;;; part II: SUBTYPEP + (assert (subtypep '(vector some-undef-type) 'vector)) (assert (not (subtypep '(vector some-undef-type) 'integer))) (assert-nil-nil (subtypep 'utype-1 'utype-2)) @@ -96,10 +102,14 @@ (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))) + ;;; Of course empty lists of subtypes are still OK. (assert (typep 11 '(and))) (assert (not (typep 11 '(or)))) @@ -118,7 +128,12 @@ ;;; HAIRY domain. (assert-nil-t (subtypep 'atom 'cons)) (assert-nil-t (subtypep 'cons 'atom)) +;;; These two are desireable but not necessary for ANSI conformance; +;;; maintenance work on other parts of the system broke them in +;;; sbcl-0.7.13.11 -- CSR +#+nil (assert-nil-t (subtypep '(not list) 'cons)) +#+nil (assert-nil-t (subtypep '(not float) 'single-float)) (assert-t-t (subtypep '(not atom) 'cons)) (assert-t-t (subtypep 'cons '(not atom))) @@ -187,6 +202,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 @@ -275,62 +321,57 @@ (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 + (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 (sb-pcl:find-class + (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)))) + (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))))) @@ -345,10 +386,37 @@ ;;; Redefinition of classes should alter the type hierarchy (BUG 140): (defclass superclass () ()) +(defclass maybe-subclass () ()) +(assert-nil-t (subtypep 'maybe-subclass 'superclass)) (defclass maybe-subclass (superclass) ()) (assert-t-t (subtypep 'maybe-subclass 'superclass)) (defclass maybe-subclass () ()) (assert-nil-t (subtypep 'maybe-subclass 'superclass)) +;;; Prior to sbcl-0.7.6.27, there was some confusion in ARRAY types +;;; specialized on some as-yet-undefined type which would cause this +;;; program to fail (bugs #123 and #165). Verify that it doesn't. +(defun foo (x) + (declare (type (vector bar) x)) + (aref x 1)) +(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)