;;; gds.el -- frontend for Guile development in Emacs ;;;; Copyright (C) 2003, 2004 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 ; TODO: ; ?transcript ; scheme-mode menu ; interrupt/sigint/async-break ; (module browsing) ; load file ; doing common protocol from debugger ; thread override for debugging ;;;; Prerequisites. (require 'scheme) (require 'cl) (require 'gds-server) (require 'gds-scheme) ;; The subprocess object for the debug server. (defvar gds-debug-server nil) (defvar gds-socket-type-alist '((tcp . 8333) (unix . "/tmp/.gds_socket")) "Maps each of the possible socket types that the GDS server can listen on to the path that it should bind to for each one.") (defun gds-run-debug-server () "Start (or restart, if already running) the GDS debug server process." (interactive) (if gds-debug-server (gds-kill-debug-server)) (setq gds-debug-server (gds-start-server "gds-debug" (cdr (assq gds-server-socket-type gds-socket-type-alist)) 'gds-debug-protocol)) (process-kill-without-query gds-debug-server)) (defun gds-kill-debug-server () "Kill the GDS debug server process." (interactive) (mapcar (function gds-client-gone) (mapcar (function car) gds-client-info)) (condition-case nil (progn (kill-process gds-debug-server) (accept-process-output gds-debug-server 0 200)) (error)) (setq gds-debug-server nil)) ;; Send input to the subprocess. (defun gds-send (string client) (with-current-buffer (get-buffer-create "*GDS Transcript*") (goto-char (point-max)) (insert (number-to-string client) ": (" string ")\n")) (gds-client-put client 'thread-id nil) (gds-show-client-status client gds-running-text) (process-send-string gds-debug-server (format "(%S %s)\n" client string))) ;;;; Per-client information (defun gds-client-put (client property value) (let ((client-info (assq client gds-client-info))) (if client-info (let ((prop-info (memq property client-info))) (if prop-info (setcar (cdr prop-info) value) (setcdr client-info (list* property value (cdr client-info))))) (setq gds-client-info (cons (list client property value) gds-client-info))))) (defun gds-client-get (client property) (let ((client-info (assq client gds-client-info))) (and client-info (cadr (memq property client-info))))) (defvar gds-client-info '()) (defun gds-get-client-buffer (client) (let ((existing-buffer (gds-client-get client 'stack-buffer))) (if (and existing-buffer (buffer-live-p existing-buffer)) existing-buffer (let ((new-buffer (generate-new-buffer (gds-client-get client 'name)))) (with-current-buffer new-buffer (gds-debug-mode) (setq gds-client client) (setq gds-stack nil)) (gds-client-put client 'stack-buffer new-buffer) new-buffer)))) (defun gds-client-gone (client &rest ignored) ;; Kill the client's stack buffer, if it has one. (let ((stack-buffer (gds-client-get client 'stack-buffer))) (if (and stack-buffer (buffer-live-p stack-buffer)) (kill-buffer stack-buffer))) ;; Dissociate all the client's associated buffers. (mapcar (function (lambda (buffer) (if (buffer-live-p buffer) (with-current-buffer buffer (gds-dissociate-buffer))))) (copy-sequence (gds-client-get client 'associated-buffers))) ;; Remove this client's record from gds-client-info. (setq gds-client-info (delq (assq client gds-client-info) gds-client-info))) (defvar gds-client nil) (make-variable-buffer-local 'gds-client) (defvar gds-stack nil) (make-variable-buffer-local 'gds-stack) (defvar gds-tweaking nil) (make-variable-buffer-local 'gds-tweaking) (defvar gds-selected-frame-index nil) (make-variable-buffer-local 'gds-selected-frame-index) ;;;; Debugger protocol (defun gds-debug-protocol (client form) (or (eq client '*) (let ((proc (car form))) (cond ((eq proc 'name) ;; (name ...) - client name. (gds-client-put client 'name (caddr form))) ((eq proc 'stack) ;; (stack ...) - stack information. (with-current-buffer (gds-get-client-buffer client) (setq gds-stack (cddr form)) (setq gds-tweaking (memq 'instead (cadr gds-stack))) (setq gds-selected-frame-index (cadr form)) (gds-display-stack))) ((eq proc 'closed) ;; (closed) - client has gone/died. (gds-client-gone client)) ((eq proc 'eval-result) ;; (eval-result RESULT) - result of evaluation. (if gds-last-eval-result (message "%s" (cadr form)) (setq gds-last-eval-result (cadr form)))) ((eq proc 'info-result) ;; (info-result RESULT) - info about selected frame. (message "%s" (cadr form))) ((eq proc 'thread-id) ;; (thread-id THREAD) - says which client thread is reading. (let ((thread-id (cadr form)) (debug-thread-id (gds-client-get client 'debug-thread-id))) (if (and debug-thread-id (/= thread-id debug-thread-id)) ;; Tell the newly reading thread to go away. (gds-send "dismiss" client) ;; Either there's no current debug-thread-id, or ;; the thread now reading is the debug thread. (if debug-thread-id (progn ;; Reset the debug-thread-id. (gds-client-put client 'debug-thread-id nil) ;; Indicate debug status in modelines. (gds-show-client-status client gds-debug-text)) ;; Indicate normal read status in modelines.. (gds-show-client-status client gds-ready-text))))) ((eq proc 'debug-thread-id) ;; (debug-thread-id THREAD) - debug override indication. (gds-client-put client 'debug-thread-id (cadr form)) ;; If another thread is already reading, send it away. (if (gds-client-get client 'thread-id) (gds-send "dismiss" client))) (t ;; Non-debug-specific protocol. (gds-nondebug-protocol client proc (cdr form))))))) ;;;; Displaying a stack (define-derived-mode gds-debug-mode scheme-mode "Guile-Debug" "Major mode for debugging a Guile client application." (use-local-map gds-mode-map)) (defun gds-display-stack-first-line () (let ((flags (cadr gds-stack))) (cond ((memq 'application flags) (insert "Calling procedure:\n")) ((memq 'evaluation flags) (insert "Evaluating expression" (cond ((stringp gds-tweaking) (format " (tweaked: %s)" gds-tweaking)) (gds-tweaking " (tweakable)") (t "")) ":\n")) ((memq 'return flags) (let ((value (cadr (memq 'return flags)))) (while (string-match "\n" value) (setq value (replace-match "\\n" nil t value))) (insert "Return value" (cond ((stringp gds-tweaking) (format " (tweaked: %s)" gds-tweaking)) (gds-tweaking " (tweakable)") (t "")) ": " value "\n"))) ((memq 'error flags) (let ((value (cadr (memq 'error flags)))) (while (string-match "\n" value) (setq value (replace-match "\\n" nil t value))) (insert "Error: " value "\n"))) (t (insert "Stack: " (prin1-to-string flags) "\n"))))) (defun gds-display-stack () (if gds-undisplay-timer (cancel-timer gds-undisplay-timer)) (setq gds-undisplay-timer nil) ;(setq buffer-read-only nil) (mapcar 'delete-overlay (overlays-in (point-min) (point-max))) (erase-buffer) (gds-display-stack-first-line) (let ((frames (car gds-stack))) (while frames (let ((frame-text (cadr (car frames))) (frame-source (caddr (car frames)))) (while (string-match "\n" frame-text) (setq frame-text (replace-match "\\n" nil t frame-text))) (insert " " (if frame-source "s" " ") frame-text "\n")) (setq frames (cdr frames)))) ;(setq buffer-read-only t) (gds-show-selected-frame)) (defun gds-tweak (expr) (interactive "sTweak expression or return value: ") (or gds-tweaking (error "The current stack cannot be tweaked")) (setq gds-tweaking (if (> (length expr) 0) expr t)) (save-excursion (goto-char (point-min)) (delete-region (point) (progn (forward-line 1) (point))) (gds-display-stack-first-line))) (defvar gds-undisplay-timer nil) (make-variable-buffer-local 'gds-undisplay-timer) (defvar gds-undisplay-wait 1) (defun gds-undisplay-buffer () (if gds-undisplay-timer (cancel-timer gds-undisplay-timer)) (setq gds-undisplay-timer (run-at-time gds-undisplay-wait nil (function kill-buffer) (current-buffer)))) (defun gds-show-selected-frame () (setq gds-local-var-cache nil) (goto-char (point-min)) (forward-line (+ gds-selected-frame-index 1)) (delete-char 3) (insert "=> ") (beginning-of-line) (gds-show-selected-frame-source (caddr (nth gds-selected-frame-index (car gds-stack))))) (defun gds-unshow-selected-frame () (if gds-frame-source-overlay (move-overlay gds-frame-source-overlay 0 0)) (save-excursion (goto-char (point-min)) (forward-line (+ gds-selected-frame-index 1)) (delete-char 3) (insert " "))) ;; Overlay used to highlight the source expression corresponding to ;; the selected frame. (defvar gds-frame-source-overlay nil) (defcustom gds-source-file-name-transforms nil "Alist of regexps and substitutions for transforming Scheme source file names. Each element in the alist is (REGEXP . SUBSTITUTION). Each source file name in a Guile backtrace is compared against each REGEXP in turn until the first one that matches, then `replace-match' is called with SUBSTITUTION to transform that file name. This mechanism targets the situation where you are working on a Guile application and want to install it, in /usr/local say, before each test run. In this situation, even though Guile is reading your Scheme files from /usr/local/share/guile, you probably want Emacs to pop up the corresponding files from your working codebase instead. Therefore you would add an element to this alist to transform \"^/usr/local/share/guile/whatever\" to \"~/codebase/whatever\"." :type '(alist :key-type regexp :value-type string) :group 'gds) (defun gds-show-selected-frame-source (source) ;; Highlight the frame source, if possible. (if source (let ((filename (car source)) (client gds-client) (transforms gds-source-file-name-transforms)) ;; Apply possible transforms to the source file name. (while transforms (if (string-match (caar transforms) filename) (let ((trans-fn (replace-match (cdar transforms) t nil filename))) (if (file-readable-p trans-fn) (setq filename trans-fn transforms nil)))) (setq transforms (cdr transforms))) ;; Try to map the (possibly transformed) source file to a ;; buffer. (let ((source-buffer (gds-source-file-name-to-buffer filename))) (if source-buffer (with-current-buffer source-buffer (if gds-frame-source-overlay nil (setq gds-frame-source-overlay (make-overlay 0 0)) (overlay-put gds-frame-source-overlay 'face 'highlight) (overlay-put gds-frame-source-overlay 'help-echo (function gds-show-local-var))) ;; 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-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))) ;; Record that this source buffer has been touched by a ;; GDS client process. (setq gds-last-touched-by client)) (message "Source for this frame cannot be shown: %s:%d:%d" filename (cadr source) (caddr source))))) (message "Source for this frame was not recorded")) (gds-display-buffers)) (defvar gds-local-var-cache nil) (defun gds-show-local-var (window overlay position) (let ((frame-index gds-selected-frame-index) (client gds-client)) (with-current-buffer (overlay-buffer overlay) (save-excursion (goto-char position) (let ((gds-selected-frame-index frame-index) (gds-client client) (varname (thing-at-point 'symbol)) (state (parse-partial-sexp (overlay-start overlay) (point)))) (when (and gds-selected-frame-index gds-client varname (not (or (nth 3 state) (nth 4 state)))) (set-text-properties 0 (length varname) nil varname) (let ((existing (assoc varname gds-local-var-cache))) (if existing (cdr existing) (gds-evaluate varname) (setq gds-last-eval-result nil) (while (not gds-last-eval-result) (accept-process-output gds-debug-server)) (setq gds-local-var-cache (cons (cons varname gds-last-eval-result) gds-local-var-cache)) gds-last-eval-result)))))))) (defun gds-source-file-name-to-buffer (filename) ;; See if filename begins with gds-emacs-buffer-port-name-prefix. (if (string-match (concat "^" (regexp-quote gds-emacs-buffer-port-name-prefix)) filename) ;; It does, so get the named buffer. (get-buffer (substring filename (match-end 0))) ;; It doesn't, so treat as a file name. (and (file-readable-p filename) (find-file-noselect filename)))) (defun gds-select-stack-frame (&optional frame-index) (interactive) (let ((new-frame-index (or frame-index (gds-current-line-frame-index)))) (or (and (>= new-frame-index 0) (< new-frame-index (length (car gds-stack)))) (error (if frame-index "No more frames in this direction" "No frame here"))) (gds-unshow-selected-frame) (setq gds-selected-frame-index new-frame-index) (gds-show-selected-frame))) (defun gds-up () (interactive) (gds-select-stack-frame (- gds-selected-frame-index 1))) (defun gds-down () (interactive) (gds-select-stack-frame (+ gds-selected-frame-index 1))) (defun gds-current-line-frame-index () (- (count-lines (point-min) (save-excursion (beginning-of-line) (point))) 1)) (defun gds-display-buffers () (let ((buf (current-buffer))) ;; If there's already a window showing the buffer, use it. (let ((window (get-buffer-window buf t))) (if window (progn (make-frame-visible (window-frame window)) (select-window window)) (switch-to-buffer buf) (setq window (get-buffer-window buf t)))) ;; If there is an associated source buffer, display it as well. (if (and gds-frame-source-overlay (overlay-end gds-frame-source-overlay) (> (overlay-end gds-frame-source-overlay) 1)) (progn (delete-other-windows) (let ((window (display-buffer (overlay-buffer gds-frame-source-overlay)))) (set-window-point window (overlay-start gds-frame-source-overlay))))))) ;;;; Debugger commands. ;; Typically but not necessarily used from the `stack' view. (defun gds-send-tweaking () (if (stringp gds-tweaking) (gds-send (format "tweak %S" gds-tweaking) gds-client))) (defun gds-go () (interactive) (gds-send-tweaking) (gds-send "continue" gds-client) (gds-unshow-selected-frame) (gds-undisplay-buffer)) (defvar gds-last-eval-result t) (defun gds-evaluate (expr) (interactive "sEvaluate variable or expression: ") (gds-send (format "evaluate %d %s" gds-selected-frame-index (prin1-to-string expr)) gds-client)) (defun gds-frame-info () (interactive) (gds-send (format "info-frame %d" gds-selected-frame-index) gds-client)) (defun gds-frame-args () (interactive) (gds-send (format "info-args %d" gds-selected-frame-index) gds-client)) (defun gds-proc-source () (interactive) (gds-send (format "proc-source %d" gds-selected-frame-index) gds-client)) (defun gds-traps-here () (interactive) (gds-send "traps-here" gds-client)) (defun gds-step-into () (interactive) (gds-send-tweaking) (gds-send (format "step-into %d" gds-selected-frame-index) gds-client) (gds-unshow-selected-frame) (gds-undisplay-buffer)) (defun gds-step-over () (interactive) (gds-send-tweaking) (gds-send (format "step-over %d" gds-selected-frame-index) gds-client) (gds-unshow-selected-frame) (gds-undisplay-buffer)) (defun gds-step-file () (interactive) (gds-send-tweaking) (gds-send (format "step-file %d" gds-selected-frame-index) gds-client) (gds-unshow-selected-frame) (gds-undisplay-buffer)) ;;;; Guile Interaction mode keymap and menu items. (defvar gds-mode-map (make-sparse-keymap)) (define-key gds-mode-map "c" (function gds-go)) (define-key gds-mode-map "g" (function gds-go)) (define-key gds-mode-map "q" (function gds-go)) (define-key gds-mode-map "e" (function gds-evaluate)) (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 "S" (function gds-proc-source)) (define-key gds-mode-map "T" (function gds-traps-here)) (define-key gds-mode-map "\C-m" (function gds-select-stack-frame)) (define-key gds-mode-map "u" (function gds-up)) (define-key gds-mode-map [up] (function gds-up)) (define-key gds-mode-map "\C-p" (function gds-up)) (define-key gds-mode-map "d" (function gds-down)) (define-key gds-mode-map [down] (function gds-down)) (define-key gds-mode-map "\C-n" (function gds-down)) (define-key gds-mode-map " " (function gds-step-file)) (define-key gds-mode-map "i" (function gds-step-into)) (define-key gds-mode-map "o" (function gds-step-over)) (define-key gds-mode-map "t" (function gds-tweak)) (defvar gds-menu nil "Global menu for GDS commands.") (if nil;gds-menu nil (setq gds-menu (make-sparse-keymap "Guile-Debug")) (define-key gds-menu [traps-here] '(menu-item "Show Traps Here" gds-traps-here)) (define-key gds-menu [proc-source] '(menu-item "Show Procedure Source" gds-proc-source)) (define-key gds-menu [frame-args] '(menu-item "Show Frame Args" gds-frame-args)) (define-key gds-menu [frame-info] '(menu-item "Show Frame Info" gds-frame-info)) (define-key gds-menu [separator-1] '("--")) (define-key gds-menu [evaluate] '(menu-item "Evaluate..." gds-evaluate)) (define-key gds-menu [separator-2] '("--")) (define-key gds-menu [down] '(menu-item "Move Down A Frame" gds-down)) (define-key gds-menu [up] '(menu-item "Move Up A Frame" gds-up)) (define-key gds-menu [separator-3] '("--")) (define-key gds-menu [step-over] '(menu-item "Step Over Current Expression" gds-step-over)) (define-key gds-menu [step-into] '(menu-item "Step Into Current Expression" gds-step-into)) (define-key gds-menu [step-file] '(menu-item "Step Through Current Source File" gds-step-file)) (define-key gds-menu [separator-4] '("--")) (define-key gds-menu [go] '(menu-item "Go [continue execution]" gds-go)) (define-key gds-mode-map [menu-bar gds-debug] (cons "Guile-Debug" gds-menu))) ;;;; Autostarting the GDS server. (defcustom gds-autorun-debug-server t "Whether to automatically run the GDS server when `gds.el' is loaded." :type 'boolean :group 'gds) (defcustom gds-server-socket-type 'tcp "What kind of socket the GDS server should listen on." :group 'gds :type '(choice (const :tag "TCP" tcp) (const :tag "Unix" unix))) ;;;; If requested, autostart the server after loading. (if (and gds-autorun-debug-server (not gds-debug-server)) (gds-run-debug-server)) ;; Things to do only when this file is loaded for the first time. ;; (And not, for example, when code is reevaluated by eval-buffer.) (defvar gds-scheme-first-load t) (if gds-scheme-first-load (progn ;; Read the persistent breakpoints file, if configured. (if gds-breakpoints-file-name (gds-read-breakpoints-file)) ;; Note that first time load is complete. (setq gds-scheme-first-load nil))) ;;;; The end! (provide 'gds) ;;; gds.el ends here.