1 ;;; gds.el -- frontend for Guile development in Emacs
3 ;;;; Copyright (C) 2003 Free Software Foundation, Inc.
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
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.
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
29 ;;;; Debugging (of this code!).
31 (defsubst dmessage
(msg &rest args
)
32 ;;(apply (function message) msg args)
36 ;;;; Customization group setup.
39 "Customization options for Guile Emacs frontend."
43 ;;;; Communication with the (ice-9 debugger ui-server) subprocess.
45 ;; The subprocess object.
46 (defvar gds-process nil
)
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
)
54 "Start (or restart, if already running) the GDS subprocess."
56 (if gds-process
(gds-shutdown))
57 (with-current-buffer (get-buffer-create "*GDS Process*")
60 (let ((process-connection-type nil
)) ; use a pipe
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
))
75 ;; Shutdown the subprocess and cleanup all associated data.
76 (defun gds-shutdown ()
77 "Shut down the GDS subprocess."
79 ;; Do cleanup for all clients.
81 (gds-client-cleanup (caar gds-names
)))
82 ;; Reset any remaining variables.
83 (setq gds-displayed-client nil
85 ;; If the timer is running, cancel it.
87 (cancel-timer gds-timer
))
89 ;; Kill the subprocess.
90 (process-kill-without-query gds-process
)
93 (kill-process gds-process
)
94 (accept-process-output gds-process
0 200))
96 (setq gds-process nil
))
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
)
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))
112 (gds-handle-input form
)))
114 (setq gds-read-cursor
(point)))))
116 ;; Subprocess sentinel: do nothing. (Currently just here to avoid
117 ;; inserting un-`read'able process status messages into the process
119 (defun gds-sentinel (proc event
)
122 ;; Send input to the subprocess.
123 (defun gds-send (string)
124 (process-send-string gds-process string
))
127 ;;;; Multiple application scheduling.
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,
132 ;; ready for instructions - `gds-displayed-client' is nil.
133 (defvar gds-displayed-client nil
)
135 ;; The list of other Guile applications waiting for focus, referenced
136 ;; by their port numbers.
137 (defvar gds-waiting nil
)
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
)
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.
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.
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
)
166 (cdr gds-waiting
)))))))
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 ()
174 ;; Although debugging of this client isn't done, yield focus to the
175 ;; next waiting client.
176 (defun gds-focus-yield ()
178 (if (and (null gds-waiting
)
179 (y-or-n-p "No other clients waiting - bury *Guile* buffer? "))
181 (or (memq gds-displayed-client gds-waiting
)
182 (setq gds-waiting
(append gds-waiting
(list gds-displayed-client
))))
186 ;;;; Per-client state information.
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
)
192 ;; Return unique form of NAME.
193 (defun gds-uniquify (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
) ">")))
201 ;; Alist mapping client port numbers to last known status.
203 ;; Status is one of the following symbols.
205 ;; `running' - application is running.
207 ;; `waiting-for-input' - application is blocked waiting for
208 ;; instruction from the frontend.
210 ;; `ready-for-input' - application is not blocked but can also
211 ;; accept asynchronous instructions from the frontend.
213 (defvar gds-statuses nil
)
215 ;; Alist mapping client port numbers to last printed outputs.
216 (defvar gds-outputs nil
)
218 ;; Alist mapping client port numbers to last known stacks.
219 (defvar gds-stacks nil
)
221 ;; Alist mapping client port numbers to module information. This
224 ;; ((4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) ...)
228 ;; (assq client gds-modules)
230 ;; (4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...)
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
236 ;; The syms are actually all strings, because some Guile symbols are
237 ;; not readable by Emacs.
238 (defvar gds-modules nil
)
241 ;;;; Handling debugging instructions.
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
'*))
249 (let ((proc (cadr form
)))
251 (cond ((eq proc
'name
)
252 ;; (name ...) - Application's name.
254 (cons (cons client
(gds-uniquify (caddr form
)))
258 ;; (stack ...) - Stack at an error or breakpoint.
259 (gds-set gds-stacks client
(cddr form
)))
262 ;; (modules ...) - Application's loaded modules.
263 (gds-set gds-modules client
264 (mapcar (function list
) (cddr form
))))
267 ;; (output ...) - Last printed output.
268 (gds-set gds-outputs client
(caddr form
)))
271 ;; (status ...) - Application status indication.
272 (let ((status (caddr form
)))
273 (gds-set gds-statuses client status
)
274 (cond ((eq status
'waiting-for-input
)
276 ((or (eq status
'running
)
277 (eq status
'ready-for-input
))
278 (if (eq client gds-displayed-client
)
279 (gds-display-state client
)))
281 (error "Unexpected status: %S" status
)))))
284 ;; (module MODULE ...) - The specified module's bindings.
285 (let* ((modules (assq client gds-modules
))
286 (minfo (assoc (caddr form
) modules
)))
288 (setcdr (cdr minfo
) (cdddr form
)))))
291 ;; (closed) - Client has gone away.
292 (gds-client-cleanup client
))
294 ((eq proc
'eval-results
)
295 ;; (eval-results ...) - Results of evaluation.
296 (gds-display-results client
(cddr form
)))
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
)))
304 (setcdr existing
,val
)
306 (cons (cons client
,val
) ,alist
)))))
308 ;; Cleanup processing when CLIENT goes away.
309 (defun gds-client-cleanup (client)
310 (if (eq client gds-displayed-client
)
313 (delq (assq client gds-names
) gds-names
))
315 (delq (assq client gds-stacks
) gds-stacks
))
317 (delq (assq client gds-modules
) gds-modules
)))
320 ;;;; Displaying debugging information.
322 (defvar gds-client-buffer nil
)
324 (define-derived-mode gds-mode
327 "Major mode for Guile information buffers.")
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
)
333 (setq gds-client-buffer
(get-buffer-create "*Guile*"))
334 (set-buffer gds-client-buffer
)
336 ;; Rename to something we don't want first. Otherwise, if the
337 ;; buffer is already correctly named, we get a confusing change
338 ;; from, say, `*Guile: REPL*' to `*Guile: REPL*<2>'.
339 (rename-buffer "*Guile Fake Buffer Name*" t
)
340 (rename-buffer (if client
342 (cdr (assq client gds-names
))
345 t
) ; Rename uniquely if needed,
346 ; although it shouldn't be.
347 (force-mode-line-update t
))
349 (defun gds-clear-display ()
350 ;; Clear the client buffer.
351 (gds-set-client-buffer)
352 (let ((inhibit-read-only t
))
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
)
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
))))
370 ;; Cached display variables for `gds-display-state'.
371 (defvar gds-displayed-stack nil
)
372 (defvar gds-displayed-modules nil
)
374 ;; Types of display areas in the *Guile* buffer.
375 (defvar gds-display-types
'("Status" "Stack" "Modules"))
376 (defvar gds-display-type-regexp
378 (substring (apply (function concat
)
379 (mapcar (lambda (type)
385 (defun gds-maybe-delete-region (type)
386 (let ((beg (save-excursion
387 (goto-char (point-min))
388 (and (re-search-forward (concat "^"
392 (match-beginning 0)))))
398 (or (and (re-search-forward gds-display-type-regexp
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)
407 (goto-char (point-max)))))
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
)
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
))
428 '((running .
"running (cannot accept input)")
429 (waiting-for-input .
"waiting for input")
430 (ready-for-input .
"running"))))
432 (let ((output (cdr (assq client gds-outputs
))))
433 (if (> (length output
) 0)
434 (widget-insert output
"\n\n")))
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")
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")
454 (if modules
(gds-insert-modules modules
))
455 ;; Record displayed list.
456 (setq gds-displayed-modules
(copy-tree modules
)))
458 (dmessage "widget-setup")
461 ;; Stack is being seen for the first time, so make sure top of
462 ;; buffer is visible.
464 (goto-char (point-min))
465 (re-search-forward "^Stack:")
466 (forward-line (+ 1 (cadr stack
))))
467 ;; Restore point from before buffer was redrawn.
469 (setq gds-displayed-client client
)
470 (dmessage "consider display")
471 (if (eq (window-buffer (selected-window)) gds-client-buffer
)
472 ;; *Guile* buffer already selected.
473 (gds-display-buffers)
474 (dmessage "Running GDS timer")
476 (run-with-idle-timer 0.5
480 (gds-display-buffers))))))
482 (defun gds-display-buffers ()
483 ;; If there's already a window showing the *Guile* buffer, use
485 (let ((window (get-buffer-window gds-client-buffer t
)))
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
))))
501 (defun gds-insert-stack (stack)
502 (let ((frames (car stack
))
504 (flags (caddr stack
))
506 (widget-insert "Stack: " (prin1-to-string flags
) "\n")
508 (gds-show-selected-frame (caddr (nth index frames
)))
510 (setq frame
(car frames
)
513 items
(cons (list 'item
514 (let ((s (cadr frame
)))
515 (put-text-property 0 1 'index i s
)
518 (setq items
(nreverse items
))
519 (apply (function widget-create
)
521 :value
(cadr (nth index items
))
522 :notify
(function gds-select-stack-frame
)
524 (widget-insert "\n")))
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"
533 ;; Overlay used to highlight the source expression corresponding to
534 ;; the selected frame.
535 (defvar gds-selected-frame-source-overlay nil
)
537 ;; Buffer containing source for the selected frame.
538 (defvar gds-selected-frame-source-buffer nil
)
540 (defun gds-show-selected-frame (source)
541 ;; Highlight the frame source, if possible.
543 (file-readable-p (car source
)))
544 (with-current-buffer (find-file-noselect (car source
))
545 (if gds-selected-frame-source-overlay
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.
553 (goto-line (+ (cadr source
) 1))
554 (move-to-column (caddr source
))
555 (move-overlay gds-selected-frame-source-overlay
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)))
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))))
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...).
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.
582 This variable is usually set to exclude Guile system modules that are
583 not of primary interest when debugging application code."
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
)))
594 (let ((gds-module-filter (cdr exception
)))
595 (gds-show-module-p (cdr name
)))
598 (defun gds-insert-modules (modules)
599 (insert "Modules:\n")
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
)
608 (widget-put w
:module
(cons client
(car minfo
)))
609 (widget-insert " " (prin1-to-string (car minfo
)) "\n")
611 (let ((syms (cddr minfo
)))
613 (widget-insert " > " (car syms
) "\n")
614 (setq syms
(cdr syms
))))))))
615 (setq modules
(cdr modules
))))
617 (defun gds-module-notify (w &rest ignore
)
618 (let* ((module (widget-get w
:module
))
619 (client (car module
))
621 (modules (assq client gds-modules
))
622 (minfo (assoc name modules
)))
624 ;; Just toggle expansion state.
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
)))))
634 ;;;; Guile Debugging keymap.
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
))
647 (defun gds-client-waiting ()
648 (eq (cdr (assq gds-displayed-client gds-statuses
)) 'waiting-for-input
))
652 (gds-send (format "(%S debugger-command continue)\n" gds-displayed-client
)))
656 (if (gds-client-waiting)
657 (if (y-or-n-p "Client is waiting for instruction - tell it to continue? ")
663 (if (gds-client-waiting)
669 (gds-send (format "(%S debugger-command next 1)\n" gds-displayed-client
)))
671 (defun gds-evaluate (expr)
672 (interactive "sEvaluate (in this stack frame): ")
673 (gds-send (format "(%S debugger-command evaluate %s)\n"
675 (prin1-to-string expr
))))
677 (defun gds-step-in ()
679 (gds-send (format "(%S debugger-command step 1)\n" gds-displayed-client
)))
681 (defun gds-step-out ()
683 (gds-send (format "(%S debugger-command finish)\n" gds-displayed-client
)))
685 (defun gds-trace-finish ()
687 (gds-send (format "(%S debugger-command trace-finish)\n"
688 gds-displayed-client
)))
690 (defun gds-set-breakpoint ()
692 (cond ((gds-in-source-buffer)
693 (gds-set-source-breakpoint))
695 (gds-set-stack-breakpoint))
697 (gds-set-module-breakpoint))
699 (error "No way to set a breakpoint from here"))))
701 (defun gds-in-source-buffer ()
702 ;; Not yet worked out what will be available in Scheme source
706 (defun gds-in-stack ()
707 (and (eq (current-buffer) gds-client-buffer
)
709 (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t
)
710 (looking-at "Stack")))))
712 (defun gds-in-modules ()
713 (and (eq (current-buffer) gds-client-buffer
)
715 (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t
)
716 (looking-at "Modules")))))
718 (defun gds-set-module-breakpoint ()
719 (let ((sym (save-excursion
721 (and (looking-at " > \\([^ \n\t]+\\)")
723 (module (save-excursion
724 (and (re-search-backward "^\\[[+---]\\] \\(([^)]+)\\)" nil t
)
727 (error "Couldn't find procedure name on current line"))
729 (error "Couldn't find module name for current line"))
732 (format "Behaviour for breakpoint at %s:%s (default debug-here): "
742 (gds-send (format "(%S set-breakpoint %s %s %s)\n"
749 ;;;; Evaluating code.
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.
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,
758 ;; or the command is invoked with `C-u', GDS asks the user which
759 ;; application is intended.
761 (defun gds-read-client ()
762 (let* ((def (if gds-displayed-client
763 (cdr (assq gds-displayed-client gds-names
))))
765 (concat "Application for eval (default "
768 "Application for eval: "))
770 (completing-read prompt
771 (mapcar (function list
)
772 (mapcar (function cdr
) gds-names
))
775 (let (client (names gds-names
))
776 (while (and names
(not client
))
777 (if (string-equal (cdar names
) name
)
778 (setq client
(caar names
)))
779 (setq names
(cdr names
)))
782 (defun gds-choose-client (client)
783 (or ;; If client is an integer, it is the port number of the
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
789 (if client
(gds-read-client))
790 ;; If ask not forced, and there is a client with the focus,
791 ;; default to that one.
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
798 (gds-start-captive t
)
799 (while (null gds-names
)
800 (accept-process-output (get-buffer-process gds-captive
)
803 ;; If there is only one known client, use that one.
804 (if (and (car gds-names
)
805 (null (cdr gds-names
)))
807 ;; Last resort - ask the user.
810 (error "No application chosen.")))
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?
819 (while (and (not module-name
)
820 (beginning-of-defun-raw 1))
821 (if (looking-at "(define-module ")
824 (goto-char (match-end 0))
825 (read (current-buffer))))))
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
832 (or (buffer-file-name)
833 (concat "Emacs buffer: " (buffer-name))))
835 (defun gds-eval-region (start end
&optional client
)
836 "Evaluate the current region."
838 (setq client
(gds-choose-client client
))
839 (let ((module (gds-module-name start end
))
840 (port-name (gds-port-name start end
))
844 (setq column
(current-column)) ; 0-based
846 (setq line
(count-lines (point-min) (point)))) ; 0-based
847 (gds-send (format "(%S eval %s %S %d %d %S)\n"
849 (if module
(prin1-to-string module
) "#f")
850 port-name line column
851 (buffer-substring-no-properties start end
)))))
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"
860 (defun gds-eval-defun (&optional client
)
861 "Evaluate the defun (top-level form) at point."
867 (gds-eval-region (point) end client
))))
869 (defun gds-eval-last-sexp (&optional client
)
870 "Evaluate the sexp before point."
872 (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client
))
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.
882 (defvar gds-help-symbol
'%-gds-help-%
883 "Symbol used by GDS to identify an evaluation response as help.")
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
)
891 (defun gds-help-symbol-here (&optional client
)
893 (gds-help-symbol (thing-at-point 'symbol
) client
))
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
)
902 ;;;; Display of evaluation and help results.
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
911 "*Guile Results*"))))
916 (insert (car results
))
919 (mapcar (function (lambda (value)
920 (insert " => " value
"\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)))))
928 (run-hooks 'temp-buffer-show-hook
)
932 ;;;; Loading (evaluating) a whole Scheme file.
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
)
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'.")
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
950 ; T because LOAD needs an
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
)))
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
)
967 ;;;; Menu bar entries.
969 (defvar gds-debug-menu nil
970 "GDS debugging menu.")
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)))
987 (defvar gds-eval-menu nil
988 "GDS evaluation menu.")
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)))
1003 (defvar gds-help-menu 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)))
1015 (defvar gds-advanced-menu nil
1016 "Menu of rarely needed GDS operations.")
1017 (if gds-advanced-menu
1019 (setq gds-advanced-menu (make-sparse-keymap "Advanced"))
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))))
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))))
1030 (defvar gds-menu nil
1031 "Global menu for GDS commands.")
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]
1039 (define-key gds-menu [debug]
1040 `(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client
1041 (gds-client-waiting))))
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)))
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)))
1054 ;;;; Autostarting the GDS server.
1056 (defcustom gds-autostart-server t
1057 "Whether to automatically start the GDS server when `gds.el' is loaded."
1061 (if (and gds-autostart-server
1066 ;;;; `Captive' Guile - a Guile process that is started when needed to
1067 ;;;; provide help, completion, evaluations etc.
1069 (defcustom gds-autostart-captive t
1070 "Whether to automatically start a `captive' Guile process when needed."
1074 (defvar gds-captive nil
1075 "Buffer of captive Guile.")
1077 (defun gds-start-captive (&optional restart)
1080 (comint-check-proc gds-captive))
1082 (if (comint-check-proc gds-captive)
1084 (let ((process-connection-type nil))
1085 (setq gds-captive (make-comint "captive-guile"
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"))))
1095 (defun gds-kill-captive ()
1097 (let ((proc (get-buffer-process gds-captive)))
1098 (process-kill-without-query proc)
1101 (kill-process gds-process)
1102 (accept-process-output gds-process 0 200))
1110 ;;; gds.el ends here.