X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fctype.lisp;h=93aeb42ab0f8d4895e8dac57ab8ff3e13c24148c;hb=d0552bdb80b50eb2c600de19b89b2d7139c4841c;hp=d331db65d566a48d4007895bd3d7bdf577356fab;hpb=ecad36c71e99fa4155b80af8bed38d02b9bdb83d;p=sbcl.git

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index d331db6..93aeb42 100644
--- 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))
@@ -728,34 +728,36 @@
 	     (dtype (when return
                       (continuation-derived-type (return-result return)))))
 	(cond
-	 ((and dtype (not (values-types-equal-or-intersect dtype
-							   type-returns)))
-	  (note-lossage
-	   "The result type from ~A:~%  ~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
-	  (assert-continuation-type (return-result return) type-returns
-                                    (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~%  ~
+            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))
@@ -764,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"))))
 
 ;;;; FIXME: Move to some other file.