0.7.8.48:

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

diff --git a/src/code/debug.lisp b/src/code/debug.lisp
index 19f3896..87d5377 100644 (file)
--- a/src/code/debug.lisp
+++ b/src/code/debug.lisp
@@ -78,9 +78,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 +94,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

@@ -464,6 +464,20 @@ Other commands:
     (print-frame-call frame :number t))
   (fresh-line *standard-output*)
   (values))
     (print-frame-call frame :number t))
   (fresh-line *standard-output*)
   (values))

+
+(defun backtrace-as-list (&optional (count most-positive-fixnum))
+  #!+sb-doc "Return a list representing the current BACKTRACE."
+  (do ((reversed-result nil)
+       (frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
+             (sb!di:frame-down frame))
+       (count count (1- count)))
+      ((or (null frame) (zerop count))
+       (nreverse reversed-result))
+    (push (frame-call-as-list frame) reversed-result)))
+
+(defun frame-call-as-list (frame)
+  (cons (sb!di:debug-fun-name (sb!di:frame-debug-fun frame))
+       (frame-args-as-list frame)))

 \f
 ;;;; frame printing
 
 \f
 ;;;; frame printing
 

@@ -511,44 +525,49 @@ Other commands:
            (:copier nil))
   string)
 
            (:copier nil))
   string)
 

-;;; 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)
+;;; Extract the function argument values for a debug frame.
+(defun frame-args-as-list (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))
        (loc (sb!di:frame-code-location frame))

-       (reversed-args nil))
-
-    ;; Construct function arguments in REVERSED-ARGS.
+       (reversed-result nil))

     (handler-case
     (handler-case

-       (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
-         (lambda-list-element-dispatch ele
-           :required ((push (frame-call-arg ele loc frame) reversed-args))
-           :optional ((push (frame-call-arg (second ele) loc frame)
-                            reversed-args))
-           :keyword ((push (second ele) reversed-args)
-                     (push (frame-call-arg (third ele) loc frame)
-                           reversed-args))
-           :deleted ((push (frame-call-arg ele loc frame) reversed-args))
-           :rest ((lambda-var-dispatch (second ele) loc
+       (progn
+         (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
+           (lambda-list-element-dispatch ele
+            :required ((push (frame-call-arg ele loc frame) reversed-result))
+            :optional ((push (frame-call-arg (second ele) loc frame)
+                             reversed-result))
+            :keyword ((push (second ele) reversed-result)
+                      (push (frame-call-arg (third ele) loc frame)
+                            reversed-result))
+            :deleted ((push (frame-call-arg ele loc frame) reversed-result))
+            :rest ((lambda-var-dispatch (second ele) loc

                     nil
                     (progn
                     nil
                     (progn

-                      (setf reversed-args
+                      (setf reversed-result

                             (append (reverse (sb!di:debug-var-value
                                               (second ele) frame))
                             (append (reverse (sb!di:debug-var-value
                                               (second ele) frame))

-                                    reversed-args))
+                                    reversed-result))

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

-                          reversed-args)))))
+                    reversed-result)))))
+         ;; As long as we do an ordinary return (as opposed to SIGNALing
+         ;; a CONDITION) from the DOLIST above:
+         (nreverse reversed-result))

       (sb!di:lambda-list-unavailable
        ()
       (sb!di:lambda-list-unavailable
        ()

-       (push (make-unprintable-object "lambda list unavailable")
-            reversed-args)))
+       (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)
+  (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 (nreverse (mapcar #'ensure-printable-object reversed-args))))
+      (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*.

@@ -556,7 +575,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 #\[)

@@ -625,10 +646,16 @@ Other commands:
     (when old-hook
       (let ((*debugger-hook* nil))
        (funcall old-hook condition old-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)

 
 

+  ;; 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
+
+  ;; 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.

@@ -639,37 +666,46 @@ 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*))
+
+  ;; 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
     (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))
+     (let ((*debug-condition* condition)
+          (*debug-restarts* (compute-restarts condition))
+          (*nested-debug-condition* nil)
+          ;; 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)
+          (*print-length* *debug-print-length*)
+          (*print-level* *debug-print-level*)
+          (*readtable* *debug-readtable*)
+          (*print-readably* nil)
+          (*package* original-package)
+          (*print-pretty* original-print-pretty))

 
        ;; Before we start our own output, finish any pending output.
 
        ;; 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.
+       ;; 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)
 
        ;; (The initial output here goes to *ERROR-OUTPUT*, because the
        (flush-standard-output-streams)
 
        ;; (The initial output here goes to *ERROR-OUTPUT*, because the

@@ -819,7 +855,7 @@ 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*)

@@ -992,6 +1028,10 @@ reset to ~S."
 ;;; 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.
 ;;; 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.

+;;;
+;;; FIXME: There's probably some way to merge the code here with
+;;; FRAME-ARGS-AS-LIST. (A fair amount of logic is already shared
+;;; through LAMBDA-LIST-ELEMENT-DISPATCH, but I suspect more could be.)

 (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))

@@ -1008,8 +1048,7 @@ reset to ~S."
        :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 argument 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

@@ -1200,9 +1239,8 @@ argument")
 ;;;  (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."))