0.7.9.47:

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

diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index cfb1a78..e4031af 100644 (file)
--- a/src/code/cross-type.lisp
+++ b/src/code/cross-type.lisp
@@ -66,29 +66,27 @@
     (warn "possible floating point information loss in ~S" call)))
 
 (defun sb!xc:type-of (object)
-  (labels (;; FIXME: This function is a no-op now that we no longer
-          ;; have a distinct package T%CL to translate
-          ;; for-the-target-Lisp CL symbols to, and should go away
-          ;; completely.
-          (translate (expr) expr))
-    (let ((raw-result (type-of object)))
-      (cond ((or (subtypep raw-result 'float)
-                (subtypep raw-result 'complex))
-            (warn-possible-cross-type-float-info-loss
-             `(sb!xc:type-of ,object))
-            (translate raw-result))
-           ((subtypep raw-result 'integer)
-            (cond ((<= 0 object 1)
-                   'bit)
-                  ((fixnump object)
-                   'fixnum)
-                  (t
-                   'integer)))
-           ((some (lambda (type) (subtypep raw-result type))
-                  '(array character list symbol))
-            (translate raw-result))
-           (t
-            (error "can't handle TYPE-OF ~S in cross-compilation"))))))
+  (let ((raw-result (type-of object)))
+    (cond ((or (subtypep raw-result 'float)
+              (subtypep raw-result 'complex))
+          (warn-possible-cross-type-float-info-loss
+           `(sb!xc:type-of ,object))
+          raw-result)
+         ((subtypep raw-result 'integer)
+          (cond ((<= 0 object 1)
+                 'bit)
+                (;; We can't rely on the host's opinion of whether
+                 ;; it's a FIXNUM, but instead test against target
+                 ;; MOST-fooITIVE-FIXNUM limits.
+                 (fixnump object)
+                 'fixnum)
+                (t
+                 'integer)))
+         ((some (lambda (type) (subtypep raw-result type))
+                '(array character list symbol))
+          raw-result)
+         (t
+          (error "can't handle TYPE-OF ~S in cross-compilation")))))
 
 ;;; Is SYMBOL in the CL package? Note that we're testing this on the
 ;;; cross-compilation host, which could do things any old way. In
@@ -198,9 +196,9 @@
             ;; Common Lisp. (Some array types are too, but they
             ;; were picked off earlier.)
             (target-type-is-in
-             '(bit character complex cons float function integer keyword
-                   list nil null number rational real signed-byte symbol t
-                   unsigned-byte))
+             '(atom bit character complex cons float function integer keyword
+               list nil null number rational real signed-byte symbol t
+               unsigned-byte))
             (values (typep host-object target-type) t))
            (;; Floating point types are guaranteed to correspond,
             ;; too, but less exactly.
@@ -211,6 +209,12 @@
                    (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)))
+                 (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
            ;; Some types require translation between the cross-compilation
            ;; host Common Lisp and the target SBCL.
            ((target-type-is-in '(sb!xc:class))
@@ -272,11 +276,20 @@
                  (destructuring-bind (predicate-name) rest
                    (if (and (in-cl-package-p predicate-name)
                             (fboundp predicate-name))
-                       ;; Many things like KEYWORDP, ODDP, PACKAGEP,
+                       ;; Many predicates like KEYWORDP, ODDP, PACKAGEP,
                        ;; and NULL correspond between host and target.
-                       (values (not (null (funcall predicate-name
-                                                   host-object)))
-                               t)
+                       ;; But we still need to handle errors, because
+                       ;; the code which calls us may not understand
+                       ;; that a type is unreachable. (E.g. when compiling
+                       ;; (AND STRING (SATISFIES ARRAY-HAS-FILL-POINTER-P))
+                       ;; CTYPEP may be called on the SATISFIES expression
+                       ;; even for non-STRINGs.)
+                       (multiple-value-bind (result error?)
+                           (ignore-errors (funcall predicate-name
+                                                   host-object))
+                         (if error?
+                             (values nil nil)
+                             (values result t)))
                        ;; For symbols not in the CL package, it's not
                        ;; in general clear how things correspond
                        ;; between host and target, so we punt.