- '*package* *package*))
- (let (;; Save *PACKAGE* to protect it from WITH-STANDARD-IO-SYNTAX.
- (original-package *package*))
- (with-standard-io-syntax
- (let* ((*debug-condition* condition)
- (*debug-restarts* (compute-restarts condition))
- ;; We want the i/o subsystem to be in a known, useful
- ;; state, regardless of where the debugger was invoked in
- ;; the program. WITH-STANDARD-IO-SYNTAX does some of that,
- ;; but
- ;; 1. It doesn't affect our internal special variables
- ;; like *CURRENT-LEVEL*.
- ;; 2. It isn't customizable.
- ;; 3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY*
- ;; to the same value as the toplevel default.
- ;; 4. It sets *PACKAGE* to COMMON-LISP-USER, which is not
- ;; helpful behavior for a debugger.
- ;; We try to remedy all these problems with explicit
- ;; rebindings here.
- (sb!kernel:*current-level* 0)
- (*print-length* *debug-print-length*)
- (*print-level* *debug-print-level*)
- (*readtable* *debug-readtable*)
- (*print-readably* nil)
- (*print-pretty* t)
- (*package* original-package))
-
- ;; The initial output here goes to *ERROR-OUTPUT*, because the
- ;; initial output is not interactive, just an error message,
- ;; and when people redirect *ERROR-OUTPUT*, they could
- ;; reasonably expect to see error messages logged there,
- ;; regardless of what the debugger does afterwards.
- #!+sb-show (sb!conditions::show-condition *debug-condition*
- *error-output*)
- (format *error-output*
- "~2&debugger invoked on condition of type ~S:~% "
- (type-of *debug-condition*))
- (princ-debug-condition-carefully *error-output*)
- (terpri *error-output*)
-
- ;; After the initial error/condition/whatever announcement to
- ;; *ERROR-OUTPUT*, we become interactive, and should talk on
- ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
- ;; statement, not a description of reality.:-| There's a lot of
- ;; older debugger code which was written to do i/o on whatever
- ;; stream was in fashion at the time, and not all of it has
- ;; been converted to behave this way. -- WHN 2000-11-16)
- (let (;; FIXME: The first two bindings here seem wrong,
- ;; violating the principle of least surprise, and making
- ;; it impossible for the user to do reasonable things
- ;; like using PRINT at the debugger prompt to send output
- ;; to the program's ordinary (possibly
- ;; redirected-to-a-file) *STANDARD-OUTPUT*, or using
- ;; PEEK-CHAR or some such thing on the program's ordinary
- ;; (possibly also redirected) *STANDARD-INPUT*.
- (*standard-input* *debug-io*)
- (*standard-output* *debug-io*)
- ;; This seems reasonable: e.g. if the user has redirected
- ;; *ERROR-OUTPUT* to some log file, it's probably wrong
- ;; to send errors which occur in interactive debugging to
- ;; that file, and right to send them to *DEBUG-IO*.
- (*error-output* *debug-io*))
- (unless (typep condition 'step-condition)
- (format *debug-io*
- "~%~@<Within the debugger, you can type HELP for help. At ~
- any command prompt (within the debugger or not) you can ~
- type (SB-EXT:QUIT) to terminate the SBCL executable. ~
- The condition which caused the debugger to be entered ~
- is bound to ~S.~:@>~2%"
- '*debug-condition*)
- (show-restarts *debug-restarts* *debug-io*)
- (terpri *debug-io*))
- (internal-debug))))))
+ '*package* *package*))
+
+ ;; Before we start our own output, finish any pending output.
+ ;; Otherwise, if the user tried to track the progress of his program
+ ;; using PRINT statements, he'd tend to lose the last line of output
+ ;; or so, which'd be confusing.
+ (flush-standard-output-streams)
+
+ (funcall-with-debug-io-syntax #'%invoke-debugger condition))
+
+(defun %print-debugger-invocation-reason (condition stream)
+ (format stream "~2&")
+ ;; Note: Ordinarily it's only a matter of taste whether to use
+ ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but
+ ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is
+ ;; definitely preferred, because the FORMAT alternative was acting odd.
+ (pprint-logical-block (stream nil)
+ (format stream
+ "debugger invoked on a ~S~@[ in thread ~A~]: ~2I~_~A"
+ (type-of condition)
+ #!+sb-thread sb!thread:*current-thread*
+ #!-sb-thread nil
+ condition))
+ (terpri stream))
+
+(defun %invoke-debugger (condition)
+ (let ((*debug-condition* condition)
+ (*debug-restarts* (compute-restarts condition))
+ (*nested-debug-condition* nil))
+ (handler-case
+ ;; (The initial output here goes to *ERROR-OUTPUT*, because the
+ ;; initial output is not interactive, just an error message, and
+ ;; when people redirect *ERROR-OUTPUT*, they could reasonably
+ ;; expect to see error messages logged there, regardless of what
+ ;; the debugger does afterwards.)
+ (unless (typep condition 'step-condition)
+ (%print-debugger-invocation-reason condition *error-output*))
+ (error (condition)
+ (setf *nested-debug-condition* condition)
+ (let ((ndc-type (type-of *nested-debug-condition*)))
+ (format *error-output*
+ "~&~@<(A ~S was caught when trying to print ~S when ~
+ entering the debugger. Printing was aborted and the ~
+ ~S was stored in ~S.)~@:>~%"
+ ndc-type
+ '*debug-condition*
+ ndc-type
+ '*nested-debug-condition*))
+ (when (typep *nested-debug-condition* 'cell-error)
+ ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
+ (format *error-output*
+ "~&(CELL-ERROR-NAME ~S) = ~S~%"
+ '*nested-debug-condition*
+ (cell-error-name *nested-debug-condition*)))))
+
+ (let ((background-p (sb!thread::debugger-wait-until-foreground-thread
+ *debug-io*)))
+
+ ;; After the initial error/condition/whatever announcement to
+ ;; *ERROR-OUTPUT*, we become interactive, and should talk on
+ ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
+ ;; statement, not a description of reality.:-| There's a lot of
+ ;; older debugger code which was written to do i/o on whatever
+ ;; stream was in fashion at the time, and not all of it has
+ ;; been converted to behave this way. -- WHN 2000-11-16)
+
+ (unwind-protect
+ (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO*
+ ;; here as well, but that is probably bogus since it
+ ;; removes the users ability to do output to a redirected
+ ;; *S-O*. Now we just rebind it so that users can temporarily
+ ;; frob it. FIXME: This and other "what gets bound when"
+ ;; behaviour should be documented in the manual.
+ (*standard-output* *standard-output*)
+ ;; This seems reasonable: e.g. if the user has redirected
+ ;; *ERROR-OUTPUT* to some log file, it's probably wrong
+ ;; to send errors which occur in interactive debugging to
+ ;; that file, and right to send them to *DEBUG-IO*.
+ (*error-output* *debug-io*))
+ (unless (typep condition 'step-condition)
+ (when *debug-beginner-help-p*
+ (format *debug-io*
+ "~%~@<Type HELP for debugger help, or ~
+ (SB-EXT:QUIT) to exit from SBCL.~:@>~2%"))
+ (show-restarts *debug-restarts* *debug-io*))
+ (internal-debug))
+ (when background-p
+ (sb!thread::release-foreground))))))
+
+;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
+;;; ANSI behavior has been suppressed by the "--disable-debugger"
+;;; command-line option
+(defun debugger-disabled-hook (condition me)
+ (declare (ignore me))
+ ;; There is no one there to interact with, so report the
+ ;; condition and terminate the program.
+ (flet ((failure-quit (&key recklessly-p)
+ (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)")
+ (quit :unix-status 1 :recklessly-p recklessly-p)))
+ ;; This HANDLER-CASE is here mostly to stop output immediately
+ ;; (and fall through to QUIT) when there's an I/O error. Thus,
+ ;; when we're run under a shell script or something, we can die
+ ;; cleanly when the script dies (and our pipes are cut), instead
+ ;; of falling into ldb or something messy like that. Similarly, we
+ ;; can terminate cleanly even if BACKTRACE dies because of bugs in
+ ;; user PRINT-OBJECT methods.
+ (handler-case
+ (progn
+ (format *error-output*
+ "~&~@<unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
+ (type-of condition)
+ #!+sb-thread sb!thread:*current-thread*
+ #!-sb-thread nil
+ condition)
+ ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
+ ;; even if we hit an error within BACKTRACE (e.g. a bug in
+ ;; the debugger's own frame-walking code, or a bug in a user
+ ;; PRINT-OBJECT method) we'll at least have the CONDITION
+ ;; printed out before we die.
+ (finish-output *error-output*)
+ ;; (Where to truncate the BACKTRACE is of course arbitrary, but
+ ;; it seems as though we should at least truncate it somewhere.)
+ (sb!debug:backtrace 128 *error-output*)
+ (format
+ *error-output*
+ "~%unhandled condition in --disable-debugger mode, quitting~%")
+ (finish-output *error-output*)
+ (failure-quit))
+ (condition ()
+ ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can
+ ;; fail when our output streams are blown away, as e.g. when
+ ;; we're running under a Unix shell script and it dies somehow
+ ;; (e.g. because of a SIGINT). In that case, we might as well
+ ;; just give it up for a bad job, and stop trying to notify
+ ;; the user of anything.
+ ;;
+ ;; Actually, the only way I've run across to exercise the
+ ;; problem is to have more than one layer of shell script.
+ ;; I have a shell script which does
+ ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp
+ ;; and the problem occurs when I interrupt this with Ctrl-C
+ ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1).
+ ;; I haven't figured out whether it's bash, time, tee, Linux, or
+ ;; what that is responsible, but that it's possible at all
+ ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24
+ (ignore-errors
+ (%primitive print
+ "Argh! error within --disable-debugger error handling"))
+ (failure-quit :recklessly-p t)))))
+
+(defvar *old-debugger-hook* nil)
+
+;;; halt-on-failures and prompt-on-failures modes, suitable for
+;;; noninteractive and interactive use respectively
+(defun disable-debugger ()
+ ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort
+ ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had
+ ;; to set it to a suitable value again and be very careful,
+ ;; especially if the user has also set it. -- MG 2005-07-15
+ (unless (eq *invoke-debugger-hook* 'debugger-disabled-hook)
+ (setf *old-debugger-hook* *invoke-debugger-hook*
+ *invoke-debugger-hook* 'debugger-disabled-hook))
+ ;; This is not inside the UNLESS to ensure that LDB is disabled
+ ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was.
+ ;; This might matter for example when restoring a core.
+ (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler"
+ (function sb!alien:void))))
+
+(defun enable-debugger ()
+ (when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
+ (setf *invoke-debugger-hook* *old-debugger-hook*
+ *old-debugger-hook* nil))
+ (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler"
+ (function sb!alien:void))))