X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=b2717e413da2e0d642e4f5a63aa8fc278b9240de;hb=8886298f2c0e50e595cf481c426b6331ab898a23;hp=bc996436001002f84d21a5344e8aad1ea0714f7c;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index bc99643..b2717e4 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -849,7 +849,6 @@ (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 @@ -1156,6 +1155,12 @@ ;; 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) @@ -1168,7 +1173,7 @@ (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)) @@ -1197,11 +1202,18 @@ (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*) @@ -1212,11 +1224,12 @@ (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)))) @@ -2119,7 +2132,8 @@ used for a COMPLEX component.~:@>" 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)) @@ -2246,23 +2260,25 @@ used for a COMPLEX component.~:@>" (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 @@ -2334,12 +2350,15 @@ used for a COMPLEX component.~:@>" ;; 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. @@ -2999,11 +3018,15 @@ used for a COMPLEX component.~:@>" ;; 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