442 lines
16 KiB
Common Lisp
442 lines
16 KiB
Common Lisp
|
;;; 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* :started-from-emacs
|
|||
|
|
"When T globally redirect all standard streams to Emacs.
|
|||
|
|
When :STARTED-FROM-EMACS redirect when launched by M-x slime")
|
|||
|
|
|
|||
|
|
(defun globally-redirect-io-p ()
|
|||
|
|
(case *globally-redirect-io*
|
|||
|
|
((t) t)
|
|||
|
|
(:started-from-emacs swank-loader:*started-from-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 (swank:make-output-stream-for-target connection
|
|||
|
|
:repl-result)))
|
|||
|
|
(typecase connection
|
|||
|
|
(multithreaded-connection
|
|||
|
|
(setf (mconn.auto-flush-thread connection)
|
|||
|
|
(make-auto-flush-thread out))))
|
|||
|
|
(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 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-p)
|
|||
|
|
`((*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*)
|
|||
|
|
(swank: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-p)
|
|||
|
|
(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-p) (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-p))
|
|||
|
|
;; 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)
|