X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-type.lisp;h=40b785e336bd6520986a022893f5232e7f38d735;hb=22217256264c3a7af7dc03b9ffb1dd72a0c25368;hp=d699d4d9f79e7b11db074f91b1a1de415613b6d0;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index d699d4d..40b785e 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -11,6 +11,13 @@ (in-package "SB!IMPL") +;;; 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*))) + ;;; (This was a useful warning when trying to get bootstrapping ;;; to work, but it's mostly irrelevant noise now that the system ;;; works.) @@ -75,7 +82,7 @@ ((subtypep raw-result 'integer) (cond ((<= 0 object 1) 'bit) - ((target-fixnump object) + ((fixnump object) 'fixnum) (t 'integer))) @@ -85,12 +92,22 @@ (t (error "can't handle TYPE-OF ~S in cross-compilation")))))) -;;; Like TYPEP, but asks whether HOST-OBJECT would be of TARGET-TYPE -;;; when instantiated on the target SBCL. Since this is hard to decide -;;; in some cases, and since in other cases we just haven't bothered -;;; to try, it needs to return two values, just like SUBTYPEP: the -;;; first value for its conservative opinion (never T unless it's -;;; certain) and the second value to tell whether it's certain. +;;; 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 +;;; particular, it might be in the CL package even though +;;; SYMBOL-PACKAGE is not (FIND-PACKAGE :CL). So we test things +;;; another way. +(defun in-cl-package-p (symbol) + (eql (find-symbol (symbol-name symbol) :cl) + symbol)) + +;;; This is like TYPEP, except that it asks whether HOST-OBJECT would +;;; be of TARGET-TYPE when instantiated on the target SBCL. Since this +;;; is hard to determine in some cases, and since in other cases we +;;; just haven't bothered to try, it needs to return two values, just +;;; like SUBTYPEP: the first value for its conservative opinion (never +;;; T unless it's certain) and the second value to tell whether it's +;;; certain. (defun cross-typep (host-object target-type) (flet ((warn-and-give-up () ;; We don't have to keep track of this as long as system performance @@ -102,9 +119,10 @@ (warn-about-possible-float-info-loss () (warn-possible-cross-type-float-info-loss `(cross-typep ,host-object ,target-type)))) - (cond (;; Handle various SBCL-specific types which can't exist on the - ;; ANSI cross-compilation host. KLUDGE: This code will need to be - ;; tweaked by hand if the names of these types ever change, ugh! + (cond (;; Handle various SBCL-specific types which can't exist on + ;; the ANSI cross-compilation host. KLUDGE: This code will + ;; need to be tweaked by hand if the names of these types + ;; ever change, ugh! (if (consp target-type) (member (car target-type) '(sb!alien:alien)) @@ -113,11 +131,11 @@ funcallable-instance sb!alien-internals:alien-value))) (values nil t)) - (;; special case when TARGET-TYPE isn't a type spec, but instead - ;; a CLASS object + (;; 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 + ;; 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) @@ -155,31 +173,32 @@ ;; between any host ANSI Common Lisp and the target SBCL. ((integer member mod rational real signed-byte unsigned-byte) (values (typep host-object target-type) t)) - ;; Floating point types are guaranteed to correspond, too, but - ;; less exactly. + ;; Floating point types are guaranteed to correspond, + ;; too, but less exactly. ((single-float double-float) (cond ((floatp host-object) (warn-about-possible-float-info-loss) (values (typep host-object target-type) t)) (t (values nil t)))) - ;; Some complex types have translations that are less trivial. - (and - ;; Note: This could be implemented as a real test, just the way - ;; that OR is; I just haven't bothered. -- WHN 19990706 - (warn-and-give-up)) - (or (let ((opinion nil) - (certain-p t)) - (dolist (i rest) - (multiple-value-bind (sub-opinion sub-certain-p) - (cross-typep host-object i) - (cond (sub-opinion (setf opinion t - certain-p t) - (return)) - ((not sub-certain-p) (setf certain-p nil)))) - (if certain-p - (values opinion t) - (warn-and-give-up))))) + ;; Some complex types have translations that are less + ;; trivial. + (and (every/type #'cross-typep host-object rest)) + (or (any/type #'cross-typep host-object rest)) + ;; If we want to work with the KEYWORD type, we need + ;; to grok (SATISFIES KEYWORDP). + (satisfies + (destructuring-bind (predicate-name) rest + (if (and (in-cl-package-p predicate-name) + (fboundp predicate-name)) + ;; Many things like KEYWORDP, ODDP, PACKAGEP, + ;; and NULL correspond between host and target. + (values (not (null (funcall predicate-name host-object))) + t) + ;; For symbols not in the CL package, it's not + ;; in general clear how things correspond + ;; between host and target, so we punt. + (warn-and-give-up)))) ;; Some complex types are too hard to handle in the positive ;; case, but at least we can be confident in a large fraction of ;; the negative cases.. @@ -199,8 +218,8 @@ (if (functionp host-object) (warn-and-give-up) (values nil t))) - ;; And the Common Lisp type system is complicated, and we don't - ;; try to implement everything. + ;; And the Common Lisp type system is complicated, and + ;; we don't try to implement everything. (otherwise (warn-and-give-up))))) (t (case target-type @@ -221,11 +240,12 @@ ;; between any host ANSI Common Lisp and the target ;; Common Lisp. (Some array types are too, but they ;; were picked off earlier.) - ((bit character complex cons float function integer list nil - null number rational real signed-byte symbol t unsigned-byte) + ((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. + ;; Floating point types are guaranteed to correspond, + ;; too, but less exactly. ((single-float double-float) (cond ((floatp host-object) (warn-about-possible-float-info-loss) @@ -235,10 +255,10 @@ ;; Some types require translation between the cross-compilation ;; host Common Lisp and the target SBCL. (sb!xc:class (values (typep host-object 'sb!xc:class) t)) - (fixnum (values (target-fixnump host-object) t)) - ;; Some types are too hard to handle in the positive case, but at - ;; least we can be confident in a large fraction of the negative - ;; cases.. + (fixnum (values (fixnump host-object) t)) + ;; Some types are too hard to handle in the positive + ;; case, but at least we can be confident in a large + ;; fraction of the negative cases.. ((base-string simple-base-string simple-string) (if (stringp host-object) (warn-and-give-up) @@ -251,19 +271,21 @@ (t (warn-and-give-up)))) ((stream instance) - ;; Neither target CL:STREAM nor target SB!KERNEL:INSTANCE is - ;; implemented as a STRUCTURE-OBJECT, so they'll fall through the - ;; tests above. We don't want to assume too much about them here, - ;; but at least we know enough about them to say that neither T - ;; nor NIL nor indeed any other symbol in the cross-compilation - ;; host is one. That knowledge suffices to answer so many of the - ;; questions that the cross-compiler asks that it's well worth + ;; Neither target CL:STREAM nor target + ;; SB!KERNEL:INSTANCE is implemented as a + ;; STRUCTURE-OBJECT, so they'll fall through the tests + ;; above. We don't want to assume too much about them + ;; here, but at least we know enough about them to say + ;; that neither T nor NIL nor indeed any other symbol in + ;; the cross-compilation host is one. That knowledge + ;; suffices to answer so many of the questions that the + ;; cross-compiler asks that it's well worth ;; special-casing it here. (if (symbolp host-object) (values nil t) (warn-and-give-up))) - ;; And the Common Lisp type system is complicated, and we don't - ;; try to implement everything. + ;; And the Common Lisp type system is complicated, and we + ;; don't try to implement everything. (otherwise (warn-and-give-up))))))) ;;; An incomplete TYPEP which runs at cross-compile time to tell whether OBJECT