-(fmakunbound 'test-inline-type-tests)
-(defun test-inline-type-tests ()
- ;; structure type tests
- (assert (typep (make-structure-foo3) 'structure-foo2))
- (assert (not (typep (make-structure-foo1) 'structure-foo4)))
- (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-kernel: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)))
- (assert (null (set-difference
- (sb-pcl:class-direct-subclasses (sb-pcl:find-class
- 'simple-condition))
- (mapcar #'sb-pcl:find-class '(simple-type-error simple-error
- sb-int:simple-style-warning)))))
-
- ;; 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))))
-
- ;; stream classes
- (assert (null (sb-kernel:class-direct-superclasses (find-class
- 'fundamental-stream))))
- (assert (equal (sb-pcl:class-direct-superclasses (sb-pcl:find-class
- 'fundamental-stream))
- (mapcar #'sb-pcl:find-class '(standard-object stream))))
- (assert (null (set-difference
- (sb-pcl:class-direct-subclasses (sb-pcl: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
- '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
- '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 (subtypep (find-class 'stream) (find-class t)))
- (assert (subtypep (find-class 'fundamental-stream) 'stream))
- (assert (not (subtypep 'stream 'fundamental-stream))))
-
-;;; inline-type tests:
-;;; Test the interpreted version.
-(test-inline-type-tests)
-;;; Test the compiled version.
-(compile nil #'test-inline-type-tests)
-(test-inline-type-tests)
+;;; 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)~%")
+\f
+;;; 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))
+\f
+;;; 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))))
+\f
+;;; 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))))
+\f
+;;; 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))))))
+\f
+(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)))
+\f
+;;; 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))
+\f
+;;; 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)))
+\f
+;;; 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)))))
+\f
+;;; 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))))
+\f
+(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))