+++ /dev/null
-;;; gds.el -- frontend for Guile development in Emacs
-
-;;;; Copyright (C) 2003 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later
-;;;; version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free
-;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-;;;; 02111-1307 USA
-
-
-;;;; Prerequisites.
-
-(require 'widget)
-(require 'wid-edit)
-(require 'scheme)
-
-
-;;;; Customization group setup.
-
-(defgroup gds nil
- "Customization options for Guile Emacs frontend."
- :group 'scheme)
-
-
-;;;; Communication with the (emacs gds-server) subprocess.
-
-;; The subprocess object.
-(defvar gds-process nil)
-
-;; Subprocess output goes into the `*GDS Process*' buffer, and
-;; is then read from there one form at a time. `gds-read-cursor' is
-;; the buffer position of the start of the next unread form.
-(defvar gds-read-cursor nil)
-
-(defun gds-start ()
- "Start (or restart, if already running) the GDS subprocess."
- (interactive)
- (if gds-process (gds-shutdown))
- (with-current-buffer (get-buffer-create "*GDS Process*")
- (erase-buffer)
- (setq gds-process
- (let ((process-connection-type nil)) ; use a pipe
- (start-process "gds"
- (current-buffer)
- "guile"
- "-q"
- "--debug"
- "-c"
- "(begin (use-modules (emacs gds-server)) (run-server))"))))
- (setq gds-read-cursor (point-min))
- (set-process-filter gds-process (function gds-filter))
- (set-process-sentinel gds-process (function gds-sentinel))
- (set-process-coding-system gds-process 'latin-1-unix))
-
-;; Shutdown the subprocess and cleanup all associated data.
-(defun gds-shutdown ()
- "Shut down the GDS subprocess."
- (interactive)
- ;; Reset variables.
- (setq gds-buffers nil
- gds-focus-client nil
- gds-waiting nil)
- ;; Kill the subprocess.
- (process-kill-without-query gds-process)
- (condition-case nil
- (progn
- (kill-process gds-process)
- (accept-process-output gds-process 0 200))
- (error))
- (setq gds-process nil))
-
-;; Subprocess output filter: inserts normally into the process buffer,
-;; then tries to reread the output one form at a time and delegates
-;; processing of each form to `gds-handle-input'.
-(defun gds-filter (proc string)
- (with-current-buffer (process-buffer proc)
- (save-excursion
- (goto-char (process-mark proc))
- (insert-before-markers string))
- (goto-char gds-read-cursor)
- (while (let ((form (condition-case nil
- (read (current-buffer))
- (error nil))))
- (if form
- (save-excursion
- (gds-handle-input form)))
- form)
- (setq gds-read-cursor (point)))))
-
-;; Subprocess sentinel: do nothing. (Currently just here to avoid
-;; inserting un-`read'able process status messages into the process
-;; buffer.)
-(defun gds-sentinel (proc event)
- )
-
-;; Send input to the subprocess.
-(defun gds-send (string)
- (process-send-string gds-process string))
-
-
-;;;; Multiple application scheduling.
-
-;; Here is how we schedule the display of multiple clients that are
-;; competing for user attention.
-;;
-;; - `gds-waiting' holds a list of clients that want attention but
-;; haven't yet got it. A client is added to this list for two
-;; reasons. (1) When it is blocked waiting for user input.
-;; (2) When it first connects to GDS, even if not blocked.
-;;
-;; - `gds-focus-client' holds the client, if any, that currently has
-;; the user's attention. A client can be given the focus if
-;; `gds-focus-client' is nil at the time that the client wants
-;; attention, or if another client relinquishes it. A client can
-;; relinquish the focus in two ways. (1) If the client application
-;; says that it is no longer blocked, and a small time passes without
-;; it becoming blocked again. (2) If the user explicitly `quits'
-;; that client.
-(defvar gds-focus-client nil)
-(defvar gds-waiting nil)
-
-(defun gds-request-focus (client)
- (cond ((eq client gds-focus-client)
- ;; CLIENT already has the focus. Display its buffer.
- (gds-display-buffers))
- (gds-focus-client
- ;; Another client has the focus. Add CLIENT to `gds-waiting'.
- (or (memq client gds-waiting)
- (setq gds-waiting (append gds-waiting (list client)))))
- (t
- ;; Give focus to CLIENT and display its buffer.
- (setq gds-focus-client client)
- (gds-display-buffers))))
-
-;; Explicitly give up focus.
-(defun gds-quit ()
- (interactive)
- (if (or (car gds-waiting)
- (not (gds-client-blocked))
- (y-or-n-p
- "Client is blocked and no others are waiting. Still quit? "))
- (progn
- (bury-buffer (current-buffer))
- ;; Pass on the focus.
- (setq gds-focus-client (car gds-waiting)
- gds-waiting (cdr gds-waiting))
- ;; If this client is blocked, add it back into the waiting list.
- (if (gds-client-blocked)
- (gds-request-focus gds-client))
- ;; If there is a new focus client, request display for it.
- (if gds-focus-client
- (gds-request-focus gds-focus-client)))))
-
-
-;;;; GDS protocol dispatch.
-
-;; General dispatch function called by the subprocess filter.
-(defun gds-handle-input (form)
- (let ((client (car form)))
- (or (eq client '*)
- (let* ((proc (cadr form))
- (args (cddr form))
- (buf (gds-client-buffer client proc args)))
- (if buf (gds-handle-client-input buf client proc args))))))
-
-(defun gds-handle-client-input (buf client proc args)
- (with-current-buffer buf
- (with-current-buffer gds-transcript
- (goto-char (point-max))
- (let ((inhibit-read-only t))
- (insert (format "<%S %S %S>" client proc args) "\n")))
- (cond (;; (name ...) - Client name.
- (eq proc 'name)
- (setq gds-pid (cadr args))
- (gds-promote-view 'interaction)
- (gds-request-focus client))
-
- (;; (current-module ...) - Current module.
- (eq proc 'current-module)
- (setq gds-current-module (car args)))
-
- (;; (stack ...) - Stack at an error or breakpoint.
- (eq proc 'stack)
- (setq gds-stack args)
- (gds-promote-view 'stack))
-
- (;; (modules ...) - Application's loaded modules.
- (eq proc 'modules)
- (while args
- (or (assoc (car args) gds-modules)
- (setq gds-modules (cons (list (car args)) gds-modules)))
- (setq args (cdr args))))
-
- (;; (output ...) - Last printed output.
- (eq proc 'output)
- (setq gds-output (car args))
- (gds-add-view 'messages))
-
- (;; (status ...) - Application status indication.
- (eq proc 'status)
- (setq gds-status (car args))
- (if (eq gds-status 'running)
- (gds-delete-view 'browser)
- (gds-add-view 'browser))
- (if (eq gds-status 'waiting-for-input)
- (progn
- (gds-promote-view 'stack)
- (gds-update-buffers)
- (gds-request-focus client))
- (setq gds-stack nil)
- (gds-delete-view 'stack)
- (gds-update-buffers-in-a-while)))
-
- (;; (module MODULE ...) - The specified module's bindings.
- (eq proc 'module)
- (let ((minfo (assoc (car args) gds-modules)))
- (if minfo
- (setcdr (cdr minfo) (cdr args)))))
-
- (;; (closed) - Client has gone away.
- (eq proc 'closed)
- (setq gds-status 'closed)
- (gds-update-buffers)
- (setq gds-buffers
- (delq (assq client gds-buffers) gds-buffers))
- (if (eq client gds-focus-client)
- (gds-quit)))
-
- (;; (eval-results ...) - Results of evaluation.
- (eq proc 'eval-results)
- (gds-display-results client args))
-
- ((eq proc 'completion-result)
- (setq gds-completion-results (or (car args) t)))
-
- (;; (breakpoint-set FILE LINE COLUMN INFO) - Breakpoint set.
- (eq proc 'breakpoint-set)
- (let ((file (nth 0 args))
- (line (nth 1 args))
- (column (nth 2 args))
- (info (nth 3 args)))
- (with-current-buffer (find-file-noselect file)
- (save-excursion
- (goto-char (point-min))
- (or (zerop line)
- (forward-line line))
- (move-to-column column)
- (let ((os (overlays-at (point))) o)
- (while os
- (if (and (overlay-get (car os) 'gds-breakpoint-info)
- (= (overlay-start (car os)) (point)))
- (progn
- (overlay-put (car os)
- 'gds-breakpoint-info
- info)
- (overlay-put (car os)
- 'before-string
- gds-active-breakpoint-before-string)
- (overlay-put (car os)
- 'after-string
- gds-active-breakpoint-after-string)
- (setq os nil))
- (setq os (cdr os)))))))))
-
- )))
-
-
-;;;; Per-client buffer state.
-
-;; This section contains code that is specific to each Guile client's
-;; buffer but independent of any particular `view'.
-
-;; Alist mapping each client port number to corresponding buffer.
-(defvar gds-buffers nil)
-
-(define-derived-mode gds-mode
- scheme-mode
- "Guile Interaction"
- "Major mode for interacting with a Guile client application.")
-
-(defvar gds-client nil
- "GDS client's port number.")
-(make-variable-buffer-local 'gds-client)
-
-(defvar gds-status nil
- "GDS client's latest status, one of the following symbols.
-`running' - Application is running.
-`waiting-for-input' - Application is blocked waiting for instruction
- from the frontend.
-`ready-for-input' - Application is not blocked but can also accept
- asynchronous instructions from the frontend.")
-(make-variable-buffer-local 'gds-status)
-
-(defvar gds-transcript nil
- "Transcript buffer for this GDS client.")
-(make-variable-buffer-local 'gds-transcript)
-
-;; Return client buffer for specified client and protocol input.
-(defun gds-client-buffer (client proc args)
- (if (eq proc 'name)
- ;; Introduction from client - create a new buffer.
- (with-current-buffer (generate-new-buffer (car args))
- (gds-mode)
- (setq gds-client client)
- (setq gds-transcript
- (find-file-noselect
- (expand-file-name (concat "~/.gds-transcript-" (car args)))))
- (with-current-buffer gds-transcript
- (goto-char (point-max))
- (insert "\nTranscript:\n"))
- (setq gds-buffers
- (cons (cons client (current-buffer))
- gds-buffers))
- (current-buffer))
- ;; Otherwise there should be an existing buffer that we can
- ;; return.
- (let ((existing (assq client gds-buffers)))
- (if (buffer-live-p (cdr existing))
- (cdr existing)
- (setq gds-buffers (delq existing gds-buffers))
- (gds-client-buffer client 'name '("(GDS buffer killed)"))))))
-
-(defun gds-client-blocked ()
- (eq gds-status 'waiting-for-input))
-
-(defvar gds-delayed-update-timer nil)
-
-(defvar gds-delayed-update-buffers nil)
-
-(defun gds-update-delayed-update-buffers ()
- (while gds-delayed-update-buffers
- (with-current-buffer (car gds-delayed-update-buffers)
- (setq gds-delayed-update-buffers
- (cdr gds-delayed-update-buffers))
- (gds-update-buffers))))
-
-(defun gds-update-buffers ()
- (if (timerp gds-delayed-update-timer)
- (cancel-timer gds-delayed-update-timer))
- (setq gds-delayed-update-timer nil)
- (let ((view (car gds-views))
- (inhibit-read-only t))
- (cond ((eq view 'stack)
- (gds-insert-stack))
- ((eq view 'interaction)
- (gds-insert-interaction))
- ((eq view 'browser)
- (gds-insert-modules))
- ((eq view 'messages)
- (gds-insert-messages))
- (t
- (error "Bad GDS view %S" view)))
- ;; Finish off.
- (widget-setup)
- (force-mode-line-update t)))
-
-(defun gds-update-buffers-in-a-while ()
- (or (memq (current-buffer) gds-delayed-update-buffers)
- (setq gds-delayed-update-buffers
- (cons (current-buffer) gds-delayed-update-buffers)))
- (if (timerp gds-delayed-update-timer)
- nil
- (setq gds-delayed-update-timer
- (run-at-time 0.5 nil (function gds-update-delayed-update-buffers)))))
-
-(defun gds-display-buffers ()
- (if gds-focus-client
- (let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers))))
- ;; If there's already a window showing the buffer, use it.
- (let ((window (get-buffer-window gds-focus-buffer t)))
- (if window
- (progn
- (make-frame-visible (window-frame window))
- (select-frame (window-frame window))
- (select-window window))
- ;(select-window (display-buffer gds-focus-buffer))
- (display-buffer gds-focus-buffer)))
- ;; If there is an associated source buffer, display it as well.
- (if (and (eq (car gds-views) 'stack)
- gds-frame-source-overlay
- (> (overlay-end gds-frame-source-overlay) 0))
- (let ((window (display-buffer
- (overlay-buffer gds-frame-source-overlay))))
- (set-window-point window
- (overlay-start gds-frame-source-overlay)))))))
-
-
-;;;; Management of `views'.
-
-;; The idea here is to keep the buffer describing a Guile client
-;; relatively uncluttered by only showing one kind of information
-;; about that client at a time. Menu items and key sequences are
-;; provided to switch easily between the available views.
-
-(defvar gds-views nil
- "List of available views for a GDS client. Each element is one of
-the following symbols.
-`interaction' - Interaction with running client.
-`stack' - Call stack view.
-`browser' - Modules and bindings browser view.
-`breakpoints' - List of set breakpoints.
-`messages' - Non-GDS-protocol output from the debugger.")
-(make-variable-buffer-local 'gds-views)
-
-(defun gds-promote-view (view)
- (setq gds-views (cons view (delq view gds-views))))
-
-(defun gds-switch-to-view (view)
- (or (memq view gds-views)
- (error "View %S is not available" view))
- (gds-promote-view view)
- (gds-update-buffers))
-
-(defun gds-add-view (view)
- (or (memq view gds-views)
- (setq gds-views (append gds-views (list view)))))
-
-(defun gds-delete-view (view)
- (setq gds-views (delq view gds-views)))
-
-
-;;;; `Interaction' view.
-
-;; This view provides interaction with a normally running Guile
-;; client, in other words one that is not stopped in the debugger but
-;; is still available to take input from GDS (usually via a thread for
-;; that purpose). The view supports evaluation, help requests,
-;; control of `debug-on-exception' function, and methods for breaking
-;; into the running code.
-
-(defvar gds-current-module "()"
- "GDS client's current module.")
-(make-variable-buffer-local 'gds-current-module)
-
-(defvar gds-pid nil
- "GDS client's process ID.")
-(make-variable-buffer-local 'gds-pid)
-
-(defvar gds-debug-exceptions nil
- "Whether to debug exceptions.")
-(make-variable-buffer-local 'gds-debug-exceptions)
-
-(defvar gds-exception-keys "signal misc-error"
- "The exception keys for which to debug a GDS client.")
-(make-variable-buffer-local 'gds-exception-keys)
-
-(defun gds-insert-interaction ()
- (erase-buffer)
- ;; Insert stuff for interacting with a running (non-blocked) Guile
- ;; client.
- (widget-insert (buffer-name)
- ", "
- (cdr (assq gds-status
- '((running . "running (cannot accept input)")
- (waiting-for-input . "waiting for input")
- (ready-for-input . "running")
- (closed . "closed"))))
- ", in "
- gds-current-module
- "\n")
- (widget-create 'push-button
- :notify (function gds-sigint)
- "SIGINT")
- (widget-insert " ")
- (widget-create 'push-button
- :notify (function gds-async-break)
- "Break")
- (widget-insert "\n")
- (widget-create 'checkbox
- :notify (function gds-toggle-debug-exceptions)
- gds-debug-exceptions)
- (widget-insert " Debug exception keys: ")
- (widget-create 'editable-field
- :notify (function gds-set-exception-keys)
- gds-exception-keys)
- (widget-insert "\n"))
-
-(defun gds-sigint (w &rest ignore)
- (interactive)
- (signal-process gds-pid 2))
-
-(defun gds-async-break (w &rest ignore)
- (interactive)
- (gds-send (format "(%S async-break)\n" gds-focus-client)))
-
-(defun gds-toggle-debug-exceptions (w &rest ignore)
- (interactive)
- (setq gds-debug-exceptions (widget-value w))
- (gds-eval-expression (concat "(use-modules (ice-9 debugger))"
- "(debug-on-error '("
- gds-exception-keys
- "))")))
-
-(defun gds-set-exception-keys (w &rest ignore)
- (interactive)
- (setq gds-exception-keys (widget-value w)))
-
-(defun gds-view-interaction ()
- (interactive)
- (gds-switch-to-view 'interaction))
-
-
-;;;; `Stack' view.
-
-;; This view shows the Guile call stack after the application has hit
-;; an error, or when it is stopped in the debugger.
-
-(defvar gds-stack nil
- "GDS client's stack when last stopped.")
-(make-variable-buffer-local 'gds-stack)
-
-(defun gds-insert-stack ()
- (erase-buffer)
- (let ((frames (car gds-stack))
- (index (cadr gds-stack))
- (flags (caddr gds-stack))
- frame items)
- (cond ((memq 'application flags)
- (widget-insert "Calling procedure:\n"))
- ((memq 'evaluation flags)
- (widget-insert "Evaluating expression:\n"))
- ((memq 'return flags)
- (widget-insert "Return value: "
- (cadr (memq 'return flags))
- "\n"))
- (t
- (widget-insert "Stack: " (prin1-to-string flags) "\n")))
- (let ((i -1))
- (gds-show-selected-frame (caddr (nth index frames)))
- (while frames
- (setq frame (car frames)
- frames (cdr frames)
- i (+ i 1)
- items (cons (list 'item
- (let ((s (cadr frame)))
- (put-text-property 0 1 'index i s)
- s))
- items))))
- (setq items (nreverse items))
- (apply (function widget-create)
- 'radio-button-choice
- :value (cadr (nth index items))
- :notify (function gds-select-stack-frame)
- items)
- (widget-insert "\n")
- (goto-char (point-min))))
-
-(defun gds-select-stack-frame (widget &rest ignored)
- (let* ((s (widget-value widget))
- (ind (memq 'index (text-properties-at 0 s))))
- (gds-send (format "(%S debugger-command frame %d)\n"
- gds-focus-client
- (cadr ind)))))
-
-;; Overlay used to highlight the source expression corresponding to
-;; the selected frame.
-(defvar gds-frame-source-overlay nil)
-
-(defun gds-show-selected-frame (source)
- ;; Highlight the frame source, if possible.
- (if (and source
- (file-readable-p (car source)))
- (with-current-buffer (find-file-noselect (car source))
- (if gds-frame-source-overlay
- nil
- (setq gds-frame-source-overlay (make-overlay 0 0))
- (overlay-put gds-frame-source-overlay 'face 'highlight))
- ;; Move to source line. Note that Guile line numbering is
- ;; 0-based, while Emacs numbering is 1-based.
- (save-restriction
- (widen)
- (goto-line (+ (cadr source) 1))
- (move-to-column (caddr source))
- (move-overlay gds-frame-source-overlay
- (point)
- (if (not (looking-at ")"))
- (save-excursion (forward-sexp 1) (point))
- ;; It seems that the source coordinates for
- ;; backquoted expressions are at the end of
- ;; the sexp rather than the beginning...
- (save-excursion (forward-char 1)
- (backward-sexp 1) (point)))
- (current-buffer))))
- (if gds-frame-source-overlay
- (move-overlay gds-frame-source-overlay 0 0))))
-
-(defun gds-view-stack ()
- (interactive)
- (gds-switch-to-view 'stack))
-
-
-;;;; `Breakpoints' view.
-
-;; This view shows a list of breakpoints.
-
-(defun gds-view-breakpoints ()
- (interactive)
- (gds-switch-to-view 'breakpoints))
-
-
-;;;; `Browser' view.
-
-;; This view shows a list of modules and module bindings.
-
-(defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil))
- "Specification of which Guile modules the debugger should display.
-This is a list with structure (DEFAULT EXCEPTION EXCEPTION...), where
-DEFAULT is `t' or `nil' and each EXCEPTION has the structure (SYMBOL
-DEFAULT EXCEPTION EXCEPTION...).
-
-A Guile module name `(x y z)' is matched against this filter as
-follows. If one of the top level EXCEPTIONs has SYMBOL `x', continue
-by matching the rest of the module name, in this case `(y z)', against
-that SYMBOL's DEFAULT and next level EXCEPTION list. Otherwise, if
-the current DEFAULT is `t' display the module, and if the current
-DEFAULT is `nil', don't display it.
-
-This variable is usually set to exclude Guile system modules that are
-not of primary interest when debugging application code."
- :type 'sexp
- :group 'gds)
-
-(defun gds-show-module-p (name)
- ;; Determine whether to display the NAMEd module by matching NAME
- ;; against `gds-module-filter'.
- (let ((default (car gds-module-filter))
- (exceptions (cdr gds-module-filter)))
- (let ((exception (assq (car name) exceptions)))
- (if exception
- (let ((gds-module-filter (cdr exception)))
- (gds-show-module-p (cdr name)))
- default))))
-
-(defvar gds-modules nil
- "GDS client's module information.
-Alist mapping module names to their symbols and related information.
-This looks like:
-
- (((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.")
-(make-variable-buffer-local 'gds-modules)
-
-(defun gds-insert-modules ()
- (let ((p (if (eq (window-buffer (selected-window)) (current-buffer))
- (point)
- (point-min)))
- (modules gds-modules))
- (erase-buffer)
- (insert "Modules:\n")
- (while modules
- (let ((minfo (car modules)))
- (if (gds-show-module-p (car minfo))
- (let ((w (widget-create 'push-button
- :notify (function gds-module-notify)
- (if (and (cdr minfo)
- (cadr minfo))
- "-" "+"))))
- (widget-put w :module (cons gds-client (car minfo)))
- (widget-insert " " (prin1-to-string (car minfo)) "\n")
- (if (cadr minfo)
- (let ((syms (cddr minfo)))
- (while syms
- (widget-insert " > " (car syms) "\n")
- (setq syms (cdr syms))))))))
- (setq modules (cdr modules)))
- (insert "\n")
- (goto-char p)))
-
-(defun gds-module-notify (w &rest ignore)
- (let* ((module (widget-get w :module))
- (client (car module))
- (name (cdr module))
- (minfo (assoc name gds-modules)))
- (if (cdr minfo)
- ;; Just toggle expansion state.
- (progn
- (setcar (cdr minfo) (not (cadr minfo)))
- (gds-update-buffers))
- ;; Set flag to indicate module expanded.
- (setcdr minfo (list t))
- ;; Get symlist from Guile.
- (gds-send (format "(%S query-module %S)\n" client name)))))
-
-(defun gds-query-modules ()
- (interactive)
- (gds-send (format "(%S query-modules)\n" gds-focus-client)))
-
-(defun gds-view-browser ()
- (interactive)
- (or gds-modules (gds-query-modules))
- (gds-switch-to-view 'browser))
-
-
-;;;; `Messages' view.
-
-;; This view shows recent non-GDS-protocol messages output from the
-;; (ice-9 debugger) code.
-
-(defvar gds-output nil
- "GDS client's recent output (printed).")
-(make-variable-buffer-local 'gds-output)
-
-(defun gds-insert-messages ()
- (erase-buffer)
- ;; Insert recent non-protocol output from (ice-9 debugger).
- (insert gds-output)
- (goto-char (point-min)))
-
-(defun gds-view-messages ()
- (interactive)
- (gds-switch-to-view 'messages))
-
-
-;;;; Debugger commands.
-
-;; Typically but not necessarily used from the `stack' view.
-
-(defun gds-go ()
- (interactive)
- (gds-send (format "(%S debugger-command continue)\n" gds-focus-client)))
-
-(defun gds-next ()
- (interactive)
- (gds-send (format "(%S debugger-command next 1)\n" gds-focus-client)))
-
-(defun gds-evaluate (expr)
- (interactive "sEvaluate (in this stack frame): ")
- (gds-send (format "(%S debugger-command evaluate %s)\n"
- gds-focus-client
- (prin1-to-string expr))))
-
-(defun gds-step-in ()
- (interactive)
- (gds-send (format "(%S debugger-command step 1)\n" gds-focus-client)))
-
-(defun gds-step-out ()
- (interactive)
- (gds-send (format "(%S debugger-command finish)\n" gds-focus-client)))
-
-(defun gds-trace-finish ()
- (interactive)
- (gds-send (format "(%S debugger-command trace-finish)\n"
- gds-focus-client)))
-
-(defun gds-frame-info ()
- (interactive)
- (gds-send (format "(%S debugger-command info-frame)\n" gds-focus-client)))
-
-(defun gds-frame-args ()
- (interactive)
- (gds-send (format "(%S debugger-command info-args)\n" gds-focus-client)))
-
-
-;;;; Setting breakpoints.
-
-(defun gds-set-breakpoint ()
- (interactive)
- (cond ((gds-in-source-buffer)
- (gds-set-source-breakpoint))
- ((gds-in-stack)
- (gds-set-stack-breakpoint))
- ((gds-in-modules)
- (gds-set-module-breakpoint))
- (t
- (error "No way to set a breakpoint from here"))))
-
-(defun gds-in-source-buffer ()
- ;; Not yet worked out what will be available in Scheme source
- ;; buffers.
- nil)
-
-(defun gds-in-stack ()
- (save-excursion
- (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
- (looking-at "Stack"))))
-
-(defun gds-in-modules ()
- (save-excursion
- (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
- (looking-at "Modules"))))
-
-(defun gds-set-module-breakpoint ()
- (let ((sym (save-excursion
- (beginning-of-line)
- (and (looking-at " > \\([^ \n\t]+\\)")
- (match-string 1))))
- (module (save-excursion
- (and (re-search-backward "^\\[[+---]\\] \\(([^)]+)\\)" nil t)
- (match-string 1)))))
- (or sym
- (error "Couldn't find procedure name on current line"))
- (or module
- (error "Couldn't find module name for current line"))
- (let ((behaviour
- (completing-read
- (format "Behaviour for breakpoint at %s:%s (default debug-here): "
- module sym)
- '(("debug-here")
- ("trace-here")
- ("trace-subtree"))
- nil
- t
- nil
- nil
- "debug-here")))
- (gds-send (format "(%S set-breakpoint %s %s %s)\n"
- gds-focus-client
- module
- sym
- behaviour)))))
-
-
-;;;; Scheme source breakpoints.
-
-(defcustom gds-breakpoint-face 'default
- "*Face used to highlight the location of a source breakpoint.
-Specifically, this face highlights the opening parenthesis of the
-form where the breakpoint is set."
- :type 'face
- :group 'gds)
-
-(defcustom gds-new-breakpoint-before-string ""
- "*String used to show the presence of a new source breakpoint.
-`New' means that the breakpoint has been set but isn't yet known to
-Guile because the containing code hasn't been reevaluated yet.
-This string appears before the opening parenthesis of the form where
-the breakpoint is set. If you prefer a marker to appear after the
-opening parenthesis, make this string empty and use
-`gds-new-breakpoint-after-string'."
- :type 'string
- :group 'gds)
-
-(defcustom gds-new-breakpoint-after-string "=?= "
- "*String used to show the presence of a new source breakpoint.
-`New' means that the breakpoint has been set but isn't yet known to
-Guile because the containing code hasn't been reevaluated yet.
-This string appears after the opening parenthesis of the form where
-the breakpoint is set. If you prefer a marker to appear before the
-opening parenthesis, make this string empty and use
-`gds-new-breakpoint-before-string'."
- :type 'string
- :group 'gds)
-
-(defcustom gds-active-breakpoint-before-string ""
- "*String used to show the presence of a source breakpoint.
-`Active' means that the breakpoint is known to Guile.
-This string appears before the opening parenthesis of the form where
-the breakpoint is set. If you prefer a marker to appear after the
-opening parenthesis, make this string empty and use
-`gds-active-breakpoint-after-string'."
- :type 'string
- :group 'gds)
-
-(defcustom gds-active-breakpoint-after-string "=|= "
- "*String used to show the presence of a source breakpoint.
-`Active' means that the breakpoint is known to Guile.
-This string appears after the opening parenthesis of the form where
-the breakpoint is set. If you prefer a marker to appear before the
-opening parenthesis, make this string empty and use
-`gds-active-breakpoint-before-string'."
- :type 'string
- :group 'gds)
-
-(defun gds-source-breakpoint-pos ()
- "Return the position of the starting parenthesis of the innermost
-Scheme pair around point."
- (if (eq (char-syntax (char-after)) ?\()
- (point)
- (save-excursion
- (condition-case nil
- (while t (forward-sexp -1))
- (error))
- (forward-char -1)
- (while (not (eq (char-syntax (char-after)) ?\())
- (forward-char -1))
- (point))))
-
-(defun gds-source-breakpoint-overlay-at (pos)
- "Return the source breakpoint overlay at POS, if any."
- (let* (o (os (overlays-at pos)))
- (while os
- (if (and (overlay-get (car os) 'gds-breakpoint-info)
- (= (overlay-start (car os)) pos))
- (setq o (car os)
- os nil))
- (setq os (cdr os)))
- o))
-
-(defun gds-set-source-breakpoint ()
- (interactive)
- (let* ((pos (gds-source-breakpoint-pos))
- (o (gds-source-breakpoint-overlay-at pos)))
- (if o
- (error "There is already a breakpoint here!")
- (setq o (make-overlay pos (+ pos 1)))
- (overlay-put o 'evaporate t)
- (overlay-put o 'face gds-breakpoint-face)
- (overlay-put o 'gds-breakpoint-info 0)
- (overlay-put o 'before-string gds-new-breakpoint-before-string)
- (overlay-put o 'after-string gds-new-breakpoint-after-string))))
-
-(defun gds-delete-source-breakpoint ()
- (interactive)
- (let* ((pos (gds-source-breakpoint-pos))
- (o (gds-source-breakpoint-overlay-at pos)))
- (or o
- (error "There is no breakpoint here to delete!"))
- (delete-overlay o)))
-
-(defun gds-region-breakpoint-info (beg end)
- "Return an alist of breakpoints in REGION.
-The car of each alist element is a cons (LINE . COLUMN) giving the
-source location of the breakpoint. The cdr is information describing
-breakpoint properties. Currently `information' is just the breakpoint
-index, for an existing Guile breakpoint, or 0 for a breakpoint that
-isn't yet known to Guile."
- (interactive "r")
- (let ((os (overlays-in beg end))
- info o)
- (while os
- (setq o (car os)
- os (cdr os))
- (if (overlay-get o 'gds-breakpoint-info)
- (progn
- (setq info
- (cons (cons (save-excursion
- (goto-char (overlay-start o))
- (cons (save-excursion
- (beginning-of-line)
- (count-lines (point-min) (point)))
- (current-column)))
- (overlay-get o 'gds-breakpoint-info))
- info))
- ;; Also now mark the breakpoint as `new'. It will become
- ;; `active' (again) when we receive a notification from
- ;; Guile that the breakpoint has been set.
- (overlay-put o 'gds-breakpoint-info 0)
- (overlay-put o 'before-string gds-new-breakpoint-before-string)
- (overlay-put o 'after-string gds-new-breakpoint-after-string))))
- (nreverse info)))
-
-
-;;;; Evaluating code.
-
-;; The following commands send code for evaluation through the GDS TCP
-;; connection, receive the result and any output generated through the
-;; same connection, and display the result and output to the user.
-;;
-;; Where there are multiple Guile applications known to GDS, GDS by
-;; default sends code to the one that holds the debugging focus,
-;; i.e. `gds-focus-client'. Where no application has the focus,
-;; or the command is invoked with `C-u', GDS asks the user which
-;; application is intended.
-
-(defun gds-read-client ()
- (let* ((def (if gds-focus-client
- (cdr (assq gds-focus-client gds-names))))
- (prompt (if def
- (concat "Application for eval (default "
- def
- "): ")
- "Application for eval: "))
- (name
- (completing-read prompt
- (mapcar (function list)
- (mapcar (function cdr) gds-names))
- nil t nil nil
- def)))
- (let (client (names gds-names))
- (while (and names (not client))
- (if (string-equal (cdar names) name)
- (setq client (caar names)))
- (setq names (cdr names)))
- client)))
-
-(defun gds-choose-client (client)
- (or ;; If client is an integer, it is the port number of the
- ;; intended client.
- (if (integerp client) client)
- ;; Any other non-nil value indicates invocation with a prefix
- ;; arg, which forces asking the user which application is
- ;; intended.
- (if client (gds-read-client))
- ;; If ask not forced, and there is a client with the focus,
- ;; default to that one.
- gds-focus-client
- ;; If there are no clients at this point, and we are allowed to
- ;; autostart a captive Guile, do so.
- (and (null gds-buffers)
- gds-autostart-captive
- (progn
- (gds-start-captive t)
- (while (null gds-buffers)
- (accept-process-output (get-buffer-process gds-captive)
- 0 100000))
- (caar gds-buffers)))
- ;; If there is only one known client, use that one.
- (if (and (car gds-buffers)
- (null (cdr gds-buffers)))
- (caar gds-buffers))
- ;; Last resort - ask the user.
- (gds-read-client)
- ;; Signal an error.
- (error "No application chosen.")))
-
-(defun gds-module-name (start end)
- "Determine and return the name of the module that governs the
-specified region. The module name is returned as a list of symbols."
- (interactive "r") ; why not?
- (save-excursion
- (goto-char start)
- (let (module-name)
- (while (and (not module-name)
- (beginning-of-defun-raw 1))
- (if (looking-at "(define-module ")
- (setq module-name
- (progn
- (goto-char (match-end 0))
- (read (current-buffer))))))
- module-name)))
-
-(defun gds-port-name (start end)
- "Return port name for the specified region of the current buffer.
-The name will be used by Guile as the port name when evaluating that
-region's code."
- (or (buffer-file-name)
- (concat "Emacs buffer: " (buffer-name))))
-
-(defun gds-eval-region (start end &optional client)
- "Evaluate the current region."
- (interactive "r\nP")
- (setq client (gds-choose-client client))
- (let ((module (gds-module-name start end))
- (port-name (gds-port-name start end))
- line column)
- (save-excursion
- (goto-char start)
- (setq column (current-column)) ; 0-based
- (beginning-of-line)
- (setq line (count-lines (point-min) (point)))) ; 0-based
- (gds-send (format "(%S eval %s %S %d %d %S %S)\n"
- client
- (if module (prin1-to-string module) "#f")
- port-name line column
- (gds-region-breakpoint-info start end)
- (buffer-substring-no-properties start end)))))
-
-(defun gds-eval-expression (expr &optional client)
- "Evaluate the supplied EXPR (a string)."
- (interactive "sEvaluate expression: \nP")
- (setq client (gds-choose-client client))
- (gds-send (format "(%S eval #f \"Emacs expression\" 0 0 %S)\n"
- client expr)))
-
-(defun gds-eval-defun (&optional client)
- "Evaluate the defun (top-level form) at point."
- (interactive "P")
- (save-excursion
- (end-of-defun)
- (let ((end (point)))
- (beginning-of-defun)
- (gds-eval-region (point) end client))))
-
-(defun gds-eval-last-sexp (&optional client)
- "Evaluate the sexp before point."
- (interactive "P")
- (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client))
-
-
-;;;; Help.
-
-;; Help is implemented as a special case of evaluation, where we
-;; arrange for the evaluation result to be a known symbol that is
-;; unlikely to crop up otherwise. When the evaluation result is this
-;; symbol, we only display the output from the evaluation.
-
-(defvar gds-help-symbol '%-gds-help-%
- "Symbol used by GDS to identify an evaluation response as help.")
-
-(defun gds-help-symbol (sym &optional client)
- "Get help for SYM (a Scheme symbol)."
- (interactive
- (let ((sym (thing-at-point 'symbol))
- (enable-recursive-minibuffers t)
- val)
- (setq val (read-from-minibuffer
- (if sym
- (format "Describe Guile symbol (default %s): " sym)
- "Describe Guile symbol: ")))
- (list (if (zerop (length val)) sym val)
- current-prefix-arg)))
- (gds-eval-expression (format "(begin (help %s) '%S)" sym gds-help-symbol)
- client))
-
-(defun gds-apropos (regex &optional client)
- "List Guile symbols matching REGEX."
- (interactive
- (let ((sym (thing-at-point 'symbol))
- (enable-recursive-minibuffers t)
- val)
- (setq val (read-from-minibuffer
- (if sym
- (format "Guile apropos (regexp, default \"%s\"): " sym)
- "Guile apropos (regexp): ")))
- (list (if (zerop (length val)) sym val)
- current-prefix-arg)))
- (gds-eval-expression (format "(begin (apropos %S) '%S)" regex gds-help-symbol)
- client))
-
-(defvar gds-completion-results nil)
-
-(defun gds-complete-symbol (&optional client)
- "Complete the Guile symbol before point. Returns `t' if anything
-interesting happened, `nil' if not."
- (interactive "P")
- (let* ((chars (- (point) (save-excursion
- (while (let ((syntax (char-syntax (char-before (point)))))
- (or (eq syntax ?w) (eq syntax ?_)))
- (forward-char -1))
- (point)))))
- (if (zerop chars)
- nil
- (setq client (gds-choose-client client))
- (setq gds-completion-results nil)
- (gds-send (format "(%S complete %s)\n" client
- (prin1-to-string
- (buffer-substring-no-properties (- (point) chars)
- (point)))))
- (while (null gds-completion-results)
- (accept-process-output gds-process 0 200))
- (cond ((eq gds-completion-results t)
- nil)
- ((stringp gds-completion-results)
- (if (<= (length gds-completion-results) chars)
- nil
- (insert (substring gds-completion-results chars))
- (message "Sole completion")
- t))
- ((= (length gds-completion-results) 1)
- (if (<= (length (car gds-completion-results)) chars)
- nil
- (insert (substring (car gds-completion-results) chars))
- t))
- (t
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list gds-completion-results))
- t)))))
-
-
-;;;; Display of evaluation and help results.
-
-(defun gds-display-results (client results)
- (let ((helpp (and (= (length results) 2)
- (= (length (cadr results)) 1)
- (string-equal (caadr results)
- (prin1-to-string gds-help-symbol)))))
- (let ((buf (get-buffer-create (if helpp
- "*Guile Help*"
- "*Guile Results*"))))
- (save-excursion
- (set-buffer buf)
- (erase-buffer)
- (scheme-mode)
- (while results
- (insert (car results))
- (if helpp
- nil
- (mapcar (function (lambda (value)
- (insert " => " value "\n")))
- (cadr results))
- (insert "\n"))
- (setq results (cddr results)))
- (goto-char (point-min))
- (if (and helpp (looking-at "Evaluating in "))
- (delete-region (point) (progn (forward-line 1) (point)))))
- (pop-to-buffer buf)
- (run-hooks 'temp-buffer-show-hook)
- (other-window 1))))
-
-
-;;;; Loading (evaluating) a whole Scheme file.
-
-(defcustom gds-source-modes '(scheme-mode)
- "*Used to determine if a buffer contains Scheme source code.
-If it's loaded into a buffer that is in one of these major modes, it's
-considered a scheme source file by `gds-load-file'."
- :type '(repeat function)
- :group 'gds)
-
-(defvar gds-prev-load-dir/file nil
- "Holds the last (directory . file) pair passed to `gds-load-file'.
-Used for determining the default for the next `gds-load-file'.")
-
-(defun gds-load-file (file-name &optional client)
- "Load a Scheme file into the inferior Scheme process."
- (interactive (list (car (comint-get-source "Load Scheme file: "
- gds-prev-load-dir/file
- gds-source-modes t))
- ; T because LOAD needs an
- ; exact name
- current-prefix-arg))
- (comint-check-source file-name) ; Check to see if buffer needs saved.
- (setq gds-prev-load-dir/file (cons (file-name-directory file-name)
- (file-name-nondirectory file-name)))
- (setq client (gds-choose-client client))
- (gds-send (format "(%S load %S)\n" client file-name)))
-
-
-;;;; Scheme mode keymap items.
-
-(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention
-(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention
-(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
-(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
-(define-key scheme-mode-map "\C-c\C-l" 'gds-load-file)
-(define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
-(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
-(define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
-(define-key scheme-mode-map "\C-x " 'gds-set-source-breakpoint)
-(define-key scheme-mode-map "\C-x\e " 'gds-delete-source-breakpoint)
-
-
-;;;; GDS (Guile Interaction) mode keymap and menu items.
-
-(set-keymap-parent gds-mode-map widget-keymap)
-
-(define-key gds-mode-map "M" (function gds-query-modules))
-
-(define-key gds-mode-map "g" (function gds-go))
-(define-key gds-mode-map "q" (function gds-quit))
-(define-key gds-mode-map " " (function gds-next))
-(define-key gds-mode-map "e" (function gds-evaluate))
-(define-key gds-mode-map "i" (function gds-step-in))
-(define-key gds-mode-map "o" (function gds-step-out))
-(define-key gds-mode-map "t" (function gds-trace-finish))
-(define-key gds-mode-map "I" (function gds-frame-info))
-(define-key gds-mode-map "A" (function gds-frame-args))
-
-(define-key gds-mode-map "b" (function gds-set-breakpoint))
-
-(define-key gds-mode-map "vi" (function gds-view-interaction))
-(define-key gds-mode-map "vs" (function gds-view-stack))
-(define-key gds-mode-map "vb" (function gds-view-breakpoints))
-(define-key gds-mode-map "vB" (function gds-view-browser))
-(define-key gds-mode-map "vm" (function gds-view-messages))
-
-(defvar gds-view-menu nil
- "GDS view menu.")
-(if gds-view-menu
- nil
- (setq gds-view-menu (make-sparse-keymap "View"))
- (define-key gds-view-menu [messages]
- '(menu-item "Messages" gds-view-messages
- :enable (memq 'messages gds-views)))
- (define-key gds-view-menu [browser]
- '(menu-item "Browser" gds-view-browser
- :enable (memq 'browser gds-views)))
- (define-key gds-view-menu [breakpoints]
- '(menu-item "Breakpoints" gds-view-breakpoints
- :enable (memq 'breakpoints gds-views)))
- (define-key gds-view-menu [stack]
- '(menu-item "Stack" gds-view-stack
- :enable (memq 'stack gds-views)))
- (define-key gds-view-menu [interaction]
- '(menu-item "Interaction" gds-view-interaction
- :enable (memq 'interaction gds-views))))
-
-(defvar gds-debug-menu nil
- "GDS debugging menu.")
-(if gds-debug-menu
- nil
- (setq gds-debug-menu (make-sparse-keymap "Debug"))
- (define-key gds-debug-menu [go]
- '(menu-item "Go" gds-go))
- (define-key gds-debug-menu [trace-finish]
- '(menu-item "Trace This Frame" gds-trace-finish))
- (define-key gds-debug-menu [step-out]
- '(menu-item "Finish This Frame" gds-step-out))
- (define-key gds-debug-menu [next]
- '(menu-item "Next" gds-next))
- (define-key gds-debug-menu [step-in]
- '(menu-item "Single Step" gds-step-in))
- (define-key gds-debug-menu [eval]
- '(menu-item "Eval In This Frame..." gds-evaluate)))
-
-(defvar gds-breakpoint-menu nil
- "GDS breakpoint menu.")
-(if gds-breakpoint-menu
- nil
- (setq gds-breakpoint-menu (make-sparse-keymap "Breakpoint"))
- (define-key gds-breakpoint-menu [last-sexp]
- '(menu-item "Delete Breakpoint" gds-delete-source-breakpoint))
- (define-key gds-breakpoint-menu [set]
- '(menu-item "Set Breakpoint" gds-set-source-breakpoint)))
-
-(defvar gds-eval-menu nil
- "GDS evaluation menu.")
-(if gds-eval-menu
- nil
- (setq gds-eval-menu (make-sparse-keymap "Evaluate"))
- (define-key gds-eval-menu [load-file]
- '(menu-item "Load Scheme File" gds-load-file))
- (define-key gds-eval-menu [defun]
- '(menu-item "Defun At Point" gds-eval-defun))
- (define-key gds-eval-menu [region]
- '(menu-item "Region" gds-eval-region))
- (define-key gds-eval-menu [last-sexp]
- '(menu-item "Sexp Before Point" gds-eval-last-sexp))
- (define-key gds-eval-menu [expr]
- '(menu-item "Expression..." gds-eval-expression)))
-
-(defvar gds-help-menu nil
- "GDS help menu.")
-(if gds-help-menu
- nil
- (setq gds-help-menu (make-sparse-keymap "Help"))
- (define-key gds-help-menu [apropos]
- '(menu-item "Apropos..." gds-apropos))
- (define-key gds-help-menu [sym]
- '(menu-item "Symbol..." gds-help-symbol)))
-
-(defvar gds-advanced-menu nil
- "Menu of rarely needed GDS operations.")
-(if gds-advanced-menu
- nil
- (setq gds-advanced-menu (make-sparse-keymap "Advanced"))
- (define-key gds-advanced-menu [run-captive]
- '(menu-item "Run Captive Guile" gds-start-captive
- :enable (not (comint-check-proc gds-captive))))
- (define-key gds-advanced-menu [restart-gds]
- '(menu-item "Restart IDE" gds-start :enable gds-process))
- (define-key gds-advanced-menu [kill-gds]
- '(menu-item "Shutdown IDE" gds-shutdown :enable gds-process))
- (define-key gds-advanced-menu [start-gds]
- '(menu-item "Start IDE" gds-start :enable (not gds-process))))
-
-(defvar gds-menu nil
- "Global menu for GDS commands.")
-(if gds-menu
- nil
- (setq gds-menu (make-sparse-keymap "Guile"))
- (define-key gds-menu [advanced]
- (cons "Advanced" gds-advanced-menu))
- (define-key gds-menu [separator-1]
- '("--"))
- (define-key gds-menu [view]
- `(menu-item "View" ,gds-view-menu :enable gds-views))
- (define-key gds-menu [debug]
- `(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client
- (gds-client-blocked))))
- (define-key gds-menu [breakpoint]
- `(menu-item "Breakpoints" ,gds-breakpoint-menu :enable t))
- (define-key gds-menu [eval]
- `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-buffers
- gds-autostart-captive)))
- (define-key gds-menu [help]
- `(menu-item "Help" ,gds-help-menu :enable (or gds-buffers
- gds-autostart-captive)))
- (setq menu-bar-final-items
- (cons 'guile menu-bar-final-items))
- (define-key scheme-mode-map [menu-bar guile]
- (cons "Guile" gds-menu)))
-
-
-;;;; Autostarting the GDS server.
-
-(defcustom gds-autostart-server t
- "Whether to automatically start the GDS server when `gds.el' is loaded."
- :type 'boolean
- :group 'gds)
-
-(if (and gds-autostart-server
- (not gds-process))
- (gds-start))
-
-
-;;;; `Captive' Guile - a Guile process that is started when needed to
-;;;; provide help, completion, evaluations etc.
-
-(defcustom gds-autostart-captive t
- "Whether to automatically start a `captive' Guile process when needed."
- :type 'boolean
- :group 'gds)
-
-(defvar gds-captive nil
- "Buffer of captive Guile.")
-
-(defun gds-start-captive (&optional restart)
- (interactive)
- (if (and restart
- (comint-check-proc gds-captive))
- (gds-kill-captive))
- (if (comint-check-proc gds-captive)
- nil
- (let ((process-connection-type nil))
- (setq gds-captive (make-comint "captive-guile"
- "guile"
- nil
- "-q")))
- (let ((proc (get-buffer-process gds-captive)))
- (comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n")
- (comint-send-string proc "(debug-enable 'backtrace)\n")
- (comint-send-string proc "(use-modules (emacs gds-client))\n")
- (comint-send-string proc "(gds-connect \"Captive Guile\" #f)\n"))))
-
-(defun gds-kill-captive ()
- (if gds-captive
- (let ((proc (get-buffer-process gds-captive)))
- (process-kill-without-query proc)
- (condition-case nil
- (progn
- (kill-process proc)
- (accept-process-output gds-process 0 200))
- (error)))))
-
-
-;;;; The end!
-
-(provide 'gds)
-
-;;; gds.el ends here.
HCoop / bpt / guile.git / blobdiff