;;; * 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
+;;; ARG-COUNT-ERROR printed as
;;; error while parsing arguments to DESTRUCTURING-BIND:
;;; invalid number of elements in
;;; #
(defun debug-prompt (stream)
(sb!thread::get-foreground)
(format stream
- "~%~W~:[~;[~W~]] "
- (sb!di:frame-number *current-frame*)
- (> *debug-command-level* 1)
- *debug-command-level*))
-
+ "~%~W~:[~;[~W~]] "
+ (sb!di:frame-number *current-frame*)
+ (> *debug-command-level* 1)
+ *debug-command-level*))
+
(defparameter *debug-help-string*
"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
+ to defaults (much like WITH-STANDARD-IO-SYNTAX does) and sometimes to
its own special values, based on SB-EXT:*DEBUG-PRINT-VARIABLE-ALIST*.
Debug commands do not affect *, //, and similar variables, but evaluation in
the debug loop does affect these variables.
SOURCE [n] displays frame's source form with n levels of enclosing forms.
Stepping:
- STEP Selects the CONTINUE restart if one exists and starts
+ STEP Selects the CONTINUE restart if one exists and starts
single-stepping. Single stepping affects only code compiled with
under high DEBUG optimization quality. See User Manual for details.
(defun maybe-block-start-location (loc)
(if (sb!di:code-location-unknown-p loc)
(let* ((block (sb!di:code-location-debug-block loc))
- (start (sb!di:do-debug-block-locations (loc block)
- (return loc))))
- (cond ((and (not (sb!di:debug-block-elsewhere-p block))
- start)
- (format *debug-io* "~%unknown location: using block start~%")
- start)
- (t
- loc)))
+ (start (sb!di:do-debug-block-locations (loc block)
+ (return loc))))
+ (cond ((and (not (sb!di:debug-block-elsewhere-p block))
+ start)
+ (format *debug-io* "~%unknown location: using block start~%")
+ start)
+ (t
+ loc)))
loc))
\f
;;;; BACKTRACE
is how many frames to show."
(fresh-line stream)
(do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
- (sb!di:frame-down frame))
+ (sb!di:frame-down frame))
(count count (1- count)))
((or (null frame) (zerop count)))
(print-frame-call frame stream :number t))
#!+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))
+ (sb!di:frame-down frame))
(count count (1- count)))
((or (null frame) (zerop count))
(nreverse reversed-result))
;;; 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
- optional
- rest
- keyword
- deleted)
+ &key
+ required
+ optional
+ rest
+ keyword
+ deleted)
`(etypecase ,element
(sb!di:debug-var
,@required)
(cons
(ecase (car ,element)
- (:optional ,@optional)
- (:rest ,@rest)
- (:keyword ,@keyword)))
+ (:optional ,@optional)
+ (:rest ,@rest)
+ (:keyword ,@keyword)))
(symbol
(aver (eq ,element :deleted))
,@deleted)))
(let ((var (gensym)))
`(let ((,var ,variable))
(cond ((eq ,var :deleted) ,deleted)
- ((eq (sb!di:debug-var-validity ,var ,location) :valid)
- ,valid)
- (t ,other)))))
+ ((eq (sb!di:debug-var-validity ,var ,location) :valid)
+ ,valid)
+ (t ,other)))))
) ; 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.
(defstruct (unprintable-object
- (:constructor make-unprintable-object (string))
- (:print-object (lambda (x s)
- (print-unreadable-object (x s)
- (write-string (unprintable-object-string x)
- s))))
- (:copier nil))
+ (:constructor make-unprintable-object (string))
+ (:print-object (lambda (x s)
+ (print-unreadable-object (x s)
+ (write-string (unprintable-object-string x)
+ s))))
+ (:copier nil))
string)
;;; 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))
+ (loc (sb!di:frame-code-location frame))
+ (reversed-result nil))
(handler-case
- (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 reversed-result
- (append (reverse (sb!di:debug-var-value
- (second ele) frame))
- reversed-result))
- (return))
- (push (make-unprintable-object
- "unavailable &REST argument")
- reversed-result)))))
- ;; As long as we do an ordinary return (as opposed to SIGNALing
- ;; a CONDITION) from the DOLIST above:
- (nreverse reversed-result))
+ (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 reversed-result
+ (append (reverse (sb!di:debug-var-value
+ (second ele) frame))
+ reversed-result))
+ (return))
+ (push (make-unprintable-object
+ "unavailable &REST argument")
+ 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
()
(make-unprintable-object "unavailable lambda list")))))
(defun clean-xep (name args)
(values (second name)
- (if (consp args)
- (let ((count (first args))
- (real-args (rest args)))
- (if (fixnump count)
- (subseq real-args 0
- (min count (length real-args)))
- real-args))
- args)))
+ (if (consp args)
+ (let ((count (first args))
+ (real-args (rest args)))
+ (if (fixnump count)
+ (subseq real-args 0
+ (min count (length real-args)))
+ real-args))
+ args)))
(defun clean-&more-processor (name args)
(values (second name)
- (if (consp args)
- (let* ((more (last args 2))
- (context (first more))
- (count (second more)))
- (append
- (butlast args 2)
- (if (fixnump count)
- (multiple-value-list
- (sb!c:%more-arg-values context 0 count))
- (list
- (make-unprintable-object "more unavailable arguments")))))
- args)))
+ (if (consp args)
+ (let* ((more (last args 2))
+ (context (first more))
+ (count (second more)))
+ (append
+ (butlast args 2)
+ (if (fixnump count)
+ (multiple-value-list
+ (sb!c:%more-arg-values context 0 count))
+ (list
+ (make-unprintable-object "more unavailable arguments")))))
+ args)))
(defun frame-call (frame)
(labels ((clean-name-and-args (name args)
(if (and (consp name) (not *show-entry-point-details*))
- ;; FIXME: do we need to deal with
- ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
- ;; &AUX-BINDINGS appear in backtraces, so they are
- ;; left alone for now. --NS 2005-02-28
+ ;; FIXME: do we need to deal with
+ ;; HAIRY-FUNCTION-ENTRY here? I can't make it or
+ ;; &AUX-BINDINGS appear in backtraces, so they are
+ ;; left alone for now. --NS 2005-02-28
(case (first name)
((sb!c::xep sb!c::tl-xep)
- (clean-xep name args))
+ (clean-xep name args))
((sb!c::&more-processor)
- (clean-&more-processor name args))
- ((sb!c::hairy-arg-processor
+ (clean-&more-processor name args))
+ ((sb!c::hairy-arg-processor
sb!c::varargs-entry sb!c::&optional-processor)
(clean-name-and-args (second name) args))
(t
(defun ensure-printable-object (object)
(handler-case
(with-open-stream (out (make-broadcast-stream))
- (prin1 object out)
- object)
+ (prin1 object out)
+ object)
(error (cond)
(declare (ignore cond))
(make-unprintable-object "error printing object"))))
(when (>= verbosity 2)
(let ((loc (sb!di:frame-code-location frame)))
(handler-case
- (progn
+ (progn
;; FIXME: Is this call really necessary here? If it is,
;; then the reason for it should be unobscured.
- (sb!di:code-location-debug-block loc)
- (format stream "~%source: ")
- (prin1 (code-location-source-form loc 0) stream))
- (sb!di:debug-condition (ignore)
+ (sb!di:code-location-debug-block loc)
+ (format stream "~%source: ")
+ (prin1 (code-location-source-form loc 0) stream))
+ (sb!di:debug-condition (ignore)
ignore)
- (error (c)
+ (error (c)
(format stream "~&error finding source: ~A" c))))))
\f
;;;; INVOKE-DEBUGGER
"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*
+ 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
(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*))
+ ;; 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
(with-sane-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 and
;; WITH-SANE-IO-SYNTAX do much of what we want, but
- ;; * It doesn't affect our internal special variables
+ ;; * It doesn't affect our internal special variables
;; like *CURRENT-LEVEL-IN-PRINT*.
;; * It isn't customizable.
;; * It sets *PACKAGE* to COMMON-LISP-USER, which is not
(let ((old-hook *debugger-hook*))
(when old-hook
(let ((*debugger-hook* nil))
- (funcall old-hook condition old-hook))))
+ (funcall old-hook condition old-hook))))
(let ((old-hook *invoke-debugger-hook*))
(when old-hook
(let ((*invoke-debugger-hook* nil))
- (funcall old-hook condition old-hook))))
+ (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
;; 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*))
+ (package-name *package*))
(setf *package* (find-package :cl-user))
(format *error-output*
- "The value of ~S was not an undeleted PACKAGE. It has been
+ "The value of ~S was not an undeleted PACKAGE. It has been
reset to ~S."
- '*package* *package*))
+ '*package* *package*))
;; Before we start our own output, finish any pending output.
;; Otherwise, if the user tried to track the progress of his program
(funcall-with-debug-io-syntax #'%invoke-debugger condition))
(defun %invoke-debugger (condition)
-
+
(let ((*debug-condition* condition)
- (*debug-restarts* (compute-restarts condition))
- (*nested-debug-condition* nil))
+ (*debug-restarts* (compute-restarts condition))
+ (*nested-debug-condition* nil))
(handler-case
- ;; (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 a ~S~@[ in thread ~A~]: ~
+ ;; (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 a ~S~@[ in thread ~A~]: ~
~2I~_~A~:>~%"
- (type-of *debug-condition*)
+ (type-of *debug-condition*)
#!+sb-thread sb!thread:*current-thread*
#!-sb-thread nil
- *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 ~
+ (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*)))))
+ 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*)))
+ *debug-io*)))
;; After the initial error/condition/whatever announcement to
;; *ERROR-OUTPUT*, we become interactive, and should talk on
;; been converted to behave this way. -- WHN 2000-11-16)
(unwind-protect
- (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO*
- ;; here as well, but that is probably bogus since it
+ (let (;; We used to bind *STANDARD-OUTPUT* to *DEBUG-IO*
+ ;; here as well, but that is probably bogus since it
;; removes the users ability to do output to a redirected
;; *S-O*. Now we just rebind it so that users can temporarily
;; frob it. FIXME: This and other "what gets bound when"
;; behaviour should be documented in the manual.
(*standard-output* *standard-output*)
;; 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*
- "~%~@<Type HELP for debugger help, or ~
+ ;; *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*
+ "~%~@<Type HELP for debugger help, or ~
(SB-EXT:QUIT) to exit from SBCL.~:@>~2%"))
- (show-restarts *debug-restarts* *debug-io*))
- (internal-debug))
- (when background-p
- (sb!thread::release-foreground))))))
+ (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"
;; 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)))
+ (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
;; can terminate cleanly even if BACKTRACE dies because of bugs in
;; user PRINT-OBJECT methods.
(handler-case
- (progn
- (format *error-output*
- "~&~@<unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
- (type-of condition)
+ (progn
+ (format *error-output*
+ "~&~@<unhandled ~S~@[ in thread ~S~]: ~2I~_~A~:>~2%"
+ (type-of condition)
#!+sb-thread sb!thread:*current-thread*
#!-sb-thread nil
- 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)
+ ;; 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.
+ ;; 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).
+ ;; 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
+ ;; 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)))))
+ "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)))
+ *invoke-debugger-hook* 'debugger-disabled-hook)))
(defun enable-debugger ()
(when (eql *invoke-debugger-hook* 'debugger-disabled-hook)
(defun show-restarts (restarts s)
(cond ((null restarts)
- (format s
- "~&(no restarts: If you didn't do this on purpose, ~
+ (format s
+ "~&(no restarts: If you didn't do this on purpose, ~
please report it as a bug.)~%"))
- (t
- (format s "~&restarts (invokable by number or by ~
+ (t
+ (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)))
- (when name
- (let ((len (length (princ-to-string name))))
- (when (> len max-name-len)
- (setf max-name-len len))))))
- (unless (zerop max-name-len)
- (incf max-name-len 3))
- (dolist (restart restarts)
- (let ((name (restart-name restart)))
- ;; FIXME: maybe it would be better to display later names
- ;; in parens instead of brakets, not just omit them fully.
- ;; Call BREAK, call BREAK in the debugger, and tell me
- ;; it's not confusing looking. --NS 20050310
- (cond ((member name names-used)
- (format s "~& ~2D: ~V@T~A~%" count max-name-len restart))
- (t
- (format s "~& ~2D: [~VA] ~A~%"
- count (- max-name-len 3) name restart)
- (push name names-used))))
- (incf count))))))
+ (let ((count 0)
+ (names-used '(nil))
+ (max-name-len 0))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ (when name
+ (let ((len (length (princ-to-string name))))
+ (when (> len max-name-len)
+ (setf max-name-len len))))))
+ (unless (zerop max-name-len)
+ (incf max-name-len 3))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ ;; FIXME: maybe it would be better to display later names
+ ;; in parens instead of brakets, not just omit them fully.
+ ;; Call BREAK, call BREAK in the debugger, and tell me
+ ;; it's not confusing looking. --NS 20050310
+ (cond ((member name names-used)
+ (format s "~& ~2D: ~V@T~A~%" count max-name-len restart))
+ (t
+ (format s "~& ~2D: [~VA] ~A~%"
+ count (- max-name-len 3) name restart)
+ (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")
;;; errors.
(defun internal-debug ()
(let ((*in-the-debugger* t)
- (*read-suppress* nil))
+ (*read-suppress* nil))
(unless (typep *debug-condition* 'step-condition)
(clear-input *debug-io*))
(funcall *debug-loop-fun*)))
(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*))
- (*stack-top-hint* nil)
- (*current-frame* *stack-top*))
+ (*real-stack-top* (sb!di:top-frame))
+ (*stack-top* (or *stack-top-hint* *real-stack-top*))
+ (*stack-top-hint* nil)
+ (*current-frame* *stack-top*))
(handler-bind ((sb!di:debug-condition
- (lambda (condition)
- (princ condition *debug-io*)
- (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
- (throw 'debug-loop-catcher nil))))
+ (lambda (condition)
+ (princ condition *debug-io*)
+ (/show0 "handling d-c by THROWing DEBUG-LOOP-CATCHER")
+ (throw 'debug-loop-catcher nil))))
(terpri *debug-io*)
(print-frame-call *current-frame* *debug-io* :verbosity 2)
(loop
- (catch 'debug-loop-catcher
- (handler-bind ((error (lambda (condition)
- (when *flush-debug-errors*
- (clear-input *debug-io*)
- (princ condition *debug-io*)
- (format *debug-io*
- "~&error flushed (because ~
+ (catch 'debug-loop-catcher
+ (handler-bind ((error (lambda (condition)
+ (when *flush-debug-errors*
+ (clear-input *debug-io*)
+ (princ condition *debug-io*)
+ (format *debug-io*
+ "~&error flushed (because ~
~S is set)"
- '*flush-debug-errors*)
- (/show0 "throwing DEBUG-LOOP-CATCHER")
- (throw 'debug-loop-catcher nil)))))
- ;; We have to bind LEVEL for the restart function created by
- ;; WITH-SIMPLE-RESTART.
- (let ((level *debug-command-level*)
- (restart-commands (make-restart-commands)))
- (with-simple-restart (abort
- "~@<Reduce debugger level (to debug level ~W).~@:>"
- level)
- (debug-prompt *debug-io*)
- (force-output *debug-io*)
- (let* ((exp (read *debug-io*))
- (cmd-fun (debug-command-p exp restart-commands)))
- (cond ((not cmd-fun)
- (debug-eval-print exp))
- ((consp cmd-fun)
- (format *debug-io*
+ '*flush-debug-errors*)
+ (/show0 "throwing DEBUG-LOOP-CATCHER")
+ (throw 'debug-loop-catcher nil)))))
+ ;; We have to bind LEVEL for the restart function created by
+ ;; WITH-SIMPLE-RESTART.
+ (let ((level *debug-command-level*)
+ (restart-commands (make-restart-commands)))
+ (with-simple-restart (abort
+ "~@<Reduce debugger level (to debug level ~W).~@:>"
+ level)
+ (debug-prompt *debug-io*)
+ (force-output *debug-io*)
+ (let* ((exp (read *debug-io*))
+ (cmd-fun (debug-command-p exp restart-commands)))
+ (cond ((not cmd-fun)
+ (debug-eval-print exp))
+ ((consp cmd-fun)
+ (format *debug-io*
"~&Your command, ~S, is ambiguous:~%"
- exp)
- (dolist (ele cmd-fun)
- (format *debug-io* " ~A~%" ele)))
- (t
- (funcall cmd-fun))))))))))))
+ exp)
+ (dolist (ele cmd-fun)
+ (format *debug-io* " ~A~%" ele)))
+ (t
+ (funcall cmd-fun))))))))))))
(defun debug-eval-print (expr)
(/noshow "entering DEBUG-EVAL-PRINT" expr)
(sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
`(let* ((temp (etypecase name
- (symbol (sb!di:debug-fun-symbol-vars
- (sb!di:frame-debug-fun *current-frame*)
- name))
- (simple-string (sb!di:ambiguous-debug-vars
- (sb!di:frame-debug-fun *current-frame*)
- name))))
- (location (sb!di:frame-code-location *current-frame*))
- ;; Let's only deal with valid variables.
- (vars (remove-if-not (lambda (v)
- (eq (sb!di:debug-var-validity v location)
- :valid))
- temp)))
+ (symbol (sb!di:debug-fun-symbol-vars
+ (sb!di:frame-debug-fun *current-frame*)
+ name))
+ (simple-string (sb!di:ambiguous-debug-vars
+ (sb!di:frame-debug-fun *current-frame*)
+ name))))
+ (location (sb!di:frame-code-location *current-frame*))
+ ;; Let's only deal with valid variables.
+ (vars (remove-if-not (lambda (v)
+ (eq (sb!di:debug-var-validity v location)
+ :valid))
+ temp)))
(declare (list vars))
(cond ((null vars)
- (error "No known valid variables match ~S." name))
- ((= (length vars) 1)
- ,(ecase ref-or-set
- (:ref
- '(sb!di:debug-var-value (car vars) *current-frame*))
- (:set
- `(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.
- (let* ((name (etypecase name
- (symbol (symbol-name name))
- (simple-string name)))
- ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/=
- ;; instead.
- (exact (remove-if-not (lambda (v)
- (string= (sb!di:debug-var-symbol-name v)
- name))
- vars))
- (vars (or exact vars)))
- (declare (simple-string name)
- (list exact vars))
- (cond
- ;; Check now for only having one variable.
- ((= (length vars) 1)
- ,(ecase ref-or-set
- (:ref
- '(sb!di:debug-var-value (car vars) *current-frame*))
- (: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.
- ((and (not exact)
- (find-if-not
- (lambda (v)
- (string= (sb!di:debug-var-symbol-name v)
- (sb!di:debug-var-symbol-name (car vars))))
- (cdr vars)))
- (error "specification ambiguous:~%~{ ~A~%~}"
- (mapcar #'sb!di:debug-var-symbol-name
- (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.
- (id-supplied
- (let ((v (find id vars :key #'sb!di:debug-var-id)))
- (unless v
- (error
- "invalid variable ID, ~W: should have been one of ~S"
- id
- (mapcar #'sb!di:debug-var-id vars)))
- ,(ecase ref-or-set
- (:ref
- '(sb!di:debug-var-value v *current-frame*))
- (:set
- `(setf (sb!di:debug-var-value v *current-frame*)
- ,value-var)))))
- (t
- (error "Specify variable ID to disambiguate ~S. Use one of ~S."
- name
- (mapcar #'sb!di:debug-var-id vars)))))))))
+ (error "No known valid variables match ~S." name))
+ ((= (length vars) 1)
+ ,(ecase ref-or-set
+ (:ref
+ '(sb!di:debug-var-value (car vars) *current-frame*))
+ (:set
+ `(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.
+ (let* ((name (etypecase name
+ (symbol (symbol-name name))
+ (simple-string name)))
+ ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/=
+ ;; instead.
+ (exact (remove-if-not (lambda (v)
+ (string= (sb!di:debug-var-symbol-name v)
+ name))
+ vars))
+ (vars (or exact vars)))
+ (declare (simple-string name)
+ (list exact vars))
+ (cond
+ ;; Check now for only having one variable.
+ ((= (length vars) 1)
+ ,(ecase ref-or-set
+ (:ref
+ '(sb!di:debug-var-value (car vars) *current-frame*))
+ (: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.
+ ((and (not exact)
+ (find-if-not
+ (lambda (v)
+ (string= (sb!di:debug-var-symbol-name v)
+ (sb!di:debug-var-symbol-name (car vars))))
+ (cdr vars)))
+ (error "specification ambiguous:~%~{ ~A~%~}"
+ (mapcar #'sb!di:debug-var-symbol-name
+ (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.
+ (id-supplied
+ (let ((v (find id vars :key #'sb!di:debug-var-id)))
+ (unless v
+ (error
+ "invalid variable ID, ~W: should have been one of ~S"
+ id
+ (mapcar #'sb!di:debug-var-id vars)))
+ ,(ecase ref-or-set
+ (:ref
+ '(sb!di:debug-var-value v *current-frame*))
+ (:set
+ `(setf (sb!di:debug-var-value v *current-frame*)
+ ,value-var)))))
+ (t
+ (error "Specify variable ID to disambiguate ~S. Use one of ~S."
+ name
+ (mapcar #'sb!di:debug-var-id vars)))))))))
) ; EVAL-WHEN
(defun nth-arg (count args)
(let ((n count))
(dolist (ele args (error "The argument specification ~S is out of range."
- n))
+ n))
(lambda-list-element-dispatch ele
- :required ((if (zerop n) (return (values ele t))))
- :optional ((if (zerop n) (return (values (second ele) t))))
- :keyword ((cond ((zerop n)
- (return (values (second ele) nil)))
- ((zerop (decf n))
- (return (values (third ele) t)))))
- :deleted ((if (zerop n) (return (values ele t))))
- :rest ((let ((var (second ele)))
- (lambda-var-dispatch var (sb!di:frame-code-location
- *current-frame*)
- (error "unused &REST argument before n'th argument")
- (dolist (value
- (sb!di:debug-var-value var *current-frame*)
- (error
- "The argument specification ~S is out of range."
- n))
- (if (zerop n)
- (return-from nth-arg (values value nil))
- (decf n)))
- (error "invalid &REST argument before n'th argument")))))
+ :required ((if (zerop n) (return (values ele t))))
+ :optional ((if (zerop n) (return (values (second ele) t))))
+ :keyword ((cond ((zerop n)
+ (return (values (second ele) nil)))
+ ((zerop (decf n))
+ (return (values (third ele) t)))))
+ :deleted ((if (zerop n) (return (values ele t))))
+ :rest ((let ((var (second ele)))
+ (lambda-var-dispatch var (sb!di:frame-code-location
+ *current-frame*)
+ (error "unused &REST argument before n'th argument")
+ (dolist (value
+ (sb!di:debug-var-value var *current-frame*)
+ (error
+ "The argument specification ~S is out of range."
+ n))
+ (if (zerop n)
+ (return-from nth-arg (values value nil))
+ (decf n)))
+ (error "invalid &REST argument before n'th argument")))))
(decf n))))
(defun arg (n)
pairs as separate arguments."
(multiple-value-bind (var lambda-var-p)
(nth-arg n (handler-case (sb!di:debug-fun-lambda-list
- (sb!di:frame-debug-fun *current-frame*))
- (sb!di:lambda-list-unavailable ()
- (error "No argument values are available."))))
+ (sb!di:frame-debug-fun *current-frame*))
+ (sb!di:lambda-list-unavailable ()
+ (error "No argument values are available."))))
(if lambda-var-p
- (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*)
- (error "Unused arguments have no values.")
- (sb!di:debug-var-value var *current-frame*)
- (error "invalid argument value"))
- var)))
+ (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*)
+ (error "Unused arguments have no values.")
+ (sb!di:debug-var-value var *current-frame*)
+ (error "invalid argument value"))
+ var)))
\f
;;;; machinery for definition of debug loop commands
(let ((fun-name (symbolicate name "-DEBUG-COMMAND")))
`(progn
(setf *debug-commands*
- (remove ,name *debug-commands* :key #'car :test #'string=))
+ (remove ,name *debug-commands* :key #'car :test #'string=))
(defun ,fun-name ,args
- (unless *in-the-debugger*
- (error "invoking debugger command while outside the debugger"))
- ,@body)
+ (unless *in-the-debugger*
+ (error "invoking debugger command while outside the debugger"))
+ ,@body)
(push (cons ,name #',fun-name) *debug-commands*)
',fun-name)))
(defun debug-command-p (form &optional other-commands)
(if (or (symbolp form) (integerp form))
(let* ((name
- (if (symbolp form)
- (symbol-name form)
- (format nil "~W" form)))
- (len (length name))
- (res nil))
- (declare (simple-string name)
- (fixnum len)
- (list res))
-
- ;; Find matching commands, punting if exact match.
- (flet ((match-command (ele)
- (let* ((str (car ele))
- (str-len (length str)))
- (declare (simple-string str)
- (fixnum str-len))
- (cond ((< str-len len))
- ((= str-len len)
- (when (string= name str :end1 len :end2 len)
- (return-from debug-command-p (cdr ele))))
- ((string= name str :end1 len :end2 len)
- (push ele res))))))
- (mapc #'match-command *debug-commands*)
- (mapc #'match-command other-commands))
-
- ;; Return the right value.
- (cond ((not res) nil)
- ((= (length res) 1)
- (cdar res))
- (t ; Just return the names.
- (do ((cmds res (cdr cmds)))
- ((not cmds) res)
- (setf (car cmds) (caar cmds))))))))
+ (if (symbolp form)
+ (symbol-name form)
+ (format nil "~W" form)))
+ (len (length name))
+ (res nil))
+ (declare (simple-string name)
+ (fixnum len)
+ (list res))
+
+ ;; Find matching commands, punting if exact match.
+ (flet ((match-command (ele)
+ (let* ((str (car ele))
+ (str-len (length str)))
+ (declare (simple-string str)
+ (fixnum str-len))
+ (cond ((< str-len len))
+ ((= str-len len)
+ (when (string= name str :end1 len :end2 len)
+ (return-from debug-command-p (cdr ele))))
+ ((string= name str :end1 len :end2 len)
+ (push ele res))))))
+ (mapc #'match-command *debug-commands*)
+ (mapc #'match-command other-commands))
+
+ ;; Return the right value.
+ (cond ((not res) nil)
+ ((= (length res) 1)
+ (cdar res))
+ (t ; Just return the names.
+ (do ((cmds res (cdr cmds)))
+ ((not cmds) res)
+ (setf (car cmds) (caar cmds))))))))
;;; Return a list of debug commands (in the same format as
;;; *DEBUG-COMMANDS*) that invoke each active restart.
;;; 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!
+ (num 0)) ; better be the same as show-restarts!
(dolist (restart restarts)
(let ((name (string (restart-name restart))))
(let ((restart-fun
(lambda ()
- (/show0 "in restart-command closure, about to i-r-i")
- (invoke-restart-interactively restart))))
+ (/show0 "in restart-command closure, about to i-r-i")
+ (invoke-restart-interactively restart))))
(push (cons (prin1-to-string num) restart-fun) commands)
- (unless (or (null (restart-name restart))
+ (unless (or (null (restart-name restart))
(find name commands :key #'car :test #'string=))
(push (cons name restart-fun) commands))))
(incf num))
(!def-debug-command "UP" ()
(let ((next (sb!di:frame-up *current-frame*)))
(cond (next
- (setf *current-frame* next)
- (print-frame-call next *debug-io*))
- (t
- (format *debug-io* "~&Top of stack.")))))
+ (setf *current-frame* next)
+ (print-frame-call next *debug-io*))
+ (t
+ (format *debug-io* "~&Top of stack.")))))
(!def-debug-command "DOWN" ()
(let ((next (sb!di:frame-down *current-frame*)))
(cond (next
- (setf *current-frame* next)
- (print-frame-call next *debug-io*))
- (t
- (format *debug-io* "~&Bottom of stack.")))))
+ (setf *current-frame* next)
+ (print-frame-call next *debug-io*))
+ (t
+ (format *debug-io* "~&Bottom of stack.")))))
(!def-debug-command-alias "D" "DOWN")
(!def-debug-command-alias "B" "BOTTOM")
(!def-debug-command "FRAME" (&optional
- (n (read-prompting-maybe "frame number: ")))
+ (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*))
- (values #'sb!di:frame-up "top")
- (values #'sb!di:frame-down "bottom"))
- (do ((frame *current-frame*))
- ((= n (sb!di:frame-number frame))
- frame)
- (let ((next-frame (funcall next-frame-fun frame)))
- (cond (next-frame
- (setf frame next-frame))
- (t
- (format *debug-io*
- "The ~A of the stack was encountered.~%"
- limit-string)
- (return frame)))))))
+ (multiple-value-bind (next-frame-fun limit-string)
+ (if (< n (sb!di:frame-number *current-frame*))
+ (values #'sb!di:frame-up "top")
+ (values #'sb!di:frame-down "bottom"))
+ (do ((frame *current-frame*))
+ ((= n (sb!di:frame-number frame))
+ frame)
+ (let ((next-frame (funcall next-frame-fun frame)))
+ (cond (next-frame
+ (setf frame next-frame))
+ (t
+ (format *debug-io*
+ "The ~A of the stack was encountered.~%"
+ limit-string)
+ (return frame)))))))
(print-frame-call *current-frame* *debug-io*))
(!def-debug-command-alias "F" "FRAME")
(force-output)
(setf num (read *debug-io*)))
(let ((restart (typecase num
- (unsigned-byte
- (nth num *debug-restarts*))
- (symbol
- (find num *debug-restarts* :key #'restart-name
- :test (lambda (sym1 sym2)
- (string= (symbol-name sym1)
- (symbol-name sym2)))))
- (t
- (format *debug-io* "~S is invalid as a restart name.~%"
+ (unsigned-byte
+ (nth num *debug-restarts*))
+ (symbol
+ (find num *debug-restarts* :key #'restart-name
+ :test (lambda (sym1 sym2)
+ (string= (symbol-name sym1)
+ (symbol-name sym2)))))
+ (t
+ (format *debug-io* "~S is invalid as a restart name.~%"
num)
- (return-from restart-debug-command nil)))))
+ (return-from restart-debug-command nil)))))
(/show0 "got RESTART")
(if restart
- (invoke-restart-interactively restart)
- (princ "There is no such restart." *debug-io*)))))
+ (invoke-restart-interactively restart)
+ (princ "There is no such restart." *debug-io*)))))
\f
;;;; information commands
;; 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.)~%"
- *debug-help-string*
- '*debug-help-string*))
+ "~&~A~2%(The HELP string is stored in ~S.)~%"
+ *debug-help-string*
+ '*debug-help-string*))
(!def-debug-command-alias "?" "HELP")
(!def-debug-command "LIST-LOCALS" ()
(let ((d-fun (sb!di:frame-debug-fun *current-frame*)))
(if (sb!di:debug-var-info-available d-fun)
- (let ((*standard-output* *debug-io*)
- (location (sb!di:frame-code-location *current-frame*))
- (prefix (read-if-available nil))
- (any-p nil)
- (any-valid-p nil))
- (dolist (v (sb!di:ambiguous-debug-vars
- d-fun
- (if prefix (string prefix) "")))
- (setf any-p t)
- (when (eq (sb!di:debug-var-validity v location) :valid)
- (setf any-valid-p t)
- (format *debug-io* "~S~:[#~W~;~*~] = ~S~%"
- (sb!di:debug-var-symbol v)
- (zerop (sb!di:debug-var-id v))
- (sb!di:debug-var-id v)
- (sb!di:debug-var-value v *current-frame*))))
-
- (cond
- ((not any-p)
- (format *debug-io*
+ (let ((*standard-output* *debug-io*)
+ (location (sb!di:frame-code-location *current-frame*))
+ (prefix (read-if-available nil))
+ (any-p nil)
+ (any-valid-p nil))
+ (dolist (v (sb!di:ambiguous-debug-vars
+ d-fun
+ (if prefix (string prefix) "")))
+ (setf any-p t)
+ (when (eq (sb!di:debug-var-validity v location) :valid)
+ (setf any-valid-p t)
+ (format *debug-io* "~S~:[#~W~;~*~] = ~S~%"
+ (sb!di:debug-var-symbol v)
+ (zerop (sb!di:debug-var-id v))
+ (sb!di:debug-var-id v)
+ (sb!di:debug-var-value v *current-frame*))))
+
+ (cond
+ ((not any-p)
+ (format *debug-io*
"There are no local variables ~@[starting with ~A ~]~
in the function."
- prefix))
- ((not any-valid-p)
- (format *debug-io*
+ prefix))
+ ((not any-valid-p)
+ (format *debug-io*
"All variables ~@[starting with ~A ~]currently ~
have invalid values."
- prefix))))
- (write-line "There is no variable information available."
+ prefix))))
+ (write-line "There is no variable information available."
*debug-io*))))
(!def-debug-command-alias "L" "LIST-LOCALS")
;;; Stuff to clean up before saving a core
(defun debug-deinit ()
(setf *cached-debug-source* nil
- *cached-source-stream* nil
- *cached-readtable* nil))
+ *cached-source-stream* nil
+ *cached-readtable* nil))
;;; We also cache the last toplevel form that we printed a source for
;;; so that we don't have to do repeated reads and calls to
(defun get-toplevel-form (location)
(let ((d-source (sb!di:code-location-debug-source location)))
(if (and (eq d-source *cached-debug-source*)
- (eql (sb!di:code-location-toplevel-form-offset location)
- *cached-toplevel-form-offset*))
- (values *cached-form-number-translations* *cached-toplevel-form*)
- (let* ((offset (sb!di:code-location-toplevel-form-offset location))
- (res
- (ecase (sb!di:debug-source-from d-source)
- (:file (get-file-toplevel-form location))
- (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
- (setq *cached-toplevel-form-offset* offset)
- (values (setq *cached-form-number-translations*
- (sb!di:form-number-translations res offset))
- (setq *cached-toplevel-form* res))))))
+ (eql (sb!di:code-location-toplevel-form-offset location)
+ *cached-toplevel-form-offset*))
+ (values *cached-form-number-translations* *cached-toplevel-form*)
+ (let* ((offset (sb!di:code-location-toplevel-form-offset location))
+ (res
+ (ecase (sb!di:debug-source-from d-source)
+ (:file (get-file-toplevel-form location))
+ (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
+ (setq *cached-toplevel-form-offset* offset)
+ (values (setq *cached-form-number-translations*
+ (sb!di:form-number-translations res offset))
+ (setq *cached-toplevel-form* res))))))
;;; 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-toplevel-form (location)
(let* ((d-source (sb!di:code-location-debug-source location))
- (tlf-offset (sb!di:code-location-toplevel-form-offset location))
- (local-tlf-offset (- tlf-offset
- (sb!di:debug-source-root-number d-source)))
- (char-offset
- (aref (or (sb!di:debug-source-start-positions d-source)
- (error "no start positions map"))
- local-tlf-offset))
- (name (sb!di:debug-source-name d-source)))
+ (tlf-offset (sb!di:code-location-toplevel-form-offset location))
+ (local-tlf-offset (- tlf-offset
+ (sb!di:debug-source-root-number d-source)))
+ (char-offset
+ (aref (or (sb!di:debug-source-start-positions d-source)
+ (error "no start positions map"))
+ local-tlf-offset))
+ (name (sb!di:debug-source-name d-source)))
(unless (eq d-source *cached-debug-source*)
(unless (and *cached-source-stream*
- (equal (pathname *cached-source-stream*)
- (pathname name)))
- (setq *cached-readtable* nil)
- (when *cached-source-stream* (close *cached-source-stream*))
- (setq *cached-source-stream* (open name :if-does-not-exist nil))
- (unless *cached-source-stream*
- (error "The source file no longer exists:~% ~A" (namestring name)))
- (format *debug-io* "~%; file: ~A~%" (namestring name)))
-
- (setq *cached-debug-source*
- (if (= (sb!di:debug-source-created d-source)
- (file-write-date name))
- d-source nil)))
+ (equal (pathname *cached-source-stream*)
+ (pathname name)))
+ (setq *cached-readtable* nil)
+ (when *cached-source-stream* (close *cached-source-stream*))
+ (setq *cached-source-stream* (open name :if-does-not-exist nil))
+ (unless *cached-source-stream*
+ (error "The source file no longer exists:~% ~A" (namestring name)))
+ (format *debug-io* "~%; file: ~A~%" (namestring name)))
+
+ (setq *cached-debug-source*
+ (if (= (sb!di:debug-source-created d-source)
+ (file-write-date name))
+ d-source nil)))
(cond
((eq *cached-debug-source* d-source)
(format *debug-io*
"~%; File has been modified since compilation:~%; ~A~@
; Using form offset instead of character position.~%"
- (namestring name))
+ (namestring name))
(file-position *cached-source-stream* 0)
(let ((*read-suppress* t))
- (dotimes (i local-tlf-offset)
- (read *cached-source-stream*)))))
+ (dotimes (i local-tlf-offset)
+ (read *cached-source-stream*)))))
(unless *cached-readtable*
(setq *cached-readtable* (copy-readtable))
(set-dispatch-macro-character
#\# #\.
(lambda (stream sub-char &rest rest)
- (declare (ignore rest sub-char))
- (let ((token (read stream t nil t)))
- (format nil "#.~S" token)))
+ (declare (ignore rest sub-char))
+ (let ((token (read stream t nil t)))
+ (format nil "#.~S" token)))
*cached-readtable*))
(let ((*readtable* *cached-readtable*))
(read *cached-source-stream*))))
(defun code-location-source-form (location context)
(let* ((location (maybe-block-start-location location))
- (form-num (sb!di:code-location-form-number location)))
+ (form-num (sb!di:code-location-form-number location)))
(multiple-value-bind (translations form) (get-toplevel-form location)
(unless (< form-num (length translations))
- (error "The source path no longer exists."))
+ (error "The source path no longer exists."))
(sb!di:source-path-context form
(svref translations form-num)
context))))
(!def-debug-command "STEP" ()
(let ((restart (find-restart 'continue *debug-condition*)))
(cond (restart
- (setf *stepping* t
- *step* t)
- (invoke-restart restart))
- (t
- (format *debug-io* "~&Non-continuable error, cannot step.~%")))))
+ (setf *stepping* t
+ *step* t)
+ (invoke-restart restart))
+ (t
+ (format *debug-io* "~&Non-continuable error, cannot step.~%")))))
;;; miscellaneous commands
(!def-debug-command "DESCRIBE" ()
(let* ((curloc (sb!di:frame-code-location *current-frame*))
- (debug-fun (sb!di:code-location-debug-fun curloc))
- (function (sb!di:debug-fun-fun debug-fun)))
+ (debug-fun (sb!di:code-location-debug-fun curloc))
+ (function (sb!di:debug-fun-fun debug-fun)))
(if function
- (describe function)
- (format *debug-io* "can't figure out the function for this frame"))))
+ (describe function)
+ (format *debug-io* "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: ")))
+ (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*))))
+ (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 *debug-io*
+ (throw (car tag)
+ (funcall (sb!di:preprocess-for-eval
+ return
+ (sb!di:frame-code-location *current-frame*))
+ *current-frame*))
+ (format *debug-io*
"~@<can't find a tag for this frame ~
~2I~_(hint: try increasing the DEBUG optimization quality ~
and recompiling)~:@>"))))
projects / sbcl.git / blobdiff