[slime-cvs] CVS slime

[CVS User heller]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv2904

Modified Files:
	ChangeLog swank-backend.lisp swank-cmucl.lisp swank.lisp 
Log Message:
* swank-backend.lisp (slime-interrupt-queued): New condition.
* swank.lisp (invoke-or-queue-interrupt): Raise it here.
* swank-cmucl.lisp (wait-for-input): Make fd readable in condition
handler so that we can call serve-events without timeout.

--- /project/slime/cvsroot/slime/ChangeLog	2008/11/02 12:05:03	1.1579
+++ /project/slime/cvsroot/slime/ChangeLog	2008/11/02 12:05:13	1.1580
@@ -1,5 +1,12 @@
 2008-11-02  Helmut Eller  <heller at common-lisp.net>
 
+	* swank-backend.lisp (slime-interrupt-queued): New condition.
+	* swank.lisp (invoke-or-queue-interrupt): Raise it here.
+	* swank-cmucl.lisp (wait-for-input): Make fd readable in condition
+	handler so that we can call serve-events without timeout.
+
+2008-11-02  Helmut Eller  <heller at common-lisp.net>
+
 	* slime.el ([test] find-definition.2, [test] compile-defun):
 	Expect to fail for CCL.
 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2008/10/19 20:03:49	1.162
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2008/11/02 12:05:13	1.163
@@ -35,6 +35,7 @@
            ;; interrupt macro for the backend
            #:*pending-slime-interrupts*
            #:check-slime-interrupts
+           #:slime-interrupt-queued
            ;; inspector related symbols
            #:emacs-inspect
            #:label-value-line
@@ -1049,6 +1050,12 @@
     (funcall (pop *pending-slime-interrupts*))
     t))
 
+(define-condition slime-interrupt-queued () ()
+  (:documentation 
+   "Non-serious condition signalled when an interrupt
+occurs while interrupt handling is disabled.
+Backends can use this to abort blocking operations."))
+
 (definterface wait-for-input (streams &optional timeout)
   "Wait for input on a list of streams.  Return those that are ready.
 STREAMS is a list of streams
--- /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/10/17 21:26:53	1.202
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp	2008/11/02 12:05:13	1.203
@@ -198,14 +198,18 @@
    (let ((ready (remove-if-not #'listen streams)))
      (when ready (return ready)))
    (when timeout (return nil))
-   (when (check-slime-interrupts) (return :interrupt))
-   (let* (#+(or)(lisp::*descriptor-handlers* '()) ; ignore other handlers
-          (f (constantly t))
-          (handlers (loop for s in streams
-                          collect (add-one-shot-handler s f))))
-     (unwind-protect
-          (sys:serve-event 0.2)
-       (mapc #'sys:remove-fd-handler handlers)))))
+   (multiple-value-bind (in out) (make-pipe)
+     (let* ((f (constantly t))
+            (handlers (loop for s in (cons in streams)
+                            collect (add-one-shot-handler s f))))
+       (unwind-protect
+            (handler-bind ((slime-interrupt-queued 
+                            (lambda (c) c (write-char #\! out))))
+              (when (check-slime-interrupts) (return :interrupt))
+              (sys:serve-event))
+         (mapc #'sys:remove-fd-handler handlers)
+         (close in)
+         (close out))))))
 
 (defun add-one-shot-handler (stream function)
   (let (handler)
@@ -215,7 +219,10 @@
                                         (sys:remove-fd-handler handler)
                                         (funcall function stream))))))
 
-
+(defun make-pipe ()
+  (multiple-value-bind (in out) (unix:unix-pipe)
+    (values (sys:make-fd-stream in :input t :buffering :none)
+            (sys:make-fd-stream out :output t :buffering :none))))
 
 
 ;;;; Stream handling
@@ -2111,7 +2118,8 @@
              (return (car tail)))))
        (when (eq timeout t) (return (values nil t)))
        (mp:process-wait-with-timeout 
-        "receive-if" 0.5 (lambda () (some test (mailbox.queue mbox)))))))
+        "receive-if" 0.5 
+        (lambda () (some test (mailbox.queue mbox)))))))
                    
 
   ) ;; #+mp
--- /project/slime/cvsroot/slime/swank.lisp	2008/10/31 14:13:10	1.608
+++ /project/slime/cvsroot/slime/swank.lisp	2008/11/02 12:05:13	1.609
@@ -376,7 +376,8 @@
          (cond ((cdr *pending-slime-interrupts*)
                 (check-slime-interrupts))
                (t
-                (log-event "queue-interrupt: ~a" function))))))
+                (log-event "queue-interrupt: ~a" function)
+                (signal 'slime-interrupt-queued))))))
 
 (defslimefun simple-break (&optional (datum "Interrupt from Emacs") &rest args)
   (with-simple-restart (continue "Continue from break.")