--- /dev/null
+;;; 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))
+
+;;;; The end!
+
+(provide 'gds)
+
+;;; gds.el ends here.
projects / lilypond.git / blobdiff