X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-type.lisp;h=72d50923e9ab887aea612fe9b8115eb4885acd01;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=0ac13c9d52e46e120b36f20372daca42a1c0d46c;hpb=cd8fe50554652680dde36396d7862fc6cc83839c;p=sbcl.git

diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index 0ac13c9..72d5092 100644
--- 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))
@@ -226,7 +248,7 @@
              (if (stringp host-object)
                  (warn-and-give-up)
                  (values nil t)))
-            ((target-type-is-in '(character base-char))
+            ((target-type-is-in '(character base-char standard-char))
              (cond ((typep host-object 'standard-char)
                     (values t t))
                    ((not (characterp host-object))
@@ -267,6 +289,12 @@
                  ;; trivial.
                  (and (every/type #'cross-typep host-object rest))
                  (or  (any/type   #'cross-typep host-object rest))
+                 (not
+                  (multiple-value-bind (value surep)
+                      (cross-typep host-object (car rest))
+                    (if surep
+                        (values (not value) t)
+                        (warn-and-give-up))))
                  ;; If we want to work with the KEYWORD type, we need
                  ;; to grok (SATISFIES KEYWORDP).
                  (satisfies
@@ -348,7 +376,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)