40 |
:group 'scheme) |
:group 'scheme) |
41 |
|
|
42 |
|
|
43 |
;;;; Communication with the (ice-9 debugger ui-server) subprocess. |
;;;; Communication with the (emacs gds-server) subprocess. |
44 |
|
|
45 |
;; The subprocess object. |
;; The subprocess object. |
46 |
(defvar gds-process nil) |
(defvar gds-process nil) |
63 |
"guile" |
"guile" |
64 |
"-q" |
"-q" |
65 |
"--debug" |
"--debug" |
66 |
"-e" |
"-c" |
67 |
"run" |
"(begin (use-modules (emacs gds-server)) (run-server))")))) |
|
"-s" |
|
|
"/home/neil/Guile/cvs/guile-core/ice-9/debugger/ui-server.scm")))) |
|
68 |
(setq gds-read-cursor (point-min)) |
(setq gds-read-cursor (point-min)) |
69 |
(set-process-filter gds-process (function gds-filter)) |
(set-process-filter gds-process (function gds-filter)) |
70 |
(set-process-sentinel gds-process (function gds-sentinel)) |
(set-process-sentinel gds-process (function gds-sentinel)) |
74 |
(defun gds-shutdown () |
(defun gds-shutdown () |
75 |
"Shut down the GDS subprocess." |
"Shut down the GDS subprocess." |
76 |
(interactive) |
(interactive) |
77 |
;; Do cleanup for all clients. |
;; Reset variables. |
78 |
(while gds-names |
(setq gds-buffers nil |
79 |
(gds-client-cleanup (caar gds-names))) |
gds-focus-client nil |
|
;; Reset any remaining variables. |
|
|
(setq gds-displayed-client nil |
|
80 |
gds-waiting nil) |
gds-waiting nil) |
|
;; If the timer is running, cancel it. |
|
|
(if gds-timer |
|
|
(cancel-timer gds-timer)) |
|
|
(setq gds-timer nil) |
|
81 |
;; Kill the subprocess. |
;; Kill the subprocess. |
82 |
(process-kill-without-query gds-process) |
(process-kill-without-query gds-process) |
83 |
(condition-case nil |
(condition-case nil |
118 |
|
|
119 |
;;;; Multiple application scheduling. |
;;;; Multiple application scheduling. |
120 |
|
|
121 |
;; At any moment one Guile application has the focus of the frontend |
;; Here is how we schedule the display of multiple clients that are |
122 |
;; code. `gds-displayed-client' holds the port number of that client. |
;; competing for user attention. |
|
;; If there are no Guile applications wanting the focus - that is, |
|
|
;; ready for instructions - `gds-displayed-client' is nil. |
|
|
(defvar gds-displayed-client nil) |
|
|
|
|
|
;; The list of other Guile applications waiting for focus, referenced |
|
|
;; by their port numbers. |
|
|
(defvar gds-waiting nil) |
|
|
|
|
|
;; An idle timer that we use to avoid confusing any user work when |
|
|
;; popping up debug buffers. `gds-timer' is non-nil whenever the |
|
|
;; timer is running and nil whenever it is not running. |
|
|
(defvar gds-timer nil) |
|
|
|
|
|
;; Debug the specified client. If it already has the focus, do so |
|
|
;; immediately, but using the idle timer to ensure that it doesn't |
|
|
;; confuse any work the user may be doing. Non-structural work is |
|
|
;; delegated to `gds-display-state'. |
|
|
(defun gds-debug (&optional client) |
|
|
(dmessage "gds-debug") |
|
|
;; If `client' is specified, add it to the end of `gds-waiting', |
|
|
;; unless that client is already the current client or it is already |
|
|
;; in the waiting list. |
|
|
(if (and client |
|
|
(not (eq client gds-displayed-client)) |
|
|
(not (memq client gds-waiting))) |
|
|
(setq gds-waiting (append gds-waiting (list client)))) |
|
|
;; Now update `client' to be the next client in the list. |
|
|
(setq client (or gds-displayed-client (car gds-waiting))) |
|
|
;; If conditions are right, start the idle timer. |
|
|
(if (and client |
|
|
(or (null gds-displayed-client) |
|
|
(eq gds-displayed-client client))) |
|
|
(gds-display-state (or gds-displayed-client |
|
|
(prog1 (car gds-waiting) |
|
|
(setq gds-waiting |
|
|
(cdr gds-waiting))))))) |
|
|
|
|
|
;; Give up focus because debugging is done for now. Display detail in |
|
|
;; case of no waiting clients is delegated to `gds-clear-display'. |
|
|
(defun gds-focus-done () |
|
|
(gds-clear-display) |
|
|
(gds-debug)) |
|
|
|
|
|
;; Although debugging of this client isn't done, yield focus to the |
|
|
;; next waiting client. |
|
|
(defun gds-focus-yield () |
|
|
(interactive) |
|
|
(if (and (null gds-waiting) |
|
|
(y-or-n-p "No other clients waiting - bury *Guile* buffer? ")) |
|
|
(bury-buffer) |
|
|
(or (memq gds-displayed-client gds-waiting) |
|
|
(setq gds-waiting (append gds-waiting (list gds-displayed-client)))) |
|
|
(gds-focus-done))) |
|
|
|
|
|
|
|
|
;;;; Per-client state information. |
|
|
|
|
|
;; Alist mapping client port numbers to application names. The names |
|
|
;; in this list have been uniquified by `gds-uniquify'. |
|
|
(defvar gds-names nil) |
|
|
|
|
|
;; Return unique form of NAME. |
|
|
(defun gds-uniquify (name) |
|
|
(let ((count 1) |
|
|
(maybe-unique name)) |
|
|
(while (member maybe-unique (mapcar (function cdr) gds-names)) |
|
|
(setq count (1+ count) |
|
|
maybe-unique (concat name "<" (number-to-string count) ">"))) |
|
|
maybe-unique)) |
|
|
|
|
|
;; Alist mapping client port numbers to last known status. |
|
123 |
;; |
;; |
124 |
;; Status is one of the following symbols. |
;; - `gds-waiting' holds a list of clients that want attention but |
125 |
|
;; haven't yet got it. A client is added to this list for two |
126 |
|
;; reasons. (1) When it is blocked waiting for user input. (2) When |
127 |
|
;; it first connects to GDS, even if not blocked. |
128 |
;; |
;; |
129 |
;; `running' - application is running. |
;; - `gds-focus-client' holds the client, if any, that currently has |
130 |
;; |
;; the user's attention. A client can be given the focus if |
131 |
;; `waiting-for-input' - application is blocked waiting for |
;; `gds-focus-client' is nil at the time that the client wants |
132 |
;; instruction from the frontend. |
;; attention, or if another client relinquishes it. A client can |
133 |
;; |
;; relinquish the focus in two ways. (1) If the client application |
134 |
;; `ready-for-input' - application is not blocked but can also |
;; says that it is no longer blocked, and a small time passes without |
135 |
;; accept asynchronous instructions from the frontend. |
;; it becoming blocked again. (2) If the user explicitly `quits' that |
136 |
;; |
;; client. |
137 |
(defvar gds-statuses nil) |
(defvar gds-focus-client nil) |
138 |
|
(defvar gds-waiting nil) |
|
;; Alist mapping client port numbers to last printed outputs. |
|
|
(defvar gds-outputs nil) |
|
|
|
|
|
;; Alist mapping client port numbers to last known stacks. |
|
|
(defvar gds-stacks nil) |
|
|
|
|
|
;; Alist mapping client port numbers to module information. This |
|
|
;; looks like: |
|
|
;; |
|
|
;; ((4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) ...) |
|
|
;; |
|
|
;; So, for example: |
|
|
;; |
|
|
;; (assq client gds-modules) |
|
|
;; => |
|
|
;; (4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) |
|
|
;; |
|
|
;; The t or nil after the module name indicates whether the module is |
|
|
;; 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. |
|
|
(defvar gds-modules nil) |
|
|
|
|
|
|
|
|
;;;; Handling debugging instructions. |
|
|
|
|
|
;; General dispatch function called by the subprocess filter. |
|
|
(defun gds-handle-input (form) |
|
|
(dmessage "Form: %S" form) |
|
|
(let ((client (car form))) |
|
|
(cond ((eq client '*)) |
|
|
(t |
|
|
(let ((proc (cadr form))) |
|
139 |
|
|
140 |
(cond ((eq proc 'name) |
;; Sometimes we want to display a client buffer immediately even if it |
141 |
;; (name ...) - Application's name. |
;; isn't already in the selected window. To do we this, we bind the |
142 |
(setq gds-names |
;; following variable to non-nil. |
143 |
(cons (cons client (gds-uniquify (caddr form))) |
(defvar gds-immediate-display nil) |
144 |
gds-names))) |
|
145 |
|
(defun gds-request-focus (client) |
146 |
((eq proc 'stack) |
(cond ((eq client gds-focus-client) |
147 |
;; (stack ...) - Stack at an error or breakpoint. |
;; CLIENT already has the focus. Display its buffer. |
148 |
(gds-set gds-stacks client (cddr form))) |
(gds-display-buffers)) |
149 |
|
(gds-focus-client |
150 |
((eq proc 'modules) |
;; Another client has the focus. Add CLIENT to `gds-waiting'. |
151 |
;; (modules ...) - Application's loaded modules. |
(or (memq client gds-waiting) |
152 |
(gds-set gds-modules client |
(setq gds-waiting (append gds-waiting (list client))))) |
153 |
(mapcar (function list) (cddr form)))) |
(t |
154 |
|
;; Give focus to CLIENT and display its buffer. |
155 |
((eq proc 'output) |
(setq gds-focus-client client) |
156 |
;; (output ...) - Last printed output. |
(gds-display-buffers)))) |
|
(gds-set gds-outputs client (caddr form))) |
|
|
|
|
|
((eq proc 'status) |
|
|
;; (status ...) - Application status indication. |
|
|
(let ((status (caddr form))) |
|
|
(gds-set gds-statuses client status) |
|
|
(cond ((eq status 'waiting-for-input) |
|
|
(gds-debug client)) |
|
|
((or (eq status 'running) |
|
|
(eq status 'ready-for-input)) |
|
|
(if (eq client gds-displayed-client) |
|
|
(gds-display-state client))) |
|
|
(t |
|
|
(error "Unexpected status: %S" status))))) |
|
|
|
|
|
((eq proc 'module) |
|
|
;; (module MODULE ...) - The specified module's bindings. |
|
|
(let* ((modules (assq client gds-modules)) |
|
|
(minfo (assoc (caddr form) modules))) |
|
|
(if minfo |
|
|
(setcdr (cdr minfo) (cdddr form))))) |
|
|
|
|
|
((eq proc 'closed) |
|
|
;; (closed) - Client has gone away. |
|
|
(gds-client-cleanup client)) |
|
|
|
|
|
((eq proc 'eval-results) |
|
|
;; (eval-results ...) - Results of evaluation. |
|
|
(gds-display-results client (cddr form))) |
|
|
|
|
|
)))))) |
|
|
|
|
|
;; Store latest status, stack or module list for the specified client. |
|
|
(defmacro gds-set (alist client val) |
|
|
`(let ((existing (assq ,client ,alist))) |
|
|
(if existing |
|
|
(setcdr existing ,val) |
|
|
(setq ,alist |
|
|
(cons (cons client ,val) ,alist))))) |
|
|
|
|
|
;; Cleanup processing when CLIENT goes away. |
|
|
(defun gds-client-cleanup (client) |
|
|
(if (eq client gds-displayed-client) |
|
|
(gds-focus-done)) |
|
|
(setq gds-names |
|
|
(delq (assq client gds-names) gds-names)) |
|
|
(setq gds-stacks |
|
|
(delq (assq client gds-stacks) gds-stacks)) |
|
|
(setq gds-modules |
|
|
(delq (assq client gds-modules) gds-modules))) |
|
157 |
|
|
158 |
|
;; Explicitly give up focus. |
159 |
|
(defun gds-quit () |
160 |
|
(interactive) |
161 |
|
(if (or (car gds-waiting) |
162 |
|
(not (gds-client-blocked)) |
163 |
|
(y-or-n-p |
164 |
|
"Client is blocked and no others are waiting. Still quit? ")) |
165 |
|
(let ((gds-immediate-display |
166 |
|
(eq (window-buffer (selected-window)) (current-buffer)))) |
167 |
|
(bury-buffer (current-buffer)) |
168 |
|
;; Pass on the focus. |
169 |
|
(setq gds-focus-client (car gds-waiting) |
170 |
|
gds-waiting (cdr gds-waiting)) |
171 |
|
;; If this client is blocked, add it back into the waiting list. |
172 |
|
(if (gds-client-blocked) |
173 |
|
(gds-request-focus gds-client)) |
174 |
|
;; If there is a new focus client, request display for it. |
175 |
|
(if gds-focus-client |
176 |
|
(gds-request-focus gds-focus-client))))) |
177 |
|
|
|
;;;; Displaying debugging information. |
|
178 |
|
|
179 |
(defvar gds-client-buffer nil) |
;;;; Per-client buffer state. |
180 |
|
|
181 |
(define-derived-mode gds-mode |
(define-derived-mode gds-mode |
182 |
fundamental-mode |
scheme-mode |
183 |
"Guile" |
"Guile Interaction" |
184 |
"Major mode for Guile information buffers.") |
"Major mode for interacting with a Guile client application.") |
185 |
|
|
186 |
(defun gds-set-client-buffer (&optional client) |
(defvar gds-client nil |
187 |
(if (and gds-client-buffer |
"GDS client's port number.") |
188 |
(buffer-live-p gds-client-buffer)) |
(make-variable-buffer-local 'gds-client) |
189 |
(set-buffer gds-client-buffer) |
|
190 |
(setq gds-client-buffer (get-buffer-create "*Guile*")) |
(defvar gds-current-module "()" |
191 |
(set-buffer gds-client-buffer) |
"GDS client's current module.") |
192 |
(gds-mode)) |
(make-variable-buffer-local 'gds-current-module) |
193 |
;; Rename to something we don't want first. Otherwise, if the |
|
194 |
;; buffer is already correctly named, we get a confusing change |
(defvar gds-stack nil |
195 |
;; from, say, `*Guile: REPL*' to `*Guile: REPL*<2>'. |
"GDS client's stack when last stopped.") |
196 |
(rename-buffer "*Guile Fake Buffer Name*" t) |
(make-variable-buffer-local 'gds-stack) |
197 |
(rename-buffer (if client |
|
198 |
(concat "*Guile: " |
(defvar gds-modules nil |
199 |
(cdr (assq client gds-names)) |
"GDS client's module information. |
200 |
"*") |
Alist mapping module names to their symbols and related information. |
201 |
"*Guile*") |
This looks like: |
202 |
t) ; Rename uniquely if needed, |
|
203 |
; although it shouldn't be. |
(((guile) t sym1 sym2 ...) |
204 |
(force-mode-line-update t)) |
((guile-user)) |
205 |
|
((ice-9 debug) nil sym3 sym4) |
206 |
(defun gds-clear-display () |
...) |
207 |
;; Clear the client buffer. |
|
208 |
(gds-set-client-buffer) |
The `t' or `nil' after the module name indicates whether the module is |
209 |
(let ((inhibit-read-only t)) |
displayed in expanded form (that is, showing the bindings in that |
210 |
(erase-buffer) |
module). The syms are actually all strings because some Guile symbols |
211 |
(insert "Stack:\nNo clients ready for debugging.\n") |
are not readable by Emacs.") |
212 |
(goto-char (point-min))) |
(make-variable-buffer-local 'gds-modules) |
213 |
(setq gds-displayed-stack 'no-clients) |
|
214 |
(setq gds-displayed-modules nil) |
(defvar gds-output nil |
215 |
(setq gds-displayed-client nil) |
"GDS client's recent output (printed).") |
216 |
(bury-buffer)) |
(make-variable-buffer-local 'gds-output) |
217 |
|
|
218 |
;; Determine whether the client display buffer is visible in the |
(defvar gds-status nil |
219 |
;; currently selected frame (i.e. where the user is editing). |
"GDS client's latest status, one of the following symbols. |
220 |
(defun gds-buffer-visible-in-selected-frame-p () |
|
221 |
(let ((visible-p nil)) |
`running' - application is running. |
222 |
(walk-windows (lambda (w) |
|
223 |
(if (eq (window-buffer w) gds-client-buffer) |
`waiting-for-input' - application is blocked waiting for instruction |
224 |
(setq visible-p t)))) |
from the frontend. |
225 |
visible-p)) |
|
226 |
|
`ready-for-input' - application is not blocked but can also accept |
227 |
|
asynchronous instructions from the frontend.") |
228 |
|
(make-variable-buffer-local 'gds-status) |
229 |
|
|
230 |
|
(defvar gds-pid nil |
231 |
|
"GDS client's process ID.") |
232 |
|
(make-variable-buffer-local 'gds-pid) |
233 |
|
|
234 |
|
(defvar gds-debug-exceptions nil |
235 |
|
"Whether to debug exceptions.") |
236 |
|
(make-variable-buffer-local 'gds-debug-exceptions) |
237 |
|
|
238 |
|
(defvar gds-exception-keys "signal misc-error" |
239 |
|
"The exception keys for which to debug a GDS client.") |
240 |
|
(make-variable-buffer-local 'gds-exception-keys) |
241 |
|
|
242 |
;; Cached display variables for `gds-display-state'. |
;; Cached display variables for `gds-update-buffers'. |
|
(defvar gds-displayed-stack nil) |
|
243 |
(defvar gds-displayed-modules nil) |
(defvar gds-displayed-modules nil) |
244 |
|
(make-variable-buffer-local 'gds-displayed-modules) |
245 |
|
|
246 |
;; Types of display areas in the *Guile* buffer. |
;; Types of display areas in the *Guile* buffer. |
247 |
(defvar gds-display-types '("Status" "Stack" "Modules")) |
(defvar gds-display-types '("\\`" |
248 |
|
"^Modules:" |
249 |
|
"^Transcript:")) |
250 |
(defvar gds-display-type-regexp |
(defvar gds-display-type-regexp |
251 |
(concat "^\\(" |
(concat "\\(" |
252 |
(substring (apply (function concat) |
(substring (apply (function concat) |
253 |
(mapcar (lambda (type) |
(mapcar (lambda (type) |
254 |
(concat "\\|" type)) |
(concat "\\|" type)) |
255 |
gds-display-types)) |
gds-display-types)) |
256 |
2) |
2) |
257 |
"\\):")) |
"\\)")) |
258 |
|
|
259 |
(defun gds-maybe-delete-region (type) |
(defun gds-maybe-delete-region (regexp) |
260 |
(let ((beg (save-excursion |
(let ((beg (save-excursion |
261 |
(goto-char (point-min)) |
(goto-char (point-min)) |
262 |
(and (re-search-forward (concat "^" |
(and (re-search-forward regexp nil t) |
|
(regexp-quote type) |
|
|
":") |
|
|
nil t) |
|
263 |
(match-beginning 0))))) |
(match-beginning 0))))) |
264 |
(if beg |
(if beg |
265 |
(delete-region beg |
(delete-region beg |
271 |
(match-beginning 0)) |
(match-beginning 0)) |
272 |
(point-max))))))) |
(point-max))))))) |
273 |
|
|
274 |
(defun gds-maybe-skip-region (type) |
(defun gds-maybe-skip-region (regexp) |
275 |
(if (looking-at (regexp-quote type)) |
(if (looking-at regexp) |
276 |
(if (re-search-forward gds-display-type-regexp nil t 2) |
(if (re-search-forward gds-display-type-regexp nil t 2) |
277 |
(beginning-of-line) |
(beginning-of-line) |
278 |
(goto-char (point-max))))) |
(goto-char (point-max))))) |
279 |
|
|
280 |
(defun gds-display-state (client) |
(defun gds-update-buffers (client) |
281 |
(dmessage "gds-display-state") |
(dmessage "gds-update-buffers") |
282 |
;; Avoid continually popping up the last associated source buffer |
;; Avoid continually popping up the last associated source buffer |
283 |
;; unless it really is still current. |
;; unless it really is still current. |
284 |
(setq gds-selected-frame-source-buffer nil) |
(setq gds-selected-frame-source-buffer nil) |
285 |
(gds-set-client-buffer client) |
(set-buffer (cdr (assq client gds-buffers))) |
286 |
(let ((stack (cdr (assq client gds-stacks))) |
(force-mode-line-update t) |
287 |
(modules (cdr (assq client gds-modules))) |
(let ((inhibit-read-only t) |
288 |
(inhibit-read-only t) |
(p (if (eq client gds-focus-client) |
|
(p (if (eq client gds-displayed-client) |
|
289 |
(point) |
(point) |
290 |
(point-min))) |
(point-min))) |
291 |
stack-changed) |
stack-changed) |
292 |
;; Start at top of buffer. |
;; Start at top of buffer. |
293 |
(goto-char (point-min)) |
(goto-char (point-min)) |
294 |
;; Display status; too simple to be worth caching. |
;; Display status; too simple to be worth caching. |
295 |
(gds-maybe-delete-region "Status") |
(gds-maybe-delete-region (concat "\\`" (regexp-quote (buffer-name)))) |
296 |
(widget-insert "Status: " |
(widget-insert (buffer-name) |
297 |
(cdr (assq (cdr (assq client gds-statuses)) |
", " |
298 |
|
(cdr (assq gds-status |
299 |
'((running . "running (cannot accept input)") |
'((running . "running (cannot accept input)") |
300 |
(waiting-for-input . "waiting for input") |
(waiting-for-input . "waiting for input") |
301 |
(ready-for-input . "running")))) |
(ready-for-input . "running") |
302 |
"\n\n") |
(closed . "closed")))) |
303 |
(let ((output (cdr (assq client gds-outputs)))) |
", in " |
304 |
(if (> (length output) 0) |
gds-current-module |
305 |
(widget-insert output "\n\n"))) |
"\n") |
306 |
|
(widget-create 'push-button |
307 |
|
:notify (function gds-sigint) |
308 |
|
"SIGINT") |
309 |
|
(widget-insert " ") |
310 |
|
(widget-create 'push-button |
311 |
|
:notify (function gds-async-break) |
312 |
|
"Break") |
313 |
|
(widget-insert "\n") |
314 |
|
(widget-create 'checkbox |
315 |
|
:notify (function gds-toggle-debug-exceptions) |
316 |
|
gds-debug-exceptions) |
317 |
|
(widget-insert " Debug exception keys: ") |
318 |
|
(widget-create 'editable-field |
319 |
|
:notify (function gds-set-exception-keys) |
320 |
|
gds-exception-keys) |
321 |
|
(widget-insert "\n") |
322 |
|
; (widget-insert "\n\n") |
323 |
|
; (if (> (length gds-output) 0) |
324 |
|
; (widget-insert gds-output "\n\n")) |
325 |
;; Display stack. |
;; Display stack. |
326 |
(dmessage "insert stack") |
(dmessage "insert stack") |
327 |
(if (equal stack gds-displayed-stack) |
(let ((stack gds-stack) |
328 |
(gds-maybe-skip-region "Stack") |
(buf (get-buffer-create (concat (buffer-name) " - stack")))) |
329 |
;; Note that stack has changed. |
(with-current-buffer buf |
330 |
(if stack (setq stack-changed t)) |
(if (equal stack gds-stack) |
331 |
;; Delete existing stack. |
;; No change needed. |
332 |
(gds-maybe-delete-region "Stack") |
nil |
333 |
;; Insert new stack. |
(erase-buffer) |
334 |
(if stack (gds-insert-stack stack)) |
(gds-mode) |
335 |
;; Record displayed stack. |
;; Insert new stack. |
336 |
(setq gds-displayed-stack stack)) |
(if stack (gds-insert-stack stack)) |
337 |
|
;; Record displayed stack. |
338 |
|
(setq gds-stack stack)))) |
339 |
;; Display module list. |
;; Display module list. |
340 |
(dmessage "insert modules") |
(dmessage "insert modules") |
341 |
(if (equal modules gds-displayed-modules) |
(if (equal gds-modules gds-displayed-modules) |
342 |
(gds-maybe-skip-region "Modules") |
(gds-maybe-skip-region "^Modules:") |
343 |
;; Delete existing module list. |
;; Delete existing module list. |
344 |
(gds-maybe-delete-region "Modules") |
(gds-maybe-delete-region "^Modules:") |
345 |
;; Insert new list. |
;; Insert new list. |
346 |
(if modules (gds-insert-modules modules)) |
(if gds-modules (gds-insert-modules gds-modules)) |
347 |
;; Record displayed list. |
;; Record displayed list. |
348 |
(setq gds-displayed-modules (copy-tree modules))) |
(setq gds-displayed-modules (copy-tree gds-modules))) |
349 |
;; Finish off. |
;; Finish off. |
350 |
(dmessage "widget-setup") |
(dmessage "widget-setup") |
351 |
(widget-setup) |
(widget-setup) |
354 |
;; buffer is visible. |
;; buffer is visible. |
355 |
(progn |
(progn |
356 |
(goto-char (point-min)) |
(goto-char (point-min)) |
357 |
(re-search-forward "^Stack:") |
(forward-line (+ 1 (cadr gds-stack)))) |
|
(forward-line (+ 1 (cadr stack)))) |
|
358 |
;; Restore point from before buffer was redrawn. |
;; Restore point from before buffer was redrawn. |
359 |
(goto-char p))) |
(goto-char p)))) |
360 |
(setq gds-displayed-client client) |
|
361 |
(dmessage "consider display") |
(defun gds-sigint (w &rest ignore) |
362 |
(if (eq (window-buffer (selected-window)) gds-client-buffer) |
(interactive) |
363 |
;; *Guile* buffer already selected. |
(signal-process gds-pid 2)) |
364 |
(gds-display-buffers) |
|
365 |
(dmessage "Running GDS timer") |
(defun gds-async-break (w &rest ignore) |
366 |
(setq gds-timer |
(interactive) |
367 |
(run-with-idle-timer 0.5 |
(gds-send (format "(%S async-break)\n" gds-focus-client))) |
368 |
nil |
|
369 |
(lambda () |
(defun gds-toggle-debug-exceptions (w &rest ignore) |
370 |
(setq gds-timer nil) |
(interactive) |
371 |
(gds-display-buffers)))))) |
(setq gds-debug-exceptions (widget-value w)) |
372 |
|
(gds-eval-expression (concat "(use-modules (ice-9 debugger))" |
373 |
|
"(debug-on-error '(" |
374 |
|
gds-exception-keys |
375 |
|
"))"))) |
376 |
|
|
377 |
|
(defun gds-set-exception-keys (w &rest ignore) |
378 |
|
(interactive) |
379 |
|
(setq gds-exception-keys (widget-value w))) |
380 |
|
|
381 |
(defun gds-display-buffers () |
(defun gds-display-buffers () |
382 |
;; If there's already a window showing the *Guile* buffer, use |
(if gds-focus-client |
383 |
;; it. |
(let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers)))) |
384 |
(let ((window (get-buffer-window gds-client-buffer t))) |
;; If there's already a window showing the buffer, use it. |
385 |
(if window |
(let ((window (get-buffer-window gds-focus-buffer t))) |
386 |
(progn |
(if window |
387 |
(make-frame-visible (window-frame window)) |
(progn |
388 |
(raise-frame (window-frame window)) |
(make-frame-visible (window-frame window)) |
389 |
(select-frame (window-frame window)) |
(select-frame (window-frame window)) |
390 |
(select-window window)) |
(select-window window)) |
391 |
(switch-to-buffer gds-client-buffer))) |
;(select-window (display-buffer gds-focus-buffer)) |
392 |
;; If there is an associated source buffer, display it as well. |
(display-buffer gds-focus-buffer))) |
393 |
(if gds-selected-frame-source-buffer |
;; If there is an associated source buffer, display it as well. |
394 |
(let ((window (display-buffer gds-selected-frame-source-buffer))) |
(if gds-selected-frame-source-buffer |
395 |
(set-window-point window |
(let ((window (display-buffer gds-selected-frame-source-buffer))) |
396 |
(overlay-start gds-selected-frame-source-overlay)))) |
(set-window-point window |
397 |
;; Force redisplay. |
(overlay-start |
398 |
(sit-for 0)) |
gds-selected-frame-source-overlay)))) |
399 |
|
;; If there is a stack to display, display it. |
400 |
|
(if gds-stack |
401 |
|
(let ((buf (get-buffer (concat (buffer-name) " - stack")))) |
402 |
|
(if (get-buffer-window buf) |
403 |
|
nil |
404 |
|
(split-window) |
405 |
|
(set-window-buffer (selected-window) buf))))))) |
406 |
|
|
407 |
(defun gds-insert-stack (stack) |
(defun gds-insert-stack (stack) |
408 |
(let ((frames (car stack)) |
(let ((frames (car stack)) |
409 |
(index (cadr stack)) |
(index (cadr stack)) |
410 |
(flags (caddr stack)) |
(flags (caddr stack)) |
411 |
frame items) |
frame items) |
412 |
(widget-insert "Stack: " (prin1-to-string flags) "\n") |
(cond ((memq 'application flags) |
413 |
|
(widget-insert "Calling procedure:\n")) |
414 |
|
((memq 'evaluation flags) |
415 |
|
(widget-insert "Evaluating expression:\n")) |
416 |
|
((memq 'return flags) |
417 |
|
(widget-insert "Return value: " |
418 |
|
(cadr (memq 'return flags)) |
419 |
|
"\n")) |
420 |
|
(t |
421 |
|
(widget-insert "Stack: " (prin1-to-string flags) "\n"))) |
422 |
(let ((i -1)) |
(let ((i -1)) |
423 |
(gds-show-selected-frame (caddr (nth index frames))) |
(gds-show-selected-frame (caddr (nth index frames))) |
424 |
(while frames |
(while frames |
442 |
(let* ((s (widget-value widget)) |
(let* ((s (widget-value widget)) |
443 |
(ind (memq 'index (text-properties-at 0 s)))) |
(ind (memq 'index (text-properties-at 0 s)))) |
444 |
(gds-send (format "(%S debugger-command frame %d)\n" |
(gds-send (format "(%S debugger-command frame %d)\n" |
445 |
gds-displayed-client |
gds-focus-client |
446 |
(cadr ind))))) |
(cadr ind))))) |
447 |
|
|
448 |
;; Overlay used to highlight the source expression corresponding to |
;; Overlay used to highlight the source expression corresponding to |
527 |
(while syms |
(while syms |
528 |
(widget-insert " > " (car syms) "\n") |
(widget-insert " > " (car syms) "\n") |
529 |
(setq syms (cdr syms)))))))) |
(setq syms (cdr syms)))))))) |
530 |
(setq modules (cdr modules)))) |
(setq modules (cdr modules))) |
531 |
|
(insert "\n")) |
532 |
|
|
533 |
(defun gds-module-notify (w &rest ignore) |
(defun gds-module-notify (w &rest ignore) |
534 |
(let* ((module (widget-get w :module)) |
(let* ((module (widget-get w :module)) |
535 |
(client (car module)) |
(client (car module)) |
536 |
(name (cdr module)) |
(name (cdr module)) |
537 |
(modules (assq client gds-modules)) |
(minfo (assoc name gds-modules))) |
|
(minfo (assoc name modules))) |
|
538 |
(if (cdr minfo) |
(if (cdr minfo) |
539 |
;; Just toggle expansion state. |
;; Just toggle expansion state. |
540 |
(progn |
(progn |
541 |
(setcar (cdr minfo) (not (cadr minfo))) |
(setcar (cdr minfo) (not (cadr minfo))) |
542 |
(gds-display-state client)) |
(gds-update-buffers client)) |
543 |
;; Set flag to indicate module expanded. |
;; Set flag to indicate module expanded. |
544 |
(setcdr minfo (list t)) |
(setcdr minfo (list t)) |
545 |
;; Get symlist from Guile. |
;; Get symlist from Guile. |
546 |
(gds-send (format "(%S query-module %S)\n" client name))))) |
(gds-send (format "(%S query-module %S)\n" client name))))) |
547 |
|
|
548 |
|
(defun gds-query-modules () |
549 |
|
(interactive) |
550 |
|
(gds-send (format "(%S query-modules)\n" gds-focus-client))) |
551 |
|
|
552 |
|
|
553 |
|
;;;; Handling debugging instructions. |
554 |
|
|
555 |
|
;; Alist mapping each client port number to corresponding buffer. |
556 |
|
(defvar gds-buffers nil) |
557 |
|
|
558 |
|
;; Return client buffer for specified client and protocol input. |
559 |
|
(defun gds-client-buffer (client proc args) |
560 |
|
(if (eq proc 'name) |
561 |
|
;; Introduction from client - create a new buffer. |
562 |
|
(with-current-buffer (generate-new-buffer (car args)) |
563 |
|
(gds-mode) |
564 |
|
(insert "Transcript:\n") |
565 |
|
(setq gds-buffers |
566 |
|
(cons (cons client (current-buffer)) |
567 |
|
gds-buffers)) |
568 |
|
(current-buffer)) |
569 |
|
;; Otherwise there should be an existing buffer that we can |
570 |
|
;; return. |
571 |
|
(let ((existing (assq client gds-buffers))) |
572 |
|
(if (buffer-live-p (cdr existing)) |
573 |
|
(cdr existing) |
574 |
|
(setq gds-buffers (delq existing gds-buffers)) |
575 |
|
(gds-client-buffer client 'name '("(GDS buffer killed)")))))) |
576 |
|
|
577 |
|
;; General dispatch function called by the subprocess filter. |
578 |
|
(defun gds-handle-input (form) |
579 |
|
(dmessage "Form: %S" form) |
580 |
|
(let ((client (car form))) |
581 |
|
(or (eq client '*) |
582 |
|
(let* ((proc (cadr form)) |
583 |
|
(args (cddr form)) |
584 |
|
(buf (gds-client-buffer client proc args))) |
585 |
|
(if buf (gds-handle-client-input buf client proc args)))))) |
586 |
|
|
587 |
|
(defun gds-handle-client-input (buf client proc args) |
588 |
|
(with-current-buffer buf |
589 |
|
(save-excursion |
590 |
|
(goto-char (point-max)) |
591 |
|
(let ((inhibit-read-only t)) |
592 |
|
(insert (format "<%S %S %S>" client proc args) "\n"))) |
593 |
|
(dmessage "Buffer: %S" (current-buffer)) |
594 |
|
(cond (;; (name ...) - Client name. |
595 |
|
(eq proc 'name) |
596 |
|
(setq gds-pid (cadr args)) |
597 |
|
(gds-request-focus client)) |
598 |
|
|
599 |
|
(;; (current-module ...) - Current module. |
600 |
|
(eq proc 'current-module) |
601 |
|
(setq gds-current-module (car args)) |
602 |
|
(dmessage "Current module: %S" gds-current-module)) |
603 |
|
|
604 |
|
(;; (stack ...) - Stack at an error or breakpoint. |
605 |
|
(eq proc 'stack) |
606 |
|
(setq gds-stack args)) |
607 |
|
|
608 |
|
(;; (modules ...) - Application's loaded modules. |
609 |
|
(eq proc 'modules) |
610 |
|
(while args |
611 |
|
(or (assoc (car args) gds-modules) |
612 |
|
(setq gds-modules (cons (list (car args)) gds-modules))) |
613 |
|
(setq args (cdr args)))) |
614 |
|
|
615 |
|
(;; (output ...) - Last printed output. |
616 |
|
(eq proc 'output) |
617 |
|
(setq gds-output (car args))) |
618 |
|
|
619 |
|
(;; (status ...) - Application status indication. |
620 |
|
(eq proc 'status) |
621 |
|
(setq gds-status (car args)) |
622 |
|
(or (eq gds-status 'waiting-for-input) |
623 |
|
(setq gds-stack nil)) |
624 |
|
(gds-update-buffers client) |
625 |
|
(if (eq gds-status 'waiting-for-input) |
626 |
|
(gds-request-focus client) |
627 |
|
(setq gds-stack nil))) |
628 |
|
|
629 |
|
(;; (module MODULE ...) - The specified module's bindings. |
630 |
|
(eq proc 'module) |
631 |
|
(let ((minfo (assoc (car args) gds-modules))) |
632 |
|
(if minfo |
633 |
|
(setcdr (cdr minfo) (cdr args))))) |
634 |
|
|
635 |
|
(;; (closed) - Client has gone away. |
636 |
|
(eq proc 'closed) |
637 |
|
(setq gds-status 'closed) |
638 |
|
(gds-update-buffers client) |
639 |
|
(setq gds-buffers |
640 |
|
(delq (assq client gds-buffers) gds-buffers)) |
641 |
|
(if (eq client gds-focus-client) |
642 |
|
(gds-quit))) |
643 |
|
|
644 |
|
(;; (eval-results ...) - Results of evaluation. |
645 |
|
(eq proc 'eval-results) |
646 |
|
(gds-display-results client args)) |
647 |
|
|
648 |
|
((eq proc 'completion-result) |
649 |
|
(setq gds-completion-results (or (car args) t))) |
650 |
|
|
651 |
|
))) |
652 |
|
|
653 |
|
|
654 |
;;;; Guile Debugging keymap. |
;;;; Guile Debugging keymap. |
655 |
|
|
657 |
(define-key gds-mode-map "g" (function gds-go)) |
(define-key gds-mode-map "g" (function gds-go)) |
658 |
(define-key gds-mode-map "b" (function gds-set-breakpoint)) |
(define-key gds-mode-map "b" (function gds-set-breakpoint)) |
659 |
(define-key gds-mode-map "q" (function gds-quit)) |
(define-key gds-mode-map "q" (function gds-quit)) |
|
(define-key gds-mode-map "y" (function gds-yield)) |
|
660 |
(define-key gds-mode-map " " (function gds-next)) |
(define-key gds-mode-map " " (function gds-next)) |
661 |
(define-key gds-mode-map "e" (function gds-evaluate)) |
(define-key gds-mode-map "e" (function gds-evaluate)) |
662 |
(define-key gds-mode-map "i" (function gds-step-in)) |
(define-key gds-mode-map "i" (function gds-step-in)) |
663 |
(define-key gds-mode-map "o" (function gds-step-out)) |
(define-key gds-mode-map "o" (function gds-step-out)) |
664 |
(define-key gds-mode-map "t" (function gds-trace-finish)) |
(define-key gds-mode-map "t" (function gds-trace-finish)) |
665 |
|
(define-key gds-mode-map "I" (function gds-frame-info)) |
666 |
|
(define-key gds-mode-map "A" (function gds-frame-args)) |
667 |
|
(define-key gds-mode-map "M" (function gds-query-modules)) |
668 |
|
|
669 |
(defun gds-client-waiting () |
(defun gds-client-blocked () |
670 |
(eq (cdr (assq gds-displayed-client gds-statuses)) 'waiting-for-input)) |
(eq gds-status 'waiting-for-input)) |
671 |
|
|
672 |
(defun gds-go () |
(defun gds-go () |
673 |
(interactive) |
(interactive) |
674 |
(gds-send (format "(%S debugger-command continue)\n" gds-displayed-client))) |
(gds-send (format "(%S debugger-command continue)\n" gds-focus-client))) |
|
|
|
|
(defun gds-quit () |
|
|
(interactive) |
|
|
(if (gds-client-waiting) |
|
|
(if (y-or-n-p "Client is waiting for instruction - tell it to continue? ") |
|
|
(gds-go))) |
|
|
(gds-yield)) |
|
|
|
|
|
(defun gds-yield () |
|
|
(interactive) |
|
|
(if (gds-client-waiting) |
|
|
(gds-focus-yield) |
|
|
(gds-focus-done))) |
|
675 |
|
|
676 |
(defun gds-next () |
(defun gds-next () |
677 |
(interactive) |
(interactive) |
678 |
(gds-send (format "(%S debugger-command next 1)\n" gds-displayed-client))) |
(gds-send (format "(%S debugger-command next 1)\n" gds-focus-client))) |
679 |
|
|
680 |
(defun gds-evaluate (expr) |
(defun gds-evaluate (expr) |
681 |
(interactive "sEvaluate (in this stack frame): ") |
(interactive "sEvaluate (in this stack frame): ") |
682 |
(gds-send (format "(%S debugger-command evaluate %s)\n" |
(gds-send (format "(%S debugger-command evaluate %s)\n" |
683 |
gds-displayed-client |
gds-focus-client |
684 |
(prin1-to-string expr)))) |
(prin1-to-string expr)))) |
685 |
|
|
686 |
(defun gds-step-in () |
(defun gds-step-in () |
687 |
(interactive) |
(interactive) |
688 |
(gds-send (format "(%S debugger-command step 1)\n" gds-displayed-client))) |
(gds-send (format "(%S debugger-command step 1)\n" gds-focus-client))) |
689 |
|
|
690 |
(defun gds-step-out () |
(defun gds-step-out () |
691 |
(interactive) |
(interactive) |
692 |
(gds-send (format "(%S debugger-command finish)\n" gds-displayed-client))) |
(gds-send (format "(%S debugger-command finish)\n" gds-focus-client))) |
693 |
|
|
694 |
(defun gds-trace-finish () |
(defun gds-trace-finish () |
695 |
(interactive) |
(interactive) |
696 |
(gds-send (format "(%S debugger-command trace-finish)\n" |
(gds-send (format "(%S debugger-command trace-finish)\n" |
697 |
gds-displayed-client))) |
gds-focus-client))) |
698 |
|
|
699 |
|
(defun gds-frame-info () |
700 |
|
(interactive) |
701 |
|
(gds-send (format "(%S debugger-command info-frame)\n" gds-focus-client))) |
702 |
|
|
703 |
|
(defun gds-frame-args () |
704 |
|
(interactive) |
705 |
|
(gds-send (format "(%S debugger-command info-args)\n" gds-focus-client))) |
706 |
|
|
707 |
(defun gds-set-breakpoint () |
(defun gds-set-breakpoint () |
708 |
(interactive) |
(interactive) |
721 |
nil) |
nil) |
722 |
|
|
723 |
(defun gds-in-stack () |
(defun gds-in-stack () |
724 |
(and (eq (current-buffer) gds-client-buffer) |
(save-excursion |
725 |
(save-excursion |
(and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) |
726 |
(and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) |
(looking-at "Stack")))) |
|
(looking-at "Stack"))))) |
|
727 |
|
|
728 |
(defun gds-in-modules () |
(defun gds-in-modules () |
729 |
(and (eq (current-buffer) gds-client-buffer) |
(save-excursion |
730 |
(save-excursion |
(and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) |
731 |
(and (re-search-backward "^\\(Stack\\|Modules\\):" nil t) |
(looking-at "Modules")))) |
|
(looking-at "Modules"))))) |
|
732 |
|
|
733 |
(defun gds-set-module-breakpoint () |
(defun gds-set-module-breakpoint () |
734 |
(let ((sym (save-excursion |
(let ((sym (save-excursion |
755 |
nil |
nil |
756 |
"debug-here"))) |
"debug-here"))) |
757 |
(gds-send (format "(%S set-breakpoint %s %s %s)\n" |
(gds-send (format "(%S set-breakpoint %s %s %s)\n" |
758 |
gds-displayed-client |
gds-focus-client |
759 |
module |
module |
760 |
sym |
sym |
761 |
behaviour))))) |
behaviour))))) |
769 |
;; |
;; |
770 |
;; Where there are multiple Guile applications known to GDS, GDS by |
;; Where there are multiple Guile applications known to GDS, GDS by |
771 |
;; default sends code to the one that holds the debugging focus, |
;; default sends code to the one that holds the debugging focus, |
772 |
;; i.e. `gds-displayed-client'. Where no application has the focus, |
;; i.e. `gds-focus-client'. Where no application has the focus, |
773 |
;; or the command is invoked with `C-u', GDS asks the user which |
;; or the command is invoked with `C-u', GDS asks the user which |
774 |
;; application is intended. |
;; application is intended. |
775 |
|
|
776 |
(defun gds-read-client () |
(defun gds-read-client () |
777 |
(let* ((def (if gds-displayed-client |
(let* ((def (if gds-focus-client |
778 |
(cdr (assq gds-displayed-client gds-names)))) |
(cdr (assq gds-focus-client gds-names)))) |
779 |
(prompt (if def |
(prompt (if def |
780 |
(concat "Application for eval (default " |
(concat "Application for eval (default " |
781 |
def |
def |
804 |
(if client (gds-read-client)) |
(if client (gds-read-client)) |
805 |
;; If ask not forced, and there is a client with the focus, |
;; If ask not forced, and there is a client with the focus, |
806 |
;; default to that one. |
;; default to that one. |
807 |
gds-displayed-client |
gds-focus-client |
808 |
;; If there are no clients at this point, and we are allowed to |
;; If there are no clients at this point, and we are allowed to |
809 |
;; autostart a captive Guile, do so. |
;; autostart a captive Guile, do so. |
810 |
(and (null gds-names) |
(and (null gds-buffers) |
811 |
gds-autostart-captive |
gds-autostart-captive |
812 |
(progn |
(progn |
813 |
(gds-start-captive t) |
(gds-start-captive t) |
814 |
(while (null gds-names) |
(while (null gds-buffers) |
815 |
(accept-process-output (get-buffer-process gds-captive) |
(accept-process-output (get-buffer-process gds-captive) |
816 |
0 100000)) |
0 100000)) |
817 |
(caar gds-names))) |
(caar gds-buffers))) |
818 |
;; If there is only one known client, use that one. |
;; If there is only one known client, use that one. |
819 |
(if (and (car gds-names) |
(if (and (car gds-buffers) |
820 |
(null (cdr gds-names))) |
(null (cdr gds-buffers))) |
821 |
(caar gds-names)) |
(caar gds-buffers)) |
822 |
;; Last resort - ask the user. |
;; Last resort - ask the user. |
823 |
(gds-read-client) |
(gds-read-client) |
824 |
;; Signal an error. |
;; Signal an error. |
899 |
|
|
900 |
(defun gds-help-symbol (sym &optional client) |
(defun gds-help-symbol (sym &optional client) |
901 |
"Get help for SYM (a Scheme symbol)." |
"Get help for SYM (a Scheme symbol)." |
902 |
(interactive "SHelp for symbol: \nP") |
(interactive |
903 |
(gds-eval-expression (format "(begin (help %S) '%S)" sym gds-help-symbol) |
(let ((sym (thing-at-point 'symbol)) |
904 |
|
(enable-recursive-minibuffers t) |
905 |
|
val) |
906 |
|
(setq val (read-from-minibuffer |
907 |
|
(if sym |
908 |
|
(format "Describe Guile symbol (default %s): " sym) |
909 |
|
"Describe Guile symbol: "))) |
910 |
|
(list (if (zerop (length val)) sym val) |
911 |
|
current-prefix-arg))) |
912 |
|
(gds-eval-expression (format "(begin (help %s) '%S)" sym gds-help-symbol) |
913 |
client)) |
client)) |
914 |
|
|
|
(defun gds-help-symbol-here (&optional client) |
|
|
(interactive "P") |
|
|
(gds-help-symbol (thing-at-point 'symbol) client)) |
|
|
|
|
915 |
(defun gds-apropos (regex &optional client) |
(defun gds-apropos (regex &optional client) |
916 |
"List Guile symbols matching REGEX." |
"List Guile symbols matching REGEX." |
917 |
(interactive "sApropos Guile regex: \nP") |
(interactive |
918 |
|
(let ((sym (thing-at-point 'symbol)) |
919 |
|
(enable-recursive-minibuffers t) |
920 |
|
val) |
921 |
|
(setq val (read-from-minibuffer |
922 |
|
(if sym |
923 |
|
(format "Guile apropos (regexp, default \"%s\"): " sym) |
924 |
|
"Guile apropos (regexp): "))) |
925 |
|
(list (if (zerop (length val)) sym val) |
926 |
|
current-prefix-arg))) |
927 |
(gds-eval-expression (format "(begin (apropos %S) '%S)" regex gds-help-symbol) |
(gds-eval-expression (format "(begin (apropos %S) '%S)" regex gds-help-symbol) |
928 |
client)) |
client)) |
929 |
|
|
930 |
|
(defvar gds-completion-results nil) |
931 |
|
|
932 |
|
(defun gds-complete-symbol (&optional client) |
933 |
|
"Complete the Guile symbol before point. Returns `t' if anything |
934 |
|
interesting happened, `nil' if not." |
935 |
|
(interactive "P") |
936 |
|
(let* ((chars (- (point) (save-excursion |
937 |
|
(while (let ((syntax (char-syntax (char-before (point))))) |
938 |
|
(or (eq syntax ?w) (eq syntax ?_))) |
939 |
|
(forward-char -1)) |
940 |
|
(point))))) |
941 |
|
(if (zerop chars) |
942 |
|
nil |
943 |
|
(setq client (gds-choose-client client)) |
944 |
|
(setq gds-completion-results nil) |
945 |
|
(gds-send (format "(%S complete %s)\n" client |
946 |
|
(prin1-to-string |
947 |
|
(buffer-substring-no-properties (- (point) chars) |
948 |
|
(point))))) |
949 |
|
(while (null gds-completion-results) |
950 |
|
(accept-process-output gds-process 0 200)) |
951 |
|
(cond ((eq gds-completion-results t) |
952 |
|
nil) |
953 |
|
((stringp gds-completion-results) |
954 |
|
(if (<= (length gds-completion-results) chars) |
955 |
|
nil |
956 |
|
(insert (substring gds-completion-results chars)) |
957 |
|
(message "Sole completion") |
958 |
|
t)) |
959 |
|
((= (length gds-completion-results) 1) |
960 |
|
(if (<= (length (car gds-completion-results)) chars) |
961 |
|
nil |
962 |
|
(insert (substring (car gds-completion-results) chars)) |
963 |
|
t)) |
964 |
|
(t |
965 |
|
(with-output-to-temp-buffer "*Completions*" |
966 |
|
(display-completion-list gds-completion-results)) |
967 |
|
t))))) |
968 |
|
|
969 |
|
|
970 |
;;;; Display of evaluation and help results. |
;;;; Display of evaluation and help results. |
971 |
|
|
980 |
(save-excursion |
(save-excursion |
981 |
(set-buffer buf) |
(set-buffer buf) |
982 |
(erase-buffer) |
(erase-buffer) |
983 |
|
(scheme-mode) |
984 |
(while results |
(while results |
985 |
(insert (car results)) |
(insert (car results)) |
986 |
(if helpp |
(if helpp |
1028 |
;; Install the process communication commands in the scheme-mode keymap. |
;; Install the process communication commands in the scheme-mode keymap. |
1029 |
(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 |
1030 |
(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 |
1031 |
(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-defun) |
(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression) |
1032 |
(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) |
(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) |
1033 |
(define-key scheme-mode-map "\C-c\C-l" 'gds-load-file) |
(define-key scheme-mode-map "\C-c\C-l" 'gds-load-file) |
1034 |
|
(define-key scheme-mode-map "\C-hg" 'gds-help-symbol) |
1035 |
|
(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos) |
1036 |
|
(define-key scheme-mode-map "\e\t" 'gds-complete-symbol) |
1037 |
|
|
1038 |
|
|
1039 |
;;;; Menu bar entries. |
;;;; Menu bar entries. |
1079 |
(setq gds-help-menu (make-sparse-keymap "Help")) |
(setq gds-help-menu (make-sparse-keymap "Help")) |
1080 |
(define-key gds-help-menu [apropos] |
(define-key gds-help-menu [apropos] |
1081 |
'(menu-item "Apropos..." gds-apropos)) |
'(menu-item "Apropos..." gds-apropos)) |
|
(define-key gds-help-menu [sym-here] |
|
|
'(menu-item "Symbol At Point" gds-help-symbol-here)) |
|
1082 |
(define-key gds-help-menu [sym] |
(define-key gds-help-menu [sym] |
1083 |
'(menu-item "Symbol..." gds-help-symbol))) |
'(menu-item "Symbol..." gds-help-symbol))) |
1084 |
|
|
1107 |
(define-key gds-menu [separator-1] |
(define-key gds-menu [separator-1] |
1108 |
'("--")) |
'("--")) |
1109 |
(define-key gds-menu [debug] |
(define-key gds-menu [debug] |
1110 |
`(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client |
`(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client |
1111 |
(gds-client-waiting)))) |
(gds-client-blocked)))) |
1112 |
(define-key gds-menu [eval] |
(define-key gds-menu [eval] |
1113 |
`(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-names |
`(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-buffers |
1114 |
gds-autostart-captive))) |
gds-autostart-captive))) |
1115 |
(define-key gds-menu [help] |
(define-key gds-menu [help] |
1116 |
`(menu-item "Help" ,gds-help-menu :enable (or gds-names |
`(menu-item "Help" ,gds-help-menu :enable (or gds-buffers |
1117 |
gds-autostart-captive))) |
gds-autostart-captive))) |
1118 |
(setq menu-bar-final-items |
(setq menu-bar-final-items |
1119 |
(cons 'guile menu-bar-final-items)) |
(cons 'guile menu-bar-final-items)) |
1120 |
(define-key global-map [menu-bar guile] |
(define-key scheme-mode-map [menu-bar guile] |
1121 |
(cons "Guile" gds-menu))) |
(cons "Guile" gds-menu))) |
1122 |
|
|
1123 |
|
|
1159 |
(let ((proc (get-buffer-process gds-captive))) |
(let ((proc (get-buffer-process gds-captive))) |
1160 |
(comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n") |
(comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n") |
1161 |
(comint-send-string proc "(debug-enable 'backtrace)\n") |
(comint-send-string proc "(debug-enable 'backtrace)\n") |
1162 |
(comint-send-string proc "(use-modules (ice-9 debugger ui-client))\n") |
(comint-send-string proc "(use-modules (emacs gds-client))\n") |
1163 |
(comint-send-string proc "(ui-connect \"Captive Guile\" #f)\n")))) |
(comint-send-string proc "(gds-connect \"Captive Guile\" #f)\n")))) |
1164 |
|
|
1165 |
(defun gds-kill-captive () |
(defun gds-kill-captive () |
1166 |
(if gds-captive |
(if gds-captive |
1168 |
(process-kill-without-query proc) |
(process-kill-without-query proc) |
1169 |
(condition-case nil |
(condition-case nil |
1170 |
(progn |
(progn |
1171 |
(kill-process gds-process) |
(kill-process proc) |
1172 |
(accept-process-output gds-process 0 200)) |
(accept-process-output gds-process 0 200)) |
1173 |
(error))))) |
(error))))) |
1174 |
|
|