From 4ce8dfa7da24056425a7ce3ce3c54f51e124c230 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 24 Jan 2010 15:30:16 +0000 Subject: [PATCH] fix problems with having a struct implement both prop:evt and prop:procedure; merge to 4.2.4 svn: r17802 --- .../scribblings/reference/custom-ports.scrbl | 10 +-- collects/scribblings/reference/evts.scrbl | 8 +- collects/tests/mzscheme/sync.ss | 76 +++++++++++-------- src/mzscheme/src/portfun.c | 27 +++---- src/mzscheme/src/struct.c | 16 +++- src/mzscheme/src/thread.c | 10 +-- 6 files changed, 86 insertions(+), 61 deletions(-) diff --git a/collects/scribblings/reference/custom-ports.scrbl b/collects/scribblings/reference/custom-ports.scrbl index fe8bda671f..866e1ef36a 100644 --- a/collects/scribblings/reference/custom-ports.scrbl +++ b/collects/scribblings/reference/custom-ports.scrbl @@ -72,11 +72,11 @@ The arguments implement the port as follows: @scheme[peek] is called again; or} @item{a @tech{synchronizable event} (see @secref["sync"]) other - than a pipe input port that becomes ready when the read is - complete (roughly): the event's value can one of the above three - results or another event like itself; in the last case, a - reading process loops with @scheme[sync] until it gets a - non-event result.} + than a pipe input port or procedure of arity four; the event + becomes ready when the read is complete (roughly): the event's + value can one of the above three results or another event like + itself; in the last case, a reading process loops with + @scheme[sync] until it gets a non-event result.} ] diff --git a/collects/scribblings/reference/evts.scrbl b/collects/scribblings/reference/evts.scrbl index 05fd41bffc..b423652918 100644 --- a/collects/scribblings/reference/evts.scrbl +++ b/collects/scribblings/reference/evts.scrbl @@ -324,13 +324,13 @@ A @tech{structure type property} that identifies structure types whose @itemize[ - @item{An event @scheme[evt]: In this case, using the structure as an - event is equivalent to using @scheme[evt].} + @item{An event @scheme[_evt]: In this case, using the structure as an + event is equivalent to using @scheme[_evt].} - @item{A procedure @scheme[proc] of one argument: In this case, the + @item{A procedure @scheme[_proc] of one argument: In this case, the structure is similar to an event generated by @scheme[guard-evt], except that the would-be guard - procedure @scheme[proc] receives the structure as an argument, instead + procedure @scheme[_proc] receives the structure as an argument, instead of no arguments.} @item{An exact, non-negative integer between @scheme[0] (inclusive) diff --git a/collects/tests/mzscheme/sync.ss b/collects/tests/mzscheme/sync.ss index 1216bdacef..cc416bac7f 100644 --- a/collects/tests/mzscheme/sync.ss +++ b/collects/tests/mzscheme/sync.ss @@ -465,12 +465,20 @@ (define-values (struct:wt make-wt wt? wt-ref wt-set!) (make-struct-type 'wt #f 2 0 #f (list (cons prop:evt 1)) (make-inspector) #f '(1))) -(let ([always-ready (make-wt #f (lambda (self) #t))] - [always-stuck (make-wt 1 2)]) - (test always-ready sync always-ready) - (test always-ready sync/timeout 0 always-ready) - (test #f sync/timeout 0 always-stuck) - (test #f sync/timeout SYNC-SLEEP-DELAY always-stuck)) +(define-values (struct:wt2 make-wt2 wt2? wt2-ref wt2-set!) + (make-struct-type 'wt2 #f 2 0 #f (list (cons prop:evt 1)) + (make-inspector) 0 '(1))) + +(let ([test-wt + (lambda (make-wt) + (let ([always-ready (make-wt (lambda () 10) (lambda (self) #t))] + [always-stuck (make-wt 1 2)]) + (test always-ready sync always-ready) + (test always-ready sync/timeout 0 always-ready) + (test #f sync/timeout 0 always-stuck) + (test #f sync/timeout SYNC-SLEEP-DELAY always-stuck)))]) + (test-wt make-wt) + (test-wt make-wt2)) ;; Check whether something that takes at least SYNC-SLEEP-DELAY ;; seconds in fact takes roughly that much CPU time. We @@ -496,7 +504,7 @@ (equal? "" Section-prefix)) (test busy? (lambda (a ax b c d) (> b c)) 'busy-wait? go took boundary real-took))))) -(define (test-good-waitable wrap-sema) +(define (test-good-waitable wrap-sema make-wt) (let ([sema (make-semaphore)]) (letrec-values ([(sema-ready-part get-sema-result) (wrap-sema sema sema (lambda () sema-ready))] [(sema-ready) (make-wt 1 sema-ready-part)]) @@ -530,13 +538,18 @@ [(wrapped) (make-wt 3 wrapped-part)]) (non-busy-wait (get-wrapped-result) get-wrapped-result)))))) -(test-good-waitable (lambda (x x-result get-self) - (values x (lambda () x-result)))) -(test-good-waitable (lambda (x x-result get-self) - (let ([ws (choice-evt - x - (make-wt 99 (lambda (self) (make-semaphore))))]) - (values ws (lambda () x-result))))) +(map + (lambda (make-wt) + (test-good-waitable (lambda (x x-result get-self) + (values x (lambda () x-result))) + make-wt) + (test-good-waitable (lambda (x x-result get-self) + (let ([ws (choice-evt + x + (make-wt 99 (lambda (self) (make-semaphore))))]) + (values ws (lambda () x-result)))) + make-wt)) + (list make-wt make-wt2)) (check-busy-wait (letrec ([s (make-semaphore)] @@ -592,22 +605,25 @@ (test bad-stuck-port sync bad-stuck-port)) #t))) -(test-stuck-port (make-semaphore 1) semaphore-try-wait? semaphore-post) -(let ([ready? #t]) - (test-stuck-port (make-wt 77 (lambda (self) - (if ready? - #t - (make-semaphore)))) - (lambda (wt) (set! ready? #f)) - (lambda (wt) (set! ready? #t)))) -(let ([s (make-semaphore 1)]) - (test-stuck-port (make-wt 77 s) - (lambda (wt) (semaphore-try-wait? s)) - (lambda (wt) (semaphore-post s)))) -(let ([s (make-semaphore 1)]) - (test-stuck-port (make-wt 177 (lambda (self) s)) - (lambda (wt) (semaphore-try-wait? s)) - (lambda (wt) (semaphore-post s)))) +(map + (lambda (make-wt) + (test-stuck-port (make-semaphore 1) semaphore-try-wait? semaphore-post) + (let ([ready? #t]) + (test-stuck-port (make-wt 77 (lambda (self) + (if ready? + #t + (make-semaphore)))) + (lambda (wt) (set! ready? #f)) + (lambda (wt) (set! ready? #t)))) + (let ([s (make-semaphore 1)]) + (test-stuck-port (make-wt 77 s) + (lambda (wt) (semaphore-try-wait? s)) + (lambda (wt) (semaphore-post s)))) + (let ([s (make-semaphore 1)]) + (test-stuck-port (make-wt 177 (lambda (self) s)) + (lambda (wt) (semaphore-try-wait? s)) + (lambda (wt) (semaphore-post s))))) + (list make-wt make-wt2)) ;; ---------------------------------------- diff --git a/src/mzscheme/src/portfun.c b/src/mzscheme/src/portfun.c index 19b3d81d90..3aa208d11d 100644 --- a/src/mzscheme/src/portfun.c +++ b/src/mzscheme/src/portfun.c @@ -769,22 +769,17 @@ static long user_read_result(const char *who, Scheme_Input_Port *port, "returned #f when no progress evt was supplied: ", val); return 0; - } else if (SCHEME_PROCP(val)) { - Scheme_Object *orig = val; - a[0] = val; - if (scheme_check_proc_arity(NULL, 4, 0, 1, a)) { - if (!special_ok) { - scheme_arg_mismatch(who, - "the port has no specific peek procedure, so" - " a special read result is not allowed: ", - orig); - return 0; - } - port->special = a[0]; - return SCHEME_SPECIAL; - } else - val = NULL; - n = 0; + } else if (SCHEME_PROCP(val) + && scheme_check_proc_arity(NULL, 4, 0, 1, a)) { + if (!special_ok) { + scheme_arg_mismatch(who, + "the port has no specific peek procedure, so" + " a special read result is not allowed: ", + val); + return 0; + } + port->special = val; + return SCHEME_SPECIAL; } else if (evt_ok && pipe_input_p(val)) { ((User_Input_Port *)port->port_data)->prefix_pipe = val; return 0; diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 876102c473..72fcd4835d 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -285,6 +285,10 @@ scheme_init_struct (Scheme_Env *env) (Scheme_Ready_Fun)evt_struct_is_ready, NULL, is_evt_struct, 1); + scheme_add_evt(scheme_proc_struct_type, + (Scheme_Ready_Fun)evt_struct_is_ready, + NULL, + is_evt_struct, 1); } { @@ -1055,6 +1059,11 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[ return v; } +static Scheme_Object *return_wrapped(void *data, int argc, Scheme_Object *argv[]) +{ + return (Scheme_Object *)data; +} + static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo) { Scheme_Object *v; @@ -1099,7 +1108,12 @@ static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo) return 0; } - /* non-evt => ready and result is self */ + /* non-evt => ready and result is self; if self is a procedure, + we need to wrap it, so that self is not treated as a `wrap-evt' + procedure. */ + if (SCHEME_PROCP(o)) { + o = scheme_make_closed_prim_w_arity(return_wrapped, (void *)o, "wrapper", 1, 1); + } scheme_set_sync_target(sinfo, o, o, NULL, 0, 0, NULL); return 1; diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index db2bde86dc..a25ff5b945 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -5881,7 +5881,7 @@ 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_cont = 0; + int to_call_is_handle = 0; o = evt_set->argv[syncing->result - 1]; if (SAME_TYPE(SCHEME_TYPE(o), scheme_channel_syncer_type)) { @@ -5908,7 +5908,7 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], if (SCHEME_BOXP(a) || SCHEME_PROCP(a)) { if (SCHEME_BOXP(a)) { a = SCHEME_BOX_VAL(a); - to_call_is_cont = 1; + to_call_is_handle = 1; } to_call = a; } else if (SAME_TYPE(scheme_thread_suspend_type, SCHEME_TYPE(a)) @@ -5921,9 +5921,9 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], if (to_call) { args[0] = o; - /* If to_call is still a wrap-evt (not a cont-evt), + /* If to_call is still a wrap-evt (not a handle-evt), then set the config one more time: */ - if (!to_call_is_cont) { + if (!to_call_is_handle) { scheme_push_break_enable(&cframe, 0, 0); tailok = 0; } @@ -5932,7 +5932,7 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], return _scheme_tail_apply(to_call, 1, args); } else { o = scheme_apply(to_call, 1, args); - if (!to_call_is_cont) + if (!to_call_is_handle) scheme_pop_break_enable(&cframe, 1); return o; }