X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=b7c1306ece30b26c2a71ec0214a20127f3a7e9bd;hb=8b64d57b865fec6ba082dda965146b5e8aa877b3;hp=ec3d3b2ff3977e3abd7dbed2f8682bab0a5054e2;hpb=ef11b09c41b1e344212f6a363892a849af7ff94e;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index ec3d3b2..b7c1306 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -31,12 +31,25 @@ ;;; to satisfy lambda list ;;; #: ;;; exactly 2 expected, but 5 found +;;; +;;; FIXME: These variables were deprecated in late February 2004, and +;;; can probably be removed in about a year. (defvar *debug-print-level* 5 #!+sb-doc - "*PRINT-LEVEL* for the debugger") + "(This is deprecated in favor of *DEBUG-PRINT-VARIABLE-ALIST*.) + +*PRINT-LEVEL* for the debugger") (defvar *debug-print-length* 7 #!+sb-doc - "*PRINT-LENGTH* for the debugger") + "(This is deprecated in favor of *DEBUG-PRINT-VARIABLE-ALIST*.) + +*PRINT-LENGTH* for the debugger") + +(defvar *debug-print-variable-alist* nil + #!+sb-doc + "an association list describing new bindings for special variables +(typically *PRINT-FOO* variables) to be used within the debugger, e.g. +((*PRINT-LENGTH* . 10) (*PRINT-LEVEL* . 6) (*PRINT-PRETTY* . NIL))") (defvar *debug-readtable* ;; KLUDGE: This can't be initialized in a cold toplevel form, @@ -71,6 +84,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*) @@ -78,9 +92,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 +108,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 @@ -122,17 +136,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. Other commands: - 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.)") + 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) ()) @@ -443,9 +460,10 @@ Other 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 @@ -557,19 +575,17 @@ Other commands: (nreverse reversed-result)) (sb!di:lambda-list-unavailable () - :lambda-list-unavailable)))) + (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)) - (loc (sb!di:frame-code-location frame))) + (let ((debug-fun (sb!di:frame-debug-fun frame))) (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") - (let ((args (mapcar #'ensure-printable-object - (frame-args-as-list frame)))) + (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*. @@ -577,7 +593,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 #\[) @@ -634,22 +652,118 @@ Other commands: of this variable to the function because it binds *DEBUGGER-HOOK* to NIL around the invocation.") +(defvar *invoke-debugger-hook* nil + #!+sb-doc + "This is either NIL or a designator for a function of two arguments, + to be run when the debugger is about to be entered. The function is + run with *INVOKE-DEBUGGER-HOOK* bound to NIL to minimize recursive + errors, and receives as arguments the condition that triggered + debugger entry and the previous value of *INVOKE-DEBUGGER-HOOK* + + This mechanism is an SBCL extension similar to the standard *DEBUGGER-HOOK*. + In contrast to *DEBUGGER-HOOK*, it is observed by INVOKE-DEBUGGER even when + called by BREAK.") + ;;; These are bound on each invocation of INVOKE-DEBUGGER. (defvar *debug-restarts*) (defvar *debug-condition*) (defvar *nested-debug-condition*) +;;; Oh, what a tangled web we weave when we preserve backwards +;;; compatibility with 1968-style use of global variables to control +;;; per-stream i/o properties; there's really no way to get this +;;; quite right, but we do what we can. +(defun funcall-with-debug-io-syntax (fun &rest rest) + (declare (type function fun)) + ;; 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 (;; 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) + (*package* original-package) + (*print-pretty* original-print-pretty) + (*print-readably* nil) + ;; Clear the circularity machinery to try to to reduce the + ;; pain from sharing the circularity table across all + ;; streams; if these are not rebound here, then setting + ;; *PRINT-CIRCLE* within the debugger when debugging in a + ;; state where something circular was being printed (e.g., + ;; because the debugger was entered on an error in a + ;; PRINT-OBJECT method) makes a hopeless mess. Binding them + ;; here does seem somewhat ugly because it makes it more + ;; difficult to debug the printing-of-circularities code + ;; itself; however, as far as I (WHN, 2004-05-29) can see, + ;; that's almost entirely academic as long as there's one + ;; shared *C-H-T* for all streams (i.e., it's already + ;; unreasonably difficult to debug print-circle machinery + ;; given the buggy crosstalk between the debugger streams + ;; and the stream you're trying to watch), and any fix for + ;; that buggy arrangement will likely let this hack go away + ;; naturally. + (sb!impl::*circularity-hash-table* . nil) + (sb!impl::*circularity-counter* . nil) + ;; These rebindings are now (as of early 2004) deprecated, + ;; with the new *PRINT-VAR-ALIST* mechanism preferred. + (*print-length* *debug-print-length*) + (*print-level* *debug-print-level*) + (*readtable* *debug-readtable*)) + (progv + ;; (Why NREVERSE? PROGV makes the later entries have + ;; precedence over the earlier entries. + ;; *DEBUG-PRINT-VARIABLE-ALIST* is called an alist, so it's + ;; expected that its earlier entries have precedence. And + ;; the earlier-has-precedence behavior is mostly more + ;; convenient, so that programmers can use PUSH or LIST* to + ;; customize *DEBUG-PRINT-VARIABLE-ALIST*.) + (nreverse (mapcar #'car *debug-print-variable-alist*)) + (nreverse (mapcar #'cdr *debug-print-variable-alist*)) + (apply fun rest)))))) + +;;; the ordinary ANSI case of INVOKE-DEBUGGER, when not suppressed by +;;; command-line --disable-debugger option (defun invoke-debugger (condition) #!+sb-doc "Enter the debugger." + (let ((old-hook *debugger-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) + (let ((old-hook *invoke-debugger-hook*)) + (when old-hook + (let ((*invoke-debugger-hook* nil)) + (funcall old-hook condition old-hook)))) + ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here, to reset the + ;; signal state in the case that we wind up in the debugger as a + ;; result of something done by a signal handler. It's not + ;; altogether obvious that this is necessary, and indeed SBCL has + ;; not been doing it since 0.7.8.5. But nobody seems altogether + ;; convinced yet + ;; -- dan 2003.11.11, based on earlier comment of 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. @@ -660,102 +774,157 @@ 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*)) - (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)) - - ;; 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.) - (handler-case - (format *error-output* - "~2&~@~%" - (type-of *debug-condition*) - *debug-condition*) - (error (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 ~ + (type-of *debug-condition*) + (sb!thread:current-thread-id) + *debug-condition*) + (error (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 - ;; *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: 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*. (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 - ;; 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) - (when *debug-beginner-help-p* - (format *debug-io* - "~%~@~2%" - '*debug-condition* - '*debug-beginner-help-p*)) - (show-restarts *debug-restarts* *debug-io*)) - (internal-debug)))))) + 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*))))) + + (let ((background-p (sb!thread::debugger-wait-until-foreground-thread + *debug-io*))) + + ;; 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) + + (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*. (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 + ;; 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) + (when *debug-beginner-help-p* + (format *debug-io* + "~%~@~2%")) + (show-restarts *debug-restarts* *debug-io*)) + (internal-debug)) + (when background-p + (sb!thread::release-foreground)))))) + +;;; this function is for use in *INVOKE-DEBUGGER-HOOK* when ordinary +;;; ANSI behavior has been suppressed by the "--disable-debugger" +;;; command-line option +(defun debugger-disabled-hook (condition me) + (declare (ignore me)) + ;; There is no one there to interact with, so report the + ;; condition and terminate the program. + (flet ((failure-quit (&key recklessly-p) + (/show0 "in FAILURE-QUIT (in --disable-debugger debugger hook)") + (quit :unix-status 1 :recklessly-p recklessly-p))) + ;; This HANDLER-CASE is here mostly to stop output immediately + ;; (and fall through to QUIT) when there's an I/O error. Thus, + ;; when we're run under a shell script or something, we can die + ;; cleanly when the script dies (and our pipes are cut), instead + ;; of falling into ldb or something messy like that. Similarly, we + ;; can terminate cleanly even if BACKTRACE dies because of bugs in + ;; user PRINT-OBJECT methods. + (handler-case + (progn + (format *error-output* + "~&~@~2%" + (type-of condition) + condition) + ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that + ;; even if we hit an error within BACKTRACE (e.g. a bug in + ;; the debugger's own frame-walking code, or a bug in a user + ;; PRINT-OBJECT method) we'll at least have the CONDITION + ;; printed out before we die. + (finish-output *error-output*) + ;; (Where to truncate the BACKTRACE is of course arbitrary, but + ;; it seems as though we should at least truncate it somewhere.) + (sb!debug:backtrace 128 *error-output*) + (format + *error-output* + "~%unhandled condition in --disable-debugger mode, quitting~%") + (finish-output *error-output*) + (failure-quit)) + (condition () + ;; We IGNORE-ERRORS here because even %PRIMITIVE PRINT can + ;; fail when our output streams are blown away, as e.g. when + ;; we're running under a Unix shell script and it dies somehow + ;; (e.g. because of a SIGINT). In that case, we might as well + ;; just give it up for a bad job, and stop trying to notify + ;; the user of anything. + ;; + ;; Actually, the only way I've run across to exercise the + ;; problem is to have more than one layer of shell script. + ;; I have a shell script which does + ;; time nice -10 sh make.sh "$1" 2>&1 | tee make.tmp + ;; and the problem occurs when I interrupt this with Ctrl-C + ;; under Linux 2.2.14-5.0 and GNU bash, version 1.14.7(1). + ;; I haven't figured out whether it's bash, time, tee, Linux, or + ;; what that is responsible, but that it's possible at all + ;; means that we should IGNORE-ERRORS here. -- WHN 2001-04-24 + (ignore-errors + (%primitive print + "Argh! error within --disable-debugger error handling")) + (failure-quit :recklessly-p t))))) + +;;; halt-on-failures and prompt-on-failures modes, suitable for +;;; noninteractive and interactive use respectively +(defun disable-debugger () + (when (eql *invoke-debugger-hook* nil) + (setf *debug-io* *error-output* + *invoke-debugger-hook* 'debugger-disabled-hook))) + +(defun enable-debugger () + (when (eql *invoke-debugger-hook* 'debugger-disabled-hook) + (setf *invoke-debugger-hook* nil))) + +(setf *debug-io* *query-io*) (defun show-restarts (restarts s) (cond ((null restarts) @@ -763,7 +932,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)) @@ -785,6 +955,9 @@ reset to ~S." (push name names-used)))) (incf count)))))) +(defvar *debug-loop-fun* #'debug-loop-fun + "a function taking no parameters that starts the low-level debug loop") + ;;; 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 @@ -796,8 +969,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 @@ -808,7 +980,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*)) @@ -840,37 +1012,21 @@ 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*) - (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 *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 - (funcall cmd-fun))))))))))))))) + (funcall cmd-fun)))))))))))) ;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic. (defun debug-eval-print (expr) @@ -1224,9 +1380,8 @@ reset to ~S." ;;; (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.")) @@ -1656,6 +1811,24 @@ reset to ~S." (!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