emacs/gds.el

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