diff options
Diffstat (limited to 'vim/bundle/slimv/slime/contrib/swank-mrepl.lisp')
-rw-r--r-- | vim/bundle/slimv/slime/contrib/swank-mrepl.lisp | 162 |
1 files changed, 162 insertions, 0 deletions
diff --git a/vim/bundle/slimv/slime/contrib/swank-mrepl.lisp b/vim/bundle/slimv/slime/contrib/swank-mrepl.lisp new file mode 100644 index 0000000..cc8ce81 --- /dev/null +++ b/vim/bundle/slimv/slime/contrib/swank-mrepl.lisp @@ -0,0 +1,162 @@ +;;; swank-mrepl.lisp +;; +;; Licence: public domain + +(in-package :swank) +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((api '( + *emacs-connection* + channel + channel-id + define-channel-method + defslimefun + dcase + log-event + process-requests + send-to-remote-channel + use-threads-p + wait-for-event + with-bindings + with-connection + with-top-level-restart + with-slime-interrupts + ))) + (eval `(defpackage #:swank-api + (:use) + (:import-from #:swank . ,api) + (:export . ,api))))) + +(defpackage :swank-mrepl + (:use :cl :swank-api) + (:export #:create-mrepl)) + +(in-package :swank-mrepl) + +(defclass listener-channel (channel) + ((remote :initarg :remote) + (env :initarg :env) + (mode :initform :eval) + (tag :initform nil))) + +(defun package-prompt (package) + (reduce (lambda (x y) (if (<= (length x) (length y)) x y)) + (cons (package-name package) (package-nicknames package)))) + +(defslimefun create-mrepl (remote) + (let* ((pkg *package*) + (conn *emacs-connection*) + (thread (if (use-threads-p) + (spawn-listener-thread conn) + nil)) + (ch (make-instance 'listener-channel :remote remote :thread thread))) + (setf (slot-value ch 'env) (initial-listener-env ch)) + (when thread + (swank/backend:send thread `(:serve-channel ,ch))) + (list (channel-id ch) + (swank/backend:thread-id (or thread (swank/backend:current-thread))) + (package-name pkg) + (package-prompt pkg)))) + +(defun initial-listener-env (listener) + `((*package* . ,*package*) + (*standard-output* . ,(make-listener-output-stream listener)) + (*standard-input* . ,(make-listener-input-stream listener)))) + +(defun spawn-listener-thread (connection) + (swank/backend:spawn + (lambda () + (with-connection (connection) + (dcase (swank/backend:receive) + ((:serve-channel c) + (loop + (with-top-level-restart (connection (drop-unprocessed-events c)) + (process-requests nil))))))) + :name "mrepl thread")) + +(defun drop-unprocessed-events (channel) + (with-slots (mode) channel + (let ((old-mode mode)) + (setf mode :drop) + (unwind-protect + (process-requests t) + (setf mode old-mode))) + (send-prompt channel))) + +(define-channel-method :process ((c listener-channel) string) + (log-event ":process ~s~%" string) + (with-slots (mode remote) c + (ecase mode + (:eval (mrepl-eval c string)) + (:read (mrepl-read c string)) + (:drop)))) + +(defun mrepl-eval (channel string) + (with-slots (remote env) channel + (let ((aborted t)) + (with-bindings env + (unwind-protect + (let ((result (with-slime-interrupts (read-eval-print string)))) + (send-to-remote-channel remote `(:write-result ,result)) + (setq aborted nil)) + (setf env (loop for (sym) in env + collect (cons sym (symbol-value sym)))) + (cond (aborted + (send-to-remote-channel remote `(:evaluation-aborted))) + (t + (send-prompt channel)))))))) + +(defun send-prompt (channel) + (with-slots (env remote) channel + (let ((pkg (or (cdr (assoc '*package* env)) *package*)) + (out (cdr (assoc '*standard-output* env))) + (in (cdr (assoc '*standard-input* env)))) + (when out (force-output out)) + (when in (clear-input in)) + (send-to-remote-channel remote `(:prompt ,(package-name pkg) + ,(package-prompt pkg)))))) + +(defun mrepl-read (channel string) + (with-slots (tag) channel + (assert tag) + (throw tag string))) + +(defun read-eval-print (string) + (with-input-from-string (in string) + (setq / ()) + (loop + (let* ((form (read in nil in))) + (cond ((eq form in) (return)) + (t (setq / (multiple-value-list (eval (setq + form)))))))) + (force-output) + (if / + (format nil "~{~s~%~}" /) + "; No values"))) + +(defun make-listener-output-stream (channel) + (let ((remote (slot-value channel 'remote))) + (swank/backend:make-output-stream + (lambda (string) + (send-to-remote-channel remote `(:write-string ,string)))))) + +(defun make-listener-input-stream (channel) + (swank/backend:make-input-stream (lambda () (read-input channel)))) + +(defun set-mode (channel new-mode) + (with-slots (mode remote) channel + (unless (eq mode new-mode) + (send-to-remote-channel remote `(:set-read-mode ,new-mode))) + (setf mode new-mode))) + +(defun read-input (channel) + (with-slots (mode tag remote) channel + (force-output) + (let ((old-mode mode) + (old-tag tag)) + (setf tag (cons nil nil)) + (set-mode channel :read) + (unwind-protect + (catch tag (process-requests nil)) + (setf tag old-tag) + (set-mode channel old-mode))))) + +(provide :swank-mrepl) |