(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" 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)))
- ((and (symbolp target-type)
- (find-class target-type nil)
- (subtypep target-type 'sb!kernel::structure!object))
- (values (typep host-object target-type) t))
+ ;; instead a CLASS object.
+ (typep target-type 'class)
+ (bug "We don't support CROSS-TYPEP of CLASS type specifiers"))
((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
(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.
(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