X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=87d5377bd686baf8996fef651954f663a25182c6;hb=148e3820ad314a9b59d0133c1d60eaac4af9118b;hp=7ac94694a4122fbd3bc05fdbf682c796b3ed676b;hpb=41ed816c7915806abca6b09ecd2136458f27adcc;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 7ac9469..87d5377 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -78,9 +78,9 @@ *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 @@ -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 - 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 @@ -291,7 +291,7 @@ Other commands: (code-location-selector (missing-arg) :type (or symbol integer) :read-only t) ;; the number used when listing the active breakpoints, and when ;; deleting breakpoints - (breakpoint-number (missing-arg) :type integer) :read-only t) + (breakpoint-number (missing-arg) :type integer :read-only t)) (defun create-breakpoint-info (place breakpoint code-location-selector &key (break #'identity) @@ -464,6 +464,20 @@ Other commands: (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))) ;;;; frame printing @@ -511,44 +525,49 @@ Other commands: (: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)) - (reversed-args nil)) - - ;; Construct function arguments in REVERSED-ARGS. + (reversed-result nil)) (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 - (setf reversed-args + (setf reversed-result (append (reverse (sb!di:debug-var-value (second ele) frame)) - reversed-args)) + reversed-result)) (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 () - (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 ")") - (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*. @@ -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. - (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 #\[) @@ -625,10 +646,16 @@ Other commands: (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. @@ -639,37 +666,46 @@ Other commands: "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 - (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. - ;; 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 @@ -819,7 +855,7 @@ reset to ~S." (let ((level *debug-command-level*) (restart-commands (make-restart-commands))) (with-simple-restart (abort - "Reduce debugger level (to debug level ~W)." + "~@" 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. +;;; +;;; 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)) @@ -1008,8 +1048,7 @@ reset to ~S." :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 @@ -1200,9 +1239,8 @@ argument") ;;; (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."))