1 ;;; gds-scheme.el -- GDS function for Scheme mode buffers
3 ;;;; Copyright (C) 2005 Neil Jerram
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
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.
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
26 ;;;; Maintaining an association between a Guile client process and a
27 ;;;; set of Scheme mode buffers.
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."
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."
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."
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
58 (make-variable-buffer-local 'gds-last-touched-by
)
60 (defun gds-auto-associate-buffer ()
61 "Automatically associate the current buffer with a Guile client, if
63 (let* ((num-clients (length gds-client-info
))
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
))))
85 (gds-associate-buffer client
))))
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
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
101 (gds-client-put client
'associated-buffers
102 (cons (current-buffer)
103 (gds-client-get client
'associated-buffers
))))
105 (defun gds-dissociate-buffer ()
106 "Dissociate the current buffer from any specific Guile process."
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))))
121 (defun gds-show-client-status (client status-string
)
122 "Show a client's status in the modeline of all its associated
124 (let ((buffers (gds-client-get client
'associated-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
)))))
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."
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
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."
155 (defun gds-choose-client ()
156 "Ask the user to choose a GDS client process from a list."
159 ;; Prepare a table containing all current clients.
160 (mapcar (lambda (client-info)
161 (setq table
(cons (cons (cadr (memq 'name 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
170 (setq default
(or (and gds-last-touched-by
171 (gds-client-get gds-last-touched-by
'name
))
173 ;; Read using this table.
174 (let* ((name (completing-read "Choose a Guile process: "
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.
188 (defvar gds-last-utility-number
0
189 "Number of the last started Guile utility process.")
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
197 (use-modules (ice-9 gds-client))
199 (if gds-scheme-directory
200 (concat "(set! %load-path (cons "
201 (format "%S" gds-scheme-directory
)
204 (proc (start-process procname
205 (get-buffer-create procname
)
212 ;; Note that this process can be killed automatically on Emacs
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
)
222 ;; Accept output from the new process until we have its number.
224 (accept-process-output proc
))
225 ;; Return the new process's client number.
228 ;;;; Evaluating code.
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.
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.
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?
245 (while (and (not module-name
)
246 (beginning-of-defun-raw 1))
247 (if (looking-at "(define-module ")
250 (goto-char (match-end 0))
251 (read (current-buffer))))))
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."
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
268 (or (and (not (buffer-modified-p))
270 (concat gds-emacs-buffer-port-name-prefix
(buffer-name))))
272 (defun gds-line-and-column (pos)
273 "Return 0-based line and column number at POS."
277 (setq column
(current-column))
279 (setq line
(count-lines (point-min) (point))))
282 (defun gds-eval-region (start end
)
283 "Evaluate the current region."
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
)
299 (defun gds-eval-expression (expr &optional correlator
)
300 "Evaluate the supplied EXPR (a string)."
301 (interactive "sEvaluate expression: \nP")
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
)
312 (defconst gds-abbreviated-length
35)
314 (defun gds-abbreviated (code)
315 (let ((nlpos (string-match (regexp-quote "\n") code
)))
318 (if (= nlpos
(- (length code
) 1))
319 (substring code
0 nlpos
)
320 (concat (substring code
0 nlpos
)
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)) "...")
328 (defun gds-eval-defun ()
329 "Evaluate the defun (top-level form) at point."
335 (gds-eval-region (point) end
))))
337 (defun gds-eval-last-sexp ()
338 "Evaluate the sexp before point."
340 (gds-eval-region (save-excursion (backward-sexp) (point)) (point)))
344 ;; Help is implemented as a special case of evaluation, identified by
345 ;; the evaluation correlator 'help.
347 (defun gds-help-symbol (sym)
348 "Get help for SYM (a Scheme symbol)."
350 (let ((sym (thing-at-point 'symbol
))
351 (enable-recursive-minibuffers t
)
353 (setq val
(read-from-minibuffer
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
))
360 (defun gds-apropos (regex)
361 "List Guile symbols matching REGEX."
363 (let ((sym (thing-at-point 'symbol
))
364 (enable-recursive-minibuffers t
)
366 (setq val
(read-from-minibuffer
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
))
374 ;;;; Displaying results of help and eval.
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*"))
382 '(nil .
"*Guile Evaluation*"))))
383 (helpp (car helpp
+bufname
)))
384 (let ((buf (get-buffer-create (cdr helpp
+bufname
))))
387 (gds-dissociate-buffer)
390 (insert (cdr correlator
) "\n\n")
392 (insert (car results
))
393 (or (bolp) (insert "\\\n"))
397 (mapcar (function (lambda (value)
398 (insert " => " value
"\n")))
400 (insert " => no (or unspecified) value\n"))
402 (setq results
(cddr results
)))
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)
410 'mouse-face
'highlight
))
412 (goto-char (point-min))
413 (gds-associate-buffer client
))
415 (run-hooks 'temp-buffer-show-hook
)
418 (defun gds-show-last-stack ()
419 "Show stack of the most recent error."
422 (gds-auto-associate-buffer)
423 (call-interactively 'gds-associate-buffer
))
424 (gds-send "debug-lazy-trap-context" gds-client
))
428 (defvar gds-completion-results nil
)
430 (defun gds-complete-symbol ()
431 "Complete the Guile symbol before point. Returns `t' if anything
432 interesting happened, `nil' if not."
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 ?_
)))
444 (setq gds-completion-results nil
)
445 (gds-send (format "complete %s"
447 (buffer-substring-no-properties (- (point) chars
)
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
)
456 ((stringp gds-completion-results
)
457 (if (<= (length gds-completion-results
) chars
)
459 (insert (substring gds-completion-results chars
))
460 (message "Sole completion")
462 ((= (length gds-completion-results
) 1)
463 (if (<= (length (car gds-completion-results
)) chars
)
465 (insert (substring (car gds-completion-results
) chars
))
468 (with-output-to-temp-buffer "*Completions*"
469 (display-completion-list gds-completion-results
))
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:
483 - the name of the procedure to break in, if TYPE is 'in
485 - the line number and column number to break at, if TYPE is 'at.
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.")
491 (defsubst gds-bpdef
:behaviour
(bpdef)
494 (defsubst gds-bpdef
:type
(bpdef)
497 (defsubst gds-bpdef
:file-name
(bpdef)
500 (defsubst gds-bpdef
:proc-name
(bpdef)
503 (defsubst gds-bpdef
:lc
(bpdef)
506 (defvar gds-breakpoint-number
0
507 "The last assigned breakpoint number. GDS increments this whenever
508 it creates a new breakpoint.")
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.")
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).")
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
)
538 (defface gds-breakpoint-face
539 '((((background dark
)) (:background
"red"))
540 (t (:background
"pink")))
541 "*Face used to highlight the location of a breakpoint."
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."
548 :type
'(choice (const :tag
"nil" nil
) file
))
550 (defcustom gds-delete-lost-breakpoints nil
551 "Whether to delete lost breakpoints.
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.
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
568 (defvar gds-bpdefs-cache nil
)
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
575 (find-file-noselect gds-breakpoints-file-name
)
576 (goto-char (point-min))
577 (read (current-buffer)))
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
)))
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)))))
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
)))
604 (defun gds-adopt-breakpoint (bpdefnum)
605 "Take ownership of the specified breakpoint if it matches the
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
616 (setq gds-bufferless-breakpoints
617 (delq bpdefnum gds-bufferless-breakpoints
)))))
619 (defun gds-make-breakpoint-overlay (bpdef &optional bpnum
)
620 ;; If no explicit number given, assign the next available breakpoint
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
)
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
)
633 (goto-char (point-min))
634 (and (re-search-forward (concat "^(define +(?\\("
640 (make-overlay (match-beginning 1) (match-end 1)))))
642 (error "Bad breakpoint type")))))
643 ;; If that succeeded, initialize the overlay's properties.
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.
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
))
671 (add-hook 'scheme-mode-hook
(function gds-adopt-breakpoints
))
673 (defcustom gds-default-breakpoint-type
'debug
674 "The type of breakpoint set by `C-x SPC'."
676 :type
'(choice (const :tag
"debug" debug
) (const :tag
"trace" trace
)))
678 (defun gds-set-breakpoint ()
679 "Create a new GDS breakpoint at point."
681 ;; Set up beg and end according to whether the mark is active.
683 ;; Set new breakpoints on all opening parentheses in the region.
684 (let ((beg (region-beginning))
689 (let ((defun-start (point)))
691 (while (search-forward "(" end t
)
692 (let ((state (parse-partial-sexp defun-start
(point)))
696 (gds-breakpoint-overlays-at pos
)
697 (gds-make-breakpoint-overlay (list gds-default-breakpoint-type
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.
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
714 (buffer-substring-no-properties
717 ;; Update the persistent breakpoints file.
718 (gds-write-breakpoints-file))
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."
726 ;; Check that we are looking at some kind of procedure
728 (and (looking-at "(define +(?\\(\\(\\s_\\|\\w\\)+\\)")
729 (let ((beg (match-beginning 1))
732 ;; Check here that we have reached past the original point
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
))
741 ;; Of the overlays at POS, select all those that have a
742 ;; gds-breakpoint-definition property.
744 (if (overlay-get (car os
) 'gds-breakpoint-definition
)
745 (setq breakpoint-os
(cons (car os
) breakpoint-os
)))
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
)
755 (or (equal bpdefs gds-bpdefs-cache
)
756 (with-current-buffer (find-file-noselect gds-breakpoints-file-name
)
758 (pp (reverse bpdefs
) (current-buffer))
759 (setq gds-bpdefs-cache bpdefs
)
760 (let ((auto-fill-function normal-auto-fill-function
))
763 (defun gds-fold-breakpoints (fn &optional foldp init
)
764 ;; Run through bufferless breakpoints first.
765 (let ((bbs gds-bufferless-breakpoints
))
767 (let ((bpnum (cadr (car bbs
)))
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
))
777 (let ((buf (car bpbufs
)))
778 (if (buffer-live-p buf
)
779 (with-current-buffer buf
782 (let ((os (overlays-in (point-min) (point-max))))
784 (let ((bpnum (overlay-get (car os
)
785 'gds-breakpoint-number
))
786 (bpdef (overlay-get (car os
)
787 'gds-breakpoint-definition
)))
789 (with-current-buffer outbuf
791 (setq init
(funcall fn bpnum bpdef init
))
792 (funcall fn bpnum bpdef
)))))
793 (setq os
(cdr os
))))))))
794 (setq bpbufs
(cdr bpbufs
))))
797 (defun gds-delete-breakpoints ()
798 "Delete GDS breakpoints in the region or at point."
801 ;; Delete all breakpoints in the region.
802 (let ((os (overlays-in (region-beginning) (region-end))))
804 (if (overlay-get (car os
) 'gds-breakpoint-definition
)
805 (gds-delete-breakpoint (car os
)))
807 ;; Delete the breakpoint "at point".
808 (call-interactively (function gds-delete-breakpoint
))))
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.
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))
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
838 (let* ((region (gds-defun-name-region))
839 (os (gds-union (gds-breakpoint-overlays-at (point))
841 (gds-breakpoint-overlays-at (car region
))))))
842 ;; Switch depending whether we found 0, 1 or more overlays.
844 ;; None found: return nil.
847 ;; One found: return it.
850 ;; More than 1 found: ask the user to choose.
851 (gds-user-selected-breakpoint os
)))))
853 (defun gds-union (first second
&rest others
)
855 (gds-union first
(apply 'gds-union second others
))
858 (or (memq (car first
) second
)
859 (setq second
(cons (car first
) second
)))
860 (setq first
(cdr first
)))
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."
869 (overlay-get o
'gds-breakpoint-definition
))
872 (cdr (assoc (completing-read "Which breakpoint do you mean? "
876 (defun gds-describe-breakpoints ()
877 "Describe all breakpoints and their programming status."
879 (with-current-buffer (get-buffer-create "*GDS Breakpoints*")
881 (gds-fold-breakpoints (function gds-describe-breakpoint
))
882 (display-buffer (current-buffer))))
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
)))
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
)
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
907 (setq gds-breakpoint-cache nil
)
910 (bpdef (overlay-get o
'gds-breakpoint-definition
))
911 (bpnum (overlay-get o
'gds-breakpoint-number
)))
913 ;; o and bpdef describe a current breakpoint.
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
)
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
)))))
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
)
936 (gds-send (format "delete-breakpoint %d" (cadr (car cache
)))
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))))
947 (add-hook 'after-save-hook
(function gds-after-save-update-breakpoints
))
949 ;;;; Dispatcher for non-debug protocol.
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
)))
961 (;; (completion-result ...) - Available completions.
962 (eq proc
'completion-result
)
963 (setq gds-completion-results
(or (car args
) t
)))
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
)
972 (let ((cliententry (assq client
(cdr bpentry
))))
974 (setcdr cliententry traplist
)
976 (cons (cons client traplist
) (cdr bpentry
)))))
977 (setq gds-breakpoint-programming
978 (cons (list bpnum
(cons client traplist
))
979 gds-breakpoint-programming
)))))
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
))
987 (;; (note ...) - For debugging only.
990 (;; (trace ...) - Tracing.
992 (with-current-buffer (get-buffer-create "*GDS Trace*")
994 (goto-char (point-max))
995 (or (bolp) (insert "\n"))
996 (insert "[client " (number-to-string client
) "] " (car args
) "\n"))))
1000 (error "Bad protocol: %S" form
))))
1002 ;;;; Scheme mode keymap items.
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
)
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 ()
1019 (let ((gds-default-breakpoint-type 'debug
))
1020 (gds-set-breakpoint)))))
1021 (define-key gds-breakpoint-map
"t"
1022 (function (lambda ()
1024 (let ((gds-default-breakpoint-type 'trace
))
1025 (gds-set-breakpoint)))))
1026 (define-key gds-breakpoint-map
"T"
1027 (function (lambda ()
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)
1036 (provide 'gds-scheme)
1038 ;;; gds-scheme.el ends here.