X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Ftype.impure.lisp;h=91a1f696a2d1ccd184231bbd1a6d7b3be41c52b7;hb=1cba0af01f5107ab384d0d8b94b1f6330b3d0ef4;hp=1dbf49cc44a6774c48b87c63942b5e6b81262fe2;hpb=467a8e5dba8bfa2598ca8e22c1204dc173ce556f;p=sbcl.git diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 1dbf49c..91a1f69 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -1,6 +1,17 @@ -(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") +(use-package "TEST-UTIL") (defmacro assert-nil-nil (expr) `(assert (equal '(nil nil) (multiple-value-list ,expr)))) @@ -9,11 +20,22 @@ (defmacro assert-t-t (expr) `(assert (equal '(t t) (multiple-value-list ,expr)))) +(defmacro assert-t-t-or-uncertain (expr) + `(assert (let ((list (multiple-value-list ,expr))) + (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) - (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 + ))) (dolist (i types) (format t "type I=~S~%" i) (dolist (j types) @@ -23,27 +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))) - ;; FIXME: The old code (including original CMU CL code) - ;; fails this test. When this is fixed, we can re-enable it. - #+nil (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" -#+nil ; FIXME: suppressed until we can fix old CMU CL big (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.) - )))) + '(;; 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) @@ -53,6 +73,11 @@ (assert (type-evidently-= '(integer 0 10) '(or (integer 0 5) (integer 4 10)))) +;;; Bug 50(c,d): numeric types with empty ranges should be NIL +(assert (type-evidently-= 'nil '(integer (0) (0)))) +(assert (type-evidently-= 'nil '(rational (0) (0)))) +(assert (type-evidently-= 'nil '(float (0.0) (0.0)))) + ;;; sbcl-0.6.10 did (UPGRADED-ARRAY-ELEMENT-TYPE 'SOME-UNDEF-TYPE)=>T ;;; and (UPGRADED-COMPLEX-PART-TYPE 'SOME-UNDEF-TYPE)=>T. (assert (raises-error? (upgraded-array-element-type 'some-undef-type))) @@ -69,6 +94,7 @@ (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)) @@ -77,10 +103,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.6.11.10. (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)))) @@ -88,12 +128,636 @@ ;;; bug 12: type system didn't grok nontrivial intersections (assert (subtypep '(and symbol (satisfies keywordp)) 'symbol)) (assert (not (subtypep '(and symbol (satisfies keywordp)) 'null))) -#| ; "we gotta target, but you gotta be patient": 0.6.11.11 work in progress (assert (subtypep 'keyword 'symbol)) (assert (not (subtypep 'symbol 'keyword))) (assert (subtypep 'ratio 'real)) (assert (subtypep 'ratio 'number)) -|# + +;;; bug 50.g: Smarten up hairy type specifiers slightly. We may wish +;;; to revisit this, perhaps by implementing a COMPLEMENT type +;;; (analogous to UNION and INTERSECTION) to take the logic out of the +;;; 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))) +;;; ANSI requires that SUBTYPEP relationships among built-in primitive +;;; types never be uncertain, i.e. never return NIL as second value. +;;; Prior to about sbcl-0.7.2.6, ATOM caused a lot of problems here +;;; (because it's a negation type, implemented as a HAIRY-TYPE, and +;;; CMU CL's HAIRY-TYPE logic punted a lot). +(assert-t-t (subtypep 'integer 'atom)) +(assert-t-t (subtypep 'function 'atom)) +(assert-nil-t (subtypep 'list 'atom)) +(assert-nil-t (subtypep 'atom 'integer)) +(assert-nil-t (subtypep 'atom 'function)) +(assert-nil-t (subtypep 'atom 'list)) +;;; ATOM is equivalent to (NOT CONS): +(assert-t-t (subtypep 'integer '(not cons))) +(assert-nil-t (subtypep 'list '(not cons))) +(assert-nil-t (subtypep '(not cons) 'integer)) +(assert-nil-t (subtypep '(not cons) 'list)) +;;; And we'd better check that all the named types are right. (We also +;;; do some more tests on ATOM here, since once CSR experimented with +;;; making it a named type.) +(assert-t-t (subtypep 'nil 'nil)) +(assert-t-t (subtypep 'nil 'atom)) +(assert-t-t (subtypep 'nil 't)) +(assert-nil-t (subtypep 'atom 'nil)) +(assert-t-t (subtypep 'atom 'atom)) +(assert-t-t (subtypep 'atom 't)) +(assert-nil-t (subtypep 't 'nil)) +(assert-nil-t (subtypep 't 'atom)) +(assert-t-t (subtypep 't 't)) +;;; Also, LIST is now somewhat special, in that (NOT LIST) should be +;;; recognized as a subtype of ATOM: +(assert-t-t (subtypep '(not list) 'atom)) +(assert-nil-t (subtypep 'atom '(not list))) +;;; These used to fail, because when the two arguments to subtypep are +;;; of different specifier-type types (e.g. HAIRY and UNION), there +;;; are two applicable type methods -- in this case +;;; HAIRY-COMPLEX-SUBTYPEP-ARG1-TYPE-METHOD and +;;; UNION-COMPLEX-SUBTYPEP-ARG2-TYPE-METHOD. Both of these exist, but +;;; [!%]INVOKE-TYPE-METHOD aren't smart enough to know that if one of +;;; them returns NIL, NIL (indicating uncertainty) it should try the +;;; other. However, as of sbcl-0.7.2.6 or so, CALL-NEXT-METHOD-ish +;;; logic in those type methods fixed it. +(assert-nil-t (subtypep '(not cons) 'list)) +(assert-nil-t (subtypep '(not single-float) 'float)) +;;; Somewhere along the line (probably when adding CALL-NEXT-METHOD-ish +;;; logic in SUBTYPEP type methods) we fixed bug 58 too: +(assert-t-t (subtypep '(and zilch integer) 'zilch)) +(assert-t-t (subtypep '(and integer zilch) 'zilch)) + +;;; Bug 84: SB-KERNEL:CSUBTYPEP was a bit enthusiastic at +;;; special-casing calls to subtypep involving *EMPTY-TYPE*, +;;; corresponding to the NIL type-specifier; we were bogusly returning +;;; NIL, T (indicating surety) for the following: +(assert-nil-nil (subtypep '(satisfies some-undefined-fun) 'nil)) + +;;; It turns out that, as of sbcl-0.7.2, we require to be able to +;;; detect this to compile src/compiler/node.lisp (and in particular, +;;; 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)))) +;;; 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. +;;; 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 +;;;; generally be nicer, and Martin Atzmueller ported the patches. +;;;; They look nice but they're nontrivial enough that it's not +;;;; obvious from inspection that everything is OK. Let's make sure +;;;; that things still basically work. + +;; structure type tests setup +(defstruct structure-foo1) +(defstruct (structure-foo2 (:include structure-foo1)) + x) +(defstruct (structure-foo3 (:include structure-foo2))) +(defstruct (structure-foo4 (:include structure-foo3)) + y z) + +;; structure-class tests setup +(defclass structure-class-foo1 () () (:metaclass cl:structure-class)) +(defclass structure-class-foo2 (structure-class-foo1) + () (:metaclass cl:structure-class)) +(defclass structure-class-foo3 (structure-class-foo2) + () (:metaclass cl:structure-class)) +(defclass structure-class-foo4 (structure-class-foo3) + () (:metaclass cl:structure-class)) + +;; standard-class tests setup +(defclass standard-class-foo1 () () (:metaclass cl:standard-class)) +(defclass standard-class-foo2 (standard-class-foo1) + () (:metaclass cl:standard-class)) +(defclass standard-class-foo3 (standard-class-foo2) + () (:metaclass cl:standard-class)) +(defclass standard-class-foo4 (standard-class-foo3) + () (:metaclass cl:standard-class)) + +;; condition tests setup +(define-condition condition-foo1 (condition) ()) +(define-condition condition-foo2 (condition-foo1) ()) +(define-condition condition-foo3 (condition-foo2) ()) +(define-condition condition-foo4 (condition-foo3) ()) + +;;; inline type tests +(format t "~&/setting up *TESTS-OF-INLINE-TYPE-TESTS*~%") +(defparameter *tests-of-inline-type-tests* + '(progn + + ;; structure type tests + (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)) + (assert (null (ignore-errors + (setf (structure-foo2-x (make-structure-foo1)) 11)))) + + ;; structure-class tests + (assert (typep (make-instance 'structure-class-foo3) + 'structure-class-foo2)) + (assert (not (typep (make-instance 'structure-class-foo1) + 'structure-class-foo4))) + (assert (null (ignore-errors + (setf (slot-value (make-instance 'structure-class-foo1) + 'x) + 11)))) + + ;; standard-class tests + (assert (typep (make-instance 'standard-class-foo3) + 'standard-class-foo2)) + (assert (not (typep (make-instance 'standard-class-foo1) + 'standard-class-foo4))) + (assert (null (ignore-errors + (setf (slot-value (make-instance 'standard-class-foo1) 'x) + 11)))) + + ;; condition tests + (assert (typep (make-condition 'condition-foo3) + 'condition-foo2)) + (assert (not (typep (make-condition 'condition-foo1) + 'condition-foo4))) + (assert (null (ignore-errors + (setf (slot-value (make-condition 'condition-foo1) 'x) + 11)))) + (assert (subtypep 'error 't)) + (assert (subtypep 'simple-condition 'condition)) + (assert (subtypep 'simple-error 'simple-condition)) + (assert (subtypep 'simple-error 'error)) + (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))) + + #+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 + (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)))) + (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))))) + (assert (equal (sb-pcl:class-precedence-list (find-class + '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::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))))) +;;; Test under the interpreter. +(eval *tests-of-inline-type-tests*) +(format t "~&/done with interpreted *TESTS-OF-INLINE-TYPE-TESTS*~%") +;;; Test under the compiler. +(defun tests-of-inline-type-tests () + #.*tests-of-inline-type-tests*) +(tests-of-inline-type-tests) +(format t "~&/done with compiled (TESTS-OF-INLINE-TYPE-TESTS)~%") + +;;; 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)))) + +;;; 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 nil) + 'function)))) +(with-test (:name (:ctor :functionp)) + (assert (functionp (sb-pcl::ensure-ctor + (list 'sb-pcl::ctor (gensym)) nil nil nil)))) +;;; some new (2008-10-03) ways of going wrong... +(with-test (:name (:ctor-allocate-instance :typep-function)) + (assert (eval '(typep (allocate-instance (find-class 'sb-pcl::ctor)) + 'function)))) +(with-test (:name (:ctor-allocate-instance :functionp)) + (assert (functionp (allocate-instance (find-class 'sb-pcl::ctor))))) + +;;; 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)) + +;;; weakening of union type checks +(defun weaken-union-1 (x) + (declare (optimize speed)) + (car x)) +(multiple-value-bind (res err) + (ignore-errors (weaken-union-1 "askdjhasdkj")) + (assert (not res)) + (assert (typep err 'type-error))) +(defun weaken-union-2 (x) + (declare (optimize speed) + (type (or cons fixnum) x)) + (etypecase x + (fixnum x) + (cons + (setf (car x) 3) + x))) +(multiple-value-bind (res err) + (ignore-errors (weaken-union-2 "asdkahsdkhj")) + (assert (not res)) + (assert (typep err 'type-error)) + (assert (or (equal '(or cons fixnum) (type-error-expected-type err)) + (equal '(or fixnum cons) (type-error-expected-type err))))) + +;;; TYPEXPAND & Co + +(deftype a-deftype (arg) + `(cons (eql ,arg) *)) + +(deftype another-deftype (arg) + `(a-deftype ,arg)) + +(deftype list-of-length (length &optional element-type) + (assert (not (minusp length))) + (if (zerop length) + 'null + `(cons ,element-type (list-of-length ,(1- length) ,element-type)))) + +(with-test (:name :typexpand-1) + (multiple-value-bind (expansion-1 expandedp-1) + (sb-ext:typexpand-1 '(another-deftype symbol)) + (assert expandedp-1) + (assert (equal expansion-1 '(a-deftype symbol))) + (multiple-value-bind (expansion-2 expandedp-2) + (sb-ext:typexpand-1 expansion-1) + (assert expandedp-2) + (assert (equal expansion-2 '(cons (eql symbol) *))) + (multiple-value-bind (expansion-3 expandedp-3) + (sb-ext:typexpand-1 expansion-2) + (assert (not expandedp-3)) + (assert (eq expansion-2 expansion-3)))))) + +(with-test (:name :typexpand.1) + (multiple-value-bind (expansion-1 expandedp-1) + (sb-ext:typexpand '(another-deftype symbol)) + (assert expandedp-1) + (assert (equal expansion-1 '(cons (eql symbol) *))) + (multiple-value-bind (expansion-2 expandedp-2) + (sb-ext:typexpand expansion-1) + (assert (not expandedp-2)) + (assert (eq expansion-1 expansion-2))))) + +(with-test (:name :typexpand.2) + (assert (equal (sb-ext:typexpand '(list-of-length 3 fixnum)) + '(cons fixnum (list-of-length 2 fixnum))))) + +(with-test (:name :typexpand-all) + (assert (equal (sb-ext:typexpand-all '(list-of-length 3)) + '(cons t (cons t (cons t null))))) + (assert (equal (sb-ext:typexpand-all '(list-of-length 3 fixnum)) + '(cons fixnum (cons fixnum (cons fixnum null)))))) + +(defclass a-deftype () ()) + +(with-test (:name (:typexpand-1 :after-type-redefinition-to-class)) + (multiple-value-bind (expansion expandedp) + (sb-ext:typexpand-1 '#1=(a-deftype symbol)) + (assert (not expandedp)) + (assert (eq expansion '#1#)))) + + +(with-test (:name :defined-type-name-p) + (assert (not (sb-ext:defined-type-name-p '#:foo))) + (assert (sb-ext:defined-type-name-p 'a-deftype)) + (assert (sb-ext:defined-type-name-p 'structure-foo1)) + (assert (sb-ext:defined-type-name-p 'structure-class-foo1)) + (assert (sb-ext:defined-type-name-p 'standard-class-foo1)) + (assert (sb-ext:defined-type-name-p 'condition-foo1)) + (dolist (prim-type '(t nil fixnum cons atom)) + (assert (sb-ext:defined-type-name-p prim-type)))) + + +(with-test (:name :valid-type-specifier-p) + (macrolet ((yes (form) `(assert ,form)) + (no (form) `(assert (not ,form)))) + (no (sb-ext:valid-type-specifier-p '(cons #(frob) *))) + (no (sb-ext:valid-type-specifier-p 'list-of-length)) + (no (sb-ext:valid-type-specifier-p '(list-of-length 5 #(x)))) + (yes (sb-ext:valid-type-specifier-p '(list-of-length 5 fixnum))) + + (yes (sb-ext:valid-type-specifier-p 'structure-foo1)) + (no (sb-ext:valid-type-specifier-p '(structure-foo1 x))) + (yes (sb-ext:valid-type-specifier-p 'condition-foo1)) + (yes (sb-ext:valid-type-specifier-p 'standard-class-foo1)) + (yes (sb-ext:valid-type-specifier-p 'structure-class-foo1)) + + (yes (sb-ext:valid-type-specifier-p 'readtable)) + (no (sb-ext:valid-type-specifier-p '(readtable))) + (no (sb-ext:valid-type-specifier-p '(readtable x))) + + (yes (sb-ext:valid-type-specifier-p '(values))) + (no (sb-ext:valid-type-specifier-p 'values)) + (yes (sb-ext:valid-type-specifier-p '(and))) + (no (sb-ext:valid-type-specifier-p 'and)))) + +(with-test (:name (:valid-type-specifier-p :introspection-test)) + (flet ((map-functions (fn) + (do-all-symbols (s) + (when (and (fboundp s) + (not (macro-function s)) + (not (special-operator-p s))) + (funcall fn s))))) + (map-functions + #'(lambda (s) + (let* ((fun (sb-kernel:%fun-fun (fdefinition s))) + (ftype (sb-kernel:%simple-fun-type fun))) + (unless (sb-ext:valid-type-specifier-p ftype) + (format *error-output* + "~@<~S returned NIL on ~S's FTYPE: ~2I~_~S~@:>" + 'sb-ext:valid-type-specifier-p + s + ftype ) + (error "FAILURE"))))))) + +(with-test (:name (:bug-309128 1)) + (let* ((s (gensym)) + (t1 (sb-kernel:specifier-type s))) + (eval `(defstruct ,s)) + (multiple-value-bind (ok sure) + (sb-kernel:csubtypep t1 (sb-kernel:specifier-type s)) + (assert (and ok sure))))) + +(with-test (:name (:bug-309128 2)) + (let* ((s (gensym)) + (t1 (sb-kernel:specifier-type s))) + (eval `(defstruct ,s)) + (multiple-value-bind (ok sure) + (sb-kernel:csubtypep (sb-kernel:specifier-type s) t1) + (assert (and ok sure))))) + +(with-test (:name (:bug-309128 3)) + (let* ((s (gensym)) + (t1 (sb-kernel:specifier-type s)) + (s2 (gensym)) + (t2 (sb-kernel:specifier-type s2))) + (eval `(deftype ,s2 () ',s)) + (eval `(defstruct ,s)) + (multiple-value-bind (ok sure) (sb-kernel:csubtypep t1 t2) + (assert (and ok sure))))) + +(with-test (:name :unknown-type-not=-for-sure) + (let* ((type (gensym "FOO")) + (spec1 (sb-kernel:specifier-type `(vector ,type))) + (spec2 (sb-kernel:specifier-type `(vector single-float)))) + (eval `(deftype ,type () 'double-float)) + (multiple-value-bind (ok sure) (sb-kernel:type= spec1 spec2) + (assert (not ok)) + (assert sure)))) + +(defclass subtypep-fwd-test1 (subtypep-fwd-test-unknown1) ()) +(defclass subtypep-fwd-test2 (subtypep-fwd-test-unknown2) ()) +(defclass subtypep-fwd-testb1 (subtypep-fwd-testb-unknown1) ()) +(defclass subtypep-fwd-testb2 (subtypep-fwd-testb-unknown2 subtypep-fwd-testb1) ()) +(with-test (:name (:subtypep :forward-referenced-classes)) + (flet ((test (c1 c2 b1 b2) + (multiple-value-bind (x1 x2) (subtypep c1 c2) + (unless (and (eq b1 x1) (eq b2 x2)) + (error "(subtypep ~S ~S) => ~S, ~S but wanted ~S, ~S" + c1 c2 x1 x2 b1 b2))))) + (test 'subtypep-fwd-test1 'subtypep-fwd-test1 t t) + (test 'subtypep-fwd-test2 'subtypep-fwd-test2 t t) + (test 'subtypep-fwd-test1 'subtypep-fwd-test2 nil nil) + (test 'subtypep-fwd-test2 'subtypep-fwd-test1 nil nil) + + (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown1 t t) + (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown2 t t) + (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown2 nil nil) + (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown1 nil nil) + + (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown2 t t) + (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown1 t t) + (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown2 nil nil) + (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown1 nil nil) + + (test 'subtypep-fwd-testb1 'subtypep-fwd-testb2 nil nil) + (test 'subtypep-fwd-testb2 'subtypep-fwd-testb1 t t))) ;;; success -(quit :unix-status 104)