X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=1ce7180f2e8816dd16886e9d11b6da9cffb25fb5;hb=fdf07da187cb31fd5bdd872c73245fd72877b1a1;hp=e102f6431ee3e3669fc1ae9a4b0de650953b6a4b;hpb=79953929196409f21fe505b29b15d2a9281884b7;p=sbcl.git

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index e102f64..1ce7180 100644
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -105,7 +105,7 @@
 (defun annotate-1-value-continuation (cont)
   (declare (type continuation cont))
   (let ((info (continuation-info cont)))
-    (assert (eq (ir2-continuation-kind info) :fixed))
+    (aver (eq (ir2-continuation-kind info) :fixed))
     (cond
      ((continuation-delayed-leaf cont)
       (setf (ir2-continuation-kind info) :delayed))
@@ -419,8 +419,8 @@
 (defun set-tail-local-call-successor (call)
   (let ((caller (node-home-lambda call))
 	(callee (combination-lambda call)))
-    (assert (eq (lambda-tail-set caller)
-		(lambda-tail-set (lambda-home callee))))
+    (aver (eq (lambda-tail-set caller)
+	      (lambda-tail-set (lambda-home callee))))
     (node-ends-block call)
     (let ((block (node-block call)))
       (unlink-blocks block (first (block-succ block)))
@@ -473,7 +473,7 @@
 (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup)
 					      node
 					      ltn-policy)
-  (declare (ignore ltn-policy))
+  ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
   (setf (basic-combination-info node) :funny)
   (setf (node-tail-p node) nil))
 
@@ -721,7 +721,7 @@
   (funcall frob "This shouldn't happen!  Bug?")
   (multiple-value-bind (win why)
       (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))
-    (assert (not win))
+    (aver (not win))
     (ecase why
       (:guard
        (funcall frob "template guard failed"))
@@ -793,8 +793,9 @@
 			 (and (template-note try)
 			      (valid-function-use
 			       call (template-type try)
-			       :argument-test #'types-intersect
-			       :result-test #'values-types-intersect))))
+			       :argument-test #'types-equal-or-intersect
+			       :result-test
+			       #'values-types-equal-or-intersect))))
 	    (losers try)))))
 
     (when (losers)
@@ -819,11 +820,11 @@
 	       ((and valid strict-valid)
 		(strange-template-failure loser call ltn-policy #'frob))
 	       ((not valid)
-		(assert (not (valid-function-use call type
-						 :error-function #'frob
-						 :warning-function #'frob))))
+		(aver (not (valid-function-use call type
+					       :error-function #'frob
+					       :warning-function #'frob))))
 	       (t
-		(assert (ltn-policy-safe-p ltn-policy))
+		(aver (ltn-policy-safe-p ltn-policy))
 		(frob "can't trust output type assertion under safe policy")))
 	      (count 1))))
 
@@ -903,8 +904,9 @@
 			      (ir1-attributep (function-info-attributes info)
 					      recursive)))))
 	  (let ((*compiler-error-context* call))
-	    (compiler-warning "recursion in known function definition~2I ~
-                               ~_arg types=~S"
+	    (compiler-warning "~@<recursion in known function definition~2I ~
+                               ~_policy=~S ~_arg types=~S~:>"
+			      (lexenv-policy (node-lexenv call))
 			      (mapcar (lambda (arg)
 					(type-specifier (continuation-type
 							 arg)))
@@ -975,7 +977,7 @@
   (declare (type component component))
   (let ((2comp (component-info component)))
     (do-blocks (block component)
-      (assert (not (block-info block)))
+      (aver (not (block-info block)))
       (let ((2block (make-ir2-block block)))
 	(setf (block-info block) 2block)
 	(ltn-analyze-block block)
@@ -991,6 +993,6 @@
 (defun ltn-analyze-belated-block (block)
   (declare (type cblock block))
   (ltn-analyze-block block)
-  (assert (not (ir2-block-popped (block-info block))))
+  (aver (not (ir2-block-popped (block-info block))))
   (values))