diff options
Diffstat (limited to 'vim/bundle/slimv/slime/contrib/swank-repl.lisp')
| -rw-r--r-- | vim/bundle/slimv/slime/contrib/swank-repl.lisp | 450 |
1 files changed, 450 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-repl.lisp b/vim/bundle/slimv/slime/contrib/swank-repl.lisp new file mode 100644 index 0000000..0bed5f4 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-repl.lisp @@ -0,0 +1,450 @@ +;;; swank-repl.lisp --- Server side part of the Lisp listener. +;; +;; License: public domain +(in-package swank) + +(defpackage swank-repl + (:use cl swank/backend) + (:export *send-repl-results-function*) + (:import-from + swank + + *default-worker-thread-bindings* + + *loopback-interface* + + add-hook + *connection-closed-hook* + + eval-region + with-buffer-syntax + + connection + connection.socket-io + connection.repl-results + connection.user-input + connection.user-output + connection.user-io + connection.trace-output + connection.dedicated-output + connection.env + + multithreaded-connection + mconn.active-threads + mconn.repl-thread + mconn.auto-flush-thread + use-threads-p + + *emacs-connection* + default-connection + with-connection + + send-to-emacs + *communication-style* + handle-requests + wait-for-event + make-tag + thread-for-evaluation + socket-quest + + authenticate-client + encode-message + + auto-flush-loop + clear-user-input + + current-thread-id + cat + with-struct* + with-retry-restart + with-bindings + + package-string-for-prompt + find-external-format-or-lose + + defslimefun + + ;; FIXME: those should be exported from swank-repl only, but how to + ;; do that whithout breaking init files? + *use-dedicated-output-stream* + *dedicated-output-stream-port* + *globally-redirect-io* + + )) + +(in-package swank-repl) + +(defvar *use-dedicated-output-stream* nil + "When T swank will attempt to create a second connection to Emacs +which is used just to send output.") + +(defvar *dedicated-output-stream-port* 0 + "Which port we should use for the dedicated output stream.") + +(defvar *dedicated-output-stream-buffering* + (if (eq *communication-style* :spawn) t nil) + "The buffering scheme that should be used for the output stream. +Valid values are nil, t, :line") + +(defvar *globally-redirect-io* nil + "When non-nil globally redirect all standard streams to Emacs.") + +(defun open-streams (connection properties) + "Return the 5 streams for IO redirection: +DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS" + (let* ((input-fn + (lambda () + (with-connection (connection) + (with-simple-restart (abort-read + "Abort reading input from Emacs.") + (read-user-input-from-emacs))))) + (dedicated-output (if *use-dedicated-output-stream* + (open-dedicated-output-stream + connection + (getf properties :coding-system)))) + (in (make-input-stream input-fn)) + (out (or dedicated-output + (make-output-stream (make-output-function connection)))) + (io (make-two-way-stream in out)) + (repl-results (make-output-stream-for-target connection + :repl-result))) + (typecase connection + (multithreaded-connection + (setf (mconn.auto-flush-thread connection) + (spawn (lambda () (auto-flush-loop out)) + :name "auto-flush-thread")))) + (values dedicated-output in out io repl-results))) + +(defun make-output-function (connection) + "Create function to send user output to Emacs." + (lambda (string) + (with-connection (connection) + (send-to-emacs `(:write-string ,string))))) + +(defun make-output-function-for-target (connection target) + "Create a function to send user output to a specific TARGET in Emacs." + (lambda (string) + (with-connection (connection) + (with-simple-restart + (abort "Abort sending output to Emacs.") + (send-to-emacs `(:write-string ,string ,target)))))) + +(defun make-output-stream-for-target (connection target) + "Create a stream that sends output to a specific TARGET in Emacs." + (make-output-stream (make-output-function-for-target connection target))) + +(defun open-dedicated-output-stream (connection coding-system) + "Open a dedicated output connection to the Emacs on SOCKET-IO. +Return an output stream suitable for writing program output. + +This is an optimized way for Lisp to deliver output to Emacs." + (let ((socket (socket-quest *dedicated-output-stream-port* nil)) + (ef (find-external-format-or-lose coding-system))) + (unwind-protect + (let ((port (local-port socket))) + (encode-message `(:open-dedicated-output-stream ,port + ,coding-system) + (connection.socket-io connection)) + (let ((dedicated (accept-connection + socket + :external-format ef + :buffering *dedicated-output-stream-buffering* + :timeout 30))) + (authenticate-client dedicated) + (close-socket socket) + (setf socket nil) + dedicated)) + (when socket + (close-socket socket))))) + +(defmethod thread-for-evaluation ((connection multithreaded-connection) + (id (eql :find-existing))) + (or (car (mconn.active-threads connection)) + (find-repl-thread connection))) + +(defmethod thread-for-evaluation ((connection multithreaded-connection) + (id (eql :repl-thread))) + (find-repl-thread connection)) + +(defun find-repl-thread (connection) + (cond ((not (use-threads-p)) + (current-thread)) + (t + (let ((thread (mconn.repl-thread connection))) + (cond ((not thread) nil) + ((thread-alive-p thread) thread) + (t + (setf (mconn.repl-thread connection) + (spawn-repl-thread connection "new-repl-thread")))))))) + +(defun spawn-repl-thread (connection name) + (spawn (lambda () + (with-bindings *default-worker-thread-bindings* + (repl-loop connection))) + :name name)) + +(defun repl-loop (connection) + (handle-requests connection)) + +;;;;; Redirection during requests +;;; +;;; We always redirect the standard streams to Emacs while evaluating +;;; an RPC. This is done with simple dynamic bindings. + +(defslimefun create-repl (target &key coding-system) + (assert (eq target nil)) + (let ((conn *emacs-connection*)) + (initialize-streams-for-connection conn `(:coding-system ,coding-system)) + (with-struct* (connection. @ conn) + (setf (@ env) + `((*standard-input* . ,(@ user-input)) + ,@(unless *globally-redirect-io* + `((*standard-output* . ,(@ user-output)) + (*trace-output* . ,(or (@ trace-output) (@ user-output))) + (*error-output* . ,(@ user-output)) + (*debug-io* . ,(@ user-io)) + (*query-io* . ,(@ user-io)) + (*terminal-io* . ,(@ user-io)))))) + (maybe-redirect-global-io conn) + (add-hook *connection-closed-hook* 'update-redirection-after-close) + (typecase conn + (multithreaded-connection + (setf (mconn.repl-thread conn) + (spawn-repl-thread conn "repl-thread")))) + (list (package-name *package*) + (package-string-for-prompt *package*))))) + +(defun initialize-streams-for-connection (connection properties) + (multiple-value-bind (dedicated in out io repl-results) + (open-streams connection properties) + (setf (connection.dedicated-output connection) dedicated + (connection.user-io connection) io + (connection.user-output connection) out + (connection.user-input connection) in + (connection.repl-results connection) repl-results) + connection)) + +(defun read-user-input-from-emacs () + (let ((tag (make-tag))) + (force-output) + (send-to-emacs `(:read-string ,(current-thread-id) ,tag)) + (let ((ok nil)) + (unwind-protect + (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value))) + (setq ok t)) + (unless ok + (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag))))))) + +;;;;; Listener eval + +(defvar *listener-eval-function* 'repl-eval) + +(defvar *listener-saved-value* nil) + +(defslimefun listener-save-value (slimefun &rest args) + "Apply SLIMEFUN to ARGS and save the value. +The saved value should be visible to all threads and retrieved via +LISTENER-GET-VALUE." + (setq *listener-saved-value* (apply slimefun args)) + t) + +(defslimefun listener-get-value () + "Get the last value saved by LISTENER-SAVE-VALUE. +The value should be produced as if it were requested through +LISTENER-EVAL directly, so that spacial variables *, etc are set." + (listener-eval (let ((*package* (find-package :keyword))) + (write-to-string '*listener-saved-value*)))) + +(defslimefun listener-eval (string &key (window-width nil window-width-p)) + (if window-width-p + (let ((*print-right-margin* window-width)) + (funcall *listener-eval-function* string)) + (funcall *listener-eval-function* string))) + +(defslimefun clear-repl-variables () + (let ((variables '(*** ** * /// // / +++ ++ +))) + (loop for variable in variables + do (setf (symbol-value variable) nil)))) + +(defvar *send-repl-results-function* 'send-repl-results-to-emacs) + +(defun repl-eval (string) + (clear-user-input) + (with-buffer-syntax () + (with-retry-restart (:msg "Retry SLIME REPL evaluation request.") + (track-package + (lambda () + (multiple-value-bind (values last-form) (eval-region string) + (setq *** ** ** * * (car values) + /// // // / / values + +++ ++ ++ + + last-form) + (funcall *send-repl-results-function* values)))))) + nil) + +(defun track-package (fun) + (let ((p *package*)) + (unwind-protect (funcall fun) + (unless (eq *package* p) + (send-to-emacs (list :new-package (package-name *package*) + (package-string-for-prompt *package*))))))) + +(defun send-repl-results-to-emacs (values) + (finish-output) + (if (null values) + (send-to-emacs `(:write-string "; No value" :repl-result)) + (dolist (v values) + (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline) + :repl-result))))) + +(defslimefun redirect-trace-output (target) + (setf (connection.trace-output *emacs-connection*) + (make-output-stream-for-target *emacs-connection* target)) + nil) + + + +;;;; IO to Emacs +;;; +;;; This code handles redirection of the standard I/O streams +;;; (`*standard-output*', etc) into Emacs. The `connection' structure +;;; contains the appropriate streams, so all we have to do is make the +;;; right bindings. + +;;;;; Global I/O redirection framework +;;; +;;; Optionally, the top-level global bindings of the standard streams +;;; can be assigned to be redirected to Emacs. When Emacs connects we +;;; redirect the streams into the connection, and they keep going into +;;; that connection even if more are established. If the connection +;;; handling the streams closes then another is chosen, or if there +;;; are no connections then we revert to the original (real) streams. +;;; +;;; It is slightly tricky to assign the global values of standard +;;; streams because they are often shadowed by dynamic bindings. We +;;; solve this problem by introducing an extra indirection via synonym +;;; streams, so that *STANDARD-INPUT* is a synonym stream to +;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current" +;;; variables, so they can always be assigned to affect a global +;;; change. + +;;;;; Global redirection setup + +(defvar *saved-global-streams* '() + "A plist to save and restore redirected stream objects. +E.g. the value for '*standard-output* holds the stream object +for *standard-output* before we install our redirection.") + +(defun setup-stream-indirection (stream-var &optional stream) + "Setup redirection scaffolding for a global stream variable. +Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro: + +1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'. + +2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as +*STANDARD-INPUT*. + +3. Assigns *STANDARD-INPUT* to a synonym stream pointing to +*CURRENT-STANDARD-INPUT*. + +This has the effect of making *CURRENT-STANDARD-INPUT* contain the +effective global value for *STANDARD-INPUT*. This way we can assign +the effective global value even when *STANDARD-INPUT* is shadowed by a +dynamic binding." + (let ((current-stream-var (prefixed-var '#:current stream-var)) + (stream (or stream (symbol-value stream-var)))) + ;; Save the real stream value for the future. + (setf (getf *saved-global-streams* stream-var) stream) + ;; Define a new variable for the effective stream. + ;; This can be reassigned. + (proclaim `(special ,current-stream-var)) + (set current-stream-var stream) + ;; Assign the real binding as a synonym for the current one. + (let ((stream (make-synonym-stream current-stream-var))) + (set stream-var stream) + (set-default-initial-binding stream-var `(quote ,stream))))) + +(defun prefixed-var (prefix variable-symbol) + "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*" + (let ((basename (subseq (symbol-name variable-symbol) 1))) + (intern (format nil "*~A-~A" (string prefix) basename) :swank))) + +(defvar *standard-output-streams* + '(*standard-output* *error-output* *trace-output*) + "The symbols naming standard output streams.") + +(defvar *standard-input-streams* + '(*standard-input*) + "The symbols naming standard input streams.") + +(defvar *standard-io-streams* + '(*debug-io* *query-io* *terminal-io*) + "The symbols naming standard io streams.") + +(defun init-global-stream-redirection () + (when *globally-redirect-io* + (cond (*saved-global-streams* + (warn "Streams already redirected.")) + (t + (mapc #'setup-stream-indirection + (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)))))) + +(defun globally-redirect-io-to-connection (connection) + "Set the standard I/O streams to redirect to CONNECTION. +Assigns *CURRENT-<STREAM>* for all standard streams." + (dolist (o *standard-output-streams*) + (set (prefixed-var '#:current o) + (connection.user-output connection))) + ;; FIXME: If we redirect standard input to Emacs then we get the + ;; regular Lisp top-level trying to read from our REPL. + ;; + ;; Perhaps the ideal would be for the real top-level to run in a + ;; thread with local bindings for all the standard streams. Failing + ;; that we probably would like to inhibit it from reading while + ;; Emacs is connected. + ;; + ;; Meanwhile we just leave *standard-input* alone. + #+NIL + (dolist (i *standard-input-streams*) + (set (prefixed-var '#:current i) + (connection.user-input connection))) + (dolist (io *standard-io-streams*) + (set (prefixed-var '#:current io) + (connection.user-io connection)))) + +(defun revert-global-io-redirection () + "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams." + (dolist (stream-var (append *standard-output-streams* + *standard-input-streams* + *standard-io-streams*)) + (set (prefixed-var '#:current stream-var) + (getf *saved-global-streams* stream-var)))) + +;;;;; Global redirection hooks + +(defvar *global-stdio-connection* nil + "The connection to which standard I/O streams are globally redirected. +NIL if streams are not globally redirected.") + +(defun maybe-redirect-global-io (connection) + "Consider globally redirecting to CONNECTION." + (when (and *globally-redirect-io* (null *global-stdio-connection*) + (connection.user-io connection)) + (unless *saved-global-streams* + (init-global-stream-redirection)) + (setq *global-stdio-connection* connection) + (globally-redirect-io-to-connection connection))) + +(defun update-redirection-after-close (closed-connection) + "Update redirection after a connection closes." + (check-type closed-connection connection) + (when (eq *global-stdio-connection* closed-connection) + (if (and (default-connection) *globally-redirect-io*) + ;; Redirect to another connection. + (globally-redirect-io-to-connection (default-connection)) + ;; No more connections, revert to the real streams. + (progn (revert-global-io-redirection) + (setq *global-stdio-connection* nil))))) + +(provide :swank-repl) |