X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=cf7f9dbc5d760a5f2eebdbf1d4f9ab19038dc4df;hb=f409f90c5e8c4c87ed9fa6efdc0e5c1952d94602;hp=f3564e86b4844cc463412910708c5296b91b4224;hpb=b0b168c08b31a748150f404398af754f26fd4813;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index f3564e8..cf7f9db 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -13,11 +13,28 @@ ;;;; variables and constants -(defvar *debug-print-level* 3 +;;; things to consider when tweaking these values: +;;; * We're afraid to just default them to NIL and NIL, in case the +;;; user inadvertently causes a hairy data structure to be printed +;;; when he inadvertently enters the debugger. +;;; * We don't want to truncate output too much. These days anyone +;;; can easily run their Lisp in a windowing system or under Emacs, +;;; so it's not the end of the world even if the worst case is a +;;; few thousand lines of output. +;;; * As condition :REPORT methods are converted to use the pretty +;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under +;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an +;;; ARG-COUNT-ERROR printed as +;;; error while parsing arguments to DESTRUCTURING-BIND: +;;; invalid number of elements in +;;; # +;;; to satisfy lambda list +;;; #: +;;; exactly 2 expected, but 5 found +(defvar *debug-print-level* 5 #!+sb-doc "*PRINT-LEVEL* for the debugger") - -(defvar *debug-print-length* 5 +(defvar *debug-print-length* 7 #!+sb-doc "*PRINT-LENGTH* for the debugger") @@ -54,6 +71,7 @@ "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*) @@ -61,22 +79,24 @@ *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. +"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 its own special values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*. -Debug commands do not affect * and friends, but evaluation in the debug loop - does affect these variables. +Debug commands do not affect *, //, and similar variables, but evaluation in + the debug loop does affect these variables. SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt - drop you into deeper into the debugger. + drop you deeper into the debugger. 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 name of any restart, or its number, is a valid command, and is the same - as using RESTART to invoke that restart. + 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. Changing frames: U up frame D down frame @@ -103,12 +123,20 @@ Breakpoints and steps: 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.") + Returns the value of the specified variable in the current frame. + +Other commands: + 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.)") ;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint. (define-condition step-condition (simple-condition) ()) @@ -244,30 +272,32 @@ Function and macro commands: ;;;; the BREAKPOINT-INFO structure ;;; info about a made breakpoint -(defstruct (breakpoint-info (:copier nil)) +(defstruct (breakpoint-info (:copier nil) + (:constructor %make-breakpoint-info)) ;; where we are going to stop - (place (missing-arg) :type (or sb!di:code-location sb!di:debug-fun)) - ;; the breakpoint returned by sb!di:make-breakpoint - (breakpoint (missing-arg) :type sb!di:breakpoint) + (place (missing-arg) + :type (or sb!di:code-location sb!di:debug-fun) + :read-only t) + ;; the breakpoint returned by SB!DI:MAKE-BREAKPOINT + (breakpoint (missing-arg) :type sb!di:breakpoint :read-only t) ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is ;; non-NIL, drop into the debugger. - (break #'identity :type function) - ;; the function returned from sb!di:preprocess-for-eval. If result is + (break #'identity :type function :read-only t) + ;; 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. - (print nil :type list) + (condition #'identity :type function :read-only t) + ;; 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 :read-only t) ;; the number used when listing the possible breakpoints within a - ;; function. Could also be a symbol such as start or end. - (code-location-number (missing-arg) :type (or symbol integer)) - ;; the number used when listing the breakpoints active and to delete - ;; breakpoints - (breakpoint-number (missing-arg) :type integer)) - -;;; Return a new BREAKPOINT-INFO structure with the info passed. -(defun create-breakpoint-info (place breakpoint code-location-number + ;; function; or could also be a symbol such as START or END + (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)) + +(defun create-breakpoint-info (place breakpoint code-location-selector &key (break #'identity) (condition #'identity) (print nil)) (setf *breakpoints* @@ -279,25 +309,25 @@ Function and macro commands: (first breakpoints))))) i)))) - (make-breakpoint-info :place place :breakpoint breakpoint - :code-location-number code-location-number - :breakpoint-number breakpoint-number - :break break :condition condition :print print))) + (%make-breakpoint-info :place place + :breakpoint breakpoint + :code-location-selector code-location-selector + :breakpoint-number breakpoint-number + :break break + :condition condition + :print print))) -;;; Print the breakpoint info for the breakpoint-info structure passed. (defun print-breakpoint-info (breakpoint-info) (let ((place (breakpoint-info-place breakpoint-info)) - (bp-number (breakpoint-info-breakpoint-number breakpoint-info)) - (loc-number (breakpoint-info-code-location-number breakpoint-info))) + (bp-number (breakpoint-info-breakpoint-number breakpoint-info))) (case (sb!di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info)) (:code-location (print-code-location-source-form place 0) (format t "~&~S: ~S in ~S" bp-number - loc-number - (sb!di:debug-fun-name (sb!di:code-location-debug-fun - place)))) + (breakpoint-info-code-location-selector breakpoint-info) + (sb!di:debug-fun-name (sb!di:code-location-debug-fun place)))) (:fun-start (format t "~&~S: FUN-START in ~S" bp-number (sb!di:debug-fun-name place))) @@ -417,9 +447,10 @@ Function and macro commands: ;;; 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)) ;;;; BACKTRACE @@ -438,6 +469,20 @@ Function and macro 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 @@ -475,53 +520,73 @@ Function and macro commands: ) ; EVAL-WHEN ;;; This is used in constructing arg lists for debugger printing when -;;; the arg list is unavailable, some arg is unavailable or unused, -;;; etc. +;;; the arg list is unavailable, some arg is unavailable or unused, etc. (defstruct (unprintable-object (:constructor make-unprintable-object (string)) (:print-object (lambda (x s) - (print-unreadable-object (x s :type t) + (print-unreadable-object (x s) (write-string (unprintable-object-string x) s)))) (: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) - (let* ((d-fun (sb!di:frame-debug-fun frame)) - (loc (sb!di:frame-code-location frame)) - (results (list (sb!di:debug-fun-name d-fun)))) +;;; 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-result nil)) (handler-case - (dolist (ele (sb!di:debug-fun-lambda-list d-fun)) - (lambda-list-element-dispatch ele - :required ((push (frame-call-arg ele loc frame) results)) - :optional ((push (frame-call-arg (second ele) loc frame) results)) - :keyword ((push (second ele) results) - (push (frame-call-arg (third ele) loc frame) results)) - :deleted ((push (frame-call-arg ele loc frame) results)) - :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 results + (setf reversed-result (append (reverse (sb!di:debug-var-value (second ele) frame)) - results)) + reversed-result)) (return)) (push (make-unprintable-object "unavailable &REST argument") - results))))) + 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") 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-fun-kind d-fun) + (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 (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*. + (let ((*print-length* nil) + (*print-level* nil)) + (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun)))) + ;; For the function arguments, we can just print normally. + (if (listp args) + (format t "~{ ~_~S~}" args) + (format t " ~S" args)))) + + (when (sb!di:debug-fun-kind debug-fun) (write-char #\[) - (prin1 (sb!di:debug-fun-kind d-fun)) + (prin1 (sb!di:debug-fun-kind debug-fun)) (write-char #\])))) (defun ensure-printable-object (object) @@ -577,6 +642,7 @@ Function and macro commands: ;;; These are bound on each invocation of INVOKE-DEBUGGER. (defvar *debug-restarts*) (defvar *debug-condition*) +(defvar *nested-debug-condition*) (defun invoke-debugger (condition) #!+sb-doc @@ -585,8 +651,19 @@ Function and macro commands: (when old-hook (let ((*debugger-hook* nil)) (funcall old-hook condition old-hook)))) - (sb!unix:unix-sigsetmask 0) + ;; If we're a background thread and *background-threads-wait-for-debugger* + ;; is NIL, this will invoke a restart + + ;; 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. @@ -597,36 +674,47 @@ Function and macro 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*. - ;; 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* 0) - (*print-length* *debug-print-length*) - (*print-level* *debug-print-level*) - (*readtable* *debug-readtable*) - (*print-readably* nil) - (*print-pretty* t) - (*package* original-package)) + (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) + (background-p nil) + (*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 @@ -641,10 +729,22 @@ reset to ~S." (type-of *debug-condition*) *debug-condition*) (error (condition) - (format *error-output* - "~&(caught ~S trying to print ~S when entering debugger)~%" - (type-of condition) - '*debug-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.)~@:>~%" + 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 @@ -653,15 +753,18 @@ reset to ~S." ;; 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, + + (setf background-p + (sb!thread::debugger-wait-until-foreground-thread *debug-io*)) + (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*, or using - ;; PEEK-CHAR or some such thing on the program's ordinary - ;; (possibly also redirected) *STANDARD-INPUT*. - (*standard-input* *debug-io*) + ;; 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 @@ -680,7 +783,8 @@ reset to ~S." '*debug-condition* '*debug-beginner-help-p*)) (show-restarts *debug-restarts* *debug-io*)) - (internal-debug)))))) + (internal-debug)) + (when background-p (sb!thread::release-foreground))))))) (defun show-restarts (restarts s) (cond ((null restarts) @@ -688,7 +792,8 @@ reset to ~S." "~&(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)) @@ -703,7 +808,7 @@ reset to ~S." (dolist (restart restarts) (let ((name (restart-name restart))) (cond ((member name names-used) - (format s "~& ~2D: ~@VT~A~%" count max-name-len restart)) + (format s "~& ~2D: ~V@T~A~%" count max-name-len restart)) (t (format s "~& ~2D: [~VA] ~A~%" count (- max-name-len 3) name restart) @@ -721,8 +826,7 @@ reset to ~S." (*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*))) ;;;; DEBUG-LOOP @@ -733,7 +837,7 @@ reset to ~S." "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*)) @@ -760,42 +864,29 @@ reset to ~S." '*flush-debug-errors*) (/show0 "throwing DEBUG-LOOP-CATCHER") (throw 'debug-loop-catcher nil))))) - ;; We have to bind level for the restart function created by + ;; We have to bind LEVEL for the restart function created by ;; WITH-SIMPLE-RESTART. (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*) - (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 - (let* ((exp (read)) - (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)))))))))))) + +(defvar *debug-loop-fun* #'debug-loop-fun + "a function taking no parameters that starts the low-level debug loop") ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic. (defun debug-eval-print (expr) @@ -938,6 +1029,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)) @@ -954,8 +1049,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 @@ -1146,9 +1240,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.")) @@ -1160,7 +1253,7 @@ argument") (show-restarts *debug-restarts* *debug-io*) (write-string "restart: ") (force-output) - (setf num (read *standard-input*))) + (setf num (read *debug-io*))) (let ((restart (typecase num (unsigned-byte (nth num *debug-restarts*)) @@ -1575,17 +1668,37 @@ argument") (if function (describe function) (format t "can't figure out the function for this frame")))) + +(!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 "~@")))) ;;;; debug loop command utilities -(defun read-prompting-maybe (prompt &optional (in *standard-input*) - (out *standard-output*)) - (unless (sb!int:listen-skip-whitespace in) - (princ prompt out) - (force-output out)) - (read in)) +(defun read-prompting-maybe (prompt) + (unless (sb!int:listen-skip-whitespace *debug-io*) + (princ prompt) + (force-output)) + (read *debug-io*)) -(defun read-if-available (default &optional (stream *standard-input*)) - (if (sb!int:listen-skip-whitespace stream) - (read stream) +(defun read-if-available (default) + (if (sb!int:listen-skip-whitespace *debug-io*) + (read *debug-io*) default))