\f
;;;; variables and constants
-(defvar *debug-print-level* 3
+;;; things to consider when tweaking these values:
+;;; * We're afraid to just default them to NIL and NIL, in case the
+;;; user inadvertently causes a hairy data structure to be printed
+;;; when he inadvertently enters the debugger.
+;;; * We don't want to truncate output too much. These days anyone
+;;; can easily run their Lisp in a windowing system or under Emacs,
+;;; so it's not the end of the world even if the worst case is a
+;;; few thousand lines of output.
+;;; * As condition :REPORT methods are converted to use the pretty
+;;; printer, they acquire *PRINT-LEVEL* constraints, so e.g. under
+;;; sbcl-0.7.1.28's old value of *DEBUG-PRINT-LEVEL*=3, an
+;;; ARG-COUNT-ERROR printed as
+;;; error while parsing arguments to DESTRUCTURING-BIND:
+;;; invalid number of elements in
+;;; #
+;;; to satisfy lambda list
+;;; #:
+;;; exactly 2 expected, but 5 found
+(defvar *debug-print-level* 5
#!+sb-doc
"*PRINT-LEVEL* for the debugger")
-
-(defvar *debug-print-length* 5
+(defvar *debug-print-length* 7
#!+sb-doc
"*PRINT-LENGTH* for the debugger")
"Should the debugger display beginner-oriented help messages?")
(defun debug-prompt (stream)
-
- ;; 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~]] "
+ "~%~W~:[~;[~W~]] "
(sb!di:frame-number *current-frame*)
(> *debug-command-level* 1)
*debug-command-level*))
(SB-DEBUG:ARG n)
Return the n'th argument in the current frame.
(SB-DEBUG:VAR string-or-symbol [id])
- Returns the value of the specified variable in the current frame.")
+ Returns the value of the specified variable in the current frame.
+
+Other commands:
+ SLURP Discard all pending input on *STANDARD-INPUT*. (This can be
+ useful when the debugger was invoked to handle an error in
+ deeply nested input syntax, and now the reader is confused.)")
\f
;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint.
(define-condition step-condition (simple-condition) ())
(cond ((sb!di:code-location-p place)
(find place info-list
:key #'breakpoint-info-place
- :test #'(lambda (x y) (and (sb!di:code-location-p y)
- (sb!di:code-location= x y)))))
+ :test (lambda (x y) (and (sb!di:code-location-p y)
+ (sb!di:code-location= x y)))))
(t
(find place info-list
- :test #'(lambda (x-debug-fun y-info)
- (let ((y-place (breakpoint-info-place y-info))
- (y-breakpoint (breakpoint-info-breakpoint
- y-info)))
- (and (sb!di:debug-fun-p y-place)
- (eq x-debug-fun y-place)
- (or (not kind)
- (eq kind (sb!di:breakpoint-kind
- y-breakpoint))))))))))
+ :test (lambda (x-debug-fun y-info)
+ (let ((y-place (breakpoint-info-place y-info))
+ (y-breakpoint (breakpoint-info-breakpoint
+ y-info)))
+ (and (sb!di:debug-fun-p y-place)
+ (eq x-debug-fun y-place)
+ (or (not kind)
+ (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
(format t "~&~S: FUN-END in ~S" bp-number
(sb!di:debug-fun-name place))))))
\f
-;;;; MAIN-HOOK-FUNCTION for steps and breakpoints
+;;;; MAIN-HOOK-FUN for steps and breakpoints
;;; 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
- fun-end-cookie)
+(defun main-hook-fun (current-frame breakpoint &optional return-vals
+ fun-end-cookie)
(setf *default-breakpoint-debug-fun*
(sb!di:frame-debug-fun current-frame))
(dolist (step-info *step-breakpoints*)
(break string)
(format t "~A" string)))
(t
- (break "error in main-hook-function: unknown breakpoint"))))))
+ (break "unknown breakpoint"))))))
\f
;;; Set breakpoints at the next possible code-locations. After calling
;;; this, either (CONTINUE) if in the debugger or just let program flow
(when bp-info
(sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
bp-info))))
- (let ((bp (sb!di:make-breakpoint #'main-hook-function code-location
+ (let ((bp (sb!di:make-breakpoint #'main-hook-fun code-location
:kind :code-location)))
(sb!di:activate-breakpoint bp)
(push (create-breakpoint-info code-location bp 0)
*step-breakpoints*))))
(t
(let* ((debug-fun (sb!di:frame-debug-fun *current-frame*))
- (bp (sb!di:make-breakpoint #'main-hook-function debug-fun
+ (bp (sb!di:make-breakpoint #'main-hook-fun debug-fun
:kind :fun-end)))
(sb!di:activate-breakpoint bp)
(push (create-breakpoint-info debug-fun bp 0)
) ; EVAL-WHEN
;;; This is used in constructing arg lists for debugger printing when
-;;; the arg list is unavailable, some arg is unavailable or unused,
-;;; etc.
+;;; the arg list is unavailable, some arg is unavailable or unused, etc.
(defstruct (unprintable-object
(:constructor make-unprintable-object (string))
(:print-object (lambda (x s)
- (print-unreadable-object (x s :type t)
+ (print-unreadable-object (x s)
(write-string (unprintable-object-string x)
s))))
(:copier nil))
;;; lambda-list variables since any other arguments will be in the
;;; &REST arg's list of values.
(defun print-frame-call-1 (frame)
- (let* ((d-fun (sb!di:frame-debug-fun frame))
- (loc (sb!di:frame-code-location frame))
- (results (list (sb!di:debug-fun-name d-fun))))
+ (let ((debug-fun (sb!di:frame-debug-fun frame))
+ (loc (sb!di:frame-code-location frame))
+ (reversed-args nil))
+
+ ;; Construct function arguments in REVERSED-ARGS.
(handler-case
- (dolist (ele (sb!di:debug-fun-lambda-list d-fun))
+ (dolist (ele (sb!di:debug-fun-lambda-list debug-fun))
(lambda-list-element-dispatch ele
- :required ((push (frame-call-arg ele loc frame) results))
- :optional ((push (frame-call-arg (second ele) loc frame) results))
- :keyword ((push (second ele) results)
- (push (frame-call-arg (third ele) loc frame) results))
- :deleted ((push (frame-call-arg ele loc frame) results))
+ :required ((push (frame-call-arg ele loc frame) reversed-args))
+ :optional ((push (frame-call-arg (second ele) loc frame)
+ reversed-args))
+ :keyword ((push (second ele) reversed-args)
+ (push (frame-call-arg (third ele) loc frame)
+ reversed-args))
+ :deleted ((push (frame-call-arg ele loc frame) reversed-args))
:rest ((lambda-var-dispatch (second ele) loc
nil
(progn
- (setf results
+ (setf reversed-args
(append (reverse (sb!di:debug-var-value
(second ele) frame))
- results))
+ reversed-args))
(return))
(push (make-unprintable-object
"unavailable &REST argument")
- results)))))
+ reversed-args)))))
(sb!di:lambda-list-unavailable
()
- (push (make-unprintable-object "lambda list unavailable") results)))
- (pprint-logical-block (*standard-output* nil)
- (let ((x (nreverse (mapcar #'ensure-printable-object results))))
- (format t "(~@<~S~{ ~_~S~}~:>)" (first x) (rest x))))
- (when (sb!di:debug-fun-kind d-fun)
+ (push (make-unprintable-object "lambda list unavailable")
+ reversed-args)))
+
+ (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")")
+ (let ((args (nreverse (mapcar #'ensure-printable-object reversed-args))))
+ ;; Since we go to some trouble to make nice informative function
+ ;; names like (PRINT-OBJECT :AROUND (CLOWN T)), let's make sure
+ ;; that they aren't truncated by *PRINT-LENGTH* and *PRINT-LEVEL*.
+ (let ((*print-length* nil)
+ (*print-level* nil))
+ (prin1 (ensure-printable-object (sb!di:debug-fun-name debug-fun))))
+ ;; For the function arguments, we can just print normally.
+ (format t "~{ ~_~S~}" args)))
+
+ (when (sb!di:debug-fun-kind debug-fun)
(write-char #\[)
- (prin1 (sb!di:debug-fun-kind d-fun))
+ (prin1 (sb!di:debug-fun-kind debug-fun))
(write-char #\]))))
(defun ensure-printable-object (object)
;;; These are bound on each invocation of INVOKE-DEBUGGER.
(defvar *debug-restarts*)
(defvar *debug-condition*)
+(defvar *nested-debug-condition*)
(defun invoke-debugger (condition)
#!+sb-doc
(when old-hook
(let ((*debugger-hook* nil))
(funcall old-hook condition old-hook))))
- (sb!unix:unix-sigsetmask 0)
+ ;; FIXME: No-one seems to know what this is for. Nothing is noticeably
+ ;; broken on sunos...
+ #!-sunos (sb!unix:unix-sigsetmask 0)
;; Elsewhere in the system, we use the SANE-PACKAGE function for
;; this, but here causing an exception just as we're trying to handle
;; the program. WITH-STANDARD-IO-SYNTAX does some of that,
;; but
;; 1. It doesn't affect our internal special variables
- ;; like *CURRENT-LEVEL*.
+ ;; like *CURRENT-LEVEL-IN-PRINT*.
;; 2. It isn't customizable.
;; 3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY*
;; to the same value as the toplevel default.
;; helpful behavior for a debugger.
;; We try to remedy all these problems with explicit
;; rebindings here.
- (sb!kernel:*current-level* 0)
+ (sb!kernel:*current-level-in-print* 0)
(*print-length* *debug-print-length*)
(*print-level* *debug-print-level*)
(*readtable* *debug-readtable*)
(*print-readably* nil)
(*print-pretty* t)
- (*package* original-package))
+ (*package* original-package)
+ (*nested-debug-condition* nil))
;; Before we start our own output, finish any pending output.
;; Otherwise, if the user tried to track the progress of
(type-of *debug-condition*)
*debug-condition*)
(error (condition)
- (format *error-output*
- "~&(caught ~S trying to print ~S when entering debugger)~%"
- (type-of condition)
- '*debug-condition*)))
+ (setf *nested-debug-condition* condition)
+ (let ((ndc-type (type-of *nested-debug-condition*)))
+ (format *error-output*
+ "~&~@<(A ~S was caught when trying to print ~S when ~
+ entering the debugger. Printing was aborted and the ~
+ ~S was stored in ~S.)~@:>~%"
+ ndc-type
+ '*debug-condition*
+ ndc-type
+ '*nested-debug-condition*))
+ (when (typep condition 'cell-error)
+ ;; what we really want to know when it's e.g. an UNBOUND-VARIABLE:
+ (format *error-output*
+ "~&(CELL-ERROR-NAME ~S) = ~S~%"
+ '*debug-condition*
+ (cell-error-name *debug-condition*)))))
;; After the initial error/condition/whatever announcement to
;; *ERROR-OUTPUT*, we become interactive, and should talk on
;; older debugger code which was written to do i/o on whatever
;; stream was in fashion at the time, and not all of it has
;; been converted to behave this way. -- WHN 2000-11-16)
- (let (;; FIXME: The first two bindings here seem wrong,
+ (let (;; FIXME: Rebinding *STANDARD-OUTPUT* here seems wrong,
;; violating the principle of least surprise, and making
;; it impossible for the user to do reasonable things
;; like using PRINT at the debugger prompt to send output
;; to the program's ordinary (possibly
- ;; redirected-to-a-file) *STANDARD-OUTPUT*, or using
- ;; PEEK-CHAR or some such thing on the program's ordinary
- ;; (possibly also redirected) *STANDARD-INPUT*.
- (*standard-input* *debug-io*)
+ ;; redirected-to-a-file) *STANDARD-OUTPUT*. (CMU CL
+ ;; used to rebind *STANDARD-INPUT* here too, but that's
+ ;; been fixed already.)
(*standard-output* *debug-io*)
;; This seems reasonable: e.g. if the user has redirected
;; *ERROR-OUTPUT* to some log file, it's probably wrong
(dolist (restart restarts)
(let ((name (restart-name restart)))
(cond ((member name names-used)
- (format s "~& ~2D: ~@VT~A~%" count max-name-len restart))
+ (format s "~& ~2D: ~V@T~A~%" count max-name-len restart))
(t
(format s "~& ~2D: [~VA] ~A~%"
count (- max-name-len 3) name restart)
(print-frame-call *current-frame* :verbosity 2)
(loop
(catch 'debug-loop-catcher
- (handler-bind ((error #'(lambda (condition)
- (when *flush-debug-errors*
- (clear-input *debug-io*)
- (princ condition)
- ;; FIXME: Doing input on *DEBUG-IO*
- ;; and output on T seems broken.
- (format t
- "~&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
+ (handler-bind ((error (lambda (condition)
+ (when *flush-debug-errors*
+ (clear-input *debug-io*)
+ (princ condition)
+ ;; FIXME: Doing input on *DEBUG-IO*
+ ;; and output on T seems broken.
+ (format t
+ "~&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 ~D)."
+ "Reduce debugger level (to debug level ~W)."
level)
(debug-prompt *debug-io*)
(force-output *debug-io*)
(apply cmd-fun
(sb!int:stream-command-args input))))))
(t
- (let* ((exp (read))
+ (let* ((exp (read *debug-io*))
(cmd-fun (debug-command-p exp
restart-commands)))
(cond ((not cmd-fun)
(sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
`(let* ((temp (etypecase name
- (symbol (sb!di:debug-fun-symbol-variables
+ (symbol (sb!di:debug-fun-symbol-vars
(sb!di:frame-debug-fun *current-frame*)
name))
(simple-string (sb!di:ambiguous-debug-vars
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))
+ (vars (remove-if-not (lambda (v)
+ (eq (sb!di:debug-var-validity v location)
+ :valid))
temp)))
(declare (list vars))
(cond ((null vars)
;; 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))))
+ (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
(let ((v (find id vars :key #'sb!di:debug-var-id)))
(unless v
(error
- "invalid variable ID, ~D: should have been one of ~S"
+ "invalid variable ID, ~W: should have been one of ~S"
id
(mapcar #'sb!di:debug-var-id vars)))
,(ecase ref-or-set
(let* ((name
(if (symbolp form)
(symbol-name form)
- (format nil "~D" form)))
+ (format nil "~W" form)))
(len (length name))
(res nil))
(declare (simple-string name)
(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))))
- (push (cons (format nil "~d" num) restart-fun) commands)
+ (lambda ()
+ (/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))
(find name commands :key #'car :test #'string=))
(push (cons name restart-fun) commands))))
(show-restarts *debug-restarts* *debug-io*)
(write-string "restart: ")
(force-output)
- (setf num (read *standard-input*)))
+ (setf num (read *debug-io*)))
(let ((restart (typecase num
(unsigned-byte
(nth num *debug-restarts*))
(symbol
(find num *debug-restarts* :key #'restart-name
- :test #'(lambda (sym1 sym2)
- (string= (symbol-name sym1)
- (symbol-name sym2)))))
+ :test (lambda (sym1 sym2)
+ (string= (symbol-name sym1)
+ (symbol-name sym2)))))
(t
(format t "~S is invalid as a restart name.~%" num)
(return-from restart-debug-command nil)))))
(setf any-p t)
(when (eq (sb!di:debug-var-validity v location) :valid)
(setf any-valid-p t)
- (format t "~S~:[#~D~;~*~] = ~S~%"
+ (format t "~S~:[#~W~;~*~] = ~S~%"
(sb!di:debug-var-symbol v)
(zerop (sb!di:debug-var-id v))
(sb!di:debug-var-id v)
(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)))
+ (lambda (stream sub-char &rest rest)
+ (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*))))
(when prev-location
(let ((this-num (1- this-num)))
(if (= prev-num this-num)
- (format t "~&~D: " prev-num)
- (format t "~&~D-~D: " prev-num this-num)))
+ (format t "~&~W: " prev-num)
+ (format t "~&~W-~W: " prev-num this-num)))
(print-code-location-source-form prev-location 0)
(when *print-location-kind*
(format t "~S " (sb!di:code-location-kind prev-location)))
*default-breakpoint-debug-fun*))))))
(setup-fun-start ()
(let ((code-loc (sb!di:debug-fun-start-location place)))
- (setf bp (sb!di:make-breakpoint #'main-hook-function
+ (setf bp (sb!di:make-breakpoint #'main-hook-fun
place
:kind :fun-start))
(setf break (sb!di:preprocess-for-eval break code-loc))
print-functions))))
(setup-fun-end ()
(setf bp
- (sb!di:make-breakpoint #'main-hook-function
+ (sb!di:make-breakpoint #'main-hook-fun
place
:kind :fun-end))
(setf break
print-functions)))
(setup-code-location ()
(setf place (nth index *possible-breakpoints*))
- (setf bp (sb!di:make-breakpoint #'main-hook-function
- place
+ (setf bp (sb!di:make-breakpoint #'main-hook-fun place
:kind :code-location))
(dolist (form print)
(push (cons
(if function
(describe function)
(format t "can't figure out the function for this frame"))))
+
+(!def-debug-command "SLURP" ()
+ (loop while (read-char-no-hang *standard-input*)))
\f
;;;; debug loop command utilities
-(defun read-prompting-maybe (prompt &optional (in *standard-input*)
- (out *standard-output*))
- (unless (sb!int:listen-skip-whitespace in)
- (princ prompt out)
- (force-output out))
- (read in))
+(defun read-prompting-maybe (prompt)
+ (unless (sb!int:listen-skip-whitespace *debug-io*)
+ (princ prompt)
+ (force-output))
+ (read *debug-io*))
-(defun read-if-available (default &optional (stream *standard-input*))
- (if (sb!int:listen-skip-whitespace stream)
- (read stream)
+(defun read-if-available (default)
+ (if (sb!int:listen-skip-whitespace *debug-io*)
+ (read *debug-io*)
default))