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 ;;;; Debugging (of this code!).
  30
  31 (defsubst dmessage (msg &rest args)
  32   ;;(apply (function message) msg args)
  33   )
  34
  35
  36 ;;;; Customization group setup.
  37
  38 (defgroup gds nil
  39   "Customization options for Guile Emacs frontend."
  40   :group 'scheme)
  41
  42
  43 ;;;; Communication with the (ice-9 debugger ui-server) subprocess.
  44
  45 ;; The subprocess object.
  46 (defvar gds-process nil)
  47
  48 ;; Subprocess output goes into the `*GDS Process*' buffer, and
  49 ;; is then read from there one form at a time.  `gds-read-cursor' is
  50 ;; the buffer position of the start of the next unread form.
  51 (defvar gds-read-cursor nil)
  52
  53 (defun gds-start ()
  54   "Start (or restart, if already running) the GDS subprocess."
  55   (interactive)
  56   (if gds-process (gds-shutdown))
  57   (with-current-buffer (get-buffer-create "*GDS Process*")
  58     (erase-buffer)
  59     (setq gds-process
  60           (let ((process-connection-type nil)) ; use a pipe
  61             (start-process "gds"
  62                            (current-buffer)
  63                            "guile"
  64                            "-q"
  65                            "--debug"
  66                            "-e"
  67                            "run"
  68                            "-s"
  69                            "/home/neil/Guile/cvs/guile-core/ice-9/debugger/ui-server.scm"))))
  70   (setq gds-read-cursor (point-min))
  71   (set-process-filter gds-process (function gds-filter))
  72   (set-process-sentinel gds-process (function gds-sentinel))
  73   (set-process-coding-system gds-process 'latin-1-unix))
  74
  75 ;; Shutdown the subprocess and cleanup all associated data.
  76 (defun gds-shutdown ()
  77   "Shut down the GDS subprocess."
  78   (interactive)
  79   ;; Do cleanup for all clients.
  80   (while gds-names
  81     (gds-client-cleanup (caar gds-names)))
  82   ;; Reset any remaining variables.
  83   (setq gds-displayed-client nil
  84         gds-waiting nil)
  85   ;; If the timer is running, cancel it.
  86   (if gds-timer
  87       (cancel-timer gds-timer))
  88   (setq gds-timer nil)
  89   ;; Kill the subprocess.
  90   (process-kill-without-query gds-process)
  91   (condition-case nil
  92       (progn
  93         (kill-process gds-process)
  94         (accept-process-output gds-process 0 200))
  95     (error))
  96   (setq gds-process nil))
  97
  98 ;; Subprocess output filter: inserts normally into the process buffer,
  99 ;; then tries to reread the output one form at a time and delegates
 100 ;; processing of each form to `gds-handle-input'.
 101 (defun gds-filter (proc string)
 102   (with-current-buffer (process-buffer proc)
 103     (save-excursion
 104       (goto-char (process-mark proc))
 105       (insert-before-markers string))
 106     (goto-char gds-read-cursor)
 107     (while (let ((form (condition-case nil
 108                            (read (current-buffer))
 109                          (error nil))))
 110              (if form
 111                  (save-excursion
 112                    (gds-handle-input form)))
 113              form)
 114       (setq gds-read-cursor (point)))))
 115
 116 ;; Subprocess sentinel: do nothing.  (Currently just here to avoid
 117 ;; inserting un-`read'able process status messages into the process
 118 ;; buffer.)
 119 (defun gds-sentinel (proc event)
 120   )
 121
 122 ;; Send input to the subprocess.
 123 (defun gds-send (string)
 124   (process-send-string gds-process string))
 125
 126
 127 ;;;; Multiple application scheduling.
 128
 129 ;; At any moment one Guile application has the focus of the frontend
 130 ;; code.  `gds-displayed-client' holds the port number of that client.
 131 ;; If there are no Guile applications wanting the focus - that is,
 132 ;; ready for instructions - `gds-displayed-client' is nil.
 133 (defvar gds-displayed-client nil)
 134
 135 ;; The list of other Guile applications waiting for focus, referenced
 136 ;; by their port numbers.
 137 (defvar gds-waiting nil)
 138
 139 ;; An idle timer that we use to avoid confusing any user work when
 140 ;; popping up debug buffers.  `gds-timer' is non-nil whenever the
 141 ;; timer is running and nil whenever it is not running.
 142 (defvar gds-timer nil)
 143
 144 ;; Debug the specified client.  If it already has the focus, do so
 145 ;; immediately, but using the idle timer to ensure that it doesn't
 146 ;; confuse any work the user may be doing.  Non-structural work is
 147 ;; delegated to `gds-display-state'.
 148 (defun gds-debug (&optional client)
 149   (dmessage "gds-debug")
 150   ;; If `client' is specified, add it to the end of `gds-waiting',
 151   ;; unless that client is already the current client or it is already
 152   ;; in the waiting list.
 153   (if (and client
 154            (not (eq client gds-displayed-client))
 155            (not (memq client gds-waiting)))
 156       (setq gds-waiting (append gds-waiting (list client))))
 157   ;; Now update `client' to be the next client in the list.
 158   (setq client (or gds-displayed-client (car gds-waiting)))
 159   ;; If conditions are right, start the idle timer.
 160   (if (and client
 161            (or (null gds-displayed-client)
 162                (eq gds-displayed-client client)))
 163       (gds-display-state (or gds-displayed-client
 164                              (prog1 (car gds-waiting)
 165                                (setq gds-waiting
 166                                      (cdr gds-waiting)))))))
 167
 168 ;; Give up focus because debugging is done for now.  Display detail in
 169 ;; case of no waiting clients is delegated to `gds-clear-display'.
 170 (defun gds-focus-done ()
 171   (gds-clear-display)
 172   (gds-debug))
 173
 174 ;; Although debugging of this client isn't done, yield focus to the
 175 ;; next waiting client.
 176 (defun gds-focus-yield ()
 177   (interactive)
 178   (if (and (null gds-waiting)
 179            (y-or-n-p "No other clients waiting - bury *Guile* buffer? "))
 180       (bury-buffer)
 181     (or (memq gds-displayed-client gds-waiting)
 182         (setq gds-waiting (append gds-waiting (list gds-displayed-client))))
 183     (gds-focus-done)))
 184
 185
 186 ;;;; Per-client state information.
 187
 188 ;; Alist mapping client port numbers to application names.  The names
 189 ;; in this list have been uniquified by `gds-uniquify'.
 190 (defvar gds-names nil)
 191
 192 ;; Return unique form of NAME.
 193 (defun gds-uniquify (name)
 194   (let ((count 1)
 195         (maybe-unique name))
 196     (while (member maybe-unique (mapcar (function cdr) gds-names))
 197       (setq count (1+ count)
 198             maybe-unique (concat name "<" (number-to-string count) ">")))
 199     maybe-unique))
 200
 201 ;; Alist mapping client port numbers to last known status.
 202 ;;
 203 ;; Status is one of the following symbols.
 204 ;;
 205 ;;   `running' - application is running.
 206 ;;
 207 ;;   `waiting-for-input' - application is blocked waiting for
 208 ;;   instruction from the frontend.
 209 ;;
 210 ;;   `ready-for-input' - application is not blocked but can also
 211 ;;   accept asynchronous instructions from the frontend.
 212 ;;
 213 (defvar gds-statuses nil)
 214
 215 ;; Alist mapping client port numbers to last printed outputs.
 216 (defvar gds-outputs nil)
 217
 218 ;; Alist mapping client port numbers to last known stacks.
 219 (defvar gds-stacks nil)
 220
 221 ;; Alist mapping client port numbers to module information.  This
 222 ;; looks like:
 223 ;;
 224 ;; ((4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) ...)
 225 ;;
 226 ;; So, for example:
 227 ;;
 228 ;; (assq client gds-modules)
 229 ;; =>
 230 ;; (4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...)
 231 ;;
 232 ;; The t or nil after the module name indicates whether the module is
 233 ;; displayed in expanded form (that is, showing the bindings in that
 234 ;; module).
 235 ;;
 236 ;; The syms are actually all strings, because some Guile symbols are
 237 ;; not readable by Emacs.
 238 (defvar gds-modules nil)
 239
 240
 241 ;;;; Handling debugging instructions.
 242
 243 ;; General dispatch function called by the subprocess filter.
 244 (defun gds-handle-input (form)
 245   (dmessage "Form: %S" form)
 246   (let ((client (car form)))
 247     (cond ((eq client '*))
 248           (t
 249            (let ((proc (cadr form)))
 250
 251              (cond ((eq proc 'name)
 252                     ;; (name ...) - Application's name.
 253                     (setq gds-names
 254                           (cons (cons client (gds-uniquify (caddr form)))
 255                                 gds-names)))
 256
 257                    ((eq proc 'stack)
 258                     ;; (stack ...) - Stack at an error or breakpoint.
 259                     (gds-set gds-stacks client (cddr form)))
 260
 261                    ((eq proc 'modules)
 262                     ;; (modules ...) - Application's loaded modules.
 263                     (gds-set gds-modules client
 264                              (mapcar (function list) (cddr form))))
 265
 266                    ((eq proc 'output)
 267                     ;; (output ...) - Last printed output.
 268                     (gds-set gds-outputs client (caddr form)))
 269
 270                    ((eq proc 'status)
 271                     ;; (status ...) - Application status indication.
 272                     (let ((status (caddr form)))
 273                       (gds-set gds-statuses client status)
 274                       (cond ((eq status 'waiting-for-input)
 275                              (gds-debug client))
 276                             ((or (eq status 'running)
 277                                  (eq status 'ready-for-input))
 278                              (if (eq client gds-displayed-client)
 279                                  (gds-display-state client)))
 280                             (t
 281                              (error "Unexpected status: %S" status)))))
 282
 283                    ((eq proc 'module)
 284                     ;; (module MODULE ...) - The specified module's bindings.
 285                     (let* ((modules (assq client gds-modules))
 286                            (minfo (assoc (caddr form) modules)))
 287                       (if minfo
 288                           (setcdr (cdr minfo) (cdddr form)))))
 289
 290                    ((eq proc 'closed)
 291                     ;; (closed) - Client has gone away.
 292                     (gds-client-cleanup client))
 293
 294                    ((eq proc 'eval-results)
 295                     ;; (eval-results ...) - Results of evaluation.
 296                     (gds-display-results client (cddr form)))
 297
 298                    ))))))
 299
 300 (defun gds-display-results (client results)
 301   (let ((buf (get-buffer-create "*Guile Results*")))
 302     (save-excursion
 303       (set-buffer buf)
 304       (erase-buffer)
 305       (while results
 306         (insert (car results))
 307         (mapcar (function (lambda (value)
 308                             (insert " => " value "\n")))
 309                 (cadr results))
 310         (insert "\n")
 311         (setq results (cddr results))))
 312     (pop-to-buffer buf)))
 313
 314 ;; Store latest status, stack or module list for the specified client.
 315 (defmacro gds-set (alist client val)
 316   `(let ((existing (assq ,client ,alist)))
 317      (if existing
 318          (setcdr existing ,val)
 319        (setq ,alist
 320              (cons (cons client ,val) ,alist)))))
 321
 322 ;; Cleanup processing when CLIENT goes away.
 323 (defun gds-client-cleanup (client)
 324   (if (eq client gds-displayed-client)
 325       (gds-focus-done))
 326   (setq gds-names
 327         (delq (assq client gds-names) gds-names))
 328   (setq gds-stacks
 329         (delq (assq client gds-stacks) gds-stacks))
 330   (setq gds-modules
 331         (delq (assq client gds-modules) gds-modules)))
 332
 333
 334 ;;;; Displaying debugging information.
 335
 336 (defvar gds-client-buffer nil)
 337
 338 (define-derived-mode gds-mode
 339   fundamental-mode
 340   "Guile"
 341   "Major mode for Guile information buffers.")
 342
 343 (defun gds-set-client-buffer (&optional client)
 344   (if (and gds-client-buffer
 345            (buffer-live-p gds-client-buffer))
 346       (set-buffer gds-client-buffer)
 347     (setq gds-client-buffer (get-buffer-create "*Guile*"))
 348     (set-buffer gds-client-buffer)
 349     (gds-mode))
 350   ;; Rename to something we don't want first.  Otherwise, if the
 351   ;; buffer is already correctly named, we get a confusing change
 352   ;; from, say, `*Guile: REPL*' to `*Guile: REPL*<2>'.
 353   (rename-buffer "*Guile Fake Buffer Name*" t)
 354   (rename-buffer (if client
 355                      (concat "*Guile: "
 356                              (cdr (assq client gds-names))
 357                              "*")
 358                    "*Guile*")
 359                  t)                     ; Rename uniquely if needed,
 360                                         ; although it shouldn't be.
 361   (force-mode-line-update t))
 362
 363 (defun gds-clear-display ()
 364   ;; Clear the client buffer.
 365   (gds-set-client-buffer)
 366   (let ((inhibit-read-only t))
 367     (erase-buffer)
 368     (insert "Stack:\nNo clients ready for debugging.\n")
 369     (goto-char (point-min)))
 370   (setq gds-displayed-stack 'no-clients)
 371   (setq gds-displayed-modules nil)
 372   (setq gds-displayed-client nil)
 373   (bury-buffer))
 374
 375 ;; Determine whether the client display buffer is visible in the
 376 ;; currently selected frame (i.e. where the user is editing).
 377 (defun gds-buffer-visible-in-selected-frame-p ()
 378   (let ((visible-p nil))
 379     (walk-windows (lambda (w)
 380                     (if (eq (window-buffer w) gds-client-buffer)
 381                         (setq visible-p t))))
 382     visible-p))
 383
 384 ;; Cached display variables for `gds-display-state'.
 385 (defvar gds-displayed-stack nil)
 386 (defvar gds-displayed-modules nil)
 387
 388 ;; Types of display areas in the *Guile* buffer.
 389 (defvar gds-display-types '("Status" "Stack" "Modules"))
 390 (defvar gds-display-type-regexp
 391   (concat "^\\("
 392           (substring (apply (function concat)
 393                             (mapcar (lambda (type)
 394                                       (concat "\\|" type))
 395                                     gds-display-types))
 396                      2)
 397           "\\):"))
 398
 399 (defun gds-maybe-delete-region (type)
 400   (let ((beg (save-excursion
 401                (goto-char (point-min))
 402                (and (re-search-forward (concat "^"
 403                                                (regexp-quote type)
 404                                                ":")
 405                                        nil t)
 406                     (match-beginning 0)))))
 407     (if beg
 408         (delete-region beg
 409                        (save-excursion
 410                          (goto-char beg)
 411                          (end-of-line)
 412                          (or (and (re-search-forward gds-display-type-regexp
 413                                                      nil t)
 414                                   (match-beginning 0))
 415                              (point-max)))))))
 416
 417 (defun gds-maybe-skip-region (type)
 418   (if (looking-at (regexp-quote type))
 419       (if (re-search-forward gds-display-type-regexp nil t 2)
 420           (beginning-of-line)
 421         (goto-char (point-max)))))
 422
 423 (defun gds-display-state (client)
 424   (dmessage "gds-display-state")
 425   ;; Avoid continually popping up the last associated source buffer
 426   ;; unless it really is still current.
 427   (setq gds-selected-frame-source-buffer nil)
 428   (gds-set-client-buffer client)
 429   (let ((stack (cdr (assq client gds-stacks)))
 430         (modules (cdr (assq client gds-modules)))
 431         (inhibit-read-only t)
 432         (p (if (eq client gds-displayed-client)
 433                (point)
 434              (point-min)))
 435         stack-changed)
 436     ;; Start at top of buffer.
 437     (goto-char (point-min))
 438     ;; Display status; too simple to be worth caching.
 439     (gds-maybe-delete-region "Status")
 440     (widget-insert "Status: "
 441                    (cdr (assq (cdr (assq client gds-statuses))
 442                               '((running . "running (cannot accept input)")
 443                                 (waiting-for-input . "waiting for input")
 444                                 (ready-for-input . "running"))))
 445                    "\n\n")
 446     (let ((output (cdr (assq client gds-outputs))))
 447       (if (> (length output) 0)
 448           (widget-insert output "\n\n")))
 449     ;; Display stack.
 450     (dmessage "insert stack")
 451     (if (equal stack gds-displayed-stack)
 452         (gds-maybe-skip-region "Stack")
 453       ;; Note that stack has changed.
 454       (if stack (setq stack-changed t))
 455       ;; Delete existing stack.
 456       (gds-maybe-delete-region "Stack")
 457       ;; Insert new stack.
 458       (if stack (gds-insert-stack stack))
 459       ;; Record displayed stack.
 460       (setq gds-displayed-stack stack))
 461     ;; Display module list.
 462     (dmessage "insert modules")
 463     (if (equal modules gds-displayed-modules)
 464         (gds-maybe-skip-region "Modules")
 465       ;; Delete existing module list.
 466       (gds-maybe-delete-region "Modules")
 467       ;; Insert new list.
 468       (if modules (gds-insert-modules modules))
 469       ;; Record displayed list.
 470       (setq gds-displayed-modules (copy-tree modules)))
 471     ;; Finish off.
 472     (dmessage "widget-setup")
 473     (widget-setup)
 474     (if stack-changed
 475         ;; Stack is being seen for the first time, so make sure top of
 476         ;; buffer is visible.
 477         (progn
 478           (goto-char (point-min))
 479           (re-search-forward "^Stack:")
 480           (forward-line (+ 1 (cadr stack))))
 481       ;; Restore point from before buffer was redrawn.
 482       (goto-char p)))
 483   (setq gds-displayed-client client)
 484   (dmessage "consider display")
 485   (if (eq (window-buffer (selected-window)) gds-client-buffer)
 486       ;; *Guile* buffer already selected.
 487       (gds-display-buffers)
 488     (dmessage "Running GDS timer")
 489     (setq gds-timer
 490           (run-with-idle-timer 0.5
 491                                nil
 492                                (lambda ()
 493                                  (setq gds-timer nil)
 494                                  (gds-display-buffers))))))
 495
 496 (defun gds-display-buffers ()
 497   ;; If there's already a window showing the *Guile* buffer, use
 498   ;; it.
 499   (let ((window (get-buffer-window gds-client-buffer t)))
 500     (if window
 501         (progn
 502           (make-frame-visible (window-frame window))
 503           (raise-frame (window-frame window))
 504           (select-frame (window-frame window))
 505           (select-window window))
 506       (switch-to-buffer gds-client-buffer)))
 507   ;; If there is an associated source buffer, display it as well.
 508   (if gds-selected-frame-source-buffer
 509       (let ((window (display-buffer gds-selected-frame-source-buffer)))
 510         (set-window-point window
 511                           (overlay-start gds-selected-frame-source-overlay))))
 512   ;; Force redisplay.
 513   (sit-for 0))
 514
 515 (defun old-stuff ()
 516   (if (gds-buffer-visible-in-selected-frame-p)
 517       ;; Buffer already visible enough.
 518       nil
 519     ;; Delete any views of the buffer in other frames - we don't want
 520     ;; views all over the place.
 521     (delete-windows-on gds-client-buffer)
 522     ;; Run idle timer to display the buffer as soon as user isn't in
 523     ;; the middle of something else.
 524     ))
 525
 526 (defun gds-insert-stack (stack)
 527   (let ((frames (car stack))
 528         (index (cadr stack))
 529         (flags (caddr stack))
 530         frame items)
 531     (widget-insert "Stack: " (prin1-to-string flags) "\n")
 532     (let ((i -1))
 533       (gds-show-selected-frame (caddr (nth index frames)))
 534       (while frames
 535         (setq frame (car frames)
 536               frames (cdr frames)
 537               i (+ i 1)
 538               items (cons (list 'item
 539                                 (let ((s (cadr frame)))
 540                                   (put-text-property 0 1 'index i s)
 541                                   s))
 542                           items))))
 543     (setq items (nreverse items))
 544     (apply (function widget-create)
 545              'radio-button-choice
 546              :value (cadr (nth index items))
 547              :notify (function gds-select-stack-frame)
 548              items)
 549     (widget-insert "\n")))
 550
 551 (defun gds-select-stack-frame (widget &rest ignored)
 552   (let* ((s (widget-value widget))
 553          (ind (memq 'index (text-properties-at 0 s))))
 554     (gds-send (format "(%S debugger-command frame %d)\n"
 555                       gds-displayed-client
 556                       (cadr ind)))))
 557
 558 ;; Overlay used to highlight the source expression corresponding to
 559 ;; the selected frame.
 560 (defvar gds-selected-frame-source-overlay nil)
 561
 562 ;; Buffer containing source for the selected frame.
 563 (defvar gds-selected-frame-source-buffer nil)
 564
 565 (defun gds-show-selected-frame (source)
 566   ;; Highlight the frame source, if possible.
 567   (if (and source
 568            (file-readable-p (car source)))
 569       (with-current-buffer (find-file-noselect (car source))
 570         (if gds-selected-frame-source-overlay
 571             nil
 572           (setq gds-selected-frame-source-overlay (make-overlay 0 0))
 573           (overlay-put gds-selected-frame-source-overlay 'face 'highlight))
 574         ;; Move to source line.  Note that Guile line numbering is
 575         ;; 0-based, while Emacs numbering is 1-based.
 576         (save-restriction
 577           (widen)
 578           (goto-line (+ (cadr source) 1))
 579           (move-to-column (caddr source))
 580           (move-overlay gds-selected-frame-source-overlay
 581                         (point)
 582                         (if (not (looking-at ")"))
 583                             (save-excursion (forward-sexp 1) (point))
 584                           ;; It seems that the source coordinates for
 585                           ;; backquoted expressions are at the end of
 586                           ;; the sexp rather than the beginning...
 587                           (save-excursion (forward-char 1)
 588                                           (backward-sexp 1) (point)))
 589                         (current-buffer)))
 590         (setq gds-selected-frame-source-buffer (current-buffer)))
 591     (if gds-selected-frame-source-overlay
 592         (move-overlay gds-selected-frame-source-overlay 0 0))))
 593
 594 (defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil))
 595   "Specification of which Guile modules the debugger should display.
 596 This is a list with structure (DEFAULT EXCEPTION EXCEPTION...), where
 597 DEFAULT is `t' or `nil' and each EXCEPTION has the structure (SYMBOL
 598 DEFAULT EXCEPTION EXCEPTION...).
 599
 600 A Guile module name `(x y z)' is matched against this filter as
 601 follows.  If one of the top level EXCEPTIONs has SYMBOL `x', continue
 602 by matching the rest of the module name, in this case `(y z)', against
 603 that SYMBOL's DEFAULT and next level EXCEPTION list.  Otherwise, if
 604 the current DEFAULT is `t' display the module, and if the current
 605 DEFAULT is `nil', don't display it.
 606
 607 This variable is usually set to exclude Guile system modules that are
 608 not of primary interest when debugging application code."
 609   :type 'sexp
 610   :group 'gds)
 611
 612 (defun gds-show-module-p (name)
 613   ;; Determine whether to display the NAMEd module by matching NAME
 614   ;; against `gds-module-filter'.
 615   (let ((default (car gds-module-filter))
 616         (exceptions (cdr gds-module-filter)))
 617     (let ((exception (assq (car name) exceptions)))
 618       (if exception
 619           (let ((gds-module-filter (cdr exception)))
 620             (gds-show-module-p (cdr name)))
 621         default))))
 622
 623 (defun gds-insert-modules (modules)
 624   (insert "Modules:\n")
 625   (while modules
 626     (let ((minfo (car modules)))
 627       (if (gds-show-module-p (car minfo))
 628           (let ((w (widget-create 'push-button
 629                                   :notify (function gds-module-notify)
 630                                   (if (and (cdr minfo)
 631                                            (cadr minfo))
 632                                       "-" "+"))))
 633             (widget-put w :module (cons client (car minfo)))
 634             (widget-insert " " (prin1-to-string (car minfo)) "\n")
 635             (if (cadr minfo)
 636                 (let ((syms (cddr minfo)))
 637                   (while syms
 638                     (widget-insert " > " (car syms) "\n")
 639                     (setq syms (cdr syms))))))))
 640     (setq modules (cdr modules))))
 641
 642 (defun gds-module-notify (w &rest ignore)
 643   (let* ((module (widget-get w :module))
 644          (client (car module))
 645          (name (cdr module))
 646          (modules (assq client gds-modules))
 647          (minfo (assoc name modules)))
 648     (if (cdr minfo)
 649         ;; Just toggle expansion state.
 650         (progn
 651           (setcar (cdr minfo) (not (cadr minfo)))
 652           (gds-display-state client))
 653       ;; Set flag to indicate module expanded.
 654       (setcdr minfo (list t))
 655       ;; Get symlist from Guile.
 656       (gds-send (format "(%S query-module %S)\n" client name)))))
 657
 658
 659 ;;;; Guile Debugging keymap.
 660
 661 (set-keymap-parent gds-mode-map widget-keymap)
 662 (define-key gds-mode-map "g" (function gds-go))
 663 (define-key gds-mode-map "b" (function gds-set-breakpoint))
 664 (define-key gds-mode-map "q" (function gds-quit))
 665 (define-key gds-mode-map "y" (function gds-yield))
 666 (define-key gds-mode-map " " (function gds-next))
 667 (define-key gds-mode-map "e" (function gds-evaluate))
 668 (define-key gds-mode-map "i" (function gds-step-in))
 669 (define-key gds-mode-map "o" (function gds-step-out))
 670 (define-key gds-mode-map "t" (function gds-trace-finish))
 671
 672 (defun gds-client-waiting ()
 673   (eq (cdr (assq gds-displayed-client gds-statuses)) 'waiting-for-input))
 674
 675 (defun gds-go ()
 676   (interactive)
 677   (gds-send (format "(%S debugger-command continue)\n" gds-displayed-client)))
 678
 679 (defun gds-quit ()
 680   (interactive)
 681   (if (gds-client-waiting)
 682       (if (y-or-n-p "Client is waiting for instruction - tell it to continue? ")
 683           (gds-go)))
 684   (gds-yield))
 685
 686 (defun gds-yield ()
 687   (interactive)
 688   (if (gds-client-waiting)
 689       (gds-focus-yield)
 690     (gds-focus-done)))
 691
 692 (defun gds-next ()
 693   (interactive)
 694   (gds-send (format "(%S debugger-command next 1)\n" gds-displayed-client)))
 695
 696 (defun gds-evaluate (expr)
 697   (interactive "sEvaluate (in this stack frame): ")
 698   (gds-send (format "(%S debugger-command evaluate %s)\n"
 699                     gds-displayed-client
 700                     (prin1-to-string expr))))
 701
 702 (defun gds-step-in ()
 703   (interactive)
 704   (gds-send (format "(%S debugger-command step 1)\n" gds-displayed-client)))
 705
 706 (defun gds-step-out ()
 707   (interactive)
 708   (gds-send (format "(%S debugger-command finish)\n" gds-displayed-client)))
 709
 710 (defun gds-trace-finish ()
 711   (interactive)
 712   (gds-send (format "(%S debugger-command trace-finish)\n"
 713                     gds-displayed-client)))
 714
 715 (defun gds-set-breakpoint ()
 716   (interactive)
 717   (cond ((gds-in-source-buffer)
 718          (gds-set-source-breakpoint))
 719         ((gds-in-stack)
 720          (gds-set-stack-breakpoint))
 721         ((gds-in-modules)
 722          (gds-set-module-breakpoint))
 723         (t
 724          (error "No way to set a breakpoint from here"))))
 725
 726 (defun gds-in-source-buffer ()
 727   ;; Not yet worked out what will be available in Scheme source
 728   ;; buffers.
 729   nil)
 730
 731 (defun gds-in-stack ()
 732   (and (eq (current-buffer) gds-client-buffer)
 733        (save-excursion
 734          (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
 735               (looking-at "Stack")))))
 736
 737 (defun gds-in-modules ()
 738   (and (eq (current-buffer) gds-client-buffer)
 739        (save-excursion
 740          (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
 741               (looking-at "Modules")))))
 742
 743 (defun gds-set-module-breakpoint ()
 744   (let ((sym (save-excursion
 745                (beginning-of-line)
 746                (and (looking-at " > \\([^ \n\t]+\\)")
 747                     (match-string 1))))
 748         (module (save-excursion
 749                   (and (re-search-backward "^\\[[+---]\\] \\(([^)]+)\\)" nil t)
 750                        (match-string 1)))))
 751     (or sym
 752         (error "Couldn't find procedure name on current line"))
 753     (or module
 754         (error "Couldn't find module name for current line"))
 755     (let ((behaviour
 756            (completing-read
 757             (format "Behaviour for breakpoint at %s:%s (default debug-here): "
 758                     module sym)
 759             '(("debug-here")
 760               ("trace-here")
 761               ("trace-subtree"))
 762             nil
 763             t
 764             nil
 765             nil
 766             "debug-here")))
 767       (gds-send (format "(%S set-breakpoint %s %s %s)\n"
 768                         gds-displayed-client
 769                         module
 770                         sym
 771                         behaviour)))))
 772
 773
 774 ;;;; Evaluating code.
 775
 776 ;; The following commands send code for evaluation through the GDS TCP
 777 ;; connection, receive the result and any output generated through the
 778 ;; same connection, and display the result and output to the user.
 779 ;;
 780 ;; Where there are multiple Guile applications known to GDS, GDS by
 781 ;; default sends code to the one that holds the debugging focus,
 782 ;; i.e. `gds-displayed-client'.  Where no application has the focus,
 783 ;; or the command is invoked `C-u', GDS asks the user which
 784 ;; application is intended.
 785
 786 (defun gds-read-client ()
 787   (let* ((def (if gds-displayed-client
 788                   (cdr (assq gds-displayed-client gds-names))))
 789          (prompt (if def
 790                      (concat "Application for eval (default "
 791                              def
 792                              "): ")
 793                    "Application for eval: "))
 794          (name
 795           (completing-read prompt
 796                            (mapcar (function cdr) gds-names)
 797                            nil t nil nil
 798                            def)))
 799     (let (client (names gds-names))
 800       (while (and names (not client))
 801         (if (string-equal (cadar names) name)
 802             (setq client (caar names)))
 803         (setq names (cdr names))))))
 804
 805 (defun gds-choose-client (client)
 806   (or ;; If client is an integer, it is the port number of the
 807       ;; intended client.
 808       (if (integerp client) client)
 809       ;; Any other non-nil value indicates invocation with a prefix
 810       ;; arg, which forces asking the user which application is
 811       ;; intended.
 812       (if client (gds-read-client))
 813       ;; If ask not forced, and there is a client with the focus,
 814       ;; default to that one.
 815       gds-displayed-client
 816       ;; Last resort - ask the user.
 817       (gds-read-client)
 818       ;; Signal an error.
 819       (error "No application chosen.")))
 820
 821 (defcustom gds-default-module-name '(guile-user)
 822   "Name of the default module for GDS code evaluation, as list of symbols.
 823 This module is used when there is no `define-module' form in the
 824 buffer preceding the code to be evaluated."
 825   :type 'sexp
 826   :group 'gds)
 827
 828 (defun gds-module-name (start end)
 829   "Determine and return the name of the module that governs the
 830 specified region.  The module name is returned as a list of symbols."
 831   (interactive "r")                     ; why not?
 832   (save-excursion
 833     (goto-char start)
 834     (let (module-name)
 835       (while (and (not module-name)
 836                   (beginning-of-defun-raw 1))
 837         (if (looking-at "(define-module ")
 838             (setq module-name
 839                   (progn
 840                     (goto-char (match-end 0))
 841                     (read (current-buffer))))))
 842       module-name)))
 843
 844 (defun gds-port-name (start end)
 845   "Return port name for the specified region of the current buffer.
 846 The name will be used by Guile as the port name when evaluating that
 847 region's code."
 848   (or (buffer-file-name)
 849       (concat "Emacs buffer: " (buffer-name))))
 850
 851 (defun gds-eval-region (start end &optional client)
 852   "Evaluate the current region."
 853   (interactive "r\nP")
 854   (setq client (gds-choose-client client))
 855   (let ((module (gds-module-name start end))
 856         (port-name (gds-port-name start end))
 857         line column)
 858     (save-excursion
 859       (goto-char start)
 860       (setq column (current-column))    ; 0-based
 861       (beginning-of-line)
 862       (setq line (count-lines (point-min) (point)))) ; 0-based
 863     (gds-send (format "(%S eval %s %S %d %d %S)\n"
 864                       client
 865                       (if module (prin1-to-string module) "#f")
 866                       port-name line column
 867                       (buffer-substring-no-properties start end)))))
 868
 869 (defun gds-eval-expression (expr &optional client)
 870   "Evaluate the supplied EXPR (a string)."
 871   (interactive "sEvaluate expression: \nP")
 872   (setq client (gds-choose-client client))
 873   (gds-send (format "(%S eval #f \"Emacs expression\" 0 0 %S)\n"
 874                     client expr)))
 875
 876 (defun gds-eval-defun (&optional client)
 877   "Evaluate the defun (top-level form) at point."
 878   (interactive "P")
 879   (save-excursion
 880    (end-of-defun)
 881    (let ((end (point)))
 882      (beginning-of-defun)
 883      (gds-eval-region (point) end client))))
 884
 885 (defun gds-eval-last-sexp (&optional client)
 886   "Evaluate the sexp before point."
 887   (interactive "P")
 888   (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client))
 889
 890 (defcustom gds-source-modes '(scheme-mode)
 891   "*Used to determine if a buffer contains Scheme source code.
 892 If it's loaded into a buffer that is in one of these major modes, it's
 893 considered a scheme source file by `gds-load-file'."
 894   :type '(repeat function)
 895   :group 'gds)
 896
 897 (defvar gds-prev-load-dir/file nil
 898   "Holds the last (directory . file) pair passed to `gds-load-file'.
 899 Used for determining the default for the next `gds-load-file'.")
 900
 901 (defun gds-load-file (file-name &optional client)
 902   "Load a Scheme file into the inferior Scheme process."
 903   (interactive (list (car (comint-get-source "Load Scheme file: "
 904                                              gds-prev-load-dir/file
 905                                              gds-source-modes t))
 906                                         ; T because LOAD needs an
 907                                         ; exact name
 908                      current-prefix-arg))
 909   (comint-check-source file-name) ; Check to see if buffer needs saved.
 910   (setq gds-prev-load-dir/file (cons (file-name-directory    file-name)
 911                                      (file-name-nondirectory file-name)))
 912   (setq client (gds-choose-client client))
 913   (gds-send (format "(%S load %S)\n" client file-name)))
 914
 915 ;; Install the process communication commands in the scheme-mode keymap.
 916 (define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention
 917 (define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention
 918 (define-key scheme-mode-map "\C-c\C-e" 'gds-eval-defun)
 919 (define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
 920 (define-key scheme-mode-map "\C-c\C-l" 'gds-load-file)
 921
 922
 923 ;;;; Menu bar entries.
 924
 925 (defvar gds-debug-menu nil
 926   "GDS debugging menu.")
 927 (if gds-debug-menu
 928     nil
 929   (setq gds-debug-menu (make-sparse-keymap "Debug"))
 930   (define-key gds-debug-menu [go]
 931     '(menu-item "Go" gds-go))
 932   (define-key gds-debug-menu [trace-finish]
 933     '(menu-item "Trace This Frame" gds-trace-finish))
 934   (define-key gds-debug-menu [step-out]
 935     '(menu-item "Finish This Frame" gds-step-out))
 936   (define-key gds-debug-menu [next]
 937     '(menu-item "Next" gds-next))
 938   (define-key gds-debug-menu [step-in]
 939     '(menu-item "Single Step" gds-step-in))
 940   (define-key gds-debug-menu [eval]
 941     '(menu-item "Eval In This Frame..." gds-evaluate)))
 942
 943 (defvar gds-eval-menu nil
 944   "GDS evaluation menu.")
 945 (if gds-eval-menu
 946     nil
 947   (setq gds-eval-menu (make-sparse-keymap "Evaluate"))
 948   (define-key gds-eval-menu [load-file]
 949     '(menu-item "Load Scheme File" gds-load-file))
 950   (define-key gds-eval-menu [defun]
 951     '(menu-item "Defun At Point" gds-eval-defun))
 952   (define-key gds-eval-menu [region]
 953     '(menu-item "Region" gds-eval-region))
 954   (define-key gds-eval-menu [last-sexp]
 955     '(menu-item "Sexp Before Point" gds-eval-last-sexp))
 956   (define-key gds-eval-menu [expr]
 957     '(menu-item "Expression..." gds-eval-expression)))
 958
 959 (defvar gds-help-menu nil
 960   "GDS help menu.")
 961 (if gds-help-menu
 962     nil
 963   (setq gds-help-menu (make-sparse-keymap "Help"))
 964   (define-key gds-help-menu [apropos]
 965     '(menu-item "Apropos..." gds-apropos))
 966   (define-key gds-help-menu [sym-here]
 967     '(menu-item "Symbol At Point" gds-help-symbol-here))
 968   (define-key gds-help-menu [sym]
 969     '(menu-item "Symbol..." gds-help-symbol)))
 970
 971 (defvar gds-advanced-menu nil
 972   "Menu of rarely needed GDS operations.")
 973 (if gds-advanced-menu
 974     nil
 975   (setq gds-advanced-menu (make-sparse-keymap "Advanced"))
 976   (define-key gds-advanced-menu [restart-gds]
 977     '(menu-item "Restart IDE" gds-start :enable gds-process))
 978   (define-key gds-advanced-menu [kill-gds]
 979     '(menu-item "Shutdown IDE" gds-shutdown :enable gds-process))
 980   (define-key gds-advanced-menu [start-gds]
 981     '(menu-item "Start IDE" gds-start :enable (not gds-process))))
 982
 983 (defvar gds-menu nil
 984   "Global menu for GDS commands.")
 985 (if gds-menu
 986     nil
 987   (setq gds-menu (make-sparse-keymap "Guile"))
 988   (define-key gds-menu [advanced]
 989     (cons "Advanced" gds-advanced-menu))
 990   (define-key gds-menu [separator-1]
 991     '("--"))
 992   (define-key gds-menu [help]
 993     `(menu-item "Help" ,gds-help-menu :enable gds-names))
 994   (define-key gds-menu [eval]
 995     `(menu-item "Evaluate" ,gds-eval-menu :enable gds-names))
 996   (define-key gds-menu [debug]
 997     `(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client
 998                                                      (gds-client-waiting))))
 999   (setq menu-bar-final-items
1000         (cons 'guile menu-bar-final-items))
1001   (define-key global-map [menu-bar guile]
1002     (cons "Guile" gds-menu)))
1003
1004 ;;;; Autostarting the GDS server.
1005
1006 (defcustom gds-autostart-server t
1007   "Whether to automatically start the GDS server when `gds.el' is loaded."
1008   :type 'boolean
1009   :group 'gds)
1010
1011 (if (and gds-autostart-server
1012          (not gds-process))
1013     (gds-start))
1014
1015 (provide 'gds)
1016
1017 ;;; gds.el ends here.