diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 14c8006b51..010211efa7 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/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 () diff --git a/collects/scribblings/reference/evts.scrbl b/collects/scribblings/reference/evts.scrbl index 577d3ce52f..6bf42c9f5f 100644 --- a/collects/scribblings/reference/evts.scrbl +++ b/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?]{ diff --git a/collects/tests/racket/sync.rktl b/collects/tests/racket/sync.rktl index 252c1cb318..9e3be0df1b 100644 --- a/collects/tests/racket/sync.rktl +++ b/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))) diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index c11e8f4a20..ad0cb3cb30 100644 --- a/src/racket/src/thread.c +++ b/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[])