\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")
;;; nestedness inside debugger command loops
(defvar *debug-command-level* 0)
-(defvar *stack-top-hint* nil
- #!+sb-doc
- "If this is bound before the debugger is invoked, it is used as the stack
- top by the debugger.")
+;;; If this is bound before the debugger is invoked, it is used as the
+;;; stack top by the debugger.
+(defvar *stack-top-hint* nil)
+
(defvar *stack-top* nil)
(defvar *real-stack-top* nil)
(defvar *current-frame* nil)
-(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)
+;;; Beginner-oriented help messages are important because you end up
+;;; in the debugger whenever something bad happens, or if you try to
+;;; get out of the system with Ctrl-C or (EXIT) or EXIT or whatever.
+;;; But after memorizing them the wasted screen space gets annoying..
+(defvar *debug-beginner-help-p* t
+ "Should the debugger display beginner-oriented help messages?")
- ;; planned new behavior, delayed since it will break ILISP
- #+nil
+(defun debug-prompt (stream)
(format stream
- "~%~D~:[~;[~D~]] "
+ "~%~W~:[~;[~W~]] "
(sb!di:frame-number *current-frame*)
(> *debug-command-level* 1)
*debug-command-level*))
(defparameter *debug-help-string*
-"The prompt is right square brackets, the number indicating how many
- recursive command loops you are in.
-Any command may be uniquely abbreviated.
+"The 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
its own special values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*.
-Debug commands do not affect * and friends, but evaluation in the debug loop
- does affect these variables.
+Debug commands do not affect *, //, and similar variables, but evaluation in
+ the debug loop does affect these variables.
SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
- drop you into deeper into the debugger.
+ drop you deeper into the debugger.
Getting in and out of the debugger:
RESTART invokes restart numbered as shown (prompt if not given).
ERROR prints the error condition and restart cases.
- The name of any restart, or its number, is a valid command, and is the same
- as using RESTART to invoke that restart.
+ The number of any restart, or its name, or a unique abbreviation for its
+ name, is a valid command, and is the same as using RESTART to invoke that
+ restart.
Changing frames:
U up frame D down frame
(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) ())
#!+sb-doc
"When true, list the code location type in the LIST-LOCATIONS command.")
-;;; a list of the types of code-locations that should not be stepped to and
-;;; should not be listed when listing breakpoints
+;;; a list of the types of code-locations that should not be stepped
+;;; to and should not be listed when listing breakpoints
(defvar *bad-code-location-types* '(:call-site :internal-error))
(declaim (type list *bad-code-location-types*))
(defvar *possible-breakpoints*)
(declaim (type list *possible-breakpoints*))
-;;; a list of the made and active breakpoints, each is a breakpoint-info
-;;; structure
+;;; a list of the made and active breakpoints, each is a
+;;; BREAKPOINT-INFO structure
(defvar *breakpoints* nil)
(declaim (type list *breakpoints*))
-;;; a list of breakpoint-info structures of the made and active step
+;;; a list of BREAKPOINT-INFO structures of the made and active step
;;; breakpoints
(defvar *step-breakpoints* nil)
(declaim (type list *step-breakpoints*))
(declaim (type integer *number-of-steps*))
;;; This is used when listing and setting breakpoints.
-(defvar *default-breakpoint-debug-function* nil)
-(declaim (type (or list sb!di:debug-function) *default-breakpoint-debug-function*))
+(defvar *default-breakpoint-debug-fun* nil)
+(declaim (type (or list sb!di:debug-fun) *default-breakpoint-debug-fun*))
\f
;;;; code location utilities
(setf found t)))
first-code-location))
-;;; Return a list of the next code-locations following the one passed. One of
-;;; the *BAD-CODE-LOCATION-TYPES* will not be returned.
+;;; Return a list of the next code-locations following the one passed.
+;;; One of the *BAD-CODE-LOCATION-TYPES* will not be returned.
(defun next-code-locations (code-location)
(let ((debug-block (sb!di:code-location-debug-block code-location))
(block-code-locations nil))
(setf next-list (next-code-locations (first next-list))))
next-list)))
-;;; Returns a list of code-locations of the possible breakpoints of the
-;;; debug-function passed.
-(defun possible-breakpoints (debug-function)
+;;; Return a list of code-locations of the possible breakpoints of DEBUG-FUN.
+(defun possible-breakpoints (debug-fun)
(let ((possible-breakpoints nil))
- (sb!di:do-debug-function-blocks (debug-block debug-function)
+ (sb!di:do-debug-fun-blocks (debug-block debug-fun)
(unless (sb!di:debug-block-elsewhere-p debug-block)
(if *only-block-start-locations*
(push (first-code-location debug-block) possible-breakpoints)
(push code-location possible-breakpoints))))))
(nreverse possible-breakpoints)))
-;;; Searches the info-list for the item passed (code-location, debug-function,
-;;; or breakpoint-info). If the item passed is a debug function then kind will
-;;; be compared if it was specified. The kind if also compared if a
-;;; breakpoint-info is passed since it's in the breakpoint. The info structure
-;;; is returned if found.
+;;; Search the info-list for the item passed (CODE-LOCATION,
+;;; DEBUG-FUN, or BREAKPOINT-INFO). If the item passed is a debug
+;;; function then kind will be compared if it was specified. The kind
+;;; if also compared if a breakpoint-info is passed since it's in the
+;;; breakpoint. The info structure is returned if found.
(defun location-in-list (place info-list &optional (kind nil))
(when (breakpoint-info-p place)
(setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place)))
(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-function y-info)
- (let ((y-place (breakpoint-info-place y-info))
- (y-breakpoint (breakpoint-info-breakpoint
- y-info)))
- (and (sb!di:debug-function-p y-place)
- (eq x-debug-function 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 none for the user.
+ :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
+;;; none for the user.
(defun maybe-block-start-location (loc)
(if (sb!di:code-location-unknown-p loc)
(let* ((block (sb!di:code-location-debug-block loc))
;;;; the BREAKPOINT-INFO structure
;;; info about a made breakpoint
-(defstruct breakpoint-info
+(defstruct (breakpoint-info (:copier nil)
+ (:constructor %make-breakpoint-info))
;; where we are going to stop
- (place (required-argument)
- :type (or sb!di:code-location sb!di:debug-function))
- ;; the breakpoint returned by sb!di:make-breakpoint
- (breakpoint (required-argument) :type sb!di:breakpoint)
- ;; the function returned from sb!di:preprocess-for-eval. If result is
+ (place (missing-arg)
+ :type (or sb!di:code-location sb!di:debug-fun)
+ :read-only t)
+ ;; the breakpoint returned by SB!DI:MAKE-BREAKPOINT
+ (breakpoint (missing-arg) :type sb!di:breakpoint :read-only t)
+ ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is
;; non-NIL, drop into the debugger.
- (break #'identity :type function)
- ;; the function returned from sb!di:preprocess-for-eval. If result is
+ (break #'identity :type function :read-only t)
+ ;; the function returned from SB!DI:PREPROCESS-FOR-EVAL. If result is
;; non-NIL, eval (each) print and print results.
- (condition #'identity :type function)
- ;; the list of functions from sb!di:preprocess-for-eval to evaluate. Results
- ;; are conditionally printed. Car of each element is the function, cdr is the
- ;; form it goes with.
- (print nil :type list)
- ;; the number used when listing the possible breakpoints within a function.
- ;; Could also be a symbol such as start or end.
- (code-location-number (required-argument) :type (or symbol integer))
- ;; the number used when listing the breakpoints active and to delete
- ;; breakpoints
- (breakpoint-number (required-argument) :type integer))
-
-;;; Return a new BREAKPOINT-INFO structure with the info passed.
-(defun create-breakpoint-info (place breakpoint code-location-number
+ (condition #'identity :type function :read-only t)
+ ;; the list of functions from SB!DI:PREPROCESS-FOR-EVAL to evaluate.
+ ;; Results are conditionally printed. CAR of each element is the
+ ;; function, CDR is the form it goes with.
+ (print nil :type list :read-only t)
+ ;; the number used when listing the possible breakpoints within a
+ ;; function; or could also be a symbol such as START or END
+ (code-location-selector (missing-arg) :type (or symbol integer) :read-only t)
+ ;; the number used when listing the active breakpoints, and when
+ ;; deleting breakpoints
+ (breakpoint-number (missing-arg) :type integer) :read-only t)
+
+(defun create-breakpoint-info (place breakpoint code-location-selector
&key (break #'identity)
(condition #'identity) (print nil))
(setf *breakpoints*
(first breakpoints)))))
i))))
- (make-breakpoint-info :place place :breakpoint breakpoint
- :code-location-number code-location-number
- :breakpoint-number breakpoint-number
- :break break :condition condition :print print)))
+ (%make-breakpoint-info :place place
+ :breakpoint breakpoint
+ :code-location-selector code-location-selector
+ :breakpoint-number breakpoint-number
+ :break break
+ :condition condition
+ :print print)))
-;;; Print the breakpoint info for the breakpoint-info structure passed.
(defun print-breakpoint-info (breakpoint-info)
(let ((place (breakpoint-info-place breakpoint-info))
- (bp-number (breakpoint-info-breakpoint-number breakpoint-info))
- (loc-number (breakpoint-info-code-location-number breakpoint-info)))
+ (bp-number (breakpoint-info-breakpoint-number breakpoint-info)))
(case (sb!di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info))
(:code-location
(print-code-location-source-form place 0)
(format t
"~&~S: ~S in ~S"
bp-number
- loc-number
- (sb!di:debug-function-name (sb!di:code-location-debug-function
- place))))
- (:function-start
- (format t "~&~S: FUNCTION-START in ~S" bp-number
- (sb!di:debug-function-name place)))
- (:function-end
- (format t "~&~S: FUNCTION-END in ~S" bp-number
- (sb!di:debug-function-name place))))))
+ (breakpoint-info-code-location-selector breakpoint-info)
+ (sb!di:debug-fun-name (sb!di:code-location-debug-fun place))))
+ (:fun-start
+ (format t "~&~S: FUN-START in ~S" bp-number
+ (sb!di:debug-fun-name place)))
+ (:fun-end
+ (format t "~&~S: FUN-END in ~S" bp-number
+ (sb!di:debug-fun-name place))))))
\f
-;;;; MAIN-HOOK-FUNCTION 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
- function-end-cookie)
- (setf *default-breakpoint-debug-function*
- (sb!di:frame-debug-function current-frame))
+;;;; 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-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*)
(sb!di:delete-breakpoint (breakpoint-info-breakpoint step-info))
(let ((bp-info (location-in-list step-info *breakpoints*)))
(print-common-info ()
(build-string
(with-output-to-string (*standard-output*)
- (when function-end-cookie
+ (when fun-end-cookie
(format t "~%Return values: ~S" return-vals))
(when condition
(when (breakpoint-info-print bp-hit-info)
(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-function (sb!di:frame-debug-function *current-frame*))
- (bp (sb!di:make-breakpoint #'main-hook-function debug-function
- :kind :function-end)))
+ (let* ((debug-fun (sb!di:frame-debug-fun *current-frame*))
+ (bp (sb!di:make-breakpoint #'main-hook-fun debug-fun
+ :kind :fun-end)))
(sb!di:activate-breakpoint bp)
- (push (create-breakpoint-info debug-function bp 0)
+ (push (create-breakpoint-info debug-fun bp 0)
*step-breakpoints*))))))))
\f
;;;; STEP
(*standard-output* *debug-io*))
#!+sb-doc
"Show a listing of the call stack going down from the current frame. In the
- debugger, the current frame is indicated by the prompt. Count is how many
+ debugger, the current frame is indicated by the prompt. COUNT is how many
frames to show."
(fresh-line *standard-output*)
(do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
(eval-when (:compile-toplevel :execute)
-;;; This is a convenient way to express what to do for each type of lambda-list
-;;; element.
+;;; This is a convenient way to express what to do for each type of
+;;; lambda-list element.
(sb!xc:defmacro lambda-list-element-dispatch (element
&key
required
(:rest ,@rest)
(:keyword ,@keyword)))
(symbol
- (assert (eq ,element :deleted))
+ (aver (eq ,element :deleted))
,@deleted)))
(sb!xc:defmacro lambda-var-dispatch (variable location deleted valid other)
) ; 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)))))
+ s))))
+ (:copier nil))
string)
;;; Print FRAME with verbosity level 1. If we hit a &REST arg, then
;;; 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-function frame))
- (loc (sb!di:frame-code-location frame))
- (results (list (sb!di:debug-function-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-function-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-function-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-function-kind d-fun))
+ (prin1 (sb!di:debug-fun-kind debug-fun))
(write-char #\]))))
(defun ensure-printable-object (object)
;;; Prints a representation of the function call causing FRAME to
;;; exist. VERBOSITY indicates the level of information to output;
-;;; zero indicates just printing the debug-function's name, and one
+;;; zero indicates just printing the DEBUG-FUN's name, and one
;;; indicates displaying call-like, one-liner format with argument
;;; values.
(defun print-frame-call (frame &key (verbosity 1) (number nil))
;;; These are bound on each invocation of INVOKE-DEBUGGER.
(defvar *debug-restarts*)
(defvar *debug-condition*)
-
-;;; Print *DEBUG-CONDITION*, taking care to avoid recursive invocation
-;;; of the debugger in case of a problem (e.g. a bug in the PRINT-OBJECT
-;;; method for *DEBUG-CONDITION*).
-(defun princ-debug-condition-carefully (stream)
- (handler-case (princ *debug-condition* stream)
- (error (condition)
- (format stream
- " (caught ~S when trying to print ~S)"
- (type-of condition)
- '*debug-condition*)))
- *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
;; the last line of output or so, and get confused.
(flush-standard-output-streams)
- ;; The initial output here goes to *ERROR-OUTPUT*, because the
+ ;; (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.
- #!+sb-show (sb!kernel:show-condition *debug-condition*
- *error-output*)
- (format *error-output*
- "~2&debugger invoked on condition of type ~S:~% "
- (type-of *debug-condition*))
- (princ-debug-condition-carefully *error-output*)
- (terpri *error-output*)
+ ;; regardless of what the debugger does afterwards.)
+ (handler-case
+ (format *error-output*
+ "~2&~@<debugger invoked on condition of type ~S: ~
+ ~2I~_~A~:>~%"
+ (type-of *debug-condition*)
+ *debug-condition*)
+ (error (condition)
+ (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
;; that file, and right to send them to *DEBUG-IO*.
(*error-output* *debug-io*))
(unless (typep condition 'step-condition)
- (format *debug-io*
- "~%~@<Within the debugger, you can type HELP for help. At ~
- any command prompt (within the debugger or not) you can ~
- type (SB-EXT:QUIT) to terminate the SBCL executable. ~
- The condition which caused the debugger to be entered ~
- is bound to ~S.~:@>~2%"
- '*debug-condition*)
- (show-restarts *debug-restarts* *debug-io*)
- (terpri *debug-io*))
+ (when *debug-beginner-help-p*
+ (format *debug-io*
+ "~%~@<Within the debugger, you can type HELP for help. ~
+ At any command prompt (within the debugger or not) you ~
+ can type (SB-EXT:QUIT) to terminate the SBCL ~
+ executable. The condition which caused the debugger to ~
+ be entered is bound to ~S. You can suppress this ~
+ message by clearing ~S.~:@>~2%"
+ '*debug-condition*
+ '*debug-beginner-help-p*))
+ (show-restarts *debug-restarts* *debug-io*))
(internal-debug))))))
(defun show-restarts (restarts s)
- (when restarts
- (format s "~&restarts:~%")
- (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)))
- (cond ((member name names-used)
- (format s "~& ~2D: ~@VT~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)))))
+ (cond ((null restarts)
+ (format s
+ "~&(no restarts: If you didn't do this on purpose, ~
+ please report it as a bug.)~%"))
+ (t
+ (format s "~&restarts:~%")
+ (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)))
+ (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))))))
;;; This calls DEBUG-LOOP, performing some simple initializations
;;; before doing so. INVOKE-DEBUGGER calls this to actually get into
(*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*)
- (throw 'debug-loop-catcher nil))))
+ (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))))
(fresh-line)
(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*)
- (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)
(t
(funcall cmd-fun)))))))))))))))
-(defvar *auto-eval-in-frame* t
- #!+sb-doc
- "When set (the default), evaluations in the debugger's command loop occur
- relative to the current frame's environment without the need of debugger
- forms that explicitly control this kind of evaluation.")
-
;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
-(defun debug-eval-print (exp)
- (setq +++ ++ ++ + + - - exp)
- (let* ((values (multiple-value-list
- (if (and (fboundp 'compile) *auto-eval-in-frame*)
- (sb!di:eval-in-frame *current-frame* -)
- (eval -))))
+(defun debug-eval-print (expr)
+ (/noshow "entering DEBUG-EVAL-PRINT" expr)
+ (/noshow (fboundp 'compile))
+ (setq +++ ++ ++ + + - - expr)
+ (let* ((values (multiple-value-list (eval -)))
(*standard-output* *debug-io*))
+ (/noshow "done with EVAL in DEBUG-EVAL-PRINT")
(fresh-line)
(if values (prin1 (car values)))
(dolist (x (cdr values))
\f
;;;; debug loop functions
-;;; These commands are functions, not really commands, so that users can get
-;;; their hands on the values returned.
+;;; These commands are functions, not really commands, so that users
+;;; can get their hands on the values returned.
(eval-when (:execute :compile-toplevel)
(sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
`(let* ((temp (etypecase name
- (symbol (sb!di:debug-function-symbol-variables
- (sb!di:frame-debug-function *current-frame*)
+ (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-function *current-frame*)
+ (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))
+ (vars (remove-if-not (lambda (v)
+ (eq (sb!di:debug-var-validity v location)
+ :valid))
temp)))
(declare (list vars))
(cond ((null vars)
`(setf (sb!di:debug-var-value (car vars) *current-frame*)
,value-var))))
(t
- ;; Since we have more than one, first see whether we have any
- ;; variables that exactly match the specification.
+ ;; Since we have more than one, first see whether we have
+ ;; any variables that exactly match the specification.
(let* ((name (etypecase name
(symbol (symbol-name name))
(simple-string name)))
;; 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
) ; EVAL-WHEN
+;;; FIXME: This doesn't work. It would be real nice we could make it
+;;; work! Alas, it doesn't seem to work in CMU CL X86 either..
(defun var (name &optional (id 0 id-supplied))
#!+sb-doc
- "Returns a variable's value if possible. Name is a simple-string or symbol.
+ "Return a variable's value if possible. NAME is a simple-string or symbol.
If it is a simple-string, it is an initial substring of the variable's name.
If name is a symbol, it has the same name and package as the variable whose
value this function returns. If the symbol is uninterned, then the variable
(define-var-operation :set value))
;;; This returns the COUNT'th arg as the user sees it from args, the
-;;; result of SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a
+;;; result of SB!DI:DEBUG-FUN-LAMBDA-LIST. If this returns a
;;; potential DEBUG-VAR from the lambda-list, then the second value is
;;; T. If this returns a keyword symbol or a value from a rest arg,
;;; then the second value is NIL.
:rest ((let ((var (second ele)))
(lambda-var-dispatch var (sb!di:frame-code-location
*current-frame*)
- (error "unused &REST argument before n'th argument")
+ (error "unused &REST argument before n'th
+argument")
(dolist (value
(sb!di:debug-var-value var *current-frame*)
(error
(defun arg (n)
#!+sb-doc
- "Returns the N'th argument's value if possible. Argument zero is the first
+ "Return the N'th argument's value if possible. Argument zero is the first
argument in a frame's default printed representation. Count keyword/value
pairs as separate arguments."
(multiple-value-bind (var lambda-var-p)
- (nth-arg n (handler-case (sb!di:debug-function-lambda-list
- (sb!di:frame-debug-function *current-frame*))
+ (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."))))
(if lambda-var-p
;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are
;;; permitted.
-;;;
-;;; FIXME: This is not needed in the target Lisp system.
-(defmacro def-debug-command (name args &rest body)
- (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND"))))
+(defmacro !def-debug-command (name args &rest body)
+ (let ((fun-name (symbolicate name "-DEBUG-COMMAND")))
`(progn
(setf *debug-commands*
(remove ,name *debug-commands* :key #'car :test #'string=))
(push (cons ,name #',fun-name) *debug-commands*)
',fun-name)))
-(defun def-debug-command-alias (new-name existing-name)
+(defun !def-debug-command-alias (new-name existing-name)
(let ((pair (assoc existing-name *debug-commands* :test #'string=)))
(unless pair (error "unknown debug command name: ~S" existing-name))
(push (cons new-name (cdr pair)) *debug-commands*))
new-name)
-;;; This takes a symbol and uses its name to find a debugger command, using
-;;; initial substring matching. It returns the command function if form
-;;; identifies only one command, but if form is ambiguous, this returns a list
-;;; of the command names. If there are no matches, this returns nil. Whenever
-;;; the loop that looks for a set of possibilities encounters an exact name
-;;; match, we return that command function immediately.
+;;; This takes a symbol and uses its name to find a debugger command,
+;;; using initial substring matching. It returns the command function
+;;; if form identifies only one command, but if form is ambiguous,
+;;; this returns a list of the command names. If there are no matches,
+;;; this returns nil. Whenever the loop that looks for a set of
+;;; possibilities encounters an exact name match, we return that
+;;; command function immediately.
(defun debug-command-p (form &optional other-commands)
(if (or (symbolp form) (integerp form))
(let* ((name
(if (symbolp form)
(symbol-name form)
- (format nil "~D" form)))
+ (format nil "~W" form)))
(len (length name))
(res nil))
(declare (simple-string name)
((not cmds) res)
(setf (car cmds) (caar cmds))))))))
-;;; Returns a list of debug commands (in the same format as *debug-commands*)
-;;; that invoke each active restart.
+;;; Return a list of debug commands (in the same format as
+;;; *DEBUG-COMMANDS*) that invoke each active restart.
;;;
-;;; Two commands are made for each restart: one for the number, and one for
-;;; the restart name (unless it's been shadowed by an earlier restart of the
-;;; same name).
+;;; Two commands are made for each restart: one for the number, and
+;;; one for the restart name (unless it's been shadowed by an earlier
+;;; restart of the same name, or it is NIL).
(defun make-restart-commands (&optional (restarts *debug-restarts*))
(let ((commands)
(num 0)) ; better be the same as show-restarts!
(dolist (restart restarts)
(let ((name (string (restart-name restart))))
- (unless (find name commands :key #'car :test #'string=)
- (let ((restart-fun
- #'(lambda ()
- (invoke-restart-interactively restart))))
- (push (cons name restart-fun) commands)
- (push (cons (format nil "~D" num) restart-fun) commands))))
- (incf num))
- commands))
+ (let ((restart-fun
+ (lambda ()
+ (/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))))
+ (incf num))
+ commands))
\f
;;;; frame-changing commands
-(def-debug-command "UP" ()
+(!def-debug-command "UP" ()
(let ((next (sb!di:frame-up *current-frame*)))
(cond (next
(setf *current-frame* next)
(t
(format t "~&Top of stack.")))))
-(def-debug-command "DOWN" ()
+(!def-debug-command "DOWN" ()
(let ((next (sb!di:frame-down *current-frame*)))
(cond (next
(setf *current-frame* next)
(t
(format t "~&Bottom of stack.")))))
-(def-debug-command-alias "D" "DOWN")
+(!def-debug-command-alias "D" "DOWN")
-;;; CMU CL had this command, but SBCL doesn't, since
-;;; it's redundant with "FRAME 0", and it interferes with abbreviations
-;;; for the TOPLEVEL restart.
-;;;(def-debug-command "TOP" ()
+;;; CMU CL had this command, but SBCL doesn't, since it's redundant
+;;; with "FRAME 0", and it interferes with abbreviations for the
+;;; TOPLEVEL restart.
+;;;(!def-debug-command "TOP" ()
;;; (do ((prev *current-frame* lead)
;;; (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead)))
;;; ((null lead)
;;; (setf *current-frame* prev)
;;; (print-frame-call prev))))
-(def-debug-command "BOTTOM" ()
+(!def-debug-command "BOTTOM" ()
(do ((prev *current-frame* lead)
(lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead)))
((null lead)
(setf *current-frame* prev)
(print-frame-call prev))))
-(def-debug-command-alias "B" "BOTTOM")
+(!def-debug-command-alias "B" "BOTTOM")
-(def-debug-command "FRAME" (&optional
- (n (read-prompting-maybe "frame number: ")))
+(!def-debug-command "FRAME" (&optional
+ (n (read-prompting-maybe "frame number: ")))
(setf *current-frame*
(multiple-value-bind (next-frame-fun limit-string)
(if (< n (sb!di:frame-number *current-frame*))
(return frame)))))))
(print-frame-call *current-frame*))
-(def-debug-command-alias "F" "FRAME")
+(!def-debug-command-alias "F" "FRAME")
\f
;;;; commands for entering and leaving the debugger
;;; things in the system, "restart the top level REPL" in the debugger
;;; and "terminate the Lisp system" as the SB-EXT:QUIT function.)
;;;
-;;;(def-debug-command "QUIT" ()
-;;; (throw 'sb!impl::top-level-catcher nil))
+;;;(!def-debug-command "QUIT" ()
+;;; (throw 'sb!impl::toplevel-catcher nil))
-;;; CMU CL supported this GO debug command, but SBCL doesn't -- just
-;;; type the CONTINUE restart name.
-;;;(def-debug-command "GO" ()
+;;; CMU CL supported this GO debug command, but SBCL doesn't -- in
+;;; SBCL you just type the CONTINUE restart name instead (or "RESTART
+;;; CONTINUE", that's OK too).
+
+;;;(!def-debug-command "GO" ()
;;; (continue *debug-condition*)
;;; (error "There is no restart named CONTINUE."))
-(def-debug-command "RESTART" ()
+(!def-debug-command "RESTART" ()
+ (/show0 "doing RESTART debug-command")
(let ((num (read-if-available :prompt)))
(when (eq num :prompt)
(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)))))
+ (/show0 "got RESTART")
(if restart
(invoke-restart-interactively restart)
;; FIXME: Even if this isn't handled by WARN, it probably
\f
;;;; information commands
-(def-debug-command "HELP" ()
+(!def-debug-command "HELP" ()
;; CMU CL had a little toy pager here, but "if you aren't running
;; ILISP (or a smart windowing system, or something) you deserve to
;; lose", so we've dropped it in SBCL. However, in case some
;; desperate holdout is running this on a dumb terminal somewhere,
;; we tell him where to find the message stored as a string.
(format *debug-io*
- "~&~a~2%(The HELP string is stored in ~S.)~%"
+ "~&~A~2%(The HELP string is stored in ~S.)~%"
*debug-help-string*
'*debug-help-string*))
-(def-debug-command-alias "?" "HELP")
+(!def-debug-command-alias "?" "HELP")
-(def-debug-command "ERROR" ()
+(!def-debug-command "ERROR" ()
(format *debug-io* "~A~%" *debug-condition*)
(show-restarts *debug-restarts* *debug-io*))
-(def-debug-command "BACKTRACE" ()
+(!def-debug-command "BACKTRACE" ()
(backtrace (read-if-available most-positive-fixnum)))
-(def-debug-command "PRINT" ()
+(!def-debug-command "PRINT" ()
(print-frame-call *current-frame*))
-(def-debug-command-alias "P" "PRINT")
+(!def-debug-command-alias "P" "PRINT")
-(def-debug-command "LIST-LOCALS" ()
- (let ((d-fun (sb!di:frame-debug-function *current-frame*)))
+(!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*))
(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)
prefix))))
(write-line "There is no variable information available."))))
-(def-debug-command-alias "L" "LIST-LOCALS")
+(!def-debug-command-alias "L" "LIST-LOCALS")
-(def-debug-command "SOURCE" ()
+(!def-debug-command "SOURCE" ()
(fresh-line)
(print-code-location-source-form (sb!di:frame-code-location *current-frame*)
(read-if-available 0)))
(defvar *cached-readtable* nil)
(declaim (type (or readtable null) *cached-readtable*))
-(pushnew #'(lambda ()
- (setq *cached-debug-source* nil *cached-source-stream* nil
- *cached-readtable* nil))
- sb!int:*before-save-initializations*)
+(pushnew (lambda ()
+ (setq *cached-debug-source* nil *cached-source-stream* nil
+ *cached-readtable* nil))
+ *before-save-initializations*)
-;;; We also cache the last top-level form that we printed a source for
+;;; 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
;;; FORM-NUMBER-TRANSLATIONS.
-(defvar *cached-top-level-form-offset* nil)
-(declaim (type (or index null) *cached-top-level-form-offset*))
-(defvar *cached-top-level-form*)
+(defvar *cached-toplevel-form-offset* nil)
+(declaim (type (or index null) *cached-toplevel-form-offset*))
+(defvar *cached-toplevel-form*)
(defvar *cached-form-number-translations*)
;;; Given a code location, return the associated form-number
-;;; translations and the actual top-level form. We check our cache ---
+;;; translations and the actual top level form. We check our cache ---
;;; if there is a miss, we dispatch on the kind of the debug source.
-(defun get-top-level-form (location)
+(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-top-level-form-offset location)
- *cached-top-level-form-offset*))
- (values *cached-form-number-translations* *cached-top-level-form*)
- (let* ((offset (sb!di:code-location-top-level-form-offset location))
+ (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-top-level-form location))
+ (:file (get-file-toplevel-form location))
(:lisp (svref (sb!di:debug-source-name d-source) offset)))))
- (setq *cached-top-level-form-offset* offset)
+ (setq *cached-toplevel-form-offset* offset)
(values (setq *cached-form-number-translations*
(sb!di:form-number-translations res offset))
- (setq *cached-top-level-form* res))))))
+ (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
+;;; Locate the source file (if it still exists) and grab the top level
+;;; form. If the file is modified, we use the top level form offset
;;; instead of the recorded character offset.
-(defun get-file-top-level-form (location)
+(defun get-file-toplevel-form (location)
(let* ((d-source (sb!di:code-location-debug-source location))
- (tlf-offset (sb!di:code-location-top-level-form-offset 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
(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*))))
(defun print-code-location-source-form (location context)
(let* ((location (maybe-block-start-location location))
(form-num (sb!di:code-location-form-number location)))
- (multiple-value-bind (translations form) (get-top-level-form location)
+ (multiple-value-bind (translations form) (get-toplevel-form location)
(unless (< form-num (length translations))
(error "The source path no longer exists."))
(prin1 (sb!di:source-path-context form
;;; breakpoint and step commands
;;; Step to the next code-location.
-(def-debug-command "STEP" ()
+(!def-debug-command "STEP" ()
(setf *number-of-steps* (read-if-available 1))
(set-step-breakpoint *current-frame*)
(continue *debug-condition*)
;;; where the CONTINUE restart will transfer control. Set
;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be
;;; used by sbreakpoint.
-(def-debug-command "LIST-LOCATIONS" ()
- (let ((df (read-if-available *default-breakpoint-debug-function*)))
+(!def-debug-command "LIST-LOCATIONS" ()
+ (let ((df (read-if-available *default-breakpoint-debug-fun*)))
(cond ((consp df)
- (setf df (sb!di:function-debug-function (eval df)))
- (setf *default-breakpoint-debug-function* df))
+ (setf df (sb!di:fun-debug-fun (eval df)))
+ (setf *default-breakpoint-debug-fun* df))
((or (eq ':c df)
- (not *default-breakpoint-debug-function*))
- (setf df (sb!di:frame-debug-function *current-frame*))
- (setf *default-breakpoint-debug-function* df)))
+ (not *default-breakpoint-debug-fun*))
+ (setf df (sb!di:frame-debug-fun *current-frame*))
+ (setf *default-breakpoint-debug-fun* df)))
(setf *possible-breakpoints* (possible-breakpoints df)))
(let ((continue-at (sb!di:frame-code-location *current-frame*)))
- (let ((active (location-in-list *default-breakpoint-debug-function*
- *breakpoints* :function-start))
+ (let ((active (location-in-list *default-breakpoint-debug-fun*
+ *breakpoints* :fun-start))
(here (sb!di:code-location=
- (sb!di:debug-function-start-location
- *default-breakpoint-debug-function*) continue-at)))
+ (sb!di:debug-fun-start-location
+ *default-breakpoint-debug-fun*) continue-at)))
(when (or active here)
- (format t "::FUNCTION-START ")
+ (format t "::FUN-START ")
(when active (format t " *Active*"))
(when here (format t " *Continue here*"))))
(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)))
(not prev-location)
(not (eq (sb!di:code-location-debug-source code-location)
(sb!di:code-location-debug-source prev-location)))
- (not (eq (sb!di:code-location-top-level-form-offset
+ (not (eq (sb!di:code-location-toplevel-form-offset
code-location)
- (sb!di:code-location-top-level-form-offset
+ (sb!di:code-location-toplevel-form-offset
prev-location)))
(not (eq (sb!di:code-location-form-number code-location)
(sb!di:code-location-form-number prev-location))))
(incf this-num))))
- (when (location-in-list *default-breakpoint-debug-function*
+ (when (location-in-list *default-breakpoint-debug-fun*
*breakpoints*
- :function-end)
- (format t "~&::FUNCTION-END *Active* "))))
+ :fun-end)
+ (format t "~&::FUN-END *Active* "))))
-(def-debug-command-alias "LL" "LIST-LOCATIONS")
+(!def-debug-command-alias "LL" "LIST-LOCATIONS")
;;; Set breakpoint at the given number.
-(def-debug-command "BREAKPOINT" ()
+(!def-debug-command "BREAKPOINT" ()
(let ((index (read-prompting-maybe "location number, :START, or :END: "))
(break t)
(condition t)
(print-functions nil)
(function nil)
(bp)
- (place *default-breakpoint-debug-function*))
+ (place *default-breakpoint-debug-fun*))
(flet ((get-command-line ()
(let ((command-line nil)
(unique '(nil)))
(:break (setf break (pop command-line)))
(:function
(setf function (eval (pop command-line)))
- (setf *default-breakpoint-debug-function*
- (sb!di:function-debug-function function))
- (setf place *default-breakpoint-debug-function*)
+ (setf *default-breakpoint-debug-fun*
+ (sb!di:fun-debug-fun function))
+ (setf place *default-breakpoint-debug-fun*)
(setf *possible-breakpoints*
(possible-breakpoints
- *default-breakpoint-debug-function*))))))
- (setup-function-start ()
- (let ((code-loc (sb!di:debug-function-start-location place)))
- (setf bp (sb!di:make-breakpoint #'main-hook-function
+ *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-fun
place
- :kind :function-start))
+ :kind :fun-start))
(setf break (sb!di:preprocess-for-eval break code-loc))
(setf condition (sb!di:preprocess-for-eval condition code-loc))
(dolist (form print)
(push (cons (sb!di:preprocess-for-eval form code-loc) form)
print-functions))))
- (setup-function-end ()
+ (setup-fun-end ()
(setf bp
- (sb!di:make-breakpoint #'main-hook-function
+ (sb!di:make-breakpoint #'main-hook-fun
place
- :kind :function-end))
+ :kind :fun-end))
(setf break
;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..)
;; forms should be converted to shiny new (LAMBDA ..) forms.
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
(set-vars-from-command-line (get-command-line))
(cond
((or (eq index :start) (eq index :s))
- (setup-function-start))
+ (setup-fun-start))
((or (eq index :end) (eq index :e))
- (setup-function-end))
+ (setup-fun-end))
(t
(setup-code-location)))
(sb!di:activate-breakpoint bp)
(print-breakpoint-info (first *breakpoints*))
(format t "~&added"))))
-(def-debug-command-alias "BP" "BREAKPOINT")
+(!def-debug-command-alias "BP" "BREAKPOINT")
;;; List all breakpoints which are set.
-(def-debug-command "LIST-BREAKPOINTS" ()
+(!def-debug-command "LIST-BREAKPOINTS" ()
(setf *breakpoints*
(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
(dolist (info *breakpoints*)
(print-breakpoint-info info)))
-(def-debug-command-alias "LB" "LIST-BREAKPOINTS")
-(def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
+(!def-debug-command-alias "LB" "LIST-BREAKPOINTS")
+(!def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
;;; Remove breakpoint N, or remove all breakpoints if no N given.
-(def-debug-command "DELETE-BREAKPOINT" ()
+(!def-debug-command "DELETE-BREAKPOINT" ()
(let* ((index (read-if-available nil))
(bp-info
(find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
(setf *breakpoints* nil)
(format t "all breakpoints deleted~%")))))
-(def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
+(!def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
\f
;;; miscellaneous commands
-(def-debug-command "DESCRIBE" ()
+(!def-debug-command "DESCRIBE" ()
(let* ((curloc (sb!di:frame-code-location *current-frame*))
- (debug-fun (sb!di:code-location-debug-function curloc))
- (function (sb!di:debug-function-function debug-fun)))
+ (debug-fun (sb!di:code-location-debug-fun curloc))
+ (function (sb!di:debug-fun-fun debug-fun)))
(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))
projects / sbcl.git / blobdiff