- (and (= (length dims1) (length dims2))
- (every (lambda (x y)
- (or (eq x '*) (eq y '*) (= x y)))
- dims1 dims2))))
- (values nil t))
- ;; See whether complexpness is compatible.
- ((not (or (eq complexp1 :maybe)
- (eq complexp2 :maybe)
- (eq complexp1 complexp2)))
- (values nil t))
- ;; Old comment:
- ;;
- ;; If either element type is wild, then they intersect.
- ;; Otherwise, the types must be identical.
- ;;
- ;; FIXME: There seems to have been a fair amount of
- ;; confusion about the distinction between requested element
- ;; type and specialized element type; here is one of
- ;; them. If we request an array to hold objects of an
- ;; unknown type, we can do no better than represent that
- ;; type as an array specialized on wild-type. We keep the
- ;; requested element-type in the -ELEMENT-TYPE slot, and
- ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here,
- ;; we must test for the SPECIALIZED slot being *WILD-TYPE*,
- ;; not just the ELEMENT-TYPE slot. Maybe the return value
- ;; in that specific case should be T, NIL? Or maybe this
- ;; function should really be called
- ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this
- ;; was responsible for bug #123, and this whole issue could
- ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21
- ((or (eq (array-type-specialized-element-type type1) *wild-type*)
- (eq (array-type-specialized-element-type type2) *wild-type*)
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
-
- (values t t))
- (t
- (values nil t)))))
+ (and (= (length dims1) (length dims2))
+ (every (lambda (x y)
+ (or (eq x '*) (eq y '*) (= x y)))
+ dims1 dims2))))
+ (values nil t))
+ ;; See whether complexpness is compatible.
+ ((not (or (eq complexp1 :maybe)
+ (eq complexp2 :maybe)
+ (eq complexp1 complexp2)))
+ (values nil t))
+ ;; Old comment:
+ ;;
+ ;; If either element type is wild, then they intersect.
+ ;; Otherwise, the types must be identical.
+ ;;
+ ;; FIXME: There seems to have been a fair amount of
+ ;; confusion about the distinction between requested element
+ ;; type and specialized element type; here is one of
+ ;; them. If we request an array to hold objects of an
+ ;; unknown type, we can do no better than represent that
+ ;; type as an array specialized on wild-type. We keep the
+ ;; requested element-type in the -ELEMENT-TYPE slot, and
+ ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here,
+ ;; we must test for the SPECIALIZED slot being *WILD-TYPE*,
+ ;; not just the ELEMENT-TYPE slot. Maybe the return value
+ ;; in that specific case should be T, NIL? Or maybe this
+ ;; function should really be called
+ ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this
+ ;; was responsible for bug #123, and this whole issue could
+ ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21
+ ((or (eq (array-type-specialized-element-type type1) *wild-type*)
+ (eq (array-type-specialized-element-type type2) *wild-type*)
+ (type= (array-type-specialized-element-type type1)
+ (array-type-specialized-element-type type2)))
+
+ (values t t))
+ (t
+ (values nil t)))))
+
+(!define-type-method (array :simple-union2) (type1 type2)
+ (let* ((dims1 (array-type-dimensions type1))
+ (dims2 (array-type-dimensions type2))
+ (complexp1 (array-type-complexp type1))
+ (complexp2 (array-type-complexp type2))
+ (eltype1 (array-type-element-type type1))
+ (eltype2 (array-type-element-type type2))
+ (stype1 (array-type-specialized-element-type type1))
+ (stype2 (array-type-specialized-element-type type2))
+ (wild1 (eq eltype1 *wild-type*))
+ (wild2 (eq eltype2 *wild-type*))
+ (e2 nil))
+ (when (or wild1 wild2
+ (and (or (setf e2 (csubtypep eltype1 eltype2))
+ (csubtypep eltype2 eltype1))
+ (type= stype1 stype2)))
+ (make-array-type
+ :dimensions (cond ((or (eq dims1 '*) (eq dims2 '*))
+ '*)
+ ((equal dims1 dims2)
+ dims1)
+ ((= (length dims1) (length dims2))
+ (mapcar (lambda (x y) (if (eq x y) x '*))
+ dims1 dims2))
+ (t
+ '*))
+ :complexp (if (eq complexp1 complexp2) complexp1 :maybe)
+ :element-type (if (or wild2 e2) eltype2 eltype1)
+ :specialized-element-type (if wild2 stype2 stype1)))))