(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
(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
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.
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.
- (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))
(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
(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
- (funcall old-hook condition old-hook))))
-
- ;; Note: CMU CL had (SB-UNIX:UNIX-SIGSETMASK 0) here, to reset the
- ;; signal state in the case that we wind up in the debugger as a
- ;; result of something done by a signal handler. It's not
- ;; altogether obvious that this is necessary, and indeed SBCL has
- ;; not been doing it since 0.7.8.5. But nobody seems altogether
- ;; convinced yet
- ;; -- dan 2003.11.11, based on earlier comment of WHN 2002-09-28
+ (funcall old-hook condition old-hook))))
+ (let ((old-hook *debugger-hook*))
+ (when old-hook
+ (let ((*debugger-hook* nil))
+ (funcall old-hook condition old-hook))))
+(defun %print-debugger-invocation-reason (condition stream)
+ (format stream "~2&")
+ ;; Note: Ordinarily it's only a matter of taste whether to use
+ ;; FORMAT "~<...~:>" or to use PPRINT-LOGICAL-BLOCK directly, but
+ ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is
+ ;; definitely preferred, because the FORMAT alternative was acting odd.
+ (pprint-logical-block (stream nil)
+ (format stream
+ "debugger invoked on a ~S~@[ in thread ~A~]: ~2I~_~A"
+ (type-of condition)
+ #!+sb-thread sb!thread:*current-thread*
+ #!-sb-thread nil
+ condition))
+ (terpri stream))
+
- ;; (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*)
- (sb!thread:current-thread-id)
- *debug-condition*)
+ ;; (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.)
+ (%print-debugger-invocation-reason condition *error-output*)
- 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 *nested-debug-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~%"
+ '*nested-debug-condition*
+ (cell-error-name *nested-debug-condition*)))))
;; 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
;; 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 ~
- (progn
- (format *error-output*
- "~&~@<unhandled ~S in thread ~S: ~2I~_~A~:>~2%"
- (type-of condition)
- (sb!thread:current-thread-id)
- 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))
+ (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))
- ;; 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.
- ;; 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).
- (when (eql *invoke-debugger-hook* nil)
- (setf *debug-io* *error-output*
- *invoke-debugger-hook* 'debugger-disabled-hook)))
+ ;; *DEBUG-IO* used to be set here to *ERROR-OUTPUT* which is sort
+ ;; of unexpected but mostly harmless, but then ENABLE-DEBUGGER had
+ ;; to set it to a suitable value again and be very careful,
+ ;; especially if the user has also set it. -- MG 2005-07-15
+ (unless (eq *invoke-debugger-hook* 'debugger-disabled-hook)
+ (setf *old-debugger-hook* *invoke-debugger-hook*
+ *invoke-debugger-hook* 'debugger-disabled-hook))
+ ;; This is not inside the UNLESS to ensure that LDB is disabled
+ ;; regardless of what the old value of *INVOKE-DEBUGGER-HOOK* was.
+ ;; This might matter for example when restoring a core.
+ (sb!alien:alien-funcall (sb!alien:extern-alien "disable_lossage_handler"
+ (function sb!alien:void))))
- (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))))))
- (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 ~
- '*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))))))))))))
+ '*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)))
+ (flush-standard-output-streams)
+ (debug-prompt *debug-io*)
+ (force-output *debug-io*)
+ (let* ((exp (debug-read *debug-io*))
+ (cmd-fun (debug-command-p exp restart-commands)))
+ (with-simple-restart (abort
+ "~@<Reduce debugger level (to debug level ~W).~@:>"
+ level)
+ (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))))))))))))
- (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)))
- (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)))))))))
- :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")))))
- (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))))))))
- (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)))))))
- (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.~%"
- (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*
- (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))
;;; 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)))
- (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)))