0.9.0.20:

[sbcl.git] / src / compiler / checkgen.lisp

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index 2f9f907..ddad0b6 100644 (file)
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -262,16 +262,18 @@
           ((lvar-single-value-p lvar)
            ;; exactly one value is consumed
            (principal-lvar-single-valuify lvar)
-           (let ((creq (car (args-type-required ctype))))
-             (multiple-value-setq (ctype atype)
-               (if creq
-                   (values creq (car (args-type-required atype)))
-                   (values (car (args-type-optional ctype))
-                           (car (args-type-optional atype)))))
-             (maybe-negate-check value
-                                 (list ctype) (list atype)
-                                 force-hairy
-                                 n-required)))
+           (flet ((get-type (type)
+                    (acond ((args-type-required type)
+                            (car it))
+                           ((args-type-optional type)
+                            (car it))
+                           (t (bug "type ~S is too hairy" type)))))
+             (multiple-value-bind (ctype atype)
+                 (values (get-type ctype) (get-type atype))
+               (maybe-negate-check value
+                                   (list ctype) (list atype)
+                                   force-hairy
+                                   n-required))))
           ((and (mv-combination-p dest)
                 (eq (mv-combination-kind dest) :local))
            ;; we know the number of consumed values
@@ -332,26 +334,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 +438,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,