X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=dde5f757fd9113962a199cd8675aa5680a267568;hb=212ef8043aeaceaa627f2924e04554fbc37b8ee1;hp=16f91768492e52524790d40afaafb02159578104;hpb=71173fc4590389c52ac0e1abd75f79e417dad361;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 16f9176..dde5f75 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -34,9 +34,8 @@ #!+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 @@ -47,19 +46,22 @@ (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. @@ -486,7 +488,7 @@ Function and macro commands: s))))) 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 ;;; &REST arg's list of values. @@ -510,25 +512,15 @@ Function and macro commands: (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))) - ;; FIXME: For some reason this sometimes prints as - ;; (FOO-BAR-LONG-THING - ;; X - ;; Y - ;; Z) - ;; (OK) and sometimes prints as - ;; (FOO-BAR-LONG-THING X - ;; Y - ;; Z) - ;; even when this second style causes confusingly long weird lines - ;; (bad). Handle printing explicitly inside our own - ;; PPRINT-LOGICAL-BLOCK, and force the preferred style for long - ;; lines. - (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)) @@ -545,9 +537,9 @@ Function and macro commands: (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) - (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; @@ -606,7 +598,7 @@ Function and macro commands: (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) ;; Elsewhere in the system, we use the SANE-PACKAGE function for @@ -624,14 +616,6 @@ reset to ~S." (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 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, @@ -652,22 +636,61 @@ reset to ~S." (*print-readably* nil) (*print-pretty* t) (*package* original-package)) - #!+sb-show (sb!conditions::show-condition *debug-condition* + + ;; 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. + #!+sb-show (sb!kernel:show-condition *debug-condition* *error-output*) (format *error-output* - "~2&debugger invoked on ~S of type ~S:~% " - '*debug-condition* + "~2&debugger invoked on condition of type ~S:~% " (type-of *debug-condition*)) (princ-debug-condition-carefully *error-output*) (terpri *error-output*) - (let (;; FIXME: like the bindings of *STANDARD-INPUT* and - ;; *STANDARD-OUTPUT* above.. + + ;; 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) - (show-restarts *debug-restarts* *error-output*)) + (format *debug-io* + "~%~@~2%" + '*debug-condition*) + (show-restarts *debug-restarts* *debug-io*) + (terpri *debug-io*)) (internal-debug)))))) -(defun show-restarts (restarts &optional (s *error-output*)) +(defun show-restarts (restarts s) (when restarts (format s "~&restarts:~%") (let ((count 0) @@ -691,18 +714,17 @@ reset to ~S." (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) - (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)))) @@ -746,7 +768,8 @@ reset to ~S." (with-simple-restart (abort "Reduce debugger level (to debug level ~D)." level) - (funcall *debug-prompt*) + (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 @@ -936,7 +959,7 @@ reset to ~S." :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 @@ -945,7 +968,7 @@ reset to ~S." (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) @@ -1134,7 +1157,7 @@ reset to ~S." (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*))) @@ -1173,8 +1196,8 @@ reset to ~S." (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)))