/[guile]/guile/guile-core/emacs/gds.el
ViewVC logotype

Diff of /guile/guile-core/emacs/gds.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by ossau, Sat Oct 4 20:03:51 2003 UTC revision 1.3 by ossau, Mon Oct 6 20:33:01 2003 UTC
# Line 1  Line 1 
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  ;;;;  ;;;;
# Line 23  Line 23 
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!).
# Line 35  Line 36 
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    
# Line 49  Line 50 
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)
# Line 72  Line 74 
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)))
# Line 125  Line 129 
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
# Line 172  Line 176 
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))))
# Line 287  Line 291 
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)))
# Line 315  Line 337 
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))
# Line 363  Line 385 
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 "^\\("
# Line 461  Line 483 
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
# Line 472  Line 494 
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
# Line 751  not of primary interest when debugging a Line 773  not of primary interest when debugging a
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.

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26