Improve channel teardown for sly-mrepl

* sly.el (sly-dispatch-event): Group channel-related
events. Accept new `:invalid-channel' event.
(sly-close-channel): Improve error message.

* swank.lisp (:swank): Export SWANK:STOP-PROCESSING symbol.
(process-requests): Catch SWANK:STOP-PROCESSING tag.
(thread-for-evaluation): Shoosh compilers.
(dispatch-event): Handle invalid channels.
(close-channel): New function.
(channel-send): Document generic.

* contrib/sly-mrepl.el (sly-mrepl-mode): Don't add to `kill-buffer-hook' here.
(sly-mrepl-new): Rather here when we're sure to have a remote channel.
(sly-mrepl--delete-process): Delete it.
(sly-mrepl--teardown): Delete process, teardown remote, close local.

* contrib/swank-mrepl.lisp (:compile-toplevel): import SWANK:CLOSE-CHANNEL
and SWANK:STOP-PROCESSING.
(listener-channel): Use accessors.
(initialize-instance): Fix whitespace.
(create-mrepl): Give channel a name
(drop-unprocessed-events): Add docstring.
(spawn-listener-thread): Learn to teardown thread.
(:teardown): New channel method.
(mrepl-eval): Rewrite env-setting for clarity.

contrib/sly-mrepl.el

@@ -22,7 +22,6 @@
 (defvar sly-mrepl-expect-sexp nil)
 
 (define-derived-mode sly-mrepl-mode comint-mode "mrepl"
-  (add-hook 'kill-buffer-hook 'sly-mrepl--delete-process nil 'local)
   (set (make-local-variable 'comint-use-prompt-regexp) nil)
   (set (make-local-variable 'comint-inhibit-carriage-motion) t)
   (set (make-local-variable 'comint-input-sender) 'sly-mrepl-input-sender)
@@ -54,6 +53,7 @@
                                              (sly-channel.id local)
                                              remote
                                              thread-id))
+            (add-hook 'kill-buffer-hook 'sly-mrepl--teardown nil 'local)
             (setq sly-current-thread thread-id)
             (setq sly-buffer-connection (sly-connection))
             (set (make-local-variable 'sly-mrepl-remote-channel) remote)
@@ -71,7 +71,10 @@
 
 (defun sly-mrepl--process () (get-buffer-process (current-buffer))) ;stupid
 (defun sly-mrepl--mark () (process-mark (sly-mrepl--process)))
-(defun sly-mrepl--delete-process () (delete-process (sly-mrepl--process)))
+(defun sly-mrepl--teardown ()
+  (delete-process (sly-mrepl--process))
+  (sly-mrepl-send `(:teardown))
+  (sly-close-channel sly-mrepl-local-channel))
 
 (defun sly-mrepl-insert (string)
   (comint-output-filter (sly-mrepl--process) string))
@@ -148,8 +151,6 @@
   "Send MSG to the remote channel."
   (sly-send-to-remote-channel sly-mrepl-remote-channel msg))
 
-
-
 (defun sly-mrepl ()
   (interactive)
   (let ((conn (sly-connection)))
@@ -160,6 +161,8 @@
                     (buffer-list))
         (sly-mrepl-new))))
 
+
+
 (def-sly-selector-method ?m
   "First mrepl-buffer"
   (or (sly-mrepl)

contrib/swank-mrepl.lisp

@@ -9,6 +9,7 @@
 	       channel 
 	       channel-id
                channel-thread
+               close-channel
 	       define-channel-method
 	       defslyfun 
 	       destructure-case
@@ -21,6 +22,7 @@
 	       with-connection
 	       with-top-level-restart
 	       with-sly-interrupts
+               stop-processing
 	       )))
     (eval `(defpackage #:swank-api
 	     (:use)
@@ -34,12 +36,13 @@
 (in-package :swank-mrepl)
 
 (defclass listener-channel (channel)
-  ((remote :initarg :remote)
-   (env :initarg :env)
-   (mode :initform :eval)
-   (tag :initform nil)))
+  ((remote :initarg  :remote :accessor remote)
+   (env    :initarg  :env    :accessor env)
+   (mode   :initform :eval   :accessor channel-mode)
+   (tag    :initform nil)))
 
-(defmethod initialize-instance :after ((channel listener-channel) &rest initargs)
+(defmethod initialize-instance :after ((channel listener-channel)
+                                       &rest initargs)
   ;; FIXME: fugly, but I need this to be able to name the thread
   ;; according to the channel.
   (setf (slot-value channel 'swank::thread)
@@ -53,7 +56,10 @@
 
 (defslyfun create-mrepl (remote)
   (let* ((pkg *package*)
-         (ch (make-instance 'listener-channel :remote remote :thread nil))
+         (ch (make-instance
+              'listener-channel
+              :remote remote :thread nil
+              :name (format nil "mrepl listener for remote ~a" remote)))
          (thread (channel-thread ch)))
     (setf (slot-value ch 'env) (initial-listener-env ch))
     (when thread
@@ -72,6 +78,7 @@
     (+) (++) (+++)))
 
 (defun drop-unprocessed-events (channel)
+  "Empty CHANNEL of events, then send prompt to Emacs."
   (with-slots (mode) channel
     (let ((old-mode mode))
       (setf mode :drop)
@@ -90,7 +97,9 @@
           (assert (eq c channel))
 	  (loop
 	   (with-top-level-restart (connection (drop-unprocessed-events channel))
-	     (process-requests nil)))))))
+	     (when (eq (process-requests nil)
+                       'listener-teardown)
+               (return))))))))
    :name (format nil "sly-mrepl-listener-ch-~a" (channel-id channel))))
 
 (define-channel-method :process ((c listener-channel) string)
@@ -101,6 +110,11 @@
       (:read (mrepl-read c string))
       (:drop))))
 
+(define-channel-method :teardown ((c listener-channel))
+  (log-event ":teardown~%")
+  (close-channel c)
+  (throw 'stop-processing 'listener-teardown))
+
 (defun mrepl-eval (channel string)
   (with-slots (remote env) channel
     (let ((aborted t))
@@ -113,8 +127,8 @@
             (setq *** **  ** *  * (car /)
                   /// //  // /  
                   +++ ++  ++ + ))
-	  (setf env (loop for (sym) in env
-			  collect (cons sym (symbol-value sym))))
+          (loop for binding in env 
+                do (setf (cdr binding) (symbol-value (car binding))))
 	  (cond (aborted
 		 (send-to-remote-channel remote `(:evaluation-aborted)))
 		(t
@@ -128,7 +142,7 @@
       (when out (force-output out))
       (when in (clear-input in))
       (send-to-remote-channel remote `(:prompt ,(package-name pkg)
-					       ,(package-prompt pkg))))))
+                                               ,(package-prompt pkg))))))
   
 (defun mrepl-read (channel string)
   (with-slots (tag) channel

sly.el

@@ -2181,15 +2181,9 @@ Debugged requests are ignored."
            (sldb-exit thread level stepping))
           ((:emacs-interrupt thread)
            (sly-send `(:emacs-interrupt ,thread)))
-          ((:channel-send id msg)
-           (sly-channel-send (or (sly-find-channel id)
-                                   (error "Invalid channel id: %S %S" id msg))
-                               msg))
-          ((:emacs-channel-send id msg)
-           (sly-send `(:emacs-channel-send ,id ,msg)))
           ((:read-from-minibuffer thread tag prompt initial-value)
            (sly-read-from-minibuffer-for-swank thread tag prompt
-                                                 initial-value))
+                                               initial-value))
           ((:y-or-n-p thread tag question)
            (sly-y-or-n-p thread tag question))
           ((:emacs-return-string thread tag string)
@@ -2211,7 +2205,7 @@ Debugged requests are ignored."
           ((:inspect what thread tag)
            (let ((hook (when (and thread tag)
                          (sly-curry #'sly-send
-                                      `(:emacs-return ,thread ,tag nil)))))
+                                    `(:emacs-return ,thread ,tag nil)))))
              (sly-open-inspector what nil hook)))
           ((:background-message message)
            (sly-background-message "%s" message))
@@ -2232,7 +2226,15 @@ Debugged requests are ignored."
            (error "Invalid rpc: %s" message))
           ((:emacs-skipped-packet _pkg))
           ((:test-delay seconds) ; for testing only
-           (sit-for seconds))))))
+           (sit-for seconds))
+          ((:channel-send id msg)
+           (sly-channel-send (or (sly-find-channel id)
+                                 (error "Invalid channel id: %S %S" id msg))
+                             msg))
+          ((:emacs-channel-send id msg)
+           (sly-send `(:emacs-channel-send ,id ,msg)))
+          ((:invalid-channel channel-id reason)
+           (error "Invalid remote channel %d: %s" channel-id reason))))))
 
 (defun sly-send (sexp)
   "Send SEXP directly over the wire on the current connection."
@@ -2282,7 +2284,7 @@ Debugged requests are ignored."
   (setf (sly-channel.operations channel) 'closed-channel)
   (let ((probe (assq (sly-channel.id channel) (sly-channels))))
     (cond (probe (setf (sly-channels) (delete probe (sly-channels))))
-          (t (error "Invalid channel: %s" channel)))))
+          (t (error "Can't close invalid channel: %s" channel)))))
 
 (defun sly-find-channel (id)
   (cdr (assq id (sly-channels))))

swank.lisp

@@ -24,7 +24,7 @@
            #:swank-debugger-hook
            #:emacs-inspect
            ;;#:inspect-slot-for-emacs
-           )
+           #:stop-processing)
   ;; These are user-configurable variables:
   (:export #:*communication-style*
            #:*dont-close*
@@ -930,16 +930,17 @@ The processing is done in the extent of the toplevel restart."
 
 (defun process-requests (timeout)
   "Read and process requests from Emacs."
-  (loop
-   (multiple-value-bind (event timeout?)
-       (wait-for-event `(or (:emacs-rex . _)
-                            (:emacs-channel-send . _))
-                       timeout)
-    (when timeout? (return))
-    (destructure-case event
-      ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
-      ((:emacs-channel-send channel (selector &rest args))
-       (channel-send channel selector args))))))
+  (catch 'stop-processing
+    (loop
+      (multiple-value-bind (event timeout?)
+          (wait-for-event `(or (:emacs-rex . _)
+                               (:emacs-channel-send . _))
+                          timeout)
+        (when timeout? (return))
+        (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*))
@@ -1008,8 +1009,10 @@ The processing is done in the extent of the toplevel restart."
   (:method ((connection multithreaded-connection) (id (eql :find-existing)))
     (car (mconn.active-threads connection)))
   (:method (connection (id integer))
+    (declare (ignore connection))
     (find-thread id))
   (:method ((connection singlethreaded-connection) id)
+    (declare (ignore id))
     (current-thread)))
 
 (defun interrupt-worker-thread (connection id)
@@ -1084,7 +1087,12 @@ The processing is done in the extent of the toplevel restart."
      (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))))
+       (cond (ch
+              (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg)))
+             (t
+              (encode-message 
+               (list :invalid-channel channel-id "Channel not found")
+               (current-socket-io))))))
     ((:reader-error packet condition)
      (encode-message `(:reader-error ,packet 
                                      ,(safe-condition-message condition))
@@ -1342,14 +1350,14 @@ event was found."
 (defvar *channel-counter* 0)
 
 (defclass channel ()
-  ((id :reader channel-id)
-   (thread :initarg :thread :initform (current-thread) :reader channel-thread)
-   (name :initarg :name :initform nil)))
+  ((id     :initform (incf *channel-counter*)
+           :reader channel-id)
+   (thread :initarg :thread :initform (current-thread)
+           :reader channel-thread)
+   (name   :initarg :name   :initform nil)))
 
 (defmethod initialize-instance :after ((ch channel) &key)
-  (with-slots (id) ch
-    (setf id (incf *channel-counter*))
-    (push (cons id ch) *channels*)))
+  (push (cons (channel-id ch) ch) *channels*))
 
 (defmethod print-object ((c channel) stream)
   (print-unreadable-object (c stream :type t)
@@ -1359,7 +1367,13 @@ event was found."
 (defun find-channel (id)
   (cdr (assoc id *channels*)))
 
-(defgeneric channel-send (channel selector args))
+(defun close-channel (channel)
+  (let ((probe (assoc (channel-id channel) *channels*)))
+    (cond (probe (setf *channels* (delete probe *channels*)))
+          (t (error "Can't close invalid channel: ~a" channel)))))
+
+(defgeneric channel-send (channel selector args)
+  (:documentation "Send to CHANNEL the message SELECTOR with ARGS."))
 
 (defmacro define-channel-method (selector (channel &rest args) &body body)
   `(defmethod channel-send (,channel (selector (eql ',selector)) args)