emacs/gds-scheme.el

   1 ;;; gds-scheme.el -- GDS function for Scheme mode buffers
   2
   3 ;;;; Copyright (C) 2005 Neil Jerram
   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 (require 'comint)
  22 (require 'scheme)
  23 (require 'derived)
  24 (require 'pp)
  25
  26 ;;;; Maintaining an association between a Guile client process and a
  27 ;;;; set of Scheme mode buffers.
  28
  29 (defcustom gds-auto-create-utility-client t
  30   "Whether to automatically create a utility Guile client, and
  31 associate the current buffer with it, if there are no existing Guile
  32 clients available to GDS when the user does something that requires a
  33 running Guile client."
  34   :type 'boolean
  35   :group 'gds)
  36
  37 (defcustom gds-auto-associate-single-client t
  38   "Whether to automatically associate the current buffer with an
  39 existing Guile client, if there is only only client known to GDS when
  40 the user does something that requires a running Guile client, and the
  41 current buffer is not already associated with a Guile client."
  42   :type 'boolean
  43   :group 'gds)
  44
  45 (defcustom gds-auto-associate-last-client t
  46   "Whether to automatically associate the current buffer with the
  47 Guile client that most recently caused that buffer to be displayed,
  48 when the user does something that requires a running Guile client and
  49 the current buffer is not already associated with a Guile client."
  50   :type 'boolean
  51   :group 'gds)
  52
  53 (defvar gds-last-touched-by nil
  54   "For each Scheme mode buffer, this records the GDS client that most
  55 recently `touched' that buffer in the sense of using it to display
  56 source code, for example for the source code relevant to a debugger
  57 stack frame.")
  58 (make-variable-buffer-local 'gds-last-touched-by)
  59
  60 (defun gds-auto-associate-buffer ()
  61   "Automatically associate the current buffer with a Guile client, if
  62 possible."
  63   (let* ((num-clients (length gds-client-info))
  64          (client
  65           (or
  66            ;; If there are no clients yet, and
  67            ;; `gds-auto-create-utility-client' allows us to create one
  68            ;; automatically, do that.
  69            (and (= num-clients 0)
  70                 gds-auto-create-utility-client
  71                 (gds-start-utility-guile))
  72            ;; Otherwise, if there is a single existing client, and
  73            ;; `gds-auto-associate-single-client' allows us to use it
  74            ;; for automatic association, do that.
  75            (and (= num-clients 1)
  76                 gds-auto-associate-single-client
  77                 (caar gds-client-info))
  78            ;; Otherwise, if the current buffer was displayed because
  79            ;; of a Guile client trapping somewhere in its code, and
  80            ;; `gds-auto-associate-last-client' allows us to associate
  81            ;; with that client, do so.
  82            (and gds-auto-associate-last-client
  83                 gds-last-touched-by))))
  84     (if client
  85         (gds-associate-buffer client))))
  86
  87 (defun gds-associate-buffer (client)
  88   "Associate the current buffer with the Guile process CLIENT.
  89 This means that operations in this buffer that require a running Guile
  90 process - such as evaluation, help, completion and setting traps -
  91 will be sent to the Guile process whose name or connection number is
  92 CLIENT."
  93   (interactive (list (gds-choose-client)))
  94   ;; If this buffer is already associated, dissociate from its
  95   ;; existing client first.
  96   (if gds-client (gds-dissociate-buffer))
  97   ;; Store the client number in the buffer-local variable gds-client.
  98   (setq gds-client client)
  99   ;; Add this buffer to the list of buffers associated with the
 100   ;; client.
 101   (gds-client-put client 'associated-buffers
 102                   (cons (current-buffer)
 103                         (gds-client-get client 'associated-buffers))))
 104
 105 (defun gds-dissociate-buffer ()
 106   "Dissociate the current buffer from any specific Guile process."
 107   (interactive)
 108   (if gds-client
 109       (progn
 110         ;; Remove this buffer from the list of buffers associated with
 111         ;; the current client.
 112         (gds-client-put gds-client 'associated-buffers
 113                         (delq (current-buffer)
 114                               (gds-client-get gds-client 'associated-buffers)))
 115         ;; Reset the buffer-local variable gds-client.
 116         (setq gds-client nil)
 117         ;; Clear any process status indication from the modeline.
 118         (setq mode-line-process nil)
 119         (force-mode-line-update))))
 120
 121 (defun gds-show-client-status (client status-string)
 122   "Show a client's status in the modeline of all its associated
 123 buffers."
 124   (let ((buffers (gds-client-get client 'associated-buffers)))
 125     (while buffers
 126       (if (buffer-live-p (car buffers))
 127           (with-current-buffer (car buffers)
 128             (setq mode-line-process status-string)
 129             (force-mode-line-update)))
 130       (setq buffers (cdr buffers)))))
 131
 132 (defcustom gds-running-text ":running"
 133   "*Mode line text used to show that a Guile process is \"running\".
 134 \"Running\" means that the process cannot currently accept any input
 135 from the GDS frontend in Emacs, because all of its threads are busy
 136 running code that GDS cannot easily interrupt."
 137   :type 'string
 138   :group 'gds)
 139
 140 (defcustom gds-ready-text ":ready"
 141   "*Mode line text used to show that a Guile process is \"ready\".
 142 \"Ready\" means that the process is ready to interact with the GDS
 143 frontend in Emacs, because at least one of its threads is waiting for
 144 GDS input."
 145   :type 'string
 146   :group 'gds)
 147
 148 (defcustom gds-debug-text ":debug"
 149   "*Mode line text used to show that a Guile process is \"debugging\".
 150 \"Debugging\" means that the process is using the GDS frontend in
 151 Emacs to display an error or trap so that the user can debug it."
 152   :type 'string
 153   :group 'gds)
 154
 155 (defun gds-choose-client ()
 156   "Ask the user to choose a GDS client process from a list."
 157   (let ((table '())
 158         (default nil))
 159     ;; Prepare a table containing all current clients.
 160     (mapcar (lambda (client-info)
 161                (setq table (cons (cons (cadr (memq 'name client-info))
 162                                        (car client-info))
 163                                  table)))
 164              gds-client-info)
 165     ;; Add an entry to allow the user to ask for a new process.
 166     (setq table (cons (cons "Start a new Guile process" nil) table))
 167     ;; Work out a good default.  If the buffer has a good value in
 168     ;; gds-last-touched-by, we use that; otherwise default to starting
 169     ;; a new process.
 170     (setq default (or (and gds-last-touched-by
 171                            (gds-client-get gds-last-touched-by 'name))
 172                       (caar table)))
 173     ;; Read using this table.
 174     (let* ((name (completing-read "Choose a Guile process: "
 175                                   table
 176                                   nil
 177                                   t     ; REQUIRE-MATCH
 178                                   nil   ; INITIAL-INPUT
 179                                   nil   ; HIST
 180                                   default))
 181            ;; Convert name to a client number.
 182            (client (cdr (assoc name table))))
 183       ;; If the user asked to start a new Guile process, do that now.
 184       (or client (setq client (gds-start-utility-guile)))
 185       ;; Return the chosen client ID.
 186       client)))
 187
 188 (defvar gds-last-utility-number 0
 189   "Number of the last started Guile utility process.")
 190
 191 (defun gds-start-utility-guile ()
 192   "Start a new utility Guile process."
 193   (setq gds-last-utility-number (+ gds-last-utility-number 1))
 194   (let* ((procname (format "gds-util[%d]" gds-last-utility-number))
 195          (code (format "(begin
 196                           %s
 197                           (use-modules (ice-9 gds-client))
 198                           (run-utility))"
 199                        (if gds-scheme-directory
 200                            (concat "(set! %load-path (cons "
 201                                    (format "%S" gds-scheme-directory)
 202                                    " %load-path))")
 203                          "")))
 204          (proc (start-process procname
 205                               (get-buffer-create procname)
 206                               gds-guile-program
 207                               "-q"
 208                               "--debug"
 209                               "-c"
 210                               code))
 211          (client nil))
 212     ;; Note that this process can be killed automatically on Emacs
 213     ;; exit.
 214     (process-kill-without-query proc)
 215     ;; Set up a process filter to catch the new client's number.
 216     (set-process-filter proc
 217                         (lambda (proc string)
 218                           (setq client (string-to-number string))
 219                           (if (process-buffer proc)
 220                               (with-current-buffer (process-buffer proc)
 221                                 (insert string)))))
 222     ;; Accept output from the new process until we have its number.
 223     (while (not client)
 224       (accept-process-output proc))
 225     ;; Return the new process's client number.
 226     client))
 227
 228 ;;;; Evaluating code.
 229
 230 ;; The following commands send code for evaluation through the GDS TCP
 231 ;; connection, receive the result and any output generated through the
 232 ;; same connection, and display the result and output to the user.
 233 ;;
 234 ;; For each buffer where evaluations can be requested, GDS uses the
 235 ;; buffer-local variable `gds-client' to track which GDS client
 236 ;; program should receive and handle that buffer's evaluations.
 237
 238 (defun gds-module-name (start end)
 239   "Determine and return the name of the module that governs the
 240 specified region.  The module name is returned as a list of symbols."
 241   (interactive "r")                     ; why not?
 242   (save-excursion
 243     (goto-char start)
 244     (let (module-name)
 245       (while (and (not module-name)
 246                   (beginning-of-defun-raw 1))
 247         (if (looking-at "(define-module ")
 248             (setq module-name
 249                   (progn
 250                     (goto-char (match-end 0))
 251                     (read (current-buffer))))))
 252       module-name)))
 253
 254 (defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: "
 255   "Prefix used when telling Guile the name of the port from which a
 256 chunk of Scheme code (to be evaluated) comes.  GDS uses this prefix,
 257 followed by the buffer name, in two cases: when the buffer concerned
 258 is not associated with a file, or if the buffer has been modified
 259 since last saving to its file.  In the case where the buffer is
 260 identical to a saved file, GDS uses the file name as the port name."
 261   :type '(string)
 262   :group 'gds)
 263
 264 (defun gds-port-name (start end)
 265   "Return port name for the specified region of the current buffer.
 266 The name will be used by Guile as the port name when evaluating that
 267 region's code."
 268   (or (and (not (buffer-modified-p))
 269            buffer-file-name)
 270       (concat gds-emacs-buffer-port-name-prefix (buffer-name))))
 271
 272 (defun gds-line-and-column (pos)
 273   "Return 0-based line and column number at POS."
 274   (let (line column)
 275     (save-excursion
 276       (goto-char pos)
 277       (setq column (current-column))
 278       (beginning-of-line)
 279       (setq line (count-lines (point-min) (point))))
 280     (cons line column)))
 281
 282 (defun gds-eval-region (start end)
 283   "Evaluate the current region."
 284   (interactive "r")
 285   (or gds-client
 286       (gds-auto-associate-buffer)
 287       (call-interactively 'gds-associate-buffer))
 288   (let ((module (gds-module-name start end))
 289         (port-name (gds-port-name start end))
 290         (lc (gds-line-and-column start)))
 291     (let ((code (buffer-substring-no-properties start end)))
 292       (gds-send (format "eval (region . %S) %s %S %d %d %S"
 293                         (gds-abbreviated code)
 294                         (if module (prin1-to-string module) "#f")
 295                         port-name (car lc) (cdr lc)
 296                         code)
 297                 gds-client))))
 298
 299 (defun gds-eval-expression (expr &optional correlator)
 300   "Evaluate the supplied EXPR (a string)."
 301   (interactive "sEvaluate expression: \nP")
 302   (or gds-client
 303       (gds-auto-associate-buffer)
 304       (call-interactively 'gds-associate-buffer))
 305   (set-text-properties 0 (length expr) nil expr)
 306   (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S"
 307                     (or correlator 'expression)
 308                     (gds-abbreviated expr)
 309                     expr)
 310             gds-client))
 311
 312 (defconst gds-abbreviated-length 35)
 313
 314 (defun gds-abbreviated (code)
 315   (let ((nlpos (string-match (regexp-quote "\n") code)))
 316     (while nlpos
 317       (setq code
 318             (if (= nlpos (- (length code) 1))
 319                 (substring code 0 nlpos)
 320               (concat (substring code 0 nlpos)
 321                       "\\n"
 322                       (substring code (+ nlpos 1)))))
 323       (setq nlpos (string-match (regexp-quote "\n") code))))
 324   (if (> (length code) gds-abbreviated-length)
 325       (concat (substring code 0 (- gds-abbreviated-length 3)) "...")
 326     code))
 327
 328 (defun gds-eval-defun ()
 329   "Evaluate the defun (top-level form) at point."
 330   (interactive)
 331   (save-excursion
 332    (end-of-defun)
 333    (let ((end (point)))
 334      (beginning-of-defun)
 335      (gds-eval-region (point) end))))
 336
 337 (defun gds-eval-last-sexp ()
 338   "Evaluate the sexp before point."
 339   (interactive)
 340   (gds-eval-region (save-excursion (backward-sexp) (point)) (point)))
 341
 342 ;;;; Help.
 343
 344 ;; Help is implemented as a special case of evaluation, identified by
 345 ;; the evaluation correlator 'help.
 346
 347 (defun gds-help-symbol (sym)
 348   "Get help for SYM (a Scheme symbol)."
 349   (interactive
 350    (let ((sym (thing-at-point 'symbol))
 351          (enable-recursive-minibuffers t)
 352          val)
 353      (setq val (read-from-minibuffer
 354                 (if sym
 355                     (format "Describe Guile symbol (default %s): " sym)
 356                   "Describe Guile symbol: ")))
 357      (list (if (zerop (length val)) sym val))))
 358   (gds-eval-expression (format "(help %s)" sym) 'help))
 359
 360 (defun gds-apropos (regex)
 361   "List Guile symbols matching REGEX."
 362   (interactive
 363    (let ((sym (thing-at-point 'symbol))
 364          (enable-recursive-minibuffers t)
 365          val)
 366      (setq val (read-from-minibuffer
 367                 (if sym
 368                     (format "Guile apropos (regexp, default \"%s\"): " sym)
 369                   "Guile apropos (regexp): ")))
 370      (list (if (zerop (length val)) sym val))))
 371   (set-text-properties 0 (length regex) nil regex)
 372   (gds-eval-expression (format "(apropos %S)" regex) 'apropos))
 373
 374 ;;;; Displaying results of help and eval.
 375
 376 (defun gds-display-results (client correlator stack-available results)
 377   (let* ((helpp+bufname (cond ((eq (car correlator) 'help)
 378                                '(t . "*Guile Help*"))
 379                               ((eq (car correlator) 'apropos)
 380                                '(t . "*Guile Apropos*"))
 381                               (t
 382                                '(nil . "*Guile Evaluation*"))))
 383          (helpp (car helpp+bufname)))
 384     (let ((buf (get-buffer-create (cdr helpp+bufname))))
 385       (save-excursion
 386         (set-buffer buf)
 387         (gds-dissociate-buffer)
 388         (erase-buffer)
 389         (scheme-mode)
 390         (insert (cdr correlator) "\n\n")
 391         (while results
 392           (insert (car results))
 393           (or (bolp) (insert "\\\n"))
 394           (if helpp
 395               nil
 396             (if (cadr results)
 397                 (mapcar (function (lambda (value)
 398                                     (insert " => " value "\n")))
 399                         (cadr results))
 400               (insert " => no (or unspecified) value\n"))
 401             (insert "\n"))
 402           (setq results (cddr results)))
 403         (if stack-available
 404             (let ((beg (point))
 405                   (map (make-sparse-keymap)))
 406               (define-key map [mouse-1] 'gds-show-last-stack)
 407               (insert "[click here to show error stack]")
 408               (add-text-properties beg (point)
 409                                    (list 'keymap map
 410                                          'mouse-face 'highlight))
 411               (insert "\n")))
 412         (goto-char (point-min))
 413         (gds-associate-buffer client))
 414       (pop-to-buffer buf)
 415       (run-hooks 'temp-buffer-show-hook)
 416       (other-window 1))))
 417
 418 (defun gds-show-last-stack ()
 419   "Show stack of the most recent error."
 420   (interactive)
 421   (or gds-client
 422       (gds-auto-associate-buffer)
 423       (call-interactively 'gds-associate-buffer))
 424   (gds-send "debug-lazy-trap-context" gds-client))
 425
 426 ;;;; Completion.
 427
 428 (defvar gds-completion-results nil)
 429
 430 (defun gds-complete-symbol ()
 431   "Complete the Guile symbol before point.  Returns `t' if anything
 432 interesting happened, `nil' if not."
 433   (interactive)
 434   (or gds-client
 435       (gds-auto-associate-buffer)
 436       (call-interactively 'gds-associate-buffer))
 437   (let* ((chars (- (point) (save-excursion
 438                              (while (let ((syntax (char-syntax (char-before (point)))))
 439                                       (or (eq syntax ?w) (eq syntax ?_)))
 440                                (forward-char -1))
 441                              (point)))))
 442     (if (zerop chars)
 443         nil
 444       (setq gds-completion-results nil)
 445       (gds-send (format "complete %s"
 446                         (prin1-to-string
 447                          (buffer-substring-no-properties (- (point) chars)
 448                                                          (point))))
 449                  gds-client)
 450       (while (null gds-completion-results)
 451         (accept-process-output gds-debug-server 0 200))
 452       (cond ((eq gds-completion-results 'error)
 453              (error "Internal error - please report the contents of the *Guile Evaluation* window"))
 454             ((eq gds-completion-results t)
 455              nil)
 456             ((stringp gds-completion-results)
 457              (if (<= (length gds-completion-results) chars)
 458                  nil
 459                (insert (substring gds-completion-results chars))
 460                (message "Sole completion")
 461                t))
 462             ((= (length gds-completion-results) 1)
 463              (if (<= (length (car gds-completion-results)) chars)
 464                  nil
 465                (insert (substring (car gds-completion-results) chars))
 466                t))
 467             (t
 468              (with-output-to-temp-buffer "*Completions*"
 469                (display-completion-list gds-completion-results))
 470              t)))))
 471
 472 ;;;; Breakpoints.
 473
 474 (defvar gds-bufferless-breakpoints nil
 475   "The list of breakpoints that are not yet associated with a
 476 particular buffer.  Each element looks like (BPDEF BPNUM) where BPDEF
 477 is the breakpoint definition and BPNUM the breakpoint's unique
 478 GDS-assigned number.  A breakpoint definition BPDEF is a list of the
 479 form (BEHAVIOUR TYPE FILENAME TYPE-ARGS...), where BEHAVIOUR is 'debug
 480 or 'trace, TYPE is 'in or 'at, FILENAME is the full name of the file
 481 where the breakpoint is (or will be) set, and TYPE-ARGS is:
 482
 483 - the name of the procedure to break in, if TYPE is 'in
 484
 485 - the line number and column number to break at, if TYPE is 'at.
 486
 487 If persistent breakpoints are enabled (by configuring
 488 gds-breakpoints-file-name), this list is initialized when GDS is
 489 loaded by reading gds-breakpoints-file-name.")
 490
 491 (defsubst gds-bpdef:behaviour (bpdef)
 492   (nth 0 bpdef))
 493
 494 (defsubst gds-bpdef:type (bpdef)
 495   (nth 1 bpdef))
 496
 497 (defsubst gds-bpdef:file-name (bpdef)
 498   (nth 2 bpdef))
 499
 500 (defsubst gds-bpdef:proc-name (bpdef)
 501   (nth 3 bpdef))
 502
 503 (defsubst gds-bpdef:lc (bpdef)
 504   (nth 3 bpdef))
 505
 506 (defvar gds-breakpoint-number 0
 507   "The last assigned breakpoint number.  GDS increments this whenever
 508 it creates a new breakpoint.")
 509
 510 (defvar gds-breakpoint-buffers nil
 511   "The list of buffers that contain GDS breakpoints.  When Emacs
 512 visits a Scheme file, GDS checks to see if any of the breakpoints in
 513 the bufferless list can be assigned to that file's buffer.  If they
 514 can, they are removed from the bufferless list and become breakpoint
 515 overlays in that buffer.  To retain the ability to enumerate all
 516 breakpoints, therefore, we keep a list of all such buffers.")
 517
 518 (defvar gds-breakpoint-programming nil
 519   "Information about how each breakpoint is actually programmed in the
 520 Guile clients that GDS is connected to.  This is an alist of the form
 521 \((BPNUM (CLIENT . TRAPLIST) ...) ...), where BPNUM is the breakpoint
 522 number, CLIENT is the number of a GDS client, and TRAPLIST is the list
 523 of traps that that client has created for the breakpoint concerned (in
 524 an arbitrary but Emacs-readable format).")
 525
 526 (defvar gds-breakpoint-cache nil
 527   "Buffer-local cache of breakpoints in a particular buffer.  When a
 528 breakpoint is represented as an overlay is a Scheme mode buffer, we
 529 need to be able to detect when the user has caused that overlay to
 530 evaporate by deleting a region of code that included it.  We do this
 531 detection when the buffer is next saved, by comparing the current set
 532 of overlays with this cache.  The cache is a list in which each
 533 element has the form (BPDEF BPNUM), with BPDEF and BPNUM as already
 534 described.  The handling of such breakpoints (which we call \"lost\")
 535 is controlled by the setting of gds-delete-lost-breakpoints.")
 536 (make-variable-buffer-local 'gds-breakpoint-cache)
 537
 538 (defface gds-breakpoint-face
 539   '((((background dark)) (:background "red"))
 540     (t (:background "pink")))
 541   "*Face used to highlight the location of a breakpoint."
 542   :group 'gds)
 543
 544 (defcustom gds-breakpoints-file-name "~/.gds-breakpoints"
 545   "Name of file used to store GDS breakpoints between sessions.
 546 You can disable breakpoint persistence by setting this to nil."
 547   :group 'gds
 548   :type '(choice (const :tag "nil" nil) file))
 549
 550 (defcustom gds-delete-lost-breakpoints nil
 551   "Whether to delete lost breakpoints.
 552
 553 A non-nil value means that the Guile clients where lost breakpoints
 554 were programmed will be told immediately to delete their breakpoints.
 555 \"Immediately\" means when the lost breakpoints are detected, which
 556 means when the buffer that previously contained them is saved.  Thus,
 557 even if the affected code (which the GDS user has deleted from his/her
 558 buffer in Emacs) is still in use in the Guile clients, the breakpoints
 559 that were previously set in that code will no longer take effect.
 560
 561 Nil (which is the default) means that GDS leaves such breakpoints
 562 active in their Guile clients.  This allows those breakpoints to
 563 continue taking effect until the affected code is no longer used by
 564 the Guile clients."
 565   :group 'gds
 566   :type 'boolean)
 567
 568 (defvar gds-bpdefs-cache nil)
 569
 570 (defun gds-read-breakpoints-file ()
 571   "Read the persistent breakpoints file, and use its contents to
 572 initialize GDS's global breakpoint variables."
 573   (let ((bpdefs (condition-case nil
 574                     (with-current-buffer
 575                         (find-file-noselect gds-breakpoints-file-name)
 576                       (goto-char (point-min))
 577                       (read (current-buffer)))
 578                   (error nil))))
 579     ;; Cache the overall value so we don't unnecessarily modify the
 580     ;; breakpoints buffer when `gds-write-breakpoints-file' is called.
 581     (setq gds-bpdefs-cache bpdefs)
 582     ;; Move definitions into the bufferless breakpoint list, assigning
 583     ;; breakpoint numbers as we go.
 584     (setq gds-bufferless-breakpoints
 585           (mapcar (function (lambda (bpdef)
 586                               (setq gds-breakpoint-number
 587                                     (1+ gds-breakpoint-number))
 588                               (list bpdef gds-breakpoint-number)))
 589                   bpdefs))
 590     ;; Check each existing Scheme buffer to see if it wants to take
 591     ;; ownership of any of these breakpoints.
 592     (mapcar (function (lambda (buffer)
 593                         (with-current-buffer buffer
 594                           (if (eq (derived-mode-class major-mode) 'scheme-mode)
 595                               (gds-adopt-breakpoints)))))
 596             (buffer-list))))
 597
 598 (defun gds-adopt-breakpoints ()
 599   "Take ownership of any of the breakpoints in the bufferless list
 600 that match the current buffer."
 601   (mapcar (function gds-adopt-breakpoint)
 602           (copy-sequence gds-bufferless-breakpoints)))
 603
 604 (defun gds-adopt-breakpoint (bpdefnum)
 605   "Take ownership of the specified breakpoint if it matches the
 606 current buffer."
 607   (let ((bpdef (car bpdefnum))
 608         (bpnum (cadr bpdefnum)))
 609     ;; Check if breakpoint's file name matches.  If it does, try to
 610     ;; convert the breakpoint definition to a breakpoint overlay in
 611     ;; the current buffer.
 612     (if (and (string-equal (gds-bpdef:file-name bpdef) buffer-file-name)
 613              (gds-make-breakpoint-overlay bpdef bpnum))
 614         ;; That all succeeded, so this breakpoint is no longer
 615         ;; bufferless.
 616         (setq gds-bufferless-breakpoints
 617               (delq bpdefnum gds-bufferless-breakpoints)))))
 618
 619 (defun gds-make-breakpoint-overlay (bpdef &optional bpnum)
 620   ;; If no explicit number given, assign the next available breakpoint
 621   ;; number.
 622   (or bpnum
 623       (setq gds-breakpoint-number (+ gds-breakpoint-number 1)
 624             bpnum gds-breakpoint-number))
 625   ;; First decide where the overlay should be, and create it there.
 626   (let ((o (cond ((eq (gds-bpdef:type bpdef) 'at)
 627                   (save-excursion
 628                     (goto-line (+ (car (gds-bpdef:lc bpdef)) 1))
 629                     (move-to-column (cdr (gds-bpdef:lc bpdef)))
 630                     (make-overlay (point) (1+ (point)))))
 631                  ((eq (gds-bpdef:type bpdef) 'in)
 632                   (save-excursion
 633                     (goto-char (point-min))
 634                     (and (re-search-forward (concat "^(define +(?\\("
 635                                                     (regexp-quote
 636                                                      (gds-bpdef:proc-name
 637                                                       bpdef))
 638                                                     "\\>\\)")
 639                                             nil t)
 640                          (make-overlay (match-beginning 1) (match-end 1)))))
 641                  (t
 642                   (error "Bad breakpoint type")))))
 643     ;; If that succeeded, initialize the overlay's properties.
 644     (if o
 645         (progn
 646           (overlay-put o 'evaporate t)
 647           (overlay-put o 'face 'gds-breakpoint-face)
 648           (overlay-put o 'gds-breakpoint-number bpnum)
 649           (overlay-put o 'gds-breakpoint-definition bpdef)
 650           (overlay-put o 'help-echo (format "Breakpoint %d: %S" bpnum bpdef))
 651           (overlay-put o 'priority 1000)
 652           ;; Make sure that the current buffer is included in
 653           ;; `gds-breakpoint-buffers'.
 654           (or (memq (current-buffer) gds-breakpoint-buffers)
 655               (setq gds-breakpoint-buffers
 656                     (cons (current-buffer) gds-breakpoint-buffers)))
 657           ;; Add the new breakpoint to this buffer's cache.
 658           (setq gds-breakpoint-cache
 659                 (cons (list bpdef bpnum) gds-breakpoint-cache))
 660           ;; If this buffer is associated with a client, tell the
 661           ;; client about the new breakpoint.
 662           (if gds-client (gds-send-breakpoint-to-client bpnum bpdef))))
 663     ;; Return the overlay, or nil if we weren't able to convert the
 664     ;; breakpoint definition.
 665     o))
 666
 667 (defun gds-send-breakpoint-to-client (bpnum bpdef)
 668   "Send specified breakpoint to this buffer's Guile client."
 669   (gds-send (format "set-breakpoint %d %S" bpnum bpdef) gds-client))
 670
 671 (add-hook 'scheme-mode-hook (function gds-adopt-breakpoints))
 672
 673 (defcustom gds-default-breakpoint-type 'debug
 674   "The type of breakpoint set by `C-x SPC'."
 675   :group 'gds
 676   :type '(choice (const :tag "debug" debug) (const :tag "trace" trace)))
 677
 678 (defun gds-set-breakpoint ()
 679   "Create a new GDS breakpoint at point."
 680   (interactive)
 681   ;; Set up beg and end according to whether the mark is active.
 682   (if mark-active
 683       ;; Set new breakpoints on all opening parentheses in the region.
 684       (let ((beg (region-beginning))
 685             (end (region-end)))
 686         (save-excursion
 687           (goto-char beg)
 688           (beginning-of-defun)
 689           (let ((defun-start (point)))
 690             (goto-char beg)
 691             (while (search-forward "(" end t)
 692               (let ((state (parse-partial-sexp defun-start (point)))
 693                     (pos (- (point) 1)))
 694                 (or (nth 3 state)
 695                     (nth 4 state)
 696                     (gds-breakpoint-overlays-at pos)
 697                     (gds-make-breakpoint-overlay (list gds-default-breakpoint-type
 698                                                        'at
 699                                                        buffer-file-name
 700                                                        (gds-line-and-column
 701                                                         pos)))))))))
 702     ;; Set a new breakpoint on the defun at point.
 703     (let ((region (gds-defun-name-region)))
 704       ;; Complain if there is no defun at point.
 705       (or region
 706           (error "Point is not in a procedure definition"))
 707       ;; Don't create another breakpoint if there is already one here.
 708       (if (gds-breakpoint-overlays-at (car region))
 709           (error "There is already a breakpoint here"))
 710       ;; Create and return the new breakpoint overlay.
 711       (gds-make-breakpoint-overlay (list gds-default-breakpoint-type
 712                                          'in
 713                                          buffer-file-name
 714                                          (buffer-substring-no-properties
 715                                           (car region)
 716                                           (cdr region))))))
 717   ;; Update the persistent breakpoints file.
 718   (gds-write-breakpoints-file))
 719
 720 (defun gds-defun-name-region ()
 721   "If point is in a defun, return the beginning and end positions of
 722 the identifier being defined."
 723   (save-excursion
 724     (let ((p (point)))
 725       (beginning-of-defun)
 726       ;; Check that we are looking at some kind of procedure
 727       ;; definition.
 728       (and (looking-at "(define +(?\\(\\(\\s_\\|\\w\\)+\\)")
 729            (let ((beg (match-beginning 1))
 730                  (end (match-end 1)))
 731              (end-of-defun)
 732              ;; Check here that we have reached past the original point
 733              ;; position.
 734              (and (>= (point) p)
 735                   (cons beg end)))))))
 736
 737 (defun gds-breakpoint-overlays-at (pos)
 738   "Return a list of GDS breakpoint overlays at the specified position."
 739   (let ((os (overlays-at pos))
 740         (breakpoint-os nil))
 741     ;; Of the overlays at POS, select all those that have a
 742     ;; gds-breakpoint-definition property.
 743     (while os
 744       (if (overlay-get (car os) 'gds-breakpoint-definition)
 745           (setq breakpoint-os (cons (car os) breakpoint-os)))
 746       (setq os (cdr os)))
 747     breakpoint-os))
 748
 749 (defun gds-write-breakpoints-file ()
 750   "Write the persistent breakpoints file, if configured."
 751   (if gds-breakpoints-file-name
 752       (let ((bpdefs (gds-fold-breakpoints (function (lambda (bpnum bpdef init)
 753                                                       (cons bpdef init)))
 754                                           t)))
 755         (or (equal bpdefs gds-bpdefs-cache)
 756             (with-current-buffer (find-file-noselect gds-breakpoints-file-name)
 757               (erase-buffer)
 758               (pp (reverse bpdefs) (current-buffer))
 759               (setq gds-bpdefs-cache bpdefs)
 760               (let ((auto-fill-function normal-auto-fill-function))
 761                 (newline)))))))
 762
 763 (defun gds-fold-breakpoints (fn &optional foldp init)
 764   ;; Run through bufferless breakpoints first.
 765   (let ((bbs gds-bufferless-breakpoints))
 766     (while bbs
 767       (let ((bpnum (cadr (car bbs)))
 768             (bpdef (caar bbs)))
 769         (if foldp
 770             (setq init (funcall fn bpnum bpdef init))
 771           (funcall fn bpnum bpdef)))
 772       (setq bbs (cdr bbs))))
 773   ;; Now run through breakpoint buffers.
 774   (let ((outbuf (current-buffer))
 775         (bpbufs gds-breakpoint-buffers))
 776     (while bpbufs
 777       (let ((buf (car bpbufs)))
 778         (if (buffer-live-p buf)
 779             (with-current-buffer buf
 780               (save-restriction
 781                 (widen)
 782                 (let ((os (overlays-in (point-min) (point-max))))
 783                   (while os
 784                     (let ((bpnum (overlay-get (car os)
 785                                               'gds-breakpoint-number))
 786                           (bpdef (overlay-get (car os)
 787                                               'gds-breakpoint-definition)))
 788                       (if bpdef
 789                           (with-current-buffer outbuf
 790                             (if foldp
 791                                 (setq init (funcall fn bpnum bpdef init))
 792                               (funcall fn bpnum bpdef)))))
 793                     (setq os (cdr os))))))))
 794       (setq bpbufs (cdr bpbufs))))
 795   init)
 796
 797 (defun gds-delete-breakpoints ()
 798   "Delete GDS breakpoints in the region or at point."
 799   (interactive)
 800   (if mark-active
 801       ;; Delete all breakpoints in the region.
 802       (let ((os (overlays-in (region-beginning) (region-end))))
 803         (while os
 804           (if (overlay-get (car os) 'gds-breakpoint-definition)
 805               (gds-delete-breakpoint (car os)))
 806           (setq os (cdr os))))
 807     ;; Delete the breakpoint "at point".
 808     (call-interactively (function gds-delete-breakpoint))))
 809
 810 (defun gds-delete-breakpoint (o)
 811   (interactive (list (or (gds-breakpoint-at-point)
 812                          (error "There is no breakpoint here"))))
 813   (let ((bpdef (overlay-get o 'gds-breakpoint-definition))
 814         (bpnum (overlay-get o 'gds-breakpoint-number)))
 815     ;; If this buffer is associated with a client, tell the client
 816     ;; that the breakpoint has been deleted.
 817     (if (and bpnum gds-client)
 818         (gds-send (format "delete-breakpoint %d" bpnum) gds-client))
 819     ;; Remove this breakpoint from the cache also, so it isn't later
 820     ;; detected as having been "lost".
 821     (setq gds-breakpoint-cache
 822           (delq (assq bpdef gds-breakpoint-cache) gds-breakpoint-cache)))
 823   ;; Remove the overlay from its buffer.
 824   (delete-overlay o)
 825   ;; If that was the last breakpoint in this buffer, remove this
 826   ;; buffer from gds-breakpoint-buffers.
 827   (or gds-breakpoint-cache
 828       (setq gds-breakpoint-buffers
 829             (delq (current-buffer) gds-breakpoint-buffers)))
 830   ;; Update the persistent breakpoints file.
 831   (gds-write-breakpoints-file))
 832
 833 (defun gds-breakpoint-at-point ()
 834   "Find and return the overlay for a breakpoint `at' the current
 835 cursor position.  This is intended for use in other functions'
 836 interactive forms, so it intentionally uses the minibuffer in some
 837 situations."
 838   (let* ((region (gds-defun-name-region))
 839          (os (gds-union (gds-breakpoint-overlays-at (point))
 840                         (and region
 841                              (gds-breakpoint-overlays-at (car region))))))
 842     ;; Switch depending whether we found 0, 1 or more overlays.
 843     (cond ((null os)
 844            ;; None found: return nil.
 845            nil)
 846           ((= (length os) 1)
 847            ;; One found: return it.
 848            (car os))
 849           (t
 850            ;; More than 1 found: ask the user to choose.
 851            (gds-user-selected-breakpoint os)))))
 852
 853 (defun gds-union (first second &rest others)
 854   (if others
 855       (gds-union first (apply 'gds-union second others))
 856     (progn
 857       (while first
 858         (or (memq (car first) second)
 859             (setq second (cons (car first) second)))
 860         (setq first (cdr first)))
 861       second)))
 862
 863 (defun gds-user-selected-breakpoint (os)
 864   "Ask the user to choose one of the given list of breakpoints, and
 865 return the one that they chose."
 866   (let ((table (mapcar
 867                 (lambda (o)
 868                   (cons (format "%S"
 869                                 (overlay-get o 'gds-breakpoint-definition))
 870                         o))
 871                 os)))
 872     (cdr (assoc (completing-read "Which breakpoint do you mean? "
 873                                  table nil t)
 874                 table))))
 875
 876 (defun gds-describe-breakpoints ()
 877   "Describe all breakpoints and their programming status."
 878   (interactive)
 879   (with-current-buffer (get-buffer-create "*GDS Breakpoints*")
 880     (erase-buffer)
 881     (gds-fold-breakpoints (function gds-describe-breakpoint))
 882     (display-buffer (current-buffer))))
 883
 884 (defun gds-describe-breakpoint (bpnum bpdef)
 885   (insert (format "Breakpoint %d: %S\n" bpnum bpdef))
 886   (let ((bpproglist (cdr (assq bpnum gds-breakpoint-programming))))
 887     (mapcar (lambda (clientprog)
 888               (let ((client (car clientprog))
 889                     (traplist (cdr clientprog)))
 890                 (mapcar (lambda (trap)
 891                           (insert (format "  Client %d: %S\n" client trap)))
 892                         traplist)))
 893             bpproglist)))
 894
 895 (defun gds-after-save-update-breakpoints ()
 896   "Function called when a buffer containing breakpoints is saved."
 897   (if (eq (derived-mode-class major-mode) 'scheme-mode)
 898       (save-restriction
 899         (widen)
 900         ;; Get the current breakpoint overlays.
 901         (let ((os (overlays-in (point-min) (point-max)))
 902               (cache (copy-sequence gds-breakpoint-cache)))
 903           ;; Identify any overlays that have disappeared by comparing
 904           ;; against this buffer's definition cache, and
 905           ;; simultaneously rebuild the cache to reflect the current
 906           ;; set of overlays.
 907           (setq gds-breakpoint-cache nil)
 908           (while os
 909             (let* ((o (car os))
 910                    (bpdef (overlay-get o 'gds-breakpoint-definition))
 911                    (bpnum (overlay-get o 'gds-breakpoint-number)))
 912               (if bpdef
 913                   ;; o and bpdef describe a current breakpoint.
 914                   (progn
 915                     ;; Remove this breakpoint from the old cache list,
 916                     ;; so we don't think it got lost.
 917                     (setq cache (delq (assq bpdef cache) cache))
 918                     ;; Check whether this breakpoint's location has
 919                     ;; moved.  If it has, update the breakpoint
 920                     ;; definition and the associated client.
 921                     (let ((lcnow (gds-line-and-column (overlay-start o))))
 922                       (if (equal lcnow (gds-bpdef:lc bpdef))
 923                           nil           ; Breakpoint hasn't moved.
 924                         (gds-bpdef:setlc bpdef lcnow)
 925                         (if gds-client
 926                             (gds-send-breakpoint-to-client bpnum bpdef))))
 927                     ;; Add this breakpoint to the new cache list.
 928                     (setq gds-breakpoint-cache
 929                           (cons (list bpdef bpnum) gds-breakpoint-cache)))))
 930             (setq os (cdr os)))
 931           ;; cache now holds the set of lost breakpoints.  If we are
 932           ;; supposed to explicitly delete these from the associated
 933           ;; client, do that now.
 934           (if (and gds-delete-lost-breakpoints gds-client)
 935               (while cache
 936                 (gds-send (format "delete-breakpoint %d" (cadr (car cache)))
 937                           gds-client)
 938                 (setq cache (cdr cache)))))
 939         ;; If this buffer now has no breakpoints, remove it from
 940         ;; gds-breakpoint-buffers.
 941         (or gds-breakpoint-cache
 942             (setq gds-breakpoint-buffers
 943                   (delq (current-buffer) gds-breakpoint-buffers)))
 944         ;; Update the persistent breakpoints file.
 945         (gds-write-breakpoints-file))))
 946
 947 (add-hook 'after-save-hook (function gds-after-save-update-breakpoints))
 948
 949 ;;;; Dispatcher for non-debug protocol.
 950
 951 (defun gds-nondebug-protocol (client proc args)
 952   (cond (;; (eval-results ...) - Results of evaluation.
 953          (eq proc 'eval-results)
 954          (gds-display-results client (car args) (cadr args) (cddr args))
 955          ;; If these results indicate an error, set
 956          ;; gds-completion-results to non-nil in case the error arose
 957          ;; when trying to do a completion.
 958          (if (eq (caar args) 'error)
 959              (setq gds-completion-results 'error)))
 960
 961         (;; (completion-result ...) - Available completions.
 962          (eq proc 'completion-result)
 963          (setq gds-completion-results (or (car args) t)))
 964
 965         (;; (breakpoint NUM STATUS) - Breakpoint set.
 966          (eq proc 'breakpoint)
 967          (let* ((bpnum (car args))
 968                 (traplist (cdr args))
 969                 (bpentry (assq bpnum gds-breakpoint-programming)))
 970            (message "Breakpoint %d: %s" bpnum traplist)
 971            (if bpentry
 972                (let ((cliententry (assq client (cdr bpentry))))
 973                  (if cliententry
 974                      (setcdr cliententry traplist)
 975                    (setcdr bpentry
 976                            (cons (cons client traplist) (cdr bpentry)))))
 977              (setq gds-breakpoint-programming
 978                    (cons (list bpnum (cons client traplist))
 979                          gds-breakpoint-programming)))))
 980
 981         (;; (get-breakpoints) - Set all breakpoints.
 982          (eq proc 'get-breakpoints)
 983          (let ((gds-client client))
 984            (gds-fold-breakpoints (function gds-send-breakpoint-to-client)))
 985          (gds-send "continue" client))
 986
 987         (;; (note ...) - For debugging only.
 988          (eq proc 'note))
 989
 990         (;; (trace ...) - Tracing.
 991          (eq proc 'trace)
 992          (with-current-buffer (get-buffer-create "*GDS Trace*")
 993            (save-excursion
 994              (goto-char (point-max))
 995              (or (bolp) (insert "\n"))
 996              (insert "[client " (number-to-string client) "] " (car args) "\n"))))
 997
 998         (t
 999          ;; Unexpected.
1000          (error "Bad protocol: %S" form))))
1001
1002 ;;;; Scheme mode keymap items.
1003
1004 (define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun)
1005 (define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp)
1006 (define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
1007 (define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
1008 (define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
1009 (define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
1010 (define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
1011 (define-key scheme-mode-map "\C-x " 'gds-set-breakpoint)
1012
1013 (define-prefix-command 'gds-breakpoint-map)
1014 (define-key scheme-mode-map "\C-c\C-b" 'gds-breakpoint-map)
1015 (define-key gds-breakpoint-map " " 'gds-set-breakpoint)
1016 (define-key gds-breakpoint-map "d"
1017   (function (lambda ()
1018               (interactive)
1019               (let ((gds-default-breakpoint-type 'debug))
1020                 (gds-set-breakpoint)))))
1021 (define-key gds-breakpoint-map "t"
1022   (function (lambda ()
1023               (interactive)
1024               (let ((gds-default-breakpoint-type 'trace))
1025                 (gds-set-breakpoint)))))
1026 (define-key gds-breakpoint-map "T"
1027   (function (lambda ()
1028               (interactive)
1029               (let ((gds-default-breakpoint-type 'trace-subtree))
1030                 (gds-set-breakpoint)))))
1031 (define-key gds-breakpoint-map [backspace] 'gds-delete-breakpoints)
1032 (define-key gds-breakpoint-map "?" 'gds-describe-breakpoints)
1033
1034 ;;;; The end!
1035
1036 (provide 'gds-scheme)
1037
1038 ;;; gds-scheme.el ends here.