;;; 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
(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)))
+ ((subtypep raw-result 'simple-string)
+ `(simple-base-string ,(length object)))
+ ((subtypep raw-result 'string) 'base-string)
+ ((some (lambda (type) (subtypep raw-result type))
+ '(array character list symbol))
+ raw-result)
+ (t
+ (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
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))
;; 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.
(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
(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.
;; 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
(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)
(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
projects / sbcl.git / blobdiff