;;;; files for more information.
(in-package "SB!DEBUG")
-
-(file-comment
- "$Header$")
\f
;;;; variables and constants
"*PRINT-LENGTH* for the debugger")
(defvar *debug-readtable*
- ;; KLUDGE: This can't be initialized in a cold toplevel form, because the
- ;; *STANDARD-READTABLE* isn't initialized until after cold toplevel forms
- ;; have run. So instead we initialize it immediately after
- ;; *STANDARD-READTABLE*. -- WHN 20000205
+ ;; KLUDGE: This can't be initialized in a cold toplevel form,
+ ;; because the *STANDARD-READTABLE* isn't initialized until after
+ ;; cold toplevel forms have run. So instead we initialize it
+ ;; immediately after *STANDARD-READTABLE*. -- WHN 20000205
nil
#!+sb-doc
"*READTABLE* for the debugger")
#!+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)
+
+;;; If this is bound before the debugger is invoked, it is used as the
+;;; stack top by the debugger.
+(defvar *stack-top-hint* nil)
-(defvar *stack-top-hint* nil
- #!+sb-doc
- "If this is bound before the debugger is invoked, it is used as the stack
- top by the debugger.")
(defvar *stack-top* nil)
(defvar *real-stack-top* nil)
(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*")
-
+;;; Beginner-oriented help messages are important because you end up
+;;; in the debugger whenever something bad happens, or if you try to
+;;; get out of the system with Ctrl-C or (EXIT) or EXIT or whatever.
+;;; But after memorizing them the wasted screen space gets annoying..
+(defvar *debug-beginner-help-p* t
+ "Should the debugger display beginner-oriented help messages?")
+
+(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.
Any command may be uniquely abbreviated.
-The debugger rebinds various special variables for controlling i/o,
- sometimes to defaults (a la WITH-STANDARD-IO-SYNTAX) and sometimes to
- its own values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*.
+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
- do affect these variables.
+ does affect these variables.
SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
drop you into deeper into the debugger.
Getting in and out of the debugger:
- Q throws to top level.
- GO calls CONTINUE which tries to proceed with the restart 'CONTINUE.
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.
Changing frames:
- U up frame D down frame
- T top frame B bottom frame
- F n frame n
+ U up frame D down frame
+ B bottom frame F n frame n (n=0 for top frame)
Inspecting frames:
BACKTRACE [n] shows n frames going down the stack.
SOURCE [n] displays frame's source form with n levels of enclosing forms.
Breakpoints and steps:
- LIST-LOCATIONS [{function | :c}] List the locations for breakpoints.
- Specify :c for the current frame.
+ LIST-LOCATIONS [{function | :C}] List the locations for breakpoints.
+ Specify :C for the current frame.
Abbreviation: LL
LIST-BREAKPOINTS List the active breakpoints.
Abbreviations: LB, LBP
#!+sb-doc
"When true, list the code location type in the LIST-LOCATIONS command.")
-;;; a list of the types of code-locations that should not be stepped to and
-;;; should not be listed when listing breakpoints
+;;; a list of the types of code-locations that should not be stepped
+;;; to and should not be listed when listing breakpoints
(defvar *bad-code-location-types* '(:call-site :internal-error))
(declaim (type list *bad-code-location-types*))
(defvar *possible-breakpoints*)
(declaim (type list *possible-breakpoints*))
-;;; a list of the made and active breakpoints, each is a breakpoint-info
-;;; structure
+;;; a list of the made and active breakpoints, each is a
+;;; BREAKPOINT-INFO structure
(defvar *breakpoints* nil)
(declaim (type list *breakpoints*))
-;;; a list of breakpoint-info structures of the made and active step
+;;; a list of BREAKPOINT-INFO structures of the made and active step
;;; breakpoints
(defvar *step-breakpoints* nil)
(declaim (type list *step-breakpoints*))
(setf found t)))
first-code-location))
-;;; Return a list of the next code-locations following the one passed. One of
-;;; the *BAD-CODE-LOCATION-TYPES* will not be returned.
+;;; Return a list of the next code-locations following the one passed.
+;;; One of the *BAD-CODE-LOCATION-TYPES* will not be returned.
(defun next-code-locations (code-location)
(let ((debug-block (sb!di:code-location-debug-block code-location))
(block-code-locations nil))
(push code-location possible-breakpoints))))))
(nreverse possible-breakpoints)))
-;;; Searches the info-list for the item passed (code-location, debug-function,
-;;; or breakpoint-info). If the item passed is a debug function then kind will
-;;; be compared if it was specified. The kind if also compared if a
-;;; breakpoint-info is passed since it's in the breakpoint. The info structure
-;;; is returned if found.
+;;; Searches the info-list for the item passed (code-location,
+;;; debug-function, or breakpoint-info). If the item passed is a debug
+;;; function then kind will be compared if it was specified. The kind
+;;; if also compared if a breakpoint-info is passed since it's in the
+;;; breakpoint. The info structure is returned if found.
(defun location-in-list (place info-list &optional (kind nil))
(when (breakpoint-info-p place)
(setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place)))
(eq kind (sb!di:breakpoint-kind
y-breakpoint))))))))))
-;;; If Loc is an unknown location, then try to find the block start location.
-;;; Used by source printing to some information instead of none for the user.
+;;; If LOC is an unknown location, then try to find the block start
+;;; location. Used by source printing to some information instead of
+;;; none for the user.
(defun maybe-block-start-location (loc)
(if (sb!di:code-location-unknown-p loc)
(let* ((block (sb!di:code-location-debug-block loc))
;;;; the BREAKPOINT-INFO structure
;;; info about a made breakpoint
-(defstruct breakpoint-info
+(defstruct (breakpoint-info (:copier nil))
;; where we are going to stop
(place (required-argument)
:type (or sb!di:code-location sb!di:debug-function))
;; 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.
+ ;; 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)
- ;; the number used when listing the possible breakpoints within a function.
- ;; Could also be a symbol such as start or end.
+ ;; the number used when listing the possible breakpoints within a
+ ;; function. Could also be a symbol such as start or end.
(code-location-number (required-argument) :type (or symbol integer))
;; the number used when listing the breakpoints active and to delete
;; breakpoints
\f
;;;; MAIN-HOOK-FUNCTION for steps and breakpoints
-;;; This must be passed as the hook function. It keeps track of where step
-;;; breakpoints are.
+;;; This must be passed as the hook function. It keeps track of where
+;;; STEP breakpoints are.
(defun main-hook-function (current-frame breakpoint &optional return-vals
function-end-cookie)
(setf *default-breakpoint-debug-function*
(eval-when (:compile-toplevel :execute)
-;;; This is a convenient way to express what to do for each type of lambda-list
-;;; element.
+;;; This is a convenient way to express what to do for each type of
+;;; lambda-list element.
(sb!xc:defmacro lambda-list-element-dispatch (element
&key
required
(:rest ,@rest)
(:keyword ,@keyword)))
(symbol
- (assert (eq ,element :deleted))
+ (aver (eq ,element :deleted))
,@deleted)))
(sb!xc:defmacro lambda-var-dispatch (variable location deleted valid other)
(:print-object (lambda (x s)
(print-unreadable-object (x s :type t)
(write-string (unprintable-object-string x)
- s)))))
+ s))))
+ (:copier nil))
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.
+;;; &REST arg's list of values.
(defun print-frame-call-1 (frame)
(let* ((d-fun (sb!di:frame-debug-function frame))
(loc (sb!di:frame-code-location frame))
(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)))
- (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))
(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;
+;;; Prints a representation of the function call causing FRAME to
+;;; exist. VERBOSITY indicates the level of information to output;
;;; zero indicates just printing the debug-function's name, and one
;;; indicates displaying call-like, one-liner format with argument
;;; values.
(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)
- (let ((original-package *package*)) ; protect it from WITH-STANDARD-IO-SYNTAX
+
+ ;; 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.
+ (unless (and (packagep *package*)
+ (package-name *package*))
+ (setf *package* (find-package :cl-user))
+ (format *error-output*
+ "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))
- ;; 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 also want to set the i/o subsystem into a known, useful
- ;; state, regardless of where in 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*.
+ ;; 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.
+ ;; 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.
+ ;; 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*)
(*print-readably* nil)
(*print-pretty* t)
(*package* original-package))
- (format *error-output*
- "~2&debugger invoked on ~S of type ~S:~% ~A~%"
- '*debug-condition*
- (type-of *debug-condition*)
- *debug-condition*)
- (let (;; FIXME: like the bindings of *STANDARD-INPUT* and
- ;; *STANDARD-OUTPUT* above..
+
+ ;; 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&~@<debugger invoked on condition of type ~S: ~
+ ~2I~_~A~:>~%"
+ (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*)))
+
+ ;; 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*))
+ (when *debug-beginner-help-p*
+ (format *debug-io*
+ "~%~@<Within the debugger, you can type HELP for help. ~
+ At any command prompt (within the debugger or not) you ~
+ can type (SB-EXT:QUIT) to terminate the SBCL ~
+ executable. The condition which caused the debugger to ~
+ be entered is bound to ~S. You can suppress this ~
+ message by clearing ~S.~:@>~2%"
+ '*debug-condition*
+ '*debug-beginner-help-p*))
+ (show-restarts *debug-restarts* *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)
(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))))
\f
;; WITH-SIMPLE-RESTART.
(let ((level *debug-command-level*)
(restart-commands (make-restart-commands)))
- (with-simple-restart (abort "Return to debug level ~D." level)
- (funcall *debug-prompt*)
+ (with-simple-restart (abort
+ "Reduce debugger level (to debug level ~D)."
+ 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
(t
(funcall cmd-fun)))))))))))))))
-(defvar *auto-eval-in-frame* t
+;;; FIXME: As far as I know, the CMU CL X86 codebase has never
+;;; supported access to the environment of the debugged function. It
+;;; would be really, really nice to make that work! (Until then,
+;;; non-NIL *AUTO-EVAL-IN-FRAME* seems to be useless, and as of
+;;; sbcl-0.6.10 it even seemed to be actively harmful, since the
+;;; debugger gets confused when trying to unwind the frames which
+;;; arise in SIGINT interrupts. So it's set to NIL.)
+(defvar *auto-eval-in-frame* nil
#!+sb-doc
- "When set (the default), evaluations in the debugger's command loop occur
- relative to the current frame's environment without the need of debugger
- forms that explicitly control this kind of evaluation.")
+ "When set, evaluations in the debugger's command loop occur relative
+ to the current frame's environment without the need of debugger
+ forms that explicitly control this kind of evaluation. In an ideal
+ world, the default would be T, but since unfortunately the X86
+ debugger support isn't good enough to make this useful, the
+ default is NIL instead.")
;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
-(defun debug-eval-print (exp)
- (setq +++ ++ ++ + + - - exp)
+(defun debug-eval-print (expr)
+ (/noshow "entering DEBUG-EVAL-PRINT" expr)
+ (/noshow (fboundp 'compile))
+ (/noshow (and (fboundp 'compile) *auto-eval-in-frame*))
+ (setq +++ ++ ++ + + - - expr)
(let* ((values (multiple-value-list
(if (and (fboundp 'compile) *auto-eval-in-frame*)
(sb!di:eval-in-frame *current-frame* -)
(eval -))))
(*standard-output* *debug-io*))
+ (/noshow "done with EVAL in DEBUG-EVAL-PRINT")
(fresh-line)
(if values (prin1 (car values)))
(dolist (x (cdr values))
(unless (boundp '*)
(setq * nil)
(fresh-line)
- ;; FIXME: Perhaps this shouldn't be WARN (for fear of complicating
- ;; the debugging situation?) but at least it should go to *ERROR-OUTPUT*.
- ;; (And probably it should just be WARN.)
+ ;; FIXME: The way INTERACTIVE-EVAL does this seems better.
(princ "Setting * to NIL (was unbound marker)."))))
\f
;;;; debug loop functions
-;;; These commands are functions, not really commands, so that users can get
-;;; their hands on the values returned.
+;;; These commands are functions, not really commands, so that users
+;;; can get their hands on the values returned.
(eval-when (:execute :compile-toplevel)
`(setf (sb!di:debug-var-value (car vars) *current-frame*)
,value-var))))
(t
- ;; Since we have more than one, first see whether we have any
- ;; variables that exactly match the specification.
+ ;; Since we have more than one, first see whether we have
+ ;; any variables that exactly match the specification.
(let* ((name (etypecase name
(symbol (symbol-name name))
(simple-string name)))
(:set
`(setf (sb!di:debug-var-value (car vars) *current-frame*)
,value-var))))
- ;; If there weren't any exact matches, flame about ambiguity
- ;; unless all the variables have the same name.
+ ;; If there weren't any exact matches, flame about
+ ;; ambiguity unless all the variables have the same
+ ;; name.
((and (not exact)
(find-if-not
#'(lambda (v)
(delete-duplicates
vars :test #'string=
:key #'sb!di:debug-var-symbol-name))))
- ;; All names are the same, so see whether the user ID'ed one of
- ;; them.
+ ;; All names are the same, so see whether the user
+ ;; ID'ed one of them.
(id-supplied
(let ((v (find id vars :key #'sb!di:debug-var-id)))
(unless v
) ; EVAL-WHEN
+;;; FIXME: This doesn't work. It would be real nice we could make it
+;;; work! Alas, it doesn't seem to work in CMU CL X86 either..
(defun var (name &optional (id 0 id-supplied))
#!+sb-doc
- "Returns a variable's value if possible. Name is a simple-string or symbol.
+ "Return a variable's value if possible. NAME is a simple-string or symbol.
If it is a simple-string, it is an initial substring of the variable's name.
If name is a symbol, it has the same name and package as the variable whose
value this function returns. If the symbol is uninterned, then the variable
(defun (setf var) (value name &optional (id 0 id-supplied))
(define-var-operation :set value))
-;;; This returns the COUNT'th arg as the user sees it from args, the result of
-;;; SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a 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.
+;;; This returns the COUNT'th arg as the user sees it from args, the
+;;; result of SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a
+;;; 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.
(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-arg before n'th argument")
+ (error "unused &REST argument before n'th
+argument")
(dolist (value
(sb!di:debug-var-value var *current-frame*)
(error
(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)
;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are
;;; permitted.
-;;;
-;;; FIXME: This is not needed in the target Lisp system.
-(defmacro def-debug-command (name args &rest body)
- (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND"))))
+(defmacro !def-debug-command (name args &rest body)
+ (let ((fun-name (symbolicate name "-DEBUG-COMMAND")))
`(progn
(setf *debug-commands*
(remove ,name *debug-commands* :key #'car :test #'string=))
(push (cons ,name #',fun-name) *debug-commands*)
',fun-name)))
-(defun def-debug-command-alias (new-name existing-name)
+(defun !def-debug-command-alias (new-name existing-name)
(let ((pair (assoc existing-name *debug-commands* :test #'string=)))
(unless pair (error "unknown debug command name: ~S" existing-name))
(push (cons new-name (cdr pair)) *debug-commands*))
new-name)
-;;; This takes a symbol and uses its name to find a debugger command, using
-;;; initial substring matching. It returns the command function if form
-;;; identifies only one command, but if form is ambiguous, this returns a list
-;;; of the command names. If there are no matches, this returns nil. Whenever
-;;; the loop that looks for a set of possibilities encounters an exact name
-;;; match, we return that command function immediately.
+;;; This takes a symbol and uses its name to find a debugger command,
+;;; using initial substring matching. It returns the command function
+;;; if form identifies only one command, but if form is ambiguous,
+;;; this returns a list of the command names. If there are no matches,
+;;; this returns nil. Whenever the loop that looks for a set of
+;;; possibilities encounters an exact name match, we return that
+;;; command function immediately.
(defun debug-command-p (form &optional other-commands)
(if (or (symbolp form) (integerp form))
(let* ((name
((not cmds) res)
(setf (car cmds) (caar cmds))))))))
-;;; Returns a list of debug commands (in the same format as *debug-commands*)
-;;; that invoke each active restart.
+;;; Return a list of debug commands (in the same format as
+;;; *debug-commands*) that invoke each active restart.
;;;
-;;; Two commands are made for each restart: one for the number, and one for
-;;; the restart name (unless it's been shadowed by an earlier restart of the
-;;; same name).
+;;; Two commands are made for each restart: one for the number, and
+;;; one for the restart name (unless it's been shadowed by an earlier
+;;; restart of the same name, or it is NIL).
(defun make-restart-commands (&optional (restarts *debug-restarts*))
(let ((commands)
(num 0)) ; better be the same as show-restarts!
(dolist (restart restarts)
(let ((name (string (restart-name restart))))
- (unless (find name commands :key #'car :test #'string=)
- (let ((restart-fun
- #'(lambda ()
- (invoke-restart-interactively restart))))
- (push (cons name restart-fun) commands)
- (push (cons (format nil "~D" num) restart-fun) commands))))
- (incf num))
- commands))
+ (let ((restart-fun
+ #'(lambda () (invoke-restart-interactively restart))))
+ (push (cons (format nil "~d" num) restart-fun) commands)
+ (unless (or (null (restart-name restart))
+ (find name commands :key #'car :test #'string=))
+ (push (cons name restart-fun) commands))))
+ (incf num))
+ commands))
\f
;;;; frame-changing commands
-(def-debug-command "UP" ()
+(!def-debug-command "UP" ()
(let ((next (sb!di:frame-up *current-frame*)))
(cond (next
(setf *current-frame* next)
(t
(format t "~&Top of stack.")))))
-(def-debug-command "DOWN" ()
+(!def-debug-command "DOWN" ()
(let ((next (sb!di:frame-down *current-frame*)))
(cond (next
(setf *current-frame* next)
(t
(format t "~&Bottom of stack.")))))
-(def-debug-command-alias "D" "DOWN")
+(!def-debug-command-alias "D" "DOWN")
-(def-debug-command "TOP" ()
- (do ((prev *current-frame* lead)
- (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead)))
- ((null lead)
- (setf *current-frame* prev)
- (print-frame-call prev))))
+;;; CMU CL had this command, but SBCL doesn't, since it's redundant
+;;; with "FRAME 0", and it interferes with abbreviations for the
+;;; TOPLEVEL restart.
+;;;(!def-debug-command "TOP" ()
+;;; (do ((prev *current-frame* lead)
+;;; (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead)))
+;;; ((null lead)
+;;; (setf *current-frame* prev)
+;;; (print-frame-call prev))))
-(def-debug-command "BOTTOM" ()
+(!def-debug-command "BOTTOM" ()
(do ((prev *current-frame* lead)
(lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead)))
((null lead)
(setf *current-frame* prev)
(print-frame-call prev))))
-(def-debug-command-alias "B" "BOTTOM")
+(!def-debug-command-alias "B" "BOTTOM")
-(def-debug-command "FRAME" (&optional
- (n (read-prompting-maybe "frame number: ")))
+(!def-debug-command "FRAME" (&optional
+ (n (read-prompting-maybe "frame number: ")))
(setf *current-frame*
(multiple-value-bind (next-frame-fun limit-string)
(if (< n (sb!di:frame-number *current-frame*))
(return frame)))))))
(print-frame-call *current-frame*))
-(def-debug-command-alias "F" "FRAME")
+(!def-debug-command-alias "F" "FRAME")
\f
;;;; commands for entering and leaving the debugger
-(def-debug-command "QUIT" ()
- (throw 'sb!impl::top-level-catcher nil))
+;;; CMU CL supported this QUIT debug command, but SBCL provides this
+;;; functionality with a restart instead. (The QUIT debug command was
+;;; removed because it's confusing to have "quit" mean two different
+;;; things in the system, "restart the top level REPL" in the debugger
+;;; and "terminate the Lisp system" as the SB-EXT:QUIT function.)
+;;;
+;;;(!def-debug-command "QUIT" ()
+;;; (throw 'sb!impl::top-level-catcher nil))
-(def-debug-command "GO" ()
- (continue *debug-condition*)
- (error "There is no restart named CONTINUE."))
+;;; 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).
-(def-debug-command "RESTART" ()
+;;;(!def-debug-command "GO" ()
+;;; (continue *debug-condition*)
+;;; (error "There is no restart named CONTINUE."))
+
+(!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*)))
\f
;;;; information commands
-(def-debug-command "HELP" ()
+(!def-debug-command "HELP" ()
;; CMU CL had a little toy pager here, but "if you aren't running
;; ILISP (or a smart windowing system, or something) you deserve to
;; lose", so we've dropped it in SBCL. However, in case some
;; desperate holdout is running this on a dumb terminal somewhere,
;; we tell him where to find the message stored as a string.
(format *debug-io*
- "~&~a~2%(The HELP string is stored in ~S.)~%"
+ "~&~A~2%(The HELP string is stored in ~S.)~%"
*debug-help-string*
'*debug-help-string*))
-(def-debug-command-alias "?" "HELP")
+(!def-debug-command-alias "?" "HELP")
-(def-debug-command "ERROR" ()
- (format t "~A~%" *debug-condition*)
- (show-restarts *debug-restarts*))
+(!def-debug-command "ERROR" ()
+ (format *debug-io* "~A~%" *debug-condition*)
+ (show-restarts *debug-restarts* *debug-io*))
-(def-debug-command "BACKTRACE" ()
+(!def-debug-command "BACKTRACE" ()
(backtrace (read-if-available most-positive-fixnum)))
-(def-debug-command "PRINT" ()
+(!def-debug-command "PRINT" ()
(print-frame-call *current-frame*))
-(def-debug-command-alias "P" "PRINT")
+(!def-debug-command-alias "P" "PRINT")
-(def-debug-command "LIST-LOCALS" ()
+(!def-debug-command "LIST-LOCALS" ()
(let ((d-fun (sb!di:frame-debug-function *current-frame*)))
(if (sb!di:debug-var-info-available d-fun)
(let ((*standard-output* *debug-io*)
prefix))))
(write-line "There is no variable information available."))))
-(def-debug-command-alias "L" "LIST-LOCALS")
+(!def-debug-command-alias "L" "LIST-LOCALS")
-(def-debug-command "SOURCE" ()
+(!def-debug-command "SOURCE" ()
(fresh-line)
(print-code-location-source-form (sb!di:frame-code-location *current-frame*)
(read-if-available 0)))
\f
;;;; source location printing
-;;; We cache a stream to the last valid file debug source so that we won't have
-;;; to repeatedly open the file.
+;;; We cache a stream to the last valid file debug source so that we
+;;; won't have to repeatedly open the file.
+;;;
;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
;;; in the 1990s, so the benefit is negligible, less important than the
;;; potential of extra confusion if someone changes the source during
*cached-readtable* nil))
sb!int:*before-save-initializations*)
-;;; We also cache the last top-level form that we printed a source for so that
-;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS.
+;;; We also cache the last top-level form that we printed a source for
+;;; so that we don't have to do repeated reads and calls to
+;;; FORM-NUMBER-TRANSLATIONS.
(defvar *cached-top-level-form-offset* nil)
(declaim (type (or index null) *cached-top-level-form-offset*))
(defvar *cached-top-level-form*)
(defvar *cached-form-number-translations*)
-;;; Given a code location, return the associated form-number translations and
-;;; the actual top-level form. We check our cache --- if there is a miss, we
-;;; dispatch on the kind of the debug source.
+;;; Given a code location, return the associated form-number
+;;; translations and the actual top-level form. We check our cache ---
+;;; if there is a miss, we dispatch on the kind of the debug source.
(defun get-top-level-form (location)
(let ((d-source (sb!di:code-location-debug-source location)))
(if (and (eq d-source *cached-debug-source*)
(sb!di:form-number-translations res offset))
(setq *cached-top-level-form* res))))))
-;;; Locates the source file (if it still exists) and grabs the top-level form.
-;;; If the file is modified, we use the top-level-form offset instead of the
-;;; recorded character offset.
+;;; Locate the source file (if it still exists) and grab the top-level
+;;; form. If the file is modified, we use the top-level-form offset
+;;; instead of the recorded character offset.
(defun get-file-top-level-form (location)
(let* ((d-source (sb!di:code-location-debug-source location))
(tlf-offset (sb!di:code-location-top-level-form-offset location))
;;; breakpoint and step commands
;;; Step to the next code-location.
-(def-debug-command "STEP" ()
+(!def-debug-command "STEP" ()
(setf *number-of-steps* (read-if-available 1))
(set-step-breakpoint *current-frame*)
(continue *debug-condition*)
(error "couldn't continue"))
-;;; List possible breakpoint locations, which ones are active, and where GO
-;;; will continue. Set *POSSIBLE-BREAKPOINTS* to the code-locations which can
-;;; then be used by sbreakpoint.
-(def-debug-command "LIST-LOCATIONS" ()
+;;; List possible breakpoint locations, which ones are active, and
+;;; where the CONTINUE restart will transfer control. Set
+;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be
+;;; used by sbreakpoint.
+(!def-debug-command "LIST-LOCATIONS" ()
(let ((df (read-if-available *default-breakpoint-debug-function*)))
(cond ((consp df)
(setf df (sb!di:function-debug-function (eval df)))
:function-end)
(format t "~&::FUNCTION-END *Active* "))))
-(def-debug-command-alias "LL" "LIST-LOCATIONS")
+(!def-debug-command-alias "LL" "LIST-LOCATIONS")
;;; Set breakpoint at the given number.
-(def-debug-command "BREAKPOINT" ()
+(!def-debug-command "BREAKPOINT" ()
(let ((index (read-prompting-maybe "location number, :START, or :END: "))
(break t)
(condition t)
(print-breakpoint-info (first *breakpoints*))
(format t "~&added"))))
-(def-debug-command-alias "BP" "BREAKPOINT")
+(!def-debug-command-alias "BP" "BREAKPOINT")
;;; List all breakpoints which are set.
-(def-debug-command "LIST-BREAKPOINTS" ()
+(!def-debug-command "LIST-BREAKPOINTS" ()
(setf *breakpoints*
(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
(dolist (info *breakpoints*)
(print-breakpoint-info info)))
-(def-debug-command-alias "LB" "LIST-BREAKPOINTS")
-(def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
+(!def-debug-command-alias "LB" "LIST-BREAKPOINTS")
+(!def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
;;; Remove breakpoint N, or remove all breakpoints if no N given.
-(def-debug-command "DELETE-BREAKPOINT" ()
+(!def-debug-command "DELETE-BREAKPOINT" ()
(let* ((index (read-if-available nil))
(bp-info
(find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
(setf *breakpoints* nil)
(format t "all breakpoints deleted~%")))))
-(def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
+(!def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
\f
;;; miscellaneous commands
-(def-debug-command "DESCRIBE" ()
+(!def-debug-command "DESCRIBE" ()
(let* ((curloc (sb!di:frame-code-location *current-frame*))
(debug-fun (sb!di:code-location-debug-function curloc))
(function (sb!di:debug-function-function debug-fun)))