0.9.14.31:

[sbcl.git] / src / code / late-type.lisp

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 08adf4d..b2717e4 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1155,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)
@@ -1167,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))
@@ -1196,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*)
@@ -1211,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))))
@@ -2118,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))
@@ -2245,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
@@ -2333,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.