X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcheckgen.lisp;h=3fd81d57a6fed065ece18b06d969fd7a26925e3f;hb=cf4cb9554515c59eddbde38d1cf236339c37f55f;hp=2f9f9072a53a5f619f37b2a403b3485bd0dd9aeb;hpb=61c18727668ff0c3263a3d363e609d4522d545cc;p=sbcl.git

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index 2f9f907..3fd81d5 100644
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -332,26 +332,30 @@
 	   nil)
 	  ((basic-combination-p dest)
 	   (let ((kind (basic-combination-kind dest)))
-	     (cond ((eq cont (basic-combination-fun dest)) t)
-		   ((eq kind :local) t)
-                   ((eq kind :full)
-                    (and (combination-p dest)
-                         (not (values-subtypep ; explicit THE
-                               (continuation-externally-checkable-type cont)
-                               (continuation-type-to-check cont)))))
-
-		   ((eq kind :error) nil)
-                   ;; :ERROR means that we have an invalid syntax of
-                   ;; the call and the callee will detect it before
-                   ;; thinking about types.
-
-		   ((fun-info-ir2-convert kind) t)
-		   (t
-		    (dolist (template (fun-info-templates kind) nil)
-		      (when (eq (template-ltn-policy template) :fast-safe)
-			(multiple-value-bind (val win)
-			    (valid-fun-use dest (template-type template))
-			  (when (or val (not win)) (return t)))))))))
+	     (cond
+	       ((eq cont (basic-combination-fun dest)) t)
+	       (t
+		(ecase kind
+		  (:local t)
+		  (:full
+		   (and (combination-p dest)
+			(not (values-subtypep ; explicit THE
+			      (continuation-externally-checkable-type cont)
+			      (continuation-type-to-check cont)))))
+		  ;; :ERROR means that we have an invalid syntax of
+		  ;; the call and the callee will detect it before
+		  ;; thinking about types.
+		  (:error nil)
+		  (:known
+		   (let ((info (basic-combination-fun-info dest)))
+		     (if (fun-info-ir2-convert info)
+			 t
+			 (dolist (template (fun-info-templates info) nil)
+			   (when (eq (template-ltn-policy template)
+				     :fast-safe)
+			     (multiple-value-bind (val win)
+				 (valid-fun-use dest (template-type template))
+			       (when (or val (not win)) (return t)))))))))))))
 	  (t t))))
 
 ;;; Return a lambda form that we can convert to do a hairy type check
@@ -432,12 +436,18 @@
                                    (leaf-source-name (elt (lambda-vars lambda)
                                                           pos)))))))
             (cond ((and (ref-p use) (constant-p (ref-leaf use)))
-                   (compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~%  ~S"
-                                  what atype-spec (constant-value (ref-leaf use))))
+                   (warn 'type-warning
+			 :format-control
+			 "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~%  ~S"
+			 :format-arguments
+			 (list what atype-spec 
+			       (constant-value (ref-leaf use)))))
                   (t
-                   (compiler-warn
-                    "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
-                    what (type-specifier dtype) atype-spec))))))))
+                   (warn 'type-warning
+			 :format-control
+			 "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
+			 :format-arguments
+			 (list what (type-specifier dtype) atype-spec)))))))))
   (values))
 
 ;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set,