diff --git a/collects/scribblings/reference/evts.scrbl b/collects/scribblings/reference/evts.scrbl index 29624de12d..671e58c8ac 100644 --- a/collects/scribblings/reference/evts.scrbl +++ b/collects/scribblings/reference/evts.scrbl @@ -102,13 +102,15 @@ pseudo-randomly, and the @tech{synchronization result} is the chosen @defproc[(wrap-evt [evt (and/c evt? (not/c handle-evt?))] - [wrap (any/c . -> . any)]) + [wrap (any/c ... . -> . any)]) evt?]{ Creates an event that is @tech{ready for synchronization} when @racket[evt] is @tech{ready for synchronization}, but whose @tech{synchronization result} is determined by applying @racket[wrap] -to the @tech{synchronization result} of @racket[evt]. +to the @tech{synchronization result} of @racket[evt]. The number +of arguments accetped by @racket[wrap] must match the number of values +for the synchronization result of @racket[evt]. The call to @racket[wrap] is @racket[parameterize-break]ed to disable breaks initially. The @@ -118,7 +120,7 @@ combination of @racket[choice-evt] involving an event from @defproc[(handle-evt [evt (and/c evt? (not/c handle-evt?))] - [handle (any/c . -> . any)]) + [handle (any/c ... . -> . any)]) handle-evt?]{ Like @racket[wrap], except that @racket[handle] is called in @tech{tail diff --git a/collects/tests/racket/sync.rktl b/collects/tests/racket/sync.rktl index c879e71856..d484c5866d 100644 --- a/collects/tests/racket/sync.rktl +++ b/collects/tests/racket/sync.rktl @@ -248,12 +248,11 @@ (err/rt-test (wrap-evt 1 void)) (err/rt-test (wrap-evt (make-semaphore) 10)) -(err/rt-test (wrap-evt (make-semaphore) (lambda () 10))) (test 17 sync (wrap-evt (make-semaphore 1) (lambda (sema) 17))) (test 17 sync (choice-evt - (make-semaphore) - (wrap-evt (make-semaphore 1) (lambda (sema) 17)))) + (make-semaphore) + (wrap-evt (make-semaphore 1) (lambda (sema) 17)))) (test #t sync (wrap-evt (make-semaphore 1) semaphore?)) (test 18 'sync (let ([n 17] @@ -275,12 +274,27 @@ (wrap-evt (choice-evt (make-semaphore 1) (make-semaphore 1)) (lambda (x) 78))) +(test-values '() (lambda () (sync (wrap-evt always-evt (lambda (x) (values)))))) +(test-values '(1 2) (lambda () (sync (wrap-evt always-evt (lambda (x) (values 1 2)))))) +(test-values '(1 2 3) (lambda () (sync (wrap-evt (wrap-evt always-evt + (lambda (_) (values 1 2))) + (lambda (a b) (values a b 3)))))) + +(err/rt-test (sync (wrap-evt always-evt (lambda () #f)))) +(err/rt-test (sync (wrap-evt always-evt (lambda (a b) #f)))) + ;; ---------------------------------------- ;; handle evt (test 10 sync (handle-evt always-evt (lambda (x) 10))) (test 11 sync (handle-evt (wrap-evt always-evt (lambda (x) 10)) add1)) (test-values '(1 2) (lambda () (sync (handle-evt always-evt (lambda (x) (values 1 2)))))) +(test-values '(1 2 3) (lambda () (sync (handle-evt (wrap-evt always-evt + (lambda (_) (values 1 2))) + (lambda (a b) (values a b 3)))))) +(err/rt-test (sync (handle-evt always-evt (lambda () #f)))) +(err/rt-test (sync (handle-evt always-evt (lambda (a b) #f)))) + ;; check tail call via loop: (test 'ok sync (let loop ([n 1000000]) (if (zero? n) @@ -517,6 +531,12 @@ (test-wt make-wt) (test-wt make-wt2)) +;; Test with multiple values +(let ([wt-v (make-wt #f (lambda (_) (wrap-evt always-evt (lambda (_) (values 1 2)))))] + [wt-fail (make-wt #f (lambda (_) (wrap-evt always-evt (lambda () #f))))]) + (test-values '(1 2) (lambda () (sync wt-v))) + (err/rt-test (sync wt-fail))) + ;; Check whether something that takes at least SYNC-SLEEP-DELAY ;; seconds in fact takes roughly that much CPU time. We ;; expect non-busy-wait takes to take a very small fraction diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index b7a310f009..35d5b06285 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,3 +1,7 @@ +Version 5.3.3.1 +Change sync, wrap-evt, and handle-evt to support multiple + evt results + Version 5.3.2.3 Added extflonums racket/extflonum: added diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index a3f8ef8055..55e00f2076 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -3262,7 +3262,9 @@ static Scheme_Object *wrap_evt(const char *who, int wrap, int argc, Scheme_Objec if (!scheme_is_evt(argv[0]) || handle_evt_p(0, argv)) scheme_wrong_contract(who, "(and/c evt? (not/c handle-evt?))", 0, argc, argv); - scheme_check_proc_arity(who, 1, 1, argc, argv); + + if (!SCHEME_PROCP(argv[1])) + scheme_wrong_contract(who, "procedure?", 1, argc, argv); ww = MALLOC_ONE_TAGGED(Wrapped_Evt); ww->so.type = (wrap ? scheme_wrap_evt_type : scheme_handle_evt_type); diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index df1b675a10..22f8d6f49e 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -6636,8 +6636,8 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], if (syncing->result) { /* Apply wrap functions to the selected evt: */ - Scheme_Object *o, *l, *a, *to_call = NULL, *args[1]; - int to_call_is_handle = 0; + Scheme_Object *o, *l, *a, *to_call = NULL, *args[1], **mv = NULL; + int to_call_is_handle = 0, rc = 1; o = evt_set->argv[syncing->result - 1]; if (SAME_TYPE(SCHEME_TYPE(o), scheme_channel_syncer_type)) { @@ -6650,12 +6650,24 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { a = SCHEME_CAR(l); if (to_call) { - args[0] = o; + if (rc == 1) { + mv = args; + args[0] = o; + } /* Call wrap proc with breaks disabled */ scheme_push_break_enable(&cframe, 0, 0); - o = scheme_apply(to_call, 1, args); + o = scheme_apply_multi(to_call, rc, mv); + + if (SAME_OBJ(o, SCHEME_MULTIPLE_VALUES)) { + rc = scheme_multiple_count; + mv = scheme_multiple_array; + scheme_detach_multple_array(mv); + } else { + rc = 1; + mv = NULL; + } scheme_pop_break_enable(&cframe, 0); @@ -6668,14 +6680,20 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], } to_call = a; } else if (SAME_TYPE(scheme_thread_suspend_type, SCHEME_TYPE(a)) - || SAME_TYPE(scheme_thread_resume_type, SCHEME_TYPE(a))) + || SAME_TYPE(scheme_thread_resume_type, SCHEME_TYPE(a))) { o = SCHEME_PTR2_VAL(a); - else + rc = 1; + } else { o = a; + rc = 1; + } } if (to_call) { - args[0] = o; + if (rc == 1) { + mv = args; + args[0] = o; + } /* If to_call is still a wrap-evt (not a handle-evt), then set the config one more time: */ @@ -6685,12 +6703,22 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], } if (tailok) { - return _scheme_tail_apply(to_call, 1, args); + return _scheme_tail_apply(to_call, rc, mv); } else { - o = scheme_apply(to_call, 1, args); - if (!to_call_is_handle) - scheme_pop_break_enable(&cframe, 1); - return o; + o = scheme_apply_multi(to_call, rc, mv); + + if (SAME_OBJ(o, SCHEME_MULTIPLE_VALUES)) { + rc = scheme_multiple_count; + mv = scheme_multiple_array; + scheme_detach_multple_array(mv); + if (!to_call_is_handle) + scheme_pop_break_enable(&cframe, 1); + return scheme_values(rc, mv); + } else { + if (!to_call_is_handle) + scheme_pop_break_enable(&cframe, 1); + return o; + } } } }