Work on debugger frontend code.

emacs/gds.el

@@ -297,20 +297,6 @@
 
 		   ))))))
 
-(defun gds-display-results (client results)
-  (let ((buf (get-buffer-create "*Guile Results*")))
-    (save-excursion
-      (set-buffer buf)
-      (erase-buffer)
-      (while results
-	(insert (car results))
-	(mapcar (function (lambda (value)
-			    (insert " => " value "\n")))
-		(cadr results))
-	(insert "\n")
-	(setq results (cddr results))))
-    (pop-to-buffer buf)))
-
 ;; Store latest status, stack or module list for the specified client.
 (defmacro gds-set (alist client val)
   `(let ((existing (assq ,client ,alist)))
@@ -512,17 +498,6 @@
   ;; Force redisplay.
   (sit-for 0))
 
-(defun old-stuff ()
-  (if (gds-buffer-visible-in-selected-frame-p)
-      ;; Buffer already visible enough.
-      nil
-    ;; Delete any views of the buffer in other frames - we don't want
-    ;; views all over the place.
-    (delete-windows-on gds-client-buffer)
-    ;; Run idle timer to display the buffer as soon as user isn't in
-    ;; the middle of something else.
-    ))
-
 (defun gds-insert-stack (stack)
   (let ((frames (car stack))
 	(index (cadr stack))
@@ -780,7 +755,7 @@ not of primary interest when debugging application code."
 ;; 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-displayed-client'.  Where no application has the focus,
-;; or the command is invoked `C-u', GDS asks the user which
+;; or the command is invoked with `C-u', GDS asks the user which
 ;; application is intended.
 
 (defun gds-read-client ()
@@ -793,14 +768,16 @@ not of primary interest when debugging application code."
 		   "Application for eval: "))
 	 (name
 	  (completing-read prompt
-			   (mapcar (function cdr) gds-names)
+			   (mapcar (function list)
+				   (mapcar (function cdr) gds-names))
 			   nil t nil nil
 			   def)))
     (let (client (names gds-names))
       (while (and names (not client))
-	(if (string-equal (cadar names) name)
+	(if (string-equal (cdar names) name)
 	    (setq client (caar names)))
-	(setq names (cdr names))))))
+	(setq names (cdr names)))
+      client)))
 
 (defun gds-choose-client (client)
   (or ;; If client is an integer, it is the port number of the
@@ -813,18 +790,25 @@ not of primary interest when debugging application code."
       ;; If ask not forced, and there is a client with the focus,
       ;; default to that one.
       gds-displayed-client
+      ;; If there are no clients at this point, and we are allowed to
+      ;; autostart a captive Guile, do so.
+      (and (null gds-names)
+	   gds-autostart-captive
+	   (progn
+	     (gds-start-captive t)
+	     (while (null gds-names)
+	       (accept-process-output (get-buffer-process gds-captive)
+				      0 100000))
+	     (caar gds-names)))
+      ;; If there is only one known client, use that one.
+      (if (and (car gds-names)
+	       (null (cdr gds-names)))
+	  (caar gds-names))
       ;; Last resort - ask the user.
       (gds-read-client)
       ;; Signal an error.
       (error "No application chosen.")))
 
-(defcustom gds-default-module-name '(guile-user)
-  "Name of the default module for GDS code evaluation, as list of symbols.
-This module is used when there is no `define-module' form in the
-buffer preceding the code to be evaluated."
-  :type 'sexp
-  :group 'gds)
-
 (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."
@@ -887,6 +871,66 @@ region's code."
   (interactive "P")
   (gds-eval-region (save-excursion (backward-sexp) (point)) (point) client))
 
+
+;;;; Help.
+
+;; Help is implemented as a special case of evaluation, where we
+;; arrange for the evaluation result to be a known symbol that is
+;; unlikely to crop up otherwise.  When the evaluation result is this
+;; symbol, we only display the output from the evaluation.
+
+(defvar gds-help-symbol '%-gds-help-%
+  "Symbol used by GDS to identify an evaluation response as help.")
+
+(defun gds-help-symbol (sym &optional client)
+  "Get help for SYM (a Scheme symbol)."
+  (interactive "SHelp for symbol: \nP")
+  (gds-eval-expression (format "(begin (help %S) '%S)" sym gds-help-symbol)
+		       client))
+
+(defun gds-help-symbol-here (&optional client)
+  (interactive "P")
+  (gds-help-symbol (thing-at-point 'symbol) client))
+
+(defun gds-apropos (regex &optional client)
+  "List Guile symbols matching REGEX."
+  (interactive "sApropos Guile regex: \nP")
+  (gds-eval-expression (format "(begin (apropos %S) '%S)" regex gds-help-symbol)
+		       client))
+
+
+;;;; Display of evaluation and help results.
+
+(defun gds-display-results (client results)
+  (let ((helpp (and (= (length results) 2)
+		    (= (length (cadr results)) 1)
+		    (string-equal (caadr results)
+				  (prin1-to-string gds-help-symbol)))))
+    (let ((buf (get-buffer-create (if helpp
+				      "*Guile Help*"
+				    "*Guile Results*"))))
+      (save-excursion
+	(set-buffer buf)
+	(erase-buffer)
+	(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))))
+
+
+;;;; Loading (evaluating) a whole Scheme file.
+
 (defcustom gds-source-modes '(scheme-mode)
   "*Used to determine if a buffer contains Scheme source code.
 If it's loaded into a buffer that is in one of these major modes, it's
@@ -973,6 +1017,9 @@ Used for determining the default for the next `gds-load-file'.")
 (if gds-advanced-menu
     nil
   (setq gds-advanced-menu (make-sparse-keymap "Advanced"))
+  (define-key gds-advanced-menu [run-captive]
+    '(menu-item "Run Captive Guile" gds-start-captive
+		:enable (not (comint-check-proc gds-captive))))
   (define-key gds-advanced-menu [restart-gds]
     '(menu-item "Restart IDE" gds-start :enable gds-process))
   (define-key gds-advanced-menu [kill-gds]
@@ -989,18 +1036,21 @@ Used for determining the default for the next `gds-load-file'.")
     (cons "Advanced" gds-advanced-menu))
   (define-key gds-menu [separator-1]
     '("--"))
-  (define-key gds-menu [help]
-    `(menu-item "Help" ,gds-help-menu :enable gds-names))
-  (define-key gds-menu [eval]
-    `(menu-item "Evaluate" ,gds-eval-menu :enable gds-names))
   (define-key gds-menu [debug]
     `(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client
 						     (gds-client-waiting))))
+  (define-key gds-menu [eval]
+    `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-names
+						      gds-autostart-captive)))
+  (define-key gds-menu [help]
+    `(menu-item "Help" ,gds-help-menu :enable (or gds-names
+						  gds-autostart-captive)))
   (setq menu-bar-final-items
 	(cons 'guile menu-bar-final-items))
   (define-key global-map [menu-bar guile]
     (cons "Guile" gds-menu)))
 
+
 ;;;; Autostarting the GDS server.
 
 (defcustom gds-autostart-server t
@@ -1012,6 +1062,49 @@ Used for determining the default for the next `gds-load-file'.")
 	 (not gds-process))
     (gds-start))
 
+
+;;;; `Captive' Guile - a Guile process that is started when needed to
+;;;; provide help, completion, evaluations etc.
+
+(defcustom gds-autostart-captive t
+  "Whether to automatically start a `captive' Guile process when needed."
+  :type 'boolean
+  :group 'gds)
+
+(defvar gds-captive nil
+  "Buffer of captive Guile.")
+
+(defun gds-start-captive (&optional restart)
+  (interactive)
+  (if (and restart
+	   (comint-check-proc gds-captive))
+      (gds-kill-captive))
+  (if (comint-check-proc gds-captive)
+      nil
+    (let ((process-connection-type nil))
+      (setq gds-captive (make-comint "captive-guile"
+				     "guile"
+				     nil
+				     "-q")))
+    (let ((proc (get-buffer-process gds-captive)))
+      (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 (ice-9 debugger ui-client))\n")
+      (comint-send-string proc "(ui-connect \"Captive Guile\" #f)\n"))))
+
+(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 gds-process)
+	      (accept-process-output gds-process 0 200))
+	  (error)))))
+
+
+;;;; The end!
+
 (provide 'gds)
 
 ;;; gds.el ends here.

ice-9/ChangeLog

@@ -1,3 +1,13 @@
+2003-10-16  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* debugger/ui-client.scm (ui-connect): Add arg to say whether to
+	debug immediately on connection.
+	(ui-eval): Handle exceptions during read and evaluation.
+
+	* debugger.scm (debug-on-error, default-default-lazy-handler):
+	Remove an unnecessary level of indirection in calling lazy
+	handler.
+
 2003-10-12  Marius Vollmer  <mvo@zagadka.de>
 
 	* ftw.scm (directory-files): Close dir-stream when done.  Thanks

ice-9/debugger.scm

@@ -158,18 +158,16 @@ Indicates that the debugger should display an introductory message.
 
 ;;; {Debug on Error}
 
-(define default-default-lazy-handler default-lazy-handler)
-
 (define (debug-on-error syms)
   "Enable or disable debug on error."
-  (set! default-lazy-handler
+  (set! lazy-handler-dispatch
 	(if syms
 	    (lambda (key . args)
 	      (or (memq key syms)
 		  (debug-stack (make-stack #t lazy-handler-dispatch)
 			       #:with-introduction
 			       #:continuable))
-	      (apply default-default-lazy-handler key args))
-	    default-default-lazy-handler)))
+	      (apply default-lazy-handler key args))
+	    default-lazy-handler)))
 
 ;;; (ice-9 debugger) ends here.

ice-9/debugger/ui-client.scm

@@ -1,338 +0,0 @@
-;;;; Guile Debugger UI client
-
-;;; Copyright (C) 2003 Free Software Foundation, Inc.
-;;;
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 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
-
-(define-module (ice-9 debugger ui-client)
-  #:use-module (ice-9 debugger)
-  #:use-module (ice-9 debugger behaviour)
-  #:use-module (ice-9 debugger breakpoints)
-  #:use-module (ice-9 debugger breakpoints procedural)
-  #:use-module (ice-9 debugger state)
-  #:use-module (ice-9 debugger utils)
-  #:use-module (ice-9 optargs)
-  #:use-module (ice-9 session)
-  #:use-module (ice-9 string-fun)
-  #:use-module (ice-9 threads)
-  #:export (ui-port-number
-	    ui-connected?
-	    ui-connect
-	    ui-command-loop)
-  #:no-backtrace)
-
-;; The TCP port number that the UI server listens for application
-;; connections on.
-(define ui-port-number 8333)
-
-;; Once connected, the TCP socket port to the UI server.
-(define ui-port #f)
-
-(define* (ui-connect name #:optional host)
-  "Connect to the debug UI server as @var{name}, a string that should
-be sufficient to describe the calling application to the debug UI
-user.  The optional @var{host} arg specifies the hostname or dotted
-decimal IP address where the UI server is running; default is
-127.0.0.1."
-  (if (ui-connected?)
-      (error "Already connected to UI server!"))
-  ;; Connect to debug server.
-  (set! ui-port
-	(let ((s (socket PF_INET SOCK_STREAM 0))
-	      (SOL_TCP 6)
-	      (TCP_NODELAY 1))
-	  (setsockopt s SOL_TCP TCP_NODELAY 1)
-	  (connect s AF_INET (inet-aton (or host "127.0.0.1")) ui-port-number)
-	  s))
-  ;; Set debugger-output-port so that stuff written to it is
-  ;; accumulated for sending to the debug server.
-  (set! (debugger-output-port)
-	(make-soft-port (vector accumulate-output
-				accumulate-output
-				#f #f #f #f)
-			"w"))
-  ;; Start the asynchronous UI thread.
-  (start-async-ui-thread)
-  ;; Write initial context to debug server.
-  (write-form (list 'name name))
-  (write-form (cons 'modules (map module-name (loaded-modules))))
-  (debug-stack (make-stack #t ui-connect) #:continuable)
-;  (ui-command-loop #f)
-  )
-
-(define ui-disable-async-thread noop)
-(define ui-continue-async-thread noop)
-
-(define (start-async-ui-thread)
-  (let ((mutex (make-mutex))
-	(condition (make-condition-variable))
-	(admin (pipe)))
-    ;; Start the asynchronous UI thread.
-    (begin-thread
-      (lock-mutex mutex)
-      ;;(write (cons admin ui-port))
-      ;;(newline)
-      (let loop ((avail '()))
-	;;(write avail)
-	;;(newline)
-	(if (null? avail)
-	    (begin
-	      (write-status 'ready-for-input)
-	      (loop (car (select (list ui-port (car admin)) '() '()))))
-	    (let ((port (car avail)))
-	      (if (eq? port ui-port)
-		  (handle-instruction #f (read ui-port))
-		  (begin
-		    ;; Notification from debugger that it wants to take
-		    ;; over.  Read the notification char.
-		    (read-char (car admin))
-		    ;; Wait on condition variable - this allows the
-		    ;; debugger thread to grab the mutex.
-		    (wait-condition-variable condition mutex)))
-	      ;; Loop.
-	      (loop (cdr avail))))))
-    ;; Redefine procs used by debugger thread to take control.
-    (set! ui-disable-async-thread
-	  (lambda ()
-	    (write-char #\x (cdr admin))
-	    (force-output (cdr admin))
-	    ;;(display "ui-disable-async-thread: locking mutex...\n"
-	    ;;	     (current-error-port))
-	    (lock-mutex mutex)))
-    (set! ui-continue-async-thread
-	  (lambda ()
-	    (unlock-mutex mutex)
-	    (signal-condition-variable condition)))))
-
-(define accumulated-output '())
-
-(define (accumulate-output obj)
-  (set! accumulated-output
-	(cons (if (string? obj) obj (make-string 1 obj))
-	      accumulated-output)))
-
-(define (get-accumulated-output)
-  (let ((s (apply string-append (reverse! accumulated-output))))
-    (set! accumulated-output '())
-    s))
-
-(define (ui-connected?)
-  "Return @code{#t} if a UI server connected has been made; else @code{#f}."
-  (not (not ui-port)))
-
-(define (ui-command-loop state)
-  "Interact with the UI frontend."
-  (or (ui-connected?)
-      (error "Not connected to UI server."))
-  (ui-disable-async-thread)
-  (catch 'exit-debugger
-	 (lambda ()
-	   (let loop ((state state))
-	     ;; Write accumulated debugger output.
-	     (write-form (list 'output 
-			       (sans-surrounding-whitespace
-				(get-accumulated-output))))
-	     ;; Write current state to the frontend.
-	     (if state (write-stack state))
-	     ;; Tell the frontend that we're waiting for input.
-	     (write-status 'waiting-for-input)
-	     ;; Read next instruction, act on it, and loop with
-	     ;; updated state.
-	     (loop (handle-instruction state (read ui-port)))))
-	 (lambda args *unspecified*))
-  (ui-continue-async-thread))
-
-(define (write-stack state)
-  ;; Write Emacs-readable representation of current state to UI
-  ;; frontend.
-  (let ((frames (stack->emacs-readable (state-stack state)))
-	(index (index->emacs-readable (state-index state)))
-	(flags (flags->emacs-readable (state-flags state))))
-    (if (memq 'backwards (debug-options))
-	(write-form (list 'stack
-			  frames
-			  index
-			  flags))
-	;; Calculate (length frames) here because `reverse!' will make
-	;; the original `frames' invalid.
-	(let ((nframes (length frames)))
-	  (write-form (list 'stack
-			    (reverse! frames)
-			    (- nframes index 1)
-			    flags))))))
-
-(define (write-form form)
-  ;; Write any form FORM to UI frontend.
-  (write form ui-port)
-  (newline ui-port)
-  (force-output ui-port))
-
-(define (stack->emacs-readable stack)
-  ;; Return Emacs-readable representation of STACK.
-  (map (lambda (index)
-	 (frame->emacs-readable (stack-ref stack index)))
-       (iota (stack-length stack))))
-
-(define (frame->emacs-readable frame)
-  ;; Return Emacs-readable representation of FRAME.
-  (if (frame-procedure? frame)
-      (list 'application
-	    (with-output-to-string
-	     (lambda ()
-	       (display (if (frame-real? frame) "  " "T "))
-	       (write-frame-short/application frame)))
-	    (source->emacs-readable (frame-source frame)))
-      (list 'evaluation
-	    (with-output-to-string
-	     (lambda ()
-	       (display (if (frame-real? frame) "  " "T "))
-	       (write-frame-short/expression frame)))
-	    (source->emacs-readable (frame-source frame)))))
-
-(define (source->emacs-readable source)
-  ;; Return Emacs-readable representation of the filename, line and
-  ;; column source properties of SOURCE.
-  (if (and source
-	   (string? (source-property source 'filename)))
-      (list (source-property source 'filename)
-	    (source-property source 'line)
-	    (source-property source 'column))
-      'nil))
-
-(define (index->emacs-readable index)
-  ;; Return Emacs-readable representation of INDEX (the current stack
-  ;; index).
-  index)
-
-(define (flags->emacs-readable flags)
-  ;; Return Emacs-readable representation of FLAGS passed to
-  ;; debug-stack.
-  (map keyword->symbol flags))
-
-(define the-ice-9-debugger-commands-module
-  (resolve-module '(ice-9 debugger commands)))
-
-(define (handle-instruction state ins)
-  ;; Read the newline that always follows an instruction.
-  (read-char ui-port)
-  ;; Handle instruction from the UI frontend, and return updated state.
-  (case (car ins)
-    ((query-module)
-     (let ((name (cadr ins)))
-       (write-form `(module ,name
-			    ,(or (loaded-module-source name) "(no source file)")
-			    ,@(sort (module-map (lambda (key value)
-						  (symbol->string key))
-						(resolve-module name))
-				    string<?))))
-     state)
-    ((debugger-command)
-     (write-status 'running)
-     (let ((name (cadr ins))
-	   (args (cddr ins)))
-       (apply (module-ref the-ice-9-debugger-commands-module name)
-	      state
-	      args)
-       state))
-    ((set-breakpoint)
-     (set-breakpoint! (case (cadddr ins)
-			((debug-here) debug-here)
-			((trace-here) trace-here)
-			((trace-subtree) trace-subtree)
-			(else
-			 (lambda ()
-			   (display "Don't know `")
-			   (display (cadddr ins))
-			   (display "' behaviour; doing `debug-here' instead.\n")
-			   (debug-here))))
-		      (module-ref (resolve-module (cadr ins)) (caddr ins)))
-     state)
-    ((eval)
-     (apply (lambda (module port-name line column code)
-	      (with-input-from-string code
-	        (lambda ()
-		  (set-port-filename! (current-input-port) port-name)
-		  (set-port-line! (current-input-port) line)
-		  (set-port-column! (current-input-port) column)
-		  (let ((m (and module (resolve-module module))))
-		    (let loop ((results '()) (x (read)))
-		      (if (eof-object? x)
-			  (write-form `(eval-results ,@results))
-			  (loop (append results (ui-eval x m))
-				(read))))))))
-	    (cdr ins))
-     state)
-    (else state)))
-
-(define (ui-eval x m)
-  ;; Consumer to accept possibly multiple values and present them for
-  ;; Emacs as a list of strings.
-  (define (value-consumer . values)
-    (if (unspecified? (car values))
-	'()
-	(map (lambda (value)
-	       (with-output-to-string (lambda () (write value))))
-	     values)))
-  (let ((value #f))
-    (let ((output
-	   (with-output-to-string
-	    (lambda ()
-	      (if m
-		  (begin
-		    (display "Evaluating in module ")
-		    (write (module-name m))
-		    (newline)
-		    (set! value
-			  (call-with-values (lambda () (eval x m))
-			    value-consumer)))
-		  (begin
-		    (display "Evaluating in current module ")
-		    (write (module-name (current-module)))
-		    (newline)
-		    (set! value
-			  (call-with-values (lambda () (primitive-eval x))
-			    value-consumer))))))))
-      (list output value))))
-
-(define (write-status status)
-  (write-form (list 'status status)))
-
-(define (loaded-module-source module-name)
-  ;; Return the file name that (ice-9 boot-9) probably loaded the
-  ;; named module from.  (The `probably' is because `%load-path' might
-  ;; have changed since the module was loaded.)
-  (let* ((reverse-name (reverse module-name))
-	 (name (symbol->string (car reverse-name)))
-	 (dir-hint-module-name (reverse (cdr reverse-name)))
-	 (dir-hint (apply string-append
-			  (map (lambda (elt)
-				 (string-append (symbol->string elt) "/"))
-			       dir-hint-module-name))))
-    (%search-load-path (in-vicinity dir-hint name))))
-
-(define (loaded-modules)
-  ;; Return list of all loaded modules sorted by name.
-  (sort (apropos-fold-all (lambda (module acc) (cons module acc)) '())
-	(lambda (m1 m2)
-	  (symlist<? (module-name m1) (module-name m2)))))
-
-(define (symlist<? l1 l2)
-  ;; Return #t if symbol list L1 is alphabetically less than L2.
-  (cond ((null? l1) #t)
-	((null? l2) #f)
-	((eq? (car l1) (car l2)) (symlist<? (cdr l1) (cdr l2)))
-	(else (string<? (symbol->string (car l1)) (symbol->string (car l2))))))
-
-;;; (ice-9 debugger ui-client) ends here.