0.9.14.21:

[sbcl.git] / tests / type.impure.lisp

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index 0b7bb17..1ab5a2c 100644 (file)
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -11,6 +11,7 @@
 
 (load "assertoid.lisp")
 (use-package "ASSERTOID")
+(use-package "TEST-UTIL")
 
 (defmacro assert-nil-nil (expr)
   `(assert (equal '(nil nil) (multiple-value-list ,expr))))
@@ -353,7 +354,6 @@
                     (mapcar #'find-class '(simple-condition
                                            condition
                                            sb-pcl::slot-object
-                                           sb-kernel:instance
                                            t))))
 
      ;; stream classes
@@ -371,18 +371,15 @@
                                                    'fundamental-stream))
                     (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 #'find-class '(fundamental-stream
                                            standard-object
-                                           sb-pcl::std-object
                                            sb-pcl::slot-object stream
-                                           sb-kernel:instance t))))
+                                           t))))
      (assert (subtypep (find-class 'stream) (find-class t)))
      (assert (subtypep (find-class 'fundamental-stream) 'stream))
      (assert (not (subtypep 'stream 'fundamental-stream)))))
@@ -429,4 +426,78 @@
   (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)
+                        'function))))
+(with-test (:name (:ctor :functionp))
+  (assert (functionp (sb-pcl::ensure-ctor
+                      (list 'sb-pcl::ctor (gensym)) 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
 ;;; success