+;; 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-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)))
+
+ (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))))
+
+ ;; 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)))))
+;;; 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
+#|| Pending fix for bug 176, bug 140 has been unfixed
+;;; Redefinition of classes should alter the type hierarchy (BUG 140):
+(defclass 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))
+\f