+++ /dev/null
-;;; gds-scheme.el -- GDS function for Scheme mode buffers
-
-;;;; Copyright (C) 2005 Neil Jerram
-;;;;
-;;;; 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
-
-(require 'comint)
-(require 'scheme)
-(require 'derived)
-(require 'pp)
-
-;;;; Maintaining an association between a Guile client process and a
-;;;; set of Scheme mode buffers.
-
-(defcustom gds-auto-create-utility-client t
- "Whether to automatically create a utility Guile client, and
-associate the current buffer with it, if there are no existing Guile
-clients available to GDS when the user does something that requires a
-running Guile client."
- :type 'boolean
- :group 'gds)
-
-(defcustom gds-auto-associate-single-client t
- "Whether to automatically associate the current buffer with an
-existing Guile client, if there is only only client known to GDS when
-the user does something that requires a running Guile client, and the
-current buffer is not already associated with a Guile client."
- :type 'boolean
- :group 'gds)
-
-(defcustom gds-auto-associate-last-client t
- "Whether to automatically associate the current buffer with the
-Guile client that most recently caused that buffer to be displayed,
-when the user does something that requires a running Guile client and
-the current buffer is not already associated with a Guile client."
- :type 'boolean
- :group 'gds)
-
-(defvar gds-last-touched-by nil
- "For each Scheme mode buffer, this records the GDS client that most
-recently `touched' that buffer in the sense of using it to display
-source code, for example for the source code relevant to a debugger
-stack frame.")
-(make-variable-buffer-local 'gds-last-touched-by)
-
-(defun gds-auto-associate-buffer ()
- "Automatically associate the current buffer with a Guile client, if
-possible."
- (let* ((num-clients (length gds-client-info))
- (client
- (or
- ;; If there are no clients yet, and
- ;; `gds-auto-create-utility-client' allows us to create one
- ;; automatically, do that.
- (and (= num-clients 0)
- gds-auto-create-utility-client
- (gds-start-utility-guile))
- ;; Otherwise, if there is a single existing client, and
- ;; `gds-auto-associate-single-client' allows us to use it
- ;; for automatic association, do that.
- (and (= num-clients 1)
- gds-auto-associate-single-client
- (caar gds-client-info))
- ;; Otherwise, if the current buffer was displayed because
- ;; of a Guile client trapping somewhere in its code, and
- ;; `gds-auto-associate-last-client' allows us to associate
- ;; with that client, do so.
- (and gds-auto-associate-last-client
- gds-last-touched-by))))
- (if client
- (gds-associate-buffer client))))
-
-(defun gds-associate-buffer (client)
- "Associate the current buffer with the Guile process CLIENT.
-This means that operations in this buffer that require a running Guile
-process - such as evaluation, help, completion and setting traps -
-will be sent to the Guile process whose name or connection number is
-CLIENT."
- (interactive (list (gds-choose-client)))
- ;; If this buffer is already associated, dissociate from its
- ;; existing client first.
- (if gds-client (gds-dissociate-buffer))
- ;; Store the client number in the buffer-local variable gds-client.
- (setq gds-client client)
- ;; Add this buffer to the list of buffers associated with the
- ;; client.
- (gds-client-put client 'associated-buffers
- (cons (current-buffer)
- (gds-client-get client 'associated-buffers))))
-
-(defun gds-dissociate-buffer ()
- "Dissociate the current buffer from any specific Guile process."
- (interactive)
- (if gds-client
- (progn
- ;; Remove this buffer from the list of buffers associated with
- ;; the current client.
- (gds-client-put gds-client 'associated-buffers
- (delq (current-buffer)
- (gds-client-get gds-client 'associated-buffers)))
- ;; Reset the buffer-local variable gds-client.
- (setq gds-client nil)
- ;; Clear any process status indication from the modeline.
- (setq mode-line-process nil)
- (force-mode-line-update))))
-
-(defun gds-show-client-status (client status-string)
- "Show a client's status in the modeline of all its associated
-buffers."
- (let ((buffers (gds-client-get client 'associated-buffers)))
- (while buffers
- (if (buffer-live-p (car buffers))
- (with-current-buffer (car buffers)
- (setq mode-line-process status-string)
- (force-mode-line-update)))
- (setq buffers (cdr buffers)))))
-
-(defcustom gds-running-text ":running"
- "*Mode line text used to show that a Guile process is \"running\".
-\"Running\" means that the process cannot currently accept any input
-from the GDS frontend in Emacs, because all of its threads are busy
-running code that GDS cannot easily interrupt."
- :type 'string
- :group 'gds)
-
-(defcustom gds-ready-text ":ready"
- "*Mode line text used to show that a Guile process is \"ready\".
-\"Ready\" means that the process is ready to interact with the GDS
-frontend in Emacs, because at least one of its threads is waiting for
-GDS input."
- :type 'string
- :group 'gds)
-
-(defcustom gds-debug-text ":debug"
- "*Mode line text used to show that a Guile process is \"debugging\".
-\"Debugging\" means that the process is using the GDS frontend in
-Emacs to display an error or trap so that the user can debug it."
- :type 'string
- :group 'gds)
-
-(defun gds-choose-client ()
- "Ask the user to choose a GDS client process from a list."
- (let ((table '())
- (default nil))
- ;; Prepare a table containing all current clients.
- (mapcar (lambda (client-info)
- (setq table (cons (cons (cadr (memq 'name client-info))
- (car client-info))
- table)))
- gds-client-info)
- ;; Add an entry to allow the user to ask for a new process.
- (setq table (cons (cons "Start a new Guile process" nil) table))
- ;; Work out a good default. If the buffer has a good value in
- ;; gds-last-touched-by, we use that; otherwise default to starting
- ;; a new process.
- (setq default (or (and gds-last-touched-by
- (gds-client-get gds-last-touched-by 'name))
- (caar table)))
- ;; Read using this table.
- (let* ((name (completing-read "Choose a Guile process: "
- table
- nil
- t ; REQUIRE-MATCH
- nil ; INITIAL-INPUT
- nil ; HIST
- default))
- ;; Convert name to a client number.
- (client (cdr (assoc name table))))
- ;; If the user asked to start a new Guile process, do that now.
- (or client (setq client (gds-start-utility-guile)))
- ;; Return the chosen client ID.
- client)))
-
-(defvar gds-last-utility-number 0
- "Number of the last started Guile utility process.")
-
-(defun gds-start-utility-guile ()
- "Start a new utility Guile process."
- (setq gds-last-utility-number (+ gds-last-utility-number 1))
- (let* ((procname (format "gds-util[%d]" gds-last-utility-number))
- (code (format "(begin
- %s
- (use-modules (ice-9 gds-client))
- (run-utility))"
- (if gds-scheme-directory
- (concat "(set! %load-path (cons "
- (format "%S" gds-scheme-directory)
- " %load-path))")
- "")))
- (proc (start-process procname
- (get-buffer-create procname)
- gds-guile-program
- "-q"
- "--debug"
- "-c"
- code)))
- ;; Note that this process can be killed automatically on Emacs
- ;; exit.
- (process-kill-without-query proc)
- ;; Set up a process filter to catch the new client's number.
- (set-process-filter proc
- (lambda (proc string)
- (if (process-buffer proc)
- (with-current-buffer (process-buffer proc)
- (insert string)
- (or gds-client
- (save-excursion
- (goto-char (point-min))
- (setq gds-client
- (condition-case nil
- (read (current-buffer))
- (error nil)))))))))
- ;; Accept output from the new process until we have its number.
- (while (not (with-current-buffer (process-buffer proc) gds-client))
- (accept-process-output proc))
- ;; Return the new process's client number.
- (with-current-buffer (process-buffer proc) gds-client)))
-
-;;;; Evaluating code.
-
-;; The following commands send code for evaluation through the GDS TCP
-;; connection, receive the result and any output generated through the
-;; same connection, and display the result and output to the user.
-;;
-;; 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.
-
-(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."
- (interactive "r") ; why not?
- (save-excursion
- (goto-char start)
- (let (module-name)
- (while (and (not module-name)
- (beginning-of-defun-raw 1))
- (if (looking-at "(define-module ")
- (setq module-name
- (progn
- (goto-char (match-end 0))
- (read (current-buffer))))))
- module-name)))
-
-(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: "
- "Prefix used when telling Guile the name of the port from which a
-chunk of Scheme code (to be evaluated) comes. GDS uses this prefix,
-followed by the buffer name, in two cases: when the buffer concerned
-is not associated with a file, or if the buffer has been modified
-since last saving to its file. In the case where the buffer is
-identical to a saved file, GDS uses the file name as the port name."
- :type '(string)
- :group 'gds)
-
-(defun gds-port-name (start end)
- "Return port name for the specified region of the current buffer.
-The name will be used by Guile as the port name when evaluating that
-region's code."
- (or (and (not (buffer-modified-p))
- buffer-file-name)
- (concat gds-emacs-buffer-port-name-prefix (buffer-name))))
-
-(defun gds-line-and-column (pos)
- "Return 0-based line and column number at POS."
- (let (line column)
- (save-excursion
- (goto-char pos)
- (setq column (current-column))
- (beginning-of-line)
- (setq line (count-lines (point-min) (point))))
- (cons line column)))
-
-(defun gds-eval-region (start end &optional debugp)
- "Evaluate the current region. If invoked with `C-u' prefix (or, in
-a program, with optional DEBUGP arg non-nil), pause and pop up the
-stack at the start of the evaluation, so that the user can single-step
-through the code."
- (interactive "r\nP")
- (or gds-client
- (gds-auto-associate-buffer)
- (call-interactively 'gds-associate-buffer))
- (let ((module (gds-module-name start end))
- (port-name (gds-port-name start end))
- (lc (gds-line-and-column start)))
- (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 (car lc) (cdr lc)
- code
- (if debugp '(debug) '(none)))
- gds-client))))
-
-(defun gds-eval-expression (expr &optional correlator debugp)
- "Evaluate the supplied EXPR (a string). If invoked with `C-u'
-prefix (or, in a program, with optional DEBUGP arg non-nil), pause and
-pop up the stack at the start of the evaluation, so that the user can
-single-step through the code."
- (interactive "sEvaluate expression: \ni\nP")
- (or gds-client
- (gds-auto-associate-buffer)
- (call-interactively 'gds-associate-buffer))
- (set-text-properties 0 (length expr) nil expr)
- (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S %s"
- (or correlator 'expression)
- (gds-abbreviated expr)
- expr
- (if debugp '(debug) '(none)))
- gds-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 debugp)
- "Evaluate the defun (top-level form) at point. If invoked with
-`C-u' prefix (or, in a program, with optional DEBUGP arg non-nil),
-pause and pop up the stack at the start of the evaluation, so that the
-user can single-step through the code."
- (interactive "P")
- (save-excursion
- (end-of-defun)
- (let ((end (point)))
- (beginning-of-defun)
- (gds-eval-region (point) end debugp))))
-
-(defun gds-eval-last-sexp (&optional debugp)
- "Evaluate the sexp before point. If invoked with `C-u' prefix (or,
-in a program, with optional DEBUGP arg non-nil), pause and pop up the
-stack at the start of the evaluation, so that the user can single-step
-through the code."
- (interactive "P")
- (gds-eval-region (save-excursion (backward-sexp) (point)) (point) debugp))
-
-;;;; Help.
-
-;; Help is implemented as a special case of evaluation, identified by
-;; the evaluation correlator 'help.
-
-(defun gds-help-symbol (sym)
- "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))))
- (gds-eval-expression (format "(help %s)" sym) 'help))
-
-(defun gds-apropos (regex)
- "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))))
- (set-text-properties 0 (length regex) nil regex)
- (gds-eval-expression (format "(apropos %S)" regex) 'apropos))
-
-;;;; Displaying results of help and eval.
-
-(defun gds-display-results (client correlator stack-available results)
- (let* ((helpp+bufname (cond ((eq (car correlator) 'help)
- '(t . "*Guile Help*"))
- ((eq (car correlator) 'apropos)
- '(t . "*Guile Apropos*"))
- (t
- '(nil . "*Guile Evaluation*"))))
- (helpp (car helpp+bufname)))
- (let ((buf (get-buffer-create (cdr helpp+bufname))))
- (save-selected-window
- (save-excursion
- (set-buffer buf)
- (gds-dissociate-buffer)
- (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)))
- (if stack-available
- (let ((beg (point))
- (map (make-sparse-keymap)))
- (define-key map [mouse-1] 'gds-show-last-stack)
- (define-key map "\C-m" 'gds-show-last-stack)
- (insert "[click here (or RET) to show error stack]")
- (add-text-properties beg (point)
- (list 'keymap map
- 'mouse-face 'highlight))
- (insert "\n")
- (add-text-properties (1- (point)) (point)
- (list 'keymap map))))
- (goto-char (point-min))
- (gds-associate-buffer client))
- (pop-to-buffer buf)
- (run-hooks 'temp-buffer-show-hook)))))
-
-(defun gds-show-last-stack ()
- "Show stack of the most recent error."
- (interactive)
- (or gds-client
- (gds-auto-associate-buffer)
- (call-interactively 'gds-associate-buffer))
- (gds-send "debug-lazy-trap-context" gds-client))
-
-;;;; Completion.
-
-(defvar gds-completion-results nil)
-
-(defun gds-complete-symbol ()
- "Complete the Guile symbol before point. Returns `t' if anything
-interesting happened, `nil' if not."
- (interactive)
- (or gds-client
- (gds-auto-associate-buffer)
- (call-interactively 'gds-associate-buffer))
- (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 gds-completion-results nil)
- (gds-send (format "complete %s"
- (prin1-to-string
- (buffer-substring-no-properties (- (point) chars)
- (point))))
- gds-client)
- (while (null gds-completion-results)
- (accept-process-output gds-debug-server 0 200))
- (cond ((eq gds-completion-results 'error)
- (error "Internal error - please report the contents of the *Guile Evaluation* window"))
- ((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)))))
-
-;;;; Dispatcher for non-debug protocol.
-
-(defun gds-nondebug-protocol (client proc args)
- (cond (;; (eval-results ...) - Results of evaluation.
- (eq proc 'eval-results)
- (gds-display-results client (car args) (cadr args) (cddr args))
- ;; If these results indicate an error, set
- ;; gds-completion-results to non-nil in case the error arose
- ;; when trying to do a completion.
- (if (eq (caar args) 'error)
- (setq gds-completion-results 'error)))
-
- (;; (completion-result ...) - Available completions.
- (eq proc 'completion-result)
- (setq gds-completion-results (or (car args) t)))
-
- (;; (note ...) - For debugging only.
- (eq proc 'note))
-
- (;; (trace ...) - Tracing.
- (eq proc 'trace)
- (with-current-buffer (get-buffer-create "*GDS Trace*")
- (save-excursion
- (goto-char (point-max))
- (or (bolp) (insert "\n"))
- (insert "[client " (number-to-string client) "] " (car args) "\n"))))
-
- (t
- ;; Unexpected.
- (error "Bad protocol: %S" form))))
-
-;;;; Scheme mode keymap items.
-
-(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun)
-(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp)
-(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-hg" 'gds-help-symbol)
-(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
-(define-key scheme-mode-map "\C-hG" 'gds-apropos)
-(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack)
-(define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
-
-;;;; The end!
-
-(provide 'gds-scheme)
-
-;;; gds-scheme.el ends here.
HCoop / bpt / guile.git / blobdiff