X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fcold-error.lisp;h=ba9bfaebfeecbe4cf2def89535f4d27f77bd9466;hb=2fdd5c9276ba68458e1186c8ae3b7b5a42729a6f;hp=429516038c2571b6029279e54912ef916204ff84;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp
index 4295160..ba9bfae 100644
--- a/src/code/cold-error.lisp
+++ b/src/code/cold-error.lisp
@@ -27,10 +27,16 @@
                                         'simple-condition
                                         'signal))
         (*handler-clusters* *handler-clusters*)
-        (old-bos *break-on-signals*))
+        (old-bos *break-on-signals*)
+        (bos-actually-breaking nil))
     (restart-case
-        (when (typep condition *break-on-signals*)
-          (let ((*break-on-signals* nil))
+        (let ((break-on-signals *break-on-signals*)
+              (*break-on-signals* nil))
+          ;; The rebinding encloses the TYPEP so that a bogus
+          ;; type specifier will not lead to infinite recursion when
+          ;; TYPEP fails.
+          (when (typep condition break-on-signals)
+            (setf bos-actually-breaking t)
             (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* ~
                     (now rebound to NIL)."
                    condition)))
@@ -45,7 +51,13 @@
       ;; unless we provide this restart.)
       (reassign (new-value)
         :report
-        "Return from BREAK and assign a new value to *BREAK-ON-SIGNALS*."
+        (lambda (stream)
+          (format stream
+                  (if bos-actually-breaking
+                    "Return from BREAK and assign a new value to ~
+                     *BREAK-ON-SIGNALS*."
+                    "Assign a new value to *BREAK-ON-SIGNALS* and ~
+                     continue with signal handling.")))
         :interactive
         (lambda ()
           (let (new-value)
@@ -98,14 +110,16 @@
 
   (infinite-error-protect
     (let ((condition (coerce-to-condition datum arguments
-                                          'simple-error 'error))
-          (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+                                          'simple-error 'error)))
       (/show0 "done coercing DATUM to CONDITION")
+      (/show0 "signalling CONDITION from within ERROR")
       (let ((sb!debug:*stack-top-hint* nil))
-        (/show0 "signalling CONDITION from within ERROR")
         (signal condition))
       (/show0 "done signalling CONDITION within ERROR")
-      (invoke-debugger condition))))
+      ;; Finding the stack top hint is pretty expensive, so don't do
+      ;; it until we know we need the debugger.
+      (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+        (invoke-debugger condition)))))
 
 (defun cerror (continue-string datum &rest arguments)
   (infinite-error-protect
@@ -114,12 +128,12 @@
       (let ((condition (coerce-to-condition datum
                                             arguments
                                             'simple-error
-                                            'cerror))
-            (sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+                                            'cerror)))
         (with-condition-restarts condition (list (find-restart 'continue))
           (let ((sb!debug:*stack-top-hint* nil))
             (signal condition))
-          (invoke-debugger condition)))))
+          (let ((sb!debug:*stack-top-hint* (maybe-find-stack-top-hint)))
+            (invoke-debugger condition))))))
   nil)
 
 ;;; like BREAK, but without rebinding *DEBUGGER-HOOK* to NIL, so that