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