X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=2b6218440af047f63c6389e3c5e8f7fe2225b3a6;hb=4ed3f0d08c3a57a6762018d9622f253ab9d0f2b6;hp=6f26239b70d1fe949821674287a42b424b966d6d;hpb=a09b213e5812edd1ef3e88c18bde6bd1294da547;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 6f26239..2b62184 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -447,9 +447,10 @@ Other commands: ;;; ANSI specifies that this macro shall exist, even if only as a ;;; trivial placeholder like this. (defmacro step (form) - "a trivial placeholder implementation of the CL:STEP macro required by - the ANSI spec" - `(progn + "This is a trivial placeholder implementation of the CL:STEP macro required + by the ANSI spec, simply expanding to `(LET () ,FORM). A more featureful + version would be welcome, we just haven't written it." + `(let () ,form)) ;;;; BACKTRACE @@ -643,7 +644,9 @@ Other commands: (defvar *debug-condition*) (defvar *nested-debug-condition*) -(defun invoke-debugger (condition) +;;; the ordinary ANSI case of INVOKE-DEBUGGER, when not suppressed by +;;; command-line --disable-debugger option +(defun invoke-debugger/enabled (condition) #!+sb-doc "Enter the debugger." (let ((old-hook *debugger-hook*)) @@ -723,9 +726,10 @@ reset to ~S." ;; regardless of what the debugger does afterwards.) (handler-case (format *error-output* - "~2&~@~%" (type-of *debug-condition*) + (sb!thread:current-thread-id) *debug-condition*) (error (condition) (setf *nested-debug-condition* condition) @@ -785,13 +789,82 @@ reset to ~S." (internal-debug)) (when background-p (sb!thread::release-foreground))))))) +;;; the degenerate case of INVOKE-DEBUGGER, when ordinary ANSI behavior +;;; has been suppressed by command-line --disable-debugger option +(defun invoke-debugger/disabled (condition) + ;; 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* + "~&~@~2%" + (type-of condition) + 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 () + (setf (fdefinition 'invoke-debugger) #'invoke-debugger/disabled + *debug-io* *error-output*)) +(defun enable-debugger () + (setf (fdefinition 'invoke-debugger) #'invoke-debugger/enabled + *debug-io* *query-io*)) +;;; The enabled mode is the ANSI default. +(enable-debugger) + (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:~%") + (format s "~&restarts (invokable by number or by ~ + possibly-abbreviated name):~%") (let ((count 0) (names-used '(nil)) (max-name-len 0)) @@ -824,7 +897,7 @@ reset to ~S." (*read-suppress* nil)) (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*)) - (debug-loop))) + (funcall *debug-loop-fun*))) ;;;; DEBUG-LOOP @@ -835,7 +908,7 @@ reset to ~S." "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while executing in the debugger.") -(defun debug-loop () +(defun debug-loop-fun () (let* ((*debug-command-level* (1+ *debug-command-level*)) (*real-stack-top* (sb!di:top-frame)) (*stack-top* (or *stack-top-hint* *real-stack-top*)) @@ -883,6 +956,9 @@ reset to ~S." (t (funcall cmd-fun)))))))))))) +(defvar *debug-loop-fun* #'debug-loop-fun + "a function taking no parameters that starts the low-level debug loop") + ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic. (defun debug-eval-print (expr) (/noshow "entering DEBUG-EVAL-PRINT" expr)