X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/ea73836c1d10053452cc56c11d04ff0e550a22bf..580987cf4b237da12dced75958b362ecdb19d0ce:/emacs/gds.el

diff --git a/emacs/gds.el b/emacs/gds.el
index af1c5cc74..50d08ec76 100644
--- a/emacs/gds.el
+++ b/emacs/gds.el
@@ -24,6 +24,9 @@
 (require 'widget)
 (require 'wid-edit)
 (require 'scheme)
+(require 'cl)
+(require 'comint)
+(require 'info)
 
 
 ;;;; Customization group setup.
@@ -43,9 +46,18 @@
 ;; the buffer position of the start of the next unread form.
 (defvar gds-read-cursor nil)
 
+;; The guile executable used by the GDS server and captive client
+;; processes.
+(defcustom gds-guile-program "guile"
+  "*The guile executable used by GDS, specifically by its server and
+captive client processes."
+  :type 'string
+  :group 'gds)
+
 (defun gds-start ()
   "Start (or restart, if already running) the GDS subprocess."
   (interactive)
+  (gds-kill-captive)
   (if gds-process (gds-shutdown))
   (with-current-buffer (get-buffer-create "*GDS Process*")
     (erase-buffer)
@@ -53,7 +65,7 @@
 	  (let ((process-connection-type nil)) ; use a pipe
 	    (start-process "gds"
 			   (current-buffer)
-			   "guile"
+			   gds-guile-program
 			   "-q"
 			   "--debug"
 			   "-c"
@@ -61,18 +73,16 @@
   (setq gds-read-cursor (point-min))
   (set-process-filter gds-process (function gds-filter))
   (set-process-sentinel gds-process (function gds-sentinel))
-  (set-process-coding-system gds-process 'latin-1-unix))
+  (set-process-coding-system gds-process 'latin-1-unix)
+  (process-kill-without-query gds-process))
 
 ;; Shutdown the subprocess and cleanup all associated data.
 (defun gds-shutdown ()
   "Shut down the GDS subprocess."
   (interactive)
   ;; Reset variables.
-  (setq gds-buffers nil
-	gds-focus-client nil
-	gds-waiting nil)
+  (setq gds-buffers nil)
   ;; Kill the subprocess.
-  (process-kill-without-query gds-process)
   (condition-case nil
       (progn
 	(kill-process gds-process)
@@ -106,14 +116,64 @@
 
 ;; Send input to the subprocess.
 (defun gds-send (string client)
-  (process-send-string gds-process (format "(%S %s)\n" client string)))
+  (process-send-string gds-process (format "(%S %s)\n" client string))
+  (let ((buf (gds-client-ref 'gds-transcript)))
+    (if buf
+	(with-current-buffer buf
+	  (goto-char (point-max))
+	  (let ((inhibit-read-only t))
+	    (insert (format "tx (%S %s)\n" client string)))))))
 
 
-;;;; Multiple application scheduling.
+;;;; Focussing in and out on interaction with a particular client.
+
+;;;; The slight possible problems here are that popping up a client's
+;;;; interaction windows when that client wants attention might
+;;;; interrupt something else that the Emacs user was working on at
+;;;; the time, and that if multiple clients are being debugged at the
+;;;; same time, their popping up of interaction windows might become
+;;;; confusing.  For this reason, we allow GDS's behavior to be
+;;;; customized via the variables `gds-focus-in-function' and
+;;;; `gds-focus-out-function'.
+;;;;
+;;;; That said, the default policy, which is probably OK for most
+;;;; users most of the time, is very simple: when a client wants
+;;;; attention, its interaction windows are popped up immediately.
+
+(defun gds-request-focus (client)
+  (funcall gds-focus-in-function client))
+
+(defcustom gds-focus-in-function (function gds-focus-in)
+  "Function to call when a GDS client program wants user attention.
+The function is called with one argument, the CLIENT in question."
+  :type 'function
+  :group 'gds)
+
+(defun gds-focus-in (client)
+  (gds-display-buffers client))
+
+(defun gds-quit ()
+  (interactive)
+  (funcall gds-focus-out-function))
+
+(defcustom gds-focus-out-function (function gds-focus-out)
+  "Function to call when user quits interacting with a GDS client."
+  :type 'function
+  :group 'gds)
+
+(defun gds-focus-out ()
+  (if (if (gds-client-blocked)
+	  (y-or-n-p "Client is waiting for input.  Quit anyway? ")
+	t)
+      (bury-buffer (current-buffer))))
+
+
+;;;; Multiple client focus -- an alternative implementation.
+
+;;;; The following code is provided as an alternative example of how a
+;;;; customized GDS could schedule the display of multiple clients
+;;;; that are competing for user attention.
 
-;; Here is how we schedule the display of multiple clients that are
-;; competing for user attention.
-;;
 ;; - `gds-waiting' holds a list of clients that want attention but
 ;;   haven't yet got it.  A client is added to this list for two
 ;;   reasons.  (1) When it is blocked waiting for user input.
@@ -127,40 +187,39 @@
 ;;   says that it is no longer blocked, and a small time passes without
 ;;   it becoming blocked again.  (2) If the user explicitly `quits'
 ;;   that client.
-(defvar gds-focus-client nil)
-(defvar gds-waiting nil)
-
-(defun gds-request-focus (client)
-  (cond ((eq client gds-focus-client)
-	 ;; CLIENT already has the focus.  Display its buffer.
-	 (gds-display-buffers))
-	(gds-focus-client
-	 ;; Another client has the focus. Add CLIENT to `gds-waiting'.
-	 (or (memq client gds-waiting)
-	     (setq gds-waiting (append gds-waiting (list client)))))
-	(t
-	 ;; Give focus to CLIENT and display its buffer.
-	 (setq gds-focus-client client)
-	 (gds-display-buffers))))
-
-;; Explicitly give up focus.
-(defun gds-quit ()
-  (interactive)
-  (if (or (car gds-waiting)
-	  (not (gds-client-blocked))
-	  (y-or-n-p
-	   "Client is blocked and no others are waiting.  Still quit? "))
-      (progn
-	(bury-buffer (current-buffer))
-	;; Pass on the focus.
-	(setq gds-focus-client (car gds-waiting)
-	      gds-waiting (cdr gds-waiting))
-	;; If this client is blocked, add it back into the waiting list.
-	(if (gds-client-blocked)
-	    (gds-request-focus gds-client))
-	;; If there is a new focus client, request display for it.
-	(if gds-focus-client
-	    (gds-request-focus gds-focus-client)))))
+;;
+;; (defvar gds-focus-client nil)
+;; (defvar gds-waiting nil)
+;; 
+;; (defun gds-focus-in-alternative (client)
+;;   (cond ((eq client gds-focus-client)
+;;	      ;; CLIENT already has the focus.  Display its buffer.
+;;	      (gds-display-buffers client))
+;;	     (gds-focus-client
+;;	      ;; Another client has the focus. Add CLIENT to `gds-waiting'.
+;;	      (or (memq client gds-waiting)
+;;		  (setq gds-waiting (append gds-waiting (list client)))))
+;;	     (t
+;;	      ;; Give focus to CLIENT and display its buffer.
+;;	      (setq gds-focus-client client)
+;;	      (gds-display-buffers client))))
+;; 
+;; (defun gds-focus-out-alternative ()
+;;   (if (or (car gds-waiting)
+;;	       (not (gds-client-blocked))
+;;	       (y-or-n-p
+;;		"Client is blocked and no others are waiting.  Still quit? "))
+;;	   (progn
+;;	     (bury-buffer (current-buffer))
+;;	     ;; Pass on the focus.
+;;	     (setq gds-focus-client (car gds-waiting)
+;;		   gds-waiting (cdr gds-waiting))
+;;	     ;; If this client is blocked, add it back into the waiting list.
+;;	     (if (gds-client-blocked)
+;;		 (gds-request-focus gds-client))
+;;	     ;; If there is a new focus client, request display for it.
+;;	     (if gds-focus-client
+;;		 (gds-request-focus gds-focus-client)))))
 
 
 ;;;; GDS protocol dispatch.
@@ -180,6 +239,7 @@
       (goto-char (point-max))
       (let ((inhibit-read-only t))
 	(insert (format "rx %S" (cons client (cons proc args))) "\n")))
+
     (cond (;; (name ...) - Client name.
 	   (eq proc 'name)
 	   (setq gds-pid (cadr args))
@@ -233,15 +293,14 @@
 	   (setq gds-status 'closed)
 	   (gds-update-buffers)
 	   (setq gds-buffers
-		 (delq (assq client gds-buffers) gds-buffers))
-	   (if (eq client gds-focus-client)
-	       (gds-quit)))
+		 (delq (assq client gds-buffers) gds-buffers)))
 
 	  (;; (eval-results ...) - Results of evaluation.
 	   (eq proc 'eval-results)
 	   (gds-display-results client (car args) (cdr args)))
 
-	  ((eq proc 'completion-result)
+	  (;; (completion-result ...) - Available completions.
+	   (eq proc 'completion-result)
 	   (setq gds-completion-results (or (car args) t)))
 
 	  (;; (breakpoint-set FILE LINE COLUMN INFO) - Breakpoint set.
@@ -273,8 +332,38 @@
 			   (setq os nil))
 		       (setq os (cdr os)))))))))
 
+	  (;; (thread-status THREAD-TYPE THREAD-NUMBER STATUS [CORRELATOR])
+	   (eq proc 'thread-status)
+	   (if (eq (car args) 'eval)
+	       (let ((number (nth 1 args))
+		     (status (nth 2 args))
+		     (correlator (nth 3 args)))
+		 (if (eq status 'busy)
+		     (progn
+		       (setq gds-evals-in-progress
+			     (append gds-evals-in-progress
+				     (list (cons number correlator))))
+		       (run-at-time 0.5 nil
+				    (function gds-display-slow-eval)
+				    buf number correlator)
+		       (gds-promote-view 'interaction))
+		   (let ((existing (assq number gds-evals-in-progress)))
+		     (if existing
+			 (setq gds-evals-in-progress
+			       (delq existing gds-evals-in-progress)))))
+		 (gds-update-buffers))))
+
 	  )))
 
+(defun gds-display-slow-eval (buf number correlator)
+  (with-current-buffer buf
+    (let ((entry (assq number gds-evals-in-progress)))
+      (if (and entry
+	       (eq (cdr entry) correlator))
+	  (progn
+	    (gds-promote-view 'interaction)
+	    (gds-request-focus gds-client))))))
+
 
 ;;;; Per-client buffer state.
 
@@ -287,7 +376,8 @@
 (define-derived-mode gds-mode
   scheme-mode
   "Guile Interaction"
-  "Major mode for interacting with a Guile client application.")
+  "Major mode for interacting with a Guile client application."
+  (widget-minor-mode 1))
 
 (defvar gds-client nil
   "GDS client's port number.")
@@ -331,8 +421,18 @@
 	(setq gds-buffers (delq existing gds-buffers))
 	(gds-client-buffer client 'name '("(GDS buffer killed)"))))))
 
+;; Get the current buffer's associated client's value of SYM.
+(defun gds-client-ref (sym &optional client)
+  (and (or client gds-client)
+       (let ((buf (assq (or client gds-client) gds-buffers)))
+	 (and buf
+	      (cdr buf)
+	      (buffer-live-p (cdr buf))
+	      (with-current-buffer (cdr buf)
+		(symbol-value sym))))))
+
 (defun gds-client-blocked ()
-  (eq gds-status 'waiting-for-input))
+  (eq (gds-client-ref 'gds-status) 'waiting-for-input))
 
 (defvar gds-delayed-update-timer nil)
 
@@ -362,7 +462,6 @@
 	  (t
 	   (error "Bad GDS view %S" view)))
     ;; Finish off.
-    (widget-setup)
     (force-mode-line-update t)))
 
 (defun gds-update-buffers-in-a-while ()
@@ -374,26 +473,25 @@
     (setq gds-delayed-update-timer
 	  (run-at-time 0.5 nil (function gds-update-delayed-update-buffers)))))
 
-(defun gds-display-buffers ()
-  (if gds-focus-client
-      (let ((gds-focus-buffer (cdr (assq gds-focus-client gds-buffers))))
-	;; If there's already a window showing the buffer, use it.
-	(let ((window (get-buffer-window gds-focus-buffer t)))
-	  (if window
-	      (progn
-		(make-frame-visible (window-frame window))
-		(select-frame (window-frame window))
-		(select-window window))
-	    ;(select-window (display-buffer gds-focus-buffer))
-	    (display-buffer gds-focus-buffer)))
-	;; If there is an associated source buffer, display it as well.
-	(if (and (eq (car gds-views) 'stack)
-		 gds-frame-source-overlay
-		 (> (overlay-end gds-frame-source-overlay) 0))
-	    (let ((window (display-buffer
-			   (overlay-buffer gds-frame-source-overlay))))
-	      (set-window-point window
-				(overlay-start gds-frame-source-overlay)))))))
+(defun gds-display-buffers (client)
+  (let ((buf (cdr (assq client gds-buffers))))
+    ;; 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-frame (window-frame window))
+	    (select-window window))
+	;;(select-window (display-buffer buf))
+	(display-buffer buf)))
+    ;; If there is an associated source buffer, display it as well.
+    (if (and (eq (car gds-views) 'stack)
+	     gds-frame-source-overlay
+	     (> (overlay-end gds-frame-source-overlay) 1))
+	(let ((window (display-buffer
+		       (overlay-buffer gds-frame-source-overlay))))
+	  (set-window-point window
+			    (overlay-start gds-frame-source-overlay))))))
 
 
 ;;;; Management of `views'.
@@ -455,12 +553,25 @@ the following symbols.
   "The exception keys for which to debug a GDS client.")
 (make-variable-buffer-local 'gds-exception-keys)
 
+(defvar gds-evals-in-progress nil
+  "Alist describing evaluations in progress.")
+(make-variable-buffer-local 'gds-evals-in-progress)
+
+(defvar gds-results nil
+  "Last help or evaluation results.")
+(make-variable-buffer-local 'gds-results)
+
+(defcustom gds-heading-face 'info-menu-header
+  "*Face used for headings in Guile Interaction buffers."
+  :type 'face
+  :group 'gds)
+
 (defun gds-insert-interaction ()
   (erase-buffer)
   ;; Insert stuff for interacting with a running (non-blocked) Guile
   ;; client.
-  (widget-insert (buffer-name)
-		 ", "
+  (gds-heading-insert (buffer-name))
+  (widget-insert " "
 		 (cdr (assq gds-status
 			    '((running . "running (cannot accept input)")
 			      (waiting-for-input . "waiting for input")
@@ -468,7 +579,7 @@ the following symbols.
 			      (closed . "closed"))))
 		 ", in "
 		 gds-current-module
-		 "\n")
+		 "\n\n")
   (widget-create 'push-button
 		 :notify (function gds-sigint)
 		 "SIGINT")
@@ -484,7 +595,28 @@ the following symbols.
   (widget-create 'editable-field
 		 :notify (function gds-set-exception-keys)
 		 gds-exception-keys)
-  (widget-insert "\n"))
+  ;; Evaluation report area.
+  (widget-insert "\n")
+  (gds-heading-insert "Recent Evaluations")
+  (widget-insert "  To run an evaluation, see the Guile->Evaluate menu.\n")
+  (if gds-results
+      (widget-insert "\n" (cdr gds-results)))
+  (let ((evals gds-evals-in-progress))
+    (while evals
+      (widget-insert "\n" (cddar evals) " - running ")
+      (let ((w (widget-create 'push-button
+			      :notify (function gds-interrupt-eval)
+			      "Interrupt")))
+	(widget-put w :thread-number (caar evals)))
+      (widget-insert "\n")
+      (setq evals (cdr evals)))))
+
+(defun gds-heading-insert (text)
+  (let ((start (point)))
+    (widget-insert text)
+    (let ((o (make-overlay start (point))))
+      (overlay-put o 'face gds-heading-face)
+      (overlay-put o 'evaporate t))))
 
 (defun gds-sigint (w &rest ignore)
   (interactive)
@@ -492,7 +624,12 @@ the following symbols.
 
 (defun gds-async-break (w &rest ignore)
   (interactive)
-  (gds-send "async-break" gds-focus-client))
+  (gds-send "async-break" gds-client))
+
+(defun gds-interrupt-eval (w &rest ignore)
+  (interactive)
+  (gds-send (format "interrupt-eval %S" (widget-get w :thread-number))
+	    gds-client))
 
 (defun gds-toggle-debug-exceptions (w &rest ignore)
   (interactive)
@@ -560,7 +697,7 @@ the following symbols.
   (let* ((s (widget-value widget))
 	 (ind (memq 'index (text-properties-at 0 s))))
     (gds-send (format "debugger-command frame %d" (cadr ind))
-	      gds-focus-client)))
+	      gds-client)))
 
 ;; Overlay used to highlight the source expression corresponding to
 ;; the selected frame.
@@ -700,7 +837,7 @@ are not readable by Emacs.")
 
 (defun gds-query-modules ()
   (interactive)
-  (gds-send "query-modules" gds-focus-client))
+  (gds-send "query-modules" gds-client))
 
 (defun gds-view-browser ()
   (interactive)
@@ -734,36 +871,48 @@ are not readable by Emacs.")
 
 (defun gds-go ()
   (interactive)
-  (gds-send "debugger-command continue" gds-focus-client))
+  (gds-send "debugger-command continue" gds-client))
 
 (defun gds-next ()
   (interactive)
-  (gds-send "debugger-command next 1" gds-focus-client))
+  (gds-send "debugger-command next 1" gds-client))
 
 (defun gds-evaluate (expr)
   (interactive "sEvaluate (in this stack frame): ")
   (gds-send (format "debugger-command evaluate %s" (prin1-to-string expr))
-	    gds-focus-client))
+	    gds-client))
 
 (defun gds-step-in ()
   (interactive)
-  (gds-send "debugger-command step 1" gds-focus-client))
+  (gds-send "debugger-command step 1" gds-client))
 
 (defun gds-step-out ()
   (interactive)
-  (gds-send "debugger-command finish" gds-focus-client))
+  (gds-send "debugger-command finish" gds-client))
 
 (defun gds-trace-finish ()
   (interactive)
-  (gds-send "debugger-command trace-finish" gds-focus-client))
+  (gds-send "debugger-command trace-finish" gds-client))
 
 (defun gds-frame-info ()
   (interactive)
-  (gds-send "debugger-command info-frame" gds-focus-client))
+  (gds-send "debugger-command info-frame" gds-client))
 
 (defun gds-frame-args ()
   (interactive)
-  (gds-send "debugger-command info-args" gds-focus-client))
+  (gds-send "debugger-command info-args" gds-client))
+
+(defun gds-debug-trap-hooks ()
+  (interactive)
+  (gds-send "debugger-command debug-trap-hooks" gds-client))
+
+(defun gds-up ()
+  (interactive)
+  (gds-send "debugger-command up 1" gds-client))
+
+(defun gds-down ()
+  (interactive)
+  (gds-send "debugger-command down 1" gds-client))
 
 
 ;;;; Setting breakpoints.
@@ -822,7 +971,7 @@ are not readable by Emacs.")
 			module
 			sym
 			behaviour)
-		gds-focus-client))))
+		gds-client))))
 
 
 ;;;; Scheme source breakpoints.
@@ -961,15 +1110,17 @@ isn't yet known to Guile."
 ;; connection, receive the result and any output generated through the
 ;; same connection, and display the result and output to the user.
 ;;
-;; Where there are multiple Guile applications known to GDS, GDS by
-;; default sends code to the one that holds the debugging focus,
-;; i.e. `gds-focus-client'.  Where no application has the focus,
-;; or the command is invoked with `C-u', GDS asks the user which
-;; application is intended.
+;; 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.  In
+;; the common case where GDS is only managing one client program, a
+;; buffer's value of `gds-client' is set automatically to point to
+;; that program the first time that an evaluation (or help or
+;; completion) is requested.  If there are multiple GDS clients
+;; running at that time, GDS asks the user which one is intended.
 
 (defun gds-read-client ()
-  (let* ((def (if gds-focus-client
-		  (cdr (assq gds-focus-client gds-names))))
+  (let* ((def (and gds-client (cdr (assq gds-client gds-names))))
 	 (prompt (if def
 		     (concat "Application for eval (default "
 			     def
@@ -989,18 +1140,28 @@ isn't yet known to Guile."
       client)))
 
 (defun gds-choose-client (client)
+  ;; Only keep the supplied client number if it is still valid.
+  (if (integerp client)
+      (setq client (gds-client-ref 'gds-client client)))
+  ;; Only keep the current buffer's setting of `gds-client' if it is
+  ;; still valid.
+  (if gds-client
+      (setq gds-client (gds-client-ref 'gds-client)))
+  
   (or ;; If client is an integer, it is the port number of the
       ;; intended client.
-      (if (integerp client) client)
+      (if (integerp client)
+	  client)
       ;; Any other non-nil value indicates invocation with a prefix
       ;; arg, which forces asking the user which application is
       ;; intended.
-      (if client (gds-read-client))
-      ;; If ask not forced, and there is a client with the focus,
-      ;; default to that one.
-      gds-focus-client
-      ;; If there are no clients at this point, and we are allowed to
-      ;; autostart a captive Guile, do so.
+      (if client
+	  (setq gds-client (gds-read-client)))
+      ;; If ask not forced, and current buffer is associated with a
+      ;; client, use that client.
+      gds-client
+      ;; If there are no clients at this point, and we are
+      ;; allowed to autostart a captive Guile, do so.
       (and (null gds-buffers)
 	   gds-autostart-captive
 	   (progn
@@ -1008,13 +1169,13 @@ isn't yet known to Guile."
 	     (while (null gds-buffers)
 	       (accept-process-output (get-buffer-process gds-captive)
 				      0 100000))
-	     (caar gds-buffers)))
+	     (setq gds-client (caar gds-buffers))))
       ;; If there is only one known client, use that one.
       (if (and (car gds-buffers)
 	       (null (cdr gds-buffers)))
-	  (caar gds-buffers))
+	  (setq gds-client (caar gds-buffers)))
       ;; Last resort - ask the user.
-      (gds-read-client)
+      (setq gds-client (gds-read-client))
       ;; Signal an error.
       (error "No application chosen.")))
 
@@ -1053,26 +1214,46 @@ region's code."
       (setq column (current-column))	; 0-based
       (beginning-of-line)
       (setq line (count-lines (point-min) (point)))) ; 0-based
-    (gds-send (format "eval region %s %S %d %d %s %S"
-		      (if module (prin1-to-string module) "#f")
-		      port-name line column
-		      (let ((bpinfo (gds-region-breakpoint-info start end)))
-			;; Make sure that "no bpinfo" is represented
-			;; as "()", not "nil", as Scheme doesn't
-			;; understand "nil".
-			(if bpinfo (format "%S" bpinfo) "()"))
-		      (buffer-substring-no-properties start end))
-	      client)))
+    (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 line column
+			(let ((bpinfo (gds-region-breakpoint-info start end)))
+			  ;; Make sure that "no bpinfo" is represented
+			  ;; as "()", not "nil", as Scheme doesn't
+			  ;; understand "nil".
+			  (if bpinfo (format "%S" bpinfo) "()"))
+			code)
+		client))))
 
 (defun gds-eval-expression (expr &optional client correlator)
   "Evaluate the supplied EXPR (a string)."
   (interactive "sEvaluate expression: \nP")
   (setq client (gds-choose-client client))
-  (gds-send (format "eval %S #f \"Emacs expression\" 0 0 () %S"
+  (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)
 	    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 client)
   "Evaluate the defun (top-level form) at point."
   (interactive "P")
@@ -1119,6 +1300,7 @@ region's code."
 		  "Guile apropos (regexp): ")))
      (list (if (zerop (length val)) sym val)
 	   current-prefix-arg)))
+  (set-text-properties 0 (length regex) nil regex)
   (gds-eval-expression (format "(apropos %S)" regex) client 'help))
 
 (defvar gds-completion-results nil)
@@ -1165,29 +1347,38 @@ interesting happened, `nil' if not."
 ;;;; Display of evaluation and help results.
 
 (defun gds-display-results (client correlator results)
-  (let ((helpp (eq correlator 'help)))
+  (let ((helpp (eq (car correlator) 'help)))
     (let ((buf (get-buffer-create (if helpp
 				      "*Guile Help*"
 				    "*Guile Results*"))))
-      (save-excursion
-	(set-buffer buf)
-	(erase-buffer)
-	(scheme-mode)
-	(while results
-	  (insert (car results))
-	  (if helpp
-	      nil
-	    (mapcar (function (lambda (value)
-				(insert " => " value "\n")))
-		    (cadr results))
-	    (insert "\n"))
-	  (setq results (cddr results)))
-	(goto-char (point-min))
-	(if (and helpp (looking-at "Evaluating in "))
-	    (delete-region (point) (progn (forward-line 1) (point)))))
-      (pop-to-buffer buf)
-      (run-hooks 'temp-buffer-show-hook)
-      (other-window 1))))
+      (setq gds-results
+	    (save-excursion
+	      (set-buffer buf)
+	      (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)))
+	      (goto-char (point-min))
+	      (if (and helpp (looking-at "Evaluating in "))
+		  (delete-region (point) (progn (forward-line 1) (point))))
+	      (cons correlator (buffer-string))))
+      ;;(pop-to-buffer buf)
+      ;;(run-hooks 'temp-buffer-show-hook)
+      ;;(other-window 1)
+      ))
+  (gds-promote-view 'interaction)
+  (gds-request-focus client))
 
 
 ;;;; Loading (evaluating) a whole Scheme file.
@@ -1232,9 +1423,7 @@ Used for determining the default for the next `gds-load-file'.")
 (define-key scheme-mode-map "\C-x\e " 'gds-delete-source-breakpoint)
 
 
-;;;; GDS (Guile Interaction) mode keymap and menu items.
-
-(set-keymap-parent gds-mode-map widget-keymap)
+;;;; Guile Interaction mode keymap and menu items.
 
 (define-key gds-mode-map "M" (function gds-query-modules))
 
@@ -1247,7 +1436,9 @@ Used for determining the default for the next `gds-load-file'.")
 (define-key gds-mode-map "t" (function gds-trace-finish))
 (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 "H" (function gds-debug-trap-hooks))
+(define-key gds-mode-map "u" (function gds-up))
+(define-key gds-mode-map "d" (function gds-down))
 (define-key gds-mode-map "b" (function gds-set-breakpoint))
 
 (define-key gds-mode-map "vi" (function gds-view-interaction))
@@ -1284,6 +1475,10 @@ Used for determining the default for the next `gds-load-file'.")
   (setq gds-debug-menu (make-sparse-keymap "Debug"))
   (define-key gds-debug-menu [go]
     '(menu-item "Go" gds-go))
+  (define-key gds-debug-menu [down]
+    '(menu-item "Move Down 1 Frame" gds-down))
+  (define-key gds-debug-menu [up]
+    '(menu-item "Move Up 1 Frame" gds-up))
   (define-key gds-debug-menu [trace-finish]
     '(menu-item "Trace This Frame" gds-trace-finish))
   (define-key gds-debug-menu [step-out]
@@ -1358,7 +1553,7 @@ Used for determining the default for the next `gds-load-file'.")
   (define-key gds-menu [view]
     `(menu-item "View" ,gds-view-menu :enable gds-views))
   (define-key gds-menu [debug]
-    `(menu-item "Debug" ,gds-debug-menu :enable (and gds-focus-client
+    `(menu-item "Debug" ,gds-debug-menu :enable (and gds-client
 						     (gds-client-blocked))))
   (define-key gds-menu [breakpoint]
     `(menu-item "Breakpoints" ,gds-breakpoint-menu :enable t))
@@ -1381,10 +1576,6 @@ Used for determining the default for the next `gds-load-file'.")
   :type 'boolean
   :group 'gds)
 
-(if (and gds-autostart-server
-	 (not gds-process))
-    (gds-start))
-
 
 ;;;; `Captive' Guile - a Guile process that is started when needed to
 ;;;; provide help, completion, evaluations etc.
@@ -1406,10 +1597,11 @@ Used for determining the default for the next `gds-load-file'.")
       nil
     (let ((process-connection-type nil))
       (setq gds-captive (make-comint "captive-guile"
-				     "guile"
+				     gds-guile-program
 				     nil
 				     "-q")))
     (let ((proc (get-buffer-process gds-captive)))
+      (process-kill-without-query proc)
       (comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n")
       (comint-send-string proc "(debug-enable 'backtrace)\n")
       (comint-send-string proc "(use-modules (emacs gds-client))\n")
@@ -1417,13 +1609,18 @@ Used for determining the default for the next `gds-load-file'.")
 
 (defun gds-kill-captive ()
   (if gds-captive
-      (let ((proc (get-buffer-process gds-captive)))
-	(process-kill-without-query proc)
-	(condition-case nil
-	    (progn
-	      (kill-process proc)
-	      (accept-process-output gds-process 0 200))
-	  (error)))))
+      (condition-case nil
+	  (progn
+	    (kill-process (get-buffer-process gds-captive))
+	    (accept-process-output gds-process 0 200))
+	(error))))
+
+
+;;;; If requested, autostart the server after loading.
+
+(if (and gds-autostart-server
+	 (not gds-process))
+    (gds-start))
 
 
 ;;;; The end!