diff --git a/collects/ffi/unsafe/com.rkt b/collects/ffi/unsafe/com.rkt index ab3be2a8d6..6e7433a6ee 100644 --- a/collects/ffi/unsafe/com.rkt +++ b/collects/ffi/unsafe/com.rkt @@ -1640,7 +1640,7 @@ (lambda () (thread-resume (com-event-executor-t self) (current-thread)) - (handle-evt + (wrap-evt (com-event-executor-ch self) (lambda (v) (lambda () diff --git a/collects/frtime/core/mailbox.rkt b/collects/frtime/core/mailbox.rkt index 17438d3353..5ef296f9c0 100644 --- a/collects/frtime/core/mailbox.rkt +++ b/collects/frtime/core/mailbox.rkt @@ -11,8 +11,8 @@ (define (new-mailbox) (define control-ch (make-channel)) (define (thread-recv-evt) - (handle-evt (thread-receive-evt) - (lambda (e) (thread-receive)))) + (wrap-evt (thread-receive-evt) + (lambda (e) (thread-receive)))) ; Try to match one message (define (try-to-match req msg) (match req diff --git a/collects/mzlib/port.rkt b/collects/mzlib/port.rkt index 06dbc01b6d..2a87650775 100644 --- a/collects/mzlib/port.rkt +++ b/collects/mzlib/port.rkt @@ -437,7 +437,7 @@ (lambda (s) (let ([r (peek-bytes-avail!* s delta #f orig-in)]) (set! delta (+ delta (if (number? r) r 1))) - (if (eq? r 0) (handle-evt orig-in (lambda (v) 0)) r))) + (if (eq? r 0) (wrap-evt orig-in (lambda (v) 0)) r))) (lambda (s skip default) (peek-bytes-avail!* s (+ delta skip) #f orig-in)) void diff --git a/collects/racket/promise.rkt b/collects/racket/promise.rkt index c83ce1c4e4..88ccdb0200 100644 --- a/collects/racket/promise.rkt +++ b/collects/racket/promise.rkt @@ -72,7 +72,7 @@ #:property prop:evt (lambda (p) (let ([v (pref p)]) - (handle-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void)))) + (wrap-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void)))) (provide (rename-out [delay/sync* delay/sync])) (define (delay/sync thunk) @@ -95,8 +95,8 @@ #:property prop:evt (lambda (p) (let ([v (pref p)]) - (handle-evt (if (running? v) (running-thread-thread v) always-evt) - void)))) + (wrap-evt (if (running? v) (running-thread-thread v) always-evt) + void)))) (provide (rename-out [delay/thread* delay/thread])) (define (delay/thread thunk group) diff --git a/collects/tests/racket/sync.rktl b/collects/tests/racket/sync.rktl index 27e7d37ab5..9b3deb132a 100644 --- a/collects/tests/racket/sync.rktl +++ b/collects/tests/racket/sync.rktl @@ -269,6 +269,35 @@ (wrap-evt (choice-evt (make-semaphore 1) (make-semaphore 1)) (lambda (x) 78))) +;; ---------------------------------------- +;; 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)))))) +;; check tail call via loop: +(test 'ok sync (let loop ([n 1000000]) + (if (zero? n) + (handle-evt always-evt (lambda (x) 'ok)) + (sync + (handle-evt always-evt (lambda (x) (loop (sub1 n)))))))) + +;; cannot wrap a `handle-evt' returns with a wrap or another handle: +(err/rt-test (handle-evt (handle-evt always-evt void) void)) +(err/rt-test (wrap-evt (handle-evt always-evt void) void)) +(err/rt-test (handle-evt (choice-evt (handle-evt always-evt void) void))) + +;; can handle a wrap evt: +(test #t evt? (handle-evt (wrap-evt always-evt void) void)) +(test #t evt? (handle-evt (choice-evt (wrap-evt always-evt void) + (wrap-evt never-evt void)) + void)) + +(test #t handle-evt? (handle-evt always-evt void)) +(test #t handle-evt? (choice-evt (wrap-evt always-evt void) (handle-evt always-evt void))) +(test #f handle-evt? (wrap-evt always-evt void)) +(test #f handle-evt? (choice-evt (wrap-evt always-evt void) (wrap-evt always-evt void))) + ;; ---------------------------------------- ;; Nack waitables diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl index 40113488bb..3bc10e1f8b 100644 --- a/collects/tests/racket/syntax.rktl +++ b/collects/tests/racket/syntax.rktl @@ -632,6 +632,15 @@ (syntax-test #'(delay . 1)) (syntax-test #'(delay 1 . 2)) +(let ([p (delay/sync 12)] + [v #f]) + (thread (lambda () (set! v (force p)))) + (sync (system-idle-evt)) + (test 12 force p) + (test 12 values v) + (test (void) sync p) + (test (list (void)) sync (wrap-evt p list))) + (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) (test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 7602d4188c..d0248ee3cb 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -3130,8 +3130,8 @@ static Scheme_Object *wrap_evt(const char *who, int wrap, int argc, Scheme_Objec { Wrapped_Evt *ww; - if (!scheme_is_evt(argv[0]) || (wrap && handle_evt_p(0, argv))) - scheme_wrong_type(who, wrap ? "non-handle evt" : "evt", 0, argc, argv); + if (!scheme_is_evt(argv[0]) || handle_evt_p(0, argv)) + scheme_wrong_type(who, "non-handle evt", 0, argc, argv); scheme_check_proc_arity(who, 1, 1, argc, argv); ww = MALLOC_ONE_TAGGED(Wrapped_Evt);