mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
53befeb700
(Not quite finished, the following will be done tomorrow. module/srfi/*.scm module/rnrs/*.scm module/scripts/*.scm testsuite/*.scm guile-readline/* )
533 lines
20 KiB
EmacsLisp
Executable file
533 lines
20 KiB
EmacsLisp
Executable file
;;; 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))
|
|
(client nil))
|
|
;; 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)
|
|
(setq client (string-to-number string))
|
|
(if (process-buffer proc)
|
|
(with-current-buffer (process-buffer proc)
|
|
(insert string)))))
|
|
;; Accept output from the new process until we have its number.
|
|
(while (not client)
|
|
(accept-process-output proc))
|
|
;; Return the new process's client number.
|
|
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 to show error stack]")
|
|
(add-text-properties beg (point)
|
|
(list 'keymap map
|
|
'mouse-face 'highlight))
|
|
(insert "\n")))
|
|
(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.
|