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           (;; (breakpoint-set FILE LINE COLUMN INFO) - Breakpoint set.
 248            (eq proc 'breakpoint-set)
 249            (let ((file (nth 0 args))
 250                  (line (nth 1 args))
 251                  (column (nth 2 args))
 252                  (info (nth 3 args)))
 253              (with-current-buffer (find-file-noselect file)
 254                (save-excursion
 255                  (goto-char (point-min))
 256                  (or (zerop line)
 257                      (forward-line line))
 258                  (move-to-column column)
 259                  (let ((os (overlays-at (point))) o)
 260                    (while os
 261                      (if (and (overlay-get (car os) 'gds-breakpoint-info)
 262                               (= (overlay-start (car os)) (point)))
 263                          (progn
 264                            (overlay-put (car os)
 265                                         'gds-breakpoint-info
 266                                         info)
 267                            (overlay-put (car os)
 268                                         'before-string
 269                                         gds-active-breakpoint-before-string)
 270                            (overlay-put (car os)
 271                                         'after-string
 272                                         gds-active-breakpoint-after-string)
 273                            (setq os nil))
 274                        (setq os (cdr os)))))))))
 275
 276           )))
 277
 278
 279 ;;;; Per-client buffer state.
 280
 281 ;; This section contains code that is specific to each Guile client's
 282 ;; buffer but independent of any particular `view'.
 283
 284 ;; Alist mapping each client port number to corresponding buffer.
 285 (defvar gds-buffers nil)
 286
 287 (define-derived-mode gds-mode
 288   scheme-mode
 289   "Guile Interaction"
 290   "Major mode for interacting with a Guile client application.")
 291
 292 (defvar gds-client nil
 293   "GDS client's port number.")
 294 (make-variable-buffer-local 'gds-client)
 295
 296 (defvar gds-status nil
 297   "GDS client's latest status, one of the following symbols.
 298 `running' - Application is running.
 299 `waiting-for-input' - Application is blocked waiting for instruction
 300                       from the frontend.
 301 `ready-for-input' - Application is not blocked but can also accept
 302                     asynchronous instructions from the frontend.")
 303 (make-variable-buffer-local 'gds-status)
 304
 305 (defvar gds-transcript nil
 306   "Transcript buffer for this GDS client.")
 307 (make-variable-buffer-local 'gds-transcript)
 308
 309 ;; Return client buffer for specified client and protocol input.
 310 (defun gds-client-buffer (client proc args)
 311   (if (eq proc 'name)
 312       ;; Introduction from client - create a new buffer.
 313       (with-current-buffer (generate-new-buffer (car args))
 314         (gds-mode)
 315         (setq gds-client client)
 316         (setq gds-transcript
 317               (find-file-noselect
 318                (expand-file-name (concat "~/.gds-transcript-" (car args)))))
 319         (with-current-buffer gds-transcript
 320           (goto-char (point-max))
 321           (insert "\nTranscript:\n"))
 322         (setq gds-buffers
 323               (cons (cons client (current-buffer))
 324                     gds-buffers))
 325         (current-buffer))
 326     ;; Otherwise there should be an existing buffer that we can
 327     ;; return.
 328     (let ((existing (assq client gds-buffers)))
 329       (if (buffer-live-p (cdr existing))
 330           (cdr existing)
 331         (setq gds-buffers (delq existing gds-buffers))
 332         (gds-client-buffer client 'name '("(GDS buffer killed)"))))))
 333
 334 (defun gds-client-blocked ()
 335   (eq gds-status 'waiting-for-input))
 336
 337 (defvar gds-delayed-update-timer nil)
 338
 339 (defvar gds-delayed-update-buffers nil)
 340
 341 (defun gds-update-delayed-update-buffers ()
 342   (while gds-delayed-update-buffers
 343     (with-current-buffer (car gds-delayed-update-buffers)
 344       (setq gds-delayed-update-buffers
 345             (cdr gds-delayed-update-buffers))
 346       (gds-update-buffers))))
 347
 348 (defun gds-update-buffers ()
 349   (if (timerp gds-delayed-update-timer)
 350       (cancel-timer gds-delayed-update-timer))
 351   (setq gds-delayed-update-timer nil)
 352   (let ((view (car gds-views))
 353         (inhibit-read-only t))
 354     (cond ((eq view 'stack)
 355            (gds-insert-stack))
 356           ((eq view 'interaction)
 357            (gds-insert-interaction))
 358           ((eq view 'browser)
 359            (gds-insert-modules))
 360           ((eq view 'messages)
 361            (gds-insert-messages))
 362           (t
 363            (error "Bad GDS view %S" view)))
 364     ;; Finish off.
 365     (widget-setup)
 366     (force-mode-line-update t)))
 367
 368 (defun gds-update-buffers-in-a-while ()
 369   (or (memq (current-buffer) gds-delayed-update-buffers)
 370       (setq gds-delayed-update-buffers
 371             (cons (current-buffer) gds-delayed-update-buffers)))
 372   (if (timerp gds-delayed-update-timer)
 373       nil
 374     (setq gds-delayed-update-timer
 375           (run-at-time 0.5 nil (function gds-update-delayed-update-buffers)))))
 376
 377 (defun gds-display-buffers ()
 378   (if gds-focus-client
 379       (let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers))))
 380         ;; If there's already a window showing the buffer, use it.
 381         (let ((window (get-buffer-window gds-focus-buffer t)))
 382           (if window
 383               (progn
 384                 (make-frame-visible (window-frame window))
 385                 (select-frame (window-frame window))
 386                 (select-window window))
 387             ;(select-window (display-buffer gds-focus-buffer))
 388             (display-buffer gds-focus-buffer)))
 389         ;; If there is an associated source buffer, display it as well.
 390         (if (and (eq (car gds-views) 'stack)
 391                  gds-frame-source-overlay
 392                  (> (overlay-end gds-frame-source-overlay) 0))
 393             (let ((window (display-buffer
 394                            (overlay-buffer gds-frame-source-overlay))))
 395               (set-window-point window
 396                                 (overlay-start gds-frame-source-overlay)))))))
 397
 398
 399 ;;;; Management of `views'.
 400
 401 ;; The idea here is to keep the buffer describing a Guile client
 402 ;; relatively uncluttered by only showing one kind of information
 403 ;; about that client at a time.  Menu items and key sequences are
 404 ;; provided to switch easily between the available views.
 405
 406 (defvar gds-views nil
 407   "List of available views for a GDS client.  Each element is one of
 408 the following symbols.
 409 `interaction' - Interaction with running client.
 410 `stack' - Call stack view.
 411 `browser' - Modules and bindings browser view.
 412 `breakpoints' - List of set breakpoints.
 413 `messages' - Non-GDS-protocol output from the debugger.")
 414 (make-variable-buffer-local 'gds-views)
 415
 416 (defun gds-promote-view (view)
 417   (setq gds-views (cons view (delq view gds-views))))
 418
 419 (defun gds-switch-to-view (view)
 420   (or (memq view gds-views)
 421       (error "View %S is not available" view))
 422   (gds-promote-view view)
 423   (gds-update-buffers))
 424
 425 (defun gds-add-view (view)
 426   (or (memq view gds-views)
 427       (setq gds-views (append gds-views (list view)))))
 428
 429 (defun gds-delete-view (view)
 430   (setq gds-views (delq view gds-views)))
 431
 432
 433 ;;;; `Interaction' view.
 434
 435 ;; This view provides interaction with a normally running Guile
 436 ;; client, in other words one that is not stopped in the debugger but
 437 ;; is still available to take input from GDS (usually via a thread for
 438 ;; that purpose).  The view supports evaluation, help requests,
 439 ;; control of `debug-on-exception' function, and methods for breaking
 440 ;; into the running code.
 441
 442 (defvar gds-current-module "()"
 443   "GDS client's current module.")
 444 (make-variable-buffer-local 'gds-current-module)
 445
 446 (defvar gds-pid nil
 447   "GDS client's process ID.")
 448 (make-variable-buffer-local 'gds-pid)
 449
 450 (defvar gds-debug-exceptions nil
 451   "Whether to debug exceptions.")
 452 (make-variable-buffer-local 'gds-debug-exceptions)
 453
 454 (defvar gds-exception-keys "signal misc-error"
 455   "The exception keys for which to debug a GDS client.")
 456 (make-variable-buffer-local 'gds-exception-keys)
 457
 458 (defun gds-insert-interaction ()
 459   (erase-buffer)
 460   ;; Insert stuff for interacting with a running (non-blocked) Guile
 461   ;; client.
 462   (widget-insert (buffer-name)
 463                  ", "
 464                  (cdr (assq gds-status
 465                             '((running . "running (cannot accept input)")
 466                               (waiting-for-input . "waiting for input")
 467                               (ready-for-input . "running")
 468                               (closed . "closed"))))
 469                  ", in "
 470                  gds-current-module
 471                  "\n")
 472   (widget-create 'push-button
 473                  :notify (function gds-sigint)
 474                  "SIGINT")
 475   (widget-insert " ")
 476   (widget-create 'push-button
 477                  :notify (function gds-async-break)
 478                  "Break")
 479   (widget-insert "\n")
 480   (widget-create 'checkbox
 481                  :notify (function gds-toggle-debug-exceptions)
 482                  gds-debug-exceptions)
 483   (widget-insert " Debug exception keys: ")
 484   (widget-create 'editable-field
 485                  :notify (function gds-set-exception-keys)
 486                  gds-exception-keys)
 487   (widget-insert "\n"))
 488
 489 (defun gds-sigint (w &rest ignore)
 490   (interactive)
 491   (signal-process gds-pid 2))
 492
 493 (defun gds-async-break (w &rest ignore)
 494   (interactive)
 495   (gds-send (format "(%S async-break)\n" gds-focus-client)))
 496
 497 (defun gds-toggle-debug-exceptions (w &rest ignore)
 498   (interactive)
 499   (setq gds-debug-exceptions (widget-value w))
 500   (gds-eval-expression (concat "(use-modules (ice-9 debugger))"
 501                                "(debug-on-error '("
 502                                gds-exception-keys
 503                                "))")))
 504
 505 (defun gds-set-exception-keys (w &rest ignore)
 506   (interactive)
 507   (setq gds-exception-keys (widget-value w)))
 508
 509 (defun gds-view-interaction ()
 510   (interactive)
 511   (gds-switch-to-view 'interaction))
 512
 513
 514 ;;;; `Stack' view.
 515
 516 ;; This view shows the Guile call stack after the application has hit
 517 ;; an error, or when it is stopped in the debugger.
 518
 519 (defvar gds-stack nil
 520   "GDS client's stack when last stopped.")
 521 (make-variable-buffer-local 'gds-stack)
 522
 523 (defun gds-insert-stack ()
 524   (erase-buffer)
 525   (let ((frames (car gds-stack))
 526         (index (cadr gds-stack))
 527         (flags (caddr gds-stack))
 528         frame items)
 529     (cond ((memq 'application flags)
 530            (widget-insert "Calling procedure:\n"))
 531           ((memq 'evaluation flags)
 532            (widget-insert "Evaluating expression:\n"))
 533           ((memq 'return flags)
 534            (widget-insert "Return value: "
 535                           (cadr (memq 'return flags))
 536                           "\n"))
 537           (t
 538            (widget-insert "Stack: " (prin1-to-string flags) "\n")))
 539     (let ((i -1))
 540       (gds-show-selected-frame (caddr (nth index frames)))
 541       (while frames
 542         (setq frame (car frames)
 543               frames (cdr frames)
 544               i (+ i 1)
 545               items (cons (list 'item
 546                                 (let ((s (cadr frame)))
 547                                   (put-text-property 0 1 'index i s)
 548                                   s))
 549                           items))))
 550     (setq items (nreverse items))
 551     (apply (function widget-create)
 552              'radio-button-choice
 553              :value (cadr (nth index items))
 554              :notify (function gds-select-stack-frame)
 555              items)
 556     (widget-insert "\n")
 557     (goto-char (point-min))))
 558
 559 (defun gds-select-stack-frame (widget &rest ignored)
 560   (let* ((s (widget-value widget))
 561          (ind (memq 'index (text-properties-at 0 s))))
 562     (gds-send (format "(%S debugger-command frame %d)\n"
 563                       gds-focus-client
 564                       (cadr ind)))))
 565
 566 ;; Overlay used to highlight the source expression corresponding to
 567 ;; the selected frame.
 568 (defvar gds-frame-source-overlay nil)
 569
 570 (defun gds-show-selected-frame (source)
 571   ;; Highlight the frame source, if possible.
 572   (if (and source
 573            (file-readable-p (car source)))
 574       (with-current-buffer (find-file-noselect (car source))
 575         (if gds-frame-source-overlay
 576             nil
 577           (setq gds-frame-source-overlay (make-overlay 0 0))
 578           (overlay-put gds-frame-source-overlay 'face 'highlight))
 579         ;; Move to source line.  Note that Guile line numbering is
 580         ;; 0-based, while Emacs numbering is 1-based.
 581         (save-restriction
 582           (widen)
 583           (goto-line (+ (cadr source) 1))
 584           (move-to-column (caddr source))
 585           (move-overlay gds-frame-source-overlay
 586                         (point)
 587                         (if (not (looking-at ")"))
 588                             (save-excursion (forward-sexp 1) (point))
 589                           ;; It seems that the source coordinates for
 590                           ;; backquoted expressions are at the end of
 591                           ;; the sexp rather than the beginning...
 592                           (save-excursion (forward-char 1)
 593                                           (backward-sexp 1) (point)))
 594                         (current-buffer))))
 595     (if gds-frame-source-overlay
 596         (move-overlay gds-frame-source-overlay 0 0))))
 597
 598 (defun gds-view-stack ()
 599   (interactive)
 600   (gds-switch-to-view 'stack))
 601
 602
 603 ;;;; `Breakpoints' view.
 604
 605 ;; This view shows a list of breakpoints.
 606
 607 (defun gds-view-breakpoints ()
 608   (interactive)
 609   (gds-switch-to-view 'breakpoints))
 610
 611
 612 ;;;; `Browser' view.
 613
 614 ;; This view shows a list of modules and module bindings.
 615
 616 (defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil))
 617   "Specification of which Guile modules the debugger should display.
 618 This is a list with structure (DEFAULT EXCEPTION EXCEPTION...), where
 619 DEFAULT is `t' or `nil' and each EXCEPTION has the structure (SYMBOL
 620 DEFAULT EXCEPTION EXCEPTION...).
 621
 622 A Guile module name `(x y z)' is matched against this filter as
 623 follows.  If one of the top level EXCEPTIONs has SYMBOL `x', continue
 624 by matching the rest of the module name, in this case `(y z)', against
 625 that SYMBOL's DEFAULT and next level EXCEPTION list.  Otherwise, if
 626 the current DEFAULT is `t' display the module, and if the current
 627 DEFAULT is `nil', don't display it.
 628
 629 This variable is usually set to exclude Guile system modules that are
 630 not of primary interest when debugging application code."
 631   :type 'sexp
 632   :group 'gds)
 633
 634 (defun gds-show-module-p (name)
 635   ;; Determine whether to display the NAMEd module by matching NAME
 636   ;; against `gds-module-filter'.
 637   (let ((default (car gds-module-filter))
 638         (exceptions (cdr gds-module-filter)))
 639     (let ((exception (assq (car name) exceptions)))
 640       (if exception
 641           (let ((gds-module-filter (cdr exception)))
 642             (gds-show-module-p (cdr name)))
 643         default))))
 644
 645 (defvar gds-modules nil
 646   "GDS client's module information.
 647 Alist mapping module names to their symbols and related information.
 648 This looks like:
 649
 650  (((guile) t sym1 sym2 ...)
 651   ((guile-user))
 652   ((ice-9 debug) nil sym3 sym4)
 653   ...)
 654
 655 The `t' or `nil' after the module name indicates whether the module is
 656 displayed in expanded form (that is, showing the bindings in that
 657 module).  The syms are actually all strings because some Guile symbols
 658 are not readable by Emacs.")
 659 (make-variable-buffer-local 'gds-modules)
 660
 661 (defun gds-insert-modules ()
 662   (let ((p (if (eq (window-buffer (selected-window)) (current-buffer))
 663                (point)
 664              (point-min)))
 665         (modules gds-modules))
 666     (erase-buffer)
 667     (insert "Modules:\n")
 668     (while modules
 669       (let ((minfo (car modules)))
 670         (if (gds-show-module-p (car minfo))
 671             (let ((w (widget-create 'push-button
 672                                     :notify (function gds-module-notify)
 673                                     (if (and (cdr minfo)
 674                                              (cadr minfo))
 675                                         "-" "+"))))
 676               (widget-put w :module (cons gds-client (car minfo)))
 677               (widget-insert " " (prin1-to-string (car minfo)) "\n")
 678               (if (cadr minfo)
 679                   (let ((syms (cddr minfo)))
 680                     (while syms
 681                       (widget-insert " > " (car syms) "\n")
 682                       (setq syms (cdr syms))))))))
 683       (setq modules (cdr modules)))
 684     (insert "\n")
 685     (goto-char p)))
 686
 687 (defun gds-module-notify (w &rest ignore)
 688   (let* ((module (widget-get w :module))
 689          (client (car module))
 690          (name (cdr module))
 691          (minfo (assoc name gds-modules)))
 692     (if (cdr minfo)
 693         ;; Just toggle expansion state.
 694         (progn
 695           (setcar (cdr minfo) (not (cadr minfo)))
 696           (gds-update-buffers))
 697       ;; Set flag to indicate module expanded.
 698       (setcdr minfo (list t))
 699       ;; Get symlist from Guile.
 700       (gds-send (format "(%S query-module %S)\n" client name)))))
 701
 702 (defun gds-query-modules ()
 703   (interactive)
 704   (gds-send (format "(%S query-modules)\n" gds-focus-client)))
 705
 706 (defun gds-view-browser ()
 707   (interactive)
 708   (or gds-modules (gds-query-modules))
 709   (gds-switch-to-view 'browser))
 710
 711
 712 ;;;; `Messages' view.
 713
 714 ;; This view shows recent non-GDS-protocol messages output from the
 715 ;; (ice-9 debugger) code.
 716
 717 (defvar gds-output nil
 718   "GDS client's recent output (printed).")
 719 (make-variable-buffer-local 'gds-output)
 720
 721 (defun gds-insert-messages ()
 722   (erase-buffer)
 723   ;; Insert recent non-protocol output from (ice-9 debugger).
 724   (insert gds-output)
 725   (goto-char (point-min)))
 726
 727 (defun gds-view-messages ()
 728   (interactive)
 729   (gds-switch-to-view 'messages))
 730
 731
 732 ;;;; Debugger commands.
 733
 734 ;; Typically but not necessarily used from the `stack' view.
 735
 736 (defun gds-go ()
 737   (interactive)
 738   (gds-send (format "(%S debugger-command continue)\n" gds-focus-client)))
 739
 740 (defun gds-next ()
 741   (interactive)
 742   (gds-send (format "(%S debugger-command next 1)\n" gds-focus-client)))
 743
 744 (defun gds-evaluate (expr)
 745   (interactive "sEvaluate (in this stack frame): ")
 746   (gds-send (format "(%S debugger-command evaluate %s)\n"
 747                     gds-focus-client
 748                     (prin1-to-string expr))))
 749
 750 (defun gds-step-in ()
 751   (interactive)
 752   (gds-send (format "(%S debugger-command step 1)\n" gds-focus-client)))
 753
 754 (defun gds-step-out ()
 755   (interactive)
 756   (gds-send (format "(%S debugger-command finish)\n" gds-focus-client)))
 757
 758 (defun gds-trace-finish ()
 759   (interactive)
 760   (gds-send (format "(%S debugger-command trace-finish)\n"
 761                     gds-focus-client)))
 762
 763 (defun gds-frame-info ()
 764   (interactive)
 765   (gds-send (format "(%S debugger-command info-frame)\n" gds-focus-client)))
 766
 767 (defun gds-frame-args ()
 768   (interactive)
 769   (gds-send (format "(%S debugger-command info-args)\n" gds-focus-client)))
 770
 771
 772 ;;;; Setting breakpoints.
 773
 774 (defun gds-set-breakpoint ()
 775   (interactive)
 776   (cond ((gds-in-source-buffer)
 777          (gds-set-source-breakpoint))
 778         ((gds-in-stack)
 779          (gds-set-stack-breakpoint))
 780         ((gds-in-modules)
 781          (gds-set-module-breakpoint))
 782         (t
 783          (error "No way to set a breakpoint from here"))))
 784
 785 (defun gds-in-source-buffer ()
 786   ;; Not yet worked out what will be available in Scheme source
 787   ;; buffers.
 788   nil)
 789
 790 (defun gds-in-stack ()
 791   (save-excursion
 792     (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
 793          (looking-at "Stack"))))
 794
 795 (defun gds-in-modules ()
 796   (save-excursion
 797     (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
 798          (looking-at "Modules"))))
 799
 800 (defun gds-set-module-breakpoint ()
 801   (let ((sym (save-excursion
 802                (beginning-of-line)
 803                (and (looking-at " > \\([^ \n\t]+\\)")
 804                     (match-string 1))))
 805         (module (save-excursion
 806                   (and (re-search-backward "^\\[[+---]\\] \\(([^)]+)\\)" nil t)
 807                        (match-string 1)))))
 808     (or sym
 809         (error "Couldn't find procedure name on current line"))
 810     (or module
 811         (error "Couldn't find module name for current line"))
 812     (let ((behaviour
 813            (completing-read
 814             (format "Behaviour for breakpoint at %s:%s (default debug-here): "
 815                     module sym)
 816             '(("debug-here")
 817               ("trace-here")
 818               ("trace-subtree"))
 819             nil
 820             t
 821             nil
 822             nil
 823             "debug-here")))
 824       (gds-send (format "(%S set-breakpoint %s %s %s)\n"
 825                         gds-focus-client
 826                         module
 827                         sym
 828                         behaviour)))))
 829
 830
 831 ;;;; Scheme source breakpoints.
 832
 833 (defcustom gds-breakpoint-face 'default
 834   "*Face used to highlight the location of a source breakpoint.
 835 Specifically, this face highlights the opening parenthesis of the
 836 form where the breakpoint is set."
 837   :type 'face
 838   :group 'gds)
 839
 840 (defcustom gds-new-breakpoint-before-string ""
 841   "*String used to show the presence of a new source breakpoint.
 842 `New' means that the breakpoint has been set but isn't yet known to
 843 Guile because the containing code hasn't been reevaluated yet.
 844 This string appears before the opening parenthesis of the form where
 845 the breakpoint is set.  If you prefer a marker to appear after the
 846 opening parenthesis, make this string empty and use
 847 `gds-new-breakpoint-after-string'."
 848   :type 'string
 849   :group 'gds)
 850
 851 (defcustom gds-new-breakpoint-after-string "=?= "
 852   "*String used to show the presence of a new source breakpoint.
 853 `New' means that the breakpoint has been set but isn't yet known to
 854 Guile because the containing code hasn't been reevaluated yet.
 855 This string appears after the opening parenthesis of the form where
 856 the breakpoint is set.  If you prefer a marker to appear before the
 857 opening parenthesis, make this string empty and use
 858 `gds-new-breakpoint-before-string'."
 859   :type 'string
 860   :group 'gds)
 861
 862 (defcustom gds-active-breakpoint-before-string ""
 863   "*String used to show the presence of a source breakpoint.
 864 `Active' means that the breakpoint is known to Guile.
 865 This string appears before the opening parenthesis of the form where
 866 the breakpoint is set.  If you prefer a marker to appear after the
 867 opening parenthesis, make this string empty and use
 868 `gds-active-breakpoint-after-string'."
 869   :type 'string
 870   :group 'gds)
 871
 872 (defcustom gds-active-breakpoint-after-string "=|= "
 873   "*String used to show the presence of a source breakpoint.
 874 `Active' means that the breakpoint is known to Guile.
 875 This string appears after the opening parenthesis of the form where
 876 the breakpoint is set.  If you prefer a marker to appear before the
 877 opening parenthesis, make this string empty and use
 878 `gds-active-breakpoint-before-string'."
 879   :type 'string
 880   :group 'gds)
 881
 882 (defun gds-source-breakpoint-pos ()
 883   "Return the position of the starting parenthesis of the innermost
 884 Scheme pair around point."
 885   (if (eq (char-syntax (char-after)) ?\()
 886       (point)
 887     (save-excursion
 888       (condition-case nil
 889           (while t (forward-sexp -1))
 890         (error))
 891       (forward-char -1)
 892       (while (not (eq (char-syntax (char-after)) ?\())
 893         (forward-char -1))
 894       (point))))
 895
 896 (defun gds-source-breakpoint-overlay-at (pos)
 897   "Return the source breakpoint overlay at POS, if any."
 898   (let* (o (os (overlays-at pos)))
 899     (while os
 900       (if (and (overlay-get (car os) 'gds-breakpoint-info)
 901                (= (overlay-start (car os)) pos))
 902           (setq o (car os)
 903                 os nil))
 904       (setq os (cdr os)))
 905     o))
 906
 907 (defun gds-set-source-breakpoint ()
 908   (interactive)
 909   (let* ((pos (gds-source-breakpoint-pos))
 910          (o (gds-source-breakpoint-overlay-at pos)))
 911     (if o
 912         (error "There is already a breakpoint here!")
 913       (setq o (make-overlay pos (+ pos 1)))
 914       (overlay-put o 'evaporate t)
 915       (overlay-put o 'face gds-breakpoint-face)
 916       (overlay-put o 'gds-breakpoint-info 0)
 917       (overlay-put o 'before-string gds-new-breakpoint-before-string)
 918       (overlay-put o 'after-string gds-new-breakpoint-after-string))))
 919
 920 (defun gds-delete-source-breakpoint ()
 921   (interactive)
 922   (let* ((pos (gds-source-breakpoint-pos))
 923          (o (gds-source-breakpoint-overlay-at pos)))
 924     (or o
 925         (error "There is no breakpoint here to delete!"))
 926     (delete-overlay o)))
 927
 928 (defun gds-region-breakpoint-info (beg end)
 929   "Return an alist of breakpoints in REGION.
 930 The car of each alist element is a cons (LINE . COLUMN) giving the
 931 source location of the breakpoint.  The cdr is information describing
 932 breakpoint properties.  Currently `information' is just the breakpoint
 933 index, for an existing Guile breakpoint, or 0 for a breakpoint that
 934 isn't yet known to Guile."
 935   (interactive "r")
 936   (let ((os (overlays-in beg end))
 937         info o)
 938     (while os
 939       (setq o (car os)
 940             os (cdr os))
 941       (if (overlay-get o 'gds-breakpoint-info)
 942           (progn
 943             (setq info
 944                   (cons (cons (save-excursion
 945                                 (goto-char (overlay-start o))
 946                                 (cons (save-excursion
 947                                         (beginning-of-line)
 948                                         (count-lines (point-min) (point)))
 949                                       (current-column)))
 950                               (overlay-get o 'gds-breakpoint-info))
 951                         info))
 952             ;; Also now mark the breakpoint as `new'.  It will become
 953             ;; `active' (again) when we receive a notification from
 954             ;; Guile that the breakpoint has been set.
 955             (overlay-put o 'gds-breakpoint-info 0)
 956             (overlay-put o 'before-string gds-new-breakpoint-before-string)
 957             (overlay-put o 'after-string gds-new-breakpoint-after-string))))
 958     (nreverse info)))
 959
 960
 961 ;;;; Evaluating code.
 962
 963 ;; The following commands send code for evaluation through the GDS TCP
 964 ;; connection, receive the result and any output generated through the
 965 ;; same connection, and display the result and output to the user.
 966 ;;
 967 ;; Where there are multiple Guile applications known to GDS, GDS by
 968 ;; default sends code to the one that holds the debugging focus,
 969 ;; i.e. `gds-focus-client'.  Where no application has the focus,
 970 ;; or the command is invoked with `C-u', GDS asks the user which
 971 ;; application is intended.
 972
 973 (defun gds-read-client ()
 974   (let* ((def (if gds-focus-client
 975                   (cdr (assq gds-focus-client gds-names))))
 976          (prompt (if def
 977                      (concat "Application for eval (default "
 978                              def
 979                              "): ")
 980                    "Application for eval: "))
 981          (name
 982           (completing-read prompt
 983                            (mapcar (function list)
 984                                    (mapcar (function cdr) gds-names))
 985                            nil t nil nil
 986                            def)))
 987     (let (client (names gds-names))
 988       (while (and names (not client))
 989         (if (string-equal (cdar names) name)
 990             (setq client (caar names)))
 991         (setq names (cdr names)))
 992       client)))
 993
 994 (defun gds-choose-client (client)
 995   (or ;; If client is an integer, it is the port number of the
 996       ;; intended client.
 997       (if (integerp client) client)
 998       ;; Any other non-nil value indicates invocation with a prefix
 999       ;; arg, which forces asking the user which application is
1000       ;; intended.
1001       (if client (gds-read-client))
1002       ;; If ask not forced, and there is a client with the focus,
1003       ;; default to that one.
1004       gds-focus-client
1005       ;; If there are no clients at this point, and we are allowed to
1006       ;; autostart a captive Guile, do so.
1007       (and (null gds-buffers)
1008            gds-autostart-captive
1009            (progn
1010              (gds-start-captive t)
1011              (while (null gds-buffers)
1012                (accept-process-output (get-buffer-process gds-captive)
1013                                       0 100000))
1014              (caar gds-buffers)))
1015       ;; If there is only one known client, use that one.
1016       (if (and (car gds-buffers)
1017                (null (cdr gds-buffers)))
1018           (caar gds-buffers))
1019       ;; Last resort - ask the user.
1020       (gds-read-client)
1021       ;; Signal an error.
1022       (error "No application chosen.")))
1023
1024 (defun gds-module-name (start end)
1025   "Determine and return the name of the module that governs the
1026 specified region.  The module name is returned as a list of symbols."
1027   (interactive "r")                     ; why not?
1028   (save-excursion
1029     (goto-char start)
1030     (let (module-name)
1031       (while (and (not module-name)
1032                   (beginning-of-defun-raw 1))
1033         (if (looking-at "(define-module ")
1034             (setq module-name
1035                   (progn
1036                     (goto-char (match-end 0))
1037                     (read (current-buffer))))))
1038       module-name)))
1039
1040 (defun gds-port-name (start end)
1041   "Return port name for the specified region of the current buffer.
1042 The name will be used by Guile as the port name when evaluating that
1043 region's code."
1044   (or (buffer-file-name)
1045       (concat "Emacs buffer: " (buffer-name))))
1046
1047 (defun gds-eval-region (start end &optional client)
1048   "Evaluate the current region."
1049   (interactive "r\nP")
1050   (setq client (gds-choose-client client))
1051   (let ((module (gds-module-name start end))
1052         (port-name (gds-port-name start end))
1053         line column)
1054     (save-excursion
1055       (goto-char start)
1056       (setq column (current-column))    ; 0-based
1057       (beginning-of-line)
1058       (setq line (count-lines (point-min) (point)))) ; 0-based
1059     (gds-send (format "(%S eval %s %S %d %d %S %S)\n"
1060                       client
1061                       (if module (prin1-to-string module) "#f")
1062                       port-name line column
1063                       (gds-region-breakpoint-info start end)
1064                       (buffer-substring-no-properties start end)))))
1065
1066 (defun gds-eval-expression (expr &optional client)
1067   "Evaluate the supplied EXPR (a string)."
1068   (interactive "sEvaluate expression: \nP")
1069   (setq client (gds-choose-client client))
1070   (gds-send (format "(%S eval #f \"Emacs expression\" 0 0 %S)\n"
1071                     client expr)))
1072
1073 (defun gds-eval-defun (&optional client)
1074   "Evaluate the defun (top-level form) at point."
1075   (interactive "P")
1076   (save-excursion
1077    (end-of-defun)
1078    (let ((end (point)))
1079      (beginning-of-defun)
1080      (gds-eval-region (point) end client))))
1081
1082 (defun gds-eval-last-sexp (&optional client)
1083   "Evaluate the sexp before point."
1084   (interactive "P")
1085   (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client))
1086
1087
1088 ;;;; Help.
1089
1090 ;; Help is implemented as a special case of evaluation, where we
1091 ;; arrange for the evaluation result to be a known symbol that is
1092 ;; unlikely to crop up otherwise.  When the evaluation result is this
1093 ;; symbol, we only display the output from the evaluation.
1094
1095 (defvar gds-help-symbol '%-gds-help-%
1096   "Symbol used by GDS to identify an evaluation response as help.")
1097
1098 (defun gds-help-symbol (sym &optional client)
1099   "Get help for SYM (a Scheme symbol)."
1100   (interactive
1101    (let ((sym (thing-at-point 'symbol))
1102          (enable-recursive-minibuffers t)
1103          val)
1104      (setq val (read-from-minibuffer
1105                 (if sym
1106                     (format "Describe Guile symbol (default %s): " sym)
1107                   "Describe Guile symbol: ")))
1108      (list (if (zerop (length val)) sym val)
1109            current-prefix-arg)))
1110   (gds-eval-expression (format "(begin (help %s) '%S)" sym gds-help-symbol)
1111                        client))
1112
1113 (defun gds-apropos (regex &optional client)
1114   "List Guile symbols matching REGEX."
1115   (interactive
1116    (let ((sym (thing-at-point 'symbol))
1117          (enable-recursive-minibuffers t)
1118          val)
1119      (setq val (read-from-minibuffer
1120                 (if sym
1121                     (format "Guile apropos (regexp, default \"%s\"): " sym)
1122                   "Guile apropos (regexp): ")))
1123      (list (if (zerop (length val)) sym val)
1124            current-prefix-arg)))
1125   (gds-eval-expression (format "(begin (apropos %S) '%S)" regex gds-help-symbol)
1126                        client))
1127
1128 (defvar gds-completion-results nil)
1129
1130 (defun gds-complete-symbol (&optional client)
1131   "Complete the Guile symbol before point.  Returns `t' if anything
1132 interesting happened, `nil' if not."
1133   (interactive "P")
1134   (let* ((chars (- (point) (save-excursion
1135                              (while (let ((syntax (char-syntax (char-before (point)))))
1136                                       (or (eq syntax ?w) (eq syntax ?_)))
1137                                (forward-char -1))
1138                              (point)))))
1139     (if (zerop chars)
1140         nil
1141       (setq client (gds-choose-client client))
1142       (setq gds-completion-results nil)
1143       (gds-send (format "(%S complete %s)\n" client
1144                         (prin1-to-string
1145                          (buffer-substring-no-properties (- (point) chars)
1146                                                          (point)))))
1147       (while (null gds-completion-results)
1148         (accept-process-output gds-process 0 200))
1149       (cond ((eq gds-completion-results t)
1150              nil)
1151             ((stringp gds-completion-results)
1152              (if (<= (length gds-completion-results) chars)
1153                  nil
1154                (insert (substring gds-completion-results chars))
1155                (message "Sole completion")
1156                t))
1157             ((= (length gds-completion-results) 1)
1158              (if (<= (length (car gds-completion-results)) chars)
1159                  nil
1160                (insert (substring (car gds-completion-results) chars))
1161                t))
1162             (t
1163              (with-output-to-temp-buffer "*Completions*"
1164                (display-completion-list gds-completion-results))
1165              t)))))
1166
1167
1168 ;;;; Display of evaluation and help results.
1169
1170 (defun gds-display-results (client results)
1171   (let ((helpp (and (= (length results) 2)
1172                     (= (length (cadr results)) 1)
1173                     (string-equal (caadr results)
1174                                   (prin1-to-string gds-help-symbol)))))
1175     (let ((buf (get-buffer-create (if helpp
1176                                       "*Guile Help*"
1177                                     "*Guile Results*"))))
1178       (save-excursion
1179         (set-buffer buf)
1180         (erase-buffer)
1181         (scheme-mode)
1182         (while results
1183           (insert (car results))
1184           (if helpp
1185               nil
1186             (mapcar (function (lambda (value)
1187                                 (insert " => " value "\n")))
1188                     (cadr results))
1189             (insert "\n"))
1190           (setq results (cddr results)))
1191         (goto-char (point-min))
1192         (if (and helpp (looking-at "Evaluating in "))
1193             (delete-region (point) (progn (forward-line 1) (point)))))
1194       (pop-to-buffer buf)
1195       (run-hooks 'temp-buffer-show-hook)
1196       (other-window 1))))
1197
1198
1199 ;;;; Loading (evaluating) a whole Scheme file.
1200
1201 (defcustom gds-source-modes '(scheme-mode)
1202   "*Used to determine if a buffer contains Scheme source code.
1203 If it's loaded into a buffer that is in one of these major modes, it's
1204 considered a scheme source file by `gds-load-file'."
1205   :type '(repeat function)
1206   :group 'gds)
1207
1208 (defvar gds-prev-load-dir/file nil
1209   "Holds the last (directory . file) pair passed to `gds-load-file'.
1210 Used for determining the default for the next `gds-load-file'.")
1211
1212 (defun gds-load-file (file-name &optional client)
1213   "Load a Scheme file into the inferior Scheme process."
1214   (interactive (list (car (comint-get-source "Load Scheme file: "
1215                                              gds-prev-load-dir/file
1216                                              gds-source-modes t))
1217                                         ; T because LOAD needs an
1218                                         ; exact name
1219                      current-prefix-arg))
1220   (comint-check-source file-name) ; Check to see if buffer needs saved.
1221   (setq gds-prev-load-dir/file (cons (file-name-directory    file-name)
1222                                      (file-name-nondirectory file-name)))
1223   (setq client (gds-choose-client client))
1224   (gds-send (format "(%S load %S)\n" client file-name)))
1225
1226
1227 ;;;; Scheme mode keymap items.
1228
1229 (define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention
1230 (define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention
1231 (define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
1232 (define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
1233 (define-key scheme-mode-map "\C-c\C-l" 'gds-load-file)
1234 (define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
1235 (define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
1236 (define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
1237 (define-key scheme-mode-map "\C-x " 'gds-set-source-breakpoint)
1238 (define-key scheme-mode-map "\C-x\e " 'gds-delete-source-breakpoint)
1239
1240
1241 ;;;; GDS (Guile Interaction) mode keymap and menu items.
1242
1243 (set-keymap-parent gds-mode-map widget-keymap)
1244
1245 (define-key gds-mode-map "M" (function gds-query-modules))
1246
1247 (define-key gds-mode-map "g" (function gds-go))
1248 (define-key gds-mode-map "q" (function gds-quit))
1249 (define-key gds-mode-map " " (function gds-next))
1250 (define-key gds-mode-map "e" (function gds-evaluate))
1251 (define-key gds-mode-map "i" (function gds-step-in))
1252 (define-key gds-mode-map "o" (function gds-step-out))
1253 (define-key gds-mode-map "t" (function gds-trace-finish))
1254 (define-key gds-mode-map "I" (function gds-frame-info))
1255 (define-key gds-mode-map "A" (function gds-frame-args))
1256
1257 (define-key gds-mode-map "b" (function gds-set-breakpoint))
1258
1259 (define-key gds-mode-map "vi" (function gds-view-interaction))
1260 (define-key gds-mode-map "vs" (function gds-view-stack))
1261 (define-key gds-mode-map "vb" (function gds-view-breakpoints))
1262 (define-key gds-mode-map "vB" (function gds-view-browser))
1263 (define-key gds-mode-map "vm" (function gds-view-messages))
1264
1265 (defvar gds-view-menu nil
1266   "GDS view menu.")
1267 (if gds-view-menu
1268     nil
1269   (setq gds-view-menu (make-sparse-keymap "View"))
1270   (define-key gds-view-menu [messages]
1271     '(menu-item "Messages" gds-view-messages
1272                 :enable (memq 'messages gds-views)))
1273   (define-key gds-view-menu [browser]
1274     '(menu-item "Browser" gds-view-browser
1275                 :enable (memq 'browser gds-views)))
1276   (define-key gds-view-menu [breakpoints]
1277     '(menu-item "Breakpoints" gds-view-breakpoints
1278                 :enable (memq 'breakpoints gds-views)))
1279   (define-key gds-view-menu [stack]
1280     '(menu-item "Stack" gds-view-stack
1281                 :enable (memq 'stack gds-views)))
1282   (define-key gds-view-menu [interaction]
1283     '(menu-item "Interaction" gds-view-interaction
1284                 :enable (memq 'interaction gds-views))))
1285
1286 (defvar gds-debug-menu nil
1287   "GDS debugging menu.")
1288 (if gds-debug-menu
1289     nil
1290   (setq gds-debug-menu (make-sparse-keymap "Debug"))
1291   (define-key gds-debug-menu [go]
1292     '(menu-item "Go" gds-go))
1293   (define-key gds-debug-menu [trace-finish]
1294     '(menu-item "Trace This Frame" gds-trace-finish))
1295   (define-key gds-debug-menu [step-out]
1296     '(menu-item "Finish This Frame" gds-step-out))
1297   (define-key gds-debug-menu [next]
1298     '(menu-item "Next" gds-next))
1299   (define-key gds-debug-menu [step-in]
1300     '(menu-item "Single Step" gds-step-in))
1301   (define-key gds-debug-menu [eval]
1302     '(menu-item "Eval In This Frame..." gds-evaluate)))
1303
1304 (defvar gds-breakpoint-menu nil
1305   "GDS breakpoint menu.")
1306 (if gds-breakpoint-menu
1307     nil
1308   (setq gds-breakpoint-menu (make-sparse-keymap "Breakpoint"))
1309   (define-key gds-breakpoint-menu [last-sexp]
1310     '(menu-item "Delete Breakpoint" gds-delete-source-breakpoint))
1311   (define-key gds-breakpoint-menu [set]
1312     '(menu-item "Set Breakpoint" gds-set-source-breakpoint)))
1313
1314 (defvar gds-eval-menu nil
1315   "GDS evaluation menu.")
1316 (if gds-eval-menu
1317     nil
1318   (setq gds-eval-menu (make-sparse-keymap "Evaluate"))
1319   (define-key gds-eval-menu [load-file]
1320     '(menu-item "Load Scheme File" gds-load-file))
1321   (define-key gds-eval-menu [defun]
1322     '(menu-item "Defun At Point" gds-eval-defun))
1323   (define-key gds-eval-menu [region]
1324     '(menu-item "Region" gds-eval-region))
1325   (define-key gds-eval-menu [last-sexp]
1326     '(menu-item "Sexp Before Point" gds-eval-last-sexp))
1327   (define-key gds-eval-menu [expr]
1328     '(menu-item "Expression..." gds-eval-expression)))
1329
1330 (defvar gds-help-menu nil
1331   "GDS help menu.")
1332 (if gds-help-menu
1333     nil
1334   (setq gds-help-menu (make-sparse-keymap "Help"))
1335   (define-key gds-help-menu [apropos]
1336     '(menu-item "Apropos..." gds-apropos))
1337   (define-key gds-help-menu [sym]
1338     '(menu-item "Symbol..." gds-help-symbol)))
1339
1340 (defvar gds-advanced-menu nil
1341   "Menu of rarely needed GDS operations.")
1342 (if gds-advanced-menu
1343     nil
1344   (setq gds-advanced-menu (make-sparse-keymap "Advanced"))
1345   (define-key gds-advanced-menu [run-captive]
1346     '(menu-item "Run Captive Guile" gds-start-captive
1347                 :enable (not (comint-check-proc gds-captive))))
1348   (define-key gds-advanced-menu [restart-gds]
1349     '(menu-item "Restart IDE" gds-start :enable gds-process))
1350   (define-key gds-advanced-menu [kill-gds]
1351     '(menu-item "Shutdown IDE" gds-shutdown :enable gds-process))
1352   (define-key gds-advanced-menu [start-gds]
1353     '(menu-item "Start IDE" gds-start :enable (not gds-process))))
1354
1355 (defvar gds-menu nil
1356   "Global menu for GDS commands.")
1357 (if gds-menu
1358     nil
1359   (setq gds-menu (make-sparse-keymap "Guile"))
1360   (define-key gds-menu [advanced]
1361     (cons "Advanced" gds-advanced-menu))
1362   (define-key gds-menu [separator-1]
1363     '("--"))
1364   (define-key gds-menu [view]
1365     `(menu-item "View" ,gds-view-menu :enable gds-views))
1366   (define-key gds-menu [debug]
1367     `(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client
1368                                                      (gds-client-blocked))))
1369   (define-key gds-menu [breakpoint]
1370     `(menu-item "Breakpoints" ,gds-breakpoint-menu :enable t))
1371   (define-key gds-menu [eval]
1372     `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-buffers
1373                                                       gds-autostart-captive)))
1374   (define-key gds-menu [help]
1375     `(menu-item "Help" ,gds-help-menu :enable (or gds-buffers
1376                                                   gds-autostart-captive)))
1377   (setq menu-bar-final-items
1378         (cons 'guile menu-bar-final-items))
1379   (define-key scheme-mode-map [menu-bar guile]
1380     (cons "Guile" gds-menu)))
1381
1382
1383 ;;;; Autostarting the GDS server.
1384
1385 (defcustom gds-autostart-server t
1386   "Whether to automatically start the GDS server when `gds.el' is loaded."
1387   :type 'boolean
1388   :group 'gds)
1389
1390 (if (and gds-autostart-server
1391          (not gds-process))
1392     (gds-start))
1393
1394
1395 ;;;; `Captive' Guile - a Guile process that is started when needed to
1396 ;;;; provide help, completion, evaluations etc.
1397
1398 (defcustom gds-autostart-captive t
1399   "Whether to automatically start a `captive' Guile process when needed."
1400   :type 'boolean
1401   :group 'gds)
1402
1403 (defvar gds-captive nil
1404   "Buffer of captive Guile.")
1405
1406 (defun gds-start-captive (&optional restart)
1407   (interactive)
1408   (if (and restart
1409            (comint-check-proc gds-captive))
1410       (gds-kill-captive))
1411   (if (comint-check-proc gds-captive)
1412       nil
1413     (let ((process-connection-type nil))
1414       (setq gds-captive (make-comint "captive-guile"
1415                                      "guile"
1416                                      nil
1417                                      "-q")))
1418     (let ((proc (get-buffer-process gds-captive)))
1419       (comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n")
1420       (comint-send-string proc "(debug-enable 'backtrace)\n")
1421       (comint-send-string proc "(use-modules (emacs gds-client))\n")
1422       (comint-send-string proc "(gds-connect \"Captive Guile\" #f)\n"))))
1423
1424 (defun gds-kill-captive ()
1425   (if gds-captive
1426       (let ((proc (get-buffer-process gds-captive)))
1427         (process-kill-without-query proc)
1428         (condition-case nil
1429             (progn
1430               (kill-process proc)
1431               (accept-process-output gds-process 0 200))
1432           (error)))))
1433
1434
1435 ;;;; The end!
1436
1437 (provide 'gds)
1438
1439 ;;; gds.el ends here.