;;; T unless it's certain) and the second value to tell whether it's
;;; certain.
(defun cross-typep (host-object raw-target-type)
- (let ((target-type (type-expand raw-target-type)))
+ (let ((target-type (typexpand raw-target-type)))
(flet ((warn-and-give-up ()
;; We don't have to keep track of this as long as system
;; performance is acceptable, since giving up
'(sb!alien:alien))
(member target-type
'(system-area-pointer
- funcallable-instance
sb!alien-internals:alien-value)))
(values nil t))
(;; special case when TARGET-TYPE isn't a type spec, but
(target-type-is-in
'(array simple-string simple-vector string vector))
(values (typep host-object target-type) t))
+ (;; sequence is not guaranteed to be an exhaustive
+ ;; partition, but it includes at least lists and vectors.
+ (target-type-is-in '(sequence))
+ (if (or (vectorp host-object) (listp host-object))
+ (values t t)
+ (if (typep host-object target-type)
+ (warn-and-give-up)
+ (values nil t))))
(;; general cases of vectors
- (and (not (unknown-type-p (values-specifier-type target-type)))
+ (and (not (hairy-type-p (values-specifier-type target-type)))
(sb!xc:subtypep target-type 'cl:vector))
(if (vectorp host-object)
(warn-and-give-up) ; general-case 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)))
+ (and (not (hairy-type-p (values-specifier-type target-type)))
(sb!xc:subtypep target-type 'cl:array))
(if (arrayp host-object)
(warn-and-give-up) ; general-case arrays being way too hard
(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)))
+ (;; Complexes suffer the same kind of problems as arrays.
+ ;; Our dumping logic is based on contents, however, so
+ ;; reasoning about them should be safe
+ (and (not (hairy-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
+ (let ((re (realpart host-object))
+ (im (imagpart host-object)))
+ (if (or (and (eq target-type 'complex)
+ (typep re 'rational) (typep im 'rational))
+ (and (equal target-type '(cl:complex single-float))
+ (typep re 'single-float) (typep im 'single-float))
+ (and (equal target-type '(cl:complex double-float))
+ (typep re 'double-float) (typep im 'double-float)))
+ (values t t)
+ (progn
+ ;; We won't know how to dump it either.
+ (warn "Host complex too complex: ~S" host-object)
+ (warn-and-give-up))))
+ (values nil t)))
;; Some types require translation between the cross-compilation
;; host Common Lisp and the target SBCL.
((target-type-is-in '(classoid))
(if (stringp host-object)
(warn-and-give-up)
(values nil t)))
- ((target-type-is-in '(character base-char))
+ ((target-type-is-in '(character base-char standard-char))
(cond ((typep host-object 'standard-char)
(values t t))
((not (characterp host-object))
;; trivial.
(and (every/type #'cross-typep host-object rest))
(or (any/type #'cross-typep host-object rest))
+ (not
+ (multiple-value-bind (value surep)
+ (cross-typep host-object (car rest))
+ (if surep
+ (values (not value) t)
+ (warn-and-give-up))))
;; If we want to work with the KEYWORD type, we need
;; to grok (SATISFIES KEYWORDP).
(satisfies
;;; cross-compile time only.
(defun ctypep (obj ctype)
(check-type ctype ctype)
- (let (;; the Common Lisp type specifier corresponding to CTYPE
- (type (type-specifier ctype)))
- (check-type type (or symbol cons))
- (cross-typep obj type)))
+ ;; There is at least one possible endless recursion in the
+ ;; cross-compiler type system: (SUBTYPEP NULL (OR UNKOWN0 UNKNOWN1)
+ ;; runs out of stack. The right way would probably be to not
+ ;; implement CTYPEP in terms of TYPE-SPECIFIER (:UNPARSE, that may
+ ;; call TYPE=, that in turn may call CTYPEP). Until then, pick a few
+ ;; cherries off.
+ (cond ((member-type-p ctype)
+ (if (member-type-member-p obj ctype)
+ (values t t)
+ (values nil t)))
+ ((union-type-p ctype)
+ (any/type #'ctypep obj (union-type-types ctype)))
+ (t
+ (let ( ;; the Common Lisp type specifier corresponding to CTYPE
+ (type (type-specifier ctype)))
+ (check-type type (or symbol cons))
+ (cross-typep obj type)))))
(defun ctype-of (x)
(typecase x
projects / sbcl.git / blobdiff