X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=c829c182b1c0f7a0eeb747f4c2691395c11147d0;hb=2561033fd3ed9e224dffc445262e097e5abfa920;hp=e47ac172f45c6088d7277611ca5c0211973ca0be;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index e47ac17..c829c18 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -471,28 +471,20 @@ is how many frames to show." (nreverse (mapcar #'cdr *debug-print-variable-alist*)) (apply fun rest))))))) -;;; the ordinary ANSI case of INVOKE-DEBUGGER, when not suppressed by -;;; command-line --disable-debugger option (defun invoke-debugger (condition) #!+sb-doc "Enter the debugger." - (let ((old-hook *debugger-hook*)) - (when old-hook - (let ((*debugger-hook* nil)) - (funcall old-hook condition old-hook)))) + ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not + ;; called when the debugger is disabled (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 + (let ((old-hook *debugger-hook*)) + (when old-hook + (let ((*debugger-hook* nil)) + (funcall old-hook condition old-hook)))) ;; We definitely want *PACKAGE* to be of valid type. ;; @@ -515,6 +507,21 @@ reset to ~S." (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) @@ -526,13 +533,7 @@ reset to ~S." ;; 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&~@~%" - (type-of *debug-condition*) - #!+sb-thread sb!thread:*current-thread* - #!-sb-thread nil - *debug-condition*) + (%print-debugger-invocation-reason condition *error-output*) (error (condition) (setf *nested-debug-condition* condition) (let ((ndc-type (type-of *nested-debug-condition*))) @@ -544,12 +545,12 @@ reset to ~S." '*debug-condition* ndc-type '*nested-debug-condition*)) - (when (typep condition 'cell-error) + (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~%" - '*debug-condition* - (cell-error-name *debug-condition*))))) + '*nested-debug-condition* + (cell-error-name *nested-debug-condition*))))) (let ((background-p (sb!thread::debugger-wait-until-foreground-thread *debug-io*))) @@ -649,16 +650,21 @@ reset to ~S." ;;; halt-on-failures and prompt-on-failures modes, suitable for ;;; noninteractive and interactive use respectively (defun disable-debugger () + ;; Why conditionally? Why not disable it even if user has frobbed + ;; this hook? We could just save the old value in case of a later + ;; ENABLE-DEBUGGER. (when (eql *invoke-debugger-hook* nil) - (setf *debug-io* *error-output* - *invoke-debugger-hook* 'debugger-disabled-hook))) + ;; *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 + (setf *invoke-debugger-hook* 'debugger-disabled-hook) + (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 *debug-io* *query-io* - *invoke-debugger-hook* nil))) - -(setf *debug-io* *query-io*) + (setf *invoke-debugger-hook* nil) + (sb!alien:alien-funcall (sb!alien:extern-alien "enable_lossage_handler" (function sb!alien:void))))) (defun show-restarts (restarts s) (cond ((null restarts) @@ -718,6 +724,14 @@ reset to ~S." "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while executing in the debugger.") +(defun debug-read (stream) + (declare (type stream stream)) + (let* ((eof-marker (cons nil nil)) + (form (read stream nil eof-marker))) + (if (eq form eof-marker) + (abort) + form))) + (defun debug-loop-fun () (let* ((*debug-command-level* (1+ *debug-command-level*)) (*real-stack-top* (sb!di:top-frame)) @@ -732,38 +746,39 @@ reset to ~S." (terpri *debug-io*) (print-frame-call *current-frame* *debug-io* :verbosity 2) (loop - (catch 'debug-loop-catcher - (handler-bind ((error (lambda (condition) - (when *flush-debug-errors* - (clear-input *debug-io*) - (princ condition *debug-io*) - (format *debug-io* - "~&error flushed (because ~ + (catch 'debug-loop-catcher + (handler-bind ((error (lambda (condition) + (when *flush-debug-errors* + (clear-input *debug-io*) + (princ condition *debug-io*) + (format *debug-io* + "~&error flushed (because ~ ~S is set)" - '*flush-debug-errors*) - (/show0 "throwing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil))))) - ;; We have to bind LEVEL for the restart function created by - ;; WITH-SIMPLE-RESTART. - (let ((level *debug-command-level*) - (restart-commands (make-restart-commands))) - (with-simple-restart (abort - "~@" - level) - (debug-prompt *debug-io*) - (force-output *debug-io*) - (let* ((exp (read *debug-io*)) - (cmd-fun (debug-command-p exp restart-commands))) - (cond ((not cmd-fun) - (debug-eval-print exp)) - ((consp cmd-fun) - (format *debug-io* - "~&Your command, ~S, is ambiguous:~%" - exp) - (dolist (ele cmd-fun) - (format *debug-io* " ~A~%" ele))) - (t - (funcall cmd-fun)))))))))))) + '*flush-debug-errors*) + (/show0 "throwing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil))))) + ;; We have to bind LEVEL for the restart function created by + ;; WITH-SIMPLE-RESTART. + (let ((level *debug-command-level*) + (restart-commands (make-restart-commands))) + (flush-standard-output-streams) + (debug-prompt *debug-io*) + (force-output *debug-io*) + (let* ((exp (debug-read *debug-io*)) + (cmd-fun (debug-command-p exp restart-commands))) + (with-simple-restart (abort + "~@" + level) + (cond ((not cmd-fun) + (debug-eval-print exp)) + ((consp cmd-fun) + (format *debug-io* + "~&Your command, ~S, is ambiguous:~%" + exp) + (dolist (ele cmd-fun) + (format *debug-io* " ~A~%" ele))) + (t + (funcall cmd-fun)))))))))))) (defun debug-eval-print (expr) (/noshow "entering DEBUG-EVAL-PRINT" expr) @@ -1095,8 +1110,8 @@ reset to ~S." (let ((num (read-if-available :prompt))) (when (eq num :prompt) (show-restarts *debug-restarts* *debug-io*) - (write-string "restart: ") - (force-output) + (write-string "restart: " *debug-io*) + (force-output *debug-io*) (setf num (read *debug-io*))) (let ((restart (typecase num (unsigned-byte