X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcross-type.lisp;h=d699d4d9f79e7b11db074f91b1a1de415613b6d0;hb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;hp=9e16a6faaa4abd24b8ce01428cb3db11dfd7f95e;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 9e16a6f..d699d4d 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -11,9 +11,6 @@ (in-package "SB!IMPL") -(file-comment - "$Header$") - ;;; (This was a useful warning when trying to get bootstrapping ;;; to work, but it's mostly irrelevant noise now that the system ;;; works.) @@ -39,21 +36,22 @@ #+cmu :reader #+cmu #.(gensym) ; (to stop bogus non-STYLE WARNING) ))) -;;; This warning refers to the flexibility in the ANSI spec with regard to -;;; run-time distinctions between floating point types. (E.g. the -;;; cross-compilation host might not even distinguish between SINGLE-FLOAT and -;;; DOUBLE-FLOAT, so a DOUBLE-FLOAT number would test positive as -;;; SINGLE-FLOAT.) If the target SBCL does make this distinction, then -;;; information is lost. It's not too hard to contrive situations where this -;;; would be a problem. In practice we don't tend to run into them because all -;;; widely used Common Lisp environments do recognize the distinction between -;;; SINGLE-FLOAT and DOUBLE-FLOAT, and we don't really need the other -;;; distinctions (e.g. between SHORT-FLOAT and SINGLE-FLOAT), so we call -;;; WARN-POSSIBLE-CROSS-TYPE-FLOAT-INFO-LOSS to test at runtime whether -;;; we need to worry about this at all, and not warn unless we do. If we *do* -;;; have to worry about this at runtime, my (WHN 19990808) guess is that -;;; the system will break in multiple places, so this is a real -;;; WARNING, not just a STYLE-WARNING. +;;; This warning refers to the flexibility in the ANSI spec with +;;; regard to run-time distinctions between floating point types. +;;; (E.g. the cross-compilation host might not even distinguish +;;; between SINGLE-FLOAT and DOUBLE-FLOAT, so a DOUBLE-FLOAT number +;;; would test positive as SINGLE-FLOAT.) If the target SBCL does make +;;; this distinction, then information is lost. It's not too hard to +;;; contrive situations where this would be a problem. In practice we +;;; don't tend to run into them because all widely used Common Lisp +;;; environments do recognize the distinction between SINGLE-FLOAT and +;;; DOUBLE-FLOAT, and we don't really need the other distinctions +;;; (e.g. between SHORT-FLOAT and SINGLE-FLOAT), so we call +;;; WARN-POSSIBLE-CROSS-TYPE-FLOAT-INFO-LOSS to test at runtime +;;; whether we need to worry about this at all, and not warn unless we +;;; do. If we *do* have to worry about this at runtime, my (WHN +;;; 19990808) guess is that the system will break in multiple places, +;;; so this is a real WARNING, not just a STYLE-WARNING. ;;; ;;; KLUDGE: If we ever try to support LONG-FLOAT or SHORT-FLOAT, this ;;; situation will get a lot more complicated. @@ -63,9 +61,10 @@ (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. + (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) @@ -86,12 +85,12 @@ (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. +;;; 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. (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 @@ -114,13 +113,15 @@ funcallable-instance sb!alien-internals:alien-value))) (values nil t)) - ((typep target-type 'sb!xc::structure-class) + (;; 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))) + (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)) @@ -130,11 +131,22 @@ (sb!xc:subtypep target-type 'cl:structure-object) (typep host-object '(or symbol number list character))) (values nil t)) - ((and (not (unknown-type-p (values-specifier-type target-type))) + (;; easy cases of arrays and vectors + (member target-type + '(array simple-string simple-vector string vector)) + (values (typep host-object target-type) t)) + (;; general cases of vectors + (and (not (unknown-type-p (values-specifier-type target-type))) + (sb!xc:subtypep target-type 'cl:vector)) + (if (vectorp host-object) + (warn-and-give-up) ; general case of vectors being way too hard + (values nil t))) ; but "obviously not a vector" being easy + (;; general cases of arrays + (and (not (unknown-type-p (values-specifier-type target-type))) (sb!xc:subtypep target-type 'cl:array)) (if (arrayp host-object) - (warn-and-give-up) ; general case of arrays being way too hard - (values nil t))) ; but "obviously not an array" being easy + (warn-and-give-up) ; general case of arrays being way too hard + (values nil t))) ; but "obviously not an array" being easy ((consp target-type) (let ((first (first target-type)) (rest (rest target-type))) @@ -166,23 +178,27 @@ (return)) ((not sub-certain-p) (setf certain-p nil)))) (if certain-p - (values opinion t) - (warn-and-give-up))))) + (values opinion t) + (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.. ((base-string simple-base-string simple-string) (if (stringp host-object) - (warn-and-give-up) - (values nil t))) - ((array simple-array simple-vector vector) + (warn-and-give-up) + (values nil t))) + ((vector simple-vector) + (if (vectorp host-object) + (warn-and-give-up) + (values nil t))) + ((array simple-array) (if (arrayp host-object) - (warn-and-give-up) - (values nil t))) + (warn-and-give-up) + (values nil t))) (function (if (functionp host-object) - (warn-and-give-up) - (values nil t))) + (warn-and-give-up) + (values nil t))) ;; And the Common Lisp type system is complicated, and we don't ;; try to implement everything. (otherwise (warn-and-give-up))))) @@ -201,11 +217,12 @@ ;; assertion: (assert (typep (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. - ((array bit character complex cons float function integer list - nil null number rational real signed-byte string symbol t - unsigned-byte vector) + ;; 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.) + ((bit character complex cons float function integer 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. @@ -224,8 +241,8 @@ ;; cases.. ((base-string simple-base-string simple-string) (if (stringp host-object) - (warn-and-give-up) - (values nil t))) + (warn-and-give-up) + (values nil t))) ((character base-char) (cond ((typep host-object 'standard-char) (values t t)) @@ -243,8 +260,8 @@ ;; 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))) + (values nil t) + (warn-and-give-up))) ;; And the Common Lisp type system is complicated, and we don't ;; try to implement everything. (otherwise (warn-and-give-up))))))) @@ -262,10 +279,10 @@ ;; A program that calls TYPEP doesn't want uncertainty and probably ;; can't handle it. (if certain-p - opinion - (error "uncertain in SB!XC:TYPEP ~S ~S" - host-object - target-type-spec)))) + opinion + (error "uncertain in SB!XC:TYPEP ~S ~S" + host-object + target-type-spec)))) ;;; This implementation is an incomplete, portable version for use at ;;; cross-compile time only. @@ -284,12 +301,14 @@ (typecase x (function (if (typep x 'generic-function) - ;; Since at cross-compile time we build a CLOS-free bootstrap version of - ;; SBCL, it's unclear how to explain to it what a generic function is. - (error "not implemented: cross CTYPE-OF generic function") - ;; 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*)) + ;; Since at cross-compile time we build a CLOS-free bootstrap + ;; version of SBCL, it's unclear how to explain to it what a + ;; generic function is. + (error "not implemented: cross CTYPE-OF generic function") + ;; 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*)) (symbol (make-member-type :members (list x))) (number @@ -317,7 +336,7 @@ :complexp (not (typep x 'simple-array)) :element-type etype :specialized-element-type etype))) - (cons (sb!xc:find-class 'cons)) + (cons (specifier-type 'cons)) (character (cond ((typep x 'standard-char) ;; (Note that SBCL doesn't distinguish between BASE-CHAR and @@ -331,7 +350,9 @@ (structure!object (sb!xc:find-class (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 cases for bootstrapping, we - ;; don't try to be complete here. -- WHN 19990512 + ;; There might be more cases which we could handle with + ;; sufficient effort; since all we *need* to handle are enough + ;; cases for bootstrapping, we don't try to be complete here,. If + ;; future maintainers make the bootstrap code more complicated, + ;; they can also add new cases here to handle it. -- WHN 2000-11-11 (error "can't handle ~S in cross CTYPE-OF" x))))