1.0.32.36: (subtypep 'symbol 'keyword) must be NIL, T

Special-case the hairy type (SATISFIES KEYWORDP) and its interaction with the
SYMBOL type.  (We could potentially be cleverer at this point and additionally
tell the system that all non-symbols are non-(SATISFIES KEYWORDP) types, but
we're somewhat late in the development cycle now)

Fixes bug #485972

diff --git a/NEWS b/NEWS
index f9f888b..1e8cfca 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -74,6 +74,8 @@ changes relative to sbcl-1.0.32:
     (reported by Attila Lendvai; launchpad bug #310132)
   * bug fix: distinguish in type specifiers between arrays that might be
     complex and arrays that are definitely complex.  (launchpad bug #309129)
+  * bug fix: SUBTYPEP knows that the SYMBOL type is not SUBTYPEP the KEYWORD
+    type.  (reported by Levente Mészáros; launchpad bug #485972)
 
 changes in sbcl-1.0.32 relative to sbcl-1.0.31:
   * optimization: faster FIND and POSITION on strings of unknown element type

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 6b1fd40..695b27a 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1349,7 +1349,15 @@
            (values nil nil)))))
 
 (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
-  (invoke-complex-subtypep-arg1-method type1 type2))
+  (let ((specifier (hairy-type-specifier type2)))
+    (cond
+      ((and (consp specifier) (eql (car specifier) 'satisfies))
+       (case (cadr specifier)
+         ((keywordp) (if (type= type1 (specifier-type 'symbol))
+                         (values nil t)
+                         (invoke-complex-subtypep-arg1-method type1 type2)))
+         (t (invoke-complex-subtypep-arg1-method type1 type2))))
+      (t (invoke-complex-subtypep-arg1-method type1 type2)))))
 
 (!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
   (declare (ignore type1 type2))

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 4e3ca06..6eea7d3 100644 (file)
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -420,3 +420,7 @@ ACTUAL ~D DERIVED ~D~%"
         (let ((i (sb-c::values-type-intersection x y)))
           (assert (sb-c::type= i (sb-c::values-type-intersection i x)))
           (assert (sb-c::type= i (sb-c::values-type-intersection i y))))))))
+
+(with-test (:name :bug-485972)
+  (assert (equal (multiple-value-list (subtypep 'symbol 'keyword)) '(nil t)))
+  (assert (equal (multiple-value-list (subtypep 'keyword 'symbol)) '(t t))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 7c4bc34..9fdf4df 100644 (file)
--- 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".)
-"1.0.32.35"
+"1.0.32.36"