Commit | Line | Data |
---|---|---|
8746959c NJ |
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)) | |
09499546 NJ |
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)) | |
8746959c NJ |
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) | |
ee6be719 NJ |
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.)" | |
8746959c NJ |
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) | |
ee6be719 NJ |
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." | |
8746959c NJ |
71 | (assert-continuable state) |
72 | (at-step debug-trap (or n 1)) | |
73 | (debugger:continue state)) | |
74 | ||
75 | (define (debugger:next state n) | |
ee6be719 NJ |
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." | |
8746959c NJ |
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 | ||
63258dc9 NJ |
127 | (cond ((string>=? (version) "1.7")) |
128 | (else | |
129 | (define (debugger-command-loop state) | |
130 | (read-and-dispatch-commands state (current-input-port))))) | |
131 | ||
8746959c NJ |
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) | |
63258dc9 | 155 | (debugger-command-loop state)))) |
8746959c NJ |
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)))))) |