#!+sb-doc
"This is T while in the debugger.")
-(defvar *debug-command-level* 0
- #!+sb-doc
- "Pushes and pops/exits inside the debugger change this.")
+;;; nestedness inside debugger command loops
+(defvar *debug-command-level* 0)
(defvar *stack-top-hint* nil
#!+sb-doc
(defvar *current-frame* nil)
-;;; the default for *DEBUG-PROMPT*
-(defun debug-prompt ()
- (let ((*standard-output* *debug-io*))
- (terpri)
- (prin1 (sb!di:frame-number *current-frame*))
- (dotimes (i *debug-command-level*) (princ "]"))
- (princ " ")
- (force-output)))
-
-(defparameter *debug-prompt* #'debug-prompt
- #!+sb-doc
- "a function of no arguments that prints the debugger prompt on *DEBUG-IO*")
-
+(defun debug-prompt (stream)
+
+ ;; old behavior, will probably go away in sbcl-0.7.x
+ (format stream "~%~D" (sb!di:frame-number *current-frame*))
+ (dotimes (i *debug-command-level*)
+ (write-char #\] stream))
+ (write-char #\space stream)
+
+ ;; planned new behavior, delayed since it will break ILISP
+ #+nil
+ (format stream
+ "~%~D~:[~;[~D~]] "
+ (sb!di:frame-number *current-frame*)
+ (> *debug-command-level* 1)
+ *debug-command-level*))
+
(defparameter *debug-help-string*
"The prompt is right square brackets, the number indicating how many
recursive command loops you are in.
s)))))
string)
-;;; Print frame with verbosity level 1. If we hit a rest-arg, then
+;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
;;; print as many of the values as possible, punting the loop over
;;; lambda-list variables since any other arguments will be in the
-;;; rest-arg's list of values.
+;;; &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*)) ; protected 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 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,
(*print-readably* nil)
(*print-pretty* t)
(*package* original-package))
- #!+sb-show (sb!conditions::show-condition *debug-condition*
- *error-output*)
+
+ ;; 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.
(format *error-output*
- "~2&debugger invoked on ~S of type ~S:~% "
- '*debug-condition*
+ "~2&debugger invoked on condition of type ~S:~% "
(type-of *debug-condition*))
(princ-debug-condition-carefully *error-output*)
(terpri *error-output*)
- (let (;; FIXME: like the bindings of *STANDARD-INPUT* and
- ;; *STANDARD-OUTPUT* above..
+
+ ;; After the initial error/condition/whatever announcement to
+ ;; *ERROR-OUTPUT*, we become interactive, and should talk on
+ ;; *DEBUG-IO* from now on. (KLUDGE: This is a normative
+ ;; statement, not a description of reality.:-| There's a lot of
+ ;; older debugger code which was written to do i/o on whatever
+ ;; stream was in fashion at the time, and not all of it has
+ ;; been converted to behave this way. -- WHN 2000-11-16)
+ (let (;; FIXME: The first two bindings here seem wrong,
+ ;; violating the principle of least surprise, and making
+ ;; it impossible for the user to do reasonable things
+ ;; like using PRINT at the debugger prompt to send output
+ ;; to the program's ordinary (possibly
+ ;; redirected-to-a-file) *STANDARD-OUTPUT*, or using
+ ;; PEEK-CHAR or some such thing on the program's ordinary
+ ;; (possibly also redirected) *STANDARD-INPUT*.
+ (*standard-input* *debug-io*)
+ (*standard-output* *debug-io*)
+ ;; This seems reasonable: e.g. if the user has redirected
+ ;; *ERROR-OUTPUT* to some log file, it's probably wrong
+ ;; to send errors which occur in interactive debugging to
+ ;; that file, and right to send them to *DEBUG-IO*.
(*error-output* *debug-io*))
(unless (typep condition 'step-condition)
- (show-restarts *debug-restarts* *error-output*))
+ (format *debug-io*
+ "~%~@<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.~:@>~2%"
+ '*debug-condition*)
+ (show-restarts *debug-restarts* *debug-io*)
+ (terpri *debug-io*))
(internal-debug))))))
-(defun show-restarts (restarts &optional (s *error-output*))
+(defun show-restarts (restarts s)
(when restarts
(format s "~&restarts:~%")
(let ((count 0)
(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 (abort
"Reduce debugger level (to debug level ~D)."
level)
- (funcall *debug-prompt*)
+ (debug-prompt *debug-io*)
+ (force-output *debug-io*)
(let ((input (sb!int:get-stream-command *debug-io*)))
(cond (input
(let ((cmd-fun (debug-command-p
(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
(: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
(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)
(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*)))
(def-debug-command-alias "?" "HELP")
(def-debug-command "ERROR" ()
- (format t "~A~%" *debug-condition*)
- (show-restarts *debug-restarts*))
+ (format *debug-io* "~A~%" *debug-condition*)
+ (show-restarts *debug-restarts* *debug-io*))
(def-debug-command "BACKTRACE" ()
(backtrace (read-if-available most-positive-fixnum)))
\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))
projects / sbcl.git / blobdiff