of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
around the invocation.")
+(defvar *invoke-debugger-hook* nil
+ #!+sb-doc
+ "This is either NIL or a designator for a function of two arguments,
+ to be run when the debugger is about to be entered. The function is
+ run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive
+ errors, and receives as arguments the condition that triggered
+ debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK*
+
+ This mechanism is an SBCL extension similar to the standard *DEBUGGER-HOOK*.
+ In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when
+ called by BREAK.")
+
;;; These are bound on each invocation of INVOKE-DEBUGGER.
(defvar *debug-restarts*)
(defvar *debug-condition*)
;;; the ordinary ANSI case of INVOKE-DEBUGGER, when not suppressed by
;;; command-line --disable-debugger option
-(defun invoke-debugger/enabled (condition)
+(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))))
+ (let ((old-hook *invoke-debugger-hook*))
+ (when old-hook
+ (let ((*invoke-debugger-hook* nil))
+ (funcall old-hook condition old-hook))))
- ;; If we're a background thread and *background-threads-wait-for-debugger*
- ;; is NIL, this will invoke a restart
-
- ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here. I deleted it
- ;; around sbcl-0.7.8.5 (by which time it had mutated to have a
- ;; #!-SUNOS prefix and a FIXME note observing that it wasn't needed
- ;; on SunOS and no one knew why it was needed anywhere else either).
- ;; So if something mysteriously breaks that has worked since the CMU
- ;; CL days, that might be why. -- WHN 2002-09-28
+ ;; 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.
;;
;; regardless of what the debugger does afterwards.)
(handler-case
(format *error-output*
- "~2&~@<debugger invoked on condition of type ~S: ~
+ "~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)
'*debug-condition*
(cell-error-name *debug-condition*)))))
+ (setf 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
;; stream was in fashion at the time, and not all of it has
;; been converted to behave this way. -- WHN 2000-11-16)
- (setf background-p
- (sb!thread::debugger-wait-until-foreground-thread *debug-io*))
(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*
- "~%~@<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. You can suppress this ~
- message by clearing ~S.~:@>~2%"
- '*debug-condition*
- '*debug-beginner-help-p*))
- (show-restarts *debug-restarts* *debug-io*))
+ (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)))))))
-
-;;; the degenerate case of INVOKE-DEBUGGER, when ordinary ANSI behavior
-;;; has been suppressed by command-line --disable-debugger option
-(defun invoke-debugger/disabled (condition)
+ (when background-p
+ (sb!thread::release-foreground)))))))
+
+;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary
+;;; ANSI behavior has been suppressed by command-line
+;;; --disable-debugger 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)
;;; 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*))
+ (when (eql *invoke-debugger-hook* nil)
+ (setf *debug-io* *error-output*
+ *invoke-debugger-hook* 'debugger-disabled-hook)))
+
(defun enable-debugger ()
- (setf (fdefinition 'invoke-debugger) #'invoke-debugger/enabled
- *debug-io* *query-io*))
-;;; The enabled mode is the ANSI default.
-(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)
(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
(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)
projects / sbcl.git / blobdiff