(require 'widget)
(require 'wid-edit)
(require 'scheme)
-
-
-;;;; Debugging (of this code!).
-
-(defsubst dmessage (msg &rest args)
- ;;(apply (function message) msg args)
- )
+(require 'cl)
+(require 'comint)
+(require 'info)
;;;; Customization group setup.
:group 'scheme)
-;;;; Communication with the (ice-9 debugger ui-server) subprocess.
+;;;; Communication with the (emacs gds-server) subprocess.
;; The subprocess object.
(defvar gds-process nil)
;; the buffer position of the start of the next unread form.
(defvar gds-read-cursor nil)
+;; The guile executable used by the GDS server and captive client
+;; processes.
+(defcustom gds-guile-program "guile"
+ "*The guile executable used by GDS, specifically by its server and
+captive client processes."
+ :type 'string
+ :group 'gds)
+
(defun gds-start ()
"Start (or restart, if already running) the GDS subprocess."
(interactive)
+ (gds-kill-captive)
(if gds-process (gds-shutdown))
(with-current-buffer (get-buffer-create "*GDS Process*")
(erase-buffer)
(let ((process-connection-type nil)) ; use a pipe
(start-process "gds"
(current-buffer)
- "guile"
+ gds-guile-program
"-q"
"--debug"
- "-e"
- "run"
- "-s"
- "/home/neil/Guile/cvs/guile-core/ice-9/debugger/ui-server.scm"))))
+ "-c"
+ "(begin (use-modules (emacs gds-server)) (run-server))"))))
(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))
+ (set-process-coding-system gds-process 'latin-1-unix)
+ (process-kill-without-query gds-process))
;; Shutdown the subprocess and cleanup all associated data.
(defun gds-shutdown ()
"Shut down the GDS subprocess."
(interactive)
- ;; 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)
+ ;; Reset variables.
+ (setq gds-buffers nil)
;; Kill the subprocess.
- (process-kill-without-query gds-process)
(condition-case nil
(progn
(kill-process gds-process)
)
;; 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 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 ()
+(defun gds-send (string client)
+ (process-send-string gds-process (format "(%S %s)\n" client string))
+ (let ((buf (gds-client-ref 'gds-transcript)))
+ (if buf
+ (with-current-buffer buf
+ (goto-char (point-max))
+ (let ((inhibit-read-only t))
+ (insert (format "tx (%S %s)\n" client string)))))))
+
+
+;;;; Focussing in and out on interaction with a particular client.
+
+;;;; The slight possible problems here are that popping up a client's
+;;;; interaction windows when that client wants attention might
+;;;; interrupt something else that the Emacs user was working on at
+;;;; the time, and that if multiple clients are being debugged at the
+;;;; same time, their popping up of interaction windows might become
+;;;; confusing. For this reason, we allow GDS's behavior to be
+;;;; customized via the variables `gds-focus-in-function' and
+;;;; `gds-focus-out-function'.
+;;;;
+;;;; That said, the default policy, which is probably OK for most
+;;;; users most of the time, is very simple: when a client wants
+;;;; attention, its interaction windows are popped up immediately.
+
+(defun gds-request-focus (client)
+ (funcall gds-focus-in-function client))
+
+(defcustom gds-focus-in-function (function gds-focus-in)
+ "Function to call when a GDS client program wants user attention.
+The function is called with one argument, the CLIENT in question."
+ :type 'function
+ :group 'gds)
+
+(defun gds-focus-in (client)
+ (gds-display-buffers client))
+
+(defun gds-quit ()
(interactive)
- (if (and (null gds-waiting)
- (y-or-n-p "No other clients waiting - bury *Guile* 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)
+ (funcall gds-focus-out-function))
-;; Alist mapping client port numbers to last printed outputs.
-(defvar gds-outputs nil)
+(defcustom gds-focus-out-function (function gds-focus-out)
+ "Function to call when user quits interacting with a GDS client."
+ :type 'function
+ :group 'gds)
-;; Alist mapping client port numbers to last known stacks.
-(defvar gds-stacks nil)
+(defun gds-focus-out ()
+ (if (if (gds-client-blocked)
+ (y-or-n-p "Client is waiting for input. Quit anyway? ")
+ t)
+ (bury-buffer (current-buffer))))
-;; 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)
+;;;; Multiple client focus -- an alternative implementation.
-;;;; Handling debugging instructions.
+;;;; The following code is provided as an alternative example of how a
+;;;; customized GDS could schedule the display of multiple clients
+;;;; that are competing for user attention.
+
+;; - `gds-waiting' holds a list of clients that want attention but
+;; haven't yet got it. A client is added to this list for two
+;; reasons. (1) When it is blocked waiting for user input.
+;; (2) When it first connects to GDS, even if not blocked.
+;;
+;; - `gds-focus-client' holds the client, if any, that currently has
+;; the user's attention. A client can be given the focus if
+;; `gds-focus-client' is nil at the time that the client wants
+;; attention, or if another client relinquishes it. A client can
+;; relinquish the focus in two ways. (1) If the client application
+;; says that it is no longer blocked, and a small time passes without
+;; it becoming blocked again. (2) If the user explicitly `quits'
+;; that client.
+;;
+;; (defvar gds-focus-client nil)
+;; (defvar gds-waiting nil)
+;;
+;; (defun gds-focus-in-alternative (client)
+;; (cond ((eq client gds-focus-client)
+;; ;; CLIENT already has the focus. Display its buffer.
+;; (gds-display-buffers client))
+;; (gds-focus-client
+;; ;; Another client has the focus. Add CLIENT to `gds-waiting'.
+;; (or (memq client gds-waiting)
+;; (setq gds-waiting (append gds-waiting (list client)))))
+;; (t
+;; ;; Give focus to CLIENT and display its buffer.
+;; (setq gds-focus-client client)
+;; (gds-display-buffers client))))
+;;
+;; (defun gds-focus-out-alternative ()
+;; (if (or (car gds-waiting)
+;; (not (gds-client-blocked))
+;; (y-or-n-p
+;; "Client is blocked and no others are waiting. Still quit? "))
+;; (progn
+;; (bury-buffer (current-buffer))
+;; ;; Pass on the focus.
+;; (setq gds-focus-client (car gds-waiting)
+;; gds-waiting (cdr gds-waiting))
+;; ;; If this client is blocked, add it back into the waiting list.
+;; (if (gds-client-blocked)
+;; (gds-request-focus gds-client))
+;; ;; If there is a new focus client, request display for it.
+;; (if gds-focus-client
+;; (gds-request-focus gds-focus-client)))))
+
+
+;;;; GDS protocol dispatch.
;; 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))
- ((or (eq status 'running)
- (eq status 'ready-for-input))
- (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))
-
- ((eq proc 'eval-results)
- ;; (eval-results ...) - Results of evaluation.
- (gds-display-results client (cddr form)))
-
- ))))))
-
-(defun gds-display-results (client results)
- (let ((buf (get-buffer-create "*Guile Results*")))
- (save-excursion
- (set-buffer buf)
- (erase-buffer)
- (while results
- (insert (car results))
- (mapcar (function (lambda (value)
- (insert " => " value "\n")))
- (cadr results))
- (insert "\n")
- (setq results (cddr results))))
- (pop-to-buffer buf)))
-
-;; 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)
+ (or (eq client '*)
+ (let* ((proc (cadr form))
+ (args (cddr form))
+ (buf (gds-client-buffer client proc args)))
+ (if buf (gds-handle-client-input buf client proc args))))))
+
+(defun gds-handle-client-input (buf client proc args)
+ (with-current-buffer buf
+ (with-current-buffer gds-transcript
+ (goto-char (point-max))
+ (let ((inhibit-read-only t))
+ (insert (format "rx %S" (cons client (cons proc args))) "\n")))
+
+ (cond (;; (name ...) - Client name.
+ (eq proc 'name)
+ (setq gds-pid (cadr args))
+ (gds-promote-view 'interaction)
+ (gds-request-focus client))
+
+ (;; (current-module ...) - Current module.
+ (eq proc 'current-module)
+ (setq gds-current-module (car args)))
+
+ (;; (stack ...) - Stack at an error or breakpoint.
+ (eq proc 'stack)
+ (setq gds-stack args)
+ (gds-promote-view 'stack))
+
+ (;; (modules ...) - Application's loaded modules.
+ (eq proc 'modules)
+ (while args
+ (or (assoc (car args) gds-modules)
+ (setq gds-modules (cons (list (car args)) gds-modules)))
+ (setq args (cdr args))))
+
+ (;; (output ...) - Last printed output.
+ (eq proc 'output)
+ (setq gds-output (car args))
+ (gds-add-view 'messages))
+
+ (;; (status ...) - Application status indication.
+ (eq proc 'status)
+ (setq gds-status (car args))
+ (if (eq gds-status 'running)
+ (gds-delete-view 'browser)
+ (gds-add-view 'browser))
+ (if (eq gds-status 'waiting-for-input)
+ (progn
+ (gds-promote-view 'stack)
+ (gds-update-buffers)
+ (gds-request-focus client))
+ (setq gds-stack nil)
+ (gds-delete-view 'stack)
+ (gds-update-buffers-in-a-while)))
+
+ (;; (module MODULE ...) - The specified module's bindings.
+ (eq proc 'module)
+ (let ((minfo (assoc (car args) gds-modules)))
+ (if minfo
+ (setcdr (cdr minfo) (cdr args)))))
+
+ (;; (closed) - Client has gone away.
+ (eq proc 'closed)
+ (setq gds-status 'closed)
+ (gds-update-buffers)
+ (setq gds-buffers
+ (delq (assq client gds-buffers) gds-buffers)))
+
+ (;; (eval-results ...) - Results of evaluation.
+ (eq proc 'eval-results)
+ (gds-display-results client (car args) (cdr args)))
+
+ (;; (completion-result ...) - Available completions.
+ (eq proc 'completion-result)
+ (setq gds-completion-results (or (car args) t)))
+
+ (;; (breakpoint-set FILE LINE COLUMN INFO) - Breakpoint set.
+ (eq proc 'breakpoint-set)
+ (let ((file (nth 0 args))
+ (line (nth 1 args))
+ (column (nth 2 args))
+ (info (nth 3 args)))
+ (with-current-buffer (find-file-noselect file)
+ (save-excursion
+ (goto-char (point-min))
+ (or (zerop line)
+ (forward-line line))
+ (move-to-column column)
+ (let ((os (overlays-at (point))) o)
+ (while os
+ (if (and (overlay-get (car os) 'gds-breakpoint-info)
+ (= (overlay-start (car os)) (point)))
+ (progn
+ (overlay-put (car os)
+ 'gds-breakpoint-info
+ info)
+ (overlay-put (car os)
+ 'before-string
+ gds-active-breakpoint-before-string)
+ (overlay-put (car os)
+ 'after-string
+ gds-active-breakpoint-after-string)
+ (setq os nil))
+ (setq os (cdr os)))))))))
+
+ (;; (thread-status THREAD-TYPE THREAD-NUMBER STATUS [CORRELATOR])
+ (eq proc 'thread-status)
+ (if (eq (car args) 'eval)
+ (let ((number (nth 1 args))
+ (status (nth 2 args))
+ (correlator (nth 3 args)))
+ (if (eq status 'busy)
+ (progn
+ (setq gds-evals-in-progress
+ (append gds-evals-in-progress
+ (list (cons number correlator))))
+ (run-at-time 0.5 nil
+ (function gds-display-slow-eval)
+ buf number correlator)
+ (gds-promote-view 'interaction))
+ (let ((existing (assq number gds-evals-in-progress)))
+ (if existing
+ (setq gds-evals-in-progress
+ (delq existing gds-evals-in-progress)))))
+ (gds-update-buffers))))
+
+ )))
+
+(defun gds-display-slow-eval (buf number correlator)
+ (with-current-buffer buf
+ (let ((entry (assq number gds-evals-in-progress)))
+ (if (and entry
+ (eq (cdr entry) correlator))
+ (progn
+ (gds-promote-view 'interaction)
+ (gds-request-focus gds-client))))))
+
+
+;;;; Per-client buffer state.
+
+;; This section contains code that is specific to each Guile client's
+;; buffer but independent of any particular `view'.
+
+;; Alist mapping each client port number to corresponding buffer.
+(defvar gds-buffers nil)
(define-derived-mode gds-mode
- fundamental-mode
- "Guile"
- "Major mode for Guile 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*"))
- (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: REPL*' to `*Guile: REPL*<2>'.
- (rename-buffer "*Guile Fake Buffer Name*" t)
- (rename-buffer (if client
- (concat "*Guile: "
- (cdr (assq client gds-names))
- "*")
- "*Guile*")
- 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* 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 (cannot accept input)")
- (waiting-for-input . "waiting for input")
- (ready-for-input . "running"))))
- "\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)))
+ scheme-mode
+ "Guile Interaction"
+ "Major mode for interacting with a Guile client application."
+ (widget-minor-mode 1))
+
+(defvar gds-client nil
+ "GDS client's port number.")
+(make-variable-buffer-local 'gds-client)
+
+(defvar gds-status nil
+ "GDS client's latest status, 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.")
+(make-variable-buffer-local 'gds-status)
+
+(defvar gds-transcript nil
+ "Transcript buffer for this GDS client.")
+(make-variable-buffer-local 'gds-transcript)
+
+;; Return client buffer for specified client and protocol input.
+(defun gds-client-buffer (client proc args)
+ (if (eq proc 'name)
+ ;; Introduction from client - create a new buffer.
+ (with-current-buffer (generate-new-buffer (car args))
+ (gds-mode)
+ (setq gds-client client)
+ (setq gds-transcript
+ (find-file-noselect
+ (expand-file-name (concat "~/.gds-transcript-" (car args)))))
+ (with-current-buffer gds-transcript
+ (goto-char (point-max))
+ (insert "\nTranscript:\n"))
+ (setq gds-buffers
+ (cons (cons client (current-buffer))
+ gds-buffers))
+ (current-buffer))
+ ;; Otherwise there should be an existing buffer that we can
+ ;; return.
+ (let ((existing (assq client gds-buffers)))
+ (if (buffer-live-p (cdr existing))
+ (cdr existing)
+ (setq gds-buffers (delq existing gds-buffers))
+ (gds-client-buffer client 'name '("(GDS buffer killed)"))))))
+
+;; Get the current buffer's associated client's value of SYM.
+(defun gds-client-ref (sym &optional client)
+ (and (or client gds-client)
+ (let ((buf (assq (or client gds-client) gds-buffers)))
+ (and buf
+ (cdr buf)
+ (buffer-live-p (cdr buf))
+ (with-current-buffer (cdr buf)
+ (symbol-value sym))))))
+
+(defun gds-client-blocked ()
+ (eq (gds-client-ref 'gds-status) 'waiting-for-input))
+
+(defvar gds-delayed-update-timer nil)
+
+(defvar gds-delayed-update-buffers nil)
+
+(defun gds-update-delayed-update-buffers ()
+ (while gds-delayed-update-buffers
+ (with-current-buffer (car gds-delayed-update-buffers)
+ (setq gds-delayed-update-buffers
+ (cdr gds-delayed-update-buffers))
+ (gds-update-buffers))))
+
+(defun gds-update-buffers ()
+ (if (timerp gds-delayed-update-timer)
+ (cancel-timer gds-delayed-update-timer))
+ (setq gds-delayed-update-timer nil)
+ (let ((view (car gds-views))
+ (inhibit-read-only t))
+ (cond ((eq view 'stack)
+ (gds-insert-stack))
+ ((eq view 'interaction)
+ (gds-insert-interaction))
+ ((eq view 'browser)
+ (gds-insert-modules))
+ ((eq view 'messages)
+ (gds-insert-messages))
+ (t
+ (error "Bad GDS view %S" view)))
;; 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* 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* 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.
+ (force-mode-line-update t)))
+
+(defun gds-update-buffers-in-a-while ()
+ (or (memq (current-buffer) gds-delayed-update-buffers)
+ (setq gds-delayed-update-buffers
+ (cons (current-buffer) gds-delayed-update-buffers)))
+ (if (timerp gds-delayed-update-timer)
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))
+ (setq gds-delayed-update-timer
+ (run-at-time 0.5 nil (function gds-update-delayed-update-buffers)))))
+
+(defun gds-display-buffers (client)
+ (let ((buf (cdr (assq client gds-buffers))))
+ ;; 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-frame (window-frame window))
+ (select-window window))
+ ;;(select-window (display-buffer buf))
+ (display-buffer buf)))
+ ;; If there is an associated source buffer, display it as well.
+ (if (and (eq (car gds-views) 'stack)
+ gds-frame-source-overlay
+ (> (overlay-end gds-frame-source-overlay) 1))
+ (let ((window (display-buffer
+ (overlay-buffer gds-frame-source-overlay))))
+ (set-window-point window
+ (overlay-start gds-frame-source-overlay))))))
+
+
+;;;; Management of `views'.
+
+;; The idea here is to keep the buffer describing a Guile client
+;; relatively uncluttered by only showing one kind of information
+;; about that client at a time. Menu items and key sequences are
+;; provided to switch easily between the available views.
+
+(defvar gds-views nil
+ "List of available views for a GDS client. Each element is one of
+the following symbols.
+`interaction' - Interaction with running client.
+`stack' - Call stack view.
+`browser' - Modules and bindings browser view.
+`breakpoints' - List of set breakpoints.
+`messages' - Non-GDS-protocol output from the debugger.")
+(make-variable-buffer-local 'gds-views)
+
+(defun gds-promote-view (view)
+ (setq gds-views (cons view (delq view gds-views))))
+
+(defun gds-switch-to-view (view)
+ (or (memq view gds-views)
+ (error "View %S is not available" view))
+ (gds-promote-view view)
+ (gds-update-buffers))
+
+(defun gds-add-view (view)
+ (or (memq view gds-views)
+ (setq gds-views (append gds-views (list view)))))
+
+(defun gds-delete-view (view)
+ (setq gds-views (delq view gds-views)))
+
+
+;;;; `Interaction' view.
+
+;; This view provides interaction with a normally running Guile
+;; client, in other words one that is not stopped in the debugger but
+;; is still available to take input from GDS (usually via a thread for
+;; that purpose). The view supports evaluation, help requests,
+;; control of `debug-on-exception' function, and methods for breaking
+;; into the running code.
+
+(defvar gds-current-module "()"
+ "GDS client's current module.")
+(make-variable-buffer-local 'gds-current-module)
+
+(defvar gds-pid nil
+ "GDS client's process ID.")
+(make-variable-buffer-local 'gds-pid)
+
+(defvar gds-debug-exceptions nil
+ "Whether to debug exceptions.")
+(make-variable-buffer-local 'gds-debug-exceptions)
+
+(defvar gds-exception-keys "signal misc-error"
+ "The exception keys for which to debug a GDS client.")
+(make-variable-buffer-local 'gds-exception-keys)
+
+(defvar gds-evals-in-progress nil
+ "Alist describing evaluations in progress.")
+(make-variable-buffer-local 'gds-evals-in-progress)
+
+(defvar gds-results nil
+ "Last help or evaluation results.")
+(make-variable-buffer-local 'gds-results)
+
+(defcustom gds-heading-face 'info-menu-header
+ "*Face used for headings in Guile Interaction buffers."
+ :type 'face
+ :group 'gds)
+
+(defun gds-insert-interaction ()
+ (erase-buffer)
+ ;; Insert stuff for interacting with a running (non-blocked) Guile
+ ;; client.
+ (gds-heading-insert (buffer-name))
+ (widget-insert " "
+ (cdr (assq gds-status
+ '((running . "running (cannot accept input)")
+ (waiting-for-input . "waiting for input")
+ (ready-for-input . "running")
+ (closed . "closed"))))
+ ", in "
+ gds-current-module
+ "\n\n")
+ (widget-create 'push-button
+ :notify (function gds-sigint)
+ "SIGINT")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (function gds-async-break)
+ "Break")
+ (widget-insert "\n")
+ (widget-create 'checkbox
+ :notify (function gds-toggle-debug-exceptions)
+ gds-debug-exceptions)
+ (widget-insert " Debug exception keys: ")
+ (widget-create 'editable-field
+ :notify (function gds-set-exception-keys)
+ gds-exception-keys)
+ ;; Evaluation report area.
+ (widget-insert "\n")
+ (gds-heading-insert "Recent Evaluations")
+ (widget-insert " To run an evaluation, see the Guile->Evaluate menu.\n")
+ (if gds-results
+ (widget-insert "\n" (cdr gds-results)))
+ (let ((evals gds-evals-in-progress))
+ (while evals
+ (widget-insert "\n" (cddar evals) " - running ")
+ (let ((w (widget-create 'push-button
+ :notify (function gds-interrupt-eval)
+ "Interrupt")))
+ (widget-put w :thread-number (caar evals)))
+ (widget-insert "\n")
+ (setq evals (cdr evals)))))
+
+(defun gds-heading-insert (text)
+ (let ((start (point)))
+ (widget-insert text)
+ (let ((o (make-overlay start (point))))
+ (overlay-put o 'face gds-heading-face)
+ (overlay-put o 'evaporate t))))
+
+(defun gds-sigint (w &rest ignore)
+ (interactive)
+ (signal-process gds-pid 2))
+
+(defun gds-async-break (w &rest ignore)
+ (interactive)
+ (gds-send "async-break" gds-client))
+
+(defun gds-interrupt-eval (w &rest ignore)
+ (interactive)
+ (gds-send (format "interrupt-eval %S" (widget-get w :thread-number))
+ gds-client))
+
+(defun gds-toggle-debug-exceptions (w &rest ignore)
+ (interactive)
+ (setq gds-debug-exceptions (widget-value w))
+ (gds-eval-expression (concat "(use-modules (ice-9 debugger))"
+ "(debug-on-error '("
+ gds-exception-keys
+ "))")))
+
+(defun gds-set-exception-keys (w &rest ignore)
+ (interactive)
+ (setq gds-exception-keys (widget-value w)))
+
+(defun gds-view-interaction ()
+ (interactive)
+ (gds-switch-to-view 'interaction))
+
+
+;;;; `Stack' view.
+
+;; This view shows the Guile call stack after the application has hit
+;; an error, or when it is stopped in the debugger.
+
+(defvar gds-stack nil
+ "GDS client's stack when last stopped.")
+(make-variable-buffer-local 'gds-stack)
+
+(defun gds-insert-stack ()
+ (erase-buffer)
+ (let ((frames (car gds-stack))
+ (index (cadr gds-stack))
+ (flags (caddr gds-stack))
frame items)
- (widget-insert "Stack: " (prin1-to-string flags) "\n")
+ (cond ((memq 'application flags)
+ (widget-insert "Calling procedure:\n"))
+ ((memq 'evaluation flags)
+ (widget-insert "Evaluating expression:\n"))
+ ((memq 'return flags)
+ (widget-insert "Return value: "
+ (cadr (memq 'return flags))
+ "\n"))
+ (t
+ (widget-insert "Stack: " (prin1-to-string flags) "\n")))
(let ((i -1))
(gds-show-selected-frame (caddr (nth index frames)))
(while frames
:value (cadr (nth index items))
:notify (function gds-select-stack-frame)
items)
- (widget-insert "\n")))
+ (widget-insert "\n")
+ (goto-char (point-min))))
(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)))))
+ (gds-send (format "debugger-command frame %d" (cadr ind))
+ gds-client)))
;; 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)
+(defvar gds-frame-source-overlay 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
+ (if gds-frame-source-overlay
nil
- (setq gds-selected-frame-source-overlay (make-overlay 0 0))
- (overlay-put gds-selected-frame-source-overlay 'face 'highlight))
+ (setq gds-frame-source-overlay (make-overlay 0 0))
+ (overlay-put gds-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
+ (move-overlay gds-frame-source-overlay
(point)
(if (not (looking-at ")"))
(save-excursion (forward-sexp 1) (point))
;; 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))))
+ (current-buffer))))
+ (if gds-frame-source-overlay
+ (move-overlay gds-frame-source-overlay 0 0))))
+
+(defun gds-view-stack ()
+ (interactive)
+ (gds-switch-to-view 'stack))
+
+
+;;;; `Breakpoints' view.
+
+;; This view shows a list of breakpoints.
+
+(defun gds-view-breakpoints ()
+ (interactive)
+ (gds-switch-to-view 'breakpoints))
+
+
+;;;; `Browser' view.
+
+;; This view shows a list of modules and module bindings.
(defcustom gds-module-filter '(t (guile nil) (ice-9 nil) (oop nil))
"Specification of which Guile modules the debugger should display.
(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))))
+(defvar gds-modules nil
+ "GDS client's module information.
+Alist mapping module names to their symbols and related information.
+This looks like:
+
+ (((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.")
+(make-variable-buffer-local 'gds-modules)
+
+(defun gds-insert-modules ()
+ (let ((p (if (eq (window-buffer (selected-window)) (current-buffer))
+ (point)
+ (point-min)))
+ (modules gds-modules))
+ (erase-buffer)
+ (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 gds-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)))
+ (insert "\n")
+ (goto-char p)))
(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)))
+ (minfo (assoc name gds-modules)))
(if (cdr minfo)
;; Just toggle expansion state.
(progn
(setcar (cdr minfo) (not (cadr minfo)))
- (gds-display-state client))
+ (gds-update-buffers))
;; Set flag to indicate module expanded.
(setcdr minfo (list t))
;; Get symlist from Guile.
- (gds-send (format "(%S query-module %S)\n" client name)))))
+ (gds-send (format "query-module %S" name) client))))
+(defun gds-query-modules ()
+ (interactive)
+ (gds-send "query-modules" gds-client))
-;;;; Guile Debugging keymap.
+(defun gds-view-browser ()
+ (interactive)
+ (or gds-modules (gds-query-modules))
+ (gds-switch-to-view 'browser))
-(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))
+;;;; `Messages' view.
-(defun gds-go ()
- (interactive)
- (gds-send (format "(%S debugger-command continue)\n" gds-displayed-client)))
+;; This view shows recent non-GDS-protocol messages output from the
+;; (ice-9 debugger) code.
-(defun gds-quit ()
+(defvar gds-output nil
+ "GDS client's recent output (printed).")
+(make-variable-buffer-local 'gds-output)
+
+(defun gds-insert-messages ()
+ (erase-buffer)
+ ;; Insert recent non-protocol output from (ice-9 debugger).
+ (insert gds-output)
+ (goto-char (point-min)))
+
+(defun gds-view-messages ()
(interactive)
- (if (gds-client-waiting)
- (if (y-or-n-p "Client is waiting for instruction - tell it to continue? ")
- (gds-go)))
- (gds-yield))
+ (gds-switch-to-view 'messages))
-(defun gds-yield ()
+
+;;;; Debugger commands.
+
+;; Typically but not necessarily used from the `stack' view.
+
+(defun gds-go ()
(interactive)
- (if (gds-client-waiting)
- (gds-focus-yield)
- (gds-focus-done)))
+ (gds-send "debugger-command continue" gds-client))
(defun gds-next ()
(interactive)
- (gds-send (format "(%S debugger-command next 1)\n" gds-displayed-client)))
+ (gds-send "debugger-command next 1" gds-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))))
+ (gds-send (format "debugger-command evaluate %s" (prin1-to-string expr))
+ gds-client))
(defun gds-step-in ()
(interactive)
- (gds-send (format "(%S debugger-command step 1)\n" gds-displayed-client)))
+ (gds-send "debugger-command step 1" gds-client))
(defun gds-step-out ()
(interactive)
- (gds-send (format "(%S debugger-command finish)\n" gds-displayed-client)))
+ (gds-send "debugger-command finish" gds-client))
(defun gds-trace-finish ()
(interactive)
- (gds-send (format "(%S debugger-command trace-finish)\n"
- gds-displayed-client)))
+ (gds-send "debugger-command trace-finish" gds-client))
+
+(defun gds-frame-info ()
+ (interactive)
+ (gds-send "debugger-command info-frame" gds-client))
+
+(defun gds-frame-args ()
+ (interactive)
+ (gds-send "debugger-command info-args" gds-client))
+
+(defun gds-debug-trap-hooks ()
+ (interactive)
+ (gds-send "debugger-command debug-trap-hooks" gds-client))
+
+(defun gds-up ()
+ (interactive)
+ (gds-send "debugger-command up 1" gds-client))
+
+(defun gds-down ()
+ (interactive)
+ (gds-send "debugger-command down 1" gds-client))
+
+
+;;;; Setting breakpoints.
(defun gds-set-breakpoint ()
(interactive)
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")))))
+ (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")))))
+ (save-excursion
+ (and (re-search-backward "^\\(Stack\\|Modules\\):" nil t)
+ (looking-at "Modules"))))
(defun gds-set-module-breakpoint ()
(let ((sym (save-excursion
nil
nil
"debug-here")))
- (gds-send (format "(%S set-breakpoint %s %s %s)\n"
- gds-displayed-client
+ (gds-send (format "set-breakpoint %s %s %s"
module
sym
- behaviour)))))
+ behaviour)
+ gds-client))))
+
+
+;;;; Scheme source breakpoints.
+
+(defcustom gds-breakpoint-face 'default
+ "*Face used to highlight the location of a source breakpoint.
+Specifically, this face highlights the opening parenthesis of the
+form where the breakpoint is set."
+ :type 'face
+ :group 'gds)
+
+(defcustom gds-new-breakpoint-before-string ""
+ "*String used to show the presence of a new source breakpoint.
+`New' means that the breakpoint has been set but isn't yet known to
+Guile because the containing code hasn't been reevaluated yet.
+This string appears before the opening parenthesis of the form where
+the breakpoint is set. If you prefer a marker to appear after the
+opening parenthesis, make this string empty and use
+`gds-new-breakpoint-after-string'."
+ :type 'string
+ :group 'gds)
+
+(defcustom gds-new-breakpoint-after-string "=?= "
+ "*String used to show the presence of a new source breakpoint.
+`New' means that the breakpoint has been set but isn't yet known to
+Guile because the containing code hasn't been reevaluated yet.
+This string appears after the opening parenthesis of the form where
+the breakpoint is set. If you prefer a marker to appear before the
+opening parenthesis, make this string empty and use
+`gds-new-breakpoint-before-string'."
+ :type 'string
+ :group 'gds)
+
+(defcustom gds-active-breakpoint-before-string ""
+ "*String used to show the presence of a source breakpoint.
+`Active' means that the breakpoint is known to Guile.
+This string appears before the opening parenthesis of the form where
+the breakpoint is set. If you prefer a marker to appear after the
+opening parenthesis, make this string empty and use
+`gds-active-breakpoint-after-string'."
+ :type 'string
+ :group 'gds)
+
+(defcustom gds-active-breakpoint-after-string "=|= "
+ "*String used to show the presence of a source breakpoint.
+`Active' means that the breakpoint is known to Guile.
+This string appears after the opening parenthesis of the form where
+the breakpoint is set. If you prefer a marker to appear before the
+opening parenthesis, make this string empty and use
+`gds-active-breakpoint-before-string'."
+ :type 'string
+ :group 'gds)
+
+(defun gds-source-breakpoint-pos ()
+ "Return the position of the starting parenthesis of the innermost
+Scheme pair around point."
+ (if (eq (char-syntax (char-after)) ?\()
+ (point)
+ (save-excursion
+ (condition-case nil
+ (while t (forward-sexp -1))
+ (error))
+ (forward-char -1)
+ (while (not (eq (char-syntax (char-after)) ?\())
+ (forward-char -1))
+ (point))))
+
+(defun gds-source-breakpoint-overlay-at (pos)
+ "Return the source breakpoint overlay at POS, if any."
+ (let* (o (os (overlays-at pos)))
+ (while os
+ (if (and (overlay-get (car os) 'gds-breakpoint-info)
+ (= (overlay-start (car os)) pos))
+ (setq o (car os)
+ os nil))
+ (setq os (cdr os)))
+ o))
+
+(defun gds-set-source-breakpoint ()
+ (interactive)
+ (let* ((pos (gds-source-breakpoint-pos))
+ (o (gds-source-breakpoint-overlay-at pos)))
+ (if o
+ (error "There is already a breakpoint here!")
+ (setq o (make-overlay pos (+ pos 1)))
+ (overlay-put o 'evaporate t)
+ (overlay-put o 'face gds-breakpoint-face)
+ (overlay-put o 'gds-breakpoint-info 0)
+ (overlay-put o 'before-string gds-new-breakpoint-before-string)
+ (overlay-put o 'after-string gds-new-breakpoint-after-string))))
+
+(defun gds-delete-source-breakpoint ()
+ (interactive)
+ (let* ((pos (gds-source-breakpoint-pos))
+ (o (gds-source-breakpoint-overlay-at pos)))
+ (or o
+ (error "There is no breakpoint here to delete!"))
+ (delete-overlay o)))
+
+(defun gds-region-breakpoint-info (beg end)
+ "Return an alist of breakpoints in REGION.
+The car of each alist element is a cons (LINE . COLUMN) giving the
+source location of the breakpoint. The cdr is information describing
+breakpoint properties. Currently `information' is just the breakpoint
+index, for an existing Guile breakpoint, or 0 for a breakpoint that
+isn't yet known to Guile."
+ (interactive "r")
+ (let ((os (overlays-in beg end))
+ info o)
+ (while os
+ (setq o (car os)
+ os (cdr os))
+ (if (overlay-get o 'gds-breakpoint-info)
+ (progn
+ (setq info
+ (cons (cons (save-excursion
+ (goto-char (overlay-start o))
+ (cons (save-excursion
+ (beginning-of-line)
+ (count-lines (point-min) (point)))
+ (current-column)))
+ (overlay-get o 'gds-breakpoint-info))
+ info))
+ ;; Also now mark the breakpoint as `new'. It will become
+ ;; `active' (again) when we receive a notification from
+ ;; Guile that the breakpoint has been set.
+ (overlay-put o 'gds-breakpoint-info 0)
+ (overlay-put o 'before-string gds-new-breakpoint-before-string)
+ (overlay-put o 'after-string gds-new-breakpoint-after-string))))
+ (nreverse info)))
;;;; Evaluating code.
;; connection, receive the result and any output generated through the
;; same connection, and display the result and output to the user.
;;
-;; Where there are multiple Guile applications known to GDS, GDS by
-;; default sends code to the one that holds the debugging focus,
-;; i.e. `gds-displayed-client'. Where no application has the focus,
-;; or the command is invoked `C-u', GDS asks the user which
-;; application is intended.
+;; For each buffer where evaluations can be requested, GDS uses the
+;; buffer-local variable `gds-client' to track which GDS client
+;; program should receive and handle that buffer's evaluations. In
+;; the common case where GDS is only managing one client program, a
+;; buffer's value of `gds-client' is set automatically to point to
+;; that program the first time that an evaluation (or help or
+;; completion) is requested. If there are multiple GDS clients
+;; running at that time, GDS asks the user which one is intended.
(defun gds-read-client ()
- (let* ((def (if gds-displayed-client
- (cdr (assq gds-displayed-client gds-names))))
+ (let* ((def (and gds-client (cdr (assq gds-client gds-names))))
(prompt (if def
(concat "Application for eval (default "
def
"Application for eval: "))
(name
(completing-read prompt
- (mapcar (function cdr) gds-names)
+ (mapcar (function list)
+ (mapcar (function cdr) gds-names))
nil t nil nil
def)))
(let (client (names gds-names))
(while (and names (not client))
- (if (string-equal (cadar names) name)
+ (if (string-equal (cdar names) name)
(setq client (caar names)))
- (setq names (cdr names))))))
+ (setq names (cdr names)))
+ client)))
(defun gds-choose-client (client)
+ ;; Only keep the supplied client number if it is still valid.
+ (if (integerp client)
+ (setq client (gds-client-ref 'gds-client client)))
+ ;; Only keep the current buffer's setting of `gds-client' if it is
+ ;; still valid.
+ (if gds-client
+ (setq gds-client (gds-client-ref 'gds-client)))
+
(or ;; If client is an integer, it is the port number of the
;; intended client.
- (if (integerp client) client)
+ (if (integerp client)
+ client)
;; Any other non-nil value indicates invocation with a prefix
;; arg, which forces asking the user which application is
;; intended.
- (if client (gds-read-client))
- ;; If ask not forced, and there is a client with the focus,
- ;; default to that one.
- gds-displayed-client
+ (if client
+ (setq gds-client (gds-read-client)))
+ ;; If ask not forced, and current buffer is associated with a
+ ;; client, use that client.
+ gds-client
+ ;; If there are no clients at this point, and we are
+ ;; allowed to autostart a captive Guile, do so.
+ (and (null gds-buffers)
+ gds-autostart-captive
+ (progn
+ (gds-start-captive t)
+ (while (null gds-buffers)
+ (accept-process-output (get-buffer-process gds-captive)
+ 0 100000))
+ (setq gds-client (caar gds-buffers))))
+ ;; If there is only one known client, use that one.
+ (if (and (car gds-buffers)
+ (null (cdr gds-buffers)))
+ (setq gds-client (caar gds-buffers)))
;; Last resort - ask the user.
- (gds-read-client)
+ (setq gds-client (gds-read-client))
;; Signal an error.
(error "No application chosen.")))
-(defcustom gds-default-module-name '(guile-user)
- "Name of the default module for GDS code evaluation, as list of symbols.
-This module is used when there is no `define-module' form in the
-buffer preceding the code to be evaluated."
- :type 'sexp
- :group 'gds)
-
(defun gds-module-name (start end)
"Determine and return the name of the module that governs the
specified region. The module name is returned as a list of symbols."
(setq column (current-column)) ; 0-based
(beginning-of-line)
(setq line (count-lines (point-min) (point)))) ; 0-based
- (gds-send (format "(%S eval %s %S %d %d %S)\n"
- client
- (if module (prin1-to-string module) "#f")
- port-name line column
- (buffer-substring-no-properties start end)))))
-
-(defun gds-eval-expression (expr &optional client)
+ (let ((code (buffer-substring-no-properties start end)))
+ (gds-send (format "eval (region . %S) %s %S %d %d %s %S"
+ (gds-abbreviated code)
+ (if module (prin1-to-string module) "#f")
+ port-name line column
+ (let ((bpinfo (gds-region-breakpoint-info start end)))
+ ;; Make sure that "no bpinfo" is represented
+ ;; as "()", not "nil", as Scheme doesn't
+ ;; understand "nil".
+ (if bpinfo (format "%S" bpinfo) "()"))
+ code)
+ client))))
+
+(defun gds-eval-expression (expr &optional client correlator)
"Evaluate the supplied EXPR (a string)."
(interactive "sEvaluate expression: \nP")
(setq client (gds-choose-client client))
- (gds-send (format "(%S eval #f \"Emacs expression\" 0 0 %S)\n"
- client expr)))
+ (set-text-properties 0 (length expr) nil expr)
+ (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 () %S"
+ (or correlator 'expression)
+ (gds-abbreviated expr)
+ expr)
+ client))
+
+(defconst gds-abbreviated-length 35)
+
+(defun gds-abbreviated (code)
+ (let ((nlpos (string-match (regexp-quote "\n") code)))
+ (while nlpos
+ (setq code
+ (if (= nlpos (- (length code) 1))
+ (substring code 0 nlpos)
+ (concat (substring code 0 nlpos)
+ "\\n"
+ (substring code (+ nlpos 1)))))
+ (setq nlpos (string-match (regexp-quote "\n") code))))
+ (if (> (length code) gds-abbreviated-length)
+ (concat (substring code 0 (- gds-abbreviated-length 3)) "...")
+ code))
(defun gds-eval-defun (&optional client)
"Evaluate the defun (top-level form) at point."
(interactive "P")
(gds-eval-region (save-excursion (backward-sexp) (point)) (point) client))
+
+;;;; Help.
+
+;; Help is implemented as a special case of evaluation, identified by
+;; the evaluation correlator 'help.
+
+(defun gds-help-symbol (sym &optional client)
+ "Get help for SYM (a Scheme symbol)."
+ (interactive
+ (let ((sym (thing-at-point 'symbol))
+ (enable-recursive-minibuffers t)
+ val)
+ (setq val (read-from-minibuffer
+ (if sym
+ (format "Describe Guile symbol (default %s): " sym)
+ "Describe Guile symbol: ")))
+ (list (if (zerop (length val)) sym val)
+ current-prefix-arg)))
+ (gds-eval-expression (format "(help %s)" sym) client 'help))
+
+(defun gds-apropos (regex &optional client)
+ "List Guile symbols matching REGEX."
+ (interactive
+ (let ((sym (thing-at-point 'symbol))
+ (enable-recursive-minibuffers t)
+ val)
+ (setq val (read-from-minibuffer
+ (if sym
+ (format "Guile apropos (regexp, default \"%s\"): " sym)
+ "Guile apropos (regexp): ")))
+ (list (if (zerop (length val)) sym val)
+ current-prefix-arg)))
+ (set-text-properties 0 (length regex) nil regex)
+ (gds-eval-expression (format "(apropos %S)" regex) client 'help))
+
+(defvar gds-completion-results nil)
+
+(defun gds-complete-symbol (&optional client)
+ "Complete the Guile symbol before point. Returns `t' if anything
+interesting happened, `nil' if not."
+ (interactive "P")
+ (let* ((chars (- (point) (save-excursion
+ (while (let ((syntax (char-syntax (char-before (point)))))
+ (or (eq syntax ?w) (eq syntax ?_)))
+ (forward-char -1))
+ (point)))))
+ (if (zerop chars)
+ nil
+ (setq client (gds-choose-client client))
+ (setq gds-completion-results nil)
+ (gds-send (format "complete %s"
+ (prin1-to-string
+ (buffer-substring-no-properties (- (point) chars)
+ (point))))
+ client)
+ (while (null gds-completion-results)
+ (accept-process-output gds-process 0 200))
+ (cond ((eq gds-completion-results t)
+ nil)
+ ((stringp gds-completion-results)
+ (if (<= (length gds-completion-results) chars)
+ nil
+ (insert (substring gds-completion-results chars))
+ (message "Sole completion")
+ t))
+ ((= (length gds-completion-results) 1)
+ (if (<= (length (car gds-completion-results)) chars)
+ nil
+ (insert (substring (car gds-completion-results) chars))
+ t))
+ (t
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list gds-completion-results))
+ t)))))
+
+
+;;;; Display of evaluation and help results.
+
+(defun gds-display-results (client correlator results)
+ (let ((helpp (eq (car correlator) 'help)))
+ (let ((buf (get-buffer-create (if helpp
+ "*Guile Help*"
+ "*Guile Results*"))))
+ (setq gds-results
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (scheme-mode)
+ (insert (cdr correlator) "\n\n")
+ (while results
+ (insert (car results))
+ (or (bolp) (insert "\\\n"))
+ (if helpp
+ nil
+ (if (cadr results)
+ (mapcar (function (lambda (value)
+ (insert " => " value "\n")))
+ (cadr results))
+ (insert " => no (or unspecified) value\n"))
+ (insert "\n"))
+ (setq results (cddr results)))
+ (goto-char (point-min))
+ (if (and helpp (looking-at "Evaluating in "))
+ (delete-region (point) (progn (forward-line 1) (point))))
+ (cons correlator (buffer-string))))
+ ;;(pop-to-buffer buf)
+ ;;(run-hooks 'temp-buffer-show-hook)
+ ;;(other-window 1)
+ ))
+ (gds-promote-view 'interaction)
+ (gds-request-focus client))
+
+
+;;;; Loading (evaluating) a whole Scheme file.
+
(defcustom gds-source-modes '(scheme-mode)
"*Used to determine if a buffer contains Scheme source code.
If it's loaded into a buffer that is in one of these major modes, it's
(setq gds-prev-load-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
(setq client (gds-choose-client client))
- (gds-send (format "(%S load %S)\n" client file-name)))
+ (gds-send (format "load %S" file-name) client))
+
+
+;;;; Scheme mode keymap items.
-;; Install the process communication commands in the scheme-mode keymap.
(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun);gnu convention
(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp);gnu convention
-(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-defun)
+(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
(define-key scheme-mode-map "\C-c\C-l" 'gds-load-file)
+(define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
+(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
+(define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
+(define-key scheme-mode-map "\C-x " 'gds-set-source-breakpoint)
+(define-key scheme-mode-map "\C-x\e " 'gds-delete-source-breakpoint)
+
+
+;;;; Guile Interaction mode keymap and menu items.
+
+(define-key gds-mode-map "M" (function gds-query-modules))
+
+(define-key gds-mode-map "g" (function gds-go))
+(define-key gds-mode-map "q" (function gds-quit))
+(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))
+(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 "H" (function gds-debug-trap-hooks))
+(define-key gds-mode-map "u" (function gds-up))
+(define-key gds-mode-map "d" (function gds-down))
+(define-key gds-mode-map "b" (function gds-set-breakpoint))
+(define-key gds-mode-map "vi" (function gds-view-interaction))
+(define-key gds-mode-map "vs" (function gds-view-stack))
+(define-key gds-mode-map "vb" (function gds-view-breakpoints))
+(define-key gds-mode-map "vB" (function gds-view-browser))
+(define-key gds-mode-map "vm" (function gds-view-messages))
-;;;; Menu bar entries.
+(defvar gds-view-menu nil
+ "GDS view menu.")
+(if gds-view-menu
+ nil
+ (setq gds-view-menu (make-sparse-keymap "View"))
+ (define-key gds-view-menu [messages]
+ '(menu-item "Messages" gds-view-messages
+ :enable (memq 'messages gds-views)))
+ (define-key gds-view-menu [browser]
+ '(menu-item "Browser" gds-view-browser
+ :enable (memq 'browser gds-views)))
+ (define-key gds-view-menu [breakpoints]
+ '(menu-item "Breakpoints" gds-view-breakpoints
+ :enable (memq 'breakpoints gds-views)))
+ (define-key gds-view-menu [stack]
+ '(menu-item "Stack" gds-view-stack
+ :enable (memq 'stack gds-views)))
+ (define-key gds-view-menu [interaction]
+ '(menu-item "Interaction" gds-view-interaction
+ :enable (memq 'interaction gds-views))))
(defvar gds-debug-menu nil
"GDS debugging menu.")
(setq gds-debug-menu (make-sparse-keymap "Debug"))
(define-key gds-debug-menu [go]
'(menu-item "Go" gds-go))
+ (define-key gds-debug-menu [down]
+ '(menu-item "Move Down 1 Frame" gds-down))
+ (define-key gds-debug-menu [up]
+ '(menu-item "Move Up 1 Frame" gds-up))
(define-key gds-debug-menu [trace-finish]
'(menu-item "Trace This Frame" gds-trace-finish))
(define-key gds-debug-menu [step-out]
(define-key gds-debug-menu [eval]
'(menu-item "Eval In This Frame..." gds-evaluate)))
+(defvar gds-breakpoint-menu nil
+ "GDS breakpoint menu.")
+(if gds-breakpoint-menu
+ nil
+ (setq gds-breakpoint-menu (make-sparse-keymap "Breakpoint"))
+ (define-key gds-breakpoint-menu [last-sexp]
+ '(menu-item "Delete Breakpoint" gds-delete-source-breakpoint))
+ (define-key gds-breakpoint-menu [set]
+ '(menu-item "Set Breakpoint" gds-set-source-breakpoint)))
+
(defvar gds-eval-menu nil
"GDS evaluation menu.")
(if gds-eval-menu
(setq gds-help-menu (make-sparse-keymap "Help"))
(define-key gds-help-menu [apropos]
'(menu-item "Apropos..." gds-apropos))
- (define-key gds-help-menu [sym-here]
- '(menu-item "Symbol At Point" gds-help-symbol-here))
(define-key gds-help-menu [sym]
'(menu-item "Symbol..." gds-help-symbol)))
(if gds-advanced-menu
nil
(setq gds-advanced-menu (make-sparse-keymap "Advanced"))
+ (define-key gds-advanced-menu [run-captive]
+ '(menu-item "Run Captive Guile" gds-start-captive
+ :enable (not (comint-check-proc gds-captive))))
(define-key gds-advanced-menu [restart-gds]
'(menu-item "Restart IDE" gds-start :enable gds-process))
(define-key gds-advanced-menu [kill-gds]
(cons "Advanced" gds-advanced-menu))
(define-key gds-menu [separator-1]
'("--"))
- (define-key gds-menu [help]
- `(menu-item "Help" ,gds-help-menu :enable gds-names))
- (define-key gds-menu [eval]
- `(menu-item "Evaluate" ,gds-eval-menu :enable gds-names))
+ (define-key gds-menu [view]
+ `(menu-item "View" ,gds-view-menu :enable gds-views))
(define-key gds-menu [debug]
- `(menu-item "Debug" ,gds-debug-menu :enable (and gds-displayed-client
- (gds-client-waiting))))
+ `(menu-item "Debug" ,gds-debug-menu :enable (and gds-client
+ (gds-client-blocked))))
+ (define-key gds-menu [breakpoint]
+ `(menu-item "Breakpoints" ,gds-breakpoint-menu :enable t))
+ (define-key gds-menu [eval]
+ `(menu-item "Evaluate" ,gds-eval-menu :enable (or gds-buffers
+ gds-autostart-captive)))
+ (define-key gds-menu [help]
+ `(menu-item "Help" ,gds-help-menu :enable (or gds-buffers
+ gds-autostart-captive)))
(setq menu-bar-final-items
(cons 'guile menu-bar-final-items))
- (define-key global-map [menu-bar guile]
+ (define-key scheme-mode-map [menu-bar guile]
(cons "Guile" gds-menu)))
+
;;;; Autostarting the GDS server.
(defcustom gds-autostart-server t
:type 'boolean
:group 'gds)
+
+;;;; `Captive' Guile - a Guile process that is started when needed to
+;;;; provide help, completion, evaluations etc.
+
+(defcustom gds-autostart-captive t
+ "Whether to automatically start a `captive' Guile process when needed."
+ :type 'boolean
+ :group 'gds)
+
+(defvar gds-captive nil
+ "Buffer of captive Guile.")
+
+(defun gds-start-captive (&optional restart)
+ (interactive)
+ (if (and restart
+ (comint-check-proc gds-captive))
+ (gds-kill-captive))
+ (if (comint-check-proc gds-captive)
+ nil
+ (let ((process-connection-type nil))
+ (setq gds-captive (make-comint "captive-guile"
+ gds-guile-program
+ nil
+ "-q")))
+ (let ((proc (get-buffer-process gds-captive)))
+ (process-kill-without-query proc)
+ (comint-send-string proc "(set! %load-path (cons \"/home/neil/Guile/cvs/guile-core\" %load-path))\n")
+ (comint-send-string proc "(debug-enable 'backtrace)\n")
+ (comint-send-string proc "(use-modules (emacs gds-client))\n")
+ (comint-send-string proc "(gds-connect \"Captive Guile\" #f)\n"))))
+
+(defun gds-kill-captive ()
+ (if gds-captive
+ (condition-case nil
+ (progn
+ (kill-process (get-buffer-process gds-captive))
+ (accept-process-output gds-process 0 200))
+ (error))))
+
+
+;;;; If requested, autostart the server after loading.
+
(if (and gds-autostart-server
(not gds-process))
(gds-start))
+
+;;;; The end!
+
(provide 'gds)
;;; gds.el ends here.
HCoop / bpt / guile.git / blobdiff