code:
2008-07-17  Neil Jerram  <neil@ossau.uklinux.net>

	* gds-scheme.el (gds-eval-region, gds-eval-expression)
	(gds-eval-defun, gds-eval-last-sexp): Support `C-u' prefix,
	meaning that user wants to single step through the code.

2007-02-06  Clinton Ebadi  <clinton@unknownlamer.org>

        * gds-scheme.el (gds-display-results): Use save-selected-window
        instead of switching to other-window in order to return to the
        proper window in frames with more than two windows.

2007-01-17  Neil Jerram  <neil@ossau.uklinux.net>

	* gds-scheme.el (gds-display-results): Add another binding for
	gds-show-last-stack (RET).
	(scheme-mode-map): And another: C-h S.
	(scheme-mode-map): And an alternative C-h G binding for
	gds-apropos, as we probably should not be using C-h C-g.

2006-11-02  Neil Jerram  <neil@ossau.uklinux.net>

	* gds-scheme.el (gds-choose-client): Change assq to memq, so that
	the mapcar really constructs a list of available clients.

2006-10-14  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el (gds-socket-type-alist): New.
	(gds-run-debug-server): Use gds-server-socket-type and
	gds-socket-type-alist instead of gds-server-port-or-path.
	(gds-server-socket-type): New, replacing gds-server-port-or-path.

2006-10-13  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el (gds-run-debug-server): Use variable
	gds-server-port-or-path instead of hardcoded 8333.
	(gds-server-port-or-path): New.

	* gds-server.el (gds-start-server): Change port arg to
	port-or-path, to support Unix domain sockets.

2006-08-18  Neil Jerram  <neil@ossau.uklinux.net>

	* gds-server.el (gds-start-server): Change "ossau" to "ice-9".

	* gds-scheme.el (gds-start-utility-guile): Change "ossau" to
	"ice-9".

2006-06-19  Neil Jerram  <neil@ossau.uklinux.net>

	* Makefile.am: New file.

	* gds.el, gds-scheme.el, gds-server.el: New files.

2005-07-09  Neil Jerram  <neil@ossau.uklinux.net>

	* Makefile.am, REAME.GDS, gds-client.scm, gds-problems.txt,
	gds-server.scm, gds-tutorial.txt, gds.el, gds.texi: Removed.

2004-03-10  Neil Jerram  <neil@ossau.uklinux.net>

	* guileint: Subdirectory (with contents) removed.  This was a dead
	end of development that only I was working on, and which is now
	superseded by the GDS work in this directory.

2004-02-25  Neil Jerram  <neil@ossau.uklinux.net>

	* gds-client.scm (handle-instruction-1): In `eval' protocol, catch
	and report read errors nicely.

	* gds.el (gds-display-buffers): Don't select the GDS window.

2004-02-22  Neil Jerram  <neil@ossau.uklinux.net>

	* Makefile.am (EXTRA_DIST): Distribute new files.

	* gds-tutorial.txt, gds-problems.txt: New files.

2004-02-21  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el: Add requirements: cl, comint, info.
	(gds-guile-program): New.
	(gds-start): When starting or restarting, kill captive if it
	exists.  Use gds-guile-program instead of just "guile".
	(gds-mode): Use widget minor mode.
	(gds-client-ref): New optional client arg.
	(gds-update-buffers): Don't call widget-setup.
	(gds-heading-face): New.
	(gds-insert-interaction): Various prettifications.
	(gds-heading-insert): New.
	(gds-choose-client): Check that numbers in client and gds-client
	are still valid.
	(gds-eval-expression, gds-apropos): Remove text properties from
	expression to evaluate.
	(gds-mode-map): Don't set widget-mode-map as parent.
	(gds-start-captive): Use gds-guile-program instead of just
	"guile".

	* gds-client.scm (install-breakpoints): Bugfix: avoid null lists
	in traversal.
	(eval-thread, gds-eval): Where expression has multiple parts,
	modify output to say which part is being evaluated.

2004-02-08  Mikael Djurfeldt  <djurfeldt@nada.kth.se>

	* Makefile.am (TAGS_FILES): Use this variable instead of
	ETAGS_ARGS so that TAGS can be built using separate build
	directory.

2004-01-28  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el (gds-handle-client-input): Handle new `thread-status'
	protocol.
	(gds-display-slow-eval): New.
	(gds-client-ref): Bugfix: buf -> (cdr buf).
	(gds-display-buffers): Bugfix: minimum overlay end value is 1, not
	0.
	(gds-evals-in-progress): New.
	(gds-results): New.
	(gds-insert-interaction): Show evaluations in progress (with
	button to interrupt them) and results of last help or evaluation.
	(gds-interrupt-eval): New.
	(gds-debug-trap-hooks, gds-up, gds-down): New.
	(gds-eval-region, gds-eval-expression): Include abbreviated code
	in eval correlator.
	(gds-abbreviated-length, gds-abbreviated): New.
	(gds-mode-map): New keys for gds-debug-trap-hooks, gds-up,
	gds-down.
	(gds-debug-menu): New menu entries for gds-up, gds-down.

	* gds-client.scm (gds-connect): Enable trapping for gds-eval
	stacks.
	(ui-read-thread-proc): Write 'running status earlier.
	(stack->emacs-readable): Limit stack length to 'depth debug
	option.
	(handle-instruction): Update format of eval correlator.
	(handle-instruction-1): Resolve module names from root module
	instead of from current module.
	(resolve-module-from-root): New.
	(handle-instruction-1): New protocol `interrupt-eval'.
	(eval-thread-table): New.
	(eval-thread): Add thread to eval-thread-table; write new protocol
	to frontend to communicate eval thread status; update for new
	correlator format; bind correlator local before entering loop2.
	(gds-eval): Use start-stack 'gds-eval-stack to rebase stack.

	* gds.el (gds-start, gds-start-captive): Do
	`process-kill-without-query' as soon as processes started, ...
	(gds-shutdown, gds-kill-captive): ... instead of here.
	(gds-display-results): More clearly show unspecified results; show
	results in interaction view instead of in separate window.
	(gds-send): Add sent protocol to transcript.

2004-01-26  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el (gds-request-focus, gds-quit): Simplify.  Old algorithm
	left in as a big comment.
	(gds-focus-in-function, gds-focus-in, gds-focus-out-function,
	gds-focus-out): New.

	* gds-client.scm (ui-read-thread-proc): Fix `with-mutex' syntax
	error.

2004-01-25  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el (gds-handle-client-input, gds-async-break,
	gds-select-stack-frame, gds-query-modules, gds-go, gds-next,
	gds-evaluate, gds-step-in, gds-step-out, gds-trace-finish,
	gds-frame-info, gds-frame-args, gds-set-module-breakpoint,
	gds-read-client, gds-choose-client): Change gds-focus-client to
	gds-client.
	(gds-choose-client): Set local value of gds-client to determined
	client.
	(gds-menu): Use gds-client rather than gds-focus-client.
	(gds-client-ref): New.
	(gds-client-blocked): Rewrite using gds-client-ref.
	(gds-display-buffers): Take `client' arg instead of global
	`gds-focus-client'.
	(gds-request-focus): Call gds-display-buffers with explicit arg.

2004-01-20  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el: Changes throughout because of (i) change of gds-send
	args, (ii) introduction of evaluation correlator.

	* gds-client.scm: Extensive changes to implement eval threads, and
	to tidy up and organize the rest of the code.

2003-12-06  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.texi: New.

	* Makefile.am (info_TEXINFOS): Added.

2003-11-27  Neil Jerram  <neil@ossau.uklinux.net>

	Initial support for setting source breakpoints...

	* gds.el (gds-handle-client-input): Handle new `breakpoint-set'
	protocol.
	(gds-breakpoint-face): New.
	(gds-new-breakpoint-before-string): New.
	(gds-new-breakpoint-after-string): New.
	(gds-active-breakpoint-before-string): New.
	(gds-active-breakpoint-after-string): New.
	(gds-source-breakpoint-pos): New.
	(gds-source-breakpoint-overlay-at): New.
	(gds-set-source-breakpoint): New.
	(gds-delete-source-breakpoint): New.
	(gds-region-breakpoint-info): New.
	(gds-eval-region): Include bpinfo in `eval' protocol.
	(scheme-mode-map): New keys for setting and deleting breakpoints.
	(gds-breakpoint-menu): New.
	(gds-menu): Include `gds-breakpoint-menu'.

	* gds-client.scm (handle-instruction-1): Handle bpinfo protocol
	field and pass to `gds-eval'.
	(install-breakpoints): New.
	(gds-eval): Call `install-breakpoints'.

2003-11-19  Neil Jerram  <neil@ossau.uklinux.net>

	* gds-client.scm (start-async-gds-thread): Changes to fix
	interaction between async and debugger threads.
	(gds-connect): Don't send module list immediately after initial
	connection.

	* gds.el (gds-immediate-display): Removed.

2003-11-19  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el (gds-update-buffers): Rewrite to only show one view at a
	time.
	(gds-display-buffers): Remove separate stack buffer display code.
	(gds-switch-to-view), gds-view-interaction, gds-view-stack,
	gds-view-breakpoints, gds-view-browser, gds-view-messages,
	gds-view-menu): New.
	(gds-maybe-skip-region): Removed.
	(gds-maybe-delete-region): Removed.
	(gds-display-types): Removed.
	(gds-display-type-regexp): Removed.
	(gds-displayed-modules): Removed.

2003-11-19  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el (gds-views, gds-promote-view, gds-add-view,
	gds-delete-view, gds-switch-to-view): New.
	(gds-handle-client-input): Use gds-promote-view.
	(gds-update-buffers): Remove unnecessary client arg.
	(gds-module-notify, gds-handle-client-input): Update callers
	accordingly.
	(gds-insert-messages): New.
	(gds-insert-interaction): New (using code from
	gds-update-buffers).
	(gds-update-buffers): Use gds-insert-interaction.

2003-11-17  Rob Browning  <rlb@defaultvalue.org>

	* .cvsignore: new file.

2003-11-11  Neil Jerram  <neil@ossau.uklinux.net>

	* gds.el: New.  (Or rather, first mention in this ChangeLog.)

	* Makefile.am, README.GDS: New.

	* gds-client.scm, gds-server.scm: New (moved here from
	ice-9/debugger/ui-{client,server}.scm).

2003-08-20  Neil Jerram  <neil@ossau.uklinux.net>

	* guileint: New subdirectory.

	* README: Mention it.

2001-11-19  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* README: Use less forking for indexing command.
	Update index.

	* gud-guile.el: New file.

	* update-changelog.el:
	When run as a batch program, invoke `(ucl-update "ChangeLog")'
	instead of `(ucl-update-all)'.

	(ucl-outdir): Delete this var.
	(ucl-update): Arg now specifies change log file
	instead of cvs module directory.
	Make interactive.
	(ucl-update-all): Delete this func.

	* update-changelog.el: New file.

	* patch.el (patch-send):
	Renamed from `patch-submit'.
	Gadzooks what kind of world is this?

2001-10-25  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* README, patch.el:
	New file.

2001-10-25  Thien-Thi Nguyen  <ttn@glug.org>

	* patch.el, README: New files.

2001-06-21  Neil Jerram  <neil@ossau.uklinux.net>

	* guile.el (guile-channel-file): Signal an error if unable to find
	channel.scm.
	Change "gulie" typos to "guile".

2001-05-06  Keisuke Nishida  <kxn30@po.cwru.edu>

	* guile.el (guile:eval): Propagate user interrupt.
	(keywordp): Define it if not defined yet.
	(guile-use-module): New macro.
	(guile-process-import-module): Renamed from guile-process-use-module.

	* guile-emacs.scm (guile-emacs-apropos, guile-emacs-describe):
	New procedures.

	* guile-scheme.el (guile-scheme-mode-map): Use
	`shared-lisp-mode-map' as the parent keymap if
	`lisp-mode-shared-map' is not defined.
	(guile-scheme-module): New variable.
	(guile-scheme-set-module): Set module only when necessary.
	(guile-scheme-eval-print-last-sexp): Insert newline after eval.
	(guile-scheme-complete-table): New variable.
	(guile-scheme-input-symbol): New function.
	(guile-scheme-apropos, guile-scheme-describe,
	guile-scheme-kill-process): New commands.

2001-04-25  Keisuke Nishida  <kxn30@po.cwru.edu>

	* guile.el, guile-scheme.el, guile-emacs.scm: New files.

2001-03-13  Martin Grabmueller  <mgrabmue@cs.tu-berlin.de>

	* guile-c.el (guile-c-edit-docstring): Set fill-column to 63, so
	that fill-paragraph'ed docstrings fit nicely when indented.

2001-03-13  Keisuke Nishida  <kxn30@po.cwru.edu>

	* guile-c.el (guile-c-window-configuration): New variable.
	(guile-c-edit-docstring, guile-c-edit-finish):
	Save/restore window-configuration.

2001-03-12  Keisuke Nishida  <kxn30@po.cwru.edu>

	* guile-c.el (guile-c-deprecate-region): New command.

2001-03-11  Keisuke Nishida  <kxn30@po.cwru.edu>

	* guile-c.el: New file.

2000-05-28  Mikael Djurfeldt  <mdj@thalamus.nada.kth.se>

	* ppexpand.el: New file.

2000-01-18  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>

	* multistring.el: New file.


code:
## Process this file with automake to produce Makefile.in.
##
##  	Copyright (C) 2006, 2008 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE 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, or
##   (at your option) any later version.
##
##   GUILE 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 GUILE; see the file COPYING.LESSER.  If not,
##   write to the Free Software Foundation, Inc., 51 Franklin Street,
##   Fifth Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

dist_lisp_LISP = gds.el gds-server.el gds-scheme.el
ELCFILES =

ETAGS_ARGS = $(dist_lisp_LISP) ChangeLog-2008

license: mit


code:
Index

gud-guile.el --- Support for debugging guile internals
guile-c.el --- Guile C editing commands
guile-scheme.el --- Guile Scheme editing mode
guile.el --- Emacs Guile interface
multistring.el --- editing multiline strings.
patch.el --- mail/apply a patch
ppexpand.el --- temporarily expanding macros in a pretty way.
update-changelog.el --- stitch rcs2log output to ChangeLog

Generated using: for f in *.el ; do sed -e 's/^....//g' -e '1q' $f ; done

path: emacs/README


code:
* 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:


code:
;;; 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.


code:
;;; 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.


code:
;; 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")

  )


code:
#!/bin/sh
GUILE_LOAD_PATH=$(pwd) emacs --batch --no-site-file -q -l gds-test.el < gds-test.stdin


code:
;; 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:


code:
;;; 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.


code:
;;; gud-guile.el --- Support for debugging guile internals

;; Copyright (C) 2001, 2006 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

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Version: 1
;;; Favorite-Favorite: Favorite-Favorite

;;; Commentary:

;; This is a grab bag of stuff for doing "gdb guile" in Emacs.
;; The var `gdb-guile-suggested-gdbinit' has a string that is
;; snarfed from ../HACKING.  (todo: Write `gdb-guile-init' to
;; send it to gdb...)

;;; Code:

(require 'cl)

(defun gdb-guile-display-scm ()
  (interactive)
  (save-excursion
    (let ((sym (thing-at-point 'symbol))
          (proc (get-buffer-process
                 (find-if (lambda (buf)
                            (string-match "^.gud-." (buffer-name buf)))
                          (buffer-list)))))
      (mapc (lambda (template)
              (process-send-string proc (format template sym)))
            (list
             "set gdb_print(%s)\n"
             "printf \"%s: %%s\\n\", gdb_output\n")))))

(defvar gdb-guile-suggested-gdbinit "
define gp
set gdb_print($arg0)
print gdb_output
end
document gp
Executes (object->string arg)
end

define ge
call gdb_read($arg0)
call gdb_eval(gdb_result)
set gdb_print(gdb_result)
print gdb_output
end
document ge
Executes (print (eval (read arg))): ge \"(+ 1 2)\" => 3
end

define gh
call g_help(scm_str2symbol($arg0), 20)
set gdb_print($1)
print gdb_output
end
document gh
Prints help string for arg: gh \"enved-target\"
end
"
  "A useful .gdbinit")

(provide 'gud-guile)

;;; gud-guile.el ends here


code:
;;; guile-c.el --- Guile C editing commands

;; Copyright (C) 2001, 2006 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

;;; Commentary:

;; (add-hook 'c-mode-hook
;;   (lambda ()
;;     (require 'guile-c)
;;     (define-key c-mode-map "\C-c\C-g\C-p" 'guile-c-insert-define)
;;     (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring)
;;     (define-key c-mode-map "\C-c\C-g\C-d" 'guile-c-deprecate-region)
;;     ))

;;; Code:

(require 'cc-mode)

(defvar guile-c-prefix "scm_")

;;;
;;; Insert templates
;;;

(defun guile-c-insert-define ()
  "Insert a template of a Scheme procedure.

  M-x guile-c-insert-define RET foo arg , opt . rest =>

  SCM_DEFINE (scm_foo, \"foo\", 1, 1, 1,
              (SCM arg, SCM opt, SCM rest),
              \"\")
  #define FUNC_NAME s_scm_foo
  {

  }
  #undef FUNC_NAME"
  (interactive)
  (let ((tokens (split-string (read-string "Procedure: ")))
	name args opts rest)
    ;; Get procedure name
    (if (not tokens) (error "No procedure name"))
    (setq name (car tokens) tokens (cdr tokens))
    ;; Get requisite arguments
    (while (and tokens (not (member (car tokens) '("," "."))))
      (setq args (cons (car tokens) args) tokens (cdr tokens)))
    (setq args (nreverse args))
    ;; Get optional arguments
    (when (string= (car tokens) ",")
      (setq tokens (cdr tokens))
      (while (and tokens (not (string= (car tokens) ".")))
	(setq opts (cons (car tokens) opts) tokens (cdr tokens)))
      (setq opts (nreverse opts)))
    ;; Get rest argument
    (when (string= (car tokens) ".")
      (setq rest (list (cadr tokens))))
    ;; Insert template
    (let ((c-name (guile-c-name-from-scheme-name name)))
      (insert (format "SCM_DEFINE (%s, \"%s\", %d, %d, %d,\n"
		      c-name name (length args) (length opts) (length rest))
	      "\t    ("
	      (mapconcat (lambda (a) (concat "SCM " a))
			 (append args opts rest) ", ")
	      "),\n"
	      "\t    \"\")\n"
	      "#define FUNC_NAME s_" c-name "\n"
	      "{\n\n}\n"
	      "#undef FUNC_NAME\n\n")
      (previous-line 4)
      (indent-for-tab-command))))

(defun guile-c-name-from-scheme-name (name)
  (while (string-match "\\?$" name) (setq name (replace-match "_p" t t name)))
  (while (string-match "!$" name) (setq name (replace-match "_x" t t name)))
  (while (string-match "^%" name) (setq name (replace-match "sys_" t t name)))
  (while (string-match "->" name) (setq name (replace-match "_to_" t t name)))
  (while (string-match "[-:]" name) (setq name (replace-match "_" t t name)))
  (concat guile-c-prefix name))

;;;
;;; Edit docstrings
;;;

(defvar guile-c-window-configuration nil)

(defun guile-c-edit-docstring ()
  (interactive)
  (let* ((region (guile-c-find-docstring))
	 (doc (if region (buffer-substring (car region) (cdr region)))))
    (if (not doc)
	(error "No docstring!")
      (setq guile-c-window-configuration (current-window-configuration))
      (with-current-buffer (get-buffer-create "*Guile Docstring*")
	(erase-buffer)
	(insert doc)
	(goto-char (point-min))
	(while (not (eobp))
	  (if (looking-at "[ \t]*\"")
	      (delete-region (match-beginning 0) (match-end 0)))
	  (end-of-line)
	  (if (eq (char-before (point)) ?\")
	      (delete-backward-char 1))
	  (if (and (eq (char-before (point)) ?n)
		   (eq (char-before (1- (point))) ?\\))
	      (delete-backward-char 2))
	  (forward-line))
	(goto-char (point-min))
	(texinfo-mode)
	(if global-font-lock-mode
	    (font-lock-fontify-buffer))
	(local-set-key "\C-c\C-c" 'guile-c-edit-finish)
	(setq fill-column 63)
	(switch-to-buffer-other-window (current-buffer))
        (message "Type `C-c C-c' to finish")))))

(defun guile-c-edit-finish ()
  (interactive)
  (goto-char (point-max))
  (while (eq (char-before) ?\n) (backward-delete-char 1))
  (goto-char (point-min))
  (if (eobp)
      (insert "\"\"")
    (while (not (eobp))
      (insert "\t    \"")
      (end-of-line)
      (insert (if (eobp) "\"" "\\n\""))
      (forward-line 1)))
  (let ((doc (buffer-string)))
    (kill-buffer (current-buffer))
    (set-window-configuration guile-c-window-configuration)
    (let ((region (guile-c-find-docstring)))
      (goto-char (car region))
      (delete-region (car region) (cdr region)))
    (insert doc)))

(defun guile-c-find-docstring ()
  (save-excursion
    (if (re-search-backward "^SCM_DEFINE" nil t)
	(let ((start (progn (forward-line 2) (point))))
	  (while (looking-at "[ \t]*\"")
	    (forward-line 1))
	  (cons start (- (point) 2))))))

;;;
;;; Others
;;;

(defun guile-c-deprecate-region (start end)
  (interactive "r")
  (save-excursion
    (let ((marker (make-marker)))
      (set-marker marker end)
      (goto-char start)
      (insert "#if (SCM_DEBUG_DEPRECATED == 0)\n\n")
      (goto-char marker)
      (insert "\n#endif /* (SCM_DEBUG_DEPRECATED == 0) */\n"))))

(provide 'guile-c)

;; guile-c.el ends here


code:
;;; guile-emacs.scm --- Guile Emacs interface

;; Copyright (C) 2001, 2010 Keisuke Nishida <kxn30@po.cwru.edu>

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

;;; Code:

(use-modules (ice-9 regex))
(use-modules (ice-9 channel))
(use-modules (ice-9 session))
(use-modules (ice-9 documentation))

;;;
;;; Emacs Lisp channel
;;;

(define (emacs-lisp-channel)

  (define (native-type? x)
    (or (integer? x) (symbol? x) (string? x) (pair? x) (vector? x)))

  (define (emacs-lisp-print ch val)
    (cond
      ((unspecified? val))
      ((eq? val #t) (channel-print-value ch 't))
      ((or (eq? val #f) (null? val)) (channel-print-value ch 'nil))
      ((native-type? val) (channel-print-value ch val))
      (else (channel-print-token ch val))))

  (channel-open (make-object-channel emacs-lisp-print)))

;;;
;;; Scheme channel
;;;

(define (emacs-scheme-channel)
  (define (print ch val) (channel-print-value ch (object->string val)))
  (channel-open (make-object-channel print)))

;;;
;;; for guile-import and guile-import-module
;;;

(define (guile-emacs-export-procedure name proc docs)
  (define (procedure-args proc)
    (let ((source (procedure-source proc)))
      (if source
	;; formals -> emacs args
	(let loop ((formals (cadr source)))
	  (cond
	    ((null? formals) '())
	    ((symbol? formals) `(&rest ,formals))
	    (else (cons (car formals) (loop (cdr formals))))))
	;; arity -> emacs args
	(let* ((arity (procedure-minimum-arity proc))
	       (nreqs (car arity))
	       (nopts (cadr arity))
	       (restp (caddr arity)))
	  (define (nsyms n)
	    (if (= n 0) '() (cons (gensym "a") (nsyms (1- n)))))
	  (append! (nsyms nreqs)
		   (if (> nopts 0) (cons '&optional (nsyms nopts)) '())
		   (if restp (cons '&rest (nsyms 1)) '()))))))

  (define (procedure-call name args)
    (let ((restp (memq '&rest args))
	  (args (delq '&rest (delq '&optional args))))
      (if restp
	`('apply ',name ,@args)
	`(',name ,@args))))

  (let ((args (procedure-args proc))
	(docs (and docs (object-documentation proc))))
    `(defun ,name ,args
       ,@(if docs (list docs) '())
       (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args)))))

(define (guile-emacs-export proc-name func-name docs)
  (let ((proc (module-ref (current-module) proc-name)))
    (guile-emacs-export-procedure func-name proc docs)))

(define (guile-emacs-export-procedures module-name docs)
  (define (module-public-procedures name)
    (hash-fold (lambda (s v d)
		 (let ((val (variable-ref v)))
		   (if (procedure? val) (acons s val d) d)))
	       '() (module-obarray (resolve-interface name))))
  `(progn ,@(map (lambda (n+p)
		   (guile-emacs-export-procedure (car n+p) (cdr n+p) docs))
		 (module-public-procedures module-name))))

;;;
;;; for guile-scheme-complete-symbol
;;;

(define (guile-emacs-complete-alist str)
  (sort! (apropos-fold (lambda (module name val data)
			 (cons (list (symbol->string name)
				     (cond ((procedure? val) " <p>")
					   ((macro? val)     " <m>")
					   (else "")))
			       data))
		       '() (string-append "^" (regexp-quote str))
		       apropos-fold-all)
	 (lambda (p1 p2) (string<? (car p1) (car p2)))))

;;;
;;; for guile-scheme-apropos
;;;

(define (guile-emacs-apropos regexp)
  (with-output-to-string (lambda () (apropos regexp))))

;;;
;;; for guile-scheme-describe
;;;

(define (guile-emacs-describe sym)
  (object-documentation (eval sym (current-module))))

;;;
;;; Guile 1.4 compatibility
;;;

(define object->string
  (if (defined? 'object->string)
    object->string
    (lambda (x) (format #f "~S" x))))

;;; guile-emacs.scm ends here