- (funcall hook condition hook))))
- (sb!unix:unix-sigsetmask 0)
- (let ((original-package *package*)) ; protect it from WITH-STANDARD-IO-SYNTAX
- (with-standard-io-syntax
- (let* ((*debug-condition* condition)
- (*debug-restarts* (compute-restarts condition))
- ;; FIXME: The next two bindings seem flaky, violating the
- ;; principle of least surprise. But in order to fix them, we'd
- ;; need to go through all the i/o statements in the debugger,
- ;; since a lot of them do their thing on *STANDARD-INPUT* and
- ;; *STANDARD-OUTPUT* instead of *DEBUG-IO*.
- (*standard-input* *debug-io*) ; in case of setq
- (*standard-output* *debug-io*) ; '' '' '' ''
- ;; We also want to set the i/o subsystem into a known, useful
- ;; state, regardless of where in 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))
- (format *error-output*
- "~2&debugger invoked on ~S of type ~S:~% ~A~%"
- '*debug-condition*
- (type-of *debug-condition*)
- *debug-condition*)
- (let (;; FIXME: like the bindings of *STANDARD-INPUT* and
- ;; *STANDARD-OUTPUT* above..
- (*error-output* *debug-io*))
- (unless (typep condition 'step-condition)
- (show-restarts *debug-restarts* *error-output*))
- (internal-debug))))))
-
-(defun show-restarts (restarts &optional (s *error-output*))
- (when restarts
- (format s "~&restarts:~%")
- (let ((count 0)
- (names-used '(nil))
- (max-name-len 0))
- (dolist (restart restarts)
- (let ((name (restart-name restart)))
- (when name
- (let ((len (length (princ-to-string name))))
- (when (> len max-name-len)
- (setf max-name-len len))))))
- (unless (zerop max-name-len)
- (incf max-name-len 3))
- (dolist (restart restarts)
- (let ((name (restart-name restart)))
- (cond ((member name names-used)
- (format s "~& ~2D: ~@VT~A~%" count max-name-len restart))
- (t
- (format s "~& ~2D: [~VA] ~A~%"
- count (- max-name-len 3) name restart)
- (push name names-used))))
- (incf count)))))
-
-;;; This calls DEBUG-LOOP, performing some simple initializations before doing
-;;; so. INVOKE-DEBUGGER calls this to actually get into the debugger.
-;;; SB!CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug
-;;; prompt as quickly as possible with as little risk as possible for stepping
-;;; on whatever is causing recursive errors.
+ (funcall old-hook condition old-hook))))
+ (let ((old-hook *invoke-debugger-hook*))
+ (when old-hook
+ (let ((*invoke-debugger-hook* nil))
+ (funcall old-hook condition old-hook))))
+
+ ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here, to reset the
+ ;; signal state in the case that we wind up in the debugger as a
+ ;; result of something done by a signal handler. It's not
+ ;; altogether obvious that this is necessary, and indeed SBCL has
+ ;; not been doing it since 0.7.8.5. But nobody seems altogether
+ ;; convinced yet
+ ;; -- dan 2003.11.11, based on earlier comment of WHN 2002-09-28
+
+ ;; We definitely want *PACKAGE* to be of valid type.
+ ;;
+ ;; Elsewhere in the system, we use the SANE-PACKAGE function for
+ ;; this, but here causing an exception just as we're trying to handle
+ ;; an exception would be confusing, so instead we use a special hack.
+ (unless (and (packagep *package*)
+ (package-name *package*))
+ (setf *package* (find-package :cl-user))
+ (format *error-output*
+ "The value of ~S was not an undeleted PACKAGE. It has been
+reset to ~S."
+ '*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 %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.)
+ (format *error-output*
+ "~2&~@<debugger invoked on a ~S in thread ~A: ~
+ ~2I~_~A~:>~%"
+ (type-of *debug-condition*)
+ (sb!thread:current-thread-id)
+ *debug-condition*)
+ (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 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~%"
+ '*debug-condition*
+ (cell-error-name *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 (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems 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*. (CMU CL
+ ;; used to rebind *STANDARD-INPUT* here too, but that's
+ ;; been fixed already.)
+ (*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)
+ (when *debug-beginner-help-p*
+ (format *debug-io*
+ "~%~@<You can 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:current-thread-id)
+ 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)))))
+
+;;; halt-on-failures and prompt-on-failures modes, suitable for
+;;; noninteractive and interactive use respectively
+(defun disable-debugger ()
+ (when (eql *invoke-debugger-hook* nil)
+ (setf *debug-io* *error-output*
+ *invoke-debugger-hook* 'debugger-disabled-hook)))
+
+(defun enable-debugger ()
+ (when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
+ (setf *invoke-debugger-hook* nil)))
+
+(setf *debug-io* *query-io*)
+
+(defun show-restarts (restarts s)
+ (cond ((null restarts)
+ (format s
+ "~&(no restarts: If you didn't do this on purpose, ~
+ please report it as a bug.)~%"))
+ (t
+ (format s "~&restarts (invokable by number or by ~
+ possibly-abbreviated name):~%")
+ (let ((count 0)
+ (names-used '(nil))
+ (max-name-len 0))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ (when name
+ (let ((len (length (princ-to-string name))))
+ (when (> len max-name-len)
+ (setf max-name-len len))))))
+ (unless (zerop max-name-len)
+ (incf max-name-len 3))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ (cond ((member name names-used)
+ (format s "~& ~2D: ~V@T~A~%" count max-name-len restart))
+ (t
+ (format s "~& ~2D: [~VA] ~A~%"
+ count (- max-name-len 3) name restart)
+ (push name names-used))))
+ (incf count))))))
+
+(defvar *debug-loop-fun* #'debug-loop-fun
+ "a function taking no parameters that starts the low-level debug loop")
+
+;;; This calls DEBUG-LOOP, performing some simple initializations
+;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
+;;; the debugger. SB!KERNEL::ERROR-ERROR calls this in emergencies
+;;; to get into a debug prompt as quickly as possible with as little
+;;; risk as possible for stepping on whatever is causing recursive
+;;; errors.
projects / sbcl.git / blobdiff