Commit | Line | Data |
---|---|---|
731bcf73 NJ |
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) | |
19b16cd0 | 161 | (setq table (cons (cons (cadr (memq 'name client-info)) |
731bcf73 NJ |
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 | |
fce4b99e | 197 | (use-modules (ice-9 gds-client)) |
731bcf73 NJ |
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. |