suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Support for multiple value return from wrap-evt and handle-evt

Browse Source 
wrap/handle-evt that receives multiple values must have a handler function with adequate arity.

struct.c:
  change contract for wrap/handle-evt from (any/c -> any) to procedure?
thread.c:
  adjust sync processing
sync.rktl:
  add test for handle-evt, wrap-evt and prop:evt
This commit is contained in:
Tobias Hammer 2013-02-14 16:01:35 +01:00 committed by Matthew Flatt
parent 1cb6c03488
commit 7e2b443fa9
5 changed files with 75 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/scribblings/reference/evts.scrbl
View File

@ -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

26
collects/tests/racket/sync.rktl
View File

@ -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

4
doc/release-notes/racket/HISTORY.txt
View File

@ -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

4
src/racket/src/struct.c
View File

@ -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);

52
src/racket/src/thread.c
View File

@ -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;
}
}
}
}