(eql yx :call-other-method))
*empty-type*)
(t
- (aver (and (not xy) (not yx))) ; else handled above
nil))))))))
(defun-cached (type-intersection2 :hash-function type-cache-hash
;; those types can be other types in disguise. So we'd
;; better delegate.
(invoke-complex-subtypep-arg1-method type1 type2))
+ ((and (or (eq type2 *instance-type*)
+ (eq type2 *funcallable-instance-type*))
+ (member-type-p type1))
+ ;; member types can be subtypep INSTANCE and
+ ;; FUNCALLABLE-INSTANCE in surprising ways.
+ (invoke-complex-subtypep-arg1-method type1 type2))
((and (eq type2 *instance-type*) (classoid-p type1))
(if (member type1 *non-instance-classoid-types* :key #'find-classoid)
(values nil t)
(values nil t))
((eq type1 (find-classoid 'function))
(values nil t))
- ((or (basic-structure-classoid-p type1)
+ ((or (structure-classoid-p type1)
#+nil
(condition-classoid-p type1))
(values t t))
(if (classoid-p type1)
(if (and (not (member type1 *non-instance-classoid-types*
:key #'find-classoid))
+ (not (eq type1 (find-classoid 'function)))
(not (find (classoid-layout (find-classoid 'function))
(layout-inherits (classoid-layout type1)))))
- type1
+ (if (or (structure-classoid-p type1)
+ (and (not (eq type1 (find-classoid 'stream)))
+ (not (find (classoid-layout (find-classoid 'stream))
+ (layout-inherits (classoid-layout type1))))))
+ type1
+ nil)
*empty-type*)
- (if (type-might-contain-other-types-p type1)
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
nil
*empty-type*)))
((eq type2 *funcallable-instance-type*)
(layout-inherits (classoid-layout type1))))
type1
(if (type= type1 (find-classoid 'function))
- type1
+ type2
nil))
(if (fun-type-p type1)
nil
- (if (type-might-contain-other-types-p type1)
+ (if (or (type-might-contain-other-types-p type1)
+ (member-type-p type1))
nil
*empty-type*))))
(t (hierarchical-intersection2 type1 type2))))
nil))
(t
(if (<= most-negative-single-float cx most-positive-single-float)
- (coerce cx format)
+ ;; FIXME: bug #389
+ (coerce cx (or format 'single-float))
nil)))))
(if (consp x) (list res) res)))))
nil))
(array-type-element-type type)))
(!define-type-method (array :simple-=) (type1 type2)
- (if (or (unknown-type-p (array-type-element-type type1))
- (unknown-type-p (array-type-element-type type2)))
- (multiple-value-bind (equalp certainp)
- (type= (array-type-element-type type1)
- (array-type-element-type type2))
- ;; By its nature, the call to TYPE= should never return NIL,
- ;; T, as we don't know what the UNKNOWN-TYPE will grow up to
- ;; be. -- CSR, 2002-08-19
- (aver (not (and (not equalp) certainp)))
- (values equalp certainp))
- (values (and (equal (array-type-dimensions type1)
+ (cond ((not (and (equal (array-type-dimensions type1)
(array-type-dimensions type2))
(eq (array-type-complexp type1)
- (array-type-complexp type2))
- (type= (specialized-element-type-maybe type1)
- (specialized-element-type-maybe type2)))
- t)))
+ (array-type-complexp type2))))
+ (values nil t))
+ ((or (unknown-type-p (array-type-element-type type1))
+ (unknown-type-p (array-type-element-type type2)))
+ (multiple-value-bind (equalp certainp)
+ (type= (array-type-element-type type1)
+ (array-type-element-type type2))
+ ;; By its nature, the call to TYPE= should never return
+ ;; NIL, T, as we don't know what the UNKNOWN-TYPE will grow
+ ;; up to be. -- CSR, 2002-08-19
+ (aver (not (and (not equalp) certainp)))
+ (values equalp certainp)))
+ (t
+ (values (type= (specialized-element-type-maybe type1)
+ (specialized-element-type-maybe type2))
+ t))))
(!define-type-method (array :negate) (type)
;; FIXME (and hint to PFD): we're vulnerable here to attacks of the
;; if the TYPE2 element type is wild.
((eq (array-type-element-type type2) *wild-type*)
(values t t))
- (;; Since we didn't match any of the special cases above, we
- ;; can't give a good answer unless both the element types
- ;; have been defined.
+ (;; Since we didn't match any of the special cases above, if
+ ;; either element type is unknown we can only give a good
+ ;; answer if they are the same.
(or (unknown-type-p (array-type-element-type type1))
(unknown-type-p (array-type-element-type type2)))
- (values nil nil))
+ (if (type= (array-type-element-type type1)
+ (array-type-element-type type2))
+ (values t t)
+ (values nil nil)))
(;; Otherwise, the subtype relationship holds iff the
;; types are equal, and they're equal iff the specialized
;; element types are identical.
;; more general case of the above, but harder to compute
((progn
(setf car-not1 (type-negation car-type1))
- (not (csubtypep car-type2 car-not1)))
+ (multiple-value-bind (yes win)
+ (csubtypep car-type2 car-not1)
+ (and (not yes) win)))
(frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
((progn
(setf car-not2 (type-negation car-type2))
- (not (csubtypep car-type1 car-not2)))
+ (multiple-value-bind (yes win)
+ (csubtypep car-type1 car-not2)
+ (and (not yes) win)))
(frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2))
;; Don't put these in -- consider the effect of taking the
;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and