* gds.el (gds-handle-client-input): Handle new `thread-status'

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

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

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

emacs/.cvsignore

@@ -1,2 +1,6 @@
 Makefile
 Makefile.in
+version.texi
+*.info
+stamp-vti
+mdate-sh

emacs/ChangeLog

@@ -1,3 +1,47 @@
+2004-01-28  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* gds.el (gds-handle-client-input): Handle new `thread-status'
+	protocol.
+	(gds-display-slow-eval): New.
+	(gds-client-ref): Bugfix: buf -> (cdr buf).
+	(gds-display-buffers): Bugfix: minimum overlay end value is 1, not
+	0.
+	(gds-evals-in-progress): New.
+	(gds-results): New.
+	(gds-insert-interaction): Show evaluations in progress (with
+	button to interrupt them) and results of last help or evaluation.
+	(gds-interrupt-eval): New.
+	(gds-debug-trap-hooks, gds-up, gds-down): New.
+	(gds-eval-region, gds-eval-expression): Include abbreviated code
+	in eval correlator.
+	(gds-abbreviated-length, gds-abbreviated): New.
+	(gds-mode-map): New keys for gds-debug-trap-hooks, gds-up,
+	gds-down.
+	(gds-debug-menu): New menu entries for gds-up, gds-down.
+	
+	* gds-client.scm (gds-connect): Enable trapping for gds-eval
+	stacks.
+	(ui-read-thread-proc): Write 'running status earlier.
+	(stack->emacs-readable): Limit stack length to 'depth debug
+	option.
+	(handle-instruction): Update format of eval correlator.
+	(handle-instruction-1): Resolve module names from root module
+	instead of from current module.
+	(resolve-module-from-root): New.
+	(handle-instruction-1): New protocol `interrupt-eval'.
+	(eval-thread-table): New.
+	(eval-thread): Add thread to eval-thread-table; write new protocol
+	to frontend to communicate eval thread status; update for new
+	correlator format; bind correlator local before entering loop2.
+	(gds-eval): Use start-stack 'gds-eval-stack to rebase stack.
+	
+	* gds.el (gds-start, gds-start-captive): Do
+	`process-kill-without-query' as soon as processes started, ...
+	(gds-shutdown, gds-kill-captive): ... instead of here.
+	(gds-display-results): More clearly show unspecified results; show
+	results in interaction view instead of in separate window.
+	(gds-send): Add sent protocol to transcript.
+
 2004-01-26  Neil Jerram  <neil@ossau.uklinux.net>
 
 	* gds.el (gds-request-focus, gds-quit): Simplify.  Old algorithm

emacs/gds-client.scm

@@ -23,6 +23,7 @@
   #:use-module (ice-9 debugger breakpoints procedural)
   #:use-module (ice-9 debugger breakpoints source)
   #:use-module (ice-9 debugger state)
+  #:use-module (ice-9 debugger trap-hooks)
   #:use-module (ice-9 debugger utils)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 regex)
@@ -101,6 +102,7 @@ decimal IP address where the UI server is running; default is
 			"w"))
   ;; Announce ourselves to the server.
   (write-form (list 'name name (getpid)))
+  (add-trapped-stack-id! 'gds-eval-stack)
   ;; Start the UI read thread.
   (set! ui-read-thread (make-thread ui-read-thread-proc)))
 
@@ -124,6 +126,7 @@ decimal IP address where the UI server is running; default is
 ;; this purpose.  This design avoids having to modify application code
 ;; at the expense of requiring a Guile with threads support.
 (define (ui-read-thread-proc)
+  (write-status 'running)
   (let ((eval-thread-needed? #t))
     ;; Start up the default eval thread.
     (make-thread eval-thread 1 (lambda () (not eval-thread-needed?)))
@@ -269,7 +272,8 @@ decimal IP address where the UI server is running; default is
   ;; Return Emacs-readable representation of STACK.
   (map (lambda (index)
 	 (frame->emacs-readable (stack-ref stack index)))
-       (iota (stack-length stack))))
+       (iota (min (stack-length stack)
+		  (cadr (memq 'depth (debug-options)))))))
 
 (define (frame->emacs-readable frame)
   ;; Return Emacs-readable representation of FRAME.
@@ -336,7 +340,7 @@ decimal IP address where the UI server is running; default is
 		  (apply throw key args))
 		 (else
 		  (write-form
-		   `(eval-results error
+		   `(eval-results (error . "")
 				  "GDS Internal Error\n"
 				  ,(list (with-output-to-string
 					  (lambda ()
@@ -373,7 +377,7 @@ decimal IP address where the UI server is running; default is
 			    ,(or (loaded-module-source name) "(no source file)")
 			    ,@(sort (module-map (lambda (key value)
 						  (symbol->string key))
-						(resolve-module name))
+						(resolve-module-from-root name))
 				    string<?))))
      state)
     ((debugger-command)
@@ -397,7 +401,7 @@ decimal IP address where the UI server is running; default is
 			   (display (cadddr ins))
 			   (display "' behaviour; doing `debug-here' instead.\n")
 			   (debug-here))))
-		      (module-ref (resolve-module (cadr ins)) (caddr ins)))
+		      (module-ref (resolve-module-from-root (cadr ins)) (caddr ins)))
      state)
     ((eval)
      (apply (lambda (correlator module port-name line column bpinfo code)
@@ -406,7 +410,7 @@ decimal IP address where the UI server is running; default is
 		  (set-port-filename! (current-input-port) port-name)
 		  (set-port-line! (current-input-port) line)
 		  (set-port-column! (current-input-port) column)
-		  (let ((m (and module (resolve-module module))))
+		  (let ((m (and module (resolve-module-from-root module))))
 		    (let loop ((exprs '()) (x (read)))
 		      (if (eof-object? x)
 			  ;; Expressions to be evaluated have all been
@@ -468,11 +472,23 @@ decimal IP address where the UI server is running; default is
 			    (debug-stack (make-stack #t 3) #:continuable))
 			  thread))
      state)
+    ((interrupt-eval)
+     (let ((thread (hash-ref eval-thread-table (cadr ins))))
+       (system-async-mark (lambda ()
+			    (debug-stack (make-stack #t 3) #:continuable))
+			  thread))
+     state)
     (else state)))
 
 (define the-ice-9-debugger-commands-module
   (resolve-module '(ice-9 debugger commands)))
 
+(define (resolve-module-from-root name)
+  (save-module-excursion
+   (lambda ()
+     (set-current-module the-root-module)
+     (resolve-module name))))
+
 
 ;;;; {Module Browsing}
 
@@ -565,12 +581,19 @@ decimal IP address where the UI server is running; default is
       (set! count (+ count 1))
       count)))
 
+(define eval-thread-table (make-hash-table 3))
+
 (define (eval-thread depth thread-should-exit-thunk)
   ;; Acquire mutex to check trigger variables.
   (with-mutex eval-work-mutex
     (let ((thread-number (next-thread-number)))
+      ;; Add this thread to global hash, so we can correlate back to
+      ;; this thread from the ID used by the GDS front end.
+      (hash-set! eval-thread-table thread-number (current-thread))
       (trc 'eval-thread depth thread-number "entering loop")
       (let loop ()
+	;; Tell the front end this thread is ready.
+	(write-form `(thread-status eval ,thread-number ready))
 	(cond ((thread-should-exit-thunk)
 	       ;; Allow thread to exit.
 	       )
@@ -579,8 +602,11 @@ decimal IP address where the UI server is running; default is
 	       ;; Take a local copy of the work, reset global
 	       ;; variables, then do the work with mutex released.
 	       (trc 'eval-thread depth thread-number "starting work")
-	       (let ((work eval-work)
+	       (let* ((work eval-work)
-		     (subthread-needed? #t))
+		      (subthread-needed? #t)
+		      (correlator (car work)))
+		 ;; Tell the front end this thread is busy.
+		 (write-form `(thread-status eval ,thread-number busy ,correlator))
 		 (set! eval-work-available #f)
 		 (signal-condition-variable eval-work-taken)
 		 (without-mutex eval-work-mutex
@@ -591,14 +617,12 @@ decimal IP address where the UI server is running; default is
 		   (make-thread eval-thread (+ depth 1)
 				(lambda () (not subthread-needed?)))
 		   ;; Do the evaluation(s).
-		   (let loop2 ((correlator (car work))
+		   (let loop2 ((m (cadr work))
-			       (m (cadr work))
 			       (exprs (cddr work))
 			       (results '()))
 		     (if (null? exprs)
 			 (write-form `(eval-results ,correlator ,@results))
-			 (loop2 correlator
+			 (loop2 m
-				m
 				(cdr exprs)
 				(append results (gds-eval (car exprs) m))))))
 		 (trc 'eval-thread depth thread-number "work done")
@@ -615,7 +639,9 @@ decimal IP address where the UI server is running; default is
 	       (wait-condition-variable eval-work-changed eval-work-mutex)
 	       (trc 'eval-thread depth thread-number "wait done")
 	       (loop))))
-      (trc 'eval-thread depth thread-number "exiting"))))
+      (trc 'eval-thread depth thread-number "exiting")
+      ;; Tell the front end this thread is ready.
+      (write-form `(thread-status eval ,thread-number exiting)))))
 
 (define (gds-eval x m)
   ;; Consumer to accept possibly multiple values and present them for
@@ -635,7 +661,8 @@ decimal IP address where the UI server is running; default is
 			  (newline)
 			  (set! value
 				(call-with-values (lambda ()
-						    (eval x m))
+						    (start-stack 'gds-eval-stack
+								 (eval x m)))
 				  value-consumer)))
 			(lambda ()
 			  (display "Evaluating in current module ")
@@ -643,7 +670,8 @@ decimal IP address where the UI server is running; default is
 			  (newline)
 			  (set! value
 				(call-with-values (lambda ()
-						    (primitive-eval x))
+						    (start-stack 'gds-eval-stack
+								 (primitive-eval x)))
 				  value-consumer)))))
 	   (output
 	    (with-output-to-string

emacs/gds.el

@@ -61,7 +61,8 @@
   (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 ()
@@ -70,7 +71,6 @@
   ;; Reset variables.
   (setq gds-buffers nil)
   ;; Kill the subprocess.
-  (process-kill-without-query gds-process)
   (condition-case nil
       (progn
 	(kill-process gds-process)
@@ -104,7 +104,13 @@
 
 ;; 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)))))))
 
 
 ;;;; Focussing in and out on interaction with a particular client.
@@ -314,8 +320,38 @@ The function is called with one argument, the CLIENT in question."
 			   (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.
 
@@ -379,7 +415,7 @@ The function is called with one argument, the CLIENT in question."
 	 (and buf
 	      (cdr buf)
 	      (buffer-live-p (cdr buf))
-	      (with-current-buffer buf
+	      (with-current-buffer (cdr buf)
 		(symbol-value sym))))))
 
 (defun gds-client-blocked ()
@@ -439,7 +475,7 @@ The function is called with one argument, the CLIENT in question."
     ;; 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))
+	     (> (overlay-end gds-frame-source-overlay) 1))
 	(let ((window (display-buffer
 		       (overlay-buffer gds-frame-source-overlay))))
 	  (set-window-point window
@@ -505,6 +541,14 @@ 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)
+
 (defun gds-insert-interaction ()
   (erase-buffer)
   ;; Insert stuff for interacting with a running (non-blocked) Guile
@@ -534,7 +578,18 @@ the following symbols.
   (widget-create 'editable-field
 		 :notify (function gds-set-exception-keys)
 		 gds-exception-keys)
-  (widget-insert "\n"))
+  (let ((evals gds-evals-in-progress))
+    (if evals
+	(widget-insert "\nEvaluations in progress:\n"))
+    (while evals
+      (let ((w (widget-create 'push-button
+			      :notify (function gds-interrupt-eval)
+			      "Interrupt")))
+	(widget-put w :thread-number (caar evals))
+	(widget-insert " " (cddar evals) "\n"))
+      (setq evals (cdr evals))))
+  (if gds-results
+      (widget-insert "\n" (cdr gds-results))))
 
 (defun gds-sigint (w &rest ignore)
   (interactive)
@@ -544,6 +599,11 @@ the following symbols.
   (interactive)
   (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)
   (setq gds-debug-exceptions (widget-value w))
@@ -815,6 +875,18 @@ are not readable by Emacs.")
   (interactive)
   (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.
 
@@ -1107,26 +1179,45 @@ 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"
+    (let ((code (buffer-substring-no-properties start end)))
-		      (if module (prin1-to-string module) "#f")
+      (gds-send (format "eval (region . %S) %s %S %d %d %s %S"
-		      port-name line column
+			(gds-abbreviated code)
-		      (let ((bpinfo (gds-region-breakpoint-info start end)))
+			(if module (prin1-to-string module) "#f")
-			;; Make sure that "no bpinfo" is represented
+			port-name line column
-			;; as "()", not "nil", as Scheme doesn't
+			(let ((bpinfo (gds-region-breakpoint-info start end)))
-			;; understand "nil".
+			  ;; Make sure that "no bpinfo" is represented
-			(if bpinfo (format "%S" bpinfo) "()"))
+			  ;; as "()", not "nil", as Scheme doesn't
-		      (buffer-substring-no-properties start end))
+			  ;; understand "nil".
-	      client)))
+			  (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"
+  (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")
@@ -1219,29 +1310,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
+      (setq gds-results
-	(set-buffer buf)
+	    (save-excursion
-	(erase-buffer)
+	      (set-buffer buf)
-	(scheme-mode)
+	      (erase-buffer)
-	(while results
+	      (scheme-mode)
-	  (insert (car results))
+	      (insert (cdr correlator) "\n\n")
-	  (if helpp
+	      (while results
-	      nil
+		(insert (car results))
-	    (mapcar (function (lambda (value)
+		(or (bolp) (insert "\\\n"))
-				(insert " => " value "\n")))
+		(if helpp
-		    (cadr results))
+		    nil
-	    (insert "\n"))
+		  (if (cadr results)
-	  (setq results (cddr results)))
+		      (mapcar (function (lambda (value)
-	(goto-char (point-min))
+					  (insert " => " value "\n")))
-	(if (and helpp (looking-at "Evaluating in "))
+			      (cadr results))
-	    (delete-region (point) (progn (forward-line 1) (point)))))
+		    (insert " => no (or unspecified) value\n"))
-      (pop-to-buffer buf)
+		  (insert "\n"))
-      (run-hooks 'temp-buffer-show-hook)
+		(setq results (cddr results)))
-      (other-window 1))))
+	      (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.
@@ -1301,7 +1401,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))
@@ -1338,6 +1440,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]
@@ -1464,6 +1570,7 @@ Used for determining the default for the next `gds-load-file'.")
 				     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")
@@ -1471,13 +1578,11 @@ 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)))
+      (condition-case nil
-	(process-kill-without-query proc)
+	  (progn
-	(condition-case nil
+	    (kill-process (get-buffer-process gds-captive))
-	    (progn
+	    (accept-process-output gds-process 0 200))
-	      (kill-process proc)
+	(error))))
-	      (accept-process-output gds-process 0 200))
-	  (error)))))
 
 
 ;;;; The end!