X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdebug.lisp;h=7ac94694a4122fbd3bc05fdbf682c796b3ed676b;hb=41ed816c7915806abca6b09ecd2136458f27adcc;hp=d95d1da8639282fc710a8c3f3a4a253eb373edf4;hpb=be9eb6c67b5f43a095c3de17bea945c309d662e4;p=sbcl.git diff --git a/src/code/debug.lisp b/src/code/debug.lisp index d95d1da..7ac9469 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -13,11 +13,28 @@ ;;;; 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") @@ -54,38 +71,31 @@ "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*)) (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 @@ -117,7 +127,12 @@ Function and macro commands: (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.)") ;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint. (define-condition step-condition (simple-condition) ()) @@ -219,19 +234,19 @@ Function and macro commands: (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 @@ -253,31 +268,32 @@ Function and macro commands: ;;;; the BREAKPOINT-INFO structure ;;; info about a made breakpoint -(defstruct (breakpoint-info (:copier nil)) +(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-fun)) - ;; the breakpoint returned by sb!di:make-breakpoint - (breakpoint (required-argument) :type sb!di:breakpoint) + (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) + (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. 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 + ;; 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* @@ -289,25 +305,25 @@ Function and macro commands: (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-fun-name (sb!di:code-location-debug-fun - 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))) @@ -315,12 +331,12 @@ Function and macro commands: (format t "~&~S: FUN-END in ~S" bp-number (sb!di:debug-fun-name place)))))) -;;;; 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*) @@ -387,7 +403,7 @@ Function and macro commands: (break string) (format t "~A" string))) (t - (break "error in main-hook-function: unknown breakpoint")))))) + (break "unknown breakpoint")))))) ;;; Set breakpoints at the next possible code-locations. After calling ;;; this, either (CONTINUE) if in the debugger or just let program flow @@ -409,14 +425,14 @@ Function and macro commands: (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) @@ -485,12 +501,11 @@ Function and macro commands: ) ; 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)) @@ -501,37 +516,51 @@ Function and macro commands: ;;; 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) @@ -587,6 +616,7 @@ Function and macro commands: ;;; 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 @@ -595,7 +625,9 @@ Function and macro commands: (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 @@ -617,7 +649,7 @@ reset to ~S." ;; 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. @@ -625,13 +657,14 @@ reset to ~S." ;; 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 @@ -651,10 +684,22 @@ reset to ~S." (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 @@ -663,15 +708,14 @@ reset to ~S." ;; 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 @@ -693,28 +737,32 @@ reset to ~S." (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 @@ -745,30 +793,33 @@ reset to ~S." (*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*) @@ -786,7 +837,7 @@ reset to ~S." (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) @@ -831,7 +882,7 @@ reset to ~S." (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 @@ -839,9 +890,9 @@ reset to ~S." 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) @@ -882,9 +933,9 @@ reset to ~S." ;; 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 @@ -897,7 +948,7 @@ reset to ~S." (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 @@ -1023,7 +1074,7 @@ argument") (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) @@ -1055,7 +1106,7 @@ argument") (setf (car cmds) (caar cmds)))))))) ;;; Return a list of debug commands (in the same format as -;;; *debug-commands*) that invoke each active restart. +;;; *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 @@ -1066,8 +1117,10 @@ argument") (dolist (restart restarts) (let ((name (string (restart-name restart)))) (let ((restart-fun - #'(lambda () (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)))) @@ -1144,7 +1197,7 @@ argument") ;;; and "terminate the Lisp system" as the SB-EXT:QUIT function.) ;;; ;;;(!def-debug-command "QUIT" () -;;; (throw 'sb!impl::top-level-catcher nil)) +;;; (throw 'sb!impl::toplevel-catcher nil)) ;;; CMU CL supported this GO debug command, but SBCL doesn't -- in ;;; SBCL you just type the CONTINUE restart name instead (or "RESTART @@ -1155,23 +1208,25 @@ argument") ;;; (error "There is no restart named CONTINUE.")) (!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 @@ -1221,7 +1276,7 @@ argument") (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) @@ -1272,39 +1327,39 @@ argument") *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 @@ -1343,10 +1398,10 @@ argument") (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*)))) @@ -1354,7 +1409,7 @@ argument") (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 @@ -1402,8 +1457,8 @@ argument") (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))) @@ -1419,9 +1474,9 @@ argument") (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)))) @@ -1472,7 +1527,7 @@ argument") *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)) @@ -1482,7 +1537,7 @@ argument") 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 @@ -1503,8 +1558,7 @@ argument") 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 @@ -1575,17 +1629,19 @@ argument") (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*))) ;;;; 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))