From cb43defd8ce791c9c5a8302c0bca20fcd1b60749 Mon Sep 17 00:00:00 2001
From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Mon, 28 Aug 2006 12:08:19 +0000
Subject: [PATCH] 0.9.16.1: 	Rework the named :complex-intersection-arg2
 method for instance 	and funcallable-instance, making it
 a lot clearer and fixing 	bugs in the process... 	...
 structure-classoids are always subtypep instance and never 
 	intersect funcallable-instance; 	...
 standard-classoids are different.  It's possible to make 
 	a subclass of an instance class which is 	
 funcallable-instance (if you pardon the loose 	
 construction), while the reverse is not possible.

---
 src/code/late-type.lisp |   64 +++++++++++++++++++++++------------------------
 tests/type.impure.lisp  |   17 +++++++++++--
 version.lisp-expr       |    2 +-
 3 files changed, 48 insertions(+), 35 deletions(-)

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 1c5b8ea..2fb73b6 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1193,39 +1193,39 @@
   ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (cond
     ((eq type2 *instance-type*)
-     (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)))))
-             (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 (or (type-might-contain-other-types-p type1)
-                 (member-type-p type1))
-             nil
-             *empty-type*)))
+     (typecase type1
+       (structure-classoid type1)
+       (classoid
+        (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)))))
+            nil
+            *empty-type*))
+       (t
+        (if (or (type-might-contain-other-types-p type1)
+                (member-type-p type1))
+            nil
+            *empty-type*))))
     ((eq type2 *funcallable-instance-type*)
-     (if (classoid-p type1)
-         (if (and (not (member type1 *non-instance-classoid-types*
-                               :key #'find-classoid))
-                  (find (classoid-layout (find-classoid 'function))
-                        (layout-inherits (classoid-layout type1))))
-             type1
-             (if (type= type1 (find-classoid 'function))
-                 type2
-                 nil))
-         (if (fun-type-p type1)
-             nil
-             (if (or (type-might-contain-other-types-p type1)
-                     (member-type-p type1))
-                 nil
-                 *empty-type*))))
+     (typecase type1
+       (structure-classoid *empty-type*)
+       (classoid
+        (if (and (not (member type1 *non-instance-classoid-types*
+                              :key #'find-classoid))
+                 (find (classoid-layout (find-classoid 'function))
+                       (layout-inherits (classoid-layout type1))))
+            type1
+            (if (type= type1 (find-classoid 'function))
+                type2
+                nil)))
+       (fun-type nil)
+       (t
+        (if (or (type-might-contain-other-types-p type1)
+                (member-type-p type1))
+            nil
+            *empty-type*))))
     (t (hierarchical-intersection2 type1 type2))))
 
 (!define-type-method (named :complex-union2) (type1 type2)
diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index e9891c9..caaefaf 100644
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -524,11 +524,24 @@
   (assert (not ok))
   (assert (not win)))
 
-;;; precice unions of array types (was bug 306a)
+;;; precise unions of array types (was bug 306a)
 (defun bug-306-a (x)
   (declare (optimize speed)
            (type (or (array cons) (array vector)) x))
   (elt (aref x 0) 0))
 (assert (= 0 (bug-306-a #((0)))))
-
+
+;;; FUNCALLABLE-INSTANCE is a subtype of function.
+(assert-t-t (subtypep '(and pathname function) nil))
+(assert-t-t (subtypep '(and pathname sb-kernel:funcallable-instance) nil))
+(assert (not (subtypep '(and stream function) nil)))
+(assert (not (subtypep '(and stream sb-kernel:funcallable-instance) nil)))
+(assert (not (subtypep '(and function standard-object) nil)))
+(assert (not (subtypep '(and sb-kernel:funcallable-instance standard-object) nil)))
+
+;;; also, intersections of classes with INSTANCE should not be too
+;;; general
+(assert (not (typep #'print-object '(and standard-object sb-kernel:instance))))
+(assert (not (subtypep 'standard-object '(and standard-object sb-kernel:instance))))
+
 ;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index b57c5cb..b8cef80 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.16"
+"0.9.16.1"
-- 
1.7.10.4