+++ /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 3 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-unix-socket-name (format "/tmp/.gds-socket-%d" (emacs-pid))
- "Name of the Unix domain socket that GDS will listen on.")
-
-(defvar gds-tcp-port 8333
- "The TCP port number that GDS will listen on.")
-
-(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"
- gds-unix-socket-name
- gds-tcp-port
- 'gds-debug-protocol))
- (process-kill-without-query gds-debug-server)
- ;; Add the Unix socket name to the environment, so that Guile
- ;; clients started from within this Emacs will be able to use it,
- ;; and thereby ensure that they connect to the GDS in this Emacs.
- (setenv "GDS_UNIX_SOCKET_NAME" gds-unix-socket-name))
-
-(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
-
-(defcustom gds-protocol-hook nil
- "Hook called on receipt of a protocol form from the GDS client."
- :type 'hook
- :group 'gds)
-
-(defun gds-debug-protocol (client form)
- (run-hook-with-args 'gds-protocol-hook 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
- "This option is now obsolete and has no effect."
- :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.
HCoop / bpt / guile.git / blobdiff