]> git.donarmstrong.com Git - lilypond.git/blob - guile18/emacs/gds.el
Import guile-1.8 as multiple upstream tarball component
[lilypond.git] / guile18 / emacs / gds.el
1 ;;; gds.el -- frontend for Guile development in Emacs
2
3 ;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
4 ;;;;
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 2.1 of the License, or (at your option) any later
9 ;;;; version.
10 ;;;; 
11 ;;;; This library is distributed in the hope that it will be useful,
12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14 ;;;; Lesser General Public License for more details.
15 ;;;; 
16 ;;;; You should have received a copy of the GNU Lesser General Public
17 ;;;; License along with this library; if not, write to the Free
18 ;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
19 ;;;; 02111-1307 USA
20
21 ; TODO:
22 ; ?transcript
23 ; scheme-mode menu
24 ; interrupt/sigint/async-break
25 ; (module browsing)
26 ; load file
27 ; doing common protocol from debugger
28 ; thread override for debugging
29
30 ;;;; Prerequisites.
31
32 (require 'scheme)
33 (require 'cl)
34 (require 'gds-server)
35 (require 'gds-scheme)
36
37 ;; The subprocess object for the debug server.
38 (defvar gds-debug-server nil)
39
40 (defvar gds-socket-type-alist '((tcp . 8333)
41                                 (unix . "/tmp/.gds_socket"))
42   "Maps each of the possible socket types that the GDS server can
43 listen on to the path that it should bind to for each one.")
44
45 (defun gds-run-debug-server ()
46   "Start (or restart, if already running) the GDS debug server process."
47   (interactive)
48   (if gds-debug-server (gds-kill-debug-server))
49   (setq gds-debug-server
50         (gds-start-server "gds-debug"
51                           (cdr (assq gds-server-socket-type
52                                      gds-socket-type-alist))
53                           'gds-debug-protocol))
54   (process-kill-without-query gds-debug-server))
55
56 (defun gds-kill-debug-server ()
57   "Kill the GDS debug server process."
58   (interactive)
59   (mapcar (function gds-client-gone)
60           (mapcar (function car) gds-client-info))
61   (condition-case nil
62       (progn
63         (kill-process gds-debug-server)
64         (accept-process-output gds-debug-server 0 200))
65     (error))
66   (setq gds-debug-server nil))
67
68 ;; Send input to the subprocess.
69 (defun gds-send (string client)
70   (with-current-buffer (get-buffer-create "*GDS Transcript*")
71     (goto-char (point-max))
72     (insert (number-to-string client) ": (" string ")\n"))
73   (gds-client-put client 'thread-id nil)
74   (gds-show-client-status client gds-running-text)
75   (process-send-string gds-debug-server (format "(%S %s)\n" client string)))
76
77
78 ;;;; Per-client information
79
80 (defun gds-client-put (client property value)
81   (let ((client-info (assq client gds-client-info)))
82     (if client-info
83         (let ((prop-info (memq property client-info)))
84           (if prop-info
85               (setcar (cdr prop-info) value)
86             (setcdr client-info
87                     (list* property value (cdr client-info)))))
88       (setq gds-client-info
89             (cons (list client property value) gds-client-info)))))
90
91 (defun gds-client-get (client property)
92   (let ((client-info (assq client gds-client-info)))
93     (and client-info
94          (cadr (memq property client-info)))))
95
96 (defvar gds-client-info '())
97
98 (defun gds-get-client-buffer (client)
99   (let ((existing-buffer (gds-client-get client 'stack-buffer)))
100     (if (and existing-buffer
101              (buffer-live-p existing-buffer))
102         existing-buffer
103       (let ((new-buffer (generate-new-buffer (gds-client-get client 'name))))
104         (with-current-buffer new-buffer
105           (gds-debug-mode)
106           (setq gds-client client)
107           (setq gds-stack nil))
108         (gds-client-put client 'stack-buffer new-buffer)
109         new-buffer))))
110
111 (defun gds-client-gone (client &rest ignored)
112   ;; Kill the client's stack buffer, if it has one.
113   (let ((stack-buffer (gds-client-get client 'stack-buffer)))
114     (if (and stack-buffer
115              (buffer-live-p stack-buffer))
116         (kill-buffer stack-buffer)))
117   ;; Dissociate all the client's associated buffers.
118   (mapcar (function (lambda (buffer)
119                       (if (buffer-live-p buffer)
120                           (with-current-buffer buffer
121                             (gds-dissociate-buffer)))))
122           (copy-sequence (gds-client-get client 'associated-buffers)))
123   ;; Remove this client's record from gds-client-info.
124   (setq gds-client-info (delq (assq client gds-client-info) gds-client-info)))
125
126 (defvar gds-client nil)
127 (make-variable-buffer-local 'gds-client)
128
129 (defvar gds-stack nil)
130 (make-variable-buffer-local 'gds-stack)
131
132 (defvar gds-tweaking nil)
133 (make-variable-buffer-local 'gds-tweaking)
134
135 (defvar gds-selected-frame-index nil)
136 (make-variable-buffer-local 'gds-selected-frame-index)
137
138
139 ;;;; Debugger protocol
140
141 (defun gds-debug-protocol (client form)
142   (or (eq client '*)
143       (let ((proc (car form)))
144         (cond ((eq proc 'name)
145                ;; (name ...) - client name.
146                (gds-client-put client 'name (caddr form)))
147
148               ((eq proc 'stack)
149                ;; (stack ...) - stack information.
150                (with-current-buffer (gds-get-client-buffer client)
151                  (setq gds-stack (cddr form))
152                  (setq gds-tweaking (memq 'instead (cadr gds-stack)))
153                  (setq gds-selected-frame-index (cadr form))
154                  (gds-display-stack)))
155
156               ((eq proc 'closed)
157                ;; (closed) - client has gone/died.
158                (gds-client-gone client))
159
160               ((eq proc 'eval-result)
161                ;; (eval-result RESULT) - result of evaluation.
162                (if gds-last-eval-result
163                    (message "%s" (cadr form))
164                  (setq gds-last-eval-result (cadr form))))
165
166               ((eq proc 'info-result)
167                ;; (info-result RESULT) - info about selected frame.
168                (message "%s" (cadr form)))
169
170               ((eq proc 'thread-id)
171                ;; (thread-id THREAD) - says which client thread is reading.
172                (let ((thread-id (cadr form))
173                      (debug-thread-id (gds-client-get client 'debug-thread-id)))
174                  (if (and debug-thread-id
175                           (/= thread-id debug-thread-id))
176                      ;; Tell the newly reading thread to go away.
177                      (gds-send "dismiss" client)
178                    ;; Either there's no current debug-thread-id, or
179                    ;; the thread now reading is the debug thread.
180                    (if debug-thread-id
181                        (progn
182                          ;; Reset the debug-thread-id.
183                          (gds-client-put client 'debug-thread-id nil)
184                          ;; Indicate debug status in modelines.
185                          (gds-show-client-status client gds-debug-text))
186                      ;; Indicate normal read status in modelines..
187                      (gds-show-client-status client gds-ready-text)))))
188
189               ((eq proc 'debug-thread-id)
190                ;; (debug-thread-id THREAD) - debug override indication.
191                (gds-client-put client 'debug-thread-id (cadr form))
192                ;; If another thread is already reading, send it away.
193                (if (gds-client-get client 'thread-id)
194                    (gds-send "dismiss" client)))
195
196               (t
197                ;; Non-debug-specific protocol.
198                (gds-nondebug-protocol client proc (cdr form)))))))
199
200
201 ;;;; Displaying a stack
202
203 (define-derived-mode gds-debug-mode
204   scheme-mode
205   "Guile-Debug"
206   "Major mode for debugging a Guile client application."
207   (use-local-map gds-mode-map))
208
209 (defun gds-display-stack-first-line ()
210   (let ((flags (cadr gds-stack)))
211     (cond ((memq 'application flags)
212            (insert "Calling procedure:\n"))
213           ((memq 'evaluation flags)
214            (insert "Evaluating expression"
215                    (cond ((stringp gds-tweaking) (format " (tweaked: %s)"
216                                                          gds-tweaking))
217                          (gds-tweaking " (tweakable)")
218                          (t ""))
219                    ":\n"))
220           ((memq 'return flags)
221            (let ((value (cadr (memq 'return flags))))
222              (while (string-match "\n" value)
223                (setq value (replace-match "\\n" nil t value)))
224              (insert "Return value"
225                      (cond ((stringp gds-tweaking) (format " (tweaked: %s)"
226                                                            gds-tweaking))
227                            (gds-tweaking " (tweakable)")
228                            (t ""))
229                      ": " value "\n")))
230           ((memq 'error flags)
231            (let ((value (cadr (memq 'error flags))))
232              (while (string-match "\n" value)
233                (setq value (replace-match "\\n" nil t value)))
234              (insert "Error: " value "\n")))
235           (t
236            (insert "Stack: " (prin1-to-string flags) "\n")))))
237
238 (defun gds-display-stack ()
239   (if gds-undisplay-timer
240       (cancel-timer gds-undisplay-timer))
241   (setq gds-undisplay-timer nil)
242   ;(setq buffer-read-only nil)
243   (mapcar 'delete-overlay
244           (overlays-in (point-min) (point-max)))
245   (erase-buffer)
246   (gds-display-stack-first-line)
247   (let ((frames (car gds-stack)))
248     (while frames
249       (let ((frame-text (cadr (car frames)))
250             (frame-source (caddr (car frames))))
251         (while (string-match "\n" frame-text)
252           (setq frame-text (replace-match "\\n" nil t frame-text)))
253         (insert "   "
254                 (if frame-source "s" " ")
255                 frame-text
256                 "\n"))
257       (setq frames (cdr frames))))
258   ;(setq buffer-read-only t)
259   (gds-show-selected-frame))
260
261 (defun gds-tweak (expr)
262   (interactive "sTweak expression or return value: ")
263   (or gds-tweaking
264       (error "The current stack cannot be tweaked"))
265   (setq gds-tweaking
266         (if (> (length expr) 0)
267             expr
268           t))
269   (save-excursion
270     (goto-char (point-min))
271     (delete-region (point) (progn (forward-line 1) (point)))
272     (gds-display-stack-first-line)))
273
274 (defvar gds-undisplay-timer nil)
275 (make-variable-buffer-local 'gds-undisplay-timer)
276
277 (defvar gds-undisplay-wait 1)
278
279 (defun gds-undisplay-buffer ()
280   (if gds-undisplay-timer
281       (cancel-timer gds-undisplay-timer))
282   (setq gds-undisplay-timer
283         (run-at-time gds-undisplay-wait
284                      nil
285                      (function kill-buffer)
286                      (current-buffer))))
287                                  
288 (defun gds-show-selected-frame ()
289   (setq gds-local-var-cache nil)
290   (goto-char (point-min))
291   (forward-line (+ gds-selected-frame-index 1))
292   (delete-char 3)
293   (insert "=> ")
294   (beginning-of-line)
295   (gds-show-selected-frame-source (caddr (nth gds-selected-frame-index
296                                               (car gds-stack)))))
297
298 (defun gds-unshow-selected-frame ()
299   (if gds-frame-source-overlay
300       (move-overlay gds-frame-source-overlay 0 0))
301   (save-excursion
302     (goto-char (point-min))
303     (forward-line (+ gds-selected-frame-index 1))
304     (delete-char 3)
305     (insert "   ")))
306
307 ;; Overlay used to highlight the source expression corresponding to
308 ;; the selected frame.
309 (defvar gds-frame-source-overlay nil)
310
311 (defcustom gds-source-file-name-transforms nil
312   "Alist of regexps and substitutions for transforming Scheme source
313 file names.  Each element in the alist is (REGEXP . SUBSTITUTION).
314 Each source file name in a Guile backtrace is compared against each
315 REGEXP in turn until the first one that matches, then `replace-match'
316 is called with SUBSTITUTION to transform that file name.
317
318 This mechanism targets the situation where you are working on a Guile
319 application and want to install it, in /usr/local say, before each
320 test run.  In this situation, even though Guile is reading your Scheme
321 files from /usr/local/share/guile, you probably want Emacs to pop up
322 the corresponding files from your working codebase instead.  Therefore
323 you would add an element to this alist to transform
324 \"^/usr/local/share/guile/whatever\" to \"~/codebase/whatever\"."
325   :type '(alist :key-type regexp :value-type string)
326   :group 'gds)
327
328 (defun gds-show-selected-frame-source (source)
329   ;; Highlight the frame source, if possible.
330   (if source
331       (let ((filename (car source))
332             (client gds-client)
333             (transforms gds-source-file-name-transforms))
334         ;; Apply possible transforms to the source file name.
335         (while transforms
336           (if (string-match (caar transforms) filename)
337               (let ((trans-fn (replace-match (cdar transforms)
338                                              t nil filename)))
339                 (if (file-readable-p trans-fn)
340                     (setq filename trans-fn
341                           transforms nil))))
342           (setq transforms (cdr transforms)))
343         ;; Try to map the (possibly transformed) source file to a
344         ;; buffer.
345         (let ((source-buffer (gds-source-file-name-to-buffer filename)))
346           (if source-buffer
347               (with-current-buffer source-buffer
348                 (if gds-frame-source-overlay
349                     nil
350                   (setq gds-frame-source-overlay (make-overlay 0 0))
351                   (overlay-put gds-frame-source-overlay 'face 'highlight)
352                   (overlay-put gds-frame-source-overlay
353                                'help-echo
354                                (function gds-show-local-var)))
355                 ;; Move to source line.  Note that Guile line numbering
356                 ;; is 0-based, while Emacs numbering is 1-based.
357                 (save-restriction
358                   (widen)
359                   (goto-line (+ (cadr source) 1))
360                   (move-to-column (caddr source))
361                   (move-overlay gds-frame-source-overlay
362                                 (point)
363                                 (if (not (looking-at ")"))
364                                     (save-excursion (forward-sexp 1) (point))
365                                   ;; It seems that the source
366                                   ;; coordinates for backquoted
367                                   ;; expressions are at the end of the
368                                   ;; sexp rather than the beginning...
369                                   (save-excursion (forward-char 1)
370                                                   (backward-sexp 1) (point)))
371                                 (current-buffer)))
372                 ;; Record that this source buffer has been touched by a
373                 ;; GDS client process.
374                 (setq gds-last-touched-by client))
375             (message "Source for this frame cannot be shown: %s:%d:%d"
376                      filename
377                      (cadr source)
378                      (caddr source)))))
379     (message "Source for this frame was not recorded"))
380   (gds-display-buffers))
381
382 (defvar gds-local-var-cache nil)
383
384 (defun gds-show-local-var (window overlay position)
385   (let ((frame-index gds-selected-frame-index)
386         (client gds-client))
387     (with-current-buffer (overlay-buffer overlay)
388       (save-excursion
389         (goto-char position)
390         (let ((gds-selected-frame-index frame-index)
391               (gds-client client)
392               (varname (thing-at-point 'symbol))
393               (state (parse-partial-sexp (overlay-start overlay) (point))))
394           (when (and gds-selected-frame-index
395                      gds-client
396                      varname
397                      (not (or (nth 3 state)
398                               (nth 4 state))))
399             (set-text-properties 0 (length varname) nil varname)
400             (let ((existing (assoc varname gds-local-var-cache)))
401               (if existing
402                   (cdr existing)
403                 (gds-evaluate varname)
404                 (setq gds-last-eval-result nil)
405                 (while (not gds-last-eval-result)
406                   (accept-process-output gds-debug-server))
407                 (setq gds-local-var-cache
408                       (cons (cons varname gds-last-eval-result)
409                             gds-local-var-cache))
410                 gds-last-eval-result))))))))
411
412 (defun gds-source-file-name-to-buffer (filename)
413   ;; See if filename begins with gds-emacs-buffer-port-name-prefix.
414   (if (string-match (concat "^"
415                             (regexp-quote gds-emacs-buffer-port-name-prefix))
416                     filename)
417       ;; It does, so get the named buffer.
418       (get-buffer (substring filename (match-end 0)))
419     ;; It doesn't, so treat as a file name.
420     (and (file-readable-p filename)
421          (find-file-noselect filename))))
422
423 (defun gds-select-stack-frame (&optional frame-index)
424   (interactive)
425   (let ((new-frame-index (or frame-index
426                              (gds-current-line-frame-index))))
427     (or (and (>= new-frame-index 0)
428              (< new-frame-index (length (car gds-stack))))
429         (error (if frame-index
430                    "No more frames in this direction"
431                  "No frame here")))
432     (gds-unshow-selected-frame)
433     (setq gds-selected-frame-index new-frame-index)
434     (gds-show-selected-frame)))
435
436 (defun gds-up ()
437   (interactive)
438   (gds-select-stack-frame (- gds-selected-frame-index 1)))
439
440 (defun gds-down ()
441   (interactive)
442   (gds-select-stack-frame (+ gds-selected-frame-index 1)))
443
444 (defun gds-current-line-frame-index ()
445   (- (count-lines (point-min)
446                   (save-excursion
447                     (beginning-of-line)
448                     (point)))
449      1))
450
451 (defun gds-display-buffers ()
452   (let ((buf (current-buffer)))
453     ;; If there's already a window showing the buffer, use it.
454     (let ((window (get-buffer-window buf t)))
455       (if window
456           (progn
457             (make-frame-visible (window-frame window))
458             (select-window window))
459         (switch-to-buffer buf)
460         (setq window (get-buffer-window buf t))))
461     ;; If there is an associated source buffer, display it as well.
462     (if (and gds-frame-source-overlay
463              (overlay-end gds-frame-source-overlay)
464              (> (overlay-end gds-frame-source-overlay) 1))
465         (progn
466           (delete-other-windows)
467           (let ((window (display-buffer
468                          (overlay-buffer gds-frame-source-overlay))))
469             (set-window-point window
470                               (overlay-start gds-frame-source-overlay)))))))
471
472
473 ;;;; Debugger commands.
474
475 ;; Typically but not necessarily used from the `stack' view.
476
477 (defun gds-send-tweaking ()
478   (if (stringp gds-tweaking)
479       (gds-send (format "tweak %S" gds-tweaking) gds-client)))
480
481 (defun gds-go ()
482   (interactive)
483   (gds-send-tweaking)
484   (gds-send "continue" gds-client)
485   (gds-unshow-selected-frame)
486   (gds-undisplay-buffer))
487
488 (defvar gds-last-eval-result t)
489
490 (defun gds-evaluate (expr)
491   (interactive "sEvaluate variable or expression: ")
492   (gds-send (format "evaluate %d %s"
493                     gds-selected-frame-index
494                     (prin1-to-string expr))
495             gds-client))
496
497 (defun gds-frame-info ()
498   (interactive)
499   (gds-send (format "info-frame %d" gds-selected-frame-index)
500             gds-client))
501
502 (defun gds-frame-args ()
503   (interactive)
504   (gds-send (format "info-args %d" gds-selected-frame-index)
505             gds-client))
506
507 (defun gds-proc-source ()
508   (interactive)
509   (gds-send (format "proc-source %d" gds-selected-frame-index)
510             gds-client))
511
512 (defun gds-traps-here ()
513   (interactive)
514   (gds-send "traps-here" gds-client))
515
516 (defun gds-step-into ()
517   (interactive)
518   (gds-send-tweaking)
519   (gds-send (format "step-into %d" gds-selected-frame-index)
520             gds-client)
521   (gds-unshow-selected-frame)
522   (gds-undisplay-buffer))
523
524 (defun gds-step-over ()
525   (interactive)
526   (gds-send-tweaking)
527   (gds-send (format "step-over %d" gds-selected-frame-index)
528             gds-client)
529   (gds-unshow-selected-frame)
530   (gds-undisplay-buffer))
531
532 (defun gds-step-file ()
533   (interactive)
534   (gds-send-tweaking)
535   (gds-send (format "step-file %d" gds-selected-frame-index)
536             gds-client)
537   (gds-unshow-selected-frame)
538   (gds-undisplay-buffer))
539
540
541
542
543 ;;;; Guile Interaction mode keymap and menu items.
544
545 (defvar gds-mode-map (make-sparse-keymap))
546 (define-key gds-mode-map "c" (function gds-go))
547 (define-key gds-mode-map "g" (function gds-go))
548 (define-key gds-mode-map "q" (function gds-go))
549 (define-key gds-mode-map "e" (function gds-evaluate))
550 (define-key gds-mode-map "I" (function gds-frame-info))
551 (define-key gds-mode-map "A" (function gds-frame-args))
552 (define-key gds-mode-map "S" (function gds-proc-source))
553 (define-key gds-mode-map "T" (function gds-traps-here))
554 (define-key gds-mode-map "\C-m" (function gds-select-stack-frame))
555 (define-key gds-mode-map "u" (function gds-up))
556 (define-key gds-mode-map [up] (function gds-up))
557 (define-key gds-mode-map "\C-p" (function gds-up))
558 (define-key gds-mode-map "d" (function gds-down))
559 (define-key gds-mode-map [down] (function gds-down))
560 (define-key gds-mode-map "\C-n" (function gds-down))
561 (define-key gds-mode-map " " (function gds-step-file))
562 (define-key gds-mode-map "i" (function gds-step-into))
563 (define-key gds-mode-map "o" (function gds-step-over))
564 (define-key gds-mode-map "t" (function gds-tweak))
565
566
567 (defvar gds-menu nil
568   "Global menu for GDS commands.")
569 (if nil;gds-menu
570     nil
571   (setq gds-menu (make-sparse-keymap "Guile-Debug"))
572   (define-key gds-menu [traps-here]
573     '(menu-item "Show Traps Here" gds-traps-here))
574   (define-key gds-menu [proc-source]
575     '(menu-item "Show Procedure Source" gds-proc-source))
576   (define-key gds-menu [frame-args]
577     '(menu-item "Show Frame Args" gds-frame-args))
578   (define-key gds-menu [frame-info]
579     '(menu-item "Show Frame Info" gds-frame-info))
580   (define-key gds-menu [separator-1]
581     '("--"))
582   (define-key gds-menu [evaluate]
583     '(menu-item "Evaluate..." gds-evaluate))
584   (define-key gds-menu [separator-2]
585     '("--"))
586   (define-key gds-menu [down]
587     '(menu-item "Move Down A Frame" gds-down))
588   (define-key gds-menu [up]
589     '(menu-item "Move Up A Frame" gds-up))
590   (define-key gds-menu [separator-3]
591     '("--"))
592   (define-key gds-menu [step-over]
593     '(menu-item "Step Over Current Expression" gds-step-over))
594   (define-key gds-menu [step-into]
595     '(menu-item "Step Into Current Expression" gds-step-into))
596   (define-key gds-menu [step-file]
597     '(menu-item "Step Through Current Source File" gds-step-file))
598   (define-key gds-menu [separator-4]
599     '("--"))
600   (define-key gds-menu [go]
601     '(menu-item "Go  [continue execution]" gds-go))
602   (define-key gds-mode-map [menu-bar gds-debug]
603     (cons "Guile-Debug" gds-menu)))
604
605
606 ;;;; Autostarting the GDS server.
607
608 (defcustom gds-autorun-debug-server t
609   "Whether to automatically run the GDS server when `gds.el' is loaded."
610   :type 'boolean
611   :group 'gds)
612
613 (defcustom gds-server-socket-type 'tcp
614   "What kind of socket the GDS server should listen on."
615   :group 'gds
616   :type '(choice (const :tag "TCP" tcp)
617                  (const :tag "Unix" unix)))
618
619 ;;;; If requested, autostart the server after loading.
620
621 (if (and gds-autorun-debug-server
622          (not gds-debug-server))
623     (gds-run-debug-server))
624
625 ;;;; The end!
626
627 (provide 'gds)
628
629 ;;; gds.el ends here.