diff options
| -rw-r--r-- | emacs/ChangeLog | 4 | ||||
| -rw-r--r-- | emacs/gds.el | 300 | ||||
| -rw-r--r-- | ice-9/ChangeLog | 6 | ||||
| -rw-r--r-- | ice-9/debugger/ui-client.scm | 45 |
4 files changed, 330 insertions, 25 deletions
diff --git a/emacs/ChangeLog b/emacs/ChangeLog index efa004269..4d7b0bf53 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,7 +1,3 @@ -2003-10-04 Neil Jerram <neil@ossau.uklinux.net> - - * gds.el (gds-handle-input): Handle `ready-for-input' status. - 2003-08-20 Neil Jerram <neil@ossau.uklinux.net> * guileint: New subdirectory. diff --git a/emacs/gds.el b/emacs/gds.el index 3b5923f03..c9d53575f 100644 --- a/emacs/gds.el +++ b/emacs/gds.el @@ -1,4 +1,4 @@ -;;; gds.el -- Guile debugging frontend +;;; gds.el -- frontend for Guile development in Emacs ;;;; Copyright (C) 2003 Free Software Foundation, Inc. ;;;; @@ -23,6 +23,7 @@ (require 'widget) (require 'wid-edit) +(require 'scheme) ;;;; Debugging (of this code!). @@ -35,7 +36,7 @@ ;;;; Customization group setup. (defgroup gds nil - "Customization options for Guile Debugging." + "Customization options for Guile Emacs frontend." :group 'scheme) @@ -49,8 +50,9 @@ ;; the buffer position of the start of the next unread form. (defvar gds-read-cursor nil) -;; Start (or restart) the subprocess. (defun gds-start () + "Start (or restart, if already running) the GDS subprocess." + (interactive) (if gds-process (gds-shutdown)) (with-current-buffer (get-buffer-create "*GDS Process*") (erase-buffer) @@ -72,6 +74,8 @@ ;; Shutdown the subprocess and cleanup all associated data. (defun gds-shutdown () + "Shut down the GDS subprocess." + (interactive) ;; Do cleanup for all clients. (while gds-names (gds-client-cleanup (caar gds-names))) @@ -125,7 +129,7 @@ ;; At any moment one Guile application has the focus of the frontend ;; code. `gds-displayed-client' holds the port number of that client. ;; If there are no Guile applications wanting the focus - that is, -;; ready for debugging instructions - `gds-displayed-client' is nil. +;; ready for instructions - `gds-displayed-client' is nil. (defvar gds-displayed-client nil) ;; The list of other Guile applications waiting for focus, referenced @@ -172,7 +176,7 @@ (defun gds-focus-yield () (interactive) (if (and (null gds-waiting) - (y-or-n-p "No other clients waiting - bury *Guile Debug* buffer? ")) + (y-or-n-p "No other clients waiting - bury *Guile* buffer? ")) (bury-buffer) (or (memq gds-displayed-client gds-waiting) (setq gds-waiting (append gds-waiting (list gds-displayed-client)))) @@ -287,8 +291,26 @@ ;; (closed) - Client has gone away. (gds-client-cleanup client)) + ((eq proc 'eval-results) + ;; (eval-results ...) - Results of evaluation. + (gds-display-results client (cddr form))) + )))))) +(defun gds-display-results (client results) + (let ((buf (get-buffer-create "*Guile Results*"))) + (save-excursion + (set-buffer buf) + (erase-buffer) + (while results + (insert (car results)) + (mapcar (function (lambda (value) + (insert " => " value "\n"))) + (cadr results)) + (insert "\n") + (setq results (cddr results)))) + (pop-to-buffer buf))) + ;; Store latest status, stack or module list for the specified client. (defmacro gds-set (alist client val) `(let ((existing (assq ,client ,alist))) @@ -315,25 +337,25 @@ (define-derived-mode gds-mode fundamental-mode - "Guile Debugging" - "Major mode for Guile debugging information buffers.") + "Guile" + "Major mode for Guile information buffers.") (defun gds-set-client-buffer (&optional client) (if (and gds-client-buffer (buffer-live-p gds-client-buffer)) (set-buffer gds-client-buffer) - (setq gds-client-buffer (get-buffer-create "*Guile Debug*")) + (setq gds-client-buffer (get-buffer-create "*Guile*")) (set-buffer gds-client-buffer) (gds-mode)) ;; Rename to something we don't want first. Otherwise, if the ;; buffer is already correctly named, we get a confusing change - ;; from, say, `*Guile Debug: REPL*' to `*Guile Debug: REPL*<2>'. - (rename-buffer "*Guile Debug Fake Buffer Name*" t) + ;; from, say, `*Guile: REPL*' to `*Guile: REPL*<2>'. + (rename-buffer "*Guile Fake Buffer Name*" t) (rename-buffer (if client - (concat "*Guile Debug: " + (concat "*Guile: " (cdr (assq client gds-names)) "*") - "*Guile Debug*") + "*Guile*") t) ; Rename uniquely if needed, ; although it shouldn't be. (force-mode-line-update t)) @@ -363,7 +385,7 @@ (defvar gds-displayed-stack nil) (defvar gds-displayed-modules nil) -;; Types of display areas in the *Guile Debug* buffer. +;; Types of display areas in the *Guile* buffer. (defvar gds-display-types '("Status" "Stack" "Modules")) (defvar gds-display-type-regexp (concat "^\\(" @@ -461,7 +483,7 @@ (setq gds-displayed-client client) (dmessage "consider display") (if (eq (window-buffer (selected-window)) gds-client-buffer) - ;; *Guile Debug* buffer already selected. + ;; *Guile* buffer already selected. (gds-display-buffers) (dmessage "Running GDS timer") (setq gds-timer @@ -472,7 +494,7 @@ (gds-display-buffers)))))) (defun gds-display-buffers () - ;; If there's already a window showing the *Guile Debug* buffer, use + ;; If there's already a window showing the *Guile* buffer, use ;; it. (let ((window (get-buffer-window gds-client-buffer t))) (if window @@ -751,9 +773,245 @@ not of primary interest when debugging application code." ;;;; Evaluating code. -;; The Scheme process to which code is sent is determined in the usual -;; cmuscheme.el way by the `scheme-buffer' variable (q.v.). -;; Customizations to the way that code is sent, for example pro- and -;; postlogs to set up and restore evaluation context correctly in the -;; Scheme process, are achieved (elsewhere than this file) by advising -;; `scheme-send-region' accordingly. +;; The following commands send code for evaluation through the GDS TCP +;; connection, receive the result and any output generated through the +;; same connection, and display the result and output to the user. +;; +;; Where there are multiple Guile applications known to GDS, GDS by +;; default sends code to the one that holds the debugging focus, +;; i.e. `gds-displayed-client'. Where no application has the focus, +;; or the command is invoked `C-u', GDS asks the user which +;; application is intended. + +(defun gds-read-client () + (let* ((def (if gds-displayed-client + (cdr (assq gds-displayed-client gds-names)))) + (prompt (if def + (concat "Application for eval (default " + def + "): ") + "Application for eval: ")) + (name + (completing-read prompt + (mapcar (function cdr) gds-names) + nil t nil nil + def))) + (let (client (names gds-names)) + (while (and names (not client)) + (if (string-equal (cadar names) name) + (setq client (caar names))) + (setq names (cdr names)))))) + +(defun gds-choose-client (client) + (or ;; If client is an integer, it is the port number of the + ;; intended client. + (if (integerp client) client) + ;; Any other non-nil value indicates invocation with a prefix + ;; arg, which forces asking the user which application is + ;; intended. + (if client (gds-read-client)) + ;; If ask not forced, and there is a client with the focus, + ;; default to that one. + gds-displayed-client + ;; Last resort - ask the user. + (gds-read-client) + ;; Signal an error. + (error "No application chosen."))) + +(defcustom gds-default-module-name '(guile-user) + "Name of the default module for GDS code evaluation, as list of symbols. +This module is used when there is no `define-module' form in the +buffer preceding the code to be evaluated." + :type 'sexp + :group 'gds) + +(defun gds-module-name (start end) + "Determine and return the name of the module that governs the +specified region. The module name is returned as a list of symbols." + (interactive "r") ; why not? + (save-excursion + (goto-char start) + (let (module-name) + (while (and (not module-name) + (beginning-of-defun-raw 1)) + (if (looking-at "(define-module ") + (setq module-name + (progn + (goto-char (match-end 0)) + (read (current-buffer)))))) + module-name))) + +(defun gds-port-name (start end) + "Return port name for the specified region of the current buffer. +The name will be used by Guile as the port name when evaluating that +region's code." + (or (buffer-file-name) + (concat "Emacs buffer: " (buffer-name)))) + +(defun gds-eval-region (start end &optional client) + "Evaluate the current region." + (interactive "r\nP") + (setq client (gds-choose-client client)) + (let ((module (gds-module-name start end)) + (port-name (gds-port-name start end)) + line column) + (save-excursion + (goto-char start) + (setq column (current-column)) ; 0-based + (beginning-of-line) + (setq line (count-lines (point-min) (point)))) ; 0-based + (gds-send (format "(%S eval %s %S %d %d %S)\n" + client + (if module (prin1-to-string module) "#f") + port-name line column + (buffer-substring-no-properties start end))))) + +(defun gds-eval-expression (expr &optional client) + "Evaluate the supplied EXPR (a string)." + (interactive "sEvaluate expression: \nP") + (setq client (gds-choose-client client)) + (gds-send (format "(%S eval #f \"Emacs expression\" 0 0 %S)\n" + client expr))) + +(defun gds-eval-defun (&optional client) + "Evaluate the defun (top-level form) at point." + (interactive "P") + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (gds-eval-region (point) end client)))) + +(defun gds-eval-last-sexp (&optional client) + "Evaluate the sexp before point." + (interactive "P") + (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client)) + +(defcustom gds-source-modes '(scheme-mode) + "*Used to determine if a buffer contains Scheme source code. +If it's loaded into a buffer that is in one of these major modes, it's +considered a scheme source file by `gds-load-file'." + :type '(repeat function) + :group 'gds) + +(defvar gds-prev-load-dir/file nil + "Holds the last (directory . file) pair passed to `gds-load-file'. +Used for determining the default for the next `gds-load-file'.") + +(defun gds-load-file (file-name &optional client) + "Load a Scheme file into the inferior Scheme process." + (interactive (list (car (comint-get-source "Load Scheme file: " + gds-prev-load-dir/file + gds-source-modes t)) + ; T because LOAD needs an + ; exact name + current-prefix-arg)) + (comint-check-source file-name) ; Check to see if buffer needs saved. + (setq gds-prev-load-dir/file (cons (file-name-directory file-name) + (file-name-nondirectory file-name))) + (setq client (gds-choose-client client)) + (gds-send (format "(%S load %S)\n" client file-name))) + +;; Install the process communication commands in the scheme-mode keymap. +(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention +(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention +(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-defun) +(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) +(define-key scheme-mode-map "\C-c\C-l" 'gds-load-file) + + +;;;; Menu bar entries. + +(defvar gds-debug-menu nil + "GDS debugging menu.") +(if gds-debug-menu + nil + (setq gds-debug-menu (make-sparse-keymap "Debug")) + (define-key gds-debug-menu [go] + '(menu-item "Go" gds-go)) + (define-key gds-debug-menu [trace-finish] + '(menu-item "Trace This Frame" gds-trace-finish)) + (define-key gds-debug-menu [step-out] + '(menu-item "Finish This Frame" gds-step-out)) + (define-key gds-debug-menu [next] + '(menu-item "Next" gds-next)) + (define-key gds-debug-menu [step-in] + '(menu-item "Single Step" gds-step-in)) + (define-key gds-debug-menu [eval] + '(menu-item "Eval In This Frame..." gds-evaluate))) + +(defvar gds-eval-menu nil + "GDS evaluation menu.") +(if gds-eval-menu + nil + (setq gds-eval-menu (make-sparse-keymap "Evaluate")) + (define-key gds-eval-menu [load-file] + '(menu-item "Load Scheme File" gds-load-file)) + (define-key gds-eval-menu [defun] + '(menu-item "Defun At Point" gds-eval-defun)) + (define-key gds-eval-menu [region] + '(menu-item "Region" gds-eval-region)) + (define-key gds-eval-menu [last-sexp] + '(menu-item "Sexp Before Point" gds-eval-last-sexp)) + (define-key gds-eval-menu [expr] + '(menu-item "Expression..." gds-eval-expression))) + +(defvar gds-help-menu nil + "GDS help menu.") +(if gds-help-menu + nil + (setq gds-help-menu (make-sparse-keymap "Help")) + (define-key gds-help-menu [apropos] + '(menu-item "Apropos..." gds-apropos)) + (define-key gds-help-menu [sym-here] + '(menu-item "Symbol At Point" gds-help-symbol-here)) + (define-key gds-help-menu [sym] + '(menu-item "Symbol..." gds-help-symbol))) + +(defvar gds-advanced-menu nil + "Menu of rarely needed GDS operations.") +(if gds-advanced-menu + nil + (setq gds-advanced-menu (make-sparse-keymap "Advanced")) + (define-key gds-advanced-menu [restart-gds] + '(menu-item "Restart IDE" gds-start :enable gds-process)) + (define-key gds-advanced-menu [kill-gds] + '(menu-item "Shutdown IDE" gds-shutdown :enable gds-process)) + (define-key gds-advanced-menu [start-gds] + '(menu-item "Start IDE" gds-start :enable (not gds-process)))) + +(defvar gds-menu nil + "Global menu for GDS commands.") +(if gds-menu + nil + (setq gds-menu (make-sparse-keymap "Guile")) + (define-key gds-menu [advanced] + (cons "Advanced" gds-advanced-menu)) + (define-key gds-menu [separator-1] + '("--")) + (define-key gds-menu [help] + `(menu-item "Help" ,gds-help-menu :enable gds-names)) + (define-key gds-menu [eval] + `(menu-item "Evaluate" ,gds-eval-menu :enable gds-names)) + (define-key gds-menu [debug] + `(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client + (gds-client-waiting)))) + (setq menu-bar-final-items + (cons 'guile menu-bar-final-items)) + (define-key global-map [menu-bar guile] + (cons "Guile" gds-menu))) + +;;;; Autostarting the GDS server. + +(defcustom gds-autostart-server t + "Whether to automatically start the GDS server when `gds.el' is loaded." + :type 'boolean + :group 'gds) + +(if (and gds-autostart-server + (not gds-process)) + (gds-start)) + +(provide 'gds) + +;;; gds.el ends here. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 024a9206c..e6b2d3905 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,9 @@ +2003-10-06 Neil Jerram <neil@ossau.uklinux.net> + + * debugger/ui-client.scm (handle-instruction): Add evaluation + support. + (ui-eval): New. + 2003-10-04 Neil Jerram <neil@ossau.uklinux.net> * debugger/ui-client.scm (ui-disable-async-thread, diff --git a/ice-9/debugger/ui-client.scm b/ice-9/debugger/ui-client.scm index 8fbbe1646..f7fc7b0e2 100644 --- a/ice-9/debugger/ui-client.scm +++ b/ice-9/debugger/ui-client.scm @@ -259,8 +259,53 @@ decimal IP address where the UI server is running; default is (debug-here)))) (module-ref (resolve-module (cadr ins)) (caddr ins))) state) + ((eval) + (apply (lambda (module port-name line column code) + (with-input-from-string code + (lambda () + (set-port-filename! (current-input-port) port-name) + (set-port-line! (current-input-port) line) + (set-port-column! (current-input-port) column) + (let ((m (and module (resolve-module module)))) + (let loop ((results '()) (x (read))) + (if (eof-object? x) + (write-form `(eval-results ,@results)) + (loop (append results (ui-eval x m)) + (read)))))))) + (cdr ins)) + state) (else state))) +(define (ui-eval x m) + ;; Consumer to accept possibly multiple values and present them for + ;; Emacs as a list of strings. + (define (value-consumer . values) + (if (unspecified? (car values)) + '() + (map (lambda (value) + (with-output-to-string (lambda () (write value)))) + values))) + (let ((value #f)) + (let ((output + (with-output-to-string + (lambda () + (if m + (begin + (display "Evaluating in module ") + (write (module-name m)) + (newline) + (set! value + (call-with-values (lambda () (eval x m)) + value-consumer))) + (begin + (display "Evaluating in current module ") + (write (module-name (current-module))) + (newline) + (set! value + (call-with-values (lambda () (primitive-eval x)) + value-consumer)))))))) + (list output value)))) + (define (write-status status) (write-form (list 'status status))) |