-(defun extract-upgraded-element-type (array)
- (let ((type (lvar-type array)))
- (cond
- ;; Note that this IF mightn't be satisfied even if the runtime
- ;; value is known to be a subtype of some specialized ARRAY, because
- ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
- ;; which are represented in the compiler as INTERSECTION-TYPE, not
- ;; array type.
- ((array-type-p type)
- (values (array-type-specialized-element-type type) nil))
- ;; fix for bug #396. This type logic corresponds to the special case for
- ;; strings in HAIRY-DATA-VECTOR-REF (generic/vm-tran.lisp)
- ((csubtypep type (specifier-type 'string))
- (cond
- ((csubtypep type (specifier-type '(array character (*))))
- (values (specifier-type 'character) nil))
- #!+sb-unicode
- ((csubtypep type (specifier-type '(array base-char (*))))
- (values (specifier-type 'base-char) nil))
- ((csubtypep type (specifier-type '(array nil (*))))
- (values *empty-type* nil))
- (t
- ;; See KLUDGE below.
- (values *wild-type* (specifier-type 'character)))))
- (t
- ;; KLUDGE: there is no good answer here, but at least
- ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
- ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
- ;; 2002-08-21
- (values *wild-type* nil)))))
+(defun array-type-upgraded-element-type (type)
+ (typecase type
+ ;; Note that this IF mightn't be satisfied even if the runtime
+ ;; value is known to be a subtype of some specialized ARRAY, because
+ ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
+ ;; which are represented in the compiler as INTERSECTION-TYPE, not
+ ;; array type.
+ (array-type
+ (values (array-type-specialized-element-type type) nil))
+ ;; Deal with intersection types (bug #316078)
+ (intersection-type
+ (let ((intersection-types (intersection-type-types type))
+ (element-type *wild-type*)
+ (element-supertypes nil))
+ (dolist (intersection-type intersection-types)
+ (multiple-value-bind (cur-type cur-supertype)
+ (array-type-upgraded-element-type intersection-type)
+ ;; According to ANSI, an array may have only one specialized
+ ;; element type - e.g. '(and (array foo) (array bar))
+ ;; is not a valid type unless foo and bar upgrade to the
+ ;; same element type.
+ (cond
+ ((eq cur-type *wild-type*)
+ nil)
+ ((eq element-type *wild-type*)
+ (setf element-type cur-type))
+ ((or (not (csubtypep cur-type element-type))
+ (not (csubtypep element-type cur-type)))
+ ;; At least two different element types where given, the array
+ ;; is valid iff they represent the same type.
+ ;;
+ ;; FIXME: TYPE-INTERSECTION already takes care of disjoint array
+ ;; types, so I believe this code should be unreachable. Maybe
+ ;; signal a warning / error instead?
+ (setf element-type *empty-type*)))
+ (push (or cur-supertype (type-*-to-t cur-type))
+ element-supertypes)))
+ (values element-type
+ (when (and (eq *wild-type* element-type) element-supertypes)
+ (apply #'type-intersection element-supertypes)))))
+ (union-type
+ (let ((union-types (union-type-types type))
+ (element-type nil)
+ (element-supertypes nil))
+ (dolist (union-type union-types)
+ (multiple-value-bind (cur-type cur-supertype)
+ (array-type-upgraded-element-type union-type)
+ (cond
+ ((eq element-type *wild-type*)
+ nil)
+ ((eq element-type nil)
+ (setf element-type cur-type))
+ ((or (eq cur-type *wild-type*)
+ ;; If each of the two following tests fail, it is not
+ ;; possible to determine the element-type of the array
+ ;; because more than one kind of element-type was provided
+ ;; like in '(or (array foo) (array bar)) although a
+ ;; supertype (or foo bar) may be provided as the second
+ ;; returned value returned. See also the KLUDGE below.
+ (not (csubtypep cur-type element-type))
+ (not (csubtypep element-type cur-type)))
+ (setf element-type *wild-type*)))
+ (push (or cur-supertype (type-*-to-t cur-type))
+ element-supertypes)))
+ (values element-type
+ (when (eq *wild-type* element-type)
+ (apply #'type-union element-supertypes)))))
+ (t
+ ;; KLUDGE: there is no good answer here, but at least
+ ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
+ ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
+ ;; 2002-08-21
+ (values *wild-type* nil))))