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