X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-type.lisp;h=557f6db0b0e7bba54654c095b7b4f59752133d4d;hb=860543cc7ba0266e41e1d41ac9b6a208f3795f1a;hp=6af03880038a9c542ac17903948bb33b2f392b85;hpb=7c07a6f965c51828d8f452b47e0620d8e6cf2959;p=sbcl.git diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 6af0388..557f6db 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 @@ -148,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))) + ;; instead a CLASS object. + (typep target-type 'class) + (bug "We don't support CROSS-TYPEP of CLASS type specifiers")) ((and (symbolp target-type) - (find-class target-type nil) - (subtypep target-type 'sb!kernel::structure!object)) - (values (typep host-object target-type) t)) - ((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)) @@ -193,16 +184,16 @@ ;; 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 ;; 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,10 +204,16 @@ (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)) - (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 @@ -274,11 +271,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. @@ -349,7 +355,7 @@ ;; There's no ANSI way to find out what the function is ;; declared to be, so we just return the CTYPE for the ;; most-general function. - *universal-function-type*)) + *universal-fun-type*)) (symbol (make-member-type :members (list x))) (number @@ -365,14 +371,14 @@ (cond ((typep x 'standard-char) ;; (Note that SBCL doesn't distinguish between BASE-CHAR and ;; CHARACTER.) - (sb!xc:find-class 'base-char)) + (find-classoid '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