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

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index c6bee54..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))
@@ -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"))))
 
 ;;;; FIXME: Move to some other file.
@@ -782,7 +782,10 @@
 
 (defun %compile-time-type-error (values atype dtype)
   (declare (ignore dtype))
-  (error 'values-type-error :datum values :expected-type atype))
+  (if (and (consp atype)
+           (eq (car atype) 'values))
+      (error 'values-type-error :datum values :expected-type atype)
+      (error 'type-error :datum (car values) :expected-type atype)))
 
 (defoptimizer (%compile-time-type-error ir2-convert)
     ((objects atype dtype) node block)
@@ -796,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)))