X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-type.lisp;h=e4031af9dbc84f53f2f96bd02d80328c5d5fa8ba;hb=8922e16df316133288d46695ff2d7596c397a6a0;hp=8110183ac757b2f772cf983eaae8d09d67e9ce83;hpb=be9eb6c67b5f43a095c3de17bea945c309d662e4;p=sbcl.git

diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index 8110183..e4031af 100644
--- a/src/code/cross-type.lisp
+++ b/src/code/cross-type.lisp
@@ -14,9 +14,7 @@
 ;;; Is X a fixnum in the target Lisp?
 (defun fixnump (x)
   (and (integerp x)
-       (<= sb!vm:*target-most-negative-fixnum*
-	   x
-	   sb!vm:*target-most-positive-fixnum*)))
+       (<= sb!xc:most-negative-fixnum x sb!xc:most-positive-fixnum)))
 
 ;;; (This was a useful warning when trying to get bootstrapping
 ;;; to work, but it's mostly irrelevant noise now that the system
@@ -68,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
@@ -200,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.
@@ -213,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))
@@ -274,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.