0.6.11.10:

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

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 5105bb4..1ebba15 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -10,9 +10,6 @@
 ;;;; files for more information.
 
 (in-package "SB!DEBUG")
 ;;;; files for more information.
 
 (in-package "SB!DEBUG")

-
-(file-comment
-  "$Header$")

 \f
 ;;;; variables and constants
 
 \f
 ;;;; variables and constants
 

@@ -25,10 +22,10 @@
   "*PRINT-LENGTH* for the debugger")
 
 (defvar *debug-readtable*
   "*PRINT-LENGTH* for the debugger")
 
 (defvar *debug-readtable*

-  ;; KLUDGE: This can't be initialized in a cold toplevel form, because the
-  ;; *STANDARD-READTABLE* isn't initialized until after cold toplevel forms
-  ;; have run. So instead we initialize it immediately after
-  ;; *STANDARD-READTABLE*. -- WHN 20000205
+  ;; KLUDGE: This can't be initialized in a cold toplevel form,
+  ;; because the *STANDARD-READTABLE* isn't initialized until after
+  ;; cold toplevel forms have run. So instead we initialize it
+  ;; immediately after *STANDARD-READTABLE*. -- WHN 20000205

   nil
   #!+sb-doc
   "*READTABLE* for the debugger")
   nil
   #!+sb-doc
   "*READTABLE* for the debugger")

@@ -37,9 +34,8 @@
   #!+sb-doc
   "This is T while in the debugger.")
 
   #!+sb-doc
   "This is T while in the debugger.")
 

-(defvar *debug-command-level* 0
-  #!+sb-doc
-  "Pushes and pops/exits inside the debugger change this.")
+;;; nestedness inside debugger command loops
+(defvar *debug-command-level* 0)

 
 (defvar *stack-top-hint* nil
   #!+sb-doc
 
 (defvar *stack-top-hint* nil
   #!+sb-doc

@@ -50,44 +46,43 @@
 
 (defvar *current-frame* nil)
 
 
 (defvar *current-frame* nil)
 

-;;; the default for *DEBUG-PROMPT*
-(defun debug-prompt ()
-  (let ((*standard-output* *debug-io*))
-    (terpri)
-    (prin1 (sb!di:frame-number *current-frame*))
-    (dotimes (i *debug-command-level*) (princ "]"))
-    (princ " ")
-    (force-output)))
-
-(defparameter *debug-prompt* #'debug-prompt
-  #!+sb-doc
-  "a function of no arguments that prints the debugger prompt on *DEBUG-IO*")
-
+(defun debug-prompt (stream)
+
+  ;; old behavior, will probably go away in sbcl-0.7.x
+  (format stream "~%~D" (sb!di:frame-number *current-frame*))
+  (dotimes (i *debug-command-level*)
+    (write-char #\] stream))
+  (write-char #\space stream)
+
+  ;; planned new behavior, delayed since it will break ILISP
+  #+nil 
+  (format stream
+         "~%~D~:[~;[~D~]] "
+         (sb!di:frame-number *current-frame*)
+         (> *debug-command-level* 1)
+         *debug-command-level*))
+  

 (defparameter *debug-help-string*
 "The prompt is right square brackets, the number indicating how many
   recursive command loops you are in. 
 Any command may be uniquely abbreviated.
 (defparameter *debug-help-string*
 "The prompt is right square brackets, the number indicating how many
   recursive command loops you are in. 
 Any command may be uniquely abbreviated.

-The debugger rebinds various special variables for controlling i/o,
-  sometimes to defaults (a la WITH-STANDARD-IO-SYNTAX) and sometimes to 
-  its own values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*.
+The debugger rebinds various special variables for controlling i/o, sometimes
+  to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to 
+  its own special values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*.

 Debug commands do not affect * and friends, but evaluation in the debug loop
 Debug commands do not affect * and friends, but evaluation in the debug loop

-  do affect these variables.
+  does affect these variables.

 SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
   drop you into deeper into the debugger.
 
 Getting in and out of the debugger:
 SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
   drop you into deeper into the debugger.
 
 Getting in and out of the debugger:

-  Q        throws to top level.
-  GO       calls CONTINUE which tries to proceed with the restart 'CONTINUE.

   RESTART  invokes restart numbered as shown (prompt if not given).
   ERROR    prints the error condition and restart cases.
   RESTART  invokes restart numbered as shown (prompt if not given).
   ERROR    prints the error condition and restart cases.

-

   The name of any restart, or its number, is a valid command, and is the same
     as using RESTART to invoke that restart.
 
 Changing frames:
   The name of any restart, or its number, is a valid command, and is the same
     as using RESTART to invoke that restart.
 
 Changing frames:

-  U     up frame     D  down frame
-  T     top frame    B  bottom frame
-  F n   frame n
+  U      up frame     D    down frame
+  B  bottom frame     F n  frame n (n=0 for top frame)

 
 Inspecting frames:
   BACKTRACE [n]  shows n frames going down the stack.
 
 Inspecting frames:
   BACKTRACE [n]  shows n frames going down the stack.

@@ -96,8 +91,8 @@ Inspecting frames:
   SOURCE [n]     displays frame's source form with n levels of enclosing forms.
 
 Breakpoints and steps:
   SOURCE [n]     displays frame's source form with n levels of enclosing forms.
 
 Breakpoints and steps:

-  LIST-LOCATIONS [{function | :c}]   List the locations for breakpoints.
-                                     Specify :c for the current frame.
+  LIST-LOCATIONS [{function | :C}]   List the locations for breakpoints.
+                                     Specify :C for the current frame.

     Abbreviation: LL
   LIST-BREAKPOINTS                   List the active breakpoints.
     Abbreviations: LB, LBP
     Abbreviation: LL
   LIST-BREAKPOINTS                   List the active breakpoints.
     Abbreviations: LB, LBP

@@ -131,8 +126,8 @@ Function and macro commands:
   #!+sb-doc
   "When true, list the code location type in the LIST-LOCATIONS command.")
 
   #!+sb-doc
   "When true, list the code location type in the LIST-LOCATIONS command.")
 

-;;; a list of the types of code-locations that should not be stepped to and
-;;; should not be listed when listing breakpoints
+;;; a list of the types of code-locations that should not be stepped
+;;; to and should not be listed when listing breakpoints

 (defvar *bad-code-location-types* '(:call-site :internal-error))
 (declaim (type list *bad-code-location-types*))
 
 (defvar *bad-code-location-types* '(:call-site :internal-error))
 (declaim (type list *bad-code-location-types*))
 

@@ -140,12 +135,12 @@ Function and macro commands:
 (defvar *possible-breakpoints*)
 (declaim (type list *possible-breakpoints*))
 
 (defvar *possible-breakpoints*)
 (declaim (type list *possible-breakpoints*))
 

-;;; a list of the made and active breakpoints, each is a breakpoint-info
-;;; structure
+;;; a list of the made and active breakpoints, each is a
+;;; BREAKPOINT-INFO structure

 (defvar *breakpoints* nil)
 (declaim (type list *breakpoints*))
 
 (defvar *breakpoints* nil)
 (declaim (type list *breakpoints*))
 

-;;; a list of breakpoint-info structures of the made and active step
+;;; a list of BREAKPOINT-INFO structures of the made and active step

 ;;; breakpoints
 (defvar *step-breakpoints* nil)
 (declaim (type list *step-breakpoints*))
 ;;; breakpoints
 (defvar *step-breakpoints* nil)
 (declaim (type list *step-breakpoints*))

@@ -170,8 +165,8 @@ Function and macro commands:
        (setf found t)))
     first-code-location))
 
        (setf found t)))
     first-code-location))
 

-;;; Return a list of the next code-locations following the one passed. One of
-;;; the *BAD-CODE-LOCATION-TYPES* will not be returned.
+;;; Return a list of the next code-locations following the one passed.
+;;; One of the *BAD-CODE-LOCATION-TYPES* will not be returned.

 (defun next-code-locations (code-location)
   (let ((debug-block (sb!di:code-location-debug-block code-location))
        (block-code-locations nil))
 (defun next-code-locations (code-location)
   (let ((debug-block (sb!di:code-location-debug-block code-location))
        (block-code-locations nil))

@@ -206,11 +201,11 @@ Function and macro commands:
                (push code-location possible-breakpoints))))))
     (nreverse possible-breakpoints)))
 
                (push code-location possible-breakpoints))))))
     (nreverse possible-breakpoints)))
 

-;;; Searches the info-list for the item passed (code-location, debug-function,
-;;; or breakpoint-info). If the item passed is a debug function then kind will
-;;; be compared if it was specified. The kind if also compared if a
-;;; breakpoint-info is passed since it's in the breakpoint. The info structure
-;;; is returned if found.
+;;; Searches the info-list for the item passed (code-location,
+;;; debug-function, or breakpoint-info). If the item passed is a debug
+;;; function then kind will be compared if it was specified. The kind
+;;; if also compared if a breakpoint-info is passed since it's in the
+;;; breakpoint. The info structure is returned if found.

 (defun location-in-list (place info-list &optional (kind nil))
   (when (breakpoint-info-p place)
     (setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place)))
 (defun location-in-list (place info-list &optional (kind nil))
   (when (breakpoint-info-p place)
     (setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place)))

@@ -232,8 +227,9 @@ Function and macro commands:
                                    (eq kind (sb!di:breakpoint-kind
                                              y-breakpoint))))))))))
 
                                    (eq kind (sb!di:breakpoint-kind
                                              y-breakpoint))))))))))
 

-;;; If Loc is an unknown location, then try to find the block start location.
-;;; Used by source printing to some information instead of none for the user.
+;;; If LOC is an unknown location, then try to find the block start
+;;; location. Used by source printing to some information instead of
+;;; none for the user.

 (defun maybe-block-start-location (loc)
   (if (sb!di:code-location-unknown-p loc)
       (let* ((block (sb!di:code-location-debug-block loc))
 (defun maybe-block-start-location (loc)
   (if (sb!di:code-location-unknown-p loc)
       (let* ((block (sb!di:code-location-debug-block loc))

@@ -251,7 +247,7 @@ Function and macro commands:
 ;;;; the BREAKPOINT-INFO structure
 
 ;;; info about a made breakpoint
 ;;;; the BREAKPOINT-INFO structure
 
 ;;; info about a made breakpoint

-(defstruct breakpoint-info
+(defstruct (breakpoint-info (:copier nil))

   ;; where we are going to stop
   (place (required-argument)
         :type (or sb!di:code-location sb!di:debug-function))
   ;; where we are going to stop
   (place (required-argument)
         :type (or sb!di:code-location sb!di:debug-function))

@@ -263,12 +259,12 @@ Function and macro commands:
   ;; the function returned from sb!di:preprocess-for-eval. If result is
   ;; non-NIL, eval (each) print and print results.
   (condition #'identity :type function)
   ;; the function returned from sb!di:preprocess-for-eval. If result is
   ;; non-NIL, eval (each) print and print results.
   (condition #'identity :type function)

-  ;; the list of functions from sb!di:preprocess-for-eval to evaluate. Results
-  ;; are conditionally printed. Car of each element is the function, cdr is the
-  ;; form it goes with.
+  ;; the list of functions from sb!di:preprocess-for-eval to evaluate.
+  ;; Results are conditionally printed. Car of each element is the
+  ;; function, cdr is the form it goes with.

   (print nil :type list)
   (print nil :type list)

-  ;; the number used when listing the possible breakpoints within a function.
-  ;; Could also be a symbol such as start or end.
+  ;; the number used when listing the possible breakpoints within a
+  ;; function. Could also be a symbol such as start or end.

   (code-location-number (required-argument) :type (or symbol integer))
   ;; the number used when listing the breakpoints active and to delete
   ;; breakpoints
   (code-location-number (required-argument) :type (or symbol integer))
   ;; the number used when listing the breakpoints active and to delete
   ;; breakpoints

@@ -315,8 +311,8 @@ Function and macro commands:
 \f
 ;;;; MAIN-HOOK-FUNCTION for steps and breakpoints
 
 \f
 ;;;; MAIN-HOOK-FUNCTION for steps and breakpoints
 

-;;; This must be passed as the hook function. It keeps track of where step
-;;; breakpoints are.
+;;; This must be passed as the hook function. It keeps track of where
+;;; STEP breakpoints are.

 (defun main-hook-function (current-frame breakpoint &optional return-vals
                                         function-end-cookie)
   (setf *default-breakpoint-debug-function*
 (defun main-hook-function (current-frame breakpoint &optional return-vals
                                         function-end-cookie)
   (setf *default-breakpoint-debug-function*

@@ -451,8 +447,8 @@ Function and macro commands:
 
 (eval-when (:compile-toplevel :execute)
 
 
 (eval-when (:compile-toplevel :execute)
 

-;;; This is a convenient way to express what to do for each type of lambda-list
-;;; element.
+;;; This is a convenient way to express what to do for each type of
+;;; lambda-list element.

 (sb!xc:defmacro lambda-list-element-dispatch (element
                                              &key
                                              required
 (sb!xc:defmacro lambda-list-element-dispatch (element
                                              &key
                                              required

@@ -490,13 +486,14 @@ Function and macro commands:
            (:print-object (lambda (x s)
                             (print-unreadable-object (x s :type t)
                               (write-string (unprintable-object-string x)
            (:print-object (lambda (x s)
                             (print-unreadable-object (x s :type t)
                               (write-string (unprintable-object-string x)

-                                            s)))))
+                                            s))))
+           (:copier nil))

   string)
 
   string)
 

-;;; Print frame with verbosity level 1. If we hit a rest-arg, then
+;;; 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
 ;;; 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.
+;;; &REST arg's list of values.

 (defun print-frame-call-1 (frame)
   (let* ((d-fun (sb!di:frame-debug-function frame))
         (loc (sb!di:frame-code-location frame))
 (defun print-frame-call-1 (frame)
   (let* ((d-fun (sb!di:frame-debug-function frame))
         (loc (sb!di:frame-code-location frame))

@@ -517,12 +514,15 @@ Function and macro commands:
                                               (second ele) frame))
                                     results))
                       (return))
                                               (second ele) frame))
                                     results))
                       (return))

-                    (push (make-unprintable-object "unavailable &REST arg")
+                    (push (make-unprintable-object
+                           "unavailable &REST argument")

                           results)))))
       (sb!di:lambda-list-unavailable
        ()
        (push (make-unprintable-object "lambda list unavailable") results)))
                           results)))))
       (sb!di:lambda-list-unavailable
        ()
        (push (make-unprintable-object "lambda list unavailable") results)))

-    (prin1 (mapcar #'ensure-printable-object (nreverse results)))
+    (pprint-logical-block (*standard-output* nil)
+      (let ((x (nreverse (mapcar #'ensure-printable-object results))))
+       (format t "(~@<~S~{ ~_~S~}~:>)" (first x) (rest x))))

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

@@ -539,12 +539,12 @@ Function and macro commands:
 
 (defun frame-call-arg (var location frame)
   (lambda-var-dispatch var location
 
 (defun frame-call-arg (var location frame)
   (lambda-var-dispatch var location

-    (make-unprintable-object "unused arg")
+    (make-unprintable-object "unused argument")

     (sb!di:debug-var-value var frame)
     (sb!di:debug-var-value var frame)

-    (make-unprintable-object "unavailable arg")))
+    (make-unprintable-object "unavailable argument")))

 
 

-;;; Prints a representation of the function call causing frame to
-;;; exist. Verbosity indicates the level of information to output;
+;;; Prints a representation of the function call causing FRAME to
+;;; exist. VERBOSITY indicates the level of information to output;

 ;;; zero indicates just printing the debug-function's name, and one
 ;;; indicates displaying call-like, one-liner format with argument
 ;;; values.
 ;;; zero indicates just printing the debug-function's name, and one
 ;;; indicates displaying call-like, one-liner format with argument
 ;;; values.

@@ -582,37 +582,55 @@ Function and macro commands:
 (defvar *debug-restarts*)
 (defvar *debug-condition*)
 
 (defvar *debug-restarts*)
 (defvar *debug-condition*)
 

+;;; Print *DEBUG-CONDITION*, taking care to avoid recursive invocation
+;;; of the debugger in case of a problem (e.g. a bug in the PRINT-OBJECT
+;;; method for *DEBUG-CONDITION*).
+(defun princ-debug-condition-carefully (stream)
+  (handler-case (princ *debug-condition* stream)
+    (error (condition)
+          (format stream
+                  "  (caught ~S when trying to print ~S)"
+                  (type-of condition)
+                  '*debug-condition*)))
+  *debug-condition*)
+

 (defun invoke-debugger (condition)
   #!+sb-doc
   "Enter the debugger."
   (let ((old-hook *debugger-hook*))
     (when old-hook
       (let ((*debugger-hook* nil))
 (defun invoke-debugger (condition)
   #!+sb-doc
   "Enter the debugger."
   (let ((old-hook *debugger-hook*))
     (when old-hook
       (let ((*debugger-hook* nil))

-       (funcall hook condition hook))))
+       (funcall old-hook condition old-hook))))

   (sb!unix:unix-sigsetmask 0)
   (sb!unix:unix-sigsetmask 0)

-  (let ((original-package *package*)) ; protect it from WITH-STANDARD-IO-SYNTAX
+
+  ;; 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*))
+  (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))
     (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*.
+           ;; 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*.

            ;;   2. It isn't customizable.
            ;;   2. It isn't customizable.

-           ;;   3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY* to the
-           ;;      same value as the toplevel default.
+           ;;   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.
            ;;   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.
+           ;; 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*)
            (sb!kernel:*current-level* 0)
            (*print-length* *debug-print-length*)
            (*print-level* *debug-print-level*)

@@ -620,19 +638,59 @@ Function and macro commands:
            (*print-readably* nil)
            (*print-pretty* t)
            (*package* original-package))
            (*print-readably* nil)
            (*print-pretty* t)
            (*package* original-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, 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.

        (format *error-output*
        (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..
+              "~2&debugger invoked on condition of type ~S:~%  "
+              (type-of *debug-condition*))
+       (princ-debug-condition-carefully *error-output*)
+       (terpri *error-output*)
+
+       ;; 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: The first two bindings here seem 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*, or using
+            ;; PEEK-CHAR or some such thing on the program's ordinary
+            ;; (possibly also redirected) *STANDARD-INPUT*.
+            (*standard-input* *debug-io*)
+            (*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)
             (*error-output* *debug-io*))
         (unless (typep condition 'step-condition)

-          (show-restarts *debug-restarts* *error-output*))
+          (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.~:@>~2%"
+                  '*debug-condition*)
+          (show-restarts *debug-restarts* *debug-io*)
+          (terpri *debug-io*))

         (internal-debug))))))
 
         (internal-debug))))))
 

-(defun show-restarts (restarts &optional (s *error-output*))
+(defun show-restarts (restarts s)

   (when restarts
     (format s "~&restarts:~%")
     (let ((count 0)
   (when restarts
     (format s "~&restarts:~%")
     (let ((count 0)

@@ -656,18 +714,17 @@ Function and macro commands:
                 (push name names-used))))
        (incf count)))))
 
                 (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.
+;;; 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.

 (defun internal-debug ()
   (let ((*in-the-debugger* t)
        (*read-suppress* nil))
     (unless (typep *debug-condition* 'step-condition)
 (defun internal-debug ()
   (let ((*in-the-debugger* t)
        (*read-suppress* nil))
     (unless (typep *debug-condition* 'step-condition)

-      (clear-input *debug-io*)
-      (format *debug-io*
-             "~&Within the debugger, you can type HELP for help.~%"))
+      (clear-input *debug-io*))

     #!-mp (debug-loop)
     #!+mp (sb!mp:without-scheduling (debug-loop))))
 \f
     #!-mp (debug-loop)
     #!+mp (sb!mp:without-scheduling (debug-loop))))
 \f

@@ -708,8 +765,11 @@ Function and macro commands:
            ;; WITH-SIMPLE-RESTART.
            (let ((level *debug-command-level*)
                  (restart-commands (make-restart-commands)))
            ;; WITH-SIMPLE-RESTART.
            (let ((level *debug-command-level*)
                  (restart-commands (make-restart-commands)))

-             (with-simple-restart (abort "Return to debug level ~D." level)
-               (funcall *debug-prompt*)
+             (with-simple-restart (abort
+                                  "Reduce debugger level (to debug level ~D)."
+                                   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
                (let ((input (sb!int:get-stream-command *debug-io*)))
                  (cond (input
                         (let ((cmd-fun (debug-command-p

@@ -738,20 +798,34 @@ Function and macro commands:
                                 (t
                                  (funcall cmd-fun)))))))))))))))
 
                                 (t
                                  (funcall cmd-fun)))))))))))))))
 

-(defvar *auto-eval-in-frame* t
+;;; FIXME: As far as I know, the CMU CL X86 codebase has never
+;;; supported access to the environment of the debugged function. It
+;;; would be really, really nice to make that work! (Until then,
+;;; non-NIL *AUTO-EVAL-IN-FRAME* seems to be useless, and as of
+;;; sbcl-0.6.10 it even seemed to be actively harmful, since the
+;;; debugger gets confused when trying to unwind the frames which
+;;; arise in SIGINT interrupts. So it's set to NIL.)
+(defvar *auto-eval-in-frame* nil

   #!+sb-doc
   #!+sb-doc

-  "When set (the default), evaluations in the debugger's command loop occur
-   relative to the current frame's environment without the need of debugger
-   forms that explicitly control this kind of evaluation.")
+  "When set, evaluations in the debugger's command loop occur relative
+   to the current frame's environment without the need of debugger
+   forms that explicitly control this kind of evaluation. In an ideal
+   world, the default would be T, but since unfortunately the X86
+   debugger support isn't good enough to make this useful, the
+   default is NIL instead.")

 
 ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
 
 ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.

-(defun debug-eval-print (exp)
-  (setq +++ ++ ++ + + - - exp)
+(defun debug-eval-print (expr)
+  (/noshow "entering DEBUG-EVAL-PRINT" expr)
+  (/noshow (fboundp 'compile))
+  (/noshow (and (fboundp 'compile) *auto-eval-in-frame*))
+  (setq +++ ++ ++ + + - - expr)

   (let* ((values (multiple-value-list
                  (if (and (fboundp 'compile) *auto-eval-in-frame*)
                      (sb!di:eval-in-frame *current-frame* -)
                      (eval -))))
         (*standard-output* *debug-io*))
   (let* ((values (multiple-value-list
                  (if (and (fboundp 'compile) *auto-eval-in-frame*)
                      (sb!di:eval-in-frame *current-frame* -)
                      (eval -))))
         (*standard-output* *debug-io*))

+    (/noshow "done with EVAL in DEBUG-EVAL-PRINT")

     (fresh-line)
     (if values (prin1 (car values)))
     (dolist (x (cdr values))
     (fresh-line)
     (if values (prin1 (car values)))
     (dolist (x (cdr values))

@@ -763,15 +837,13 @@ Function and macro commands:
     (unless (boundp '*)
       (setq * nil)
       (fresh-line)
     (unless (boundp '*)
       (setq * nil)
       (fresh-line)

-      ;; FIXME: Perhaps this shouldn't be WARN (for fear of complicating
-      ;; the debugging situation?) but at least it should go to *ERROR-OUTPUT*.
-      ;; (And probably it should just be WARN.)
+      ;; FIXME: The way INTERACTIVE-EVAL does this seems better.

       (princ "Setting * to NIL (was unbound marker)."))))
 \f
 ;;;; debug loop functions
 
       (princ "Setting * to NIL (was unbound marker)."))))
 \f
 ;;;; debug loop functions
 

-;;; These commands are functions, not really commands, so that users can get
-;;; their hands on the values returned.
+;;; These commands are functions, not really commands, so that users
+;;; can get their hands on the values returned.

 
 (eval-when (:execute :compile-toplevel)
 
 
 (eval-when (:execute :compile-toplevel)
 

@@ -800,8 +872,8 @@ Function and macro commands:
                `(setf (sb!di:debug-var-value (car vars) *current-frame*)
                       ,value-var))))
           (t
                `(setf (sb!di:debug-var-value (car vars) *current-frame*)
                       ,value-var))))
           (t

-           ;; Since we have more than one, first see whether we have any
-           ;; variables that exactly match the specification.
+           ;; Since we have more than one, first see whether we have
+           ;; any variables that exactly match the specification.

            (let* ((name (etypecase name
                           (symbol (symbol-name name))
                           (simple-string name)))
            (let* ((name (etypecase name
                           (symbol (symbol-name name))
                           (simple-string name)))

@@ -823,8 +895,9 @@ Function and macro commands:
                   (:set
                    `(setf (sb!di:debug-var-value (car vars) *current-frame*)
                           ,value-var))))
                   (:set
                    `(setf (sb!di:debug-var-value (car vars) *current-frame*)
                           ,value-var))))

-              ;; If there weren't any exact matches, flame about ambiguity
-              ;; unless all the variables have the same name.
+              ;; If there weren't any exact matches, flame about
+              ;; ambiguity unless all the variables have the same
+              ;; name.

               ((and (not exact)
                     (find-if-not
                      #'(lambda (v)
               ((and (not exact)
                     (find-if-not
                      #'(lambda (v)

@@ -836,8 +909,8 @@ Function and macro commands:
                               (delete-duplicates
                                vars :test #'string=
                                :key #'sb!di:debug-var-symbol-name))))
                               (delete-duplicates
                                vars :test #'string=
                                :key #'sb!di:debug-var-symbol-name))))

-              ;; All names are the same, so see whether the user ID'ed one of
-              ;; them.
+              ;; All names are the same, so see whether the user
+              ;; ID'ed one of them.

               (id-supplied
                (let ((v (find id vars :key #'sb!di:debug-var-id)))
                  (unless v
               (id-supplied
                (let ((v (find id vars :key #'sb!di:debug-var-id)))
                  (unless v

@@ -858,9 +931,11 @@ Function and macro commands:
 
 ) ; EVAL-WHEN
 
 
 ) ; EVAL-WHEN
 

+;;; FIXME: This doesn't work. It would be real nice we could make it
+;;; work! Alas, it doesn't seem to work in CMU CL X86 either..

 (defun var (name &optional (id 0 id-supplied))
   #!+sb-doc
 (defun var (name &optional (id 0 id-supplied))
   #!+sb-doc

-  "Returns a variable's value if possible. Name is a simple-string or symbol.
+  "Return a variable's value if possible. NAME is a simple-string or symbol.

    If it is a simple-string, it is an initial substring of the variable's name.
    If name is a symbol, it has the same name and package as the variable whose
    value this function returns. If the symbol is uninterned, then the variable
    If it is a simple-string, it is an initial substring of the variable's name.
    If name is a symbol, it has the same name and package as the variable whose
    value this function returns. If the symbol is uninterned, then the variable

@@ -879,11 +954,11 @@ Function and macro commands:
 (defun (setf var) (value name &optional (id 0 id-supplied))
   (define-var-operation :set value))
 
 (defun (setf var) (value name &optional (id 0 id-supplied))
   (define-var-operation :set value))
 

-;;; This returns the COUNT'th arg as the user sees it from args, the result of
-;;; SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a potential
-;;; DEBUG-VAR from the lambda-list, then the second value is T. If this
-;;; returns a keyword symbol or a value from a rest arg, then the second value
-;;; is NIL.
+;;; This returns the COUNT'th arg as the user sees it from args, the
+;;; result of SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a
+;;; potential DEBUG-VAR from the lambda-list, then the second value is
+;;; T. If this returns a keyword symbol or a value from a rest arg,
+;;; then the second value is NIL.

 (declaim (ftype (function (index list)) nth-arg))
 (defun nth-arg (count args)
   (let ((n count))
 (declaim (ftype (function (index list)) nth-arg))
 (defun nth-arg (count args)
   (let ((n count))

@@ -900,7 +975,8 @@ Function and macro commands:
        :rest ((let ((var (second ele)))
                 (lambda-var-dispatch var (sb!di:frame-code-location
                                           *current-frame*)
        :rest ((let ((var (second ele)))
                 (lambda-var-dispatch var (sb!di:frame-code-location
                                           *current-frame*)

-                  (error "unused REST-arg before n'th argument")
+                  (error "unused &REST argument before n'th
+argument")

                   (dolist (value
                            (sb!di:debug-var-value var *current-frame*)
                            (error
                   (dolist (value
                            (sb!di:debug-var-value var *current-frame*)
                            (error

@@ -909,7 +985,7 @@ Function and macro commands:
                     (if (zerop n)
                         (return-from nth-arg (values value nil))
                         (decf n)))
                     (if (zerop n)
                         (return-from nth-arg (values value nil))
                         (decf n)))

-                  (error "invalid REST-arg before n'th argument")))))
+                  (error "invalid &REST argument before n'th argument")))))

       (decf n))))
 
 (defun arg (n)
       (decf n))))
 
 (defun arg (n)

@@ -955,12 +1031,13 @@ Function and macro commands:
     (push (cons new-name (cdr pair)) *debug-commands*))
   new-name)
 
     (push (cons new-name (cdr pair)) *debug-commands*))
   new-name)
 

-;;; This takes a symbol and uses its name to find a debugger command, using
-;;; initial substring matching. It returns the command function if form
-;;; identifies only one command, but if form is ambiguous, this returns a list
-;;; of the command names. If there are no matches, this returns nil. Whenever
-;;; the loop that looks for a set of possibilities encounters an exact name
-;;; match, we return that command function immediately.
+;;; This takes a symbol and uses its name to find a debugger command,
+;;; using initial substring matching. It returns the command function
+;;; if form identifies only one command, but if form is ambiguous,
+;;; this returns a list of the command names. If there are no matches,
+;;; this returns nil. Whenever the loop that looks for a set of
+;;; possibilities encounters an exact name match, we return that
+;;; command function immediately.

 (defun debug-command-p (form &optional other-commands)
   (if (or (symbolp form) (integerp form))
       (let* ((name
 (defun debug-command-p (form &optional other-commands)
   (if (or (symbolp form) (integerp form))
       (let* ((name

@@ -997,25 +1074,25 @@ Function and macro commands:
                   ((not cmds) res)
                 (setf (car cmds) (caar cmds))))))))
 
                   ((not cmds) res)
                 (setf (car cmds) (caar cmds))))))))
 

-;;; Returns a list of debug commands (in the same format as *debug-commands*)
-;;; that invoke each active restart.
+;;; Return a list of debug commands (in the same format as
+;;; *debug-commands*) that invoke each active restart.

 ;;;
 ;;;

-;;; Two commands are made for each restart: one for the number, and one for
-;;; the restart name (unless it's been shadowed by an earlier restart of the
-;;; same name).
+;;; Two commands are made for each restart: one for the number, and
+;;; one for the restart name (unless it's been shadowed by an earlier
+;;; restart of the same name, or it is NIL).

 (defun make-restart-commands (&optional (restarts *debug-restarts*))
   (let ((commands)
        (num 0))                        ; better be the same as show-restarts!
     (dolist (restart restarts)
       (let ((name (string (restart-name restart))))
 (defun make-restart-commands (&optional (restarts *debug-restarts*))
   (let ((commands)
        (num 0))                        ; better be the same as show-restarts!
     (dolist (restart restarts)
       (let ((name (string (restart-name restart))))

-       (unless (find name commands :key #'car :test #'string=)
-         (let ((restart-fun
-                #'(lambda ()
-                    (invoke-restart-interactively restart))))
-           (push (cons name restart-fun) commands)
-           (push (cons (format nil "~D" num) restart-fun) commands))))
-      (incf num))
-    commands))
+        (let ((restart-fun
+                #'(lambda () (invoke-restart-interactively restart))))
+          (push (cons (format nil "~d" num) restart-fun) commands)
+          (unless (or (null (restart-name restart)) 
+                      (find name commands :key #'car :test #'string=))
+            (push (cons name restart-fun) commands))))
+    (incf num))
+  commands))

 \f
 ;;;; frame-changing commands
 
 \f
 ;;;; frame-changing commands
 

@@ -1037,12 +1114,15 @@ Function and macro commands:
 
 (def-debug-command-alias "D" "DOWN")
 
 
 (def-debug-command-alias "D" "DOWN")
 

-(def-debug-command "TOP" ()
-  (do ((prev *current-frame* lead)
-       (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead)))
-      ((null lead)
-       (setf *current-frame* prev)
-       (print-frame-call prev))))
+;;; CMU CL had this command, but SBCL doesn't, since it's redundant
+;;; with "FRAME 0", and it interferes with abbreviations for the
+;;; TOPLEVEL restart.
+;;;(def-debug-command "TOP" ()
+;;;  (do ((prev *current-frame* lead)
+;;;       (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead)))
+;;;      ((null lead)
+;;;       (setf *current-frame* prev)
+;;;       (print-frame-call prev))))

 
 (def-debug-command "BOTTOM" ()
   (do ((prev *current-frame* lead)
 
 (def-debug-command "BOTTOM" ()
   (do ((prev *current-frame* lead)

@@ -1077,17 +1157,25 @@ Function and macro commands:
 \f
 ;;;; commands for entering and leaving the debugger
 
 \f
 ;;;; commands for entering and leaving the debugger
 

-(def-debug-command "QUIT" ()
-  (throw 'sb!impl::top-level-catcher nil))
+;;; CMU CL supported this QUIT debug command, but SBCL provides this
+;;; functionality with a restart instead. (The QUIT debug command was
+;;; removed because it's confusing to have "quit" mean two different
+;;; things in the system, "restart the top level REPL" in the debugger
+;;; and "terminate the Lisp system" as the SB-EXT:QUIT function.)
+;;;
+;;;(def-debug-command "QUIT" ()
+;;;  (throw 'sb!impl::top-level-catcher nil))

 
 

-(def-debug-command "GO" ()
-  (continue *debug-condition*)
-  (error "There is no restart named CONTINUE."))
+;;; CMU CL supported this GO debug command, but SBCL doesn't -- just
+;;; type the CONTINUE restart name.
+;;;(def-debug-command "GO" ()
+;;;  (continue *debug-condition*)
+;;;  (error "There is no restart named CONTINUE."))

 
 (def-debug-command "RESTART" ()
   (let ((num (read-if-available :prompt)))
     (when (eq num :prompt)
 
 (def-debug-command "RESTART" ()
   (let ((num (read-if-available :prompt)))
     (when (eq num :prompt)

-      (show-restarts *debug-restarts*)
+      (show-restarts *debug-restarts* *debug-io*)

       (write-string "restart: ")
       (force-output)
       (setf num (read *standard-input*)))
       (write-string "restart: ")
       (force-output)
       (setf num (read *standard-input*)))

@@ -1126,8 +1214,8 @@ Function and macro commands:
 (def-debug-command-alias "?" "HELP")
 
 (def-debug-command "ERROR" ()
 (def-debug-command-alias "?" "HELP")
 
 (def-debug-command "ERROR" ()

-  (format t "~A~%" *debug-condition*)
-  (show-restarts *debug-restarts*))
+  (format *debug-io* "~A~%" *debug-condition*)
+  (show-restarts *debug-restarts* *debug-io*))

 
 (def-debug-command "BACKTRACE" ()
   (backtrace (read-if-available most-positive-fixnum)))
 
 (def-debug-command "BACKTRACE" ()
   (backtrace (read-if-available most-positive-fixnum)))

@@ -1177,8 +1265,9 @@ Function and macro commands:
 \f
 ;;;; source location printing
 
 \f
 ;;;; source location printing
 

-;;; We cache a stream to the last valid file debug source so that we won't have
-;;; to repeatedly open the file.
+;;; We cache a stream to the last valid file debug source so that we
+;;; won't have to repeatedly open the file.
+;;;

 ;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
 ;;; in the 1990s, so the benefit is negligible, less important than the
 ;;; potential of extra confusion if someone changes the source during
 ;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
 ;;; in the 1990s, so the benefit is negligible, less important than the
 ;;; potential of extra confusion if someone changes the source during

@@ -1201,16 +1290,17 @@ Function and macro commands:
                   *cached-readtable* nil))
         sb!int:*before-save-initializations*)
 
                   *cached-readtable* nil))
         sb!int:*before-save-initializations*)
 

-;;; We also cache the last top-level form that we printed a source for so that
-;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS.
+;;; We also cache the last top-level form that we printed a source for
+;;; so that we don't have to do repeated reads and calls to
+;;; FORM-NUMBER-TRANSLATIONS.

 (defvar *cached-top-level-form-offset* nil)
 (declaim (type (or index null) *cached-top-level-form-offset*))
 (defvar *cached-top-level-form*)
 (defvar *cached-form-number-translations*)
 
 (defvar *cached-top-level-form-offset* nil)
 (declaim (type (or index null) *cached-top-level-form-offset*))
 (defvar *cached-top-level-form*)
 (defvar *cached-form-number-translations*)
 

-;;; Given a code location, return the associated form-number translations and
-;;; the actual top-level form. We check our cache --- if there is a miss, we
-;;; dispatch on the kind of the debug source.
+;;; Given a code location, return the associated form-number
+;;; translations and the actual top-level form. We check our cache ---
+;;; if there is a miss, we dispatch on the kind of the debug source.

 (defun get-top-level-form (location)
   (let ((d-source (sb!di:code-location-debug-source location)))
     (if (and (eq d-source *cached-debug-source*)
 (defun get-top-level-form (location)
   (let ((d-source (sb!di:code-location-debug-source location)))
     (if (and (eq d-source *cached-debug-source*)

@@ -1227,9 +1317,9 @@ Function and macro commands:
                        (sb!di:form-number-translations res offset))
                  (setq *cached-top-level-form* res))))))
 
                        (sb!di:form-number-translations res offset))
                  (setq *cached-top-level-form* res))))))
 

-;;; Locates the source file (if it still exists) and grabs the top-level form.
-;;; If the file is modified, we use the top-level-form offset instead of the
-;;; recorded character offset.
+;;; Locate the source file (if it still exists) and grab the top-level
+;;; form. If the file is modified, we use the top-level-form offset
+;;; instead of the recorded character offset.

 (defun get-file-top-level-form (location)
   (let* ((d-source (sb!di:code-location-debug-source location))
         (tlf-offset (sb!di:code-location-top-level-form-offset location))
 (defun get-file-top-level-form (location)
   (let* ((d-source (sb!di:code-location-debug-source location))
         (tlf-offset (sb!di:code-location-top-level-form-offset location))

@@ -1298,9 +1388,10 @@ Function and macro commands:
   (continue *debug-condition*)
   (error "couldn't continue"))
 
   (continue *debug-condition*)
   (error "couldn't continue"))
 

-;;; List possible breakpoint locations, which ones are active, and where GO
-;;; will continue. Set *POSSIBLE-BREAKPOINTS* to the code-locations which can
-;;; then be used by sbreakpoint.
+;;; List possible breakpoint locations, which ones are active, and
+;;; where the CONTINUE restart will transfer control. Set
+;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be
+;;; used by sbreakpoint.

 (def-debug-command "LIST-LOCATIONS" ()
   (let ((df (read-if-available *default-breakpoint-debug-function*)))
     (cond ((consp df)
 (def-debug-command "LIST-LOCATIONS" ()
   (let ((df (read-if-available *default-breakpoint-debug-function*)))
     (cond ((consp df)

@@ -1502,7 +1593,7 @@ Function and macro commands:
     (if function
        (describe function)
        (format t "can't figure out the function for this frame"))))
     (if function
        (describe function)
        (format t "can't figure out the function for this frame"))))

-\f
+\f<

 ;;;; debug loop command utilities
 
 (defun read-prompting-maybe (prompt &optional (in *standard-input*)
 ;;;; debug loop command utilities
 
 (defun read-prompting-maybe (prompt &optional (in *standard-input*)