;;; 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)))
+ ((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
;; 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))
(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.
(check-type type (or symbol cons))
(cross-typep obj type)))
-(defparameter *universal-function-type*
- (make-function-type :wild-args t
- :returns *wild-type*))
-
(defun ctype-of (x)
(typecase x
(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*))
+ *universal-fun-type*))
(symbol
(make-member-type :members (list x)))
(number