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

fix problems with having a struct implement both prop:evt and prop:procedure; merge to 4.2.4

Browse Source 
svn: r17802
This commit is contained in:
Matthew Flatt 2010-01-24 15:30:16 +00:00
parent bbc654c69e
commit 4ce8dfa7da
6 changed files with 86 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/scribblings/reference/custom-ports.scrbl
View File

@ -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.}
]

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

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

76
collects/tests/mzscheme/sync.ss
View File

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

27
src/mzscheme/src/portfun.c
View File

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

16
src/mzscheme/src/struct.c
View File

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

10
src/mzscheme/src/thread.c
View File

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