[Sbcl-commits] CVS: sbcl/src/code late-type.lisp,1.140,1.141

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv25821/src/code

Modified Files:
	late-type.lisp 
Log Message:
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


Index: late-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v
retrieving revision 1.140
retrieving revision 1.141
diff -u -d -r1.140 -r1.141
--- late-type.lisp	19 Nov 2009 11:50:43 -0000	1.140
+++ late-type.lisp	20 Nov 2009 21:33:52 -0000	1.141
@@ -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))