X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fltn.lisp;h=1ce7180f2e8816dd16886e9d11b6da9cffb25fb5;hb=872175cd9cb5b4966a36d4bd92421cc407a0355b;hp=9a2570a5ae92bb14f90c7486f67c476a2c492a50;hpb=cfb9e3640e34706acdfccd26236024de259f3b4f;p=sbcl.git

diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index 9a2570a..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))))
 
@@ -888,9 +889,11 @@
       (when (and rejected
 		 (policy call (> speed inhibit-warnings)))
 	(note-rejected-templates call ltn-policy template))
-      ;; If we are forced to do a full call, we check to see whether the
-      ;; function called is the same as the current function. If so, we
-      ;; give a warning, as this is probably a botched interpreter stub.
+      ;; If we are forced to do a full call, we check to see whether
+      ;; the function called is the same as the current function. If
+      ;; so, we give a warning, as this is probably a botched attempt
+      ;; to implement an out-of-line version in terms of inline
+      ;; transforms or VOPs or whatever.
       (unless template
 	(when (and (eq (continuation-function-name (combination-fun call))
 		       (leaf-name
@@ -901,7 +904,13 @@
 			      (ir1-attributep (function-info-attributes info)
 					      recursive)))))
 	  (let ((*compiler-error-context* call))
-	    (compiler-warning "recursive known function definition")))
+	    (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)))
+				      args))))
 	(ltn-default-call call ltn-policy)
 	(return-from ltn-analyze-known-call (values)))
       (setf (basic-combination-info call) template)
@@ -968,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)
@@ -984,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))