X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fserve-event.lisp;h=af166658ebad8fdf80c20d725ba65ea3483da3fc;hb=2529c316d05494f2bcdeccf98c3a6298ecd08d7d;hp=ed5c8dba48035877aa53229cc541ff1ab6225502;hpb=fe962ba01d267b92f638c8f0d19be41054219f04;p=sbcl.git

diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp
index ed5c8db..af16665 100644
--- a/src/code/serve-event.lisp
+++ b/src/code/serve-event.lisp
@@ -146,17 +146,18 @@
   "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
 :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
 up."
-  (let (usable)
-    (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
-        (decode-timeout timeout)
-      (declare (type (or integer null) to-sec to-usec))
-      (with-fd-handler (fd direction (lambda (fd)
-                                       (declare (ignore fd))
-                                       (setf usable t)))
-        (loop
+  (prog (usable)
+   :restart
+     (multiple-value-bind (to-sec to-usec stop-sec stop-usec signalp)
+         (decode-timeout timeout)
+       (declare (type (or integer null) to-sec to-usec))
+       (with-fd-handler (fd direction (lambda (fd)
+                                        (declare (ignore fd))
+                                        (setf usable t)))
+         (loop
            (sub-serve-event to-sec to-usec signalp)
            (when usable
-             (return t))
+             (return-from wait-until-fd-usable t))
            (when to-sec
              (multiple-value-bind (sec usec)
                  (decode-internal-time (get-internal-real-time))
@@ -168,8 +169,10 @@ up."
                       (setf to-usec (- stop-usec usec)))))
              (when (or (minusp to-sec) (minusp to-usec))
                (if signalp
-                   (signal-deadline)
-                   (return nil)))))))))
+                   (progn
+                     (signal-deadline)
+                     (go :restart))
+                   (return-from wait-until-fd-usable nil)))))))))
 
 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
 ;;; pending events are processed before returning.