0.8.0.78.vector-nil-string.7:

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

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 2c9a094..93aeb42 100644 (file)
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -265,7 +265,7 @@
 ;;;
 ;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
 ;;; the &REST type.
-(declaim (ftype (function (functional) fun-type) definition-type))
+(declaim (ftype (sfunction (functional) fun-type) definition-type))
 (defun definition-type (functional)
   (if (lambda-p functional)
       (make-fun-type
@@ -418,7 +418,7 @@
                                          #'types-equal-or-intersect)
                                         (*lossage-fun*
                                          #'compiler-style-warn)
-                                        (*unwinnage-fun* #'compiler-note))
+                                        (*unwinnage-fun* #'compiler-notify))
   (let* ((*lossage-detected* nil)
         (*unwinnage-detected* nil)
         (required (fun-type-required type))
@@ -704,11 +704,11 @@
 ;;; If there is no problem, we return T (even if REALLY-ASSERT was
 ;;; false). If there was a problem, we return NIL.
 (defun assert-definition-type
-       (functional type &key (really-assert t)
-                  ((:lossage-fun *lossage-fun*)
-                   #'compiler-style-warn)
-                  unwinnage-fun
-                  (where "previous declaration"))
+    (functional type &key (really-assert t)
+     ((:lossage-fun *lossage-fun*)
+      #'compiler-style-warn)
+     unwinnage-fun
+     (where "previous declaration"))
   (declare (type functional functional)
           (type function *lossage-fun*)
           (string where))
@@ -725,39 +725,39 @@
               (find-lambda-types functional type where))))
       (let* ((type-returns (fun-type-returns type))
             (return (lambda-return (main-entry functional)))
-            (atype (when return
-                      nil
-                     #+nil(continuation-derived-type (return-result return))))) ; !!
+            (dtype (when return
+                      (continuation-derived-type (return-result return)))))
        (cond
-        ((and atype (not (values-types-equal-or-intersect atype
-                                                          type-returns)))
-         (note-lossage
-          "The result type from ~A:~%  ~S~@
-          conflicts with the definition's result type assertion:~%  ~S"
-          where (type-specifier type-returns) (type-specifier atype))
-         nil)
-        (*lossage-detected* nil)
-        ((not really-assert) t)
-        (t
-         (when atype
-           (assert-continuation-type (return-result return) atype
-                                      (lexenv-policy (functional-lexenv functional))))
-         (loop for var in vars and type in types do
-           (cond ((basic-var-sets var)
-                  (when (and unwinnage-fun
-                             (not (csubtypep (leaf-type var) type)))
-                    (funcall unwinnage-fun
-                             "Assignment to argument: ~S~%  ~
+          ((and dtype (not (values-types-equal-or-intersect dtype
+                                                            type-returns)))
+           (note-lossage
+            "The result type from ~A:~%  ~S~@
+          conflicts with the definition's result type:~%  ~S"
+            where (type-specifier type-returns) (type-specifier dtype))
+           nil)
+          (*lossage-detected* nil)
+          ((not really-assert) t)
+          (t
+           (let ((policy (lexenv-policy (functional-lexenv functional))))
+             (when (policy policy (> type-check 0))
+               (assert-continuation-type (return-result return) type-returns
+                                         policy)))
+           (loop for var in vars and type in types do
+                (cond ((basic-var-sets var)
+                       (when (and unwinnage-fun
+                                  (not (csubtypep (leaf-type var) type)))
+                         (funcall unwinnage-fun
+                                  "Assignment to argument: ~S~%  ~
                               prevents use of assertion from function ~
                               type ~A:~%  ~S~%"
-                             (leaf-debug-name var)
-                             where
-                             (type-specifier type))))
-                 (t
-                  (setf (leaf-type var) type)
-                  (dolist (ref (leaf-refs var))
-                    (derive-node-type ref (make-single-value-type type))))))
-         t))))))
+                                  (leaf-debug-name var)
+                                  where
+                                  (type-specifier type))))
+                      (t
+                       (setf (leaf-type var) type)
+                       (dolist (ref (leaf-refs var))
+                         (derive-node-type ref (make-single-value-type type))))))
+           t))))))
 
 (defun assert-global-function-definition-type (name fun)
   (declare (type functional fun))
@@ -766,7 +766,7 @@
     (when (eq where :declared)
       (setf (leaf-type fun) type)
       (assert-definition-type fun type
-                              :unwinnage-fun #'compiler-note
+                              :unwinnage-fun #'compiler-notify
                               :where "proclamation"))))
 \f
 ;;;; FIXME: Move to some other file.
@@ -799,6 +799,6 @@
             (dtype (continuation-value dtype)))
       (unless (eq atype nil)
         (compiler-warn
-         "Asserted type ~S conflicts with derived type ~S."
+         "~@<Asserted type ~S conflicts with derived type ~S.~@:>"
          atype dtype))))
     (ir2-convert-full-call node block)))