| 1 | |
| 2 | (define-module (ice-9 debugging ice-9-debugger-extensions) |
| 3 | #:use-module (ice-9 debugger)) |
| 4 | |
| 5 | ;;; Upgrade the debugger state object so that it can carry a flag |
| 6 | ;;; indicating whether the debugging session is continuable. |
| 7 | |
| 8 | (cond ((string>=? (version) "1.7") |
| 9 | (use-modules (ice-9 debugger state)) |
| 10 | (define-module (ice-9 debugger state))) |
| 11 | (else |
| 12 | (define-module (ice-9 debugger)))) |
| 13 | |
| 14 | (set! state-rtd (make-record-type "debugger-state" '(stack index flags))) |
| 15 | (set! state? (record-predicate state-rtd)) |
| 16 | (set! make-state |
| 17 | (let ((make-state-internal (record-constructor state-rtd |
| 18 | '(stack index flags)))) |
| 19 | (lambda (stack index . flags) |
| 20 | (make-state-internal stack index flags)))) |
| 21 | (set! state-stack (record-accessor state-rtd 'stack)) |
| 22 | (set! state-index (record-accessor state-rtd 'index)) |
| 23 | |
| 24 | (define state-flags (record-accessor state-rtd 'flags)) |
| 25 | |
| 26 | ;;; Add commands that (ice-9 debugger) doesn't currently have, for |
| 27 | ;;; continuing or single stepping program execution. |
| 28 | |
| 29 | (cond ((string>=? (version) "1.7") |
| 30 | (use-modules (ice-9 debugger command-loop)) |
| 31 | (define-module (ice-9 debugger command-loop) |
| 32 | #:use-module (ice-9 debugger) |
| 33 | #:use-module (ice-9 debugger state) |
| 34 | #:use-module (ice-9 debugging traps)) |
| 35 | (define new-define-command define-command) |
| 36 | (set! define-command |
| 37 | (lambda (name argument-template documentation procedure) |
| 38 | (new-define-command name argument-template procedure)))) |
| 39 | (else |
| 40 | (define-module (ice-9 debugger)))) |
| 41 | |
| 42 | (use-modules (ice-9 debugging steps)) |
| 43 | |
| 44 | (define (assert-continuable state) |
| 45 | ;; Check that debugger is in a state where `continuing' makes sense. |
| 46 | ;; If not, signal an error. |
| 47 | (or (memq #:continuable (state-flags state)) |
| 48 | (user-error "This debug session is not continuable."))) |
| 49 | |
| 50 | (define (debugger:continue state) |
| 51 | "Tell the program being debugged to continue running. (In fact this is |
| 52 | the same as the @code{quit} command, because it exits the debugger |
| 53 | command loop and so allows whatever code it was that invoked the |
| 54 | debugger to continue.)" |
| 55 | (assert-continuable state) |
| 56 | (throw 'exit-debugger)) |
| 57 | |
| 58 | (define (debugger:finish state) |
| 59 | "Continue until evaluation of the current frame is complete, and |
| 60 | print the result obtained." |
| 61 | (assert-continuable state) |
| 62 | (at-exit (- (stack-length (state-stack state)) |
| 63 | (state-index state)) |
| 64 | (list trace-trap debug-trap)) |
| 65 | (debugger:continue state)) |
| 66 | |
| 67 | (define (debugger:step state n) |
| 68 | "Tell the debugged program to do @var{n} more steps from its current |
| 69 | position. One @dfn{step} means executing until the next frame entry |
| 70 | or exit of any kind. @var{n} defaults to 1." |
| 71 | (assert-continuable state) |
| 72 | (at-step debug-trap (or n 1)) |
| 73 | (debugger:continue state)) |
| 74 | |
| 75 | (define (debugger:next state n) |
| 76 | "Tell the debugged program to do @var{n} more steps from its current |
| 77 | position, but only counting frame entries and exits where the |
| 78 | corresponding source code comes from the same file as the current |
| 79 | stack frame. (See @ref{Step Traps} for the details of how this |
| 80 | works.) If the current stack frame has no source code, the effect of |
| 81 | this command is the same as of @code{step}. @var{n} defaults to 1." |
| 82 | (assert-continuable state) |
| 83 | (at-step debug-trap |
| 84 | (or n 1) |
| 85 | (frame-file-name (stack-ref (state-stack state) |
| 86 | (state-index state))) |
| 87 | (if (memq #:return (state-flags state)) |
| 88 | #f |
| 89 | (- (stack-length (state-stack state)) (state-index state)))) |
| 90 | (debugger:continue state)) |
| 91 | |
| 92 | (define-command "continue" '() |
| 93 | "Continue program execution." |
| 94 | debugger:continue) |
| 95 | |
| 96 | (define-command "finish" '() |
| 97 | "Continue until evaluation of the current frame is complete, and |
| 98 | print the result obtained." |
| 99 | debugger:finish) |
| 100 | |
| 101 | (define-command "step" '('optional exact-integer) |
| 102 | "Continue until entry to @var{n}th next frame." |
| 103 | debugger:step) |
| 104 | |
| 105 | (define-command "next" '('optional exact-integer) |
| 106 | "Continue until entry to @var{n}th next frame in same file." |
| 107 | debugger:next) |
| 108 | |
| 109 | ;;; Export a couple of procedures for use by (ice-9 debugging trace). |
| 110 | |
| 111 | (cond ((string>=? (version) "1.7")) |
| 112 | (else |
| 113 | (define-module (ice-9 debugger)) |
| 114 | (export write-frame-short/expression |
| 115 | write-frame-short/application))) |
| 116 | |
| 117 | ;;; Provide a `debug-trap' entry point in (ice-9 debugger). This is |
| 118 | ;;; designed so that it can be called to explore the stack at a |
| 119 | ;;; breakpoint, and to single step from the breakpoint. |
| 120 | |
| 121 | (define-module (ice-9 debugger)) |
| 122 | |
| 123 | (use-modules (ice-9 debugging traps)) |
| 124 | |
| 125 | (define *not-yet-introduced* #t) |
| 126 | |
| 127 | (cond ((string>=? (version) "1.7")) |
| 128 | (else |
| 129 | (define (debugger-command-loop state) |
| 130 | (read-and-dispatch-commands state (current-input-port))))) |
| 131 | |
| 132 | (define-public (debug-trap trap-context) |
| 133 | "Invoke the Guile debugger to explore the stack at the specified @var{trap}." |
| 134 | (start-stack 'debugger |
| 135 | (let* ((stack (tc:stack trap-context)) |
| 136 | (flags1 (let ((trap-type (tc:type trap-context))) |
| 137 | (case trap-type |
| 138 | ((#:return #:error) |
| 139 | (list trap-type |
| 140 | (tc:return-value trap-context))) |
| 141 | (else |
| 142 | (list trap-type))))) |
| 143 | (flags (if (tc:continuation trap-context) |
| 144 | (cons #:continuable flags1) |
| 145 | flags1)) |
| 146 | (state (apply make-state stack 0 flags))) |
| 147 | (if *not-yet-introduced* |
| 148 | (let ((ssize (stack-length stack))) |
| 149 | (display "This is the Guile debugger -- for help, type `help'.\n") |
| 150 | (set! *not-yet-introduced* #f) |
| 151 | (if (= ssize 1) |
| 152 | (display "There is 1 frame on the stack.\n\n") |
| 153 | (format #t "There are ~A frames on the stack.\n\n" ssize)))) |
| 154 | (write-state-short-with-source-location state) |
| 155 | (debugger-command-loop state)))) |
| 156 | |
| 157 | (define write-state-short-with-source-location |
| 158 | (cond ((string>=? (version) "1.7") |
| 159 | write-state-short) |
| 160 | (else |
| 161 | (lambda (state) |
| 162 | (let* ((frame (stack-ref (state-stack state) (state-index state))) |
| 163 | (source (frame-source frame)) |
| 164 | (position (and source (source-position source)))) |
| 165 | (format #t "Frame ~A at " (frame-number frame)) |
| 166 | (if position |
| 167 | (display-position position) |
| 168 | (display "unknown source location")) |
| 169 | (newline) |
| 170 | (write-char #\tab) |
| 171 | (write-frame-short frame) |
| 172 | (newline)))))) |