X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=a67b43ff7c1894d146c91e35a166ace43ce6c941;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=64dce3b13203acb710af90bcb9b46948cadd0257;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 64dce3b..a67b43f 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -93,10 +93,8 @@
 ;;; matches the specified result.
 ;;;
 ;;; Unlike the argument test, the result test may be called on values
-;;; or function types. If STRICT-RESULT is true and SAFETY is
-;;; non-zero, then the NODE-DERIVED-TYPE is always used. Otherwise, if
-;;; CONT's TYPE-CHECK is true, then the NODE-DERIVED-TYPE is
-;;; intersected with the CONT's ASSERTED-TYPE.
+;;; or function types. NODE-DERIVED-TYPE is intersected with the
+;;; trusted asserted type.
 ;;;
 ;;; The error and warning functions are functions that are called to
 ;;; explain the result. We bind *COMPILER-ERROR-CONTEXT* to the
@@ -107,7 +105,7 @@
                       (result-test #'values-subtypep)
                       ((:lossage-fun *lossage-fun*))
                       ((:unwinnage-fun *unwinnage-fun*)))
-  (declare (type function result-test) (type combination call)
+  (declare (type (or function null) result-test) (type combination call)
 	   ;; FIXME: Could TYPE here actually be something like
 	   ;; (AND GENERIC-FUNCTION (FUNCTION (T) T))?  How
 	   ;; horrible...  -- CSR, 2003-05-03
@@ -153,17 +151,26 @@
              (when keyp
                (check-key-args args max-args type))))
 
-          (let* ((dtype (node-derived-type call))
-                 (return-type (fun-type-returns type))
-                 (out-type dtype))
-            (multiple-value-bind (int win) (funcall result-test out-type return-type)
-              (cond ((not win)
-                     (note-unwinnage "can't tell whether the result is a ~S"
-                                     (type-specifier return-type)))
-                    ((not int)
-                     (note-lossage "The result is a ~S, not a ~S."
-                                   (type-specifier out-type)
-                                   (type-specifier return-type)))))))
+          (when result-test
+            (let* ((dtype (node-derived-type call))
+                   (out-type (or
+                              (binding* ((lvar (node-lvar call) :exit-if-null)
+                                         (dest (lvar-dest lvar)))
+                                (when (and (cast-p dest)
+                                           (eq (cast-type-to-check dest) *wild-type*)
+                                           (immediately-used-p lvar call))
+                                  (values-type-intersection
+                                   dtype (cast-asserted-type dest))))
+                              dtype))
+                   (return-type (fun-type-returns type)))
+              (multiple-value-bind (int win) (funcall result-test out-type return-type)
+                (cond ((not win)
+                       (note-unwinnage "can't tell whether the result is a ~S"
+                                       (type-specifier return-type)))
+                      ((not int)
+                       (note-lossage "The result is a ~S, not a ~S."
+                                     (type-specifier out-type)
+                                     (type-specifier return-type))))))))
         (loop for arg in args
               and i from 1
               do (check-arg-type arg *wild-type* i)))
@@ -205,7 +212,7 @@
        (multiple-value-bind (res win) (ctypep val type)
 	 (cond ((not win)
 		(note-unwinnage "can't tell whether the ~:R argument is a ~
-			        constant ~S:~%  ~S"
+                                 constant ~S:~%  ~S"
 				n (type-specifier type) val)
 		nil)
 	       ((not res)
@@ -246,7 +253,7 @@
        ((not (check-arg-type k (specifier-type 'symbol) n)))
        ((not (constant-lvar-p k))
 	(note-unwinnage "The ~:R argument (in keyword position) is not a ~
-                        constant."
+                         constant."
 			n))
        (t
 	(let* ((name (lvar-value k))
@@ -547,7 +554,7 @@
 	       ((eq int *empty-type*)
 		(note-lossage
 		 "Definition's declared type for variable ~A:~%  ~S~@
-		  conflicts with this type from ~A:~%  ~S"
+                  conflicts with this type from ~A:~%  ~S"
 		 (leaf-debug-name var) (type-specifier vtype)
 		 where (type-specifier type))
 		(return-from try-type-intersections (values nil nil)))
@@ -599,7 +606,7 @@
 	     (unless (eq x y)
 	       (note-lossage
 		"The definition ~:[doesn't have~;has~] ~A, but ~
-		~A ~:[doesn't~;does~]."
+                 ~A ~:[doesn't~;does~]."
 		x what where y))))
       (frob (optional-dispatch-keyp od) (fun-type-keyp type)
 	    "&KEY arguments")
@@ -732,7 +739,7 @@
                                                             type-returns)))
            (note-lossage
             "The result type from ~A:~%  ~S~@
-	   conflicts with the definition's result type:~%  ~S"
+             conflicts with the definition's result type:~%  ~S"
             where (type-specifier type-returns) (type-specifier dtype))
            nil)
           (*lossage-detected* nil)
@@ -748,8 +755,8 @@
                                    (not (csubtypep (leaf-type var) type)))
                           (funcall unwinnage-fun
                                    "Assignment to argument: ~S~%  ~
-			       prevents use of assertion from function ~
-			       type ~A:~%  ~S~%"
+                                    prevents use of assertion from function ~
+                                    type ~A:~%  ~S~%"
                                    (leaf-debug-name var)
                                    where
                                    (type-specifier type))))
@@ -843,7 +850,8 @@
       (let ((atype (lvar-value atype))
             (dtype (lvar-value dtype)))
       (unless (eq atype nil)
-        (compiler-warn
-         "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
-         atype dtype))))
+        (warn 'type-warning
+	      :format-control 
+	      "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
+	      :format-arguments (list atype dtype)))))
     (ir2-convert-full-call node block)))