[nongnu] elpa/slime 5006caa5b4 3/3: Catch interrupts only around wait-for-event.

[ELPA Syncer]

branch: elpa/slime
commit 5006caa5b44665b53431ece0baa298f2ffc521eb
Author: Stas Boukarev <stassats@gmail.com>
Commit: Stas Boukarev <stassats@gmail.com>

    Catch interrupts only around wait-for-event.
---
 contrib/swank-repl.lisp | 21 +++++----------------
 swank.lisp              | 42 ++++++++++++++++++++++++++++--------------
 2 files changed, 33 insertions(+), 30 deletions(-)

diff --git a/contrib/swank-repl.lisp b/contrib/swank-repl.lisp
index c1380001c1..49578842f2 100644
--- a/contrib/swank-repl.lisp
+++ b/contrib/swank-repl.lisp
@@ -144,22 +144,11 @@ INPUT OUTPUT IO REPL-RESULTS"
 
 (defun repl-loop (connection)
   (unwind-protect
-       (prog (interruption)
-        again
-          (call-with-interrupt-handler
-           (lambda (interrupt-function)
-             (with-connection (connection)
-               (send-to-emacs `(:new-repl-output)))
-             (format t "Invoking an interrupt ~s~%" interrupt-function)
-             (setf interruption interrupt-function)
-             (go interrupt))
-           (lambda ()
-             (return 
-               (handle-requests connection))))
-        interrupt
-          (let ((*slime-interrupts-enabled* t))
-            (funcall interruption))
-          (go again))
+       (handle-requests connection nil
+                        (lambda (interrupt-function)
+                          (with-connection (connection)
+                            (send-to-emacs `(:new-repl-output)))
+                          (format t "Invoking an interrupt ~s~%" 
interrupt-function)))
     (when (typep connection 'multithreaded-connection)
       (setf (mconn.repl-thread connection)
             'aborted))))
diff --git a/swank.lisp b/swank.lisp
index 6263f24c66..eef774a7a5 100644
--- a/swank.lisp
+++ b/swank.lisp
@@ -836,30 +836,44 @@ if the file doesn't exist; otherwise the first line of 
the file."
          (force-user-output)
          ,k))))
 
-(defun handle-requests (connection &optional timeout)
+(defun handle-requests (connection &optional timeout interrupt-handler)
   "Read and process :emacs-rex requests.
 The processing is done in the extent of the toplevel restart."
   (with-connection (connection)
     (cond (*sldb-quit-restart*
-           (process-requests timeout))
+           (process-requests timeout interrupt-handler))
           (t
            (tagbody
             start
               (with-top-level-restart (connection (go start))
-                (process-requests timeout)))))))
+                (process-requests timeout interrupt-handler)))))))
 
-(defun process-requests (timeout)
+(defun process-requests (timeout &optional interrupt-handler)
   "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))
-     (dcase event
-       ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
-       ((:emacs-channel-send channel (selector &rest args))
-        (channel-send channel selector args))))))
+  (prog (interruption)
+   again
+     (multiple-value-bind (event timeout?)
+         (call-with-interrupt-handler
+          (lambda (interrupt-function)
+            (when interrupt-handler
+              (funcall interrupt-handler interrupt-function))
+            (setf interruption interrupt-function)
+            (go interrupt))
+          (lambda ()
+            (wait-for-event `(or (:emacs-rex . _)
+                                 (:emacs-channel-send . _))
+                            timeout)))
+       
+       (when timeout? (return))
+       (dcase event
+         ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
+         ((:emacs-channel-send channel (selector &rest args))
+          (channel-send channel selector args))))
+     (go again)
+   interrupt
+     (let ((*slime-interrupts-enabled* t))
+       (funcall interruption))
+     (go again)))
 
 (defun current-socket-io ()
   (connection.socket-io *emacs-connection*))