1.0.12.6: Removing UNIX-NAMESTRING, part 1

[sbcl.git] / src / code / serve-event.lisp

diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp
index ed5c8db..af16665 100644 (file)
--- 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)))))))))
 \f
 ;;; Wait for up to timeout seconds for an event to happen. Make sure all
 ;;; pending events are processed before returning.