26 |
(require 'scheme) |
(require 'scheme) |
27 |
|
|
28 |
|
|
|
;;;; Debugging (of this code!). |
|
|
|
|
|
(defsubst dmessage (msg &rest args) |
|
|
;;(apply (function message) msg args) |
|
|
) |
|
|
|
|
|
|
|
29 |
;;;; Customization group setup. |
;;;; Customization group setup. |
30 |
|
|
31 |
(defgroup gds nil |
(defgroup gds nil |
115 |
;; competing for user attention. |
;; competing for user attention. |
116 |
;; |
;; |
117 |
;; - `gds-waiting' holds a list of clients that want attention but |
;; - `gds-waiting' holds a list of clients that want attention but |
118 |
;; haven't yet got it. A client is added to this list for two |
;; haven't yet got it. A client is added to this list for two |
119 |
;; reasons. (1) When it is blocked waiting for user input. (2) When |
;; reasons. (1) When it is blocked waiting for user input. |
120 |
;; it first connects to GDS, even if not blocked. |
;; (2) When it first connects to GDS, even if not blocked. |
121 |
;; |
;; |
122 |
;; - `gds-focus-client' holds the client, if any, that currently has |
;; - `gds-focus-client' holds the client, if any, that currently has |
123 |
;; the user's attention. A client can be given the focus if |
;; the user's attention. A client can be given the focus if |
124 |
;; `gds-focus-client' is nil at the time that the client wants |
;; `gds-focus-client' is nil at the time that the client wants |
125 |
;; attention, or if another client relinquishes it. A client can |
;; attention, or if another client relinquishes it. A client can |
126 |
;; relinquish the focus in two ways. (1) If the client application |
;; relinquish the focus in two ways. (1) If the client application |
127 |
;; says that it is no longer blocked, and a small time passes without |
;; says that it is no longer blocked, and a small time passes without |
128 |
;; it becoming blocked again. (2) If the user explicitly `quits' that |
;; it becoming blocked again. (2) If the user explicitly `quits' |
129 |
;; client. |
;; that client. |
130 |
(defvar gds-focus-client nil) |
(defvar gds-focus-client nil) |
131 |
(defvar gds-waiting nil) |
(defvar gds-waiting nil) |
132 |
|
|
|
;; Sometimes we want to display a client buffer immediately even if it |
|
|
;; isn't already in the selected window. To do we this, we bind the |
|
|
;; following variable to non-nil. |
|
|
(defvar gds-immediate-display nil) |
|
|
|
|
133 |
(defun gds-request-focus (client) |
(defun gds-request-focus (client) |
134 |
(cond ((eq client gds-focus-client) |
(cond ((eq client gds-focus-client) |
135 |
;; CLIENT already has the focus. Display its buffer. |
;; CLIENT already has the focus. Display its buffer. |
150 |
(not (gds-client-blocked)) |
(not (gds-client-blocked)) |
151 |
(y-or-n-p |
(y-or-n-p |
152 |
"Client is blocked and no others are waiting. Still quit? ")) |
"Client is blocked and no others are waiting. Still quit? ")) |
153 |
(let ((gds-immediate-display |
(progn |
|
(eq (window-buffer (selected-window)) (current-buffer)))) |
|
154 |
(bury-buffer (current-buffer)) |
(bury-buffer (current-buffer)) |
155 |
;; Pass on the focus. |
;; Pass on the focus. |
156 |
(setq gds-focus-client (car gds-waiting) |
(setq gds-focus-client (car gds-waiting) |
163 |
(gds-request-focus gds-focus-client))))) |
(gds-request-focus gds-focus-client))))) |
164 |
|
|
165 |
|
|
166 |
|
;;;; GDS protocol dispatch. |
167 |
|
|
168 |
|
;; General dispatch function called by the subprocess filter. |
169 |
|
(defun gds-handle-input (form) |
170 |
|
(let ((client (car form))) |
171 |
|
(or (eq client '*) |
172 |
|
(let* ((proc (cadr form)) |
173 |
|
(args (cddr form)) |
174 |
|
(buf (gds-client-buffer client proc args))) |
175 |
|
(if buf (gds-handle-client-input buf client proc args)))))) |
176 |
|
|
177 |
|
(defun gds-handle-client-input (buf client proc args) |
178 |
|
(with-current-buffer buf |
179 |
|
(with-current-buffer gds-transcript |
180 |
|
(goto-char (point-max)) |
181 |
|
(let ((inhibit-read-only t)) |
182 |
|
(insert (format "<%S %S %S>" client proc args) "\n"))) |
183 |
|
(cond (;; (name ...) - Client name. |
184 |
|
(eq proc 'name) |
185 |
|
(setq gds-pid (cadr args)) |
186 |
|
(gds-promote-view 'interaction) |
187 |
|
(gds-request-focus client)) |
188 |
|
|
189 |
|
(;; (current-module ...) - Current module. |
190 |
|
(eq proc 'current-module) |
191 |
|
(setq gds-current-module (car args))) |
192 |
|
|
193 |
|
(;; (stack ...) - Stack at an error or breakpoint. |
194 |
|
(eq proc 'stack) |
195 |
|
(setq gds-stack args) |
196 |
|
(gds-promote-view 'stack)) |
197 |
|
|
198 |
|
(;; (modules ...) - Application's loaded modules. |
199 |
|
(eq proc 'modules) |
200 |
|
(while args |
201 |
|
(or (assoc (car args) gds-modules) |
202 |
|
(setq gds-modules (cons (list (car args)) gds-modules))) |
203 |
|
(setq args (cdr args)))) |
204 |
|
|
205 |
|
(;; (output ...) - Last printed output. |
206 |
|
(eq proc 'output) |
207 |
|
(setq gds-output (car args)) |
208 |
|
(gds-add-view 'messages)) |
209 |
|
|
210 |
|
(;; (status ...) - Application status indication. |
211 |
|
(eq proc 'status) |
212 |
|
(setq gds-status (car args)) |
213 |
|
(if (eq gds-status 'running) |
214 |
|
(gds-delete-view 'browser) |
215 |
|
(gds-add-view 'browser)) |
216 |
|
(if (eq gds-status 'waiting-for-input) |
217 |
|
(progn |
218 |
|
(gds-promote-view 'stack) |
219 |
|
(gds-update-buffers) |
220 |
|
(gds-request-focus client)) |
221 |
|
(setq gds-stack nil) |
222 |
|
(gds-delete-view 'stack) |
223 |
|
(gds-update-buffers-in-a-while))) |
224 |
|
|
225 |
|
(;; (module MODULE ...) - The specified module's bindings. |
226 |
|
(eq proc 'module) |
227 |
|
(let ((minfo (assoc (car args) gds-modules))) |
228 |
|
(if minfo |
229 |
|
(setcdr (cdr minfo) (cdr args))))) |
230 |
|
|
231 |
|
(;; (closed) - Client has gone away. |
232 |
|
(eq proc 'closed) |
233 |
|
(setq gds-status 'closed) |
234 |
|
(gds-update-buffers) |
235 |
|
(setq gds-buffers |
236 |
|
(delq (assq client gds-buffers) gds-buffers)) |
237 |
|
(if (eq client gds-focus-client) |
238 |
|
(gds-quit))) |
239 |
|
|
240 |
|
(;; (eval-results ...) - Results of evaluation. |
241 |
|
(eq proc 'eval-results) |
242 |
|
(gds-display-results client args)) |
243 |
|
|
244 |
|
((eq proc 'completion-result) |
245 |
|
(setq gds-completion-results (or (car args) t))) |
246 |
|
|
247 |
|
))) |
248 |
|
|
249 |
|
|
250 |
;;;; Per-client buffer state. |
;;;; Per-client buffer state. |
251 |
|
|
252 |
|
;; This section contains code that is specific to each Guile client's |
253 |
|
;; buffer but independent of any particular `view'. |
254 |
|
|
255 |
|
;; Alist mapping each client port number to corresponding buffer. |
256 |
|
(defvar gds-buffers nil) |
257 |
|
|
258 |
(define-derived-mode gds-mode |
(define-derived-mode gds-mode |
259 |
scheme-mode |
scheme-mode |
260 |
"Guile Interaction" |
"Guile Interaction" |
264 |
"GDS client's port number.") |
"GDS client's port number.") |
265 |
(make-variable-buffer-local 'gds-client) |
(make-variable-buffer-local 'gds-client) |
266 |
|
|
267 |
(defvar gds-current-module "()" |
(defvar gds-status nil |
268 |
"GDS client's current module.") |
"GDS client's latest status, one of the following symbols. |
269 |
(make-variable-buffer-local 'gds-current-module) |
`running' - Application is running. |
270 |
|
`waiting-for-input' - Application is blocked waiting for instruction |
271 |
|
from the frontend. |
272 |
|
`ready-for-input' - Application is not blocked but can also accept |
273 |
|
asynchronous instructions from the frontend.") |
274 |
|
(make-variable-buffer-local 'gds-status) |
275 |
|
|
276 |
(defvar gds-stack nil |
(defvar gds-transcript nil |
277 |
"GDS client's stack when last stopped.") |
"Transcript buffer for this GDS client.") |
278 |
(make-variable-buffer-local 'gds-stack) |
(make-variable-buffer-local 'gds-transcript) |
279 |
|
|
280 |
(defvar gds-modules nil |
;; Return client buffer for specified client and protocol input. |
281 |
"GDS client's module information. |
(defun gds-client-buffer (client proc args) |
282 |
Alist mapping module names to their symbols and related information. |
(if (eq proc 'name) |
283 |
This looks like: |
;; Introduction from client - create a new buffer. |
284 |
|
(with-current-buffer (generate-new-buffer (car args)) |
285 |
|
(gds-mode) |
286 |
|
(setq gds-client client) |
287 |
|
(setq gds-transcript |
288 |
|
(find-file-noselect |
289 |
|
(expand-file-name (concat "~/.gds-transcript-" (car args))))) |
290 |
|
(with-current-buffer gds-transcript |
291 |
|
(goto-char (point-max)) |
292 |
|
(insert "\nTranscript:\n")) |
293 |
|
(setq gds-buffers |
294 |
|
(cons (cons client (current-buffer)) |
295 |
|
gds-buffers)) |
296 |
|
(current-buffer)) |
297 |
|
;; Otherwise there should be an existing buffer that we can |
298 |
|
;; return. |
299 |
|
(let ((existing (assq client gds-buffers))) |
300 |
|
(if (buffer-live-p (cdr existing)) |
301 |
|
(cdr existing) |
302 |
|
(setq gds-buffers (delq existing gds-buffers)) |
303 |
|
(gds-client-buffer client 'name '("(GDS buffer killed)")))))) |
304 |
|
|
305 |
(((guile) t sym1 sym2 ...) |
(defun gds-client-blocked () |
306 |
((guile-user)) |
(eq gds-status 'waiting-for-input)) |
|
((ice-9 debug) nil sym3 sym4) |
|
|
...) |
|
307 |
|
|
308 |
The `t' or `nil' after the module name indicates whether the module is |
(defvar gds-delayed-update-timer nil) |
|
displayed in expanded form (that is, showing the bindings in that |
|
|
module). The syms are actually all strings because some Guile symbols |
|
|
are not readable by Emacs.") |
|
|
(make-variable-buffer-local 'gds-modules) |
|
309 |
|
|
310 |
(defvar gds-output nil |
(defvar gds-delayed-update-buffers nil) |
|
"GDS client's recent output (printed).") |
|
|
(make-variable-buffer-local 'gds-output) |
|
311 |
|
|
312 |
(defvar gds-status nil |
(defun gds-update-delayed-update-buffers () |
313 |
"GDS client's latest status, one of the following symbols. |
(while gds-delayed-update-buffers |
314 |
|
(with-current-buffer (car gds-delayed-update-buffers) |
315 |
|
(setq gds-delayed-update-buffers |
316 |
|
(cdr gds-delayed-update-buffers)) |
317 |
|
(gds-update-buffers)))) |
318 |
|
|
319 |
|
(defun gds-update-buffers () |
320 |
|
(if (timerp gds-delayed-update-timer) |
321 |
|
(cancel-timer gds-delayed-update-timer)) |
322 |
|
(setq gds-delayed-update-timer nil) |
323 |
|
(let ((view (car gds-views)) |
324 |
|
(inhibit-read-only t)) |
325 |
|
(cond ((eq view 'stack) |
326 |
|
(gds-insert-stack)) |
327 |
|
((eq view 'interaction) |
328 |
|
(gds-insert-interaction)) |
329 |
|
((eq view 'browser) |
330 |
|
(gds-insert-modules)) |
331 |
|
((eq view 'messages) |
332 |
|
(gds-insert-messages)) |
333 |
|
(t |
334 |
|
(error "Bad GDS view %S" view))) |
335 |
|
;; Finish off. |
336 |
|
(widget-setup) |
337 |
|
(force-mode-line-update t))) |
338 |
|
|
339 |
`running' - application is running. |
(defun gds-update-buffers-in-a-while () |
340 |
|
(or (memq (current-buffer) gds-delayed-update-buffers) |
341 |
|
(setq gds-delayed-update-buffers |
342 |
|
(cons (current-buffer) gds-delayed-update-buffers))) |
343 |
|
(if (timerp gds-delayed-update-timer) |
344 |
|
nil |
345 |
|
(setq gds-delayed-update-timer |
346 |
|
(run-at-time 0.5 nil (function gds-update-delayed-update-buffers))))) |
347 |
|
|
348 |
`waiting-for-input' - application is blocked waiting for instruction |
(defun gds-display-buffers () |
349 |
from the frontend. |
(if gds-focus-client |
350 |
|
(let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers)))) |
351 |
|
;; If there's already a window showing the buffer, use it. |
352 |
|
(let ((window (get-buffer-window gds-focus-buffer t))) |
353 |
|
(if window |
354 |
|
(progn |
355 |
|
(make-frame-visible (window-frame window)) |
356 |
|
(select-frame (window-frame window)) |
357 |
|
(select-window window)) |
358 |
|
;(select-window (display-buffer gds-focus-buffer)) |
359 |
|
(display-buffer gds-focus-buffer))) |
360 |
|
;; If there is an associated source buffer, display it as well. |
361 |
|
(if (and (eq (car gds-views) 'stack) |
362 |
|
gds-frame-source-overlay |
363 |
|
(> (overlay-end gds-frame-source-overlay) 0)) |
364 |
|
(let ((window (display-buffer |
365 |
|
(overlay-buffer gds-frame-source-overlay)))) |
366 |
|
(set-window-point window |
367 |
|
(overlay-start gds-frame-source-overlay))))))) |
368 |
|
|
369 |
`ready-for-input' - application is not blocked but can also accept |
|
370 |
asynchronous instructions from the frontend.") |
;;;; Management of `views'. |
371 |
(make-variable-buffer-local 'gds-status) |
|
372 |
|
;; The idea here is to keep the buffer describing a Guile client |
373 |
|
;; relatively uncluttered by only showing one kind of information |
374 |
|
;; about that client at a time. Menu items and key sequences are |
375 |
|
;; provided to switch easily between the available views. |
376 |
|
|
377 |
|
(defvar gds-views nil |
378 |
|
"List of available views for a GDS client. Each element is one of |
379 |
|
the following symbols. |
380 |
|
`interaction' - Interaction with running client. |
381 |
|
`stack' - Call stack view. |
382 |
|
`browser' - Modules and bindings browser view. |
383 |
|
`breakpoints' - List of set breakpoints. |
384 |
|
`messages' - Non-GDS-protocol output from the debugger.") |
385 |
|
(make-variable-buffer-local 'gds-views) |
386 |
|
|
387 |
|
(defun gds-promote-view (view) |
388 |
|
(setq gds-views (cons view (delq view gds-views)))) |
389 |
|
|
390 |
|
(defun gds-switch-to-view (view) |
391 |
|
(or (memq view gds-views) |
392 |
|
(error "View %S is not available" view)) |
393 |
|
(gds-promote-view view) |
394 |
|
(gds-update-buffers)) |
395 |
|
|
396 |
|
(defun gds-add-view (view) |
397 |
|
(or (memq view gds-views) |
398 |
|
(setq gds-views (append gds-views (list view))))) |
399 |
|
|
400 |
|
(defun gds-delete-view (view) |
401 |
|
(setq gds-views (delq view gds-views))) |
402 |
|
|
403 |
|
|
404 |
|
;;;; `Interaction' view. |
405 |
|
|
406 |
|
;; This view provides interaction with a normally running Guile |
407 |
|
;; client, in other words one that is not stopped in the debugger but |
408 |
|
;; is still available to take input from GDS (usually via a thread for |
409 |
|
;; that purpose). The view supports evaluation, help requests, |
410 |
|
;; control of `debug-on-exception' function, and methods for breaking |
411 |
|
;; into the running code. |
412 |
|
|
413 |
|
(defvar gds-current-module "()" |
414 |
|
"GDS client's current module.") |
415 |
|
(make-variable-buffer-local 'gds-current-module) |
416 |
|
|
417 |
(defvar gds-pid nil |
(defvar gds-pid nil |
418 |
"GDS client's process ID.") |
"GDS client's process ID.") |
426 |
"The exception keys for which to debug a GDS client.") |
"The exception keys for which to debug a GDS client.") |
427 |
(make-variable-buffer-local 'gds-exception-keys) |
(make-variable-buffer-local 'gds-exception-keys) |
428 |
|
|
429 |
;; Cached display variables for `gds-update-buffers'. |
(defun gds-insert-interaction () |
430 |
(defvar gds-displayed-modules nil) |
(erase-buffer) |
431 |
(make-variable-buffer-local 'gds-displayed-modules) |
;; Insert stuff for interacting with a running (non-blocked) Guile |
432 |
|
;; client. |
433 |
;; Types of display areas in the *Guile* buffer. |
(widget-insert (buffer-name) |
434 |
(defvar gds-display-types '("\\`" |
", " |
435 |
"^Modules:" |
(cdr (assq gds-status |
436 |
"^Transcript:")) |
'((running . "running (cannot accept input)") |
437 |
(defvar gds-display-type-regexp |
(waiting-for-input . "waiting for input") |
438 |
(concat "\\(" |
(ready-for-input . "running") |
439 |
(substring (apply (function concat) |
(closed . "closed")))) |
440 |
(mapcar (lambda (type) |
", in " |
441 |
(concat "\\|" type)) |
gds-current-module |
442 |
gds-display-types)) |
"\n") |
443 |
2) |
(widget-create 'push-button |
444 |
"\\)")) |
:notify (function gds-sigint) |
445 |
|
"SIGINT") |
446 |
(defun gds-maybe-delete-region (regexp) |
(widget-insert " ") |
447 |
(let ((beg (save-excursion |
(widget-create 'push-button |
448 |
(goto-char (point-min)) |
:notify (function gds-async-break) |
449 |
(and (re-search-forward regexp nil t) |
"Break") |
450 |
(match-beginning 0))))) |
(widget-insert "\n") |
451 |
(if beg |
(widget-create 'checkbox |
452 |
(delete-region beg |
:notify (function gds-toggle-debug-exceptions) |
453 |
(save-excursion |
gds-debug-exceptions) |
454 |
(goto-char beg) |
(widget-insert " Debug exception keys: ") |
455 |
(end-of-line) |
(widget-create 'editable-field |
456 |
(or (and (re-search-forward gds-display-type-regexp |
:notify (function gds-set-exception-keys) |
457 |
nil t) |
gds-exception-keys) |
458 |
(match-beginning 0)) |
(widget-insert "\n")) |
|
(point-max))))))) |
|
|
|
|
|
(defun gds-maybe-skip-region (regexp) |
|
|
(if (looking-at regexp) |
|
|
(if (re-search-forward gds-display-type-regexp nil t 2) |
|
|
(beginning-of-line) |
|
|
(goto-char (point-max))))) |
|
|
|
|
|
(defun gds-update-buffers (client) |
|
|
(dmessage "gds-update-buffers") |
|
|
;; Avoid continually popping up the last associated source buffer |
|
|
;; unless it really is still current. |
|
|
(setq gds-selected-frame-source-buffer nil) |
|
|
(set-buffer (cdr (assq client gds-buffers))) |
|
|
(force-mode-line-update t) |
|
|
(let ((inhibit-read-only t) |
|
|
(p (if (eq client gds-focus-client) |
|
|
(point) |
|
|
(point-min))) |
|
|
stack-changed) |
|
|
;; Start at top of buffer. |
|
|
(goto-char (point-min)) |
|
|
;; Display status; too simple to be worth caching. |
|
|
(gds-maybe-delete-region (concat "\\`" (regexp-quote (buffer-name)))) |
|
|
(widget-insert (buffer-name) |
|
|
", " |
|
|
(cdr (assq gds-status |
|
|
'((running . "running (cannot accept input)") |
|
|
(waiting-for-input . "waiting for input") |
|
|
(ready-for-input . "running") |
|
|
(closed . "closed")))) |
|
|
", in " |
|
|
gds-current-module |
|
|
"\n") |
|
|
(widget-create 'push-button |
|
|
:notify (function gds-sigint) |
|
|
"SIGINT") |
|
|
(widget-insert " ") |
|
|
(widget-create 'push-button |
|
|
:notify (function gds-async-break) |
|
|
"Break") |
|
|
(widget-insert "\n") |
|
|
(widget-create 'checkbox |
|
|
:notify (function gds-toggle-debug-exceptions) |
|
|
gds-debug-exceptions) |
|
|
(widget-insert " Debug exception keys: ") |
|
|
(widget-create 'editable-field |
|
|
:notify (function gds-set-exception-keys) |
|
|
gds-exception-keys) |
|
|
(widget-insert "\n") |
|
|
; (widget-insert "\n\n") |
|
|
; (if (> (length gds-output) 0) |
|
|
; (widget-insert gds-output "\n\n")) |
|
|
;; Display stack. |
|
|
(dmessage "insert stack") |
|
|
(let ((stack gds-stack) |
|
|
(buf (get-buffer-create (concat (buffer-name) " - stack")))) |
|
|
(with-current-buffer buf |
|
|
(if (equal stack gds-stack) |
|
|
;; No change needed. |
|
|
nil |
|
|
(erase-buffer) |
|
|
(gds-mode) |
|
|
;; Insert new stack. |
|
|
(if stack (gds-insert-stack stack)) |
|
|
;; Record displayed stack. |
|
|
(setq gds-stack stack)))) |
|
|
;; Display module list. |
|
|
(dmessage "insert modules") |
|
|
(if (equal gds-modules gds-displayed-modules) |
|
|
(gds-maybe-skip-region "^Modules:") |
|
|
;; Delete existing module list. |
|
|
(gds-maybe-delete-region "^Modules:") |
|
|
;; Insert new list. |
|
|
(if gds-modules (gds-insert-modules gds-modules)) |
|
|
;; Record displayed list. |
|
|
(setq gds-displayed-modules (copy-tree gds-modules))) |
|
|
;; Finish off. |
|
|
(dmessage "widget-setup") |
|
|
(widget-setup) |
|
|
(if stack-changed |
|
|
;; Stack is being seen for the first time, so make sure top of |
|
|
;; buffer is visible. |
|
|
(progn |
|
|
(goto-char (point-min)) |
|
|
(forward-line (+ 1 (cadr gds-stack)))) |
|
|
;; Restore point from before buffer was redrawn. |
|
|
(goto-char p)))) |
|
459 |
|
|
460 |
(defun gds-sigint (w &rest ignore) |
(defun gds-sigint (w &rest ignore) |
461 |
(interactive) |
(interactive) |
477 |
(interactive) |
(interactive) |
478 |
(setq gds-exception-keys (widget-value w))) |
(setq gds-exception-keys (widget-value w))) |
479 |
|
|
480 |
(defun gds-display-buffers () |
(defun gds-view-interaction () |
481 |
(if gds-focus-client |
(interactive) |
482 |
(let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers)))) |
(gds-switch-to-view 'interaction)) |
483 |
;; If there's already a window showing the buffer, use it. |
|
484 |
(let ((window (get-buffer-window gds-focus-buffer t))) |
|
485 |
(if window |
;;;; `Stack' view. |
486 |
(progn |
|
487 |
(make-frame-visible (window-frame window)) |
;; This view shows the Guile call stack after the application has hit |
488 |
(select-frame (window-frame window)) |
;; an error, or when it is stopped in the debugger. |
489 |
(select-window window)) |
|
490 |
;(select-window (display-buffer gds-focus-buffer)) |
(defvar gds-stack nil |
491 |
(display-buffer gds-focus-buffer))) |
"GDS client's stack when last stopped.") |
492 |
;; If there is an associated source buffer, display it as well. |
(make-variable-buffer-local 'gds-stack) |
493 |
(if gds-selected-frame-source-buffer |
|
494 |
(let ((window (display-buffer gds-selected-frame-source-buffer))) |
(defun gds-insert-stack () |
495 |
(set-window-point window |
(erase-buffer) |
496 |
(overlay-start |
(let ((frames (car gds-stack)) |
497 |
gds-selected-frame-source-overlay)))) |
(index (cadr gds-stack)) |
498 |
;; If there is a stack to display, display it. |
(flags (caddr gds-stack)) |
|
(if gds-stack |
|
|
(let ((buf (get-buffer (concat (buffer-name) " - stack")))) |
|
|
(if (get-buffer-window buf) |
|
|
nil |
|
|
(split-window) |
|
|
(set-window-buffer (selected-window) buf))))))) |
|
|
|
|
|
(defun gds-insert-stack (stack) |
|
|
(let ((frames (car stack)) |
|
|
(index (cadr stack)) |
|
|
(flags (caddr stack)) |
|
499 |
frame items) |
frame items) |
500 |
(cond ((memq 'application flags) |
(cond ((memq 'application flags) |
501 |
(widget-insert "Calling procedure:\n")) |
(widget-insert "Calling procedure:\n")) |
524 |
:value (cadr (nth index items)) |
:value (cadr (nth index items)) |
525 |
:notify (function gds-select-stack-frame) |
:notify (function gds-select-stack-frame) |
526 |
items) |
items) |
527 |
(widget-insert "\n"))) |
(widget-insert "\n") |
528 |
|
(goto-char (point-min)))) |
529 |
|
|
530 |
(defun gds-select-stack-frame (widget &rest ignored) |
(defun gds-select-stack-frame (widget &rest ignored) |
531 |
(let* ((s (widget-value widget)) |
(let* ((s (widget-value widget)) |
536 |
|
|
537 |
;; Overlay used to highlight the source expression corresponding to |
;; Overlay used to highlight the source expression corresponding to |
538 |
;; the selected frame. |
;; the selected frame. |
539 |
(defvar gds-selected-frame-source-overlay nil) |
(defvar gds-frame-source-overlay nil) |
|
|
|
|
;; Buffer containing source for the selected frame. |
|
|
(defvar gds-selected-frame-source-buffer nil) |
|
540 |
|
|
541 |
(defun gds-show-selected-frame (source) |
(defun gds-show-selected-frame (source) |
542 |
;; Highlight the frame source, if possible. |
;; Highlight the frame source, if possible. |
543 |
(if (and source |
(if (and source |
544 |
(file-readable-p (car source))) |
(file-readable-p (car source))) |
545 |
(with-current-buffer (find-file-noselect (car source)) |
(with-current-buffer (find-file-noselect (car source)) |
546 |
(if gds-selected-frame-source-overlay |
(if gds-frame-source-overlay |
547 |
nil |
nil |
548 |
(setq gds-selected-frame-source-overlay (make-overlay 0 0)) |
(setq gds-frame-source-overlay (make-overlay 0 0)) |
549 |
(overlay-put gds-selected-frame-source-overlay 'face 'highlight)) |
(overlay-put gds-frame-source-overlay 'face 'highlight)) |
550 |
;; Move to source line. Note that Guile line numbering is |
;; Move to source line. Note that Guile line numbering is |
551 |
;; 0-based, while Emacs numbering is 1-based. |
;; 0-based, while Emacs numbering is 1-based. |
552 |
(save-restriction |
(save-restriction |
553 |
(widen) |
(widen) |
554 |
(goto-line (+ (cadr source) 1)) |
(goto-line (+ (cadr source) 1)) |
555 |
(move-to-column (caddr source)) |
(move-to-column (caddr source)) |
556 |
(move-overlay gds-selected-frame-source-overlay |
(move-overlay gds-frame-source-overlay |
557 |
(point) |
(point) |
558 |
(if (not (looking-at ")")) |
(if (not (looking-at ")")) |
559 |
(save-excursion (forward-sexp 1) (point)) |
(save-excursion (forward-sexp 1) (point)) |
562 |
;; the sexp rather than the beginning... |
;; the sexp rather than the beginning... |
563 |
(save-excursion (forward-char 1) |
(save-excursion (forward-char 1) |
564 |
(backward-sexp 1) (point))) |
(backward-sexp 1) (point))) |
565 |
(current-buffer))) |
(current-buffer)))) |
566 |
(setq gds-selected-frame-source-buffer (current-buffer))) |
(if gds-frame-source-overlay |
567 |
(if gds-selected-frame-source-overlay |
(move-overlay gds-frame-source-overlay 0 0)))) |
568 |
(move-overlay gds-selected-frame-source-overlay 0 0)))) |
|
569 |
|
(defun gds-view-stack () |
570 |
|
(interactive) |
571 |
|
(gds-switch-to-view 'stack)) |
572 |
|
|
573 |
|
|
574 |
|
;;;; `Breakpoints' view. |
575 |
|
|
576 |
|
;; This view shows a list of breakpoints. |
577 |
|
|
578 |
|
(defun gds-view-breakpoints () |
579 |
|
(interactive) |
580 |
|
(gds-switch-to-view 'breakpoints)) |
581 |
|
|
582 |
|
|
583 |
|
;;;; `Browser' view. |
584 |
|
|
585 |
|
;; This view shows a list of modules and module bindings. |
586 |
|
|
587 |
(defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil)) |
(defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil)) |
588 |
"Specification of which Guile modules the debugger should display. |
"Specification of which Guile modules the debugger should display. |
613 |
(gds-show-module-p (cdr name))) |
(gds-show-module-p (cdr name))) |
614 |
default)))) |
default)))) |
615 |
|
|
616 |
(defun gds-insert-modules (modules) |
(defvar gds-modules nil |
617 |
(insert "Modules:\n") |
"GDS client's module information. |
618 |
(while modules |
Alist mapping module names to their symbols and related information. |
619 |
(let ((minfo (car modules))) |
This looks like: |
620 |
(if (gds-show-module-p (car minfo)) |
|
621 |
(let ((w (widget-create 'push-button |
(((guile) t sym1 sym2 ...) |
622 |
:notify (function gds-module-notify) |
((guile-user)) |
623 |
(if (and (cdr minfo) |
((ice-9 debug) nil sym3 sym4) |
624 |
(cadr minfo)) |
...) |
625 |
"-" "+")))) |
|
626 |
(widget-put w :module (cons client (car minfo))) |
The `t' or `nil' after the module name indicates whether the module is |
627 |
(widget-insert " " (prin1-to-string (car minfo)) "\n") |
displayed in expanded form (that is, showing the bindings in that |
628 |
(if (cadr minfo) |
module). The syms are actually all strings because some Guile symbols |
629 |
(let ((syms (cddr minfo))) |
are not readable by Emacs.") |
630 |
(while syms |
(make-variable-buffer-local 'gds-modules) |
631 |
(widget-insert " > " (car syms) "\n") |
|
632 |
(setq syms (cdr syms)))))))) |
(defun gds-insert-modules () |
633 |
(setq modules (cdr modules))) |
(let ((p (if (eq (window-buffer (selected-window)) (current-buffer)) |
634 |
(insert "\n")) |
(point) |
635 |
|
(point-min))) |
636 |
|
(modules gds-modules)) |
637 |
|
(erase-buffer) |
638 |
|
(insert "Modules:\n") |
639 |
|
(while modules |
640 |
|
(let ((minfo (car modules))) |
641 |
|
(if (gds-show-module-p (car minfo)) |
642 |
|
(let ((w (widget-create 'push-button |
643 |
|
:notify (function gds-module-notify) |
644 |
|
(if (and (cdr minfo) |
645 |
|
(cadr minfo)) |
646 |
|
"-" "+")))) |
647 |
|
(widget-put w :module (cons gds-client (car minfo))) |
648 |
|
(widget-insert " " (prin1-to-string (car minfo)) "\n") |
649 |
|
(if (cadr minfo) |
650 |
|
(let ((syms (cddr minfo))) |
651 |
|
(while syms |
652 |
|
(widget-insert " > " (car syms) "\n") |
653 |
|
(setq syms (cdr syms)))))))) |
654 |
|
(setq modules (cdr modules))) |
655 |
|
(insert "\n") |
656 |
|
(goto-char p))) |
657 |
|
|
658 |
(defun gds-module-notify (w &rest ignore) |
(defun gds-module-notify (w &rest ignore) |
659 |
(let* ((module (widget-get w :module)) |
(let* ((module (widget-get w :module)) |
664 |
;; Just toggle expansion state. |
;; Just toggle expansion state. |
665 |
(progn |
(progn |
666 |
(setcar (cdr minfo) (not (cadr minfo))) |
(setcar (cdr minfo) (not (cadr minfo))) |
667 |
(gds-update-buffers client)) |
(gds-update-buffers)) |
668 |
;; Set flag to indicate module expanded. |
;; Set flag to indicate module expanded. |
669 |
(setcdr minfo (list t)) |
(setcdr minfo (list t)) |
670 |
;; Get symlist from Guile. |
;; Get symlist from Guile. |
674 |
(interactive) |
(interactive) |
675 |
(gds-send (format "(%S query-modules)\n" gds-focus-client))) |
(gds-send (format "(%S query-modules)\n" gds-focus-client))) |
676 |
|
|
677 |
|
(defun gds-view-browser () |
678 |
|
(interactive) |
679 |
|
(or gds-modules (gds-query-modules)) |
680 |
|
(gds-switch-to-view 'browser)) |
681 |
|
|
|
;;;; Handling debugging instructions. |
|
|
|
|
|
;; Alist mapping each client port number to corresponding buffer. |
|
|
(defvar gds-buffers nil) |
|
|
|
|
|
;; Return client buffer for specified client and protocol input. |
|
|
(defun gds-client-buffer (client proc args) |
|
|
(if (eq proc 'name) |
|
|
;; Introduction from client - create a new buffer. |
|
|
(with-current-buffer (generate-new-buffer (car args)) |
|
|
(gds-mode) |
|
|
(insert "Transcript:\n") |
|
|
(setq gds-buffers |
|
|
(cons (cons client (current-buffer)) |
|
|
gds-buffers)) |
|
|
(current-buffer)) |
|
|
;; Otherwise there should be an existing buffer that we can |
|
|
;; return. |
|
|
(let ((existing (assq client gds-buffers))) |
|
|
(if (buffer-live-p (cdr existing)) |
|
|
(cdr existing) |
|
|
(setq gds-buffers (delq existing gds-buffers)) |
|
|
(gds-client-buffer client 'name '("(GDS buffer killed)")))))) |
|
|
|
|
|
;; General dispatch function called by the subprocess filter. |
|
|
(defun gds-handle-input (form) |
|
|
(dmessage "Form: %S" form) |
|
|
(let ((client (car form))) |
|
|
(or (eq client '*) |
|
|
(let* ((proc (cadr form)) |
|
|
(args (cddr form)) |
|
|
(buf (gds-client-buffer client proc args))) |
|
|
(if buf (gds-handle-client-input buf client proc args)))))) |
|
|
|
|
|
(defun gds-handle-client-input (buf client proc args) |
|
|
(with-current-buffer buf |
|
|
(save-excursion |
|
|
(goto-char (point-max)) |
|
|
(let ((inhibit-read-only t)) |
|
|
(insert (format "<%S %S %S>" client proc args) "\n"))) |
|
|
(dmessage "Buffer: %S" (current-buffer)) |
|
|
(cond (;; (name ...) - Client name. |
|
|
(eq proc 'name) |
|
|
(setq gds-pid (cadr args)) |
|
|
(gds-request-focus client)) |
|
|
|
|
|
(;; (current-module ...) - Current module. |
|
|
(eq proc 'current-module) |
|
|
(setq gds-current-module (car args)) |
|
|
(dmessage "Current module: %S" gds-current-module)) |
|
|
|
|
|
(;; (stack ...) - Stack at an error or breakpoint. |
|
|
(eq proc 'stack) |
|
|
(setq gds-stack args)) |
|
|
|
|
|
(;; (modules ...) - Application's loaded modules. |
|
|
(eq proc 'modules) |
|
|
(while args |
|
|
(or (assoc (car args) gds-modules) |
|
|
(setq gds-modules (cons (list (car args)) gds-modules))) |
|
|
(setq args (cdr args)))) |
|
|
|
|
|
(;; (output ...) - Last printed output. |
|
|
(eq proc 'output) |
|
|
(setq gds-output (car args))) |
|
|
|
|
|
(;; (status ...) - Application status indication. |
|
|
(eq proc 'status) |
|
|
(setq gds-status (car args)) |
|
|
(or (eq gds-status 'waiting-for-input) |
|
|
(setq gds-stack nil)) |
|
|
(gds-update-buffers client) |
|
|
(if (eq gds-status 'waiting-for-input) |
|
|
(gds-request-focus client) |
|
|
(setq gds-stack nil))) |
|
|
|
|
|
(;; (module MODULE ...) - The specified module's bindings. |
|
|
(eq proc 'module) |
|
|
(let ((minfo (assoc (car args) gds-modules))) |
|
|
(if minfo |
|
|
(setcdr (cdr minfo) (cdr args))))) |
|
682 |
|
|
683 |
(;; (closed) - Client has gone away. |
;;;; `Messages' view. |
|
(eq proc 'closed) |
|
|
(setq gds-status 'closed) |
|
|
(gds-update-buffers client) |
|
|
(setq gds-buffers |
|
|
(delq (assq client gds-buffers) gds-buffers)) |
|
|
(if (eq client gds-focus-client) |
|
|
(gds-quit))) |
|
684 |
|
|
685 |
(;; (eval-results ...) - Results of evaluation. |
;; This view shows recent non-GDS-protocol messages output from the |
686 |
(eq proc 'eval-results) |
;; (ice-9 debugger) code. |
|
(gds-display-results client args)) |
|
687 |
|
|
688 |
((eq proc 'completion-result) |
(defvar gds-output nil |
689 |
(setq gds-completion-results (or (car args) t))) |
"GDS client's recent output (printed).") |
690 |
|
(make-variable-buffer-local 'gds-output) |
691 |
|
|
692 |
))) |
(defun gds-insert-messages () |
693 |
|
(erase-buffer) |
694 |
|
;; Insert recent non-protocol output from (ice-9 debugger). |
695 |
|
(insert gds-output) |
696 |
|
(goto-char (point-min))) |
697 |
|
|
698 |
|
(defun gds-view-messages () |
699 |
|
(interactive) |
700 |
|
(gds-switch-to-view 'messages)) |
701 |
|
|
|
;;;; Guile Debugging keymap. |
|
702 |
|
|
703 |
(set-keymap-parent gds-mode-map widget-keymap) |
;;;; Debugger commands. |
|
(define-key gds-mode-map "g" (function gds-go)) |
|
|
(define-key gds-mode-map "b" (function gds-set-breakpoint)) |
|
|
(define-key gds-mode-map "q" (function gds-quit)) |
|
|
(define-key gds-mode-map " " (function gds-next)) |
|
|
(define-key gds-mode-map "e" (function gds-evaluate)) |
|
|
(define-key gds-mode-map "i" (function gds-step-in)) |
|
|
(define-key gds-mode-map "o" (function gds-step-out)) |
|
|
(define-key gds-mode-map "t" (function gds-trace-finish)) |
|
|
(define-key gds-mode-map "I" (function gds-frame-info)) |
|
|
(define-key gds-mode-map "A" (function gds-frame-args)) |
|
|
(define-key gds-mode-map "M" (function gds-query-modules)) |
|
704 |
|
|
705 |
(defun gds-client-blocked () |
;; Typically but not necessarily used from the `stack' view. |
|
(eq gds-status 'waiting-for-input)) |
|
706 |
|
|
707 |
(defun gds-go () |
(defun gds-go () |
708 |
(interactive) |
(interactive) |
739 |
(interactive) |
(interactive) |
740 |
(gds-send (format "(%S debugger-command info-args)\n" gds-focus-client))) |
(gds-send (format "(%S debugger-command info-args)\n" gds-focus-client))) |
741 |
|
|
742 |
|
|
743 |
|
;;;; Setting breakpoints. |
744 |
|
|
745 |
(defun gds-set-breakpoint () |
(defun gds-set-breakpoint () |
746 |
(interactive) |
(interactive) |
747 |
(cond ((gds-in-source-buffer) |
(cond ((gds-in-source-buffer) |
1063 |
(setq client (gds-choose-client client)) |
(setq client (gds-choose-client client)) |
1064 |
(gds-send (format "(%S load %S)\n" client file-name))) |
(gds-send (format "(%S load %S)\n" client file-name))) |
1065 |
|
|
1066 |
;; Install the process communication commands in the scheme-mode keymap. |
|
1067 |
|
;;;; Scheme mode keymap items. |
1068 |
|
|
1069 |
(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention |
(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention |
1070 |
(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention |
(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention |
1071 |
(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression) |
(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression) |
1076 |
(define-key scheme-mode-map "\e\t" 'gds-complete-symbol) |
(define-key scheme-mode-map "\e\t" 'gds-complete-symbol) |
1077 |
|
|
1078 |
|
|
1079 |
;;;; Menu bar entries. |
;;;; GDS (Guile Interaction) mode keymap and menu items. |
1080 |
|
|
1081 |
|
(set-keymap-parent gds-mode-map widget-keymap) |
1082 |
|
|
1083 |
|
(define-key gds-mode-map "M" (function gds-query-modules)) |
1084 |
|
|
1085 |
|
(define-key gds-mode-map "g" (function gds-go)) |
1086 |
|
(define-key gds-mode-map "q" (function gds-quit)) |
1087 |
|
(define-key gds-mode-map " " (function gds-next)) |
1088 |
|
(define-key gds-mode-map "e" (function gds-evaluate)) |
1089 |
|
(define-key gds-mode-map "i" (function gds-step-in)) |
1090 |
|
(define-key gds-mode-map "o" (function gds-step-out)) |
1091 |
|
(define-key gds-mode-map "t" (function gds-trace-finish)) |
1092 |
|
(define-key gds-mode-map "I" (function gds-frame-info)) |
1093 |
|
(define-key gds-mode-map "A" (function gds-frame-args)) |
1094 |
|
|
1095 |
|
(define-key gds-mode-map "b" (function gds-set-breakpoint)) |
1096 |
|
|
1097 |
|
(define-key gds-mode-map "vi" (function gds-view-interaction)) |
1098 |
|
(define-key gds-mode-map "vs" (function gds-view-stack)) |
1099 |
|
(define-key gds-mode-map "vb" (function gds-view-breakpoints)) |
1100 |
|
(define-key gds-mode-map "vB" (function gds-view-browser)) |
1101 |
|
(define-key gds-mode-map "vm" (function gds-view-messages)) |
1102 |
|
|
1103 |
|
(defvar gds-view-menu nil |
1104 |
|
"GDS view menu.") |
1105 |
|
(if gds-view-menu |
1106 |
|
nil |
1107 |
|
(setq gds-view-menu (make-sparse-keymap "View")) |
1108 |
|
(define-key gds-view-menu [messages] |
1109 |
|
'(menu-item "Messages" gds-view-messages |
1110 |
|
:enable (memq 'messages gds-views))) |
1111 |
|
(define-key gds-view-menu [browser] |
1112 |
|
'(menu-item "Browser" gds-view-browser |
1113 |
|
:enable (memq 'browser gds-views))) |
1114 |
|
(define-key gds-view-menu [breakpoints] |
1115 |
|
'(menu-item "Breakpoints" gds-view-breakpoints |
1116 |
|
:enable (memq 'breakpoints gds-views))) |
1117 |
|
(define-key gds-view-menu [stack] |
1118 |
|
'(menu-item "Stack" gds-view-stack |
1119 |
|
:enable (memq 'stack gds-views))) |
1120 |
|
(define-key gds-view-menu [interaction] |
1121 |
|
'(menu-item "Interaction" gds-view-interaction |
1122 |
|
:enable (memq 'interaction gds-views)))) |
1123 |
|
|
1124 |
(defvar gds-debug-menu nil |
(defvar gds-debug-menu nil |
1125 |
"GDS debugging menu.") |
"GDS debugging menu.") |
1189 |
(cons "Advanced" gds-advanced-menu)) |
(cons "Advanced" gds-advanced-menu)) |
1190 |
(define-key gds-menu [separator-1] |
(define-key gds-menu [separator-1] |
1191 |
'("--")) |
'("--")) |
1192 |
|
(define-key gds-menu [view] |
1193 |
|
`(menu-item "View" ,gds-view-menu :enable gds-views)) |
1194 |
(define-key gds-menu [debug] |
(define-key gds-menu [debug] |
1195 |
`(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client |
`(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client |
1196 |
(gds-client-blocked)))) |
(gds-client-blocked)))) |