X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fir1util.lisp;h=c1c1db8304b53ef47fd154536c2431b67c0cb3ed;hb=ad1aa2961d81ed8db9dac59068c6861199c29a3a;hp=2e1d354fcafce5e2a44ef205d2b0ae20a6e01d71;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 2e1d354..c1c1db8 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -877,7 +877,14 @@
 	(reoptimize-continuation cont)))
 
   (dolist (b (block-pred block))
-    (unlink-blocks b block))
+    (unlink-blocks b block)
+    ;; In bug 147 the almost-all-blocks-have-a-successor invariant was
+    ;; broken when successors were deleted without setting the
+    ;; BLOCK-DELETE-P flags of their predececessors. Make sure that
+    ;; doesn't happen again.
+    (aver (not (and (null (block-succ b))
+                    (not (block-delete-p b))
+                    (not (eq b (component-head (block-component b))))))))
   (dolist (b (block-succ block))
     (unlink-blocks block b))
 
@@ -1353,20 +1360,20 @@
 
 ;;; Apply a function to some arguments, returning a list of the values
 ;;; resulting of the evaluation. If an error is signalled during the
-;;; application, then we print a warning message and return NIL as our
-;;; second value to indicate this. Node is used as the error context
-;;; for any error message, and Context is a string that is spliced
-;;; into the warning.
-(declaim (ftype (function ((or symbol function) list node string)
+;;; application, then we produce a warning message using WARN-FUN and
+;;; return NIL as our second value to indicate this. NODE is used as
+;;; the error context for any error message, and CONTEXT is a string
+;;; that is spliced into the warning.
+(declaim (ftype (function ((or symbol function) list node function string)
 			  (values list boolean))
 		careful-call))
-(defun careful-call (function args node context)
+(defun careful-call (function args node warn-fun context)
   (values
    (multiple-value-list
     (handler-case (apply function args)
       (error (condition)
 	(let ((*compiler-error-context* node))
-	  (compiler-warn "Lisp error during ~A:~%~A" context condition)
+	  (funcall warn-fun "Lisp error during ~A:~%~A" context condition)
 	  (return-from careful-call (values nil nil))))))
    t))