diff options
| -rw-r--r-- | emacs/Makefile.am | 7 | ||||
| -rwxr-xr-x | emacs/gds-faq.txt | 225 | ||||
| -rwxr-xr-x | emacs/gds-scheme.el | 540 | ||||
| -rw-r--r-- | emacs/gds-server.el | 109 | ||||
| -rw-r--r-- | emacs/gds-test.el | 166 | ||||
| -rwxr-xr-x | emacs/gds-test.sh | 2 | ||||
| -rw-r--r-- | emacs/gds-test.stdin | 1 | ||||
| -rwxr-xr-x | emacs/gds-tutorial.txt | 223 | ||||
| -rw-r--r-- | emacs/gds.el | 639 | ||||
| -rw-r--r-- | module/Makefile.am | 3 | ||||
| -rwxr-xr-x | module/ice-9/gds-client.scm | 583 | ||||
| -rw-r--r-- | module/ice-9/gds-server.scm | 188 |
12 files changed, 2 insertions, 2684 deletions
diff --git a/emacs/Makefile.am b/emacs/Makefile.am index e18f30bf1..69bab137d 100644 --- a/emacs/Makefile.am +++ b/emacs/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright (C) 2006, 2008 Free Software Foundation, Inc. +## Copyright (C) 2006, 2008, 2010 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -21,7 +21,4 @@ AUTOMAKE_OPTIONS = gnu -dist_lisp_LISP = gds.el gds-server.el gds-scheme.el -ELCFILES = - -ETAGS_ARGS = $(dist_lisp_LISP) ChangeLog-2008 +ETAGS_ARGS = ChangeLog-2008 diff --git a/emacs/gds-faq.txt b/emacs/gds-faq.txt deleted file mode 100755 index b60a2c9ae..000000000 --- a/emacs/gds-faq.txt +++ /dev/null @@ -1,225 +0,0 @@ - -* Installation - -** How do I install guile-debugging? - -After unpacking the .tar.gz file, run the usual sequence of commands: - -$ ./configure -$ make -$ sudo make install - -Then you need to make sure that the directory where guile-debugging's -Scheme files were installed is included in your Guile's load path. -(The sequence above will usually install guile-debugging under -/usr/local, and /usr/local is not in Guile's load path by default, -unless Guile itself was installed under /usr/local.) You can discover -your Guile's default load path by typing - -$ guile -q -c '(begin (write %load-path) (newline))' - -There are two ways to add guile-debugging's installation directory to -Guile's load path, if it isn't already there. - -1. Edit or create the `init.scm' file, which Guile reads on startup, - so that it includes a line like this: - - (set! %load-path (cons "/usr/local/share/guile" %load-path)) - - but with "/usr/local" replaced by the prefix that you installed - guile-debugging under, if not /usr/local. - - The init.scm file must be installed (if it does not already exist - there) in one of the directories in Guile's default load-path. - -2. Add this line to your .emacs file: - - (setq gds-scheme-directory "/usr/local/share/guile") - - before the `require' or `load' line that loads GDS, but with - "/usr/local" replaced by the prefix that you installed - guile-debugging under, if not /usr/local. - -Finally, if you want guile-debugging's GDS interface to be loaded -automatically whenever you run Emacs, add this line to your .emacs: - -(require 'gds) - -* Troubleshooting - -** "error in process filter" when starting Emacs (or loading GDS) - -This is caused by an internal error in GDS's Scheme code, for which a -backtrace will have appeared in the gds-debug buffer, so please switch -to the gds-debug buffer and see what it says there. - -The most common cause is a load path problem: Guile cannot find GDS's -Scheme code because it is not in the known load path. In this case -you should see the error message "no code for module" somewhere in the -backtrace. If you see this, please try the remedies described in `How -do I install guile-debugging?' above, then restart Emacs and see if -the problem has been cured. - -If you don't see "no code for module", or if the described remedies -don't fix the problem, please send the contents of the gds-debug -buffer to me at <neil@ossau.uklinux.net>, so I can debug the problem. - -If you don't see a backtrace at all in the gds-debug buffer, try the -next item ... - -** "error in process filter" at some other time - -This is caused by an internal error somewhere in GDS's Emacs Lisp -code. If possible, please - -- switch on the `debug-on-error' option (M-x set-variable RET - debug-on-error RET t RET) - -- do whatever you were doing so that the same error happens again - -- send the Emacs Lisp stack trace which pops up to me at - <neil@ossau.uklinux.net>. - -If that doesn't work, please just mail me with as much detail as -possible of what you were doing when the error occurred. - -* GDS Features - -** How do I inspect variable values? - -Type `e' followed by the name of the variable, then <RET>. This -works whenever GDS is displaying a stack for an error at at a -breakpoint. (You can actually `e' to evaluate any expression in the -local environment of the selected stack frame; inspecting variables is -the special case of this where the expression is only a variable name.) - -If GDS is displaying the associated source code in the window above or -below the stack, you can see the values of any variables in the -highlighted code just by hovering your mouse over them. - -** How do I change a variable's value? - -Type `e' and then `(set! VARNAME NEWVAL)', where VARNAME is the name -of the variable you want to set and NEWVAL is an expression which -Guile can evaluate to get the new value. This works whenever GDS is -displaying a stack for an error at at a breakpoint. The setting will -take effect in the local environment of the selected stack frame. - -** How do I change the expression that Guile is about to evaluate? - -Type `t' followed by the expression that you want Guile to evaluate -instead, then <RET>. - -Then type one of the commands that tells Guile to continue execution. - -(Tweaking expressions, as described here, is only supported by the -latest CVS version of Guile. The GDS stack display tells you when -tweaking is possible by adding "(tweakable)" to the first line of the -stack window.) - -** How do I return a value from the current stack frame different to what the evaluator has calculated? - -You have to be at the normal exit of the relevant frame first, so if -GDS is not already showing you the normally calculated return value, -type `o' to finish the evaluation of the selected frame. - -Then type `t' followed by the value you want to return, and <RET>. -The value that you type can be any expression, but note that it will -not be evaluated before being returned; for example if you type `(+ 2 -3)', the return value will be a three-element list, not 5. - -Finally type one of the commands that tells Guile to continue -execution. - -(Tweaking return values, as described here, is only supported by the -latest CVS version of Guile. The GDS stack display tells you when -tweaking is possible by adding "(tweakable)" to the first line of the -stack window.) - -** How do I step over a line of code? - -Scheme isn't organized by lines, so it doesn't really make sense to -think of stepping over lines. Instead please see the next entry on -stepping over expressions. - -** How do I step over an expression? - -It depends what you mean by "step over". If you mean that you want -Guile to evaluate that expression normally, but then show you its -return value, type `o', which does exactly that. - -If you mean that you want to skip the evaluation of that expression -(for example because it has side effects that you don't want to -happen), use `t' to change the expression to something else which -Guile will evaluate instead. - -There has to be a substitute expression so Guile can calculate a value -to return to the calling frame. If you know at a particular point -that the return value is not important, you can type `t #f <RET>' or -`t 0 <RET>'. - -See `How do I change the expression that Guile is about to evaluate?' -above for more on using `t'. - -** How do I move up and down the call stack? - -Type `u' to move up and `d' to move down. "Up" in GDS means to a more -"inner" frame, and "down" means to a more "outer" frame. - -** How do I run until the next breakpoint? - -Type `g' (for "go"). - -** How do I run until the end of the selected stack frame? - -Type `o'. - -** How do I set a breakpoint? - -First identify the code that you want to set the breakpoint in, and -what kind of breakpoint you want. To set a breakpoint on entry to a -top level procedure, move the cursor to anywhere in the procedure -definition, and make sure that the region/mark is inactive. To set a -breakpoint on a particular expression (or sequence of expressions) set -point and mark so that the region covers the opening parentheses of -all the target expressions. - -Then type ... - - `C-c C-b d' for a `debug' breakpoint, which means that GDS will - display the stack when the breakpoint is hit - - `C-c C-b t' for a `trace' breakpoint, which means that the start and - end of the relevant procedure or expression(s) will be traced to the - *GDS Trace* buffer - - `C-c C-b T' for a `trace-subtree' breakpoint, which means that every - evaluation step involved in the evaluation of the relevant procedure - or expression(s) will be traced to the *GDS Trace* buffer. - -You can also type `C-x <SPC>', which does the same as one of the -above, depending on the value of `gds-default-breakpoint-type'. - -** How do I clear a breakpoint? - -Select a region containing the breakpoints that you want to clear, and -type `C-c C-b <DEL>'. - -** How do I trace calls to a particular procedure or evaluations of a particular expression? - -In GDS this means setting a breakpoint whose type is `trace' or -`trace-subtree'. See `How do I set a breakpoint?' above. - -* Development - -** How can I follow or contribute to guile-debugging's development? - -guile-debugging is hosted at http://gna.org, so please see the project -page there. Feel free to raise bugs, tasks containing patches or -feature requests, and so on. You can also write directly to me by -email: <neil@ossau.uklinux.net>. - - -Local Variables: -mode: outline -End: diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el deleted file mode 100755 index 326d15265..000000000 --- a/emacs/gds-scheme.el +++ /dev/null @@ -1,540 +0,0 @@ -;;; gds-scheme.el -- GDS function for Scheme mode buffers - -;;;; Copyright (C) 2005 Neil Jerram -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free -;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;;; 02111-1307 USA - -(require 'comint) -(require 'scheme) -(require 'derived) -(require 'pp) - -;;;; Maintaining an association between a Guile client process and a -;;;; set of Scheme mode buffers. - -(defcustom gds-auto-create-utility-client t - "Whether to automatically create a utility Guile client, and -associate the current buffer with it, if there are no existing Guile -clients available to GDS when the user does something that requires a -running Guile client." - :type 'boolean - :group 'gds) - -(defcustom gds-auto-associate-single-client t - "Whether to automatically associate the current buffer with an -existing Guile client, if there is only only client known to GDS when -the user does something that requires a running Guile client, and the -current buffer is not already associated with a Guile client." - :type 'boolean - :group 'gds) - -(defcustom gds-auto-associate-last-client t - "Whether to automatically associate the current buffer with the -Guile client that most recently caused that buffer to be displayed, -when the user does something that requires a running Guile client and -the current buffer is not already associated with a Guile client." - :type 'boolean - :group 'gds) - -(defvar gds-last-touched-by nil - "For each Scheme mode buffer, this records the GDS client that most -recently `touched' that buffer in the sense of using it to display -source code, for example for the source code relevant to a debugger -stack frame.") -(make-variable-buffer-local 'gds-last-touched-by) - -(defun gds-auto-associate-buffer () - "Automatically associate the current buffer with a Guile client, if -possible." - (let* ((num-clients (length gds-client-info)) - (client - (or - ;; If there are no clients yet, and - ;; `gds-auto-create-utility-client' allows us to create one - ;; automatically, do that. - (and (= num-clients 0) - gds-auto-create-utility-client - (gds-start-utility-guile)) - ;; Otherwise, if there is a single existing client, and - ;; `gds-auto-associate-single-client' allows us to use it - ;; for automatic association, do that. - (and (= num-clients 1) - gds-auto-associate-single-client - (caar gds-client-info)) - ;; Otherwise, if the current buffer was displayed because - ;; of a Guile client trapping somewhere in its code, and - ;; `gds-auto-associate-last-client' allows us to associate - ;; with that client, do so. - (and gds-auto-associate-last-client - gds-last-touched-by)))) - (if client - (gds-associate-buffer client)))) - -(defun gds-associate-buffer (client) - "Associate the current buffer with the Guile process CLIENT. -This means that operations in this buffer that require a running Guile -process - such as evaluation, help, completion and setting traps - -will be sent to the Guile process whose name or connection number is -CLIENT." - (interactive (list (gds-choose-client))) - ;; If this buffer is already associated, dissociate from its - ;; existing client first. - (if gds-client (gds-dissociate-buffer)) - ;; Store the client number in the buffer-local variable gds-client. - (setq gds-client client) - ;; Add this buffer to the list of buffers associated with the - ;; client. - (gds-client-put client 'associated-buffers - (cons (current-buffer) - (gds-client-get client 'associated-buffers)))) - -(defun gds-dissociate-buffer () - "Dissociate the current buffer from any specific Guile process." - (interactive) - (if gds-client - (progn - ;; Remove this buffer from the list of buffers associated with - ;; the current client. - (gds-client-put gds-client 'associated-buffers - (delq (current-buffer) - (gds-client-get gds-client 'associated-buffers))) - ;; Reset the buffer-local variable gds-client. - (setq gds-client nil) - ;; Clear any process status indication from the modeline. - (setq mode-line-process nil) - (force-mode-line-update)))) - -(defun gds-show-client-status (client status-string) - "Show a client's status in the modeline of all its associated -buffers." - (let ((buffers (gds-client-get client 'associated-buffers))) - (while buffers - (if (buffer-live-p (car buffers)) - (with-current-buffer (car buffers) - (setq mode-line-process status-string) - (force-mode-line-update))) - (setq buffers (cdr buffers))))) - -(defcustom gds-running-text ":running" - "*Mode line text used to show that a Guile process is \"running\". -\"Running\" means that the process cannot currently accept any input -from the GDS frontend in Emacs, because all of its threads are busy -running code that GDS cannot easily interrupt." - :type 'string - :group 'gds) - -(defcustom gds-ready-text ":ready" - "*Mode line text used to show that a Guile process is \"ready\". -\"Ready\" means that the process is ready to interact with the GDS -frontend in Emacs, because at least one of its threads is waiting for -GDS input." - :type 'string - :group 'gds) - -(defcustom gds-debug-text ":debug" - "*Mode line text used to show that a Guile process is \"debugging\". -\"Debugging\" means that the process is using the GDS frontend in -Emacs to display an error or trap so that the user can debug it." - :type 'string - :group 'gds) - -(defun gds-choose-client () - "Ask the user to choose a GDS client process from a list." - (let ((table '()) - (default nil)) - ;; Prepare a table containing all current clients. - (mapcar (lambda (client-info) - (setq table (cons (cons (cadr (memq 'name client-info)) - (car client-info)) - table))) - gds-client-info) - ;; Add an entry to allow the user to ask for a new process. - (setq table (cons (cons "Start a new Guile process" nil) table)) - ;; Work out a good default. If the buffer has a good value in - ;; gds-last-touched-by, we use that; otherwise default to starting - ;; a new process. - (setq default (or (and gds-last-touched-by - (gds-client-get gds-last-touched-by 'name)) - (caar table))) - ;; Read using this table. - (let* ((name (completing-read "Choose a Guile process: " - table - nil - t ; REQUIRE-MATCH - nil ; INITIAL-INPUT - nil ; HIST - default)) - ;; Convert name to a client number. - (client (cdr (assoc name table)))) - ;; If the user asked to start a new Guile process, do that now. - (or client (setq client (gds-start-utility-guile))) - ;; Return the chosen client ID. - client))) - -(defvar gds-last-utility-number 0 - "Number of the last started Guile utility process.") - -(defun gds-start-utility-guile () - "Start a new utility Guile process." - (setq gds-last-utility-number (+ gds-last-utility-number 1)) - (let* ((procname (format "gds-util[%d]" gds-last-utility-number)) - (code (format "(begin - %s - (use-modules (ice-9 gds-client)) - (run-utility))" - (if gds-scheme-directory - (concat "(set! %load-path (cons " - (format "%S" gds-scheme-directory) - " %load-path))") - ""))) - (proc (start-process procname - (get-buffer-create procname) - gds-guile-program - "-q" - "--debug" - "-c" - code))) - ;; Note that this process can be killed automatically on Emacs - ;; exit. - (process-kill-without-query proc) - ;; Set up a process filter to catch the new client's number. - (set-process-filter proc - (lambda (proc string) - (if (process-buffer proc) - (with-current-buffer (process-buffer proc) - (insert string) - (or gds-client - (save-excursion - (goto-char (point-min)) - (setq gds-client - (condition-case nil - (read (current-buffer)) - (error nil))))))))) - ;; Accept output from the new process until we have its number. - (while (not (with-current-buffer (process-buffer proc) gds-client)) - (accept-process-output proc)) - ;; Return the new process's client number. - (with-current-buffer (process-buffer proc) gds-client))) - -;;;; Evaluating code. - -;; 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. -;; -;; For each buffer where evaluations can be requested, GDS uses the -;; buffer-local variable `gds-client' to track which GDS client -;; program should receive and handle that buffer's evaluations. - -(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))) - -(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: " - "Prefix used when telling Guile the name of the port from which a -chunk of Scheme code (to be evaluated) comes. GDS uses this prefix, -followed by the buffer name, in two cases: when the buffer concerned -is not associated with a file, or if the buffer has been modified -since last saving to its file. In the case where the buffer is -identical to a saved file, GDS uses the file name as the port name." - :type '(string) - :group 'gds) - -(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 (and (not (buffer-modified-p)) - buffer-file-name) - (concat gds-emacs-buffer-port-name-prefix (buffer-name)))) - -(defun gds-line-and-column (pos) - "Return 0-based line and column number at POS." - (let (line column) - (save-excursion - (goto-char pos) - (setq column (current-column)) - (beginning-of-line) - (setq line (count-lines (point-min) (point)))) - (cons line column))) - -(defun gds-eval-region (start end &optional debugp) - "Evaluate the current region. If invoked with `C-u' prefix (or, in -a program, with optional DEBUGP arg non-nil), pause and pop up the -stack at the start of the evaluation, so that the user can single-step -through the code." - (interactive "r\nP") - (or gds-client - (gds-auto-associate-buffer) - (call-interactively 'gds-associate-buffer)) - (let ((module (gds-module-name start end)) - (port-name (gds-port-name start end)) - (lc (gds-line-and-column start))) - (let ((code (buffer-substring-no-properties start end))) - (gds-send (format "eval (region . %S) %s %S %d %d %S %s" - (gds-abbreviated code) - (if module (prin1-to-string module) "#f") - port-name (car lc) (cdr lc) - code - (if debugp '(debug) '(none))) - gds-client)))) - -(defun gds-eval-expression (expr &optional correlator debugp) - "Evaluate the supplied EXPR (a string). If invoked with `C-u' -prefix (or, in a program, with optional DEBUGP arg non-nil), pause and -pop up the stack at the start of the evaluation, so that the user can -single-step through the code." - (interactive "sEvaluate expression: \ni\nP") - (or gds-client - (gds-auto-associate-buffer) - (call-interactively 'gds-associate-buffer)) - (set-text-properties 0 (length expr) nil expr) - (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S %s" - (or correlator 'expression) - (gds-abbreviated expr) - expr - (if debugp '(debug) '(none))) - gds-client)) - -(defconst gds-abbreviated-length 35) - -(defun gds-abbreviated (code) - (let ((nlpos (string-match (regexp-quote "\n") code))) - (while nlpos - (setq code - (if (= nlpos (- (length code) 1)) - (substring code 0 nlpos) - (concat (substring code 0 nlpos) - "\\n" - (substring code (+ nlpos 1))))) - (setq nlpos (string-match (regexp-quote "\n") code)))) - (if (> (length code) gds-abbreviated-length) - (concat (substring code 0 (- gds-abbreviated-length 3)) "...") - code)) - -(defun gds-eval-defun (&optional debugp) - "Evaluate the defun (top-level form) at point. If invoked with -`C-u' prefix (or, in a program, with optional DEBUGP arg non-nil), -pause and pop up the stack at the start of the evaluation, so that the -user can single-step through the code." - (interactive "P") - (save-excursion - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (gds-eval-region (point) end debugp)))) - -(defun gds-eval-last-sexp (&optional debugp) - "Evaluate the sexp before point. If invoked with `C-u' prefix (or, -in a program, with optional DEBUGP arg non-nil), pause and pop up the -stack at the start of the evaluation, so that the user can single-step -through the code." - (interactive "P") - (gds-eval-region (save-excursion (backward-sexp) (point)) (point) debugp)) - -;;;; Help. - -;; Help is implemented as a special case of evaluation, identified by -;; the evaluation correlator 'help. - -(defun gds-help-symbol (sym) - "Get help for SYM (a Scheme symbol)." - (interactive - (let ((sym (thing-at-point 'symbol)) - (enable-recursive-minibuffers t) - val) - (setq val (read-from-minibuffer - (if sym - (format "Describe Guile symbol (default %s): " sym) - "Describe Guile symbol: "))) - (list (if (zerop (length val)) sym val)))) - (gds-eval-expression (format "(help %s)" sym) 'help)) - -(defun gds-apropos (regex) - "List Guile symbols matching REGEX." - (interactive - (let ((sym (thing-at-point 'symbol)) - (enable-recursive-minibuffers t) - val) - (setq val (read-from-minibuffer - (if sym - (format "Guile apropos (regexp, default \"%s\"): " sym) - "Guile apropos (regexp): "))) - (list (if (zerop (length val)) sym val)))) - (set-text-properties 0 (length regex) nil regex) - (gds-eval-expression (format "(apropos %S)" regex) 'apropos)) - -;;;; Displaying results of help and eval. - -(defun gds-display-results (client correlator stack-available results) - (let* ((helpp+bufname (cond ((eq (car correlator) 'help) - '(t . "*Guile Help*")) - ((eq (car correlator) 'apropos) - '(t . "*Guile Apropos*")) - (t - '(nil . "*Guile Evaluation*")))) - (helpp (car helpp+bufname))) - (let ((buf (get-buffer-create (cdr helpp+bufname)))) - (save-selected-window - (save-excursion - (set-buffer buf) - (gds-dissociate-buffer) - (erase-buffer) - (scheme-mode) - (insert (cdr correlator) "\n\n") - (while results - (insert (car results)) - (or (bolp) (insert "\\\n")) - (if helpp - nil - (if (cadr results) - (mapcar (function (lambda (value) - (insert " => " value "\n"))) - (cadr results)) - (insert " => no (or unspecified) value\n")) - (insert "\n")) - (setq results (cddr results))) - (if stack-available - (let ((beg (point)) - (map (make-sparse-keymap))) - (define-key map [mouse-1] 'gds-show-last-stack) - (define-key map "\C-m" 'gds-show-last-stack) - (insert "[click here (or RET) to show error stack]") - (add-text-properties beg (point) - (list 'keymap map - 'mouse-face 'highlight)) - (insert "\n") - (add-text-properties (1- (point)) (point) - (list 'keymap map)))) - (goto-char (point-min)) - (gds-associate-buffer client)) - (pop-to-buffer buf) - (run-hooks 'temp-buffer-show-hook))))) - -(defun gds-show-last-stack () - "Show stack of the most recent error." - (interactive) - (or gds-client - (gds-auto-associate-buffer) - (call-interactively 'gds-associate-buffer)) - (gds-send "debug-lazy-trap-context" gds-client)) - -;;;; Completion. - -(defvar gds-completion-results nil) - -(defun gds-complete-symbol () - "Complete the Guile symbol before point. Returns `t' if anything -interesting happened, `nil' if not." - (interactive) - (or gds-client - (gds-auto-associate-buffer) - (call-interactively 'gds-associate-buffer)) - (let* ((chars (- (point) (save-excursion - (while (let ((syntax (char-syntax (char-before (point))))) - (or (eq syntax ?w) (eq syntax ?_))) - (forward-char -1)) - (point))))) - (if (zerop chars) - nil - (setq gds-completion-results nil) - (gds-send (format "complete %s" - (prin1-to-string - (buffer-substring-no-properties (- (point) chars) - (point)))) - gds-client) - (while (null gds-completion-results) - (accept-process-output gds-debug-server 0 200)) - (cond ((eq gds-completion-results 'error) - (error "Internal error - please report the contents of the *Guile Evaluation* window")) - ((eq gds-completion-results t) - nil) - ((stringp gds-completion-results) - (if (<= (length gds-completion-results) chars) - nil - (insert (substring gds-completion-results chars)) - (message "Sole completion") - t)) - ((= (length gds-completion-results) 1) - (if (<= (length (car gds-completion-results)) chars) - nil - (insert (substring (car gds-completion-results) chars)) - t)) - (t - (with-output-to-temp-buffer "*Completions*" - (display-completion-list gds-completion-results)) - t))))) - -;;;; Dispatcher for non-debug protocol. - -(defun gds-nondebug-protocol (client proc args) - (cond (;; (eval-results ...) - Results of evaluation. - (eq proc 'eval-results) - (gds-display-results client (car args) (cadr args) (cddr args)) - ;; If these results indicate an error, set - ;; gds-completion-results to non-nil in case the error arose - ;; when trying to do a completion. - (if (eq (caar args) 'error) - (setq gds-completion-results 'error))) - - (;; (completion-result ...) - Available completions. - (eq proc 'completion-result) - (setq gds-completion-results (or (car args) t))) - - (;; (note ...) - For debugging only. - (eq proc 'note)) - - (;; (trace ...) - Tracing. - (eq proc 'trace) - (with-current-buffer (get-buffer-create "*GDS Trace*") - (save-excursion - (goto-char (point-max)) - (or (bolp) (insert "\n")) - (insert "[client " (number-to-string client) "] " (car args) "\n")))) - - (t - ;; Unexpected. - (error "Bad protocol: %S" form)))) - -;;;; Scheme mode keymap items. - -(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun) -(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp) -(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression) -(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region) -(define-key scheme-mode-map "\C-hg" 'gds-help-symbol) -(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos) -(define-key scheme-mode-map "\C-hG" 'gds-apropos) -(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack) -(define-key scheme-mode-map "\e\t" 'gds-complete-symbol) - -;;;; The end! - -(provide 'gds-scheme) - -;;; gds-scheme.el ends here. diff --git a/emacs/gds-server.el b/emacs/gds-server.el deleted file mode 100644 index 9cfcd3aab..000000000 --- a/emacs/gds-server.el +++ /dev/null @@ -1,109 +0,0 @@ -;;; gds-server.el -- infrastructure for running GDS server processes - -;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc. -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free -;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;;; 02111-1307 USA - - -;;;; Customization group setup. - -(defgroup gds nil - "Customization options for Guile Emacs frontend." - :group 'scheme) - - -;;;; Communication with the (ice-9 gds-server) subprocess. - -;; Subprocess output goes into the `*GDS Process*' buffer, and -;; is then read from there one form at a time. `gds-read-cursor' is -;; the buffer position of the start of the next unread form. -(defvar gds-read-cursor nil) - -;; The guile executable used by the GDS server process. -(defcustom gds-guile-program "guile" - "*The guile executable used by the GDS server process." - :type 'string - :group 'gds) - -(defcustom gds-scheme-directory nil - "Where GDS's Scheme code is, if not in one of the standard places." - :group 'gds - :type '(choice (const :tag "nil" nil) directory)) - -(defun gds-start-server (procname unix-socket-name tcp-port protocol-handler) - "Start a GDS server process called PROCNAME, listening on Unix -domain socket UNIX-SOCKET-NAME and TCP port number TCP-PORT. -PROTOCOL-HANDLER should be a function that accepts and processes -one protocol form." - (with-current-buffer (get-buffer-create procname) - (erase-buffer) - (let* ((code (format "(begin - %s - (use-modules (ice-9 gds-server)) - (run-server %S %S))" - (if gds-scheme-directory - (concat "(set! %load-path (cons " - (format "%S" gds-scheme-directory) - " %load-path))") - "") - unix-socket-name - tcp-port)) - (process-connection-type nil) ; use a pipe - (proc (start-process procname - (current-buffer) - gds-guile-program - "-q" - "--debug" - "-c" - code))) - (set (make-local-variable 'gds-read-cursor) (point-min)) - (set (make-local-variable 'gds-protocol-handler) protocol-handler) - (set-process-filter proc (function gds-filter)) - (set-process-sentinel proc (function gds-sentinel)) - (set-process-coding-system proc 'latin-1-unix) - (process-kill-without-query proc) - proc))) - -;; Subprocess output filter: inserts normally into the process buffer, -;; then tries to reread the output one form at a time and delegates -;; processing of each form to `gds-protocol-handler'. -(defun gds-filter (proc string) - (with-current-buffer (process-buffer proc) - (save-excursion - (goto-char (process-mark proc)) - (insert-before-markers string)) - (goto-char gds-read-cursor) - (while (let ((form (condition-case nil - (read (current-buffer)) - (error nil)))) - (if form - (save-excursion - (funcall gds-protocol-handler (car form) (cdr form)))) - form) - (setq gds-read-cursor (point))))) - -;; Subprocess sentinel: do nothing. (Currently just here to avoid -;; inserting un-`read'able process status messages into the process -;; buffer.) -(defun gds-sentinel (proc event) - ) - - -;;;; The end! - -(provide 'gds-server) - -;;; gds-server.el ends here. diff --git a/emacs/gds-test.el b/emacs/gds-test.el deleted file mode 100644 index dfd4f6c7b..000000000 --- a/emacs/gds-test.el +++ /dev/null @@ -1,166 +0,0 @@ - -;; Test utility code. -(defun gds-test-execute-keys (keys &optional keys2) - (execute-kbd-macro (apply 'vector (listify-key-sequence keys)))) - -(defvar gds-test-expecting nil) - -(defun gds-test-protocol-hook (form) - (message "[protocol: %s]" (car form)) - (if (eq (car form) gds-test-expecting) - (setq gds-test-expecting nil))) - -(defun gds-test-expect-protocol (proc &optional timeout) - (message "[expect: %s]" proc) - (setq gds-test-expecting proc) - (while gds-test-expecting - (or (accept-process-output gds-debug-server (or timeout 5)) - (error "Timed out after %ds waiting for %s" (or timeout 5) proc)))) - -(defun gds-test-check-buffer (name &rest strings) - (let ((buf (or (get-buffer name) (error "No %s buffer" name)))) - (save-excursion - (set-buffer buf) - (goto-char (point-min)) - (while strings - (search-forward (car strings)) - (setq strings (cdr strings)))))) - -(defun TEST (desc) - (message "TEST: %s" desc)) - -;; Make sure we take GDS elisp code from this code tree. -(setq load-path (cons (concat default-directory "emacs/") load-path)) - -;; Protect the tests so we can do some cleanups in case of error. -(unwind-protect - (progn - - ;; Visit the tutorial. - (find-file "gds-tutorial.txt") - - (TEST "Load up GDS.") - (search-forward "(require 'gds)") - (setq load-path (cons (concat default-directory "emacs/") load-path)) - (gds-test-execute-keys "\C-x\C-e") - - ;; Install our testing hook. - (add-hook 'gds-protocol-hook 'gds-test-protocol-hook) - - (TEST "Help.") - (search-forward "(list-ref") - (backward-char 2) - (gds-test-execute-keys "\C-hg\C-m") - (gds-test-expect-protocol 'eval-results 10) - (gds-test-check-buffer "*Guile Help*" - "help list-ref" - "is a primitive procedure in the (guile) module") - - (TEST "Completion.") - (re-search-forward "^with-output-to-s") - (gds-test-execute-keys "\e\C-i") - (beginning-of-line) - (or (looking-at "with-output-to-string") - (error "Expected completion `with-output-to-string' failed")) - - (TEST "Eval defun.") - (search-forward "(display z)") - (gds-test-execute-keys "\e\C-x") - (gds-test-expect-protocol 'eval-results) - (gds-test-check-buffer "*Guile Evaluation*" - "(let ((x 1) (y 2))" - "Arctangent is: 0.46" - "=> 0.46") - - (TEST "Multiple values.") - (search-forward "(values 'a ") - (gds-test-execute-keys "\e\C-x") - (gds-test-expect-protocol 'eval-results) - (gds-test-check-buffer "*Guile Evaluation*" - "(values 'a" - "hello world" - "=> a" - "=> b" - "=> c") - - (TEST "Eval region with multiple expressions.") - (search-forward "(display \"Arctangent is: \")") - (beginning-of-line) - (push-mark nil nil t) - (forward-line 3) - (gds-test-execute-keys "\C-c\C-r") - (gds-test-expect-protocol 'eval-results) - (gds-test-check-buffer "*Guile Evaluation*" - "(display \"Arctangent is" - "Arctangent is:" - "=> no (or unspecified) value" - "ERROR: Unbound variable: z" - "=> error-in-evaluation" - "Evaluating expression 3" - "=> no (or unspecified) value") - - (TEST "Eval syntactically unbalanced region.") - (search-forward "(let ((z (atan x y)))") - (beginning-of-line) - (push-mark nil nil t) - (forward-line 4) - (gds-test-execute-keys "\C-c\C-r") - (gds-test-expect-protocol 'eval-results) - (gds-test-check-buffer "*Guile Evaluation*" - "(let ((z (atan" - "Reading expressions to evaluate" - "ERROR" - "end of file" - "=> error-in-read") - - (TEST "Stepping through an evaluation.") - (search-forward "(for-each (lambda (x)") - (forward-line 1) - (push-mark nil nil t) - (forward-line 1) - (gds-test-execute-keys "\C-u\e\C-x") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys " ") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "o") - (gds-test-expect-protocol 'stack) - (gds-test-execute-keys "g") - (gds-test-expect-protocol 'eval-results) - (gds-test-check-buffer "*Guile Evaluation*" - "(for-each (lambda" - "Evaluating in current module" - "3 cubed is 27" - "=> no (or unspecified) value") - - ;; Done. - (message "====================================") - (message "gds-test.el completed without errors") - (message "====================================") - - ) - - (switch-to-buffer "gds-debug") - (write-region (point-min) (point-max) "gds-test.debug") - - (switch-to-buffer "*GDS Transcript*") - (write-region (point-min) (point-max) "gds-test.transcript") - - ) diff --git a/emacs/gds-test.sh b/emacs/gds-test.sh deleted file mode 100755 index 2f8ddff9f..000000000 --- a/emacs/gds-test.sh +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -GUILE_LOAD_PATH=$(pwd) emacs --batch --no-site-file -q -l gds-test.el < gds-test.stdin diff --git a/emacs/gds-test.stdin b/emacs/gds-test.stdin deleted file mode 100644 index 8b1378917..000000000 --- a/emacs/gds-test.stdin +++ /dev/null @@ -1 +0,0 @@ - diff --git a/emacs/gds-tutorial.txt b/emacs/gds-tutorial.txt deleted file mode 100755 index 4254803ec..000000000 --- a/emacs/gds-tutorial.txt +++ /dev/null @@ -1,223 +0,0 @@ - -;; Welcome to the GDS tutorial! - -;; This tutorial teaches the use of GDS by leading you through a set -;; of examples where you actually use GDS, in Emacs, along the way. -;; To get maximum benefit, therefore, you should be reading this -;; tutorial in Emacs. - -;; ** GDS setup - -;; The first thing to do, if you haven't already, is to load the GDS -;; library into Emacs. The Emacs Lisp expression for this is: - -(require 'gds) - -;; So, if you don't already have this in your .emacs, either add it -;; and then restart Emacs, or evaluate it just for this Emacs session -;; by moving the cursor to just after the closing parenthesis and -;; typing `C-x C-e'. - -;; (Note that if you _have_ already loaded GDS, and you type `C-x C-e' -;; after this expression, you will see a *Guile Evaluation* window -;; telling you that the evaluation failed because `require' is -;; unbound. Don't worry; this is not a problem, and the rest of the -;; tutorial should still work just fine.) - -;; ** Help - -;; GDS makes it easy to access the Guile help system when working on a -;; Scheme program in Emacs. For example, suppose that you are writing -;; code that uses list-ref, and need to remind yourself about -;; list-ref's arguments ... - -(define (penultimate l) - (list-ref - -;; Just place the cursor on the word "list-ref" and type `C-h g RET'. -;; Try it now! - -;; If GDS is working correctly, a window should have popped up above -;; or below showing the Guile help for list-ref. - -;; You can also do an "apropos" search through Guile's help. If you -;; couldn't remember the name list-ref, for example, you could search -;; for anything matching "list" by typing `C-h C-g' and entering -;; "list" at the minibuffer prompt. Try doing this now: you should -;; see a longish list of Guile definitions whose names include "list". -;; As usual in Emacs, you can use `M-PageUp' and `M-PageDown' to -;; conveniently scroll the other window without having to select it. - -;; The functions called by `C-h g' and `C-h C-g' are gds-help-symbol -;; and gds-apropos. They both look up the symbol or word at point by -;; default, but that default can be overidden by typing something else -;; at the minibuffer prompt. - -;; ** Completion - -;; As you are typing Scheme code, you can ask GDS to complete the -;; symbol before point for you, by typing `ESC TAB'. GDS selects -;; possible completions by matching the text so far against all -;; definitions in the Guile environment. (This may be contrasted with -;; the "dabbrev" completion performed by `M-/', which selects possible -;; completions from the contents of Emacs buffers. So, if you are -;; trying to complete "with-ou", to get "with-output-to-string", for -;; example, `ESC TAB' will always work, because with-output-to-string -;; is always defined in Guile's default environment, whereas `M-/' -;; will only work if one of Emacs's buffers happens to contain the -;; full name "with-output-to-string".) - -;; To illustrate the idea, here are some partial names that you can -;; try completing. For each one, move the cursor to the end of the -;; line and type `ESC TAB' to try to complete it. - -list- -with-ou -with-output-to-s -mkst - -;; (If you are not familiar with any of the completed definitions, -;; feel free to use `C-h g' to find out about them!) - -;; ** Evaluation - -;; GDS provides several ways for you to evaluate Scheme code from -;; within Emacs. - -;; Just like in Emacs Lisp, a single expression in a buffer can be -;; evaluated using `C-x C-e' or `C-M-x'. For `C-x C-e', the -;; expression is that which ends immediately before point (so that it -;; is useful for evaluating something just after you have typed it). -;; For `C-M-x', the expression is the "top level defun" around point; -;; this means the balanced chunk of code around point whose opening -;; parenthesis is in column 0. - -;; Take this code fragment as an example: - -(let ((x 1) (y 2)) - (let ((z (atan x y))) - (display "Arctangent is: ") - (display z) - (newline) - z)) - -;; If you move the cursor to the end of the (display z) line and type -;; `C-x C-e', the code evaluated is just "(display z)", which normally -;; produces an error, because z is not defined in the usual Guile -;; environment. If, however, you type `C-M-x' with the cursor in the -;; same place, the code evaluated is the whole "(let ((x 1) (y 2)) -;; ...)" kaboodle, because that is the most recent expression before -;; point that starts in column 0. - -;; Try these now. The Guile Evaluation window should pop up again, -;; and show you: -;; - the expression that was evaluated (probably abbreviated) -;; - the module that it was evaluated in -;; - anything that the code wrote to its standard output -;; - the return value(s) of the evaluation. -;; Following the convention of the Emacs Lisp and Guile manuals, -;; return values are indicated by the symbol "=>". - -;; To see what happens when an expression has multiple return values, -;; try evaluating this one: - -(values 'a (begin (display "hello world\n") 'b) 'c) - -;; You can also evaluate a region of a buffer using `C-c C-r'. If the -;; code in the region consists of multiple expressions, GDS evaluates -;; them sequentially. For example, try selecting the following three -;; lines and typing `C-c C-r'. - - (display "Arctangent is: ") - (display z) - (newline) - -;; If the code in the region evaluated isn't syntactically balanced, -;; GDS will indicate a read error, for example for this code: - - (let ((z (atan x y))) - (display "Arctangent is: ") - (display z) - (newline) - -;; Finally, if you want to evaluate something quickly that is not in a -;; buffer, you can use `C-c C-e' and type the code to evaluate at the -;; minibuffer prompt. The results are popped up in the same way as -;; for code from a buffer. - -;; ** Breakpoints - -;; Before evaluating Scheme code from an Emacs buffer, you may want to -;; set some breakpoints in it. With GDS you can set breakpoints in -;; Scheme code by typing `C-x SPC'. -;; -;; To see how this works, select the second line of the following code -;; (the `(format ...)' line) and type `C-x SPC'. - -(for-each (lambda (x) - (format #t "~A cubed is ~A\n" x (* x x x))) - (iota 6)) - -;; The two opening parentheses in that line should now be highlighted -;; in red, to show that breakpoints have been set at the start of the -;; `(format ...)' and `(* x x x)' expressions. Then evaluate the -;; whole for-each expression by typing `C-M-x' ... -;; -;; In the upper half of your Emacs, a buffer appears showing you the -;; Scheme stack. -;; -;; In the lower half, the `(format ...)' expression is highlighted. -;; -;; What has happened is that Guile started evaluating the for-each -;; code, but then hit the breakpoint that you set on the start of the -;; format expression. Guile therefore pauses the evaluation at that -;; point and passes the stack (which encapsulates everything that is -;; interesting about the state of Guile at that point) to GDS. You -;; can then explore the stack and decide how to tell Guile to -;; continue. -;; -;; - If you move your mouse over any of the identifiers in the -;; highlighted code, a help echo (or tooltip) will appear to tell -;; you that identifier's current value. (Note though that this only -;; works when the stack buffer is selected. So if you have switched -;; to this buffer in order to scroll down and read these lines, you -;; will need to switch back to the stack buffer before trying this -;; out.) -;; -;; - In the stack buffer, the "=>" on the left shows you that the top -;; frame is currently selected. You can move up and down the stack -;; by pressing the up and down arrows (or `u' and `d'). As you do -;; this, GDS will change the highlight in the lower window to show -;; the code that corresponds to the selected stack frame. -;; -;; - You can evaluate an arbitrary expression in the local environment -;; of the selected stack frame by typing `e' followed by the -;; expression. -;; -;; - You can show various bits of information about the selected frame -;; by typing `I', `A' and `S'. Feel free to try these now, to see -;; what they do. -;; -;; You also have control over the continuing evaluation of this code. -;; Here are some of the things you can do - please try them as you -;; read. -;; -;; - `g' tells Guile to continue execution normally. In this case -;; that means that evaluation will continue until it hits the next -;; breakpoint, which is on the `(* x x x)' expression. -;; -;; - `SPC' tells Guile to continue until the next significant event in -;; the same source file as the selected frame. A "significant -;; event" means either beginning to evaluate an expression in the -;; relevant file, or completing such an evaluation, in which case -;; GDS tells you the value that it is returning. Pressing `SPC' -;; repeatedly is a nice way to step through all the details of the -;; code in a given file, but stepping over calls that involve code -;; from other files. -;; -;; - `o' tells Guile to continue execution until the selected stack -;; frame completes, and then to show its return value. - -;; Local Variables: -;; mode: scheme -;; End: diff --git a/emacs/gds.el b/emacs/gds.el deleted file mode 100644 index 991ba7504..000000000 --- a/emacs/gds.el +++ /dev/null @@ -1,639 +0,0 @@ -;;; gds.el -- frontend for Guile development in Emacs - -;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc. -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free -;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -;;;; 02111-1307 USA - -; TODO: -; ?transcript -; scheme-mode menu -; interrupt/sigint/async-break -; (module browsing) -; load file -; doing common protocol from debugger -; thread override for debugging - -;;;; Prerequisites. - -(require 'scheme) -(require 'cl) -(require 'gds-server) -(require 'gds-scheme) - -;; The subprocess object for the debug server. -(defvar gds-debug-server nil) - -(defvar gds-unix-socket-name (format "/tmp/.gds-socket-%d" (emacs-pid)) - "Name of the Unix domain socket that GDS will listen on.") - -(defvar gds-tcp-port 8333 - "The TCP port number that GDS will listen on.") - -(defun gds-run-debug-server () - "Start (or restart, if already running) the GDS debug server process." - (interactive) - (if gds-debug-server (gds-kill-debug-server)) - (setq gds-debug-server - (gds-start-server "gds-debug" - gds-unix-socket-name - gds-tcp-port - 'gds-debug-protocol)) - (process-kill-without-query gds-debug-server) - ;; Add the Unix socket name to the environment, so that Guile - ;; clients started from within this Emacs will be able to use it, - ;; and thereby ensure that they connect to the GDS in this Emacs. - (setenv "GDS_UNIX_SOCKET_NAME" gds-unix-socket-name)) - -(defun gds-kill-debug-server () - "Kill the GDS debug server process." - (interactive) - (mapcar (function gds-client-gone) - (mapcar (function car) gds-client-info)) - (condition-case nil - (progn - (kill-process gds-debug-server) - (accept-process-output gds-debug-server 0 200)) - (error)) - (setq gds-debug-server nil)) - -;; Send input to the subprocess. -(defun gds-send (string client) - (with-current-buffer (get-buffer-create "*GDS Transcript*") - (goto-char (point-max)) - (insert (number-to-string client) ": (" string ")\n")) - (gds-client-put client 'thread-id nil) - (gds-show-client-status client gds-running-text) - (process-send-string gds-debug-server (format "(%S %s)\n" client string))) - - -;;;; Per-client information - -(defun gds-client-put (client property value) - (let ((client-info (assq client gds-client-info))) - (if client-info - (let ((prop-info (memq property client-info))) - (if prop-info - (setcar (cdr prop-info) value) - (setcdr client-info - (list* property value (cdr client-info))))) - (setq gds-client-info - (cons (list client property value) gds-client-info))))) - -(defun gds-client-get (client property) - (let ((client-info (assq client gds-client-info))) - (and client-info - (cadr (memq property client-info))))) - -(defvar gds-client-info '()) - -(defun gds-get-client-buffer (client) - (let ((existing-buffer (gds-client-get client 'stack-buffer))) - (if (and existing-buffer - (buffer-live-p existing-buffer)) - existing-buffer - (let ((new-buffer (generate-new-buffer (gds-client-get client 'name)))) - (with-current-buffer new-buffer - (gds-debug-mode) - (setq gds-client client) - (setq gds-stack nil)) - (gds-client-put client 'stack-buffer new-buffer) - new-buffer)))) - -(defun gds-client-gone (client &rest ignored) - ;; Kill the client's stack buffer, if it has one. - (let ((stack-buffer (gds-client-get client 'stack-buffer))) - (if (and stack-buffer - (buffer-live-p stack-buffer)) - (kill-buffer stack-buffer))) - ;; Dissociate all the client's associated buffers. - (mapcar (function (lambda (buffer) - (if (buffer-live-p buffer) - (with-current-buffer buffer - (gds-dissociate-buffer))))) - (copy-sequence (gds-client-get client 'associated-buffers))) - ;; Remove this client's record from gds-client-info. - (setq gds-client-info (delq (assq client gds-client-info) gds-client-info))) - -(defvar gds-client nil) -(make-variable-buffer-local 'gds-client) - -(defvar gds-stack nil) -(make-variable-buffer-local 'gds-stack) - -(defvar gds-tweaking nil) -(make-variable-buffer-local 'gds-tweaking) - -(defvar gds-selected-frame-index nil) -(make-variable-buffer-local 'gds-selected-frame-index) - - -;;;; Debugger protocol - -(defcustom gds-protocol-hook nil - "Hook called on receipt of a protocol form from the GDS client." - :type 'hook - :group 'gds) - -(defun gds-debug-protocol (client form) - (run-hook-with-args 'gds-protocol-hook form) - (or (eq client '*) - (let ((proc (car form))) - (cond ((eq proc 'name) - ;; (name ...) - client name. - (gds-client-put client 'name (caddr form))) - - ((eq proc 'stack) - ;; (stack ...) - stack information. - (with-current-buffer (gds-get-client-buffer client) - (setq gds-stack (cddr form)) - (setq gds-tweaking (memq 'instead (cadr gds-stack))) - (setq gds-selected-frame-index (cadr form)) - (gds-display-stack))) - - ((eq proc 'closed) - ;; (closed) - client has gone/died. - (gds-client-gone client)) - - ((eq proc 'eval-result) - ;; (eval-result RESULT) - result of evaluation. - (if gds-last-eval-result - (message "%s" (cadr form)) - (setq gds-last-eval-result (cadr form)))) - - ((eq proc 'info-result) - ;; (info-result RESULT) - info about selected frame. - (message "%s" (cadr form))) - - ((eq proc 'thread-id) - ;; (thread-id THREAD) - says which client thread is reading. - (let ((thread-id (cadr form)) - (debug-thread-id (gds-client-get client 'debug-thread-id))) - (if (and debug-thread-id - (/= thread-id debug-thread-id)) - ;; Tell the newly reading thread to go away. - (gds-send "dismiss" client) - ;; Either there's no current debug-thread-id, or - ;; the thread now reading is the debug thread. - (if debug-thread-id - (progn - ;; Reset the debug-thread-id. - (gds-client-put client 'debug-thread-id nil) - ;; Indicate debug status in modelines. - (gds-show-client-status client gds-debug-text)) - ;; Indicate normal read status in modelines.. - (gds-show-client-status client gds-ready-text))))) - - ((eq proc 'debug-thread-id) - ;; (debug-thread-id THREAD) - debug override indication. - (gds-client-put client 'debug-thread-id (cadr form)) - ;; If another thread is already reading, send it away. - (if (gds-client-get client 'thread-id) - (gds-send "dismiss" client))) - - (t - ;; Non-debug-specific protocol. - (gds-nondebug-protocol client proc (cdr form))))))) - - -;;;; Displaying a stack - -(define-derived-mode gds-debug-mode - scheme-mode - "Guile-Debug" - "Major mode for debugging a Guile client application." - (use-local-map gds-mode-map)) - -(defun gds-display-stack-first-line () - (let ((flags (cadr gds-stack))) - (cond ((memq 'application flags) - (insert "Calling procedure:\n")) - ((memq 'evaluation flags) - (insert "Evaluating expression" - (cond ((stringp gds-tweaking) (format " (tweaked: %s)" - gds-tweaking)) - (gds-tweaking " (tweakable)") - (t "")) - ":\n")) - ((memq 'return flags) - (let ((value (cadr (memq 'return flags)))) - (while (string-match "\n" value) - (setq value (replace-match "\\n" nil t value))) - (insert "Return value" - (cond ((stringp gds-tweaking) (format " (tweaked: %s)" - gds-tweaking)) - (gds-tweaking " (tweakable)") - (t "")) - ": " value "\n"))) - ((memq 'error flags) - (let ((value (cadr (memq 'error flags)))) - (while (string-match "\n" value) - (setq value (replace-match "\\n" nil t value))) - (insert "Error: " value "\n"))) - (t - (insert "Stack: " (prin1-to-string flags) "\n"))))) - -(defun gds-display-stack () - (if gds-undisplay-timer - (cancel-timer gds-undisplay-timer)) - (setq gds-undisplay-timer nil) - ;(setq buffer-read-only nil) - (mapcar 'delete-overlay - (overlays-in (point-min) (point-max))) - (erase-buffer) - (gds-display-stack-first-line) - (let ((frames (car gds-stack))) - (while frames - (let ((frame-text (cadr (car frames))) - (frame-source (caddr (car frames)))) - (while (string-match "\n" frame-text) - (setq frame-text (replace-match "\\n" nil t frame-text))) - (insert " " - (if frame-source "s" " ") - frame-text - "\n")) - (setq frames (cdr frames)))) - ;(setq buffer-read-only t) - (gds-show-selected-frame)) - -(defun gds-tweak (expr) - (interactive "sTweak expression or return value: ") - (or gds-tweaking - (error "The current stack cannot be tweaked")) - (setq gds-tweaking - (if (> (length expr) 0) - expr - t)) - (save-excursion - (goto-char (point-min)) - (delete-region (point) (progn (forward-line 1) (point))) - (gds-display-stack-first-line))) - -(defvar gds-undisplay-timer nil) -(make-variable-buffer-local 'gds-undisplay-timer) - -(defvar gds-undisplay-wait 1) - -(defun gds-undisplay-buffer () - (if gds-undisplay-timer - (cancel-timer gds-undisplay-timer)) - (setq gds-undisplay-timer - (run-at-time gds-undisplay-wait - nil - (function kill-buffer) - (current-buffer)))) - -(defun gds-show-selected-frame () - (setq gds-local-var-cache nil) - (goto-char (point-min)) - (forward-line (+ gds-selected-frame-index 1)) - (delete-char 3) - (insert "=> ") - (beginning-of-line) - (gds-show-selected-frame-source (caddr (nth gds-selected-frame-index - (car gds-stack))))) - -(defun gds-unshow-selected-frame () - (if gds-frame-source-overlay - (move-overlay gds-frame-source-overlay 0 0)) - (save-excursion - (goto-char (point-min)) - (forward-line (+ gds-selected-frame-index 1)) - (delete-char 3) - (insert " "))) - -;; Overlay used to highlight the source expression corresponding to -;; the selected frame. -(defvar gds-frame-source-overlay nil) - -(defcustom gds-source-file-name-transforms nil - "Alist of regexps and substitutions for transforming Scheme source -file names. Each element in the alist is (REGEXP . SUBSTITUTION). -Each source file name in a Guile backtrace is compared against each -REGEXP in turn until the first one that matches, then `replace-match' -is called with SUBSTITUTION to transform that file name. - -This mechanism targets the situation where you are working on a Guile -application and want to install it, in /usr/local say, before each -test run. In this situation, even though Guile is reading your Scheme -files from /usr/local/share/guile, you probably want Emacs to pop up -the corresponding files from your working codebase instead. Therefore -you would add an element to this alist to transform -\"^/usr/local/share/guile/whatever\" to \"~/codebase/whatever\"." - :type '(alist :key-type regexp :value-type string) - :group 'gds) - -(defun gds-show-selected-frame-source (source) - ;; Highlight the frame source, if possible. - (if source - (let ((filename (car source)) - (client gds-client) - (transforms gds-source-file-name-transforms)) - ;; Apply possible transforms to the source file name. - (while transforms - (if (string-match (caar transforms) filename) - (let ((trans-fn (replace-match (cdar transforms) - t nil filename))) - (if (file-readable-p trans-fn) - (setq filename trans-fn - transforms nil)))) - (setq transforms (cdr transforms))) - ;; Try to map the (possibly transformed) source file to a - ;; buffer. - (let ((source-buffer (gds-source-file-name-to-buffer filename))) - (if source-buffer - (with-current-buffer source-buffer - (if gds-frame-source-overlay - nil - (setq gds-frame-source-overlay (make-overlay 0 0)) - (overlay-put gds-frame-source-overlay 'face 'highlight) - (overlay-put gds-frame-source-overlay - 'help-echo - (function gds-show-local-var))) - ;; Move to source line. Note that Guile line numbering - ;; is 0-based, while Emacs numbering is 1-based. - (save-restriction - (widen) - (goto-line (+ (cadr source) 1)) - (move-to-column (caddr source)) - (move-overlay gds-frame-source-overlay - (point) - (if (not (looking-at ")")) - (save-excursion (forward-sexp 1) (point)) - ;; It seems that the source - ;; coordinates for backquoted - ;; expressions are at the end of the - ;; sexp rather than the beginning... - (save-excursion (forward-char 1) - (backward-sexp 1) (point))) - (current-buffer))) - ;; Record that this source buffer has been touched by a - ;; GDS client process. - (setq gds-last-touched-by client)) - (message "Source for this frame cannot be shown: %s:%d:%d" - filename - (cadr source) - (caddr source))))) - (message "Source for this frame was not recorded")) - (gds-display-buffers)) - -(defvar gds-local-var-cache nil) - -(defun gds-show-local-var (window overlay position) - (let ((frame-index gds-selected-frame-index) - (client gds-client)) - (with-current-buffer (overlay-buffer overlay) - (save-excursion - (goto-char position) - (let ((gds-selected-frame-index frame-index) - (gds-client client) - (varname (thing-at-point 'symbol)) - (state (parse-partial-sexp (overlay-start overlay) (point)))) - (when (and gds-selected-frame-index - gds-client - varname - (not (or (nth 3 state) - (nth 4 state)))) - (set-text-properties 0 (length varname) nil varname) - (let ((existing (assoc varname gds-local-var-cache))) - (if existing - (cdr existing) - (gds-evaluate varname) - (setq gds-last-eval-result nil) - (while (not gds-last-eval-result) - (accept-process-output gds-debug-server)) - (setq gds-local-var-cache - (cons (cons varname gds-last-eval-result) - gds-local-var-cache)) - gds-last-eval-result)))))))) - -(defun gds-source-file-name-to-buffer (filename) - ;; See if filename begins with gds-emacs-buffer-port-name-prefix. - (if (string-match (concat "^" - (regexp-quote gds-emacs-buffer-port-name-prefix)) - filename) - ;; It does, so get the named buffer. - (get-buffer (substring filename (match-end 0))) - ;; It doesn't, so treat as a file name. - (and (file-readable-p filename) - (find-file-noselect filename)))) - -(defun gds-select-stack-frame (&optional frame-index) - (interactive) - (let ((new-frame-index (or frame-index - (gds-current-line-frame-index)))) - (or (and (>= new-frame-index 0) - (< new-frame-index (length (car gds-stack)))) - (error (if frame-index - "No more frames in this direction" - "No frame here"))) - (gds-unshow-selected-frame) - (setq gds-selected-frame-index new-frame-index) - (gds-show-selected-frame))) - -(defun gds-up () - (interactive) - (gds-select-stack-frame (- gds-selected-frame-index 1))) - -(defun gds-down () - (interactive) - (gds-select-stack-frame (+ gds-selected-frame-index 1))) - -(defun gds-current-line-frame-index () - (- (count-lines (point-min) - (save-excursion - (beginning-of-line) - (point))) - 1)) - -(defun gds-display-buffers () - (let ((buf (current-buffer))) - ;; If there's already a window showing the buffer, use it. - (let ((window (get-buffer-window buf t))) - (if window - (progn - (make-frame-visible (window-frame window)) - (select-window window)) - (switch-to-buffer buf) - (setq window (get-buffer-window buf t)))) - ;; If there is an associated source buffer, display it as well. - (if (and gds-frame-source-overlay - (overlay-end gds-frame-source-overlay) - (> (overlay-end gds-frame-source-overlay) 1)) - (progn - (delete-other-windows) - (let ((window (display-buffer - (overlay-buffer gds-frame-source-overlay)))) - (set-window-point window - (overlay-start gds-frame-source-overlay))))))) - - -;;;; Debugger commands. - -;; Typically but not necessarily used from the `stack' view. - -(defun gds-send-tweaking () - (if (stringp gds-tweaking) - (gds-send (format "tweak %S" gds-tweaking) gds-client))) - -(defun gds-go () - (interactive) - (gds-send-tweaking) - (gds-send "continue" gds-client) - (gds-unshow-selected-frame) - (gds-undisplay-buffer)) - -(defvar gds-last-eval-result t) - -(defun gds-evaluate (expr) - (interactive "sEvaluate variable or expression: ") - (gds-send (format "evaluate %d %s" - gds-selected-frame-index - (prin1-to-string expr)) - gds-client)) - -(defun gds-frame-info () - (interactive) - (gds-send (format "info-frame %d" gds-selected-frame-index) - gds-client)) - -(defun gds-frame-args () - (interactive) - (gds-send (format "info-args %d" gds-selected-frame-index) - gds-client)) - -(defun gds-proc-source () - (interactive) - (gds-send (format "proc-source %d" gds-selected-frame-index) - gds-client)) - -(defun gds-traps-here () - (interactive) - (gds-send "traps-here" gds-client)) - -(defun gds-step-into () - (interactive) - (gds-send-tweaking) - (gds-send (format "step-into %d" gds-selected-frame-index) - gds-client) - (gds-unshow-selected-frame) - (gds-undisplay-buffer)) - -(defun gds-step-over () - (interactive) - (gds-send-tweaking) - (gds-send (format "step-over %d" gds-selected-frame-index) - gds-client) - (gds-unshow-selected-frame) - (gds-undisplay-buffer)) - -(defun gds-step-file () - (interactive) - (gds-send-tweaking) - (gds-send (format "step-file %d" gds-selected-frame-index) - gds-client) - (gds-unshow-selected-frame) - (gds-undisplay-buffer)) - - - - -;;;; Guile Interaction mode keymap and menu items. - -(defvar gds-mode-map (make-sparse-keymap)) -(define-key gds-mode-map "c" (function gds-go)) -(define-key gds-mode-map "g" (function gds-go)) -(define-key gds-mode-map "q" (function gds-go)) -(define-key gds-mode-map "e" (function gds-evaluate)) -(define-key gds-mode-map "I" (function gds-frame-info)) -(define-key gds-mode-map "A" (function gds-frame-args)) -(define-key gds-mode-map "S" (function gds-proc-source)) -(define-key gds-mode-map "T" (function gds-traps-here)) -(define-key gds-mode-map "\C-m" (function gds-select-stack-frame)) -(define-key gds-mode-map "u" (function gds-up)) -(define-key gds-mode-map [up] (function gds-up)) -(define-key gds-mode-map "\C-p" (function gds-up)) -(define-key gds-mode-map "d" (function gds-down)) -(define-key gds-mode-map [down] (function gds-down)) -(define-key gds-mode-map "\C-n" (function gds-down)) -(define-key gds-mode-map " " (function gds-step-file)) -(define-key gds-mode-map "i" (function gds-step-into)) -(define-key gds-mode-map "o" (function gds-step-over)) -(define-key gds-mode-map "t" (function gds-tweak)) - - -(defvar gds-menu nil - "Global menu for GDS commands.") -(if nil;gds-menu - nil - (setq gds-menu (make-sparse-keymap "Guile-Debug")) - (define-key gds-menu [traps-here] - '(menu-item "Show Traps Here" gds-traps-here)) - (define-key gds-menu [proc-source] - '(menu-item "Show Procedure Source" gds-proc-source)) - (define-key gds-menu [frame-args] - '(menu-item "Show Frame Args" gds-frame-args)) - (define-key gds-menu [frame-info] - '(menu-item "Show Frame Info" gds-frame-info)) - (define-key gds-menu [separator-1] - '("--")) - (define-key gds-menu [evaluate] - '(menu-item "Evaluate..." gds-evaluate)) - (define-key gds-menu [separator-2] - '("--")) - (define-key gds-menu [down] - '(menu-item "Move Down A Frame" gds-down)) - (define-key gds-menu [up] - '(menu-item "Move Up A Frame" gds-up)) - (define-key gds-menu [separator-3] - '("--")) - (define-key gds-menu [step-over] - '(menu-item "Step Over Current Expression" gds-step-over)) - (define-key gds-menu [step-into] - '(menu-item "Step Into Current Expression" gds-step-into)) - (define-key gds-menu [step-file] - '(menu-item "Step Through Current Source File" gds-step-file)) - (define-key gds-menu [separator-4] - '("--")) - (define-key gds-menu [go] - '(menu-item "Go [continue execution]" gds-go)) - (define-key gds-mode-map [menu-bar gds-debug] - (cons "Guile-Debug" gds-menu))) - - -;;;; Autostarting the GDS server. - -(defcustom gds-autorun-debug-server t - "Whether to automatically run the GDS server when `gds.el' is loaded." - :type 'boolean - :group 'gds) - -(defcustom gds-server-socket-type 'tcp - "This option is now obsolete and has no effect." - :group 'gds - :type '(choice (const :tag "TCP" tcp) - (const :tag "Unix" unix))) - -;;;; If requested, autostart the server after loading. - -(if (and gds-autorun-debug-server - (not gds-debug-server)) - (gds-run-debug-server)) - -;;;; The end! - -(provide 'gds) - -;;; gds.el ends here. diff --git a/module/Makefile.am b/module/Makefile.am index 0e50b7119..aad8c7080 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -183,7 +183,6 @@ ICE_9_SOURCES = \ ice-9/control.scm \ ice-9/curried-definitions.scm \ ice-9/debug.scm \ - ice-9/debugger.scm \ ice-9/documentation.scm \ ice-9/expect.scm \ ice-9/format.scm \ @@ -229,7 +228,6 @@ ICE_9_SOURCES = \ ice-9/weak-vector.scm \ ice-9/list.scm \ ice-9/serialize.scm \ - ice-9/gds-server.scm \ ice-9/vlist.scm SRFI_SOURCES = \ @@ -346,7 +344,6 @@ LIB_SOURCES = \ EXTRA_DIST += oop/ChangeLog-2008 NOCOMP_SOURCES = \ - ice-9/gds-client.scm \ ice-9/match.upstream.scm \ ice-9/psyntax.scm \ ice-9/r6rs-libraries.scm \ diff --git a/module/ice-9/gds-client.scm b/module/ice-9/gds-client.scm deleted file mode 100755 index 848b77485..000000000 --- a/module/ice-9/gds-client.scm +++ /dev/null @@ -1,583 +0,0 @@ -(define-module (ice-9 gds-client) - #:use-module (oop goops) - #:use-module (oop goops describe) - #:use-module (ice-9 debugging trace) - #:use-module (ice-9 debugging traps) - #:use-module (ice-9 debugging trc) - #:use-module (ice-9 debugging steps) - #:use-module (ice-9 pretty-print) - #:use-module (ice-9 regex) - #:use-module (ice-9 session) - #:use-module (ice-9 string-fun) - #:export (gds-debug-trap - run-utility - gds-accept-input)) - -(use-modules (ice-9 debugger utils)) - -(use-modules (ice-9 debugger)) - -(define gds-port #f) - -;; Return an integer that somehow identifies the current thread. -(define (get-thread-id) - (let ((root (dynamic-root))) - (cond ((integer? root) - root) - ((pair? root) - (object-address root)) - (else - (error "Unexpected dynamic root:" root))))) - -;; gds-debug-read is a high-priority read. The (debug-thread-id ID) -;; form causes the frontend to dismiss any reads from threads whose id -;; is not ID, until it receives the (thread-id ...) form with the same -;; id as ID. Dismissing the reads of any other threads (by sending a -;; form that is otherwise ignored) causes those threads to release the -;; read mutex, which allows the (gds-read) here to proceed. -(define (gds-debug-read) - (write-form `(debug-thread-id ,(get-thread-id))) - (gds-read)) - -(define (gds-debug-trap trap-context) - "Invoke the GDS debugger to explore the stack at the specified trap." - (connect-to-gds) - (start-stack 'debugger - (let* ((stack (tc:stack trap-context)) - (flags1 (let ((trap-type (tc:type trap-context))) - (case trap-type - ((#:return #:error) - (list trap-type - (tc:return-value trap-context))) - (else - (list trap-type))))) - (flags (if (tc:continuation trap-context) - (cons #:continuable flags1) - flags1)) - (fired-traps (tc:fired-traps trap-context)) - (special-index (and (= (length fired-traps) 1) - (is-a? (car fired-traps) <exit-trap>) - (eq? (tc:type trap-context) #:return) - (- (tc:depth trap-context) - (slot-ref (car fired-traps) 'depth))))) - ;; Write current stack to the frontend. - (write-form (list 'stack - (if (and special-index (> special-index 0)) - special-index - 0) - (stack->emacs-readable stack) - (append (flags->emacs-readable flags) - (slot-ref trap-context - 'handler-return-syms)))) - ;; Now wait for instruction. - (let loop ((protocol (gds-debug-read))) - ;; Act on it. - (case (car protocol) - ((tweak) - ;; Request to tweak the handler return value. - (let ((tweaking (catch #t - (lambda () - (list (with-input-from-string - (cadr protocol) - read))) - (lambda ignored #f)))) - (if tweaking - (slot-set! trap-context - 'handler-return-value - (cons 'instead (car tweaking))))) - (loop (gds-debug-read))) - ((continue) - ;; Continue (by exiting the debugger). - *unspecified*) - ((evaluate) - ;; Evaluate expression in specified frame. - (eval-in-frame stack (cadr protocol) (caddr protocol)) - (loop (gds-debug-read))) - ((info-frame) - ;; Return frame info. - (let ((frame (stack-ref stack (cadr protocol)))) - (write-form (list 'info-result - (with-output-to-string - (lambda () - (write-frame-long frame)))))) - (loop (gds-debug-read))) - ((info-args) - ;; Return frame args. - (let ((frame (stack-ref stack (cadr protocol)))) - (write-form (list 'info-result - (with-output-to-string - (lambda () - (write-frame-args-long frame)))))) - (loop (gds-debug-read))) - ((proc-source) - ;; Show source of application procedure. - (let* ((frame (stack-ref stack (cadr protocol))) - (proc (frame-procedure frame)) - (source (and proc (procedure-source proc)))) - (write-form (list 'info-result - (if source - (sans-surrounding-whitespace - (with-output-to-string - (lambda () - (pretty-print source)))) - (if proc - "This procedure is coded in C" - "This frame has no procedure"))))) - (loop (gds-debug-read))) - ((traps-here) - ;; Show the traps that fired here. - (write-form (list 'info-result - (with-output-to-string - (lambda () - (for-each describe - (tc:fired-traps trap-context)))))) - (loop (gds-debug-read))) - ((step-into) - ;; Set temporary breakpoint on next trap. - (at-step gds-debug-trap - 1 - #f - (if (memq #:return flags) - #f - (- (stack-length stack) - (cadr protocol))))) - ((step-over) - ;; Set temporary breakpoint on exit from - ;; specified frame. - (at-exit (- (stack-length stack) (cadr protocol)) - gds-debug-trap)) - ((step-file) - ;; Set temporary breakpoint on next trap in same - ;; source file. - (at-step gds-debug-trap - 1 - (frame-file-name (stack-ref stack - (cadr protocol))) - (if (memq #:return flags) - #f - (- (stack-length stack) - (cadr protocol))))) - (else - (safely-handle-nondebug-protocol protocol) - (loop (gds-debug-read)))))))) - -(define (connect-to-gds . application-name) - (or gds-port - (let ((gds-unix-socket-name (getenv "GDS_UNIX_SOCKET_NAME"))) - (set! gds-port - (or (and gds-unix-socket-name - (false-if-exception - (let ((s (socket PF_UNIX SOCK_STREAM 0))) - (connect s AF_UNIX gds-unix-socket-name) - s))) - (false-if-exception - (let ((s (socket PF_INET SOCK_STREAM 0)) - (SOL_TCP 6) - (TCP_NODELAY 1)) - (setsockopt s SOL_TCP TCP_NODELAY 1) - (connect s AF_INET (inet-aton "127.0.0.1") 8333) - s)) - (error "Couldn't connect to GDS by TCP or Unix domain socket"))) - (write-form (list 'name (getpid) (apply client-name application-name)))))) - -(define (client-name . application-name) - (let loop ((args (append application-name (program-arguments)))) - (if (null? args) - (format #f "PID ~A" (getpid)) - (let ((arg (car args))) - (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg) - (loop (cdr args))) - ((string-match "^-" arg) - (loop (cdr args))) - (else - (format #f "~A (PID ~A)" arg (getpid)))))))) - -;;(if (not (defined? 'make-mutex)) -;; (begin -;; (define (make-mutex) #f) -;; (define lock-mutex noop) -;; (define unlock-mutex noop))) - -(define write-mutex (make-mutex)) - -(define (write-form form) - ;; Write any form FORM to GDS. - (lock-mutex write-mutex) - (write form gds-port) - (newline gds-port) - (force-output gds-port) - (unlock-mutex write-mutex)) - -(define (stack->emacs-readable stack) - ;; Return Emacs-readable representation of STACK. - (map (lambda (index) - (frame->emacs-readable (stack-ref stack index))) - (iota (min (stack-length stack) - (cadr (memq 'depth (debug-options))))))) - -(define (frame->emacs-readable frame) - ;; Return Emacs-readable representation of FRAME. - (if (frame-procedure? frame) - (list 'application - (with-output-to-string - (lambda () - (display (if (frame-real? frame) " " "t ")) - (write-frame-short/application frame))) - (source->emacs-readable frame)) - (list 'evaluation - (with-output-to-string - (lambda () - (display (if (frame-real? frame) " " "t ")) - (write-frame-short/expression frame))) - (source->emacs-readable frame)))) - -(define (source->emacs-readable frame) - ;; Return Emacs-readable representation of the filename, line and - ;; column source properties of SOURCE. - (or (frame->source-position frame) 'nil)) - -(define (flags->emacs-readable flags) - ;; Return Emacs-readable representation of trap FLAGS. - (let ((prev #f)) - (map (lambda (flag) - (let ((erf (if (and (keyword? flag) - (not (eq? prev #:return))) - (keyword->symbol flag) - (format #f "~S" flag)))) - (set! prev flag) - erf)) - flags))) - -;; FIXME: the new evaluator breaks this, by removing local-eval. Need to -;; figure out our story in this regard. -(define (eval-in-frame stack index expr) - (write-form - (list 'eval-result - (format #f "~S" - (catch #t - (lambda () - (local-eval (with-input-from-string expr read) - (memoized-environment - (frame-source (stack-ref stack - index))))) - (lambda args - (cons 'ERROR args))))))) - -(set! (behaviour-ordering gds-debug-trap) 100) - -;;; Code below here adds support for interaction between the GDS -;;; client program and the Emacs frontend even when not stopped in the -;;; debugger. - -;; A mutex to control attempts by multiple threads to read protocol -;; back from the frontend. -(define gds-read-mutex (make-mutex)) - -;; Read a protocol instruction from the frontend. -(define (gds-read) - ;; Acquire the read mutex. - (lock-mutex gds-read-mutex) - ;; Tell the front end something that identifies us as a thread. - (write-form `(thread-id ,(get-thread-id))) - ;; Now read, then release the mutex and return what was read. - (let ((x (catch #t - (lambda () (read gds-port)) - (lambda ignored the-eof-object)))) - (unlock-mutex gds-read-mutex) - x)) - -(define (gds-accept-input exit-on-continue) - ;; If reading from the GDS connection returns EOF, we will throw to - ;; this catch. - (catch 'server-eof - (lambda () - (let loop ((protocol (gds-read))) - (if (or (eof-object? protocol) - (and exit-on-continue - (eq? (car protocol) 'continue))) - (throw 'server-eof)) - (safely-handle-nondebug-protocol protocol) - (loop (gds-read)))) - (lambda ignored #f))) - -(define (safely-handle-nondebug-protocol protocol) - ;; This catch covers any internal errors in the GDS code or - ;; protocol. - (catch #t - (lambda () - (lazy-catch #t - (lambda () - (handle-nondebug-protocol protocol)) - save-lazy-trap-context-and-rethrow)) - (lambda (key . args) - (write-form - `(eval-results (error . ,(format #f "~s" protocol)) - ,(if last-lazy-trap-context 't 'nil) - "GDS Internal Error -Please report this to <neil@ossau.uklinux.net>, ideally including: -- a description of the scenario in which this error occurred -- which versions of Guile and guile-debugging you are using -- the error stack, which you can get by clicking on the link below, - and then cut and paste into your report. -Thanks!\n\n" - ,(list (with-output-to-string - (lambda () - (write key) - (display ": ") - (write args) - (newline))))))))) - -;; The key that is used to signal a read error changes from 1.6 to -;; 1.8; here we cover all eventualities by discovering the key -;; dynamically. -(define read-error-key - (catch #t - (lambda () - (with-input-from-string "(+ 3 4" read)) - (lambda (key . args) - key))) - -(define (handle-nondebug-protocol protocol) - (case (car protocol) - - ((eval) - (set! last-lazy-trap-context #f) - (apply (lambda (correlator module port-name line column code flags) - (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-from-root module)))) - (catch read-error-key - (lambda () - (let loop ((exprs '()) (x (read))) - (if (eof-object? x) - ;; Expressions to be evaluated have all - ;; been read. Now evaluate them. - (let loop2 ((exprs (reverse! exprs)) - (results '()) - (n 1)) - (if (null? exprs) - (write-form `(eval-results ,correlator - ,(if last-lazy-trap-context 't 'nil) - ,@results)) - (loop2 (cdr exprs) - (append results (gds-eval (car exprs) m - (if (and (null? (cdr exprs)) - (= n 1)) - #f n))) - (+ n 1)))) - ;; Another complete expression read; add - ;; it to the list. - (begin - (if (and (pair? x) - (memq 'debug flags)) - (install-trap (make <source-trap> - #:expression x - #:behaviour gds-debug-trap))) - (loop (cons x exprs) (read)))))) - (lambda (key . args) - (write-form `(eval-results - ,correlator - ,(if last-lazy-trap-context 't 'nil) - ,(with-output-to-string - (lambda () - (display ";;; Reading expressions") - (display " to evaluate\n") - (apply display-error #f - (current-output-port) args))) - ("error-in-read"))))))))) - (cdr protocol))) - - ((complete) - (let ((matches (apropos-internal - (string-append "^" (regexp-quote (cadr protocol)))))) - (cond ((null? matches) - (write-form '(completion-result nil))) - (else - ;;(write matches (current-error-port)) - ;;(newline (current-error-port)) - (let ((match - (let loop ((match (symbol->string (car matches))) - (matches (cdr matches))) - ;;(write match (current-error-port)) - ;;(newline (current-error-port)) - ;;(write matches (current-error-port)) - ;;(newline (current-error-port)) - (if (null? matches) - match - (if (string-prefix=? match - (symbol->string (car matches))) - (loop match (cdr matches)) - (loop (substring match 0 - (- (string-length match) 1)) - matches)))))) - (if (string=? match (cadr protocol)) - (write-form `(completion-result - ,(map symbol->string matches))) - (write-form `(completion-result - ,match)))))))) - - ((debug-lazy-trap-context) - (if last-lazy-trap-context - (gds-debug-trap last-lazy-trap-context) - (error "There is no stack available to show"))) - - (else - (error "Unexpected protocol:" protocol)))) - -(define (resolve-module-from-root name) - (save-module-excursion - (lambda () - (set-current-module the-root-module) - (resolve-module name)))) - -(define (gds-eval x m part) - ;; 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))) - ;; Now do evaluation. - (let ((intro (if part - (format #f ";;; Evaluating expression ~A" part) - ";;; Evaluating")) - (value #f)) - (let* ((do-eval (if m - (lambda () - (display intro) - (display " in module ") - (write (module-name m)) - (newline) - (set! value - (call-with-values (lambda () - (start-stack 'gds-eval-stack - (eval x m))) - value-consumer))) - (lambda () - (display intro) - (display " in current module ") - (write (module-name (current-module))) - (newline) - (set! value - (call-with-values (lambda () - (start-stack 'gds-eval-stack - (primitive-eval x))) - value-consumer))))) - (output - (with-output-to-string - (lambda () - (catch #t - (lambda () - (lazy-catch #t - do-eval - save-lazy-trap-context-and-rethrow)) - (lambda (key . args) - (case key - ((misc-error signal unbound-variable numerical-overflow) - (apply display-error #f - (current-output-port) args) - (set! value '("error-in-evaluation"))) - (else - (display "EXCEPTION: ") - (display key) - (display " ") - (write args) - (newline) - (set! value - '("unhandled-exception-in-evaluation")))))))))) - (list output value)))) - -(define last-lazy-trap-context #f) - -(define (save-lazy-trap-context-and-rethrow key . args) - (set! last-lazy-trap-context - (throw->trap-context key args save-lazy-trap-context-and-rethrow)) - (apply throw key args)) - -(define (run-utility) - (connect-to-gds) - (write (getpid)) - (newline) - (force-output) - (module-use! (resolve-module '(guile-user)) - (resolve-interface '(ice-9 session))) - (gds-accept-input #f)) - -(define-method (trap-description (trap <trap>)) - (let loop ((description (list (class-name (class-of trap)))) - (next 'installed?)) - (case next - ((installed?) - (loop (if (slot-ref trap 'installed) - (cons 'installed description) - description) - 'conditional?)) - ((conditional?) - (loop (if (slot-ref trap 'condition) - (cons 'conditional description) - description) - 'skip-count)) - ((skip-count) - (loop (let ((skip-count (slot-ref trap 'skip-count))) - (if (zero? skip-count) - description - (cons* skip-count 'skip-count description))) - 'single-shot?)) - ((single-shot?) - (loop (if (slot-ref trap 'single-shot) - (cons 'single-shot description) - description) - 'done)) - (else - (reverse! description))))) - -(define-method (trap-description (trap <procedure-trap>)) - (let ((description (next-method))) - (set-cdr! description - (cons (procedure-name (slot-ref trap 'procedure)) - (cdr description))) - description)) - -(define-method (trap-description (trap <source-trap>)) - (let ((description (next-method))) - (set-cdr! description - (cons (format #f "~s" (slot-ref trap 'expression)) - (cdr description))) - description)) - -(define-method (trap-description (trap <location-trap>)) - (let ((description (next-method))) - (set-cdr! description - (cons* (slot-ref trap 'file-regexp) - (slot-ref trap 'line) - (slot-ref trap 'column) - (cdr description))) - description)) - -(define (gds-trace-trap trap-context) - (connect-to-gds) - (gds-do-trace trap-context) - (at-exit (tc:depth trap-context) gds-do-trace)) - -(define (gds-do-trace trap-context) - (write-form (list 'trace - (format #f - "~3@a: ~a" - (trace/stack-real-depth trap-context) - (trace/info trap-context))))) - -(define (gds-trace-subtree trap-context) - (connect-to-gds) - (gds-do-trace trap-context) - (let ((step-trap (make <step-trap> #:behaviour gds-do-trace))) - (install-trap step-trap) - (at-exit (tc:depth trap-context) - (lambda (trap-context) - (uninstall-trap step-trap))))) - -;;; (ice-9 gds-client) ends here. diff --git a/module/ice-9/gds-server.scm b/module/ice-9/gds-server.scm deleted file mode 100644 index 5ec867535..000000000 --- a/module/ice-9/gds-server.scm +++ /dev/null @@ -1,188 +0,0 @@ -;;;; Guile Debugger UI server - -;;; Copyright (C) 2003 Free Software Foundation, Inc. -;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (ice-9 gds-server) - #:export (run-server)) - -;; UI is normally via a pipe to Emacs, so make sure to flush output -;; every time we write. -(define (write-to-ui form) - (write form) - (newline) - (force-output)) - -(define (trc . args) - (write-to-ui (cons '* args))) - -(define (with-error->eof proc port) - (catch #t - (lambda () (proc port)) - (lambda args the-eof-object))) - -(define connection->id (make-object-property)) - -(define (run-server unix-socket-name tcp-port) - - (let ((unix-server (socket PF_UNIX SOCK_STREAM 0)) - (tcp-server (socket PF_INET SOCK_STREAM 0))) - - ;; Bind and start listening on the Unix domain socket. - (false-if-exception (delete-file unix-socket-name)) - (bind unix-server AF_UNIX unix-socket-name) - (listen unix-server 5) - - ;; Bind and start listening on the TCP socket. - (setsockopt tcp-server SOL_SOCKET SO_REUSEADDR 1) - (false-if-exception (bind tcp-server AF_INET INADDR_ANY tcp-port)) - (listen tcp-server 5) - - ;; Main loop. - (let loop ((clients '()) (readable-sockets '())) - - (define (do-read port) - (cond ((eq? port (current-input-port)) - (do-read-from-ui)) - ((eq? port unix-server) - (accept-new-client unix-server)) - ((eq? port tcp-server) - (accept-new-client tcp-server)) - (else - (do-read-from-client port)))) - - (define (do-read-from-ui) - (trc "reading from ui") - (let* ((form (with-error->eof read (current-input-port))) - (client (assq-ref (map (lambda (port) - (cons (connection->id port) port)) - clients) - (car form)))) - (with-error->eof read-char (current-input-port)) - (if client - (begin - (write (cdr form) client) - (newline client)) - (trc "client not found"))) - clients) - - (define (accept-new-client server) - (let ((new-port (car (accept server)))) - ;; Read the client's ID. - (let ((name-form (read new-port))) - ;; Absorb the following newline character. - (read-char new-port) - ;; Check that we have a name form. - (or (eq? (car name-form) 'name) - (error "Invalid name form:" name-form)) - ;; Store an association from the connection to the ID. - (set! (connection->id new-port) (cadr name-form)) - ;; Pass the name form on to Emacs. - (write-to-ui (cons (connection->id new-port) name-form))) - ;; Add the new connection to the set that we select on. - (cons new-port clients))) - - (define (do-read-from-client port) - (trc "reading from client") - (let ((next-char (with-error->eof peek-char port))) - ;;(trc 'next-char next-char) - (cond ((eof-object? next-char) - (write-to-ui (list (connection->id port) 'closed)) - (close port) - (delq port clients)) - ((char=? next-char #\() - (write-to-ui (cons (connection->id port) - (with-error->eof read port))) - clients) - (else - (with-error->eof read-char port) - clients)))) - - ;;(trc 'clients clients) - ;;(trc 'readable-sockets readable-sockets) - - (if (null? readable-sockets) - (loop clients (car (select (cons* (current-input-port) - unix-server - tcp-server - clients) - '() - '()))) - (loop (do-read (car readable-sockets)) (cdr readable-sockets)))))) - -;; What happens if there are multiple copies of Emacs running on the -;; same machine, and they all try to start up the GDS server? They -;; can't all listen on the same TCP port, so the short answer is that -;; all of them except the first will get an EADDRINUSE error when -;; trying to bind. -;; -;; We want to be able to handle this scenario, though, so that Scheme -;; code can be evaluated, and help invoked, in any of those Emacsen. -;; So we introduce the idea of a "slave server". When a new GDS -;; server gets an EADDRINUSE bind error, the implication is that there -;; is already a GDS server running, so the new server instead connects -;; to the existing one (by issuing a connect to the GDS port number). -;; -;; Let's call the first server the "master", and the new one the -;; "slave". In principle the master can now proxy any GDS client -;; connections through to the slave, so long as there is sufficient -;; information in the protocol for it to decide when and how to do -;; this. -;; -;; The basic information and mechanism that we need for this is as -;; follows. -;; -;; - A unique ID for each Emacs; this can be each Emacs's PID. When a -;; slave server connects to the master, it announces itself by sending -;; the protocol (emacs ID). -;; -;; - A way for a client to indicate which Emacs it wants to use. At -;; the protocol level, this is an extra argument in the (name ...) -;; protocol. (The absence of this argument means "no preference". A -;; simplistic master server might then decide to use its own Emacs; a -;; cleverer one might monitor which Emacs appears to be most in use, -;; and use that one.) At the API level this can be an optional -;; argument to the `gds-connect' procedure, and the Emacs GDS code -;; would obviously set this argument when starting a client from -;; within Emacs. -;; -;; We also want a strategy for continuing seamlessly if the master -;; server shuts down. -;; -;; - Each slave server will detect this as an error on the connection -;; to the master socket. Each server then tries to bind to the GDS -;; port again (a race which the OS will resolve), and if that fails, -;; connect again. The result of this is that there should be a new -;; master, and the others all slaves connected to the new master. -;; -;; - Each client will also detect this as an error on the connection -;; to the (master) server. Either the client should try to connect -;; again (perhaps after a short delay), or the reconnection can be -;; delayed until the next time that the client requires the server. -;; (Probably the latter, all done within `gds-read'.) -;; -;; (Historical note: Before this master-slave idea, clients were -;; identified within gds-server.scm and gds*.el by an ID which was -;; actually the file descriptor of their connection to the server. -;; That is no good in the new scheme, because each client's ID must -;; persist when the master server changes, so we now use the client's -;; PID instead. We didn't use PID before because the client/server -;; code was written to be completely asynchronous, which made it -;; tricky for the server to discover each client's PID and associate -;; it with a particular connection. Now we solve that problem by -;; handling the initial protocol exchange synchronously.) -(define (run-slave-server port) - 'not-implemented) |