From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Mon, 27 Mar 2006 08:19:36 +0000 (+0000)
Subject: 0.9.11.2:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=23ce012234d40a8d9ad34644d20496d062713352;p=sbcl.git

0.9.11.2:
	Fix for MISC.629 (PFD ansi-tests)
	... all paths lead to the type system.
---

diff --git a/NEWS b/NEWS
index d421f3f..467a261 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@ changes in sbcl-0.9.12 relative to sbcl-0.9.11:
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** REMOVE-METHOD returns its generic function argument even when
        the method is not one of the generic functions' methods.
+    ** objects declared as MEMBER types can be admissible arguments to 
+       structure accessors.
 
 changes in sbcl-0.9.11 relative to sbcl-0.9.10:
   * new platform: experimental support for SBCL x86/Darwin, including
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 102c8b5..b2717e4 100644
--- 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)
@@ -1206,7 +1212,8 @@
                  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*)
@@ -1221,7 +1228,8 @@
                  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))))
diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index be9e55b..d5edc2e 100644
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -445,4 +445,46 @@
                  t)))
   (assert (null (values (subtypep `(not ,t2) `(not ,t1))))))
 
+(defstruct misc-629a)
+(defclass misc-629b () ())
+(defclass misc-629c () () (:metaclass sb-mop:funcallable-standard-class))
+
+(assert (typep (make-misc-629a) 'sb-kernel:instance))
+(assert-t-t (subtypep `(member ,(make-misc-629a)) 'sb-kernel:instance))
+(assert-nil-t (subtypep `(and (member ,(make-misc-629a)) sb-kernel:instance)
+                        nil))
+(let ((misc-629a (make-misc-629a)))
+  (assert-t-t (subtypep `(member ,misc-629a)
+                        `(and (member ,misc-629a) sb-kernel:instance)))
+  (assert-t-t (subtypep `(and (member ,misc-629a)
+                          sb-kernel:funcallable-instance)
+                        nil)))
+
+(assert (typep (make-instance 'misc-629b) 'sb-kernel:instance))
+(assert-t-t (subtypep `(member ,(make-instance 'misc-629b))
+                      'sb-kernel:instance))
+(assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629b))
+                          sb-kernel:instance)
+                        nil))
+(let ((misc-629b (make-instance 'misc-629b)))
+  (assert-t-t (subtypep `(member ,misc-629b)
+                        `(and (member ,misc-629b) sb-kernel:instance)))
+  (assert-t-t (subtypep `(and (member ,misc-629b)
+                          sb-kernel:funcallable-instance)
+                        nil)))
+
+(assert (typep (make-instance 'misc-629c) 'sb-kernel:funcallable-instance))
+(assert-t-t (subtypep `(member ,(make-instance 'misc-629c))
+                      'sb-kernel:funcallable-instance))
+(assert-nil-t (subtypep `(and (member ,(make-instance 'misc-629c))
+                          sb-kernel:funcallable-instance)
+                        nil))
+(let ((misc-629c (make-instance 'misc-629c)))
+  (assert-t-t (subtypep `(member ,misc-629c)
+                        `(and (member ,misc-629c)
+                          sb-kernel:funcallable-instance)))
+  (assert-t-t (subtypep `(and (member ,misc-629c)
+                          sb-kernel:instance)
+                        nil)))
+
 ;;; success
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 55e2575..593e45e 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -330,3 +330,6 @@ ACTUAL ~D DERIVED ~D~%"
   (sb-kernel:type=
    (sb-kernel:specifier-type '(simple-array an-unkown-type (7)))
    (sb-kernel:specifier-type '(simple-array an-unkown-type (8))))))
+
+(assert (typep #p"" 'sb-kernel:instance))
+(assert (subtypep '(member #p"") 'sb-kernel:instance))
diff --git a/version.lisp-expr b/version.lisp-expr
index 92d7606..49019a0 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.11.1"
+"0.9.11.2"