[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Fri Jan 2 21:57:54 UTC 2009
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv28131
Modified Files:
ChangeLog slime.el swank.lisp
Log Message:
Experimental implementation of "channels".
The idea is to support arbitrary protocols without
changes to the low level event dispatcher.
* slime.el (slime-make-channel, slime-close-channel)
(slime-channel-send, slime-send-to-remote-channel): New functions.
(slime-define-channel-type, slime-define-channel-method): New
macros.
(slime-dispatch-event): Support channel events.
* swank.lisp (channel, listener-channel): New classes.
(channel-send, send-to-remote-channel): New functions.
(create-listener): New function. Test case for channel code.
(process-requests): Process channel events.
--- /project/slime/cvsroot/slime/ChangeLog 2009/01/02 21:57:23 1.1622
+++ /project/slime/cvsroot/slime/ChangeLog 2009/01/02 21:57:53 1.1623
@@ -15,6 +15,22 @@
2009-01-02 Helmut Eller <heller at common-lisp.net>
+ Experimental implementation of "channels".
+ The idea is to support arbitrary protocols without
+ changes to the low level event dispatcher.
+
+ * slime.el (slime-make-channel, slime-close-channel)
+ (slime-channel-send, slime-send-to-remote-channel): New functions.
+ (slime-define-channel-type, slime-define-channel-method): New
+ macros.
+ (slime-dispatch-event): Support channel events.
+ * swank.lisp (channel, listener-channel): New classes.
+ (channel-send, send-to-remote-channel): New functions.
+ (create-listener): New function. Test case for channel code.
+ (process-requests): Process channel events.
+
+(2009-01-02 Helmut Eller <heller at common-lisp.net>
+
* slime.el ([test] arglist): Guard against nil. ECL
returns nil most of the time.
--- /project/slime/cvsroot/slime/slime.el 2009/01/02 21:57:31 1.1090
+++ /project/slime/cvsroot/slime/slime.el 2009/01/02 21:57:54 1.1091
@@ -2368,6 +2368,8 @@
(slime-channel-send (or (slime-find-channel id)
(error "Invalid channel id: %S %S" id msg))
msg))
+ ((:emacs-channel-send id msg)
+ (slime-send `(:emacs-channel-send ,id ,msg)))
((:y-or-n-p thread tag question)
(slime-y-or-n-p thread tag question))
((:emacs-return-string thread tag string)
@@ -2420,6 +2422,15 @@
;;;;; Channels
+;;; A channel implements a set of operations. Those operations can be
+;;; invoked by sending messages to the channel. Channels are used for
+;;; protocols which can't be expressed naturally with RPCs, e.g. if
+;;; operations don't return a meaningful result.
+;;;
+;;; A channel can be "remote" or "local". Remote channels are
+;;; represented by integers. Local channels are structures. Messages
+;;; sent to a closed (remote) channel are ignored.
+
(slime-def-connection-var slime-channels '()
"Alist of the form (ID . CHANNEL).")
@@ -2428,13 +2439,14 @@
(defstruct (slime-channel (:conc-name slime-channel.)
(:constructor
- slime-make-channel% (operations name id)))
- operations name id)
+ slime-make-channel% (operations name id plist)))
+ operations name id plist)
(defun slime-make-channel (operations &optional name)
(let* ((id (incf (slime-channels-counter)))
- (ch (slime-make-channel% operations name id)))
- (push (cons (cons id ch) (slime-channels)))))
+ (ch (slime-make-channel% operations name id nil)))
+ (push (cons id ch) (slime-channels))
+ ch))
(defun slime-close-channel (channel)
(setf (slime-channels.operations channel) 'closed-channel)
@@ -2446,10 +2458,36 @@
(cdr (assq id (slime-channels))))
(defun slime-channel-send (channel message)
- (apply (or (cdr (assq (car message)
- (slime-channel.operations channel)))
+ (apply (or (gethash (car message) (slime-channel.operations channel))
(error "Unsupported operation: %S %S" message channel))
- (cdr message)))
+ channel (cdr message)))
+
+(defun slime-channel-put (channel prop value)
+ (setf (slime-channel.plist channel)
+ (plist-put (slime-channel.plist channel) prop value)))
+
+(defun slime-channel-get (channel prop)
+ (plist-get (slime-channel.plist channel) prop))
+
+(eval-and-compile
+ (defun slime-channel-method-table-name (type)
+ (intern (format "slime-%s-channel-methods" type))))
+
+(defmacro slime-define-channel-type (name)
+ (let ((tab (slime-channel-method-table-name name)))
+ `(progn
+ (defvar ,tab)
+ (setq ,tab (make-hash-table :size 10)))))
+
+(defmacro slime-define-channel-method (type method args &rest body)
+ `(puthash ',method
+ (lambda (self . ,args) . ,body)
+ ,(slime-channel-method-table-name type)))
+
+(put 'slime-define-channel-method 'lisp-indent-function 3)
+
+(defun slime-send-to-remote-channel (channel-id msg)
+ (slime-dispatch-event `(:emacs-channel-send ,channel-id ,msg)))
;;;;; Event logging to *slime-events*
;;;
--- /project/slime/cvsroot/slime/swank.lisp 2009/01/02 21:57:31 1.622
+++ /project/slime/cvsroot/slime/swank.lisp 2009/01/02 21:57:54 1.623
@@ -970,9 +970,14 @@
"Read and process requests from Emacs."
(loop
(multiple-value-bind (event timeout?)
- (wait-for-event `(:emacs-rex . _) timeout)
+ (wait-for-event `(or (:emacs-rex . _)
+ (:emacs-channel-send . _))
+ timeout)
(when timeout? (return))
- (apply #'eval-for-emacs (cdr event)))))
+ (destructure-case event
+ ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
+ ((:emacs-channel-send channel (selector &rest args))
+ (channel-send channel selector args))))))
(defun current-socket-io ()
(connection.socket-io *emacs-connection*))
@@ -1116,6 +1121,9 @@
(encode-message event (current-socket-io)))
(((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
(send-event (find-thread thread-id) (cons (car event) args)))
+ ((:emacs-channel-send channel-id msg)
+ (let ((ch (find-channel channel-id)))
+ (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
(((:end-of-stream))
(close-connection *emacs-connection* nil (safe-backtrace)))
((:reader-error packet condition)
@@ -1521,6 +1529,123 @@
(connection.repl-results connection) repl-results)
connection))
+
+;;; Channels
+
+(progn
+
+(defvar *channels* '())
+(defvar *channel-counter* 0)
+
+(defclass channel ()
+ ((id :reader channel-id)
+ (thread :initarg :thread :initform (current-thread) :reader channel-thread)
+ (name :initarg :name :initform nil)))
+
+(defmethod initialize-instance ((ch channel) &rest initargs)
+ (declare (ignore initargs))
+ (call-next-method)
+ (with-slots (id) ch
+ (setf id (incf *channel-counter*))
+ (push (cons id ch) *channels*)))
+
+(defmethod print-object ((c channel) stream)
+ (print-unreadable-object (c stream :type t)
+ (with-slots (id name) c
+ (format stream "~d ~a" id name))))
+
+(defun find-channel (id)
+ (cdr (assoc id *channels*)))
+
+(defgeneric channel-send (channel selector args))
+
+(defmacro define-channel-method (selector (channel &rest args) &body body)
+ `(defmethod channel-send (,channel (selector (eql ',selector)) args)
+ (destructuring-bind ,args args
+ . ,body)))
+
+(defun send-to-remote-channel (channel-id msg)
+ (send-to-emacs `(:channel-send ,channel-id ,msg)))
+
+(defclass listener-channel (channel)
+ ((remote :initarg :remote)
+ (env :initarg :env)))
+
+(defslimefun create-listener (remote)
+ (let* ((pkg *package*)
+ (conn *emacs-connection*)
+ (ch (make-instance 'listener-channel
+ :remote remote
+ :env (initial-listener-bindings remote))))
+
+ (with-slots (thread id) ch
+ (when (use-threads-p)
+ (setf thread (spawn-listener-thread ch conn)))
+ (list id
+ (thread-id thread)
+ (package-name pkg)
+ (package-string-for-prompt pkg)))))
+
+(defun initial-listener-bindings (remote)
+ `((*package* . ,*package*)
+ (*standard-output*
+ . ,(make-listener-output-stream remote))
+ (*standard-input*
+ . ,(make-listener-input-stream remote))))
+
+(defun spawn-listener-thread (channel connection)
+ (spawn (lambda ()
+ (with-connection (connection)
+ (loop
+ (destructure-case (wait-for-event `(:emacs-channel-send . _))
+ ((:emacs-channel-send c (selector &rest args))
+ (assert (eq c channel))
+ (channel-send channel selector args))))))
+ :name "swank-listener-thread"))
+
+(define-channel-method :eval ((c listener-channel) string)
+ (with-slots (remote env) c
+ (let ((aborted t))
+ (with-bindings env
+ (unwind-protect
+ (let* ((form (read-from-string string))
+ (value (eval form)))
+ (send-to-remote-channel remote
+ `(:write-result
+ ,(prin1-to-string value)))
+ (setq aborted nil))
+ (force-output)
+ (setf env (loop for (sym) in env
+ collect (cons sym (symbol-value sym))))
+ (let ((pkg (package-name *package*))
+ (prompt (package-string-for-prompt *package*)))
+ (send-to-remote-channel remote
+ (if aborted
+ `(:evaluation-aborted ,pkg ,prompt)
+ `(:prompt ,pkg ,prompt)))))))))
+
+(defun make-listener-output-stream (remote)
+ (make-output-stream (lambda (string)
+ (send-to-remote-channel remote
+ `(:write-string ,string)))))
+
+(defun make-listener-input-stream (remote)
+ (make-input-stream
+ (lambda ()
+ (force-output)
+ (let ((tag (make-tag)))
+ (send-to-remote-channel remote
+ `(: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-remote-channel remote `(:read-aborted ,tag)))))))))
+
+)
+
(defun call-with-thread-description (description thunk)
;; For `M-x slime-list-threads': Display what threads
;; created by swank are currently doing.
@@ -2206,8 +2331,8 @@
;; This is only used by the test suite.
(defun sleep-for (seconds)
- "Sleep at least SECONDS seconds.
-This is just like sleep but guarantees to sleep
+ "Sleep for at least SECONDS seconds.
+This is just like cl:sleep but guarantees to sleep
at least SECONDS."
(let* ((start (get-internal-real-time))
(end (+ start
More information about the slime-cvs
mailing list