\f
;;;; 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")
"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*)
*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
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.)")
\f
;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint.
(define-condition step-condition (simple-condition) ())
;;;; 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*
(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)))
;;; 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))
\f
;;;; BACKTRACE
(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
) ; 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)
;;; 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
(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.
"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
(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
;; 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
'*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)
"~&(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))
(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)
(*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*)))
\f
;;;; DEBUG-LOOP
"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*))
'*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)."
+ "~@<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)
;;; 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))
: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
;;; (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."))
(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*))
(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 "~@<can't find a tag for this frame ~
+ ~2I~_(hint: try increasing the DEBUG optimization quality ~
+ and recompiling)~:@>"))))
\f
;;;; 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))
projects / sbcl.git / blobdiff