Work (in progress) on new debugging frontend.

emacs/gds.el

@@ -0,0 +1,748 @@
+;;; gds.el -- Guile debugging frontend
+
+;;;; 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
+
+
+;;;; Prerequisites.
+
+(require 'widget)
+(require 'wid-edit)
+
+
+;;;; Debugging (of this code!).
+
+(defsubst dmessage (msg &rest args)
+  ;;(apply (function message) msg args)
+  )
+
+
+;;;; Customization group setup.
+
+(defgroup gds nil
+  "Customization options for Guile Debugging."
+  :group 'scheme)
+
+
+;;;; Communication with the (ice-9 debugger ui-server) subprocess.
+
+;; The subprocess object.
+(defvar gds-process nil)
+
+;; 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)
+
+;; Start (or restart) the subprocess.
+(defun gds-start ()
+  (if gds-process (gds-shutdown))
+  (with-current-buffer (get-buffer-create "*GDS Process*")
+    (erase-buffer)
+    (setq gds-process
+	  (let ((process-connection-type nil)) ; use a pipe
+	    (start-process "gds"
+			   (current-buffer)
+			   "guile"
+			   "-q"
+			   "--debug"
+			   "-e"
+			   "run"
+			   "-s"
+			   "/home/neil/Guile/cvs/guile-core/ice-9/debugger/ui-server.scm"))))
+  (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))
+
+;; Shutdown the subprocess and cleanup all associated data.
+(defun gds-shutdown ()
+  ;; Do cleanup for all clients.
+  (while gds-names
+    (gds-client-cleanup (caar gds-names)))
+  ;; Reset any remaining variables.
+  (setq gds-displayed-client nil
+	gds-waiting nil)
+  ;; If the timer is running, cancel it.
+  (if gds-timer
+      (cancel-timer gds-timer))
+  (setq gds-timer nil)
+  ;; Kill the subprocess.
+  (process-kill-without-query gds-process)
+  (condition-case nil
+      (progn
+	(kill-process gds-process)
+	(accept-process-output gds-process 0 200))
+    (error))
+  (setq gds-process nil))
+
+;; 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-handle-input'.
+(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
+		   (gds-handle-input 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)
+  )
+
+;; Send input to the subprocess.
+(defun gds-send (string)
+  (process-send-string gds-process string))
+
+
+;;;; Multiple application scheduling.
+
+;; At any moment one Guile application has the focus of the frontend
+;; code.  `gds-displayed-client' holds the port number of that client.
+;; If there are no Guile applications wanting the focus - that is,
+;; ready for debugging instructions - `gds-displayed-client' is nil.
+(defvar gds-displayed-client nil)
+
+;; The list of other Guile applications waiting for focus, referenced
+;; by their port numbers.
+(defvar gds-waiting nil)
+
+;; An idle timer that we use to avoid confusing any user work when
+;; popping up debug buffers.  `gds-timer' is non-nil whenever the
+;; timer is running and nil whenever it is not running.
+(defvar gds-timer nil)
+
+;; Debug the specified client.  If it already has the focus, do so
+;; immediately, but using the idle timer to ensure that it doesn't
+;; confuse any work the user may be doing.  Non-structural work is
+;; delegated to `gds-display-state'.
+(defun gds-debug (&optional client)
+  (dmessage "gds-debug")
+  ;; If `client' is specified, add it to the end of `gds-waiting',
+  ;; unless that client is already the current client or it is already
+  ;; in the waiting list.
+  (if (and client
+	   (not (eq client gds-displayed-client))
+	   (not (memq client gds-waiting)))
+      (setq gds-waiting (append gds-waiting (list client))))
+  ;; Now update `client' to be the next client in the list.
+  (setq client (or gds-displayed-client (car gds-waiting)))
+  ;; If conditions are right, start the idle timer.
+  (if (and client
+	   (or (null gds-displayed-client)
+	       (eq gds-displayed-client client)))
+      (gds-display-state (or gds-displayed-client
+			     (prog1 (car gds-waiting)
+			       (setq gds-waiting
+				     (cdr gds-waiting)))))))
+
+;; Give up focus because debugging is done for now.  Display detail in
+;; case of no waiting clients is delegated to `gds-clear-display'.
+(defun gds-focus-done ()
+  (gds-clear-display)
+  (gds-debug))
+
+;; Although debugging of this client isn't done, yield focus to the
+;; next waiting client.
+(defun gds-focus-yield ()
+  (interactive)
+  (if (and (null gds-waiting)
+	   (y-or-n-p "No other clients waiting - bury *Guile Debug* buffer? "))
+      (bury-buffer)
+    (or (memq gds-displayed-client gds-waiting)
+	(setq gds-waiting (append gds-waiting (list gds-displayed-client))))
+    (gds-focus-done)))
+
+
+;;;; Per-client state information.
+
+;; Alist mapping client port numbers to application names.  The names
+;; in this list have been uniquified by `gds-uniquify'.
+(defvar gds-names nil)
+
+;; Return unique form of NAME.
+(defun gds-uniquify (name)
+  (let ((count 1)
+	(maybe-unique name))
+    (while (member maybe-unique (mapcar (function cdr) gds-names))
+      (setq count (1+ count)
+	    maybe-unique (concat name "<" (number-to-string count) ">")))
+    maybe-unique))
+
+;; Alist mapping client port numbers to last known status.
+;;
+;; Status is one of the following symbols.
+;;
+;;   `running' - application is running.
+;;
+;;   `waiting-for-input' - application is blocked waiting for
+;;   instruction from the frontend.
+;;
+;;   `ready-for-input' - application is not blocked but can also
+;;   accept asynchronous instructions from the frontend.
+;;
+(defvar gds-statuses nil)
+
+;; Alist mapping client port numbers to last printed outputs.
+(defvar gds-outputs nil)
+
+;; Alist mapping client port numbers to last known stacks.
+(defvar gds-stacks nil)
+
+;; Alist mapping client port numbers to module information.  This
+;; looks like:
+;;
+;; ((4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...) ...)
+;;
+;; So, for example:
+;;
+;; (assq client gds-modules)
+;; =>
+;; (4 ((guile) t sym1 sym2 ...) ((guile-user)) ((ice-9 debug) nil sym3 sym4) ...)
+;;
+;; The t or nil after the module name indicates whether the module is
+;; displayed in expanded form (that is, showing the bindings in that
+;; module).
+;;
+;; The syms are actually all strings, because some Guile symbols are
+;; not readable by Emacs.
+(defvar gds-modules nil)
+
+
+;;;; Handling debugging instructions.
+
+;; General dispatch function called by the subprocess filter.
+(defun gds-handle-input (form)
+  (dmessage "Form: %S" form)
+  (let ((client (car form)))
+    (cond ((eq client '*))
+	  (t
+	   (let ((proc (cadr form)))
+
+	     (cond ((eq proc 'name)
+		    ;; (name ...) - Application's name.
+		    (setq gds-names
+			  (cons (cons client (gds-uniquify (caddr form)))
+				gds-names)))
+
+		   ((eq proc 'stack)
+		    ;; (stack ...) - Stack at an error or breakpoint.
+		    (gds-set gds-stacks client (cddr form)))
+
+		   ((eq proc 'modules)
+		    ;; (modules ...) - Application's loaded modules.
+		    (gds-set gds-modules client
+			     (mapcar (function list) (cddr form))))
+
+		   ((eq proc 'output)
+		    ;; (output ...) - Last printed output.
+		    (gds-set gds-outputs client (caddr form)))
+
+		   ((eq proc 'status)
+		    ;; (status ...) - Application status indication.
+		    (let ((status (caddr form)))
+		      (gds-set gds-statuses client status)
+		      (cond ((eq status 'waiting-for-input)
+			     (gds-debug client))
+			    ((eq status 'running)
+			     (if (eq client gds-displayed-client)
+				 (gds-display-state client)))
+			    (t
+			     (error "Unexpected status: %S" status)))))
+
+		   ((eq proc 'module)
+		    ;; (module MODULE ...) - The specified module's bindings.
+		    (let* ((modules (assq client gds-modules))
+			   (minfo (assoc (caddr form) modules)))
+		      (if minfo
+			  (setcdr (cdr minfo) (cdddr form)))))
+
+		   ((eq proc 'closed)
+		    ;; (closed) - Client has gone away.
+		    (gds-client-cleanup client))
+
+		   ))))))
+
+;; Store latest status, stack or module list for the specified client.
+(defmacro gds-set (alist client val)
+  `(let ((existing (assq ,client ,alist)))
+     (if existing
+	 (setcdr existing ,val)
+       (setq ,alist
+	     (cons (cons client ,val) ,alist)))))
+
+;; Cleanup processing when CLIENT goes away.
+(defun gds-client-cleanup (client)
+  (if (eq client gds-displayed-client)
+      (gds-focus-done))
+  (setq gds-names
+	(delq (assq client gds-names) gds-names))
+  (setq gds-stacks
+	(delq (assq client gds-stacks) gds-stacks))
+  (setq gds-modules
+	(delq (assq client gds-modules) gds-modules)))
+
+
+;;;; Displaying debugging information.
+
+(defvar gds-client-buffer nil)
+
+(define-derived-mode gds-mode
+  fundamental-mode
+  "Guile Debugging"
+  "Major mode for Guile debugging information buffers.")
+
+(defun gds-set-client-buffer (&optional client)
+  (if (and gds-client-buffer
+	   (buffer-live-p gds-client-buffer))
+      (set-buffer gds-client-buffer)
+    (setq gds-client-buffer (get-buffer-create "*Guile Debug*"))
+    (set-buffer gds-client-buffer)
+    (gds-mode))
+  ;; Rename to something we don't want first.  Otherwise, if the
+  ;; buffer is already correctly named, we get a confusing change
+  ;; from, say, `*Guile Debug: REPL*' to `*Guile Debug: REPL*<2>'.
+  (rename-buffer "*Guile Debug Fake Buffer Name*" t)
+  (rename-buffer (if client
+		     (concat "*Guile Debug: "
+			     (cdr (assq client gds-names))
+			     "*")
+		   "*Guile Debug*")
+		 t)			; Rename uniquely if needed,
+					; although it shouldn't be.
+  (force-mode-line-update t))
+
+(defun gds-clear-display ()
+  ;; Clear the client buffer.
+  (gds-set-client-buffer)
+  (let ((inhibit-read-only t))
+    (erase-buffer)
+    (insert "Stack:\nNo clients ready for debugging.\n")
+    (goto-char (point-min)))
+  (setq gds-displayed-stack 'no-clients)
+  (setq gds-displayed-modules nil)
+  (setq gds-displayed-client nil)
+  (bury-buffer))
+
+;; Determine whether the client display buffer is visible in the
+;; currently selected frame (i.e. where the user is editing).
+(defun gds-buffer-visible-in-selected-frame-p ()
+  (let ((visible-p nil))
+    (walk-windows (lambda (w)
+		    (if (eq (window-buffer w) gds-client-buffer)
+			(setq visible-p t))))
+    visible-p))
+
+;; Cached display variables for `gds-display-state'.
+(defvar gds-displayed-stack nil)
+(defvar gds-displayed-modules nil)
+
+;; Types of display areas in the *Guile Debug* buffer.
+(defvar gds-display-types '("Status" "Stack" "Modules"))
+(defvar gds-display-type-regexp
+  (concat "^\\("
+	  (substring (apply (function concat)
+			    (mapcar (lambda (type)
+				      (concat "\\|" type))
+				    gds-display-types))
+		     2)
+	  "\\):"))
+
+(defun gds-maybe-delete-region (type)
+  (let ((beg (save-excursion
+	       (goto-char (point-min))
+	       (and (re-search-forward (concat "^"
+					       (regexp-quote type)
+					       ":")
+				       nil t)
+		    (match-beginning 0)))))
+    (if beg
+	(delete-region beg
+		       (save-excursion
+			 (goto-char beg)
+			 (end-of-line)
+			 (or (and (re-search-forward gds-display-type-regexp
+						     nil t)
+				  (match-beginning 0))
+			     (point-max)))))))
+
+(defun gds-maybe-skip-region (type)
+  (if (looking-at (regexp-quote type))
+      (if (re-search-forward gds-display-type-regexp nil t 2)
+	  (beginning-of-line)
+	(goto-char (point-max)))))
+
+(defun gds-display-state (client)
+  (dmessage "gds-display-state")
+  ;; Avoid continually popping up the last associated source buffer
+  ;; unless it really is still current.
+  (setq gds-selected-frame-source-buffer nil)
+  (gds-set-client-buffer client)
+  (let ((stack (cdr (assq client gds-stacks)))
+	(modules (cdr (assq client gds-modules)))
+	(inhibit-read-only t)
+	(p (if (eq client gds-displayed-client)
+	       (point)
+	     (point-min)))
+	stack-changed)
+    ;; Start at top of buffer.
+    (goto-char (point-min))
+    ;; Display status; too simple to be worth caching.
+    (gds-maybe-delete-region "Status")
+    (widget-insert "Status: "
+		   (cdr (assq (cdr (assq client gds-statuses))
+			      '((running . "running")
+				(waiting-for-input . "waiting for input")
+				(ready-for-input . "ready for input"))))
+		   "\n\n")
+    (let ((output (cdr (assq client gds-outputs))))
+      (if (> (length output) 0)
+	  (widget-insert output "\n\n")))
+    ;; Display stack.
+    (dmessage "insert stack")
+    (if (equal stack gds-displayed-stack)
+	(gds-maybe-skip-region "Stack")
+      ;; Note that stack has changed.
+      (if stack (setq stack-changed t))
+      ;; Delete existing stack.
+      (gds-maybe-delete-region "Stack")
+      ;; Insert new stack.		       
+      (if stack (gds-insert-stack stack))
+      ;; Record displayed stack.
+      (setq gds-displayed-stack stack))
+    ;; Display module list.
+    (dmessage "insert modules")
+    (if (equal modules gds-displayed-modules)
+	(gds-maybe-skip-region "Modules")
+      ;; Delete existing module list.
+      (gds-maybe-delete-region "Modules")
+      ;; Insert new list.
+      (if modules (gds-insert-modules modules))
+      ;; Record displayed list.
+      (setq gds-displayed-modules (copy-tree modules)))
+    ;; Finish off.
+    (dmessage "widget-setup")
+    (widget-setup)
+    (if stack-changed
+	;; Stack is being seen for the first time, so make sure top of
+	;; buffer is visible.
+	(progn
+	  (goto-char (point-min))
+	  (re-search-forward "^Stack:")
+	  (forward-line (+ 1 (cadr stack))))
+      ;; Restore point from before buffer was redrawn.
+      (goto-char p)))
+  (setq gds-displayed-client client)
+  (dmessage "consider display")
+  (if (eq (window-buffer (selected-window)) gds-client-buffer)
+      ;; *Guile Debug* buffer already selected.
+      (gds-display-buffers)
+    (dmessage "Running GDS timer")
+    (setq gds-timer
+	  (run-with-idle-timer 0.5
+			       nil
+			       (lambda ()
+				 (setq gds-timer nil)
+				 (gds-display-buffers))))))
+
+(defun gds-display-buffers ()
+  ;; If there's already a window showing the *Guile Debug* buffer, use
+  ;; it.
+  (let ((window (get-buffer-window gds-client-buffer t)))
+    (if window
+	(progn
+	  (make-frame-visible (window-frame window))
+	  (raise-frame (window-frame window))
+	  (select-frame (window-frame window))
+	  (select-window window))
+      (switch-to-buffer gds-client-buffer)))
+  ;; If there is an associated source buffer, display it as well.
+  (if gds-selected-frame-source-buffer
+      (let ((window (display-buffer gds-selected-frame-source-buffer)))
+	(set-window-point window
+			  (overlay-start gds-selected-frame-source-overlay))))
+  ;; 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))
+	(flags (caddr stack))
+	frame items)
+    (widget-insert "Stack: " (prin1-to-string flags) "\n")
+    (let ((i -1))
+      (gds-show-selected-frame (caddr (nth index frames)))
+      (while frames
+	(setq frame (car frames)
+	      frames (cdr frames)
+	      i (+ i 1)
+	      items (cons (list 'item
+				(let ((s (cadr frame)))
+				  (put-text-property 0 1 'index i s)
+				  s))
+			  items))))
+    (setq items (nreverse items))
+    (apply (function widget-create)
+	     'radio-button-choice
+	     :value (cadr (nth index items))
+	     :notify (function gds-select-stack-frame)
+	     items)
+    (widget-insert "\n")))
+
+(defun gds-select-stack-frame (widget &rest ignored)
+  (let* ((s (widget-value widget))
+	 (ind (memq 'index (text-properties-at 0 s))))
+    (gds-send (format "(%S debugger-command frame %d)\n"
+		      gds-displayed-client
+		      (cadr ind)))))
+
+;; Overlay used to highlight the source expression corresponding to
+;; the selected frame.
+(defvar gds-selected-frame-source-overlay nil)
+
+;; Buffer containing source for the selected frame.
+(defvar gds-selected-frame-source-buffer nil)
+
+(defun gds-show-selected-frame (source)
+  ;; Highlight the frame source, if possible.
+  (if (and source
+	   (file-readable-p (car source)))
+      (with-current-buffer (find-file-noselect (car source))
+	(if gds-selected-frame-source-overlay
+	    nil
+	  (setq gds-selected-frame-source-overlay (make-overlay 0 0))
+	  (overlay-put gds-selected-frame-source-overlay 'face 'highlight))
+	;; 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-selected-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)))
+	(setq gds-selected-frame-source-buffer (current-buffer)))
+    (if gds-selected-frame-source-overlay
+	(move-overlay gds-selected-frame-source-overlay 0 0))))
+
+(defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil))
+  "Specification of which Guile modules the debugger should display.
+This is a list with structure (DEFAULT EXCEPTION EXCEPTION...), where
+DEFAULT is `t' or `nil' and each EXCEPTION has the structure (SYMBOL
+DEFAULT EXCEPTION EXCEPTION...).
+
+A Guile module name `(x y z)' is matched against this filter as
+follows.  If one of the top level EXCEPTIONs has SYMBOL `x', continue
+by matching the rest of the module name, in this case `(y z)', against
+that SYMBOL's DEFAULT and next level EXCEPTION list.  Otherwise, if
+the current DEFAULT is `t' display the module, and if the current
+DEFAULT is `nil', don't display it.
+
+This variable is usually set to exclude Guile system modules that are
+not of primary interest when debugging application code."
+  :type 'sexp
+  :group 'gds)
+
+(defun gds-show-module-p (name)
+  ;; Determine whether to display the NAMEd module by matching NAME
+  ;; against `gds-module-filter'.
+  (let ((default (car gds-module-filter))
+	(exceptions (cdr gds-module-filter)))
+    (let ((exception (assq (car name) exceptions)))
+      (if exception
+	  (let ((gds-module-filter (cdr exception)))
+	    (gds-show-module-p (cdr name)))
+	default))))
+
+(defun gds-insert-modules (modules)
+  (insert "Modules:\n")
+  (while modules
+    (let ((minfo (car modules)))
+      (if (gds-show-module-p (car minfo))
+	  (let ((w (widget-create 'push-button
+				  :notify (function gds-module-notify)
+				  (if (and (cdr minfo)
+					   (cadr minfo))
+				      "-" "+"))))
+	    (widget-put w :module (cons client (car minfo)))
+	    (widget-insert " " (prin1-to-string (car minfo)) "\n")
+	    (if (cadr minfo)
+		(let ((syms (cddr minfo)))
+		  (while syms
+		    (widget-insert " > " (car syms) "\n")
+		    (setq syms (cdr syms))))))))
+    (setq modules (cdr modules))))
+
+(defun gds-module-notify (w &rest ignore)
+  (let* ((module (widget-get w :module))
+	 (client (car module))
+	 (name (cdr module))
+	 (modules (assq client gds-modules))
+	 (minfo (assoc name modules)))
+    (if (cdr minfo)
+	;; Just toggle expansion state.
+	(progn
+	  (setcar (cdr minfo) (not (cadr minfo)))
+	  (gds-display-state client))
+      ;; Set flag to indicate module expanded.
+      (setcdr minfo (list t))
+      ;; Get symlist from Guile.
+      (gds-send (format "(%S query-module %S)\n" client name)))))
+
+
+;;;; Guile Debugging keymap.
+
+(set-keymap-parent gds-mode-map widget-keymap)
+(define-key gds-mode-map "g" (function gds-go))
+(define-key gds-mode-map "b" (function gds-set-breakpoint))
+(define-key gds-mode-map "q" (function gds-quit))
+(define-key gds-mode-map "y" (function gds-yield))
+(define-key gds-mode-map " " (function gds-next))
+(define-key gds-mode-map "e" (function gds-evaluate))
+(define-key gds-mode-map "i" (function gds-step-in))
+(define-key gds-mode-map "o" (function gds-step-out))
+(define-key gds-mode-map "t" (function gds-trace-finish))
+
+(defun gds-client-waiting ()
+  (eq (cdr (assq gds-displayed-client gds-statuses)) 'waiting-for-input))
+
+(defun gds-go ()
+  (interactive)
+  (gds-send (format "(%S debugger-command continue)\n" gds-displayed-client)))
+
+(defun gds-quit ()
+  (interactive)
+  (if (gds-client-waiting)
+      (if (y-or-n-p "Client is waiting for instruction - tell it to continue? ")
+	  (gds-go)))
+  (gds-yield))
+
+(defun gds-yield ()
+  (interactive)
+  (if (gds-client-waiting)
+      (gds-focus-yield)
+    (gds-focus-done)))
+
+(defun gds-next ()
+  (interactive)
+  (gds-send (format "(%S debugger-command next 1)\n" gds-displayed-client)))
+
+(defun gds-evaluate (expr)
+  (interactive "sEvaluate (in this stack frame): ")
+  (gds-send (format "(%S debugger-command evaluate %s)\n"
+		    gds-displayed-client
+		    (prin1-to-string expr))))
+
+(defun gds-step-in ()
+  (interactive)
+  (gds-send (format "(%S debugger-command step 1)\n" gds-displayed-client)))
+
+(defun gds-step-out ()
+  (interactive)
+  (gds-send (format "(%S debugger-command finish)\n" gds-displayed-client)))
+
+(defun gds-trace-finish ()
+  (interactive)
+  (gds-send (format "(%S debugger-command trace-finish)\n"
+		    gds-displayed-client)))
+
+(defun gds-set-breakpoint ()
+  (interactive)
+  (cond ((gds-in-source-buffer)
+	 (gds-set-source-breakpoint))
+	((gds-in-stack)
+	 (gds-set-stack-breakpoint))
+	((gds-in-modules)
+	 (gds-set-module-breakpoint))
+	(t
+	 (error "No way to set a breakpoint from here"))))
+
+(defun gds-in-source-buffer ()
+  ;; Not yet worked out what will be available in Scheme source
+  ;; buffers.
+  nil)
+
+(defun gds-in-stack ()
+  (and (eq (current-buffer) gds-client-buffer)
+       (save-excursion
+	 (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
+	      (looking-at "Stack")))))
+
+(defun gds-in-modules ()
+  (and (eq (current-buffer) gds-client-buffer)
+       (save-excursion
+	 (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
+	      (looking-at "Modules")))))
+
+(defun gds-set-module-breakpoint ()
+  (let ((sym (save-excursion
+	       (beginning-of-line)
+	       (and (looking-at " > \\([^ \n\t]+\\)")
+		    (match-string 1))))
+	(module (save-excursion
+		  (and (re-search-backward "^\\[[+---]\\] \\(([^)]+)\\)" nil t)
+		       (match-string 1)))))
+    (or sym
+	(error "Couldn't find procedure name on current line"))
+    (or module
+	(error "Couldn't find module name for current line"))
+    (let ((behaviour
+	   (completing-read
+	    (format "Behaviour for breakpoint at %s:%s (default debug-here): "
+		    module sym)
+	    '(("debug-here")
+	      ("trace-here")
+	      ("trace-subtree"))
+	    nil
+	    t
+	    nil
+	    nil
+	    "debug-here")))
+      (gds-send (format "(%S set-breakpoint %s %s %s)\n"
+			gds-displayed-client
+			module
+			sym
+			behaviour)))))

ice-9/ChangeLog

@@ -1,3 +1,22 @@
+2003-09-25  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* debugger/ui-client.scm, debugger/ui-server.scm: New (work in
+	progress on new debugging front end).
+
+2003-09-24  Neil Jerram  <neil@ossau.uklinux.net>
+
+	* debugger.scm (default-default-lazy-handler, debug-on-error):
+	New.
+
+	* debugger/behaviour.scm (debug-if-flag-set): Display debug entry
+	messages through (debugger-output-port).
+	(after-exit-frame-hook): Trace through (debugger-output-port).
+	(trace-here): Trace through (debugger-output-port).
+
+	* debugger/commands.scm (evaluate): If supplied expression is a
+	string, read from it before evaluating.
+	(evaluate): Change output format to "EXPR => VALUE".
+
 2003-09-19  Kevin Ryde  <user42@zip.com.au>
 
 	* popen.scm (open-process): Correction to previous fdes closing

ice-9/debugger.scm

@@ -19,6 +19,7 @@
 (define-module (ice-9 debugger)
   #:use-module (ice-9 debugger command-loop)
   #:use-module (ice-9 debugger state)
+  #:use-module (ice-9 debugger ui-client)
   #:use-module (ice-9 debugger utils)
   #:use-module (ice-9 format)
   #:export (debug-stack
@@ -27,7 +28,8 @@
 	    debugger-error
 	    debugger-quit
 	    debugger-input-port
-	    debugger-output-port)
+	    debugger-output-port
+	    debug-on-error)
   #:no-backtrace)
 
 ;;; The old (ice-9 debugger) has been factored into its constituent
@@ -119,7 +121,9 @@ Indicates that the debugger should display an introductory message.
 			(display "There is 1 frame on the stack.\n\n")
 			(format #t "There are ~A frames on the stack.\n\n" ssize))))
 	      (write-state-short state)
-	      (debugger-command-loop state))))))))
+	      (if (ui-connected?)
+		  (ui-command-loop state)
+		  (debugger-command-loop state)))))))))
 
 (define (debug)
   "Invoke the Guile debugger to explore the context of the last error."
@@ -152,4 +156,20 @@ Indicates that the debugger should display an introductory message.
      (lambda () output-port)
      (lambda (port) (set! output-port port)))))
 
+;;; {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
+	(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)))
+
 ;;; (ice-9 debugger) ends here.

ice-9/debugger/Makefile.am

@@ -25,7 +25,7 @@ SUBDIRS = breakpoints
 
 # These should be installed and distributed.
 ice9_debugger_sources = behaviour.scm breakpoints.scm command-loop.scm \
-	commands.scm state.scm trap-hooks.scm trc.scm utils.scm
+	commands.scm state.scm trap-hooks.scm trc.scm utils.scm ui-client.scm
 
 subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/ice-9/debugger
 subpkgdata_DATA = $(ice9_debugger_sources)

ice-9/debugger/behaviour.scm

@@ -88,7 +88,9 @@
 (define (debug-if-flag-set)
   (if *debug-flag*
       (begin
-	(for-each display (reverse! *debug-entry-messages*))
+	(for-each (lambda (msg)
+		    (display msg (debugger-output-port)))
+		  (reverse! *debug-entry-messages*))
 	(set! *debug-entry-messages* '())
 	(debug-stack (make-stack *cont*) #:continuable))))
 
@@ -99,15 +101,16 @@
 (add-hook! after-exit-frame-hook
 	   (lambda ()
 	     (if *trace-retval*
-		 (begin
+		 (with-output-to-port (debugger-output-port)
-		   (let indent ((td *trace-depths*))
+		   (lambda ()
-		     (cond ((null? td))
+		     (let indent ((td *trace-depths*))
-			   (else (display "|  ")
+		       (cond ((null? td))
-				 (indent (cdr td)))))
+			     (else (display "|  ")
-		   (display "|  ")
+				   (indent (cdr td)))))
-		   (write *retval*)
+		     (display "|  ")
-		   (newline)
+		     (write *retval*)
-		   (set! *trace-retval* #f)))
+		     (newline)
+		     (set! *trace-retval* #f))))
 	     (debug-if-flag-set)))
 
 (define (frame-depth frame)
@@ -250,15 +253,17 @@
 		       (else (loop (+ frame-number 1)))))))
 	(if push-current-depth
 	    (set! *trace-depths* (cons *depth* *trace-depths*)))
-	(let indent ((td *trace-depths*))
+	(with-output-to-port (debugger-output-port)
-	  (cond ((null? td))
+	  (lambda ()
-		(else
+	    (let indent ((td *trace-depths*))
-		 (display "|  ")
+	      (cond ((null? td))
-		 (indent (cdr td)))))
+		    (else
-	((if *expr*
+		     (display "|  ")
-	     write-frame-short/expression
+		     (indent (cdr td)))))
-	     write-frame-short/application) *frame*)
+	    ((if *expr*
-	(newline)
+		 write-frame-short/expression
+		 write-frame-short/application) *frame*)
+	    (newline)))
 	(if push-current-depth
 	    (at-exit (lambda ()
 		       (set! *trace-depths* (cdr *trace-depths*))

ice-9/debugger/commands.scm

@@ -84,9 +84,22 @@ however it may be continued over multiple lines."
 	       (lambda ()
 		 (lazy-catch #t
 			     (lambda ()
-			       (let* ((env (memoized-environment source))
+			       (let* ((expr
-				      (value (local-eval expression env)))
+				       ;; We assume that no one will
-				 (display ";value: ")
+				       ;; really want to evaluate a
+				       ;; string (since it is
+				       ;; self-evaluating); so if we
+				       ;; have a string here, read the
+				       ;; expression to evaluate from
+				       ;; it.
+				       (if (string? expression)
+					   (with-input-from-string expression
+								   read)
+					   expression))
+				      (env (memoized-environment source))
+				      (value (local-eval expr env)))
+				 (write expr)
+				 (display " => ")
 				 (write value)
 				 (newline)))
 			     eval-handler))

ice-9/debugger/ui-client.scm

@@ -0,0 +1,242 @@
+;;;; 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)
+  #: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"))
+  ;; 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 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."))
+  (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*)))
+
+(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)
+  ;; 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)
+    (else state)))
+
+(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.