0.8.12.6:

[sbcl.git] / src / code / debug.lisp

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index ec3d3b2..b7c1306 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -31,12 +31,25 @@
 ;;;         to satisfy lambda list
 ;;;           #:
 ;;;         exactly 2 expected, but 5 found
 ;;;         to satisfy lambda list
 ;;;           #:
 ;;;         exactly 2 expected, but 5 found

+;;;
+;;; FIXME: These variables were deprecated in late February 2004, and
+;;; can probably be removed in about a year.

 (defvar *debug-print-level* 5
   #!+sb-doc
 (defvar *debug-print-level* 5
   #!+sb-doc

-  "*PRINT-LEVEL* for the debugger")
+  "(This is deprecated in favor of *DEBUG-PRINT-VARIABLE-ALIST*.)
+
+*PRINT-LEVEL* for the debugger")

 (defvar *debug-print-length* 7
   #!+sb-doc
 (defvar *debug-print-length* 7
   #!+sb-doc

-  "*PRINT-LENGTH* for the debugger")
+  "(This is deprecated in favor of *DEBUG-PRINT-VARIABLE-ALIST*.)
+
+*PRINT-LENGTH* for the debugger")
+
+(defvar *debug-print-variable-alist* nil
+  #!+sb-doc
+  "an association list describing new bindings for special variables
+(typically *PRINT-FOO* variables) to be used within the debugger, e.g.
+((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL))")

 
 (defvar *debug-readtable*
   ;; KLUDGE: This can't be initialized in a cold toplevel form,
 
 (defvar *debug-readtable*
   ;; KLUDGE: This can't be initialized in a cold toplevel form,

@@ -71,6 +84,7 @@
   "Should the debugger display beginner-oriented help messages?")
 
 (defun debug-prompt (stream)
   "Should the debugger display beginner-oriented help messages?")
 
 (defun debug-prompt (stream)

+  (sb!thread::get-foreground)

   (format stream
          "~%~W~:[~;[~W~]] "
          (sb!di:frame-number *current-frame*)
   (format stream
          "~%~W~:[~;[~W~]] "
          (sb!di:frame-number *current-frame*)

@@ -78,9 +92,9 @@
          *debug-command-level*))
   
 (defparameter *debug-help-string*
          *debug-command-level*))
   
 (defparameter *debug-help-string*

-"The prompt is square brackets, with number(s) indicating the current control
-  stack level and, if you've entered the debugger recursively, how deeply
-  recursed you are.
+"The debug prompt is square brackets, with number(s) indicating the current
+  control stack level and, if you've entered the debugger recursively, how
+  deeply recursed you are.

 Any command -- including the name of a restart -- may be uniquely abbreviated.
 The debugger rebinds various special variables for controlling i/o, sometimes
   to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to 
 Any command -- including the name of a restart -- may be uniquely abbreviated.
 The debugger rebinds various special variables for controlling i/o, sometimes
   to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to 

@@ -94,8 +108,8 @@ Getting in and out of the debugger:
   RESTART  invokes restart numbered as shown (prompt if not given).
   ERROR    prints the error condition and restart cases.
   The number of any restart, or its name, or a unique abbreviation for its
   RESTART  invokes restart numbered as shown (prompt if not given).
   ERROR    prints the error condition and restart cases.
   The number of any restart, or its name, or a unique abbreviation for its

-    name, is a valid command, and is the same as using RESTART to invoke that
-    restart.
+    name, is a valid command, and is the same as using RESTART to invoke
+    that restart.

 
 Changing frames:
   U      up frame     D    down frame
 
 Changing frames:
   U      up frame     D    down frame

@@ -122,17 +136,20 @@ Breakpoints and steps:
   STEP [n]                           Step to the next location or step n times.
 
 Function and macro commands:
   STEP [n]                           Step to the next location or step n times.
 
 Function and macro commands:

- (SB-DEBUG:DEBUG-RETURN expression)
-    Exit the debugger, returning expression's values from the current frame.

  (SB-DEBUG:ARG n)
     Return the n'th argument in the current frame.
  (SB-DEBUG:VAR string-or-symbol [id])
     Returns the value of the specified variable in the current frame.
 
 Other commands:
  (SB-DEBUG:ARG n)
     Return the n'th argument in the current frame.
  (SB-DEBUG:VAR string-or-symbol [id])
     Returns the value of the specified variable in the current frame.
 
 Other commands:

-  SLURP   Discard all pending input on *STANDARD-INPUT*. (This can be
-          useful when the debugger was invoked to handle an error in
-          deeply nested input syntax, and now the reader is confused.)")
+  RETURN expr
+    [EXPERIMENTAL] Return the values resulting from evaluation of expr
+    from the current frame, if this frame was compiled with a sufficiently
+    high DEBUG optimization quality.
+  SLURP
+    Discard all pending input on *STANDARD-INPUT*. (This can be
+    useful when the debugger was invoked to handle an error in
+    deeply nested input syntax, and now the reader is confused.)")

 \f
 ;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint.
 (define-condition step-condition (simple-condition) ())
 \f
 ;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint.
 (define-condition step-condition (simple-condition) ())

@@ -443,9 +460,10 @@ Other commands:
 ;;; ANSI specifies that this macro shall exist, even if only as a
 ;;; trivial placeholder like this.
 (defmacro step (form)
 ;;; 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))
 \f
 ;;;; BACKTRACE
      ,form))
 \f
 ;;;; BACKTRACE

@@ -557,19 +575,17 @@ Other commands:
          (nreverse reversed-result))
       (sb!di:lambda-list-unavailable
        ()
          (nreverse reversed-result))
       (sb!di:lambda-list-unavailable
        ()

-       :lambda-list-unavailable))))
+       (make-unprintable-object "unavailable lambda list")))))

 
 ;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
 ;;; print as many of the values as possible, punting the loop over
 ;;; lambda-list variables since any other arguments will be in the
 ;;; &REST arg's list of values.
 (defun print-frame-call-1 (frame)
 
 ;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
 ;;; print as many of the values as possible, punting the loop over
 ;;; lambda-list variables since any other arguments will be in the
 ;;; &REST arg's list of values.
 (defun print-frame-call-1 (frame)

-  (let ((debug-fun (sb!di:frame-debug-fun frame))
-       (loc (sb!di:frame-code-location frame)))
+  (let ((debug-fun (sb!di:frame-debug-fun frame)))

 
     (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
 
     (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")

-      (let ((args (mapcar #'ensure-printable-object
-                         (frame-args-as-list frame))))
+      (let ((args (ensure-printable-object (frame-args-as-list frame))))

        ;; Since we go to some trouble to make nice informative function
        ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
        ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
        ;; Since we go to some trouble to make nice informative function
        ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
        ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.

@@ -577,7 +593,9 @@ Other commands:
              (*print-level* nil))
          (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
        ;; For the function arguments, we can just print normally.
              (*print-level* nil))
          (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
        ;; For the function arguments, we can just print normally.

-       (format t "~{ ~_~S~}" args)))
+        (if (listp args)
+            (format t "~{ ~_~S~}" args)
+            (format t " ~S" args))))

 
     (when (sb!di:debug-fun-kind debug-fun)
       (write-char #\[)
 
     (when (sb!di:debug-fun-kind debug-fun)
       (write-char #\[)

@@ -634,22 +652,118 @@ Other commands:
    of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
    around the invocation.")
 
    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*)
 (defvar *nested-debug-condition*)
 
 ;;; These are bound on each invocation of INVOKE-DEBUGGER.
 (defvar *debug-restarts*)
 (defvar *debug-condition*)
 (defvar *nested-debug-condition*)
 

+;;; Oh, what a tangled web we weave when we preserve backwards
+;;; compatibility with 1968-style use of global variables to control
+;;; per-stream i/o properties; there's really no way to get this
+;;; quite right, but we do what we can.
+(defun funcall-with-debug-io-syntax (fun &rest rest)
+  (declare (type function fun))
+  ;; Try to force the other special variables into a useful state.
+  (let (;; Protect from WITH-STANDARD-IO-SYNTAX some variables where
+       ;; any default we might use is less useful than just reusing
+       ;; the global values.
+       (original-package *package*)
+       (original-print-pretty *print-pretty*))
+    (with-standard-io-syntax
+     (let (;; We want the printer and reader to be in a useful state,
+          ;; regardless of where the debugger was invoked in the
+          ;; program. WITH-STANDARD-IO-SYNTAX did much of what we
+          ;; want, but
+          ;;   * It doesn't affect our internal special variables 
+          ;;     like *CURRENT-LEVEL-IN-PRINT*.
+          ;;   * It isn't customizable.
+          ;;   * It doesn't set *PRINT-READABLY* to the same value
+          ;;     as the toplevel default.
+          ;;   * It sets *PACKAGE* to COMMON-LISP-USER, which is not
+          ;;     helpful behavior for a debugger.
+          ;;   * There's no particularly good debugger default for
+          ;;     *PRINT-PRETTY*, since T is usually what you want
+          ;;     -- except absolutely not what you want when you're
+          ;;     debugging failures in PRINT-OBJECT logic.
+          ;; We try to address all these issues with explicit
+          ;; rebindings here.
+          (sb!kernel:*current-level-in-print* 0)
+          (*package* original-package)
+          (*print-pretty* original-print-pretty)
+          (*print-readably* nil)
+          ;; Clear the circularity machinery to try to to reduce the
+          ;; pain from sharing the circularity table across all
+          ;; streams; if these are not rebound here, then setting
+          ;; *PRINT-CIRCLE* within the debugger when debugging in a
+          ;; state where something circular was being printed (e.g.,
+          ;; because the debugger was entered on an error in a
+          ;; PRINT-OBJECT method) makes a hopeless mess. Binding them
+          ;; here does seem somewhat ugly because it makes it more
+          ;; difficult to debug the printing-of-circularities code
+          ;; itself; however, as far as I (WHN, 2004-05-29) can see,
+          ;; that's almost entirely academic as long as there's one
+          ;; shared *C-H-T* for all streams (i.e., it's already
+          ;; unreasonably difficult to debug print-circle machinery
+          ;; given the buggy crosstalk between the debugger streams
+          ;; and the stream you're trying to watch), and any fix for
+          ;; that buggy arrangement will likely let this hack go away
+          ;; naturally.
+          (sb!impl::*circularity-hash-table* . nil)
+          (sb!impl::*circularity-counter* . nil)
+          ;; These rebindings are now (as of early 2004) deprecated,
+          ;; with the new *PRINT-VAR-ALIST* mechanism preferred.
+          (*print-length* *debug-print-length*)
+          (*print-level* *debug-print-level*)
+          (*readtable* *debug-readtable*))
+       (progv
+          ;; (Why NREVERSE? PROGV makes the later entries have
+          ;; precedence over the earlier entries.
+          ;; *DEBUG-PRINT-VARIABLE-ALIST* is called an alist, so it's
+          ;; expected that its earlier entries have precedence. And
+          ;; the earlier-has-precedence behavior is mostly more
+          ;; convenient, so that programmers can use PUSH or LIST* to
+          ;; customize *DEBUG-PRINT-VARIABLE-ALIST*.)
+          (nreverse (mapcar #'car *debug-print-variable-alist*))
+          (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."
 (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 *debugger-hook*))
     (when old-hook
       (let ((*debugger-hook* nil))
        (funcall old-hook condition old-hook))))

-  ;; FIXME: No-one seems to know what this is for. Nothing is noticeably
-  ;; broken on sunos...
-  #!-sunos (sb!unix:unix-sigsetmask 0)
+  (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.
   ;; 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.

@@ -660,102 +774,157 @@ Other commands:
            "The value of ~S was not an undeleted PACKAGE. It has been
 reset to ~S."
            '*package* *package*))
            "The value of ~S was not an undeleted PACKAGE. It has been
 reset to ~S."
            '*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-IN-PRINT*.
-           ;;   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-in-print* 0)
-           (*print-length* *debug-print-length*)
-           (*print-level* *debug-print-level*)
-           (*readtable* *debug-readtable*)
-           (*print-readably* nil)
-           (*print-pretty* t)
-           (*package* original-package)
-           (*nested-debug-condition* nil))
-
-       ;; 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, and get confused.
-       (flush-standard-output-streams)
-
-       ;; (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.)
-       (handler-case
-          (format *error-output*
-                  "~2&~@<debugger invoked on condition of type ~S: ~
+
+  ;; 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~:>~%"
                     ~2I~_~A~:>~%"

-                  (type-of *debug-condition*)
-                  *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 ~
+               (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.)~@:>~%"
                       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*)))))
-
-       ;; 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: 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*))
-        (internal-debug))))))
+                 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 condition (of type ~S): ~2I~_~A~:>~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 ()
+  (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)
 
 (defun show-restarts (restarts s)
   (cond ((null restarts)

@@ -763,7 +932,8 @@ reset to ~S."
                 "~&(no restarts: If you didn't do this on purpose, ~
                   please report it as a bug.)~%"))
        (t
                 "~&(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))
         (let ((count 0)
               (names-used '(nil))
               (max-name-len 0))

@@ -785,6 +955,9 @@ reset to ~S."
                      (push name names-used))))
             (incf count))))))
 
                      (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
 ;;; 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

@@ -796,8 +969,7 @@ reset to ~S."
        (*read-suppress* nil))
     (unless (typep *debug-condition* 'step-condition)
       (clear-input *debug-io*))
        (*read-suppress* nil))
     (unless (typep *debug-condition* 'step-condition)
       (clear-input *debug-io*))

-    #!-mp (debug-loop)
-    #!+mp (sb!mp:without-scheduling (debug-loop))))
+    (funcall *debug-loop-fun*)))

 \f
 ;;;; DEBUG-LOOP
 
 \f
 ;;;; DEBUG-LOOP
 

@@ -808,7 +980,7 @@ reset to ~S."
   "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
    executing in the debugger.")
 
   "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*))
   (let* ((*debug-command-level* (1+ *debug-command-level*))
         (*real-stack-top* (sb!di:top-frame))
         (*stack-top* (or *stack-top-hint* *real-stack-top*))

@@ -840,37 +1012,21 @@ reset to ~S."
            (let ((level *debug-command-level*)
                  (restart-commands (make-restart-commands)))
              (with-simple-restart (abort
            (let ((level *debug-command-level*)
                  (restart-commands (make-restart-commands)))
              (with-simple-restart (abort

-                                  "Reduce debugger level (to debug level ~W)."
+                                  "~@<Reduce debugger level (to debug level ~W).~@:>"

                                    level)
                (debug-prompt *debug-io*)
                (force-output *debug-io*)
                                    level)
                (debug-prompt *debug-io*)
                (force-output *debug-io*)

-               (let ((input (sb!int:get-stream-command *debug-io*)))
-                 (cond (input
-                        (let ((cmd-fun (debug-command-p
-                                        (sb!int:stream-command-name input)
-                                        restart-commands)))
-                          (cond
-                           ((not cmd-fun)
-                            (error "unknown stream-command: ~S" input))
-                           ((consp cmd-fun)
-                            (error "ambiguous debugger command: ~S" cmd-fun))
-                           (t
-                            (apply cmd-fun
-                                   (sb!int:stream-command-args input))))))
+               (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 t "~&Your command, ~S, is ambiguous:~%"
+                                exp)
+                        (dolist (ele cmd-fun)
+                          (format t "   ~A~%" ele)))

                        (t
                        (t

-                        (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 t
-                                         "~&Your command, ~S, is ambiguous:~%"
-                                         exp)
-                                 (dolist (ele cmd-fun)
-                                   (format t "   ~A~%" ele)))
-                                (t
-                                 (funcall cmd-fun)))))))))))))))
+                        (funcall cmd-fun))))))))))))

 
 ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
 (defun debug-eval-print (expr)
 
 ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
 (defun debug-eval-print (expr)

@@ -1224,9 +1380,8 @@ reset to ~S."
 ;;;  (throw 'sb!impl::toplevel-catcher nil))
 
 ;;; CMU CL supported this GO debug command, but SBCL doesn't -- in
 ;;;  (throw 'sb!impl::toplevel-catcher nil))
 
 ;;; CMU CL supported this GO debug command, but SBCL doesn't -- in

-;;; SBCL you just type the CONTINUE restart name instead (or "RESTART
-;;; CONTINUE", that's OK too).
-
+;;; SBCL you just type the CONTINUE restart name instead (or "C" or
+;;; "RESTART CONTINUE", that's OK too).

 ;;;(!def-debug-command "GO" ()
 ;;;  (continue *debug-condition*)
 ;;;  (error "There is no restart named CONTINUE."))
 ;;;(!def-debug-command "GO" ()
 ;;;  (continue *debug-condition*)
 ;;;  (error "There is no restart named CONTINUE."))

@@ -1656,6 +1811,24 @@ reset to ~S."
 
 (!def-debug-command "SLURP" ()
   (loop while (read-char-no-hang *standard-input*)))
 
 (!def-debug-command "SLURP" ()
   (loop while (read-char-no-hang *standard-input*)))

+
+(!def-debug-command "RETURN" (&optional
+                             (return (read-prompting-maybe
+                                      "return: ")))
+  (let ((tag (find-if (lambda (x)
+                       (and (typep (car x) 'symbol)
+                            (not (symbol-package (car x)))
+                            (string= (car x) "SB-DEBUG-CATCH-TAG")))
+                     (sb!di::frame-catches *current-frame*))))
+    (if tag
+       (throw (car tag)
+         (funcall (sb!di:preprocess-for-eval
+                   return
+                   (sb!di:frame-code-location *current-frame*))
+                  *current-frame*))
+       (format t "~@<can't find a tag for this frame ~
+                   ~2I~_(hint: try increasing the DEBUG optimization quality ~
+                   and recompiling)~:@>"))))

 \f
 ;;;; debug loop command utilities
 
 \f
 ;;;; debug loop command utilities