0.8.3.35:

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

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index ec5e9aa..5a9d009 100644 (file)
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -244,6 +244,7 @@
                 ((and (continuation-single-value-p cont)
                       (or (not (args-type-rest ctype))
                           (eq (args-type-rest ctype) *universal-type*)))
+                 (principal-continuation-single-valuify cont)
                  (let ((creq (car (args-type-required ctype))))
                    (multiple-value-setq (ctype atype)
                      (if creq
@@ -268,8 +269,8 @@
                                        force-hairy)))
                 ((not (eq vcount :unknown))
                  (maybe-negate-check value
-                                     (values-type-start ctype vcount)
-                                     (values-type-start atype vcount)
+                                     (values-type-out ctype vcount)
+                                     (values-type-out atype vcount)
                                      t))
                 (t
                  (values :too-hairy nil))))))))
@@ -279,27 +280,26 @@
   (declare (type cast cast))
   (let* ((cont (node-cont cast))
          (dest (continuation-dest cont)))
-    (not (or (not (cast-type-check cast))
-             (and (combination-p dest)
-                  (let ((kind (combination-kind dest)))
-                    (or (eq kind :full)
-                        ;; The theory is that the type assertion is
-                        ;; from a declaration in (or on) the callee,
-                        ;; so the callee should be able to do the
-                        ;; check. We want to let the callee do the
-                        ;; check, because it is possible that by the
-                        ;; time of call that declaration will be
-                        ;; changed and we do not want to make people
-                        ;; recompile all calls to a function when they
-                        ;; were originally compiled with a bad
-                        ;; declaration. (See also bug 35.)
-                        (and (fun-info-p kind)
-                             (null (fun-info-templates kind))
-                             (not (fun-info-ir2-convert kind)))))
-                  (and
-                   (immediately-used-p cont cast)
-                   (values-subtypep (continuation-externally-checkable-type cont)
-                                   (cast-type-to-check cast))))))))
+    (cond ((not (cast-type-check cast))
+           nil)
+          ((and (combination-p dest)
+                (call-full-like-p dest)
+                ;; The theory is that the type assertion is
+                ;; from a declaration in (or on) the callee,
+                ;; so the callee should be able to do the
+                ;; check. We want to let the callee do the
+                ;; check, because it is possible that by the
+                ;; time of call that declaration will be
+                ;; changed and we do not want to make people
+                ;; recompile all calls to a function when they
+                ;; were originally compiled with a bad
+                ;; declaration. (See also bug 35.)
+                (immediately-used-p cont cast)
+                (values-subtypep (continuation-externally-checkable-type cont)
+                                 (cast-type-to-check cast)))
+           nil)
+          (t
+           t))))
 
 ;;; Return true if CONT is a continuation whose type the back end is
 ;;; likely to want to check. Since we don't know what template the
@@ -388,11 +388,11 @@
                        ((= length 1)
                          (single-value-type atype))
                         (t
-                        (make-values-type :required 
-                                          (values-type-start atype length)))))
+                        (make-values-type
+                          :required (values-type-out atype length)))))
            (dtype (node-derived-type cast))
-           (dtype (make-values-type :required 
-                                   (values-type-start dtype length))))
+           (dtype (make-values-type
+                   :required (values-type-out dtype length))))
       (setf (cast-asserted-type cast) atype)
       (setf (node-derived-type cast) dtype)))
 
@@ -466,9 +466,9 @@
     (do-blocks (block component)
       (when (block-type-check block)
        (do-nodes (node cont block)
-          (when (cast-p node)
-            (when (cast-type-check node)
-              (cast-check-uses node))
+          (when (and (cast-p node)
+                     (cast-type-check node))
+            (cast-check-uses node)
             (cond ((worth-type-check-p node)
                    (casts (cons node (not (probable-type-check-p node)))))
                   (t
@@ -486,9 +486,9 @@
             (:too-hairy
              (let ((*compiler-error-context* cast))
                (when (policy cast (>= safety inhibit-warnings))
-                 (compiler-note
+                 (compiler-notify
                   "type assertion too complex to check:~% ~S."
-                  (type-specifier (cast-asserted-type cast)))))
+                  (type-specifier (coerce-to-values (cast-asserted-type cast))))))
              (setf (cast-type-to-check cast) *wild-type*)
              (setf (cast-%type-check cast) nil)))))))
   (values))