extend `sync/timeout' to allow a tail-position fail thunk for polling

collects/mred/private/wx/common/queue.rkt

@@ -399,20 +399,22 @@
        [(and (eq? evt 'wait)
              (not handler?))
         #t]
-       ;; `yield' is supposed to return immediately if the
-       ;; event is already ready:
-       [(and (evt? evt) (sync/timeout 0 (wrap-evt evt (lambda (v) (list v)))))
-        => (lambda (v) (car v))]
-       [handler?
-        (sync (if (eq? evt 'wait) 
-                  (wrap-evt e (lambda (_) #t))
-                  evt)
-              (handle-evt ((eventspace-queue-proc e))
-                          (lambda (v)
-                            (when v (handle-event v))
-                            (yield evt))))]
        [else
-        (sync evt)]))]))
+        (define (wait-now)
+          (if handler?
+              (sync (if (eq? evt 'wait) 
+                        (wrap-evt e (lambda (_) #t))
+                        evt)
+                    (handle-evt ((eventspace-queue-proc e))
+                                (lambda (v)
+                                  (when v (handle-event v))
+                                  (yield evt))))
+              (sync evt)))
+        (if (evt? evt)
+            ;; `yield' is supposed to return immediately if the
+            ;; event is already ready:
+            (sync/timeout wait-now evt)
+            (wait-now))]))]))
 
 (define yield-refresh
   (lambda ()

collects/scribblings/reference/evts.scrbl

@@ -207,17 +207,20 @@ pseudo-randomly for the result; the
 random-number generator that controls this choice.}
 
 
-@defproc[(sync/timeout [timeout-secs (or/c nonnegative-number? #f)]
+@defproc[(sync/timeout [timeout (or/c #f (and/c real? (not/c negative?)) (-> any))]
                        [evt evt?] ...+) 
           any]{
 
-Like @racket[sync], but returns @racket[#f] if @racket[timeout-secs]
-is not @racket[#f] and if @racket[timeout-secs] seconds pass without a
-successful synchronization.
+Like @racket[sync] if @racket[timeout] is @racket[#f]. If
+@racket[timeout] is a real number, then the result is @racket[#f]
+if @racket[timeout] seconds pass without a
+successful synchronization. If @racket[timeout] is a procedure, then
+it is called in tail position if polling the @racket[evt]s discovers
+no ready events.
 
-If @racket[timeout-secs] is @racket[0], each @racket[evt] is checked
-at least once before returning @racket[#f], so a @racket[timeout-secs] 
-value of @racket[0] can be used for polling.
+A zero value for @racket[timeout] is equivalent to @racket[(lambda ()
+#f)]. In either case, each @racket[evt] is checked at least once
+before returning @racket[#f] or calling @racket[timeout].
 
 See also @racket[alarm-evt] for an alternative timeout mechanism.}
 
@@ -231,12 +234,11 @@ either all @racket[evt]s remain unchosen or the @racket[exn:break]
 exception is raised, but not both.}
 
 
-@defproc[(sync/timeout/enable-break [timeout-secs (or/c nonnegative-number? #f)]
+@defproc[(sync/timeout/enable-break [timeout (or/c #f (and/c real? (not/c negative?)) (-> any))]
                                     [evt evt?] ...+) 
          any]{
 
-Like @racket[sync/enable-break], but with a timeout in seconds (or
-@racket[#f]), as for @racket[sync/timeout].}
+Like @racket[sync/enable-break], but with a timeout as for @racket[sync/timeout].}
 
 
 @defproc[(choice-evt [evt evt?] ...) evt?]{

collects/tests/racket/sync.rktl

@@ -15,6 +15,7 @@
        [ch (make-channel)])
   (test #f sync/timeout 0 s p)
   (test #f sync/timeout 0 s p)
+  (test 'nope sync/timeout (lambda () 'nope) s p)
   (semaphore-post s)
   (test p sync/timeout 0 p)
   (test p sync p)
@@ -23,6 +24,7 @@
   (thread (lambda () (sync (system-idle-evt)) (semaphore-post s)))
   (test p sync p)
   (test p sync p)
+  (test p sync/timeout (lambda () 'nope) p)
   (test s sync s)
   (test #f sync/timeout 0 p)
   (thread (lambda () (sync/timeout 0 p) (channel-put ch 7)))

src/racket/src/thread.c

@@ -5993,6 +5993,8 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[],
     if (!SCHEME_FALSEP(argv[0])) {
       if (SCHEME_REALP(argv[0]))
 	timeout = (float)scheme_real_to_double(argv[0]);
+      else if (scheme_check_proc_arity(NULL, 0, 0, argc, argv))
+        timeout = 0.0;
       
       if (timeout < 0.0) {
 	scheme_wrong_type(name, "non-negative real number", 0, argc, argv);
@@ -6151,10 +6153,17 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[],
       }
     }
     return o;
-  } else if (tailok)
-    return scheme_false;
-  else
-    return NULL;
+  } else {
+    if (with_timeout && SCHEME_PROCP(argv[0])) {
+      if (tailok)
+        return _scheme_tail_apply(argv[0], 0, NULL);
+      else
+        return _scheme_apply(argv[0], 0, NULL);
+    } else if (tailok)
+      return scheme_false;
+    else
+      return NULL;
+  }
 }
 
 static Scheme_Object *sch_sync(int argc, Scheme_Object *argv[])