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