Commit | Line | Data |
---|---|---|
41a80feb | 1 | ;;; gds.el -- frontend for Guile development in Emacs |
79b1c5b6 NJ |
2 | |
3 | ;;;; Copyright (C) 2003 Free Software Foundation, Inc. | |
4 | ;;;; | |
5 | ;;;; This library is free software; you can redistribute it and/or | |
6 | ;;;; modify it under the terms of the GNU Lesser General Public | |
7 | ;;;; License as published by the Free Software Foundation; either | |
8 | ;;;; version 2.1 of the License, or (at your option) any later | |
9 | ;;;; version. | |
10 | ;;;; | |
11 | ;;;; This library is distributed in the hope that it will be useful, | |
12 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
14 | ;;;; Lesser General Public License for more details. | |
15 | ;;;; | |
16 | ;;;; You should have received a copy of the GNU Lesser General Public | |
17 | ;;;; License along with this library; if not, write to the Free | |
18 | ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA | |
19 | ;;;; 02111-1307 USA | |
20 | ||
21 | ||
22 | ;;;; Prerequisites. | |
23 | ||
24 | (require 'widget) | |
25 | (require 'wid-edit) | |
41a80feb | 26 | (require 'scheme) |
79b1c5b6 NJ |
27 | |
28 | ||
29 | ;;;; Debugging (of this code!). | |
30 | ||
31 | (defsubst dmessage (msg &rest args) | |
32 | ;;(apply (function message) msg args) | |
33 | ) | |
34 | ||
35 | ||
36 | ;;;; Customization group setup. | |
37 | ||
38 | (defgroup gds nil | |
41a80feb | 39 | "Customization options for Guile Emacs frontend." |
79b1c5b6 NJ |
40 | :group 'scheme) |
41 | ||
42 | ||
43 | ;;;; Communication with the (ice-9 debugger ui-server) subprocess. | |
44 | ||
45 | ;; The subprocess object. | |
46 | (defvar gds-process nil) | |
47 | ||
48 | ;; Subprocess output goes into the `*GDS Process*' buffer, and | |
49 | ;; is then read from there one form at a time. `gds-read-cursor' is | |
50 | ;; the buffer position of the start of the next unread form. | |
51 | (defvar gds-read-cursor nil) | |
52 | ||
79b1c5b6 | 53 | (defun gds-start () |
41a80feb NJ |
54 | "Start (or restart, if already running) the GDS subprocess." |
55 | (interactive) | |
79b1c5b6 NJ |
56 | (if gds-process (gds-shutdown)) |
57 | (with-current-buffer (get-buffer-create "*GDS Process*") | |
58 | (erase-buffer) | |
59 | (setq gds-process | |
60 | (let ((process-connection-type nil)) ; use a pipe | |
61 | (start-process "gds" | |
62 | (current-buffer) | |
63 | "guile" | |
64 | "-q" | |
65 | "--debug" | |
66 | "-e" | |
67 | "run" | |
68 | "-s" | |
69 | "/home/neil/Guile/cvs/guile-core/ice-9/debugger/ui-server.scm")))) | |
70 | (setq gds-read-cursor (point-min)) | |
71 | (set-process-filter gds-process (function gds-filter)) | |
72 | (set-process-sentinel gds-process (function gds-sentinel)) | |
73 | (set-process-coding-system gds-process 'latin-1-unix)) | |
74 | ||
75 | ;; Shutdown the subprocess and cleanup all associated data. | |
76 | (defun gds-shutdown () | |
41a80feb NJ |
77 | "Shut down the GDS subprocess." |
78 | (interactive) | |
79b1c5b6 NJ |
79 | ;; Do cleanup for all clients. |
80 | (while gds-names | |
81 | (gds-client-cleanup (caar gds-names))) | |
82 | ;; Reset any remaining variables. | |
83 | (setq gds-displayed-client nil | |
84 | gds-waiting nil) | |
85 | ;; If the timer is running, cancel it. | |
86 | (if gds-timer | |
87 | (cancel-timer gds-timer)) | |
88 | (setq gds-timer nil) | |
89 | ;; Kill the subprocess. | |
90 | (process-kill-without-query gds-process) | |
91 | (condition-case nil | |
92 | (progn | |
93 | (kill-process gds-process) | |
94 | (accept-process-output gds-process 0 200)) | |
95 | (error)) | |
96 | (setq gds-process nil)) | |
97 | ||
98 | ;; Subprocess output filter: inserts normally into the process buffer, | |
99 | ;; then tries to reread the output one form at a time and delegates | |
100 | ;; processing of each form to `gds-handle-input'. | |
101 | (defun gds-filter (proc string) | |
102 | (with-current-buffer (process-buffer proc) | |
103 | (save-excursion | |
104 | (goto-char (process-mark proc)) | |
105 | (insert-before-markers string)) | |
106 | (goto-char gds-read-cursor) | |
107 | (while (let ((form (condition-case nil | |
108 | (read (current-buffer)) | |
109 | (error nil)))) | |
110 | (if form | |
111 | (save-excursion | |
112 | (gds-handle-input form))) | |
113 | form) | |
114 | (setq gds-read-cursor (point))))) | |
115 | ||
116 | ;; Subprocess sentinel: do nothing. (Currently just here to avoid | |
117 | ;; inserting un-`read'able process status messages into the process | |
118 | ;; buffer.) | |
119 | (defun gds-sentinel (proc event) | |
120 | ) | |
121 | ||
122 | ;; Send input to the subprocess. | |
123 | (defun gds-send (string) | |
124 | (process-send-string gds-process string)) | |
125 | ||
126 | ||
127 | ;;;; Multiple application scheduling. | |
128 | ||
129 | ;; At any moment one Guile application has the focus of the frontend | |
130 | ;; code. `gds-displayed-client' holds the port number of that client. | |
131 | ;; If there are no Guile applications wanting the focus - that is, | |
41a80feb | 132 | ;; ready for instructions - `gds-displayed-client' is nil. |
79b1c5b6 NJ |
133 | (defvar gds-displayed-client nil) |
134 | ||
135 | ;; The list of other Guile applications waiting for focus, referenced | |
136 | ;; by their port numbers. | |
137 | (defvar gds-waiting nil) | |
138 | ||
139 | ;; An idle timer that we use to avoid confusing any user work when | |
140 | ;; popping up debug buffers. `gds-timer' is non-nil whenever the | |
141 | ;; timer is running and nil whenever it is not running. | |
142 | (defvar gds-timer nil) | |
143 | ||
144 | ;; Debug the specified client. If it already has the focus, do so | |
145 | ;; immediately, but using the idle timer to ensure that it doesn't | |
146 | ;; confuse any work the user may be doing. Non-structural work is | |
147 | ;; delegated to `gds-display-state'. | |
148 | (defun gds-debug (&optional client) | |
149 | (dmessage "gds-debug") | |
150 | ;; If `client' is specified, add it to the end of `gds-waiting', | |
151 | ;; unless that client is already the current client or it is already | |
152 | ;; in the waiting list. | |
153 | (if (and client | |
154 | (not (eq client gds-displayed-client)) | |
155 | (not (memq client gds-waiting))) | |
156 | (setq gds-waiting (append gds-waiting (list client)))) | |
157 | ;; Now update `client' to be the next client in the list. | |
158 | (setq client (or gds-displayed-client (car gds-waiting))) | |
159 | ;; If conditions are right, start the idle timer. | |
160 | (if (and client | |
161 | (or (null gds-displayed-client) | |
162 | (eq gds-displayed-client client))) | |
163 | (gds-display-state (or gds-displayed-client | |
164 | (prog1 (car gds-waiting) | |
165 | (setq gds-waiting | |
166 | (cdr gds-waiting))))))) | |
167 | ||
168 | ;; Give up focus because debugging is done for now. Display detail in | |
169 | ;; case of no waiting clients is delegated to `gds-clear-display'. | |
170 | (defun gds-focus-done () | |
171 | (gds-clear-display) | |
172 | (gds-debug)) | |
173 | ||
174 | ;; Although debugging of this client isn't done, yield focus to the | |
175 | ;; next waiting client. | |
176 | (defun gds-focus-yield () | |
177 | (interactive) | |
178 | (if (and (null gds-waiting) | |
41a80feb | 179 | (y-or-n-p "No other clients waiting - bury *Guile* buffer? ")) |
79b1c5b6 NJ |
180 | (bury-buffer) |
181 | (or (memq gds-displayed-client gds-waiting) | |
182 | (setq gds-waiting (append gds-waiting (list gds-displayed-client)))) | |
183 | (gds-focus-done))) | |
184 | ||
185 | ||
186 | ;;;; Per-client state information. | |
187 | ||
188 | ;; Alist mapping client port numbers to application names. The names | |
189 | ;; in this list have been uniquified by `gds-uniquify'. | |
190 | (defvar gds-names nil) | |
191 | ||
192 | ;; Return unique form of NAME. | |
193 | (defun gds-uniquify (name) | |
194 | (let ((count 1) | |
195 | (maybe-unique name)) | |
196 | (while (member maybe-unique (mapcar (function cdr) gds-names)) | |
197 | (setq count (1+ count) | |
198 | maybe-unique (concat name "<" (number-to-string count) ">"))) | |
199 | maybe-unique)) | |
200 | ||
201 | ;; Alist mapping client port numbers to last known status. | |
202 | ;; | |
203 | ;; Status is one of the following symbols. | |
204 | ;; | |
205 | ;; `running' - application is running. | |
206 | ;; | |
207 | ;; `waiting-for-input' - application is blocked waiting for | |
208 | ;; instruction from the frontend. | |
209 | ;; | |
210 | ;; `ready-for-input' - application is not blocked but can also | |
211 | ;; accept asynchronous instructions from the frontend. | |
212 | ;; | |
213 | (defvar gds-statuses nil) | |
214 | ||
215 | ;; Alist mapping client port numbers to last printed outputs. | |
216 | (defvar gds-outputs nil) | |
217 | ||
218 | ;; Alist mapping client port numbers to last known stacks. | |
219 | (defvar gds-stacks nil) | |
220 | ||
221 | ;; Alist mapping client port numbers to module information. This | |
222 | ;; looks like: | |
223 | ;; | |
224 | ;; ((4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) ...) | |
225 | ;; | |
226 | ;; So, for example: | |
227 | ;; | |
228 | ;; (assq client gds-modules) | |
229 | ;; => | |
230 | ;; (4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) | |
231 | ;; | |
232 | ;; The t or nil after the module name indicates whether the module is | |
233 | ;; displayed in expanded form (that is, showing the bindings in that | |
234 | ;; module). | |
235 | ;; | |
236 | ;; The syms are actually all strings, because some Guile symbols are | |
237 | ;; not readable by Emacs. | |
238 | (defvar gds-modules nil) | |
239 | ||
240 | ||
241 | ;;;; Handling debugging instructions. | |
242 | ||
243 | ;; General dispatch function called by the subprocess filter. | |
244 | (defun gds-handle-input (form) | |
245 | (dmessage "Form: %S" form) | |
246 | (let ((client (car form))) | |
247 | (cond ((eq client '*)) | |
248 | (t | |
249 | (let ((proc (cadr form))) | |
250 | ||
251 | (cond ((eq proc 'name) | |
252 | ;; (name ...) - Application's name. | |
253 | (setq gds-names | |
254 | (cons (cons client (gds-uniquify (caddr form))) | |
255 | gds-names))) | |
256 | ||
257 | ((eq proc 'stack) | |
258 | ;; (stack ...) - Stack at an error or breakpoint. | |
259 | (gds-set gds-stacks client (cddr form))) | |
260 | ||
261 | ((eq proc 'modules) | |
262 | ;; (modules ...) - Application's loaded modules. | |
263 | (gds-set gds-modules client | |
264 | (mapcar (function list) (cddr form)))) | |
265 | ||
266 | ((eq proc 'output) | |
267 | ;; (output ...) - Last printed output. | |
268 | (gds-set gds-outputs client (caddr form))) | |
269 | ||
270 | ((eq proc 'status) | |
271 | ;; (status ...) - Application status indication. | |
272 | (let ((status (caddr form))) | |
273 | (gds-set gds-statuses client status) | |
274 | (cond ((eq status 'waiting-for-input) | |
275 | (gds-debug client)) | |
02b0c692 NJ |
276 | ((or (eq status 'running) |
277 | (eq status 'ready-for-input)) | |
79b1c5b6 NJ |
278 | (if (eq client gds-displayed-client) |
279 | (gds-display-state client))) | |
280 | (t | |
281 | (error "Unexpected status: %S" status))))) | |
282 | ||
283 | ((eq proc 'module) | |
284 | ;; (module MODULE ...) - The specified module's bindings. | |
285 | (let* ((modules (assq client gds-modules)) | |
286 | (minfo (assoc (caddr form) modules))) | |
287 | (if minfo | |
288 | (setcdr (cdr minfo) (cdddr form))))) | |
289 | ||
290 | ((eq proc 'closed) | |
291 | ;; (closed) - Client has gone away. | |
292 | (gds-client-cleanup client)) | |
293 | ||
41a80feb NJ |
294 | ((eq proc 'eval-results) |
295 | ;; (eval-results ...) - Results of evaluation. | |
296 | (gds-display-results client (cddr form))) | |
297 | ||
79b1c5b6 NJ |
298 | )))))) |
299 | ||
300 | ;; Store latest status, stack or module list for the specified client. | |
301 | (defmacro gds-set (alist client val) | |
302 | `(let ((existing (assq ,client ,alist))) | |
303 | (if existing | |
304 | (setcdr existing ,val) | |
305 | (setq ,alist | |
306 | (cons (cons client ,val) ,alist))))) | |
307 | ||
308 | ;; Cleanup processing when CLIENT goes away. | |
309 | (defun gds-client-cleanup (client) | |
310 | (if (eq client gds-displayed-client) | |
311 | (gds-focus-done)) | |
312 | (setq gds-names | |
313 | (delq (assq client gds-names) gds-names)) | |
314 | (setq gds-stacks | |
315 | (delq (assq client gds-stacks) gds-stacks)) | |
316 | (setq gds-modules | |
317 | (delq (assq client gds-modules) gds-modules))) | |
318 | ||
319 | ||
320 | ;;;; Displaying debugging information. | |
321 | ||
322 | (defvar gds-client-buffer nil) | |
323 | ||
324 | (define-derived-mode gds-mode | |
325 | fundamental-mode | |
41a80feb NJ |
326 | "Guile" |
327 | "Major mode for Guile information buffers.") | |
79b1c5b6 NJ |
328 | |
329 | (defun gds-set-client-buffer (&optional client) | |
330 | (if (and gds-client-buffer | |
331 | (buffer-live-p gds-client-buffer)) | |
332 | (set-buffer gds-client-buffer) | |
41a80feb | 333 | (setq gds-client-buffer (get-buffer-create "*Guile*")) |
79b1c5b6 NJ |
334 | (set-buffer gds-client-buffer) |
335 | (gds-mode)) | |
336 | ;; Rename to something we don't want first. Otherwise, if the | |
337 | ;; buffer is already correctly named, we get a confusing change | |
41a80feb NJ |
338 | ;; from, say, `*Guile: REPL*' to `*Guile: REPL*<2>'. |
339 | (rename-buffer "*Guile Fake Buffer Name*" t) | |
79b1c5b6 | 340 | (rename-buffer (if client |
41a80feb | 341 | (concat "*Guile: " |
79b1c5b6 NJ |
342 | (cdr (assq client gds-names)) |
343 | "*") | |
41a80feb | 344 | "*Guile*") |
79b1c5b6 NJ |
345 | t) ; Rename uniquely if needed, |
346 | ; although it shouldn't be. | |
347 | (force-mode-line-update t)) | |
348 | ||
349 | (defun gds-clear-display () | |
350 | ;; Clear the client buffer. | |
351 | (gds-set-client-buffer) | |
352 | (let ((inhibit-read-only t)) | |
353 | (erase-buffer) | |
354 | (insert "Stack:\nNo clients ready for debugging.\n") | |
355 | (goto-char (point-min))) | |
356 | (setq gds-displayed-stack 'no-clients) | |
357 | (setq gds-displayed-modules nil) | |
358 | (setq gds-displayed-client nil) | |
359 | (bury-buffer)) | |
360 | ||
361 | ;; Determine whether the client display buffer is visible in the | |
362 | ;; currently selected frame (i.e. where the user is editing). | |
363 | (defun gds-buffer-visible-in-selected-frame-p () | |
364 | (let ((visible-p nil)) | |
365 | (walk-windows (lambda (w) | |
366 | (if (eq (window-buffer w) gds-client-buffer) | |
367 | (setq visible-p t)))) | |
368 | visible-p)) | |
369 | ||
370 | ;; Cached display variables for `gds-display-state'. | |
371 | (defvar gds-displayed-stack nil) | |
372 | (defvar gds-displayed-modules nil) | |
373 | ||
41a80feb | 374 | ;; Types of display areas in the *Guile* buffer. |
79b1c5b6 NJ |
375 | (defvar gds-display-types '("Status" "Stack" "Modules")) |
376 | (defvar gds-display-type-regexp | |
377 | (concat "^\\(" | |
378 | (substring (apply (function concat) | |
379 | (mapcar (lambda (type) | |
380 | (concat "\\|" type)) | |
381 | gds-display-types)) | |
382 | 2) | |
383 | "\\):")) | |
384 | ||
385 | (defun gds-maybe-delete-region (type) | |
386 | (let ((beg (save-excursion | |
387 | (goto-char (point-min)) | |
388 | (and (re-search-forward (concat "^" | |
389 | (regexp-quote type) | |
390 | ":") | |
391 | nil t) | |
392 | (match-beginning 0))))) | |
393 | (if beg | |
394 | (delete-region beg | |
395 | (save-excursion | |
396 | (goto-char beg) | |
397 | (end-of-line) | |
398 | (or (and (re-search-forward gds-display-type-regexp | |
399 | nil t) | |
400 | (match-beginning 0)) | |
401 | (point-max))))))) | |
402 | ||
403 | (defun gds-maybe-skip-region (type) | |
404 | (if (looking-at (regexp-quote type)) | |
405 | (if (re-search-forward gds-display-type-regexp nil t 2) | |
406 | (beginning-of-line) | |
407 | (goto-char (point-max))))) | |
408 | ||
409 | (defun gds-display-state (client) | |
410 | (dmessage "gds-display-state") | |
411 | ;; Avoid continually popping up the last associated source buffer | |
412 | ;; unless it really is still current. | |
413 | (setq gds-selected-frame-source-buffer nil) | |
414 | (gds-set-client-buffer client) | |
415 | (let ((stack (cdr (assq client gds-stacks))) | |
416 | (modules (cdr (assq client gds-modules))) | |
417 | (inhibit-read-only t) | |
418 | (p (if (eq client gds-displayed-client) | |
419 | (point) | |
420 | (point-min))) | |
421 | stack-changed) | |
422 | ;; Start at top of buffer. | |
423 | (goto-char (point-min)) | |
424 | ;; Display status; too simple to be worth caching. | |
425 | (gds-maybe-delete-region "Status") | |
426 | (widget-insert "Status: " | |
427 | (cdr (assq (cdr (assq client gds-statuses)) | |
02b0c692 | 428 | '((running . "running (cannot accept input)") |
79b1c5b6 | 429 | (waiting-for-input . "waiting for input") |
02b0c692 | 430 | (ready-for-input . "running")))) |
79b1c5b6 NJ |
431 | "\n\n") |
432 | (let ((output (cdr (assq client gds-outputs)))) | |
433 | (if (> (length output) 0) | |
434 | (widget-insert output "\n\n"))) | |
435 | ;; Display stack. | |
436 | (dmessage "insert stack") | |
437 | (if (equal stack gds-displayed-stack) | |
438 | (gds-maybe-skip-region "Stack") | |
439 | ;; Note that stack has changed. | |
440 | (if stack (setq stack-changed t)) | |
441 | ;; Delete existing stack. | |
442 | (gds-maybe-delete-region "Stack") | |
443 | ;; Insert new stack. | |
444 | (if stack (gds-insert-stack stack)) | |
445 | ;; Record displayed stack. | |
446 | (setq gds-displayed-stack stack)) | |
447 | ;; Display module list. | |
448 | (dmessage "insert modules") | |
449 | (if (equal modules gds-displayed-modules) | |
450 | (gds-maybe-skip-region "Modules") | |
451 | ;; Delete existing module list. | |
452 | (gds-maybe-delete-region "Modules") | |
453 | ;; Insert new list. | |
454 | (if modules (gds-insert-modules modules)) | |
455 | ;; Record displayed list. | |
456 | (setq gds-displayed-modules (copy-tree modules))) | |
457 | ;; Finish off. | |
458 | (dmessage "widget-setup") | |
459 | (widget-setup) | |
460 | (if stack-changed | |
461 | ;; Stack is being seen for the first time, so make sure top of | |
462 | ;; buffer is visible. | |
463 | (progn | |
464 | (goto-char (point-min)) | |
465 | (re-search-forward "^Stack:") | |
466 | (forward-line (+ 1 (cadr stack)))) | |
467 | ;; Restore point from before buffer was redrawn. | |
468 | (goto-char p))) | |
469 | (setq gds-displayed-client client) | |
470 | (dmessage "consider display") | |
471 | (if (eq (window-buffer (selected-window)) gds-client-buffer) | |
41a80feb | 472 | ;; *Guile* buffer already selected. |
79b1c5b6 NJ |
473 | (gds-display-buffers) |
474 | (dmessage "Running GDS timer") | |
475 | (setq gds-timer | |
476 | (run-with-idle-timer 0.5 | |
477 | nil | |
478 | (lambda () | |
479 | (setq gds-timer nil) | |
480 | (gds-display-buffers)))))) | |
481 | ||
482 | (defun gds-display-buffers () | |
41a80feb | 483 | ;; If there's already a window showing the *Guile* buffer, use |
79b1c5b6 NJ |
484 | ;; it. |
485 | (let ((window (get-buffer-window gds-client-buffer t))) | |
486 | (if window | |
487 | (progn | |
488 | (make-frame-visible (window-frame window)) | |
489 | (raise-frame (window-frame window)) | |
490 | (select-frame (window-frame window)) | |
491 | (select-window window)) | |
492 | (switch-to-buffer gds-client-buffer))) | |
493 | ;; If there is an associated source buffer, display it as well. | |
494 | (if gds-selected-frame-source-buffer | |
495 | (let ((window (display-buffer gds-selected-frame-source-buffer))) | |
496 | (set-window-point window | |
497 | (overlay-start gds-selected-frame-source-overlay)))) | |
498 | ;; Force redisplay. | |
499 | (sit-for 0)) | |
500 | ||
79b1c5b6 NJ |
501 | (defun gds-insert-stack (stack) |
502 | (let ((frames (car stack)) | |
503 | (index (cadr stack)) | |
504 | (flags (caddr stack)) | |
505 | frame items) | |
506 | (widget-insert "Stack: " (prin1-to-string flags) "\n") | |
507 | (let ((i -1)) | |
508 | (gds-show-selected-frame (caddr (nth index frames))) | |
509 | (while frames | |
510 | (setq frame (car frames) | |
511 | frames (cdr frames) | |
512 | i (+ i 1) | |
513 | items (cons (list 'item | |
514 | (let ((s (cadr frame))) | |
515 | (put-text-property 0 1 'index i s) | |
516 | s)) | |
517 | items)))) | |
518 | (setq items (nreverse items)) | |
519 | (apply (function widget-create) | |
520 | 'radio-button-choice | |
521 | :value (cadr (nth index items)) | |
522 | :notify (function gds-select-stack-frame) | |
523 | items) | |
524 | (widget-insert "\n"))) | |
525 | ||
526 | (defun gds-select-stack-frame (widget &rest ignored) | |
527 | (let* ((s (widget-value widget)) | |
528 | (ind (memq 'index (text-properties-at 0 s)))) | |
529 | (gds-send (format "(%S debugger-command frame %d)\n" | |
530 | gds-displayed-client | |
531 | (cadr ind))))) | |
532 | ||
533 | ;; Overlay used to highlight the source expression corresponding to | |
534 | ;; the selected frame. | |
535 | (defvar gds-selected-frame-source-overlay nil) | |
536 | ||
537 | ;; Buffer containing source for the selected frame. | |
538 | (defvar gds-selected-frame-source-buffer nil) | |
539 | ||
540 | (defun gds-show-selected-frame (source) | |
541 | ;; Highlight the frame source, if possible. | |
542 | (if (and source | |
543 | (file-readable-p (car source))) | |
544 | (with-current-buffer (find-file-noselect (car source)) | |
545 | (if gds-selected-frame-source-overlay | |
546 | nil | |
547 | (setq gds-selected-frame-source-overlay (make-overlay 0 0)) | |
548 | (overlay-put gds-selected-frame-source-overlay 'face 'highlight)) | |
549 | ;; Move to source line. Note that Guile line numbering is | |
550 | ;; 0-based, while Emacs numbering is 1-based. | |
551 | (save-restriction | |
552 | (widen) | |
553 | (goto-line (+ (cadr source) 1)) | |
554 | (move-to-column (caddr source)) | |
555 | (move-overlay gds-selected-frame-source-overlay | |
556 | (point) | |
557 | (if (not (looking-at ")")) | |
558 | (save-excursion (forward-sexp 1) (point)) | |
559 | ;; It seems that the source coordinates for | |
560 | ;; backquoted expressions are at the end of | |
561 | ;; the sexp rather than the beginning... | |
562 | (save-excursion (forward-char 1) | |
563 | (backward-sexp 1) (point))) | |
564 | (current-buffer))) | |
565 | (setq gds-selected-frame-source-buffer (current-buffer))) | |
566 | (if gds-selected-frame-source-overlay | |
567 | (move-overlay gds-selected-frame-source-overlay 0 0)))) | |
568 | ||
569 | (defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil)) | |
570 | "Specification of which Guile modules the debugger should display. | |
571 | This is a list with structure (DEFAULT EXCEPTION EXCEPTION...), where | |
572 | DEFAULT is `t' or `nil' and each EXCEPTION has the structure (SYMBOL | |
573 | DEFAULT EXCEPTION EXCEPTION...). | |
574 | ||
575 | A Guile module name `(x y z)' is matched against this filter as | |
576 | follows. If one of the top level EXCEPTIONs has SYMBOL `x', continue | |
577 | by matching the rest of the module name, in this case `(y z)', against | |
578 | that SYMBOL's DEFAULT and next level EXCEPTION list. Otherwise, if | |
579 | the current DEFAULT is `t' display the module, and if the current | |
580 | DEFAULT is `nil', don't display it. | |
581 | ||
582 | This variable is usually set to exclude Guile system modules that are | |
583 | not of primary interest when debugging application code." | |
584 | :type 'sexp | |
585 | :group 'gds) | |
586 | ||
587 | (defun gds-show-module-p (name) | |
588 | ;; Determine whether to display the NAMEd module by matching NAME | |
589 | ;; against `gds-module-filter'. | |
590 | (let ((default (car gds-module-filter)) | |
591 | (exceptions (cdr gds-module-filter))) | |
592 | (let ((exception (assq (car name) exceptions))) | |
593 | (if exception | |
594 | (let ((gds-module-filter (cdr exception))) | |
595 | (gds-show-module-p (cdr name))) | |
596 | default)))) | |
597 | ||
598 | (defun gds-insert-modules (modules) | |
599 | (insert "Modules:\n") | |
600 | (while modules | |
601 | (let ((minfo (car modules))) | |
602 | (if (gds-show-module-p (car minfo)) | |
603 | (let ((w (widget-create 'push-button | |
604 | :notify (function gds-module-notify) | |
605 | (if (and (cdr minfo) | |
606 | (cadr minfo)) | |
607 | "-" "+")))) | |
608 | (widget-put w :module (cons client (car minfo))) | |
609 | (widget-insert " " (prin1-to-string (car minfo)) "\n") | |
610 | (if (cadr minfo) | |
611 | (let ((syms (cddr minfo))) | |
612 | (while syms | |
613 | (widget-insert " > " (car syms) "\n") | |
614 | (setq syms (cdr syms)))))))) | |
615 | (setq modules (cdr modules)))) | |
616 | ||
617 | (defun gds-module-notify (w &rest ignore) | |
618 | (let* ((module (widget-get w :module)) | |
619 | (client (car module)) | |
620 | (name (cdr module)) | |
621 | (modules (assq client gds-modules)) | |
622 | (minfo (assoc name modules))) | |
623 | (if (cdr minfo) | |
624 | ;; Just toggle expansion state. | |
625 | (progn | |
626 | (setcar (cdr minfo) (not (cadr minfo))) | |
627 | (gds-display-state client)) | |
628 | ;; Set flag to indicate module expanded. | |
629 | (setcdr minfo (list t)) | |
630 | ;; Get symlist from Guile. | |
631 | (gds-send (format "(%S query-module %S)\n" client name))))) | |
632 | ||
633 | ||
634 | ;;;; Guile Debugging keymap. | |
635 | ||
636 | (set-keymap-parent gds-mode-map widget-keymap) | |
637 | (define-key gds-mode-map "g" (function gds-go)) | |
638 | (define-key gds-mode-map "b" (function gds-set-breakpoint)) | |
639 | (define-key gds-mode-map "q" (function gds-quit)) | |
640 | (define-key gds-mode-map "y" (function gds-yield)) | |
641 | (define-key gds-mode-map " " (function gds-next)) | |
642 | (define-key gds-mode-map "e" (function gds-evaluate)) | |
643 | (define-key gds-mode-map "i" (function gds-step-in)) | |
644 | (define-key gds-mode-map "o" (function gds-step-out)) | |
645 | (define-key gds-mode-map "t" (function gds-trace-finish)) | |
646 | ||
647 | (defun gds-client-waiting () | |
648 | (eq (cdr (assq gds-displayed-client gds-statuses)) 'waiting-for-input)) | |
649 | ||
650 | (defun gds-go () | |
651 | (interactive) | |
652 | (gds-send (format "(%S debugger-command continue)\n" gds-displayed-client))) | |
653 | ||
654 | (defun gds-quit () | |
655 | (interactive) | |
656 | (if (gds-client-waiting) | |
657 | (if (y-or-n-p "Client is waiting for instruction - tell it to continue? ") | |
658 | (gds-go))) | |
659 | (gds-yield)) | |
660 | ||
661 | (defun gds-yield () | |
662 | (interactive) | |
663 | (if (gds-client-waiting) | |
664 | (gds-focus-yield) | |
665 | (gds-focus-done))) | |
666 | ||
667 | (defun gds-next () | |
668 | (interactive) | |
669 | (gds-send (format "(%S debugger-command next 1)\n" gds-displayed-client))) | |
670 | ||
671 | (defun gds-evaluate (expr) | |
672 | (interactive "sEvaluate (in this stack frame): ") | |
673 | (gds-send (format "(%S debugger-command evaluate %s)\n" | |
674 | gds-displayed-client | |
675 | (prin1-to-string expr)))) | |
676 | ||
677 | (defun gds-step-in () | |
678 | (interactive) | |
679 | (gds-send (format "(%S debugger-command step 1)\n" gds-displayed-client))) | |
680 | ||
681 | (defun gds-step-out () | |
682 | (interactive) | |
683 | (gds-send (format "(%S debugger-command finish)\n" gds-displayed-client))) | |
684 | ||
685 | (defun gds-trace-finish () | |
686 | (interactive) | |
687 | (gds-send (format "(%S debugger-command trace-finish)\n" | |
688 | gds-displayed-client))) | |
689 | ||
690 | (defun gds-set-breakpoint () | |
691 | (interactive) | |
692 | (cond ((gds-in-source-buffer) | |
693 | (gds-set-source-breakpoint)) | |
694 | ((gds-in-stack) | |
695 | (gds-set-stack-breakpoint)) | |
696 | ((gds-in-modules) | |
697 | (gds-set-module-breakpoint)) | |
698 | (t | |
699 | (error "No way to set a breakpoint from here")))) | |
700 | ||
701 | (defun gds-in-source-buffer () | |
702 | ;; Not yet worked out what will be available in Scheme source | |
703 | ;; buffers. | |
704 | nil) | |
705 | ||
706 | (defun gds-in-stack () | |
707 | (and (eq (current-buffer) gds-client-buffer) | |
708 | (save-excursion | |
709 | (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) | |
710 | (looking-at "Stack"))))) | |
711 | ||
712 | (defun gds-in-modules () | |
713 | (and (eq (current-buffer) gds-client-buffer) | |
714 | (save-excursion | |
715 | (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) | |
716 | (looking-at "Modules"))))) | |
717 | ||
718 | (defun gds-set-module-breakpoint () | |
719 | (let ((sym (save-excursion | |
720 | (beginning-of-line) | |
721 | (and (looking-at " > \\([^ \n\t]+\\)") | |
722 | (match-string 1)))) | |
723 | (module (save-excursion | |
724 | (and (re-search-backward "^\\[[+---]\\] \\(([^)]+)\\)" nil t) | |
725 | (match-string 1))))) | |
726 | (or sym | |
727 | (error "Couldn't find procedure name on current line")) | |
728 | (or module | |
729 | (error "Couldn't find module name for current line")) | |
730 | (let ((behaviour | |
731 | (completing-read | |
732 | (format "Behaviour for breakpoint at %s:%s (default debug-here): " | |
733 | module sym) | |
734 | '(("debug-here") | |
735 | ("trace-here") | |
736 | ("trace-subtree")) | |
737 | nil | |
738 | t | |
739 | nil | |
740 | nil | |
741 | "debug-here"))) | |
742 | (gds-send (format "(%S set-breakpoint %s %s %s)\n" | |
743 | gds-displayed-client | |
744 | module | |
745 | sym | |
746 | behaviour))))) | |
02b0c692 NJ |
747 | |
748 | ||
749 | ;;;; Evaluating code. | |
750 | ||
41a80feb NJ |
751 | ;; The following commands send code for evaluation through the GDS TCP |
752 | ;; connection, receive the result and any output generated through the | |
753 | ;; same connection, and display the result and output to the user. | |
754 | ;; | |
755 | ;; Where there are multiple Guile applications known to GDS, GDS by | |
756 | ;; default sends code to the one that holds the debugging focus, | |
757 | ;; i.e. `gds-displayed-client'. Where no application has the focus, | |
9f1af5d9 | 758 | ;; or the command is invoked with `C-u', GDS asks the user which |
41a80feb NJ |
759 | ;; application is intended. |
760 | ||
761 | (defun gds-read-client () | |
762 | (let* ((def (if gds-displayed-client | |
763 | (cdr (assq gds-displayed-client gds-names)))) | |
764 | (prompt (if def | |
765 | (concat "Application for eval (default " | |
766 | def | |
767 | "): ") | |
768 | "Application for eval: ")) | |
769 | (name | |
770 | (completing-read prompt | |
9f1af5d9 NJ |
771 | (mapcar (function list) |
772 | (mapcar (function cdr) gds-names)) | |
41a80feb NJ |
773 | nil t nil nil |
774 | def))) | |
775 | (let (client (names gds-names)) | |
776 | (while (and names (not client)) | |
9f1af5d9 | 777 | (if (string-equal (cdar names) name) |
41a80feb | 778 | (setq client (caar names))) |
9f1af5d9 NJ |
779 | (setq names (cdr names))) |
780 | client))) | |
41a80feb NJ |
781 | |
782 | (defun gds-choose-client (client) | |
783 | (or ;; If client is an integer, it is the port number of the | |
784 | ;; intended client. | |
785 | (if (integerp client) client) | |
786 | ;; Any other non-nil value indicates invocation with a prefix | |
787 | ;; arg, which forces asking the user which application is | |
788 | ;; intended. | |
789 | (if client (gds-read-client)) | |
790 | ;; If ask not forced, and there is a client with the focus, | |
791 | ;; default to that one. | |
792 | gds-displayed-client | |
9f1af5d9 NJ |
793 | ;; If there are no clients at this point, and we are allowed to |
794 | ;; autostart a captive Guile, do so. | |
795 | (and (null gds-names) | |
796 | gds-autostart-captive | |
797 | (progn | |
798 | (gds-start-captive t) | |
799 | (while (null gds-names) | |
800 | (accept-process-output (get-buffer-process gds-captive) | |
801 | 0 100000)) | |
802 | (caar gds-names))) | |
803 | ;; If there is only one known client, use that one. | |
804 | (if (and (car gds-names) | |
805 | (null (cdr gds-names))) | |
806 | (caar gds-names)) | |
41a80feb NJ |
807 | ;; Last resort - ask the user. |
808 | (gds-read-client) | |
809 | ;; Signal an error. | |
810 | (error "No application chosen."))) | |
811 | ||
41a80feb NJ |
812 | (defun gds-module-name (start end) |
813 | "Determine and return the name of the module that governs the | |
814 | specified region. The module name is returned as a list of symbols." | |
815 | (interactive "r") ; why not? | |
816 | (save-excursion | |
817 | (goto-char start) | |
818 | (let (module-name) | |
819 | (while (and (not module-name) | |
820 | (beginning-of-defun-raw 1)) | |
821 | (if (looking-at "(define-module ") | |
822 | (setq module-name | |
823 | (progn | |
824 | (goto-char (match-end 0)) | |
825 | (read (current-buffer)))))) | |
826 | module-name))) | |
827 | ||
828 | (defun gds-port-name (start end) | |
829 | "Return port name for the specified region of the current buffer. | |
830 | The name will be used by Guile as the port name when evaluating that | |
831 | region's code." | |
832 | (or (buffer-file-name) | |
833 | (concat "Emacs buffer: " (buffer-name)))) | |
834 | ||
835 | (defun gds-eval-region (start end &optional client) | |
836 | "Evaluate the current region." | |
837 | (interactive "r\nP") | |
838 | (setq client (gds-choose-client client)) | |
839 | (let ((module (gds-module-name start end)) | |
840 | (port-name (gds-port-name start end)) | |
841 | line column) | |
842 | (save-excursion | |
843 | (goto-char start) | |
844 | (setq column (current-column)) ; 0-based | |
845 | (beginning-of-line) | |
846 | (setq line (count-lines (point-min) (point)))) ; 0-based | |
847 | (gds-send (format "(%S eval %s %S %d %d %S)\n" | |
848 | client | |
849 | (if module (prin1-to-string module) "#f") | |
850 | port-name line column | |
851 | (buffer-substring-no-properties start end))))) | |
852 | ||
853 | (defun gds-eval-expression (expr &optional client) | |
854 | "Evaluate the supplied EXPR (a string)." | |
855 | (interactive "sEvaluate expression: \nP") | |
856 | (setq client (gds-choose-client client)) | |
857 | (gds-send (format "(%S eval #f \"Emacs expression\" 0 0 %S)\n" | |
858 | client expr))) | |
859 | ||
860 | (defun gds-eval-defun (&optional client) | |
861 | "Evaluate the defun (top-level form) at point." | |
862 | (interactive "P") | |
863 | (save-excursion | |
864 | (end-of-defun) | |
865 | (let ((end (point))) | |
866 | (beginning-of-defun) | |
867 | (gds-eval-region (point) end client)))) | |
868 | ||
869 | (defun gds-eval-last-sexp (&optional client) | |
870 | "Evaluate the sexp before point." | |
871 | (interactive "P") | |
872 | (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client)) | |
873 | ||
9f1af5d9 NJ |
874 | |
875 | ;;;; Help. | |
876 | ||
877 | ;; Help is implemented as a special case of evaluation, where we | |
878 | ;; arrange for the evaluation result to be a known symbol that is | |
879 | ;; unlikely to crop up otherwise. When the evaluation result is this | |
880 | ;; symbol, we only display the output from the evaluation. | |
881 | ||
882 | (defvar gds-help-symbol '%-gds-help-% | |
883 | "Symbol used by GDS to identify an evaluation response as help.") | |
884 | ||
885 | (defun gds-help-symbol (sym &optional client) | |
886 | "Get help for SYM (a Scheme symbol)." | |
887 | (interactive "SHelp for symbol: \nP") | |
888 | (gds-eval-expression (format "(begin (help %S) '%S)" sym gds-help-symbol) | |
889 | client)) | |
890 | ||
891 | (defun gds-help-symbol-here (&optional client) | |
892 | (interactive "P") | |
893 | (gds-help-symbol (thing-at-point 'symbol) client)) | |
894 | ||
895 | (defun gds-apropos (regex &optional client) | |
896 | "List Guile symbols matching REGEX." | |
897 | (interactive "sApropos Guile regex: \nP") | |
898 | (gds-eval-expression (format "(begin (apropos %S) '%S)" regex gds-help-symbol) | |
899 | client)) | |
900 | ||
901 | ||
902 | ;;;; Display of evaluation and help results. | |
903 | ||
904 | (defun gds-display-results (client results) | |
905 | (let ((helpp (and (= (length results) 2) | |
906 | (= (length (cadr results)) 1) | |
907 | (string-equal (caadr results) | |
908 | (prin1-to-string gds-help-symbol))))) | |
909 | (let ((buf (get-buffer-create (if helpp | |
910 | "*Guile Help*" | |
911 | "*Guile Results*")))) | |
912 | (save-excursion | |
913 | (set-buffer buf) | |
914 | (erase-buffer) | |
915 | (while results | |
916 | (insert (car results)) | |
917 | (if helpp | |
918 | nil | |
919 | (mapcar (function (lambda (value) | |
920 | (insert " => " value "\n"))) | |
921 | (cadr results)) | |
922 | (insert "\n")) | |
923 | (setq results (cddr results))) | |
924 | (goto-char (point-min)) | |
925 | (if (and helpp (looking-at "Evaluating in ")) | |
926 | (delete-region (point) (progn (forward-line 1) (point))))) | |
927 | (pop-to-buffer buf) | |
928 | (run-hooks 'temp-buffer-show-hook) | |
929 | (other-window 1)))) | |
930 | ||
931 | ||
932 | ;;;; Loading (evaluating) a whole Scheme file. | |
933 | ||
41a80feb NJ |
934 | (defcustom gds-source-modes '(scheme-mode) |
935 | "*Used to determine if a buffer contains Scheme source code. | |
936 | If it's loaded into a buffer that is in one of these major modes, it's | |
937 | considered a scheme source file by `gds-load-file'." | |
938 | :type '(repeat function) | |
939 | :group 'gds) | |
940 | ||
941 | (defvar gds-prev-load-dir/file nil | |
942 | "Holds the last (directory . file) pair passed to `gds-load-file'. | |
943 | Used for determining the default for the next `gds-load-file'.") | |
944 | ||
945 | (defun gds-load-file (file-name &optional client) | |
946 | "Load a Scheme file into the inferior Scheme process." | |
947 | (interactive (list (car (comint-get-source "Load Scheme file: " | |
948 | gds-prev-load-dir/file | |
949 | gds-source-modes t)) | |
950 | ; T because LOAD needs an | |
951 | ; exact name | |
952 | current-prefix-arg)) | |
953 | (comint-check-source file-name) ; Check to see if buffer needs saved. | |
954 | (setq gds-prev-load-dir/file (cons (file-name-directory file-name) | |
955 | (file-name-nondirectory file-name))) | |
956 | (setq client (gds-choose-client client)) | |
957 | (gds-send (format "(%S load %S)\n" client file-name))) | |
958 | ||
959 | ;; Install the process communication commands in the scheme-mode keymap. | |
960 | (define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention | |
961 | (define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention | |
962 | (define-key scheme-mode-map "\C-c\C-e" 'gds-eval-defun) | |
963 | (define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) | |
964 | (define-key scheme-mode-map "\C-c\C-l" 'gds-load-file) | |
965 | ||
966 | ||
967 | ;;;; Menu bar entries. | |
968 | ||
969 | (defvar gds-debug-menu nil | |
970 | "GDS debugging menu.") | |
971 | (if gds-debug-menu | |
972 | nil | |
973 | (setq gds-debug-menu (make-sparse-keymap "Debug")) | |
974 | (define-key gds-debug-menu [go] | |
975 | '(menu-item "Go" gds-go)) | |
976 | (define-key gds-debug-menu [trace-finish] | |
977 | '(menu-item "Trace This Frame" gds-trace-finish)) | |
978 | (define-key gds-debug-menu [step-out] | |
979 | '(menu-item "Finish This Frame" gds-step-out)) | |
980 | (define-key gds-debug-menu [next] | |
981 | '(menu-item "Next" gds-next)) | |
982 | (define-key gds-debug-menu [step-in] | |
983 | '(menu-item "Single Step" gds-step-in)) | |
984 | (define-key gds-debug-menu [eval] | |
985 | '(menu-item "Eval In This Frame..." gds-evaluate))) | |
986 | ||
987 | (defvar gds-eval-menu nil | |
988 | "GDS evaluation menu.") | |
989 | (if gds-eval-menu | |
990 | nil | |
991 | (setq gds-eval-menu (make-sparse-keymap "Evaluate")) | |
992 | (define-key gds-eval-menu [load-file] | |
993 | '(menu-item "Load Scheme File" gds-load-file)) | |
994 | (define-key gds-eval-menu [defun] | |
995 | '(menu-item "Defun At Point" gds-eval-defun)) | |
996 | (define-key gds-eval-menu [region] | |
997 | '(menu-item "Region" gds-eval-region)) | |
998 | (define-key gds-eval-menu [last-sexp] | |
999 | '(menu-item "Sexp Before Point" gds-eval-last-sexp)) | |
1000 | (define-key gds-eval-menu [expr] | |
1001 | '(menu-item "Expression..." gds-eval-expression))) | |
1002 | ||
1003 | (defvar gds-help-menu nil | |
1004 | "GDS help menu.") | |
1005 | (if gds-help-menu | |
1006 | nil | |
1007 | (setq gds-help-menu (make-sparse-keymap "Help")) | |
1008 | (define-key gds-help-menu [apropos] | |
1009 | '(menu-item "Apropos..." gds-apropos)) | |
1010 | (define-key gds-help-menu [sym-here] | |
1011 | '(menu-item "Symbol At Point" gds-help-symbol-here)) | |
1012 | (define-key gds-help-menu [sym] | |
1013 | '(menu-item "Symbol..." gds-help-symbol))) | |
1014 | ||
1015 | (defvar gds-advanced-menu nil | |
1016 | "Menu of rarely needed GDS operations.") | |
1017 | (if gds-advanced-menu | |
1018 | nil | |
1019 | (setq gds-advanced-menu (make-sparse-keymap "Advanced")) | |
9f1af5d9 NJ |
1020 | (define-key gds-advanced-menu [run-captive] |
1021 | '(menu-item "Run Captive Guile" gds-start-captive | |
1022 | :enable (not (comint-check-proc gds-captive)))) | |
41a80feb NJ |
1023 | (define-key gds-advanced-menu [restart-gds] |
1024 | '(menu-item "Restart IDE" gds-start :enable gds-process)) | |
1025 | (define-key gds-advanced-menu [kill-gds] | |
1026 | '(menu-item "Shutdown IDE" gds-shutdown :enable gds-process)) | |
1027 | (define-key gds-advanced-menu [start-gds] | |
1028 | '(menu-item "Start IDE" gds-start :enable (not gds-process)))) | |
1029 | ||
1030 | (defvar gds-menu nil | |
1031 | "Global menu for GDS commands.") | |
1032 | (if gds-menu | |
1033 | nil | |
1034 | (setq gds-menu (make-sparse-keymap "Guile")) | |
1035 | (define-key gds-menu [advanced] | |
1036 | (cons "Advanced" gds-advanced-menu)) | |
1037 | (define-key gds-menu [separator-1] | |
1038 | '("--")) | |
41a80feb NJ |
1039 | (define-key gds-menu [debug] |
1040 | `(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client | |
1041 | (gds-client-waiting)))) | |
9f1af5d9 NJ |
1042 | (define-key gds-menu [eval] |
1043 | `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-names | |
1044 | gds-autostart-captive))) | |
1045 | (define-key gds-menu [help] | |
1046 | `(menu-item "Help" ,gds-help-menu :enable (or gds-names | |
1047 | gds-autostart-captive))) | |
41a80feb NJ |
1048 | (setq menu-bar-final-items |
1049 | (cons 'guile menu-bar-final-items)) | |
1050 | (define-key global-map [menu-bar guile] | |
1051 | (cons "Guile" gds-menu))) | |
1052 | ||
9f1af5d9 | 1053 | |
41a80feb NJ |
1054 | ;;;; Autostarting the GDS server. |
1055 | ||
1056 | (defcustom gds-autostart-server t | |
1057 | "Whether to automatically start the GDS server when `gds.el' is loaded." | |
1058 | :type 'boolean | |
1059 | :group 'gds) | |
1060 | ||
1061 | (if (and gds-autostart-server | |
1062 | (not gds-process)) | |
1063 | (gds-start)) | |
1064 | ||
9f1af5d9 NJ |
1065 | |
1066 | ;;;; `Captive' Guile - a Guile process that is started when needed to | |
1067 | ;;;; provide help, completion, evaluations etc. | |
1068 | ||
1069 | (defcustom gds-autostart-captive t | |
1070 | "Whether to automatically start a `captive' Guile process when needed." | |
1071 | :type 'boolean | |
1072 | :group 'gds) | |
1073 | ||
1074 | (defvar gds-captive nil | |
1075 | "Buffer of captive Guile.") | |
1076 | ||
1077 | (defun gds-start-captive (&optional restart) | |
1078 | (interactive) | |
1079 | (if (and restart | |
1080 | (comint-check-proc gds-captive)) | |
1081 | (gds-kill-captive)) | |
1082 | (if (comint-check-proc gds-captive) | |
1083 | nil | |
1084 | (let ((process-connection-type nil)) | |
1085 | (setq gds-captive (make-comint "captive-guile" | |
1086 | "guile" | |
1087 | nil | |
1088 | "-q"))) | |
1089 | (let ((proc (get-buffer-process gds-captive))) | |
1090 | (comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n") | |
1091 | (comint-send-string proc "(debug-enable 'backtrace)\n") | |
1092 | (comint-send-string proc "(use-modules (ice-9 debugger ui-client))\n") | |
1093 | (comint-send-string proc "(ui-connect \"Captive Guile\" #f)\n")))) | |
1094 | ||
1095 | (defun gds-kill-captive () | |
1096 | (if gds-captive | |
1097 | (let ((proc (get-buffer-process gds-captive))) | |
1098 | (process-kill-without-query proc) | |
1099 | (condition-case nil | |
1100 | (progn | |
1101 | (kill-process gds-process) | |
1102 | (accept-process-output gds-process 0 200)) | |
1103 | (error))))) | |
1104 | ||
1105 | ||
1106 | ;;;; The end! | |
1107 | ||
41a80feb NJ |
1108 | (provide 'gds) |
1109 | ||
1110 | ;;; gds.el ends here. |