X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-type.lisp;h=7ebfccf60fdd2f34a0efab47e6f467167b9dac90;hb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;hp=14948067a92a7511d81df80d51738824dee3f6fe;hpb=53e7a02c819090af8e6db7e47d29cdbb5296814f;p=sbcl.git

diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp
index 1494806..7ebfccf 100644
--- a/src/code/target-type.lisp
+++ b/src/code/target-type.lisp
@@ -28,10 +28,10 @@
 ;;; return whether the object is of that type as the first value and
 ;;; second value true. Otherwise return NIL, NIL.
 ;;;
-;;; We give up on unknown types and pick off FUNCTION and UNION types.
-;;; For structure types, we require that the type be defined in both
-;;; the current and compiler environments, and that the INCLUDES be
-;;; the same.
+;;; We give up on unknown types and pick off FUNCTION- and COMPOUND-
+;;; types. For STRUCTURE- types, we require that the type be defined
+;;; in both the current and compiler environments, and that the
+;;; INCLUDES be the same.
 (defun ctypep (obj type)
   (declare (type ctype type))
   (etypecase type
@@ -51,11 +51,30 @@
 	     (values (sb!xc:typep obj type) t)
 	     (values nil nil))
 	 (values nil t)))
-    (union-type
-     (dolist (mem (union-type-types type) (values nil t))
-       (multiple-value-bind (val win) (ctypep obj mem)
-	 (unless win (return (values nil nil)))
-	 (when val (return (values t t))))))
+    (compound-type
+     (let ((certain? t))
+       (etypecase type
+	 ;; FIXME: The cases here are very similar to #'EVERY/TYPE and
+	 ;; #'ANY/TYPE. It would be good to fix them so that they
+	 ;; share the same code. (That will require making sure that
+	 ;; the two-value return convention for CTYPEP really is
+	 ;; exactly compatible with the two-value convention the
+	 ;; quantifier/TYPE functions operate on, and probably also
+	 ;; making sure that things are inlined and defined early
+	 ;; enough that consing can be avoided.)
+	 (union-type
+	  (dolist (mem (union-type-types type) (values nil certain?))
+	    (multiple-value-bind (val win) (ctypep obj mem)
+	      (if win
+		  (when val (return (values t t)))
+		  (setf certain? nil)))))
+	 (intersection-type
+	  (dolist (mem (intersection-type-types type)
+		       (if certain? (values t t) (values nil nil)))
+	    (multiple-value-bind (val win) (ctypep obj mem)
+	      (if win
+		  (unless val (return (values nil t)))
+		  (setf certain? nil))))))))
     (function-type
      (values (functionp obj) t))
     (unknown-type
@@ -151,7 +170,7 @@
 		   type-union-cache-clear
 		   values-subtypep-cache-clear
 		   csubtypep-cache-clear
-		   type-intersection-cache-clear
+		   type-intersection2-cache-clear
 		   values-type-intersection-cache-clear))
       (funcall (symbol-function sym))))
   (values))