[slime-cvs] CVS slime

[heller]

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv16851

Modified Files:
	ChangeLog swank.lisp 
Log Message:
Stop handling events in worker threads after sldb-quit.

* swank.lisp (with-top-level-restart): New macro.
(handle-requests, spawn-worker-thread): Use it.
(process-requests): Drop the just-one argument.
(handle-or-process-requests): Deleted. Call handle-requests
directly.

--- /project/slime/cvsroot/slime/ChangeLog	2008/09/26 23:14:10	1.1545
+++ /project/slime/cvsroot/slime/ChangeLog	2008/09/28 09:39:31	1.1546
@@ -1,3 +1,13 @@
+2008-09-28  Helmut Eller  <heller at common-lisp.net>
+
+	Stop handling events in worker threads after sldb-quit.
+
+	* swank.lisp (with-top-level-restart): New macro.
+	(handle-requests, spawn-worker-thread): Use it.
+	(process-requests): Drop the just-one argument.
+	(handle-or-process-requests): Deleted. Call handle-requests
+	directly.
+
 2008-09-27  Tobias C. Rittweiler  <tcr at freebits.de>
 
 	Improve ECL's arglist support somewhat.
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/23 04:57:51	1.596
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/28 09:39:31	1.597
@@ -934,31 +934,42 @@
       (when socket
         (close-socket socket)))))
 
-(defvar *sldb-quit-restart* 'abort
-  "What restart should swank attempt to invoke when the user sldb-quits.")
+;; The restart that will be invoked when the user calls sldb-quit.
+;; This restart will be named "abort" because many people press "a"
+;; instead of "q" in the debugger.
+(defvar *sldb-quit-restart*)
+
+;; Establish a top-level restart and execute BODY.
+;; Execute K if the restart is invoked.
+(defmacro with-top-level-restart ((connection k) &body body)
+  `(with-connection (,connection)
+     (restart-case 
+         (let ((*sldb-quit-restart* (find-restart 'abort)))
+           . ,body)
+       (abort (&optional v)
+         :report "Return to SLIME's top level."
+         (declare (ignore v))
+         (force-user-output)
+         ,k))))
 
-(defun handle-requests (connection &optional timeout just-one)
-  "Read and process requests.  
+(defun handle-requests (connection &optional timeout)
+  "Read and process :emacs-rex requests.
 The processing is done in the extent of the toplevel restart."
-  (assert (null *swank-state-stack*))
-  (let ((*swank-state-stack* '(:handle-request)))
-    (with-connection (connection)
-      (loop 
-       (with-simple-restart (abort "Return to SLIME's top level.")
-         (let* ((*sldb-quit-restart* (find-restart 'abort))
-                (timeout? (process-requests timeout just-one)))
-           (when (or just-one timeout?) 
-             (return))))
-       (force-user-output)))))
+  (cond ((boundp '*sldb-quit-restart*)
+         (process-requests timeout))
+        (t 
+         (tagbody
+            start
+            (with-top-level-restart (connection (go start))
+              (process-requests timeout))))))
 
-(defun process-requests (timeout just-one)
+(defun process-requests (timeout)
   "Read and process requests from Emacs."
   (loop
    (multiple-value-bind (event timeout?)
        (wait-for-event `(:emacs-rex . _) timeout)
-     (when timeout? (return t))
-     (apply #'eval-for-emacs (cdr event))
-     (when just-one (return nil)))))
+    (when timeout? (return))
+    (apply #'eval-for-emacs (cdr event)))))
 
 (defun current-socket-io ()
   (connection.socket-io *emacs-connection*))
@@ -1061,7 +1072,9 @@
 (defun spawn-worker-thread (connection)
   (spawn (lambda () 
            (with-bindings *default-worker-thread-bindings*
-             (handle-requests connection nil t)))
+             (with-top-level-restart (connection nil)
+               (apply #'eval-for-emacs 
+                      (cdr (wait-for-event `(:emacs-rex . _)))))))
          :name "worker"))
 
 (defun spawn-repl-thread (connection name)
@@ -1204,7 +1217,7 @@
 (defun install-sigio-handler (connection)
   (add-sigio-handler (connection.socket-io connection) 
                      (lambda () (process-io-interrupt connection)))
-  (handle-or-process-requests connection))
+  (handle-requests connection t))
 
 (defvar *io-interupt-level* 0)
 
@@ -1212,16 +1225,9 @@
   (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
   (let ((*io-interupt-level* (1+ *io-interupt-level*)))
     (invoke-or-queue-interrupt
-     (lambda () (handle-or-process-requests connection))))
+     (lambda () (handle-requests connection t))))
   (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
 
-(defun handle-or-process-requests (connection)
-  (log-event "handle-or-process-requests: ~a~%" *swank-state-stack*)
-  (cond ((null *swank-state-stack*)
-         (handle-requests connection t))
-        ((eq (car *swank-state-stack*) :read-next-form))
-        (t (process-requests t nil))))
-
 (defun deinstall-sigio-handler (connection)
   (log-event "deinstall-sigio-handler...~%")
   (remove-sigio-handlers (connection.socket-io connection))
@@ -1231,7 +1237,7 @@
 
 (defun install-fd-handler (connection)
   (add-fd-handler (connection.socket-io connection)
-                  (lambda () (handle-or-process-requests connection)))
+                  (lambda () (handle-requests connection t)))
   (setf (connection.saved-sigint-handler connection)
         (install-sigint-handler 
          (lambda () 
@@ -1239,7 +1245,7 @@
             (lambda () 
               (with-connection (connection)
                 (dispatch-interrupt-event)))))))
-  (handle-or-process-requests connection))
+  (handle-requests connection t))
 
 (defun dispatch-interrupt-event ()
   (dispatch-event `(:emacs-interrupt ,(current-thread-id))))