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