X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=73301f03e011a0d475e84b854fd3230c7b58b2a1;hb=ddaf14f0438b5252d4d5d149f65921795c9a771d;hp=248955ec43897168131e383be620e5bb47ec07ee;hpb=2034cb134af58c5998f4e305673af6e2c75bc179;p=sbcl.git diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 248955e..73301f0 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -4,13 +4,14 @@ ;;;; 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") +(use-package "TEST-UTIL") (defmacro assert-nil-nil (expr) `(assert (equal '(nil nil) (multiple-value-list ,expr)))) @@ -21,20 +22,20 @@ (defmacro assert-t-t-or-uncertain (expr) `(assert (let ((list (multiple-value-list ,expr))) - (or (equal '(nil nil) list) - (equal '(t t) list))))) + (or (equal '(nil nil) list) + (equal '(t t) list))))) (let ((types '(character - integer fixnum (integer 0 10) - single-float (single-float -1.0 1.0) (single-float 0.1) - (real 4 8) (real -1 7) (real 2 11) - null symbol keyword - (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3) + integer fixnum (integer 0 10) + single-float (single-float -1.0 1.0) (single-float 0.1) + (real 4 8) (real -1 7) (real 2 11) + null symbol keyword + (member #\a #\b #\c) (member 1 #\a) (member 3.0 3.3) (member #\a #\c #\d #\f) (integer -1 1) - unsigned-byte - (rational -1 7) (rational -2 4) - ratio - ))) + unsigned-byte + (rational -1 7) (rational -2 4) + ratio + ))) (dolist (i types) (format t "type I=~S~%" i) (dolist (j types) @@ -44,25 +45,25 @@ (assert (subtypep i `(or ,i ,i ,j))) (assert (subtypep i `(or ,j ,i))) (dolist (k types) - (format t " type K=~S~%" k) - (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k))) - (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i))))))) + (format t " type K=~S~%" k) + (assert (subtypep `(or ,i ,j) `(or ,i ,j ,k))) + (assert (subtypep `(or ,i ,j) `(or ,k ,j ,i))))))) ;;; gotchas that can come up in handling subtypeness as "X is a ;;; subtype of Y if each of the elements of X is a subtype of Y" (let ((subtypep-values (multiple-value-list - (subtypep '(single-float -1.0 1.0) - '(or (real -100.0 0.0) - (single-float 0.0 100.0)))))) + (subtypep '(single-float -1.0 1.0) + '(or (real -100.0 0.0) + (single-float 0.0 100.0)))))) (assert (member subtypep-values - '(;; The system isn't expected to - ;; understand the subtype relationship. - (nil nil) - ;; But if it does, that'd be neat. - (t t) - ;; (And any other return would be wrong.) - ) - :test #'equal))) + '(;; The system isn't expected to + ;; understand the subtype relationship. + (nil nil) + ;; But if it does, that'd be neat. + (t t) + ;; (And any other return would be wrong.) + ) + :test #'equal))) (defun type-evidently-= (x y) (and (subtypep x y) @@ -206,12 +207,12 @@ ;;; the definition of the component structure). Since it's a sensible ;;; thing to want anyway, let's test for it here: (assert-t-t (subtypep '(or some-undefined-type (member :no-ir2-yet :dead)) - '(or some-undefined-type (member :no-ir2-yet :dead)))) + '(or some-undefined-type (member :no-ir2-yet :dead)))) ;;; BUG 158 (failure to compile loops with vector references and ;;; increments of greater than 1) was a symptom of type system ;;; uncertainty, to wit: (assert-t-t (subtypep '(and (mod 536870911) (or (integer 0 0) (integer 2 536870912))) - '(mod 536870911))) ; aka SB-INT:INDEX. + '(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))) @@ -292,39 +293,39 @@ (assert (typep (make-structure-foo3) 'structure-foo2)) (assert (not (typep (make-structure-foo1) 'structure-foo4))) (assert (typep (nth-value 1 - (ignore-errors (structure-foo2-x - (make-structure-foo1)))) - 'type-error)) + (ignore-errors (structure-foo2-x + (make-structure-foo1)))) + 'type-error)) (assert (null (ignore-errors - (setf (structure-foo2-x (make-structure-foo1)) 11)))) + (setf (structure-foo2-x (make-structure-foo1)) 11)))) ;; structure-class tests (assert (typep (make-instance 'structure-class-foo3) - 'structure-class-foo2)) + 'structure-class-foo2)) (assert (not (typep (make-instance 'structure-class-foo1) - 'structure-class-foo4))) + 'structure-class-foo4))) (assert (null (ignore-errors - (setf (slot-value (make-instance 'structure-class-foo1) - 'x) - 11)))) + (setf (slot-value (make-instance 'structure-class-foo1) + 'x) + 11)))) ;; standard-class tests (assert (typep (make-instance 'standard-class-foo3) - 'standard-class-foo2)) + 'standard-class-foo2)) (assert (not (typep (make-instance 'standard-class-foo1) - 'standard-class-foo4))) + 'standard-class-foo4))) (assert (null (ignore-errors - (setf (slot-value (make-instance 'standard-class-foo1) 'x) - 11)))) + (setf (slot-value (make-instance 'standard-class-foo1) 'x) + 11)))) ;; condition tests (assert (typep (make-condition 'condition-foo3) - 'condition-foo2)) + 'condition-foo2)) (assert (not (typep (make-condition 'condition-foo1) - 'condition-foo4))) + 'condition-foo4))) (assert (null (ignore-errors - (setf (slot-value (make-condition 'condition-foo1) 'x) - 11)))) + (setf (slot-value (make-condition 'condition-foo1) 'x) + 11)))) (assert (subtypep 'error 't)) (assert (subtypep 'simple-condition 'condition)) (assert (subtypep 'simple-error 'simple-condition)) @@ -332,9 +333,9 @@ (assert (not (subtypep 'condition 'simple-condition))) (assert (not (subtypep 'error 'simple-error))) (assert (eq (car (sb-pcl:class-direct-superclasses - (find-class 'simple-condition))) - (find-class 'condition))) - + (find-class 'simple-condition))) + (find-class 'condition))) + #+nil ; doesn't look like a good test (let ((subclasses (mapcar #'find-class '(simple-type-error @@ -346,43 +347,39 @@ (sb-pcl:class-direct-subclasses (find-class 'simple-condition)) subclasses)))) - + ;; precedence lists - (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)))) + (assert (equal (sb-pcl:class-precedence-list + (find-class 'simple-condition)) + (mapcar #'find-class '(simple-condition + condition + sb-pcl::slot-object + t)))) ;; stream classes (assert (equal (sb-pcl:class-direct-superclasses (find-class - 'fundamental-stream)) - (mapcar #'find-class '(standard-object stream)))) + 'fundamental-stream)) + (mapcar #'find-class '(standard-object stream)))) (assert (null (set-difference - (sb-pcl:class-direct-subclasses (find-class - 'fundamental-stream)) - (mapcar #'find-class '(fundamental-binary-stream - fundamental-character-stream - fundamental-output-stream - fundamental-input-stream))))) + (sb-pcl:class-direct-subclasses (find-class + 'fundamental-stream)) + (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 #'find-class '(fundamental-stream - standard-object - sb-pcl::std-object - sb-pcl::slot-object - stream - sb-kernel:instance - t)))) + 'fundamental-stream)) + (mapcar #'find-class '(fundamental-stream + standard-object + sb-pcl::slot-object + stream + t)))) (assert (equal (sb-pcl:class-precedence-list (find-class - 'fundamental-stream)) - (mapcar #'find-class '(fundamental-stream - standard-object - sb-pcl::std-object - sb-pcl::slot-object stream - sb-kernel:instance t)))) + 'fundamental-stream)) + (mapcar #'find-class '(fundamental-stream + standard-object + sb-pcl::slot-object stream + t)))) (assert (subtypep (find-class 'stream) (find-class t))) (assert (subtypep (find-class 'fundamental-stream) 'stream)) (assert (not (subtypep 'stream 'fundamental-stream))))) @@ -412,7 +409,7 @@ (aref x 1)) (deftype bar () 'single-float) (assert (eql (foo (make-array 3 :element-type 'bar :initial-element 0.0f0)) - 0.0f0)) + 0.0f0)) ;;; bug 260a (assert-t-t @@ -429,5 +426,136 @@ (assert-t-t (subtypep `(not ,t2) `(not ,t1))) (assert-nil-t (subtypep `(not ,t1) `(not ,t2)))) +;;; not easily visible to user code, but this used to be very +;;; confusing. +(with-test (:name (:ctor :typep-function)) + (assert (eval '(typep (sb-pcl::ensure-ctor + (list 'sb-pcl::ctor (gensym)) nil nil) + 'function)))) +(with-test (:name (:ctor :functionp)) + (assert (functionp (sb-pcl::ensure-ctor + (list 'sb-pcl::ctor (gensym)) nil nil)))) + +;;; from PFD ansi-tests +(let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) + (integer -234496 215373)) + integer)) + (t2 '(cons (cons (cons integer integer) + (integer -234496 215373)) + t))) + (assert (null (values (subtypep `(not ,t2) `(not ,t1)))))) + +(defstruct misc-629a) +(defclass misc-629b () ()) +(defclass misc-629c () () (:metaclass sb-mop:funcallable-standard-class)) + +(assert (typep (make-misc-629a) 'sb-kernel:instance)) +(assert-t-t (subtypep `(member ,(make-misc-629a)) 'sb-kernel:instance)) +(assert-nil-t (subtypep `(and (member ,(make-misc-629a)) sb-kernel:instance) + nil)) +(let ((misc-629a (make-misc-629a))) + (assert-t-t (subtypep `(member ,misc-629a) + `(and (member ,misc-629a) sb-kernel:instance))) + (assert-t-t (subtypep `(and (member ,misc-629a) + sb-kernel:funcallable-instance) + nil))) + +(assert (typep (make-instance 'misc-629b) 'sb-kernel:instance)) +(assert-t-t (subtypep `(member ,(make-instance 'misc-629b)) + 'sb-kernel:instance)) +(assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629b)) + sb-kernel:instance) + nil)) +(let ((misc-629b (make-instance 'misc-629b))) + (assert-t-t (subtypep `(member ,misc-629b) + `(and (member ,misc-629b) sb-kernel:instance))) + (assert-t-t (subtypep `(and (member ,misc-629b) + sb-kernel:funcallable-instance) + nil))) + +(assert (typep (make-instance 'misc-629c) 'sb-kernel:funcallable-instance)) +(assert-t-t (subtypep `(member ,(make-instance 'misc-629c)) + 'sb-kernel:funcallable-instance)) +(assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629c)) + sb-kernel:funcallable-instance) + nil)) +(let ((misc-629c (make-instance 'misc-629c))) + (assert-t-t (subtypep `(member ,misc-629c) + `(and (member ,misc-629c) + sb-kernel:funcallable-instance))) + (assert-t-t (subtypep `(and (member ,misc-629c) + sb-kernel:instance) + nil))) + +;;; this was broken during the FINALIZE-INHERITANCE rearrangement; the +;;; MAKE-INSTANCE finalizes the superclass, thus invalidating the +;;; subclass, so SUBTYPEP must be prepared to deal with +(defclass ansi-tests-defclass1 () ()) +(defclass ansi-tests-defclass3 (ansi-tests-defclass1) ()) +(make-instance 'ansi-tests-defclass1) +(assert-t-t (subtypep 'ansi-tests-defclass3 'standard-object)) + +;;; so was this +(let ((class (eval '(defclass to-be-type-ofed () ())))) + (setf (find-class 'to-be-type-ofed) nil) + (assert (eq (type-of (make-instance class)) class))) + +;;; accuracy of CONS :SIMPLE-TYPE-= +(deftype goldbach-1 () '(satisfies even-and-greater-then-two-p)) +(deftype goldbach-2 () ' (satisfies sum-of-two-primes-p)) + +(multiple-value-bind (ok win) + (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer)) + (sb-kernel:specifier-type '(cons goldbach1 integer))) + (assert ok) + (assert win)) + +;; See FIXME in type method for CONS :SIMPLE-TYPE-= +#+nil +(multiple-value-bind (ok win) + (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer)) + (sb-kernel:specifier-type '(cons goldbach1 single-float))) + (assert (not ok)) + (assert win)) + +(multiple-value-bind (ok win) + (sb-kernel:type= (sb-kernel:specifier-type '(cons goldbach1 integer)) + (sb-kernel:specifier-type '(cons goldbach2 single-float))) + (assert (not ok)) + (assert (not win))) + +;;; precise unions of array types (was bug 306a) +(defun bug-306-a (x) + (declare (optimize speed) + (type (or (array cons) (array vector)) x)) + (elt (aref x 0) 0)) +(assert (= 0 (bug-306-a #((0))))) + +;;; FUNCALLABLE-INSTANCE is a subtype of function. +(assert-t-t (subtypep '(and pathname function) nil)) +(assert-t-t (subtypep '(and pathname sb-kernel:funcallable-instance) nil)) +(assert (not (subtypep '(and stream function) nil))) +(assert (not (subtypep '(and stream sb-kernel:funcallable-instance) nil))) +(assert (not (subtypep '(and function standard-object) nil))) +(assert (not (subtypep '(and sb-kernel:funcallable-instance standard-object) nil))) + +;;; also, intersections of classes with INSTANCE should not be too +;;; general +(assert (not (typep #'print-object '(and standard-object sb-kernel:instance)))) +(assert (not (subtypep 'standard-object '(and standard-object sb-kernel:instance)))) + +(assert-t-t + (subtypep '(or simple-array simple-string) '(or simple-string simple-array))) +(assert-t-t + (subtypep '(or simple-string simple-array) '(or simple-array simple-string))) +(assert-t-t + (subtypep '(or fixnum simple-string end-of-file parse-error fixnum vector) + '(or fixnum vector end-of-file parse-error fixnum simple-string))) + +#+sb-eval +(assert-t-t + (subtypep '(and function (not compiled-function) + (not sb-eval:interpreted-function)) + nil)) + ;;; success -(quit :unix-status 104)