;;; 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)))))