X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-type.lisp;h=e431dbb0ba3950daf45579d216a9ea7950cc3e24;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=c68b2ce5c772942ede9b03e49ee271719e5f3920;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index c68b2ce..e431dbb 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
@@ -143,7 +143,6 @@
                          '(sb!alien:alien))
                  (member target-type
                          '(system-area-pointer
-                           funcallable-instance
                            sb!alien-internals:alien-value)))
              (values nil t))
             (;; special case when TARGET-TYPE isn't a type spec, but
@@ -163,14 +162,22 @@
              (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 (unknown-type-p (values-specifier-type target-type)))
+             (and (not (hairy-type-p (values-specifier-type target-type)))
                   (sb!xc:subtypep target-type 'cl:vector))
              (if (vectorp host-object)
                  (warn-and-give-up) ; general-case vectors being way too hard
                  (values nil t))) ; but "obviously not a vector" being easy
             (;; general cases of arrays
-             (and (not (unknown-type-p (values-specifier-type target-type)))
+             (and (not (hairy-type-p (values-specifier-type target-type)))
                   (sb!xc:subtypep target-type 'cl:array))
              (if (arrayp host-object)
                  (warn-and-give-up) ; general-case arrays being way too hard
@@ -207,12 +214,26 @@
                     (values (typep host-object target-type) t))
                    (t
                     (values nil t))))
-            (;; Complexes suffer the same kind of problems as arrays
-             (and (not (unknown-type-p (values-specifier-type target-type)))
+            (;; 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))
@@ -342,10 +363,23 @@
 ;;; cross-compile time only.
 (defun ctypep (obj ctype)
   (check-type ctype ctype)
-  (let (;; the Common Lisp type specifier corresponding to CTYPE
-        (type (type-specifier ctype)))
-    (check-type type (or symbol cons))
-    (cross-typep obj type)))
+  ;; There is at least one possible endless recursion in the
+  ;; cross-compiler type system: (SUBTYPEP NULL (OR UNKOWN0 UNKNOWN1)
+  ;; runs out of stack. The right way would probably be to not
+  ;; implement CTYPEP in terms of TYPE-SPECIFIER (:UNPARSE, that may
+  ;; call TYPE=, that in turn may call CTYPEP). Until then, pick a few
+  ;; cherries off.
+  (cond ((member-type-p ctype)
+         (if (member-type-member-p obj ctype)
+             (values t t)
+             (values nil t)))
+        ((union-type-p ctype)
+         (any/type #'ctypep obj (union-type-types ctype)))
+        (t
+         (let ( ;; the Common Lisp type specifier corresponding to CTYPE
+               (type (type-specifier ctype)))
+           (check-type type (or symbol cons))
+           (cross-typep obj type)))))
 
 (defun ctype-of (x)
   (typecase x