X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-type.lisp;h=1aefd7f391619a30a527a767253f1f0bdfe10801;hb=063f2d867cfdfee8a7cbab17e6c5054d9c6f3ad1;hp=e4031af9dbc84f53f2f96bd02d80328c5d5fa8ba;hpb=42b8c7570a2faa21529fadeef84a0caea186aa8c;p=sbcl.git

diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp
index e4031af..1aefd7f 100644
--- a/src/code/cross-type.lisp
+++ b/src/code/cross-type.lisp
@@ -86,7 +86,7 @@
 		 '(array character list symbol))
 	   raw-result)
 	  (t
-	   (error "can't handle TYPE-OF ~S in cross-compilation")))))
+	   (error "can't handle TYPE-OF ~S in cross-compilation" object)))))
 
 ;;; 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
@@ -144,23 +144,18 @@
 			   sb!alien-internals:alien-value)))
 	     (values nil t))
 	    (;; special case when TARGET-TYPE isn't a type spec, but
-	     ;; instead a CLASS object
-	     (typep target-type 'sb!xc::structure-class)
-	     ;; SBCL-specific types which have an analogue specially
-	     ;; created on the host system
-	     (if (sb!xc:subtypep (sb!xc:class-name target-type)
-				 'sb!kernel::structure!object)
-		 (values (typep host-object (sb!xc:class-name target-type)) t)
-		 (values nil t)))
-	    ((and (symbolp target-type)
-		  (find-class target-type nil)
-		  (subtypep target-type 'sb!kernel::structure!object))
-	     (values (typep host-object target-type) t))
+	     ;; instead a CLASS object.
+	     (typep target-type 'class)
+	     (bug "We don't support CROSS-TYPEP of CLASS type specifiers"))
 	    ((and (symbolp target-type)
-		  (sb!xc:find-class target-type nil)
+		  (find-classoid target-type nil)
 		  (sb!xc:subtypep target-type 'cl:structure-object)
 		  (typep host-object '(or symbol number list character)))
 	     (values nil t))
+	    ((and (symbolp target-type)
+		  (find-class target-type nil)
+		  (subtypep target-type 'sb!kernel::structure!object))
+	     (values (typep host-object target-type) t))
 	    (;; easy cases of arrays and vectors
 	     (target-type-is-in
 	      '(array simple-string simple-vector string vector))
@@ -189,7 +184,7 @@
 	     ;; we don't continue doing it after we someday patch
 	     ;; SBCL's type system so that * is no longer a type, we
 	     ;; make this assertion. -- WHN 2001-08-08
-	     (aver (typep (specifier-type '*) 'named-type))
+	     (aver (typep (values-specifier-type '*) 'named-type))
 	     (values t t))
 	    (;; Many simple types are guaranteed to correspond exactly
 	     ;; between any host ANSI Common Lisp and the target
@@ -217,8 +212,8 @@
 		 (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))
-	     (values (typep host-object 'sb!xc:class) t))
+	    ((target-type-is-in '(classoid))
+	     (values (typep host-object 'classoid) t))
 	    ((target-type-is-in '(fixnum))
 	     (values (fixnump host-object) t))
 	    ;; Some types are too hard to handle in the positive
@@ -365,6 +360,11 @@
      (make-member-type :members (list x)))
     (number
      (ctype-of-number x))
+    (string
+     (make-array-type :dimensions (array-dimensions x)
+                      :complexp (not (typep x 'simple-array))
+                      :element-type (specifier-type 'base-char)
+                      :specialized-element-type (specifier-type 'base-char)))
     (array
      (let ((etype (specifier-type (array-element-type x))))
        (make-array-type :dimensions (array-dimensions x)
@@ -376,14 +376,14 @@
      (cond ((typep x 'standard-char)
 	    ;; (Note that SBCL doesn't distinguish between BASE-CHAR and
 	    ;; CHARACTER.)
-	    (sb!xc:find-class 'base-char))
+	    (specifier-type 'base-char))
 	   ((not (characterp x))
 	    nil)
 	   (t
 	    ;; Beyond this, there seems to be no portable correspondence.
 	    (error "can't map host Lisp CHARACTER ~S to target Lisp" x))))
     (structure!object
-     (sb!xc:find-class (uncross (class-name (class-of x)))))
+     (find-classoid (uncross (class-name (class-of x)))))
     (t
      ;; There might be more cases which we could handle with
      ;; sufficient effort; since all we *need* to handle are enough