Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Tree: 752221ff07
Fetching contributors…

Cannot retrieve contributors at this time

214 lines (185 sloc) 8.52 KB
(define-slime-contrib slime-proxy
"Interaction with other environments through SLIME and swank."
(:authors "3b"
"Red Daly <>")
(:license "elisp code is GPL, Common Lisp Code is BSD?")
(:slime-dependencies slime-repl)
(:swank-dependencies swank-proxy swank-repl)
(defgroup slime-proxy nil
"Interaction with other environments through SLIME."
:prefix "slime-proxy-"
:group 'slime)
(defvar slime-proxy-event-loop nil)
(defvar slime-proxy-most-recent-channel-id nil)
(slime-def-connection-var slime-connection-proxy-output-buffer nil
"The buffer for the REPL. May be nil or a dead buffer.")
(defvar slime-proxy-proxy-connection nil))
(defun slime-proxy-output-buffer ()
"Returns the proxy REPL buffer based on the current buffer."
;; FIXME: use a per-buffer variable instead of a per-connection variable
(let* ((slime-dispatching-connection (slime-proxy-connection)))
(defun slime-proxy-connection ()
"Returns the most relevant proxy connection."
(flet ((test-process (process)
(let ((slime-dispatching-connection process))
(slime-with-connection-buffer (process)
(when (slime-connection-proxy-output-buffer)
(find-if #'test-process (cons (slime-current-connection)
(defmacro with-proxy-output-buffers (&rest body)
`(letf (((slime-connection-output-buffer) (slime-proxy-output-buffer)))
(defun slime-proxy-repl-write-string (string &optional target)
(case target
((or :proxy-repl-result :proxy)
(slime-proxy-repl-write-string string nil)))
(funcall 'slime-repl-write-string string target))))
(setq slime-write-string-function 'slime-proxy-repl-write-string)
(defun slime-proxy (target)
"Open up a slime proxy instance through the remote swank, and
launch a REPL for the proxy."
(interactive "sTarget for proxy: ")
(slime-proxy-open-listener target))
(defun slime-proxy-open-listener (target)
"Create a new listener window."
;; create emacs-side channel struct
(let ((channel (slime-make-channel nil "slime-proxy-channel")))
;; now create the swank-side proxy listener
`(swank:create-proxy-listener ,( channel) ,target)
(lambda (result channel)
(let ((slime-dispatching-connection (slime-connection)))
(destructuring-bind (remote thread-id package prompt) result
(setq slime-proxy-most-recent-channel-id remote)
(pop-to-buffer (generate-new-buffer (slime-buffer-name :proxy-repl)))
(setq slime-proxy-proxy-connection t)
(setq slime-current-thread thread-id)
;(message "New buffer with slime connection=%s" (slime-connection))
(setq slime-buffer-connection (slime-connection))
(setf slime-buffer-package package)
(setf (slime-connection-proxy-output-buffer) (current-buffer))
(set (make-local-variable 'slime-proxy-remote-channel) remote)
(slime-channel-put channel 'buffer (current-buffer))
;(slime-channel-send channel `(:prompt ,package ,prompt))
(letf (((slime-lisp-package-prompt-string) (or prompt "PAREN")))
(defun slime-proxy-connected-p ()
"Returns T if we are connected to a proxy server."
(let ((slime-dispatching-connection (slime-proxy-connection)))
(and slime-dispatching-connection
(defun slime-proxy-event-hook-function (event)
((and slime-proxy-proxy-connection
(not slime-proxy-event-loop))
(let ((slime-proxy-event-loop t)
(proxy slime-proxy-proxy-connection)
(slime-proxy-proxy-connection nil)
(slime-dispatching-connection (slime-proxy-connection)))
; (message "sending proxied msg %s - %s" proxy event)
(destructure-case event
((:emacs-interrupt thread)
(slime-send `(:emacs-interrupt ,thread)))
((:emacs-rex form package thread continuation)
(when (and (slime-use-sigint-for-interrupt) (slime-busy-p))
(slime-display-oneliner "; pipelined request... %S" form))
(let ((id (incf (slime-continuation-counter))))
;(message "proxied message, id=%s" id)
;(message "proxied message, form=%s" form)
(slime-send `(:emacs-channel-send
(:proxy (:emacs-rex ,form ,package ,thread ,id))) )
;; wrap the continuation to execute in the proxy's environment
(lexical-let* ((original continuation)
(wrapped (lambda (result)
(let ((slime-proxy-wrapped-continuation t))
(funcall original result))))))
(push (cons id wrapped)
;(message "adjusted continuations (added %i for %s): %s"
; id (slime-connection) (mapcar 'car (slime-rex-continuations)))
((:operator-arglist )
(message "slime-proxy ignorning slime: %s" event)
;;; fixme dont have proxy-event caught in two places. Use
;;; only the one below, and get rid of the if/else separating
;;; these.
((:proxy-event wrapped-event package prompt-string)
(case wrapped-event
(setf (slime-lisp-package) package)
(setf (slime-lisp-package-prompt-string) prompt-string)
(let ((buffer (slime-connection-output-buffer)))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq slime-buffer-package package)))))
(t (message "slime-proxy ignoring proxy event: %s" wrapped-event)))
(message "slime-proxy ignorning slime: %s" event)))
((and (slime-proxy-connected-p)
(not slime-proxy-event-loop))
(destructure-case event
((:proxy-event wrapped-event package prompt-string)
(case wrapped-event
;; fixme: need a proxy version of slime-lisp-package, which
;; requires making slime-lisp-package buffer-specific, not
;; connection-specific
(setf (slime-lisp-package) package)
(setf (slime-lisp-package-prompt-string) prompt-string)
(lexical-let ((buffer (slime-connection-proxy-output-buffer)))
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq slime-buffer-package package)))))
(t (message "slime-proxy ignoring proxy event: %s" wrapped-event)))
(t nil)))
(t nil)))
(defun slime-proxy-initialize-macroexpansion-buffer-hook-function (buffer)
"Put the macroexpansion buffer into proxy mode."
(with-current-buffer buffer
(message "macroexpansion hook %s and continuation? %s"
(setq slime-proxy-proxy-connection
(and slime-proxy-wrapped-continuation t))))
(add-hook 'slime-event-hooks 'slime-proxy-event-hook-function)
(add-hook 'slime-initialize-macroexpansion-buffer-hook
;;; todo: on slime-net-process-close-hooks, check for proxy connection closing
(defvar slime-echo-arglist-function 'slime-show-arglist-ps)
(defun slime-show-arglist-ps ()
(let ((op (slime-operator/form-before-point)))
(when op
(slime-eval-async `(swank:operator-arglist ,op ,(slime-current-package))
(lambda (arglist)
(when arglist
(slime-message "%s" arglist)))))))
(defun slime-operator/form-before-point ()
(backward-up-list 1)
(down-list 1)
(provide 'slime-proxy)
Jump to Line
Something went wrong with that request. Please try again.