mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

remove GDS

Browse source 
It is with a sigh that I do this. Farewell, old friend GDS; your bits
will live on, reclaimed and reused in the new debugger.

* module/Makefile.am:
* module/ice-9/gds-client.scm:
* module/ice-9/gds-server.scm: Remove these; we favor Geiser now.

* emacs/Makefile.am:
* emacs/gds-faq.txt:
* emacs/gds-scheme.el:
* emacs/gds-server.el:
* emacs/gds-test.el:
* emacs/gds-test.sh:
* emacs/gds-test.stdin:
* emacs/gds-tutorial.txt:
* emacs/gds.el: Remove GDS files. The docs are still around, as they
  need to be folded into the docmentation of the new debugger.
This commit is contained in:
Andy Wingo 2010-09-24 18:34:02 +02:00
parent d2c7e7de40
commit 178e9d237b
12 changed files with 2 additions and 2684 deletions
Download patch file Download diff file Expand all files Collapse all files

7
emacs/Makefile.am
View file

@ -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

225
emacs/gds-faq.txt
View file

@ -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:

540
emacs/gds-scheme.el
View file

@ -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.

109
emacs/gds-server.el
View file

@ -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.

166
emacs/gds-test.el
View file

@ -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")
)

2
emacs/gds-test.sh
View file

@ -1,2 +0,0 @@
#!/bin/sh
GUILE_LOAD_PATH=$(pwd) emacs --batch --no-site-file -q -l gds-test.el < gds-test.stdin

1
emacs/gds-test.stdin
View file

@ -1 +0,0 @@

223
emacs/gds-tutorial.txt
View file

@ -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:

639
emacs/gds.el
View file

@ -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.