* Makefile.am: New file.

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

5 files changed, 1809 insertions, 0 deletions

diff --git a/emacs/ChangeLog b/emacs/ChangeLog
index ab4969cab..2396af25c 100644
--- a/emacs/ChangeLog
+++ b/emacs/ChangeLog
@@ -1,3 +1,9 @@
+2006-06-19  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* Makefile.am: New file.
+
+	* gds.el, gds-scheme.el, gds-server.el: New files.
+
 2005-07-09  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* Makefile.am, REAME.GDS, gds-client.scm, gds-problems.txt,
diff --git a/emacs/Makefile.am b/emacs/Makefile.am
new file mode 100644
index 000000000..e10043c2b
--- /dev/null
+++ b/emacs/Makefile.am
@@ -0,0 +1,27 @@
+## Process this file with automake to produce Makefile.in.
+##
+##  	Copyright (C) 2006 Free Software Foundation, Inc.
+##
+##   This file is part of GUILE.
+##
+##   GUILE is free software; you can redistribute it and/or modify
+##   it under the terms of the GNU General Public License as
+##   published by the Free Software Foundation; either version 2, or
+##   (at your option) any later version.
+##
+##   GUILE is distributed in the hope that it will be useful, but
+##   WITHOUT ANY WARRANTY; without even the implied warranty of
+##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+##   GNU General Public License for more details.
+##
+##   You should have received a copy of the GNU General Public
+##   License along with GUILE; see the file COPYING.  If not, write
+##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
+##   Floor, Boston, MA 02110-1301 USA
+
+AUTOMAKE_OPTIONS = gnu
+
+dist_lisp_LISP = gds.el gds-server.el gds-scheme.el
+ELCFILES = 
+
+ETAGS_ARGS = $(dist_lisp_LISP)
diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el
new file mode 100755
index 000000000..f5d235edf
--- /dev/null
+++ b/emacs/gds-scheme.el
@@ -0,0 +1,1038 @@
+;;; 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 2.1 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 (assq '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 (ossau 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))
+         (client nil))
+    ;; 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)
+                          (setq client (string-to-number string))
+                          (if (process-buffer proc)
+                              (with-current-buffer (process-buffer proc)
+                                (insert string)))))
+    ;; Accept output from the new process until we have its number.
+    (while (not client)
+      (accept-process-output proc))
+    ;; Return the new process's client number.
+    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)
+  "Evaluate the current region."
+  (interactive "r")
+  (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"
+			(gds-abbreviated code)
+			(if module (prin1-to-string module) "#f")
+			port-name (car lc) (cdr lc)
+			code)
+		gds-client))))
+
+(defun gds-eval-expression (expr &optional correlator)
+  "Evaluate the supplied EXPR (a string)."
+  (interactive "sEvaluate expression: \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"
+		    (or correlator 'expression)
+		    (gds-abbreviated expr)
+		    expr)
+	    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 ()
+  "Evaluate the defun (top-level form) at point."
+  (interactive)
+  (save-excursion
+   (end-of-defun)
+   (let ((end (point)))
+     (beginning-of-defun)
+     (gds-eval-region (point) end))))
+
+(defun gds-eval-last-sexp ()
+  "Evaluate the sexp before point."
+  (interactive)
+  (gds-eval-region (save-excursion (backward-sexp) (point)) (point)))
+
+;;;; 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-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)
+              (insert "[click here to show error stack]")
+              (add-text-properties beg (point)
+                                   (list 'keymap map
+                                         'mouse-face 'highlight))
+              (insert "\n")))
+        (goto-char (point-min))
+        (gds-associate-buffer client))
+      (pop-to-buffer buf)
+      (run-hooks 'temp-buffer-show-hook)
+      (other-window 1))))
+
+(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)))))
+
+;;;; Breakpoints.
+
+(defvar gds-bufferless-breakpoints nil
+  "The list of breakpoints that are not yet associated with a
+particular buffer.  Each element looks like (BPDEF BPNUM) where BPDEF
+is the breakpoint definition and BPNUM the breakpoint's unique
+GDS-assigned number.  A breakpoint definition BPDEF is a list of the
+form (BEHAVIOUR TYPE FILENAME TYPE-ARGS...), where BEHAVIOUR is 'debug
+or 'trace, TYPE is 'in or 'at, FILENAME is the full name of the file
+where the breakpoint is (or will be) set, and TYPE-ARGS is:
+
+- the name of the procedure to break in, if TYPE is 'in
+
+- the line number and column number to break at, if TYPE is 'at.
+
+If persistent breakpoints are enabled (by configuring
+gds-breakpoints-file-name), this list is initialized when GDS is
+loaded by reading gds-breakpoints-file-name.")
+
+(defsubst gds-bpdef:behaviour (bpdef)
+  (nth 0 bpdef))
+
+(defsubst gds-bpdef:type (bpdef)
+  (nth 1 bpdef))
+
+(defsubst gds-bpdef:file-name (bpdef)
+  (nth 2 bpdef))
+
+(defsubst gds-bpdef:proc-name (bpdef)
+  (nth 3 bpdef))
+
+(defsubst gds-bpdef:lc (bpdef)
+  (nth 3 bpdef))
+
+(defvar gds-breakpoint-number 0
+  "The last assigned breakpoint number.  GDS increments this whenever
+it creates a new breakpoint.")
+
+(defvar gds-breakpoint-buffers nil
+  "The list of buffers that contain GDS breakpoints.  When Emacs
+visits a Scheme file, GDS checks to see if any of the breakpoints in
+the bufferless list can be assigned to that file's buffer.  If they
+can, they are removed from the bufferless list and become breakpoint
+overlays in that buffer.  To retain the ability to enumerate all
+breakpoints, therefore, we keep a list of all such buffers.")
+
+(defvar gds-breakpoint-programming nil
+  "Information about how each breakpoint is actually programmed in the
+Guile clients that GDS is connected to.  This is an alist of the form
+\((BPNUM (CLIENT . TRAPLIST) ...) ...), where BPNUM is the breakpoint
+number, CLIENT is the number of a GDS client, and TRAPLIST is the list
+of traps that that client has created for the breakpoint concerned (in
+an arbitrary but Emacs-readable format).")
+
+(defvar gds-breakpoint-cache nil
+  "Buffer-local cache of breakpoints in a particular buffer.  When a
+breakpoint is represented as an overlay is a Scheme mode buffer, we
+need to be able to detect when the user has caused that overlay to
+evaporate by deleting a region of code that included it.  We do this
+detection when the buffer is next saved, by comparing the current set
+of overlays with this cache.  The cache is a list in which each
+element has the form (BPDEF BPNUM), with BPDEF and BPNUM as already
+described.  The handling of such breakpoints (which we call \"lost\")
+is controlled by the setting of gds-delete-lost-breakpoints.")
+(make-variable-buffer-local 'gds-breakpoint-cache)
+
+(defface gds-breakpoint-face
+  '((((background dark)) (:background "red"))
+    (t (:background "pink")))
+  "*Face used to highlight the location of a breakpoint."
+  :group 'gds)
+
+(defcustom gds-breakpoints-file-name "~/.gds-breakpoints"
+  "Name of file used to store GDS breakpoints between sessions.
+You can disable breakpoint persistence by setting this to nil."
+  :group 'gds
+  :type '(choice (const :tag "nil" nil) file))
+
+(defcustom gds-delete-lost-breakpoints nil
+  "Whether to delete lost breakpoints.
+
+A non-nil value means that the Guile clients where lost breakpoints
+were programmed will be told immediately to delete their breakpoints.
+\"Immediately\" means when the lost breakpoints are detected, which
+means when the buffer that previously contained them is saved.  Thus,
+even if the affected code (which the GDS user has deleted from his/her
+buffer in Emacs) is still in use in the Guile clients, the breakpoints
+that were previously set in that code will no longer take effect.
+
+Nil (which is the default) means that GDS leaves such breakpoints
+active in their Guile clients.  This allows those breakpoints to
+continue taking effect until the affected code is no longer used by
+the Guile clients."
+  :group 'gds
+  :type 'boolean)
+
+(defvar gds-bpdefs-cache nil)
+
+(defun gds-read-breakpoints-file ()
+  "Read the persistent breakpoints file, and use its contents to
+initialize GDS's global breakpoint variables."
+  (let ((bpdefs (condition-case nil
+		    (with-current-buffer
+			(find-file-noselect gds-breakpoints-file-name)
+		      (goto-char (point-min))
+		      (read (current-buffer)))
+		  (error nil))))
+    ;; Cache the overall value so we don't unnecessarily modify the
+    ;; breakpoints buffer when `gds-write-breakpoints-file' is called.
+    (setq gds-bpdefs-cache bpdefs)
+    ;; Move definitions into the bufferless breakpoint list, assigning
+    ;; breakpoint numbers as we go.
+    (setq gds-bufferless-breakpoints
+	  (mapcar (function (lambda (bpdef)
+			      (setq gds-breakpoint-number
+				    (1+ gds-breakpoint-number))
+			      (list bpdef gds-breakpoint-number)))
+		  bpdefs))
+    ;; Check each existing Scheme buffer to see if it wants to take
+    ;; ownership of any of these breakpoints.
+    (mapcar (function (lambda (buffer)
+			(with-current-buffer buffer
+			  (if (eq (derived-mode-class major-mode) 'scheme-mode)
+			      (gds-adopt-breakpoints)))))
+	    (buffer-list))))
+
+(defun gds-adopt-breakpoints ()
+  "Take ownership of any of the breakpoints in the bufferless list
+that match the current buffer."
+  (mapcar (function gds-adopt-breakpoint)
+	  (copy-sequence gds-bufferless-breakpoints)))
+
+(defun gds-adopt-breakpoint (bpdefnum)
+  "Take ownership of the specified breakpoint if it matches the
+current buffer."
+  (let ((bpdef (car bpdefnum))
+	(bpnum (cadr bpdefnum)))
+    ;; Check if breakpoint's file name matches.  If it does, try to
+    ;; convert the breakpoint definition to a breakpoint overlay in
+    ;; the current buffer.
+    (if (and (string-equal (gds-bpdef:file-name bpdef) buffer-file-name)
+	     (gds-make-breakpoint-overlay bpdef bpnum))
+	;; That all succeeded, so this breakpoint is no longer
+	;; bufferless.
+	(setq gds-bufferless-breakpoints
+	      (delq bpdefnum gds-bufferless-breakpoints)))))
+
+(defun gds-make-breakpoint-overlay (bpdef &optional bpnum)
+  ;; If no explicit number given, assign the next available breakpoint
+  ;; number.
+  (or bpnum
+      (setq gds-breakpoint-number (+ gds-breakpoint-number 1)
+	    bpnum gds-breakpoint-number))
+  ;; First decide where the overlay should be, and create it there.
+  (let ((o (cond ((eq (gds-bpdef:type bpdef) 'at)
+		  (save-excursion
+		    (goto-line (+ (car (gds-bpdef:lc bpdef)) 1))
+		    (move-to-column (cdr (gds-bpdef:lc bpdef)))
+		    (make-overlay (point) (1+ (point)))))
+		 ((eq (gds-bpdef:type bpdef) 'in)
+		  (save-excursion
+		    (goto-char (point-min))
+		    (and (re-search-forward (concat "^(define +(?\\("
+						    (regexp-quote
+						     (gds-bpdef:proc-name
+						      bpdef))
+						    "\\>\\)")
+					    nil t)
+			 (make-overlay (match-beginning 1) (match-end 1)))))
+		 (t
+		  (error "Bad breakpoint type")))))
+    ;; If that succeeded, initialize the overlay's properties.
+    (if o
+	(progn
+	  (overlay-put o 'evaporate t)
+	  (overlay-put o 'face 'gds-breakpoint-face)
+	  (overlay-put o 'gds-breakpoint-number bpnum)
+	  (overlay-put o 'gds-breakpoint-definition bpdef)
+	  (overlay-put o 'help-echo (format "Breakpoint %d: %S" bpnum bpdef))
+	  (overlay-put o 'priority 1000)
+	  ;; Make sure that the current buffer is included in
+	  ;; `gds-breakpoint-buffers'.
+	  (or (memq (current-buffer) gds-breakpoint-buffers)
+	      (setq gds-breakpoint-buffers
+		    (cons (current-buffer) gds-breakpoint-buffers)))
+	  ;; Add the new breakpoint to this buffer's cache.
+	  (setq gds-breakpoint-cache
+		(cons (list bpdef bpnum) gds-breakpoint-cache))
+	  ;; If this buffer is associated with a client, tell the
+	  ;; client about the new breakpoint.
+	  (if gds-client (gds-send-breakpoint-to-client bpnum bpdef))))
+    ;; Return the overlay, or nil if we weren't able to convert the
+    ;; breakpoint definition.
+    o))
+
+(defun gds-send-breakpoint-to-client (bpnum bpdef)
+  "Send specified breakpoint to this buffer's Guile client."
+  (gds-send (format "set-breakpoint %d %S" bpnum bpdef) gds-client))
+
+(add-hook 'scheme-mode-hook (function gds-adopt-breakpoints))
+
+(defcustom gds-default-breakpoint-type 'debug
+  "The type of breakpoint set by `C-x SPC'."
+  :group 'gds
+  :type '(choice (const :tag "debug" debug) (const :tag "trace" trace)))
+
+(defun gds-set-breakpoint ()
+  "Create a new GDS breakpoint at point."
+  (interactive)
+  ;; Set up beg and end according to whether the mark is active.
+  (if mark-active
+      ;; Set new breakpoints on all opening parentheses in the region.
+      (let ((beg (region-beginning))
+	    (end (region-end)))
+	(save-excursion
+	  (goto-char beg)
+	  (beginning-of-defun)
+	  (let ((defun-start (point)))
+	    (goto-char beg)
+	    (while (search-forward "(" end t)
+	      (let ((state (parse-partial-sexp defun-start (point)))
+		    (pos (- (point) 1)))
+		(or (nth 3 state)
+		    (nth 4 state)
+		    (gds-breakpoint-overlays-at pos)
+		    (gds-make-breakpoint-overlay (list gds-default-breakpoint-type
+						       'at
+						       buffer-file-name
+						       (gds-line-and-column
+							pos)))))))))
+    ;; Set a new breakpoint on the defun at point.
+    (let ((region (gds-defun-name-region)))
+      ;; Complain if there is no defun at point.
+      (or region
+	  (error "Point is not in a procedure definition"))
+      ;; Don't create another breakpoint if there is already one here.
+      (if (gds-breakpoint-overlays-at (car region))
+	  (error "There is already a breakpoint here"))
+      ;; Create and return the new breakpoint overlay.
+      (gds-make-breakpoint-overlay (list gds-default-breakpoint-type
+					 'in
+					 buffer-file-name
+					 (buffer-substring-no-properties
+					  (car region)
+					  (cdr region))))))
+  ;; Update the persistent breakpoints file.
+  (gds-write-breakpoints-file))
+
+(defun gds-defun-name-region ()
+  "If point is in a defun, return the beginning and end positions of
+the identifier being defined."
+  (save-excursion
+    (let ((p (point)))
+      (beginning-of-defun)
+      ;; Check that we are looking at some kind of procedure
+      ;; definition.
+      (and (looking-at "(define +(?\\(\\(\\s_\\|\\w\\)+\\)")
+	   (let ((beg (match-beginning 1))
+		 (end (match-end 1)))
+	     (end-of-defun)
+	     ;; Check here that we have reached past the original point
+	     ;; position.
+	     (and (>= (point) p)
+		  (cons beg end)))))))
+
+(defun gds-breakpoint-overlays-at (pos)
+  "Return a list of GDS breakpoint overlays at the specified position."
+  (let ((os (overlays-at pos))
+	(breakpoint-os nil))
+    ;; Of the overlays at POS, select all those that have a
+    ;; gds-breakpoint-definition property.
+    (while os
+      (if (overlay-get (car os) 'gds-breakpoint-definition)
+	  (setq breakpoint-os (cons (car os) breakpoint-os)))
+      (setq os (cdr os)))
+    breakpoint-os))
+
+(defun gds-write-breakpoints-file ()
+  "Write the persistent breakpoints file, if configured."
+  (if gds-breakpoints-file-name
+      (let ((bpdefs (gds-fold-breakpoints (function (lambda (bpnum bpdef init)
+						      (cons bpdef init)))
+					  t)))
+        (or (equal bpdefs gds-bpdefs-cache)
+            (with-current-buffer (find-file-noselect gds-breakpoints-file-name)
+              (erase-buffer)
+              (pp (reverse bpdefs) (current-buffer))
+              (setq gds-bpdefs-cache bpdefs)
+              (let ((auto-fill-function normal-auto-fill-function))
+                (newline)))))))
+
+(defun gds-fold-breakpoints (fn &optional foldp init)
+  ;; Run through bufferless breakpoints first.
+  (let ((bbs gds-bufferless-breakpoints))
+    (while bbs
+      (let ((bpnum (cadr (car bbs)))
+	    (bpdef (caar bbs)))
+	(if foldp
+	    (setq init (funcall fn bpnum bpdef init))
+	  (funcall fn bpnum bpdef)))
+      (setq bbs (cdr bbs))))
+  ;; Now run through breakpoint buffers.
+  (let ((outbuf (current-buffer))
+	(bpbufs gds-breakpoint-buffers))
+    (while bpbufs
+      (let ((buf (car bpbufs)))
+	(if (buffer-live-p buf)
+	    (with-current-buffer buf
+	      (save-restriction
+		(widen)
+		(let ((os (overlays-in (point-min) (point-max))))
+		  (while os
+		    (let ((bpnum (overlay-get (car os)
+					      'gds-breakpoint-number))
+			  (bpdef (overlay-get (car os)
+					      'gds-breakpoint-definition)))
+		      (if bpdef
+			  (with-current-buffer outbuf
+			    (if foldp
+				(setq init (funcall fn bpnum bpdef init))
+			      (funcall fn bpnum bpdef)))))
+		    (setq os (cdr os))))))))
+      (setq bpbufs (cdr bpbufs))))
+  init)
+
+(defun gds-delete-breakpoints ()
+  "Delete GDS breakpoints in the region or at point."
+  (interactive)
+  (if mark-active
+      ;; Delete all breakpoints in the region.
+      (let ((os (overlays-in (region-beginning) (region-end))))
+	(while os
+	  (if (overlay-get (car os) 'gds-breakpoint-definition)
+	      (gds-delete-breakpoint (car os)))
+	  (setq os (cdr os))))
+    ;; Delete the breakpoint "at point".
+    (call-interactively (function gds-delete-breakpoint))))
+
+(defun gds-delete-breakpoint (o)
+  (interactive (list (or (gds-breakpoint-at-point)
+			 (error "There is no breakpoint here"))))
+  (let ((bpdef (overlay-get o 'gds-breakpoint-definition))
+	(bpnum (overlay-get o 'gds-breakpoint-number)))
+    ;; If this buffer is associated with a client, tell the client
+    ;; that the breakpoint has been deleted.
+    (if (and bpnum gds-client)
+	(gds-send (format "delete-breakpoint %d" bpnum) gds-client))
+    ;; Remove this breakpoint from the cache also, so it isn't later
+    ;; detected as having been "lost".
+    (setq gds-breakpoint-cache
+	  (delq (assq bpdef gds-breakpoint-cache) gds-breakpoint-cache)))
+  ;; Remove the overlay from its buffer.
+  (delete-overlay o)
+  ;; If that was the last breakpoint in this buffer, remove this
+  ;; buffer from gds-breakpoint-buffers.
+  (or gds-breakpoint-cache
+      (setq gds-breakpoint-buffers
+	    (delq (current-buffer) gds-breakpoint-buffers)))
+  ;; Update the persistent breakpoints file.
+  (gds-write-breakpoints-file))
+
+(defun gds-breakpoint-at-point ()
+  "Find and return the overlay for a breakpoint `at' the current
+cursor position.  This is intended for use in other functions'
+interactive forms, so it intentionally uses the minibuffer in some
+situations."
+  (let* ((region (gds-defun-name-region))
+	 (os (gds-union (gds-breakpoint-overlays-at (point))
+			(and region
+			     (gds-breakpoint-overlays-at (car region))))))
+    ;; Switch depending whether we found 0, 1 or more overlays.
+    (cond ((null os)
+	   ;; None found: return nil.
+	   nil)
+	  ((= (length os) 1)
+	   ;; One found: return it.
+	   (car os))
+	  (t
+	   ;; More than 1 found: ask the user to choose.
+	   (gds-user-selected-breakpoint os)))))
+
+(defun gds-union (first second &rest others)
+  (if others
+      (gds-union first (apply 'gds-union second others))
+    (progn
+      (while first
+	(or (memq (car first) second)
+	    (setq second (cons (car first) second)))
+	(setq first (cdr first)))
+      second)))
+
+(defun gds-user-selected-breakpoint (os)
+  "Ask the user to choose one of the given list of breakpoints, and
+return the one that they chose."
+  (let ((table (mapcar
+		(lambda (o)
+		  (cons (format "%S"
+				(overlay-get o 'gds-breakpoint-definition))
+			o))
+		os)))
+    (cdr (assoc (completing-read "Which breakpoint do you mean? "
+				 table nil t)
+		table))))
+
+(defun gds-describe-breakpoints ()
+  "Describe all breakpoints and their programming status."
+  (interactive)
+  (with-current-buffer (get-buffer-create "*GDS Breakpoints*")
+    (erase-buffer)
+    (gds-fold-breakpoints (function gds-describe-breakpoint))
+    (display-buffer (current-buffer))))
+
+(defun gds-describe-breakpoint (bpnum bpdef)
+  (insert (format "Breakpoint %d: %S\n" bpnum bpdef))
+  (let ((bpproglist (cdr (assq bpnum gds-breakpoint-programming))))
+    (mapcar (lambda (clientprog)
+	      (let ((client (car clientprog))
+		    (traplist (cdr clientprog)))
+		(mapcar (lambda (trap)
+			  (insert (format "  Client %d: %S\n" client trap)))
+			traplist)))
+	    bpproglist)))
+
+(defun gds-after-save-update-breakpoints ()
+  "Function called when a buffer containing breakpoints is saved."
+  (if (eq (derived-mode-class major-mode) 'scheme-mode)
+      (save-restriction
+	(widen)
+	;; Get the current breakpoint overlays.
+	(let ((os (overlays-in (point-min) (point-max)))
+	      (cache (copy-sequence gds-breakpoint-cache)))
+	  ;; Identify any overlays that have disappeared by comparing
+	  ;; against this buffer's definition cache, and
+	  ;; simultaneously rebuild the cache to reflect the current
+	  ;; set of overlays.
+	  (setq gds-breakpoint-cache nil)
+	  (while os
+	    (let* ((o (car os))
+		   (bpdef (overlay-get o 'gds-breakpoint-definition))
+		   (bpnum (overlay-get o 'gds-breakpoint-number)))
+	      (if bpdef
+		  ;; o and bpdef describe a current breakpoint.
+		  (progn
+		    ;; Remove this breakpoint from the old cache list,
+		    ;; so we don't think it got lost.
+		    (setq cache (delq (assq bpdef cache) cache))
+		    ;; Check whether this breakpoint's location has
+		    ;; moved.  If it has, update the breakpoint
+		    ;; definition and the associated client.
+		    (let ((lcnow (gds-line-and-column (overlay-start o))))
+		      (if (equal lcnow (gds-bpdef:lc bpdef))
+			  nil		; Breakpoint hasn't moved.
+			(gds-bpdef:setlc bpdef lcnow)
+			(if gds-client
+			    (gds-send-breakpoint-to-client bpnum bpdef))))
+		    ;; Add this breakpoint to the new cache list.
+		    (setq gds-breakpoint-cache
+			  (cons (list bpdef bpnum) gds-breakpoint-cache)))))
+	    (setq os (cdr os)))
+	  ;; cache now holds the set of lost breakpoints.  If we are
+	  ;; supposed to explicitly delete these from the associated
+	  ;; client, do that now.
+	  (if (and gds-delete-lost-breakpoints gds-client)
+	      (while cache
+		(gds-send (format "delete-breakpoint %d" (cadr (car cache)))
+			  gds-client)
+		(setq cache (cdr cache)))))
+	;; If this buffer now has no breakpoints, remove it from
+	;; gds-breakpoint-buffers.
+	(or gds-breakpoint-cache
+	    (setq gds-breakpoint-buffers
+		  (delq (current-buffer) gds-breakpoint-buffers)))
+	;; Update the persistent breakpoints file.
+	(gds-write-breakpoints-file))))
+
+(add-hook 'after-save-hook (function gds-after-save-update-breakpoints))
+
+;;;; 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)))
+
+	(;; (breakpoint NUM STATUS) - Breakpoint set.
+	 (eq proc 'breakpoint)
+	 (let* ((bpnum (car args))
+		(traplist (cdr args))
+		(bpentry (assq bpnum gds-breakpoint-programming)))
+	   (message "Breakpoint %d: %s" bpnum traplist)
+	   (if bpentry
+	       (let ((cliententry (assq client (cdr bpentry))))
+		 (if cliententry
+		     (setcdr cliententry traplist)
+		   (setcdr bpentry
+			   (cons (cons client traplist) (cdr bpentry)))))
+	     (setq gds-breakpoint-programming
+		   (cons (list bpnum (cons client traplist))
+			 gds-breakpoint-programming)))))
+
+	(;; (get-breakpoints) - Set all breakpoints.
+	 (eq proc 'get-breakpoints)
+	 (let ((gds-client client))
+	   (gds-fold-breakpoints (function gds-send-breakpoint-to-client)))
+	 (gds-send "continue" client))
+
+	(;; (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 "\e\t" 'gds-complete-symbol)
+(define-key scheme-mode-map "\C-x " 'gds-set-breakpoint)
+
+(define-prefix-command 'gds-breakpoint-map)
+(define-key scheme-mode-map "\C-c\C-b" 'gds-breakpoint-map)
+(define-key gds-breakpoint-map " " 'gds-set-breakpoint)
+(define-key gds-breakpoint-map "d"
+  (function (lambda ()
+              (interactive)
+              (let ((gds-default-breakpoint-type 'debug))
+                (gds-set-breakpoint)))))
+(define-key gds-breakpoint-map "t"
+  (function (lambda ()
+              (interactive)
+              (let ((gds-default-breakpoint-type 'trace))
+                (gds-set-breakpoint)))))
+(define-key gds-breakpoint-map "T"
+  (function (lambda ()
+              (interactive)
+              (let ((gds-default-breakpoint-type 'trace-subtree))
+                (gds-set-breakpoint)))))
+(define-key gds-breakpoint-map [backspace] 'gds-delete-breakpoints)
+(define-key gds-breakpoint-map "?" 'gds-describe-breakpoints)
+
+;;;; The end!
+
+(provide 'gds-scheme)
+
+;;; gds-scheme.el ends here.
diff --git a/emacs/gds-server.el b/emacs/gds-server.el
new file mode 100644
index 000000000..cca23c836
--- /dev/null
+++ b/emacs/gds-server.el
@@ -0,0 +1,110 @@
+;;; 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 2.1 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 (ossau 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 port protocol-handler &optional bufname)
+  "Start a GDS server process called PROCNAME, listening on TCP port PORT.
+PROTOCOL-HANDLER should be a function that accepts and processes one
+protocol form.  Optional arg BUFNAME specifies the name of the buffer
+that is used for process output\; if not specified the buffer name is
+the same as the process name."
+  (with-current-buffer (get-buffer-create (or bufname procname))
+    (erase-buffer)
+    (let* ((code (format "(begin
+                            %s
+                            (use-modules (ossau gds-server))
+                            (run-server %d))"
+			 (if gds-scheme-directory
+			     (concat "(set! %load-path (cons "
+				     (format "%S" gds-scheme-directory)
+				     " %load-path))")
+			   "")
+                         port))
+           (process-connection-type nil) ; use a pipe
+           (proc (start-process procname
+                                (current-buffer)
+                                gds-guile-program
+                                "-q"
+                                "--debug"
+                                "-c"
+                                code)))
+      (set (make-local-variable 'gds-read-cursor) (point-min))
+      (set (make-local-variable 'gds-protocol-handler) protocol-handler)
+      (set-process-filter proc (function gds-filter))
+      (set-process-sentinel proc (function gds-sentinel))
+      (set-process-coding-system proc 'latin-1-unix)
+      (process-kill-without-query proc)
+      proc)))
+
+;; Subprocess output filter: inserts normally into the process buffer,
+;; then tries to reread the output one form at a time and delegates
+;; processing of each form to `gds-protocol-handler'.
+(defun gds-filter (proc string)
+  (with-current-buffer (process-buffer proc)
+    (save-excursion
+      (goto-char (process-mark proc))
+      (insert-before-markers string))
+    (goto-char gds-read-cursor)
+    (while (let ((form (condition-case nil
+			   (read (current-buffer))
+			 (error nil))))
+	     (if form
+		 (save-excursion
+		   (funcall gds-protocol-handler (car form) (cdr form))))
+	     form)
+      (setq gds-read-cursor (point)))))
+
+;; Subprocess sentinel: do nothing.  (Currently just here to avoid
+;; inserting un-`read'able process status messages into the process
+;; buffer.)
+(defun gds-sentinel (proc event)
+  )
+
+
+;;;; The end!
+
+(provide 'gds-server)
+
+;;; gds-server.el ends here.
diff --git a/emacs/gds.el b/emacs/gds.el
new file mode 100644
index 000000000..3ce4696b6
--- /dev/null
+++ b/emacs/gds.el
@@ -0,0 +1,628 @@
+;;; 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 2.1 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)
+
+(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" 8333 'gds-debug-protocol))
+  (process-kill-without-query gds-debug-server))
+
+(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
+
+(defun gds-debug-protocol (client 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)
+
+
+;;;; If requested, autostart the server after loading.
+
+(if (and gds-autorun-debug-server
+	 (not gds-debug-server))
+    (gds-run-debug-server))
+
+;; Things to do only when this file is loaded for the first time.
+;; (And not, for example, when code is reevaluated by eval-buffer.)
+(defvar gds-scheme-first-load t)
+(if gds-scheme-first-load
+    (progn
+      ;; Read the persistent breakpoints file, if configured.
+      (if gds-breakpoints-file-name
+	  (gds-read-breakpoints-file))
+      ;; Note that first time load is complete.
+      (setq gds-scheme-first-load nil)))
+
+
+;;;; The end!
+
+(provide 'gds)
+
+;;; gds.el ends here.