[slime-cvs] CVS slime

[heller]

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

Modified Files:
	swank-backend.lisp swank.lisp 
Log Message:
More interrupt related frobbing.

--- /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/14 17:10:34	1.152
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2008/09/15 08:26:41	1.153
@@ -1027,14 +1027,20 @@
 (definterface receive-if (predicate &optional timeout)
   "Return the first message satisfiying PREDICATE.")
 
-(defvar *pending-slime-interrupts* '())
+;; List of delayed interrupts.  
+;; This should only have thread-local bindings, so no init form.
+(defvar *pending-slime-interrupts*)
 
-(defun check-slime-interrupts ()
+(defun check-slime-interrupts (&optional test-only)
   "Execute pending interrupts if any.
 This should be called periodically in operations which
-can take a long time to complete."
-  (when (and *pending-slime-interrupts*)
-    (funcall (pop *pending-slime-interrupts*))))
+can take a long time to complete.
+Return a boolean indicating whether any interrupts are queued."
+  (when (and (boundp '*pending-slime-interrupts*)
+             *pending-slime-interrupts*)
+    (unless test-only
+      (funcall (pop *pending-slime-interrupts*)))
+    t))
 
 (definterface wait-for-input (streams &optional timeout)
   "Wait for input on a list of streams.  Return those that are ready.
--- /project/slime/cvsroot/slime/swank.lisp	2008/09/14 17:10:34	1.587
+++ /project/slime/cvsroot/slime/swank.lisp	2008/09/15 08:26:41	1.588
@@ -340,23 +340,23 @@
 
 ;;;;; Helper macros
 
+;; If true execute interrupts, otherwise queue them.
+;; Note: `with-connection' binds *pending-slime-interrupts*.
 (defvar *slime-interrupts-enabled*)
 
-(defmacro with-slime-interrupts (&body body)
+(defmacro with-interrupts-enabled% (flag body)
   `(progn
      (check-slime-interrupts)
      (multiple-value-prog1
-         (let ((*slime-interrupts-enabled* t))
+         (let ((*slime-interrupts-enabled* ,flag))
            , at body)
        (check-slime-interrupts))))
 
+(defmacro with-slime-interrupts (&body body)
+  `(with-interrupts-enabled% t ,body))
+
 (defmacro without-slime-interrupts (&body body)
-  `(progn
-     (check-slime-interrupts)
-     (multiple-value-prog1
-         (let ((*slime-interrupts-enabled* t))
-           , at body)
-       (check-slime-interrupts))))
+  `(with-interrupts-enabled% nil ,body))
 
 (defun invoke-or-queue-interrupt (function)
   (log-event "invoke-or-queue-interrupt: ~a" function)
@@ -401,7 +401,8 @@
 (defun call-with-connection (connection function)
   (if (eq *emacs-connection* connection)
       (funcall function)
-      (let ((*emacs-connection* connection))
+      (let ((*emacs-connection* connection)
+            (*pending-slime-interrupts* '()))
         (without-slime-interrupts
           (with-swank-error-handler (*emacs-connection*)
             (with-io-redirection (*emacs-connection*)
@@ -946,8 +947,9 @@
 (defun process-requests (timeout just-one)
   "Read and process requests from Emacs."
   (loop
-   (multiple-value-bind (event timeout?)
-       (wait-for-event `(:emacs-rex . _) timeout)
+   (multiple-value-bind (event timeout? interrupt?)
+       (wait-for-event `(:emacs-rex . _) timeout just-one)
+     (when interrupt? (return nil))
      (when timeout? (return t))
      (apply #'eval-for-emacs (cdr event))
      (when just-one (return nil)))))
@@ -1117,18 +1119,21 @@
   (cond ((use-threads-p) (interrupt-thread thread interrupt))
         (t (funcall interrupt))))
 
-(defun wait-for-event (pattern &optional timeout)
+(defun wait-for-event (pattern &optional timeout report-interrupts)
   (log-event "wait-for-event: ~s ~s~%" pattern timeout)
   (without-slime-interrupts
     (cond ((use-threads-p) 
            (receive-if (lambda (e) (event-match-p e pattern)) timeout))
           (t 
-           (wait-for-event/event-loop pattern timeout)))))
+           (wait-for-event/event-loop pattern timeout report-interrupts)))))
 
-(defun wait-for-event/event-loop (pattern timeout)
+(defun wait-for-event/event-loop (pattern timeout report-interrupts)
   (assert (or (not timeout) (eq timeout t)))
   (loop 
-   (check-slime-interrupts)
+   (when *pending-slime-interrupts*
+     (check-slime-interrupts)
+     (when report-interrupts (return (values nil nil t)))
+     (when timeout (return (values nil t))))
    (let ((event (poll-for-event pattern)))
      (when event (return (car event))))
    (let ((events-enqueued *events-enqueued*)