1 |
;;; gds.el -- Guile debugging frontend |
;;; gds.el -- frontend for Guile development in Emacs |
2 |
|
|
3 |
;;;; Copyright (C) 2003 Free Software Foundation, Inc. |
;;;; Copyright (C) 2003 Free Software Foundation, Inc. |
4 |
;;;; |
;;;; |
23 |
|
|
24 |
(require 'widget) |
(require 'widget) |
25 |
(require 'wid-edit) |
(require 'wid-edit) |
26 |
|
(require 'scheme) |
27 |
|
|
28 |
|
|
29 |
;;;; Debugging (of this code!). |
;;;; Debugging (of this code!). |
36 |
;;;; Customization group setup. |
;;;; Customization group setup. |
37 |
|
|
38 |
(defgroup gds nil |
(defgroup gds nil |
39 |
"Customization options for Guile Debugging." |
"Customization options for Guile Emacs frontend." |
40 |
:group 'scheme) |
:group 'scheme) |
41 |
|
|
42 |
|
|
50 |
;; the buffer position of the start of the next unread form. |
;; the buffer position of the start of the next unread form. |
51 |
(defvar gds-read-cursor nil) |
(defvar gds-read-cursor nil) |
52 |
|
|
|
;; Start (or restart) the subprocess. |
|
53 |
(defun gds-start () |
(defun gds-start () |
54 |
|
"Start (or restart, if already running) the GDS subprocess." |
55 |
|
(interactive) |
56 |
(if gds-process (gds-shutdown)) |
(if gds-process (gds-shutdown)) |
57 |
(with-current-buffer (get-buffer-create "*GDS Process*") |
(with-current-buffer (get-buffer-create "*GDS Process*") |
58 |
(erase-buffer) |
(erase-buffer) |
74 |
|
|
75 |
;; Shutdown the subprocess and cleanup all associated data. |
;; Shutdown the subprocess and cleanup all associated data. |
76 |
(defun gds-shutdown () |
(defun gds-shutdown () |
77 |
|
"Shut down the GDS subprocess." |
78 |
|
(interactive) |
79 |
;; Do cleanup for all clients. |
;; Do cleanup for all clients. |
80 |
(while gds-names |
(while gds-names |
81 |
(gds-client-cleanup (caar gds-names))) |
(gds-client-cleanup (caar gds-names))) |
129 |
;; At any moment one Guile application has the focus of the frontend |
;; At any moment one Guile application has the focus of the frontend |
130 |
;; code. `gds-displayed-client' holds the port number of that client. |
;; code. `gds-displayed-client' holds the port number of that client. |
131 |
;; If there are no Guile applications wanting the focus - that is, |
;; If there are no Guile applications wanting the focus - that is, |
132 |
;; ready for debugging instructions - `gds-displayed-client' is nil. |
;; ready for instructions - `gds-displayed-client' is nil. |
133 |
(defvar gds-displayed-client nil) |
(defvar gds-displayed-client nil) |
134 |
|
|
135 |
;; The list of other Guile applications waiting for focus, referenced |
;; The list of other Guile applications waiting for focus, referenced |
176 |
(defun gds-focus-yield () |
(defun gds-focus-yield () |
177 |
(interactive) |
(interactive) |
178 |
(if (and (null gds-waiting) |
(if (and (null gds-waiting) |
179 |
(y-or-n-p "No other clients waiting - bury *Guile Debug* buffer? ")) |
(y-or-n-p "No other clients waiting - bury *Guile* buffer? ")) |
180 |
(bury-buffer) |
(bury-buffer) |
181 |
(or (memq gds-displayed-client gds-waiting) |
(or (memq gds-displayed-client gds-waiting) |
182 |
(setq gds-waiting (append gds-waiting (list gds-displayed-client)))) |
(setq gds-waiting (append gds-waiting (list gds-displayed-client)))) |
291 |
;; (closed) - Client has gone away. |
;; (closed) - Client has gone away. |
292 |
(gds-client-cleanup client)) |
(gds-client-cleanup client)) |
293 |
|
|
294 |
|
((eq proc 'eval-results) |
295 |
|
;; (eval-results ...) - Results of evaluation. |
296 |
|
(gds-display-results client (cddr form))) |
297 |
|
|
298 |
)))))) |
)))))) |
299 |
|
|
300 |
|
(defun gds-display-results (client results) |
301 |
|
(let ((buf (get-buffer-create "*Guile Results*"))) |
302 |
|
(save-excursion |
303 |
|
(set-buffer buf) |
304 |
|
(erase-buffer) |
305 |
|
(while results |
306 |
|
(insert (car results)) |
307 |
|
(mapcar (function (lambda (value) |
308 |
|
(insert " => " value "\n"))) |
309 |
|
(cadr results)) |
310 |
|
(insert "\n") |
311 |
|
(setq results (cddr results)))) |
312 |
|
(pop-to-buffer buf))) |
313 |
|
|
314 |
;; Store latest status, stack or module list for the specified client. |
;; Store latest status, stack or module list for the specified client. |
315 |
(defmacro gds-set (alist client val) |
(defmacro gds-set (alist client val) |
316 |
`(let ((existing (assq ,client ,alist))) |
`(let ((existing (assq ,client ,alist))) |
337 |
|
|
338 |
(define-derived-mode gds-mode |
(define-derived-mode gds-mode |
339 |
fundamental-mode |
fundamental-mode |
340 |
"Guile Debugging" |
"Guile" |
341 |
"Major mode for Guile debugging information buffers.") |
"Major mode for Guile information buffers.") |
342 |
|
|
343 |
(defun gds-set-client-buffer (&optional client) |
(defun gds-set-client-buffer (&optional client) |
344 |
(if (and gds-client-buffer |
(if (and gds-client-buffer |
345 |
(buffer-live-p gds-client-buffer)) |
(buffer-live-p gds-client-buffer)) |
346 |
(set-buffer gds-client-buffer) |
(set-buffer gds-client-buffer) |
347 |
(setq gds-client-buffer (get-buffer-create "*Guile Debug*")) |
(setq gds-client-buffer (get-buffer-create "*Guile*")) |
348 |
(set-buffer gds-client-buffer) |
(set-buffer gds-client-buffer) |
349 |
(gds-mode)) |
(gds-mode)) |
350 |
;; Rename to something we don't want first. Otherwise, if the |
;; Rename to something we don't want first. Otherwise, if the |
351 |
;; buffer is already correctly named, we get a confusing change |
;; buffer is already correctly named, we get a confusing change |
352 |
;; from, say, `*Guile Debug: REPL*' to `*Guile Debug: REPL*<2>'. |
;; from, say, `*Guile: REPL*' to `*Guile: REPL*<2>'. |
353 |
(rename-buffer "*Guile Debug Fake Buffer Name*" t) |
(rename-buffer "*Guile Fake Buffer Name*" t) |
354 |
(rename-buffer (if client |
(rename-buffer (if client |
355 |
(concat "*Guile Debug: " |
(concat "*Guile: " |
356 |
(cdr (assq client gds-names)) |
(cdr (assq client gds-names)) |
357 |
"*") |
"*") |
358 |
"*Guile Debug*") |
"*Guile*") |
359 |
t) ; Rename uniquely if needed, |
t) ; Rename uniquely if needed, |
360 |
; although it shouldn't be. |
; although it shouldn't be. |
361 |
(force-mode-line-update t)) |
(force-mode-line-update t)) |
385 |
(defvar gds-displayed-stack nil) |
(defvar gds-displayed-stack nil) |
386 |
(defvar gds-displayed-modules nil) |
(defvar gds-displayed-modules nil) |
387 |
|
|
388 |
;; Types of display areas in the *Guile Debug* buffer. |
;; Types of display areas in the *Guile* buffer. |
389 |
(defvar gds-display-types '("Status" "Stack" "Modules")) |
(defvar gds-display-types '("Status" "Stack" "Modules")) |
390 |
(defvar gds-display-type-regexp |
(defvar gds-display-type-regexp |
391 |
(concat "^\\(" |
(concat "^\\(" |
483 |
(setq gds-displayed-client client) |
(setq gds-displayed-client client) |
484 |
(dmessage "consider display") |
(dmessage "consider display") |
485 |
(if (eq (window-buffer (selected-window)) gds-client-buffer) |
(if (eq (window-buffer (selected-window)) gds-client-buffer) |
486 |
;; *Guile Debug* buffer already selected. |
;; *Guile* buffer already selected. |
487 |
(gds-display-buffers) |
(gds-display-buffers) |
488 |
(dmessage "Running GDS timer") |
(dmessage "Running GDS timer") |
489 |
(setq gds-timer |
(setq gds-timer |
494 |
(gds-display-buffers)))))) |
(gds-display-buffers)))))) |
495 |
|
|
496 |
(defun gds-display-buffers () |
(defun gds-display-buffers () |
497 |
;; If there's already a window showing the *Guile Debug* buffer, use |
;; If there's already a window showing the *Guile* buffer, use |
498 |
;; it. |
;; it. |
499 |
(let ((window (get-buffer-window gds-client-buffer t))) |
(let ((window (get-buffer-window gds-client-buffer t))) |
500 |
(if window |
(if window |
773 |
|
|
774 |
;;;; Evaluating code. |
;;;; Evaluating code. |
775 |
|
|
776 |
;; The Scheme process to which code is sent is determined in the usual |
;; The following commands send code for evaluation through the GDS TCP |
777 |
;; cmuscheme.el way by the `scheme-buffer' variable (q.v.). |
;; connection, receive the result and any output generated through the |
778 |
;; Customizations to the way that code is sent, for example pro- and |
;; same connection, and display the result and output to the user. |
779 |
;; postlogs to set up and restore evaluation context correctly in the |
;; |
780 |
;; Scheme process, are achieved (elsewhere than this file) by advising |
;; Where there are multiple Guile applications known to GDS, GDS by |
781 |
;; `scheme-send-region' accordingly. |
;; default sends code to the one that holds the debugging focus, |
782 |
|
;; i.e. `gds-displayed-client'. Where no application has the focus, |
783 |
|
;; or the command is invoked `C-u', GDS asks the user which |
784 |
|
;; application is intended. |
785 |
|
|
786 |
|
(defun gds-read-client () |
787 |
|
(let* ((def (if gds-displayed-client |
788 |
|
(cdr (assq gds-displayed-client gds-names)))) |
789 |
|
(prompt (if def |
790 |
|
(concat "Application for eval (default " |
791 |
|
def |
792 |
|
"): ") |
793 |
|
"Application for eval: ")) |
794 |
|
(name |
795 |
|
(completing-read prompt |
796 |
|
(mapcar (function cdr) gds-names) |
797 |
|
nil t nil nil |
798 |
|
def))) |
799 |
|
(let (client (names gds-names)) |
800 |
|
(while (and names (not client)) |
801 |
|
(if (string-equal (cadar names) name) |
802 |
|
(setq client (caar names))) |
803 |
|
(setq names (cdr names)))))) |
804 |
|
|
805 |
|
(defun gds-choose-client (client) |
806 |
|
(or ;; If client is an integer, it is the port number of the |
807 |
|
;; intended client. |
808 |
|
(if (integerp client) client) |
809 |
|
;; Any other non-nil value indicates invocation with a prefix |
810 |
|
;; arg, which forces asking the user which application is |
811 |
|
;; intended. |
812 |
|
(if client (gds-read-client)) |
813 |
|
;; If ask not forced, and there is a client with the focus, |
814 |
|
;; default to that one. |
815 |
|
gds-displayed-client |
816 |
|
;; Last resort - ask the user. |
817 |
|
(gds-read-client) |
818 |
|
;; Signal an error. |
819 |
|
(error "No application chosen."))) |
820 |
|
|
821 |
|
(defcustom gds-default-module-name '(guile-user) |
822 |
|
"Name of the default module for GDS code evaluation, as list of symbols. |
823 |
|
This module is used when there is no `define-module' form in the |
824 |
|
buffer preceding the code to be evaluated." |
825 |
|
:type 'sexp |
826 |
|
:group 'gds) |
827 |
|
|
828 |
|
(defun gds-module-name (start end) |
829 |
|
"Determine and return the name of the module that governs the |
830 |
|
specified region. The module name is returned as a list of symbols." |
831 |
|
(interactive "r") ; why not? |
832 |
|
(save-excursion |
833 |
|
(goto-char start) |
834 |
|
(let (module-name) |
835 |
|
(while (and (not module-name) |
836 |
|
(beginning-of-defun-raw 1)) |
837 |
|
(if (looking-at "(define-module ") |
838 |
|
(setq module-name |
839 |
|
(progn |
840 |
|
(goto-char (match-end 0)) |
841 |
|
(read (current-buffer)))))) |
842 |
|
module-name))) |
843 |
|
|
844 |
|
(defun gds-port-name (start end) |
845 |
|
"Return port name for the specified region of the current buffer. |
846 |
|
The name will be used by Guile as the port name when evaluating that |
847 |
|
region's code." |
848 |
|
(or (buffer-file-name) |
849 |
|
(concat "Emacs buffer: " (buffer-name)))) |
850 |
|
|
851 |
|
(defun gds-eval-region (start end &optional client) |
852 |
|
"Evaluate the current region." |
853 |
|
(interactive "r\nP") |
854 |
|
(setq client (gds-choose-client client)) |
855 |
|
(let ((module (gds-module-name start end)) |
856 |
|
(port-name (gds-port-name start end)) |
857 |
|
line column) |
858 |
|
(save-excursion |
859 |
|
(goto-char start) |
860 |
|
(setq column (current-column)) ; 0-based |
861 |
|
(beginning-of-line) |
862 |
|
(setq line (count-lines (point-min) (point)))) ; 0-based |
863 |
|
(gds-send (format "(%S eval %s %S %d %d %S)\n" |
864 |
|
client |
865 |
|
(if module (prin1-to-string module) "#f") |
866 |
|
port-name line column |
867 |
|
(buffer-substring-no-properties start end))))) |
868 |
|
|
869 |
|
(defun gds-eval-expression (expr &optional client) |
870 |
|
"Evaluate the supplied EXPR (a string)." |
871 |
|
(interactive "sEvaluate expression: \nP") |
872 |
|
(setq client (gds-choose-client client)) |
873 |
|
(gds-send (format "(%S eval #f \"Emacs expression\" 0 0 %S)\n" |
874 |
|
client expr))) |
875 |
|
|
876 |
|
(defun gds-eval-defun (&optional client) |
877 |
|
"Evaluate the defun (top-level form) at point." |
878 |
|
(interactive "P") |
879 |
|
(save-excursion |
880 |
|
(end-of-defun) |
881 |
|
(let ((end (point))) |
882 |
|
(beginning-of-defun) |
883 |
|
(gds-eval-region (point) end client)))) |
884 |
|
|
885 |
|
(defun gds-eval-last-sexp (&optional client) |
886 |
|
"Evaluate the sexp before point." |
887 |
|
(interactive "P") |
888 |
|
(gds-eval-region (save-excursion (backward-sexp) (point)) (point) client)) |
889 |
|
|
890 |
|
(defcustom gds-source-modes '(scheme-mode) |
891 |
|
"*Used to determine if a buffer contains Scheme source code. |
892 |
|
If it's loaded into a buffer that is in one of these major modes, it's |
893 |
|
considered a scheme source file by `gds-load-file'." |
894 |
|
:type '(repeat function) |
895 |
|
:group 'gds) |
896 |
|
|
897 |
|
(defvar gds-prev-load-dir/file nil |
898 |
|
"Holds the last (directory . file) pair passed to `gds-load-file'. |
899 |
|
Used for determining the default for the next `gds-load-file'.") |
900 |
|
|
901 |
|
(defun gds-load-file (file-name &optional client) |
902 |
|
"Load a Scheme file into the inferior Scheme process." |
903 |
|
(interactive (list (car (comint-get-source "Load Scheme file: " |
904 |
|
gds-prev-load-dir/file |
905 |
|
gds-source-modes t)) |
906 |
|
; T because LOAD needs an |
907 |
|
; exact name |
908 |
|
current-prefix-arg)) |
909 |
|
(comint-check-source file-name) ; Check to see if buffer needs saved. |
910 |
|
(setq gds-prev-load-dir/file (cons (file-name-directory file-name) |
911 |
|
(file-name-nondirectory file-name))) |
912 |
|
(setq client (gds-choose-client client)) |
913 |
|
(gds-send (format "(%S load %S)\n" client file-name))) |
914 |
|
|
915 |
|
;; Install the process communication commands in the scheme-mode keymap. |
916 |
|
(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention |
917 |
|
(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention |
918 |
|
(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-defun) |
919 |
|
(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) |
920 |
|
(define-key scheme-mode-map "\C-c\C-l" 'gds-load-file) |
921 |
|
|
922 |
|
|
923 |
|
;;;; Menu bar entries. |
924 |
|
|
925 |
|
(defvar gds-debug-menu nil |
926 |
|
"GDS debugging menu.") |
927 |
|
(if gds-debug-menu |
928 |
|
nil |
929 |
|
(setq gds-debug-menu (make-sparse-keymap "Debug")) |
930 |
|
(define-key gds-debug-menu [go] |
931 |
|
'(menu-item "Go" gds-go)) |
932 |
|
(define-key gds-debug-menu [trace-finish] |
933 |
|
'(menu-item "Trace This Frame" gds-trace-finish)) |
934 |
|
(define-key gds-debug-menu [step-out] |
935 |
|
'(menu-item "Finish This Frame" gds-step-out)) |
936 |
|
(define-key gds-debug-menu [next] |
937 |
|
'(menu-item "Next" gds-next)) |
938 |
|
(define-key gds-debug-menu [step-in] |
939 |
|
'(menu-item "Single Step" gds-step-in)) |
940 |
|
(define-key gds-debug-menu [eval] |
941 |
|
'(menu-item "Eval In This Frame..." gds-evaluate))) |
942 |
|
|
943 |
|
(defvar gds-eval-menu nil |
944 |
|
"GDS evaluation menu.") |
945 |
|
(if gds-eval-menu |
946 |
|
nil |
947 |
|
(setq gds-eval-menu (make-sparse-keymap "Evaluate")) |
948 |
|
(define-key gds-eval-menu [load-file] |
949 |
|
'(menu-item "Load Scheme File" gds-load-file)) |
950 |
|
(define-key gds-eval-menu [defun] |
951 |
|
'(menu-item "Defun At Point" gds-eval-defun)) |
952 |
|
(define-key gds-eval-menu [region] |
953 |
|
'(menu-item "Region" gds-eval-region)) |
954 |
|
(define-key gds-eval-menu [last-sexp] |
955 |
|
'(menu-item "Sexp Before Point" gds-eval-last-sexp)) |
956 |
|
(define-key gds-eval-menu [expr] |
957 |
|
'(menu-item "Expression..." gds-eval-expression))) |
958 |
|
|
959 |
|
(defvar gds-help-menu nil |
960 |
|
"GDS help menu.") |
961 |
|
(if gds-help-menu |
962 |
|
nil |
963 |
|
(setq gds-help-menu (make-sparse-keymap "Help")) |
964 |
|
(define-key gds-help-menu [apropos] |
965 |
|
'(menu-item "Apropos..." gds-apropos)) |
966 |
|
(define-key gds-help-menu [sym-here] |
967 |
|
'(menu-item "Symbol At Point" gds-help-symbol-here)) |
968 |
|
(define-key gds-help-menu [sym] |
969 |
|
'(menu-item "Symbol..." gds-help-symbol))) |
970 |
|
|
971 |
|
(defvar gds-advanced-menu nil |
972 |
|
"Menu of rarely needed GDS operations.") |
973 |
|
(if gds-advanced-menu |
974 |
|
nil |
975 |
|
(setq gds-advanced-menu (make-sparse-keymap "Advanced")) |
976 |
|
(define-key gds-advanced-menu [restart-gds] |
977 |
|
'(menu-item "Restart IDE" gds-start :enable gds-process)) |
978 |
|
(define-key gds-advanced-menu [kill-gds] |
979 |
|
'(menu-item "Shutdown IDE" gds-shutdown :enable gds-process)) |
980 |
|
(define-key gds-advanced-menu [start-gds] |
981 |
|
'(menu-item "Start IDE" gds-start :enable (not gds-process)))) |
982 |
|
|
983 |
|
(defvar gds-menu nil |
984 |
|
"Global menu for GDS commands.") |
985 |
|
(if gds-menu |
986 |
|
nil |
987 |
|
(setq gds-menu (make-sparse-keymap "Guile")) |
988 |
|
(define-key gds-menu [advanced] |
989 |
|
(cons "Advanced" gds-advanced-menu)) |
990 |
|
(define-key gds-menu [separator-1] |
991 |
|
'("--")) |
992 |
|
(define-key gds-menu [help] |
993 |
|
`(menu-item "Help" ,gds-help-menu :enable gds-names)) |
994 |
|
(define-key gds-menu [eval] |
995 |
|
`(menu-item "Evaluate" ,gds-eval-menu :enable gds-names)) |
996 |
|
(define-key gds-menu [debug] |
997 |
|
`(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client |
998 |
|
(gds-client-waiting)))) |
999 |
|
(setq menu-bar-final-items |
1000 |
|
(cons 'guile menu-bar-final-items)) |
1001 |
|
(define-key global-map [menu-bar guile] |
1002 |
|
(cons "Guile" gds-menu))) |
1003 |
|
|
1004 |
|
;;;; Autostarting the GDS server. |
1005 |
|
|
1006 |
|
(defcustom gds-autostart-server t |
1007 |
|
"Whether to automatically start the GDS server when `gds.el' is loaded." |
1008 |
|
:type 'boolean |
1009 |
|
:group 'gds) |
1010 |
|
|
1011 |
|
(if (and gds-autostart-server |
1012 |
|
(not gds-process)) |
1013 |
|
(gds-start)) |
1014 |
|
|
1015 |
|
(provide 'gds) |
1016 |
|
|
1017 |
|
;;; gds.el ends here. |