automate widetag dispatching

[sbcl.git] / src / code / cross-type.lisp

diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index 0ac13c9..e431dbb 100644 (file)
--- a/src/code/cross-type.lisp
+++ b/src/code/cross-type.lisp
@@ -108,7 +108,7 @@
 ;;; T unless it's certain) and the second value to tell whether it's
 ;;; certain.
 (defun cross-typep (host-object raw-target-type)
-  (let ((target-type (type-expand raw-target-type)))
+  (let ((target-type (typexpand raw-target-type)))
     (flet ((warn-and-give-up ()
            ;; We don't have to keep track of this as long as system
            ;; performance is acceptable, since giving up
@@ -162,6 +162,14 @@
              (target-type-is-in
               '(array simple-string simple-vector string vector))
              (values (typep host-object target-type) t))
+            (;; sequence is not guaranteed to be an exhaustive
+             ;; partition, but it includes at least lists and vectors.
+             (target-type-is-in '(sequence))
+             (if (or (vectorp host-object) (listp host-object))
+                 (values t t)
+                 (if (typep host-object target-type)
+                     (warn-and-give-up)
+                     (values nil t))))
             (;; general cases of vectors
              (and (not (hairy-type-p (values-specifier-type target-type)))
                   (sb!xc:subtypep target-type 'cl:vector))
@@ -206,12 +214,26 @@
                     (values (typep host-object target-type) t))
                    (t
                     (values nil t))))
-            (;; Complexes suffer the same kind of problems as arrays
+            (;; Complexes suffer the same kind of problems as arrays.
+             ;; Our dumping logic is based on contents, however, so
+             ;; reasoning about them should be safe
              (and (not (hairy-type-p (values-specifier-type target-type)))
                   (sb!xc:subtypep target-type 'cl:complex))
              (if (complexp host-object)
-                 (warn-and-give-up) ; general-case complexes being way too hard
-                 (values nil t))) ; but "obviously not a complex" being easy
+                 (let ((re (realpart host-object))
+                       (im (imagpart host-object)))
+                   (if (or (and (eq target-type 'complex)
+                                (typep re 'rational) (typep im 'rational))
+                           (and (equal target-type '(cl:complex single-float))
+                                (typep re 'single-float) (typep im 'single-float))
+                           (and (equal target-type '(cl:complex double-float))
+                                (typep re 'double-float) (typep im 'double-float)))
+                       (values t t)
+                       (progn
+                         ;; We won't know how to dump it either.
+                         (warn "Host complex too complex: ~S" host-object)
+                         (warn-and-give-up))))
+                 (values nil t)))
             ;; Some types require translation between the cross-compilation
             ;; host Common Lisp and the target SBCL.
             ((target-type-is-in '(classoid))
@@ -348,7 +370,7 @@
   ;; call TYPE=, that in turn may call CTYPEP). Until then, pick a few
   ;; cherries off.
   (cond ((member-type-p ctype)
-         (if (member obj (member-type-members ctype))
+         (if (member-type-member-p obj ctype)
              (values t t)
              (values nil t)))
         ((union-type-p ctype)