681 lines
27 KiB
Racket
681 lines
27 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
racket/draw/private/utils
|
|
ffi/unsafe/atomic
|
|
racket/class
|
|
racket/port
|
|
"rbtree.rkt"
|
|
"../../lock.rkt"
|
|
"handlers.rkt"
|
|
"once.rkt"
|
|
"keep-forever.rkt")
|
|
|
|
(provide
|
|
(protect-out queue-evt
|
|
set-check-queue!
|
|
set-queue-wakeup!
|
|
|
|
add-event-boundary-callback!
|
|
add-event-boundary-sometimes-callback!
|
|
remove-event-boundary-callback!
|
|
pre-event-sync
|
|
boundary-tasks-ready-evt
|
|
sometimes-delay-msec
|
|
set-platform-queue-sync!
|
|
|
|
eventspace?
|
|
current-eventspace
|
|
queue-event
|
|
queue-refresh-event
|
|
yield
|
|
yield/no-sync
|
|
yield-refresh
|
|
eventspace-event-evt
|
|
(rename-out [make-new-eventspace make-eventspace])
|
|
|
|
event-dispatch-handler
|
|
eventspace-shutdown?
|
|
main-eventspace?
|
|
eventspace-handler-thread
|
|
eventspace-event-evt
|
|
eventspace-wait-cursor-count
|
|
eventspace-extra-table
|
|
eventspace-adjust-external-modal!
|
|
|
|
queue-callback
|
|
middle-queue-key
|
|
|
|
make-timer-callback
|
|
add-timer-callback
|
|
remove-timer-callback
|
|
|
|
register-frame-shown
|
|
get-top-level-windows
|
|
other-modal?
|
|
|
|
queue-quit-event
|
|
queue-prefs-event
|
|
queue-about-event
|
|
queue-file-event
|
|
queue-start-empty-event
|
|
|
|
begin-busy-cursor
|
|
end-busy-cursor
|
|
is-busy?)
|
|
|
|
scheme_register_process_global)
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Create a Scheme evt that is ready when a queue is nonempty
|
|
|
|
(define _Scheme_Type _short)
|
|
(define-mz scheme_make_type (_fun _string -> _Scheme_Type))
|
|
(define event-queue-type (scheme_make_type "event-queue"))
|
|
|
|
(define-mz scheme_add_evt (_fun _Scheme_Type
|
|
(_fun #:atomic? #t _scheme -> _int)
|
|
(_fun #:atomic? #t _scheme _gcpointer -> _void)
|
|
_pointer
|
|
_int
|
|
-> _void))
|
|
|
|
(define (do-check-queue) #f)
|
|
(define (do-queue-wakeup fds) #f)
|
|
|
|
(define (check-queue o)
|
|
(if (do-check-queue) 1 0))
|
|
(define (queue-wakeup o fds)
|
|
(do-queue-wakeup fds))
|
|
(scheme_add_evt event-queue-type check-queue queue-wakeup #f 0)
|
|
(keep-forever check-queue)
|
|
(keep-forever queue-wakeup)
|
|
(define queue-evt (let ([p (malloc 16)]
|
|
[p2 (malloc 'nonatomic _pointer)])
|
|
(memset p 0 16)
|
|
(ptr-set! p _Scheme_Type event-queue-type)
|
|
(ptr-set! p2 _pointer p)
|
|
(ptr-ref p2 _scheme)))
|
|
|
|
(define (set-check-queue! check)
|
|
(set! do-check-queue check))
|
|
(define (set-queue-wakeup! wake)
|
|
(set! do-queue-wakeup wake))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Pre-event sync
|
|
|
|
(define boundary-ht (make-hasheq))
|
|
(define sometimes-boundary-ht (make-hasheq))
|
|
|
|
(define tasks-ready? #f)
|
|
(define task-ready-sema (make-semaphore))
|
|
(define boundary-tasks-ready-evt (semaphore-peek-evt task-ready-sema))
|
|
|
|
(define (alert-tasks-ready)
|
|
(let ([ready? (or (positive? (hash-count boundary-ht))
|
|
(positive? (hash-count sometimes-boundary-ht)))])
|
|
(unless (eq? ready? tasks-ready?)
|
|
(set! tasks-ready? ready?)
|
|
(if ready?
|
|
(semaphore-post task-ready-sema)
|
|
(semaphore-wait task-ready-sema)))))
|
|
|
|
(define (add-event-boundary-callback! v proc)
|
|
(atomically
|
|
(hash-set! boundary-ht v proc)
|
|
(alert-tasks-ready)))
|
|
(define (add-event-boundary-sometimes-callback! v proc)
|
|
(atomically
|
|
(when (zero? (hash-count sometimes-boundary-ht))
|
|
(set! last-time (current-inexact-milliseconds)))
|
|
(hash-set! sometimes-boundary-ht v proc)
|
|
(alert-tasks-ready)))
|
|
|
|
(define (remove-event-boundary-callback! v)
|
|
(atomically
|
|
(hash-remove! boundary-ht v)
|
|
(hash-remove! sometimes-boundary-ht v)
|
|
(alert-tasks-ready)))
|
|
|
|
(define last-time -inf.0)
|
|
(define sometimes-delay-msec 100)
|
|
|
|
;; Call this function only in atomic mode:
|
|
(define (pre-event-sync force?)
|
|
(let ([now (current-inexact-milliseconds)])
|
|
(when (or (now . > . (+ last-time sometimes-delay-msec))
|
|
force?)
|
|
(set! last-time now)
|
|
(hash-for-each sometimes-boundary-ht
|
|
(lambda (v p) (hash-remove! sometimes-boundary-ht v) (p v)))))
|
|
(hash-for-each boundary-ht (lambda (v p) (hash-remove! boundary-ht v) (p v)))
|
|
(alert-tasks-ready))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Eventspaces
|
|
|
|
(define-struct eventspace (handler-thread
|
|
queue-proc
|
|
frames-hash
|
|
done-evt
|
|
[shutdown? #:mutable]
|
|
done-sema
|
|
[wait-cursor-count #:mutable]
|
|
extra-table
|
|
[external-modal #:mutable])
|
|
#:property prop:evt (lambda (v)
|
|
(wrap-evt (eventspace-done-evt v)
|
|
(lambda (_) v))))
|
|
(define-struct timed (alarm-evt msecs val [id #:mutable]))
|
|
|
|
(define (make-timer-callback msecs thunk)
|
|
(make-timed (alarm-evt msecs)
|
|
msecs
|
|
thunk
|
|
0))
|
|
|
|
(define (timed-compare a b)
|
|
(if (eq? a b)
|
|
0
|
|
(let ([am (timed-msecs a)]
|
|
[bm (timed-msecs b)])
|
|
(cond
|
|
[(= am bm) (if ((timed-id a) . < . (timed-id b))
|
|
-1
|
|
1)]
|
|
[(< am bm) -1]
|
|
[else 1]))))
|
|
|
|
;; This table refers to handle threads of eventspaces
|
|
;; that have an open window, etc., so that the eventspace
|
|
;; isn't GCed
|
|
(define active-eventspaces (make-hasheq))
|
|
|
|
(define current-cb-box (make-parameter #f))
|
|
|
|
(define-mz scheme_add_managed (_fun _racket ; custodian
|
|
_racket ; object
|
|
(_fun #:atomic? #t #:keep (lambda (v) (set-box! (current-cb-box) v))
|
|
_racket _racket -> _void)
|
|
_racket ; data
|
|
_int ; strong?
|
|
-> _gcpointer))
|
|
|
|
(define (shutdown-eventspace! e ignored)
|
|
;; atomic mode
|
|
(unless (eventspace-shutdown? e)
|
|
(set-eventspace-shutdown?! e #t)
|
|
(semaphore-post (eventspace-done-sema e))
|
|
(for ([f (in-list (get-top-level-windows e))])
|
|
(send f destroy))
|
|
(hash-remove! active-eventspaces (eventspace-handler-thread e))))
|
|
|
|
(define platform-queue-sync void)
|
|
(define (set-platform-queue-sync! proc)
|
|
(set! platform-queue-sync proc))
|
|
|
|
(define (make-eventspace* th)
|
|
(let ([done-sema (make-semaphore 1)]
|
|
[done-set? #t]
|
|
[frames (make-hasheq)])
|
|
(let ([e
|
|
(make-eventspace th
|
|
(let ([count 0])
|
|
(let ([lo (mcons #f #f)]
|
|
[refresh (mcons #f #f)]
|
|
[med (mcons #f #f)]
|
|
[hi (mcons #f #f)]
|
|
[timer (box '())]
|
|
[timer-counter 0]
|
|
[newly-posted-sema (make-semaphore)])
|
|
(let* ([check-done
|
|
(lambda ()
|
|
(if (or (positive? count)
|
|
(positive? (hash-count frames))
|
|
(not (null? (unbox timer))))
|
|
(when done-set?
|
|
(hash-set! active-eventspaces th #t)
|
|
(set! done-set? #f)
|
|
(semaphore-try-wait? done-sema))
|
|
(unless done-set?
|
|
(hash-remove! active-eventspaces th)
|
|
(set! done-set? #t)
|
|
(semaphore-post done-sema))))]
|
|
[enqueue (lambda (v q)
|
|
(set! count (add1 count))
|
|
(check-done)
|
|
(let ([p (mcons v #f)])
|
|
(if (mcdr q)
|
|
(set-mcdr! (mcdr q) p)
|
|
(set-mcar! q p))
|
|
(set-mcdr! q p)))]
|
|
[first (lambda (q peek?)
|
|
(and (mcar q)
|
|
(if peek?
|
|
always-evt
|
|
(wrap-evt
|
|
always-evt
|
|
(lambda (_)
|
|
(start-atomic)
|
|
(set! count (sub1 count))
|
|
(check-done)
|
|
(let ([result (mcar (mcar q))])
|
|
(set-mcar! q (mcdr (mcar q)))
|
|
(unless (mcar q)
|
|
(set-mcdr! q #f))
|
|
(end-atomic)
|
|
result))))))]
|
|
[remove-timer
|
|
(lambda (v timer)
|
|
(set-box! timer (rbtree-remove
|
|
timed-compare
|
|
v
|
|
(unbox timer)))
|
|
(check-done))]
|
|
[timer-first-ready
|
|
(lambda (timer peek?)
|
|
(let ([rb (unbox timer)])
|
|
(and (not (null? rb))
|
|
(let* ([v (rbtree-min (unbox timer))]
|
|
[evt (timed-alarm-evt v)])
|
|
(and (sync/timeout 0 evt)
|
|
;; It's ready
|
|
(if peek?
|
|
always-evt
|
|
(wrap-evt
|
|
always-evt
|
|
(lambda (_)
|
|
(start-atomic)
|
|
(remove-timer v timer)
|
|
(end-atomic)
|
|
(timed-val v)))))))))]
|
|
[timer-first-wait
|
|
(lambda (timer peek?)
|
|
(let ([rb (unbox timer)])
|
|
(and (not (null? rb))
|
|
(wrap-evt
|
|
(timed-alarm-evt (rbtree-min (unbox timer)))
|
|
(lambda (_) #f)))))]
|
|
[make-event-choice
|
|
(lambda (peek? sync?)
|
|
(choice-evt
|
|
(wrap-evt (semaphore-peek-evt newly-posted-sema)
|
|
(lambda (_) #f))
|
|
(or (first hi peek?)
|
|
(timer-first-ready timer peek?)
|
|
(first refresh peek?)
|
|
(first med peek?)
|
|
(and (not peek?)
|
|
sync?
|
|
;; before going with low-priority events,
|
|
;; make sure we're sync'ed up with the
|
|
;; GUI platform's event queue:
|
|
(platform-queue-sync)
|
|
(first med peek?))
|
|
(first lo peek?)
|
|
(timer-first-wait timer peek?)
|
|
;; nothing else ready...
|
|
never-evt)))])
|
|
(case-lambda
|
|
[(v)
|
|
;; Enqueue
|
|
(start-atomic)
|
|
(let ([val (cdr v)])
|
|
(case (car v)
|
|
[(lo) (enqueue val lo)]
|
|
[(refresh) (enqueue val refresh)]
|
|
[(med) (enqueue val med)]
|
|
[(hi) (enqueue val hi)]
|
|
[(timer-add)
|
|
(set! timer-counter (add1 timer-counter))
|
|
(set-timed-id! val timer-counter)
|
|
(set-box! timer
|
|
(rbtree-insert
|
|
timed-compare
|
|
val
|
|
(unbox timer)))
|
|
(check-done)]
|
|
[(timer-remove) (remove-timer val timer)]
|
|
[(frame-add) (hash-set! frames val #t) (check-done)]
|
|
[(frame-remove) (hash-remove! frames val) (check-done)]))
|
|
(semaphore-post newly-posted-sema)
|
|
(set! newly-posted-sema (make-semaphore))
|
|
(check-done)
|
|
(end-atomic)]
|
|
[()
|
|
;; Dequeue as evt
|
|
(start-atomic)
|
|
(begin0
|
|
(make-event-choice #f #t)
|
|
(end-atomic))]
|
|
[(only-refresh? peek? sync?)
|
|
(start-atomic)
|
|
(begin0
|
|
(cond
|
|
[only-refresh?
|
|
;; Dequeue only refresh event
|
|
(or (first refresh peek?) never-evt)]
|
|
[else
|
|
(make-event-choice peek? sync?)])
|
|
(end-atomic))]))))
|
|
frames
|
|
(semaphore-peek-evt done-sema)
|
|
#f
|
|
done-sema
|
|
0
|
|
(make-hash)
|
|
0)]
|
|
[cb-box (box #f)])
|
|
(parameterize ([current-cb-box cb-box])
|
|
(scheme_add_managed (current-custodian)
|
|
e
|
|
shutdown-eventspace!
|
|
cb-box ; retain callback until it's called
|
|
0))
|
|
e)))
|
|
|
|
(define main-eventspace (make-eventspace* (current-thread)))
|
|
(define current-eventspace (make-parameter main-eventspace))
|
|
|
|
;; So we can get from a thread to the eventspace that
|
|
;; it handles (independent of the `current-eventspace'
|
|
;; parameter):
|
|
(define handler-thread-of (make-thread-cell #f))
|
|
(thread-cell-set! handler-thread-of main-eventspace)
|
|
|
|
(define make-new-eventspace
|
|
(let ([make-eventspace
|
|
(lambda ()
|
|
(define pause (make-semaphore))
|
|
(define break-paramz (current-break-parameterization))
|
|
(define es
|
|
(make-eventspace*
|
|
(parameterize-break
|
|
#f ; disable breaks until we're in the yield loop
|
|
(thread
|
|
(lambda ()
|
|
(sync pause) ; wait until `es' has a value
|
|
(thread-cell-set! handler-thread-of es)
|
|
(current-eventspace es)
|
|
(let loop ()
|
|
(call-with-continuation-prompt
|
|
(lambda ()
|
|
;; re-enable breaks (if they are supposed to be enabled):
|
|
(call-with-break-parameterization
|
|
break-paramz
|
|
(lambda ()
|
|
;; yield; any abort (including a break exception)
|
|
;; will get caught and the loop will yield again
|
|
(yield (make-semaphore))))))
|
|
(loop)))))))
|
|
(semaphore-post pause) ; `es' has a value
|
|
es)])
|
|
make-eventspace))
|
|
|
|
(define (queue-event eventspace thunk [level 'med])
|
|
((eventspace-queue-proc eventspace) (cons level thunk)))
|
|
|
|
(define (queue-refresh-event eventspace thunk)
|
|
((eventspace-queue-proc eventspace) (cons 'refresh thunk)))
|
|
|
|
(define dispatch-event-prompt (make-continuation-prompt-tag))
|
|
(define dispatch-event-key (gensym))
|
|
|
|
(define (really-dispatch-event e)
|
|
(let ([b (continuation-mark-set-first
|
|
#f
|
|
dispatch-event-key
|
|
#f
|
|
dispatch-event-prompt)])
|
|
(unless b
|
|
(error 'default-event-dispatch-handler
|
|
"not in an event-dispatch context"))
|
|
(let ([thunk (atomically
|
|
(begin0
|
|
(unbox b)
|
|
(set-box! b #f)))])
|
|
(unless thunk
|
|
(error 'default-event-dispatch-handler
|
|
"event in current context was already dispatched"))
|
|
(thunk))))
|
|
|
|
(define event-dispatch-handler (make-parameter really-dispatch-event))
|
|
|
|
(define event-logger (make-logger 'gui-event (current-logger)))
|
|
;; start? : boolean -- indicates if this is a start of an event being handled or not
|
|
;; msec : start time if start? is #t, delta from start to end if start? is #f
|
|
;; name : (or/c #f symbol?)
|
|
(struct gui-event (start end name) #:prefab)
|
|
|
|
(define (handle-event thunk e)
|
|
(call-with-continuation-prompt ; to delimit continuations
|
|
(lambda ()
|
|
(call-with-continuation-prompt ; to delimit search for dispatch-event-key
|
|
(lambda ()
|
|
;; communicate the thunk to `really-dispatch-event':
|
|
(define before (current-inexact-milliseconds))
|
|
(when (log-level? event-logger 'debug)
|
|
(log-message event-logger 'debug
|
|
(format "starting to handle an event from ~a" (object-name thunk))
|
|
(gui-event before #f (object-name thunk))))
|
|
(let ([b (box thunk)])
|
|
;; use the event-dispatch handler:
|
|
(with-continuation-mark dispatch-event-key b
|
|
((event-dispatch-handler) e))
|
|
;; if the event-dispatch handler doesn't chain
|
|
;; to the original one, then do so now:
|
|
(when (unbox b)
|
|
(set-box! b #f)
|
|
(thunk)))
|
|
(define after (current-inexact-milliseconds))
|
|
(when (log-level? event-logger 'debug)
|
|
(log-message event-logger 'debug
|
|
(format "handled an event: ~a msec"
|
|
(- after before))
|
|
(gui-event before after (object-name thunk)))))
|
|
dispatch-event-prompt))))
|
|
|
|
(define yield
|
|
(case-lambda
|
|
[()
|
|
(let ([e (current-eventspace)])
|
|
(if (eq? (current-thread) (eventspace-handler-thread e))
|
|
(let ([v (sync/timeout 0 ((eventspace-queue-proc e)))])
|
|
(if v
|
|
(begin (handle-event v e) #t)
|
|
#f))
|
|
#f))]
|
|
[(evt)
|
|
(unless (or (evt? evt)
|
|
(eq? evt 'wait))
|
|
(raise-type-error 'yield "evt or 'wait" evt))
|
|
(let* ([e (current-eventspace)]
|
|
[handler? (eq? (current-thread) (eventspace-handler-thread e))])
|
|
(cond
|
|
[(and (eq? evt 'wait)
|
|
(not handler?))
|
|
#t]
|
|
[else
|
|
(define (wait-now)
|
|
(if handler?
|
|
(sync (if (eq? evt 'wait)
|
|
(wrap-evt e (lambda (_) #t))
|
|
evt)
|
|
(handle-evt ((eventspace-queue-proc e))
|
|
(lambda (v)
|
|
(when v (handle-event v e))
|
|
(yield evt))))
|
|
(sync evt)))
|
|
(if (evt? evt)
|
|
;; `yield' is supposed to return immediately if the
|
|
;; event is already ready:
|
|
(sync/timeout wait-now evt)
|
|
(wait-now))]))]))
|
|
|
|
(define (yield/no-sync)
|
|
(let ([e (current-eventspace)])
|
|
(when (eq? (current-thread) (eventspace-handler-thread e))
|
|
(let ([v (sync/timeout 0 ((eventspace-queue-proc e) #f #f #f))])
|
|
(if v
|
|
(begin (handle-event v e) #t)
|
|
#f)))))
|
|
|
|
(define yield-refresh
|
|
(lambda ()
|
|
(let ([e (current-eventspace)])
|
|
(and (eq? (current-thread) (eventspace-handler-thread e))
|
|
(let loop ([result #f])
|
|
(let ([v (sync/timeout 0 ((eventspace-queue-proc e) #t #f #t))])
|
|
(if v
|
|
(begin
|
|
(handle-event v e)
|
|
(loop #t))
|
|
result)))))))
|
|
|
|
(define (eventspace-event-evt [e (current-eventspace)])
|
|
(unless (eventspace? e)
|
|
(raise-type-error 'eventspace-event-evt "eventspace" e))
|
|
(wrap-evt ((eventspace-queue-proc e) #f #t #t)
|
|
(lambda (_) e)))
|
|
|
|
(define (main-eventspace? e)
|
|
(eq? e main-eventspace))
|
|
|
|
(define (queue-callback thunk [high? #t])
|
|
(let ([es (current-eventspace)])
|
|
(when (eventspace-shutdown? es)
|
|
(error 'queue-callback "eventspace is shutdown: ~e" es))
|
|
(queue-event es thunk (cond
|
|
[(not high?) 'lo]
|
|
[(eq? high? middle-queue-key) 'med]
|
|
[else 'hi]))))
|
|
|
|
(define middle-queue-key (gensym 'middle))
|
|
|
|
|
|
(define (add-timer-callback cb es)
|
|
;; in atomic mode
|
|
(queue-event es cb 'timer-add))
|
|
(define (remove-timer-callback cb es)
|
|
;; in atomic mode
|
|
(unless (eventspace-shutdown? es)
|
|
(queue-event es cb 'timer-remove)))
|
|
|
|
(define (register-frame-shown f on?)
|
|
(queue-event (send f get-eventspace) f (if on?
|
|
'frame-add
|
|
'frame-remove)))
|
|
|
|
(define (get-top-level-windows [e (current-eventspace)])
|
|
;; called in event-pump thread
|
|
(hash-map (eventspace-frames-hash e)
|
|
(lambda (k v) k)))
|
|
|
|
(define (other-modal? win [e #f] [ignore-win #f])
|
|
;; called in atomic mode in eventspace's thread
|
|
(and
|
|
;; deliver mouse-motion events even if a modal window
|
|
;; is open
|
|
(or (not e)
|
|
(not (or (send e leaving?)
|
|
(send e entering?)
|
|
(send e moving?))))
|
|
;; for any other kind of mouse or key event, deliver only
|
|
;; if no model dialog is open
|
|
(let ([es (send win get-eventspace)])
|
|
(or (positive? (eventspace-external-modal es))
|
|
(let loop ([frames (get-top-level-windows es)])
|
|
(and (pair? frames)
|
|
(let ([status (if (eq? ignore-win (car frames))
|
|
#f
|
|
(send (car frames) frame-relative-dialog-status win))])
|
|
(case status
|
|
[(#f) (loop (cdr frames))]
|
|
[(same) (loop (cdr frames))]
|
|
[(other) #t]))))))))
|
|
|
|
(define (eventspace-adjust-external-modal! es amt)
|
|
(atomically
|
|
(set-eventspace-external-modal!
|
|
es
|
|
(+ (eventspace-external-modal es) amt))))
|
|
|
|
(define (queue-quit-event)
|
|
;; called in event-pump thread
|
|
(queue-event main-eventspace (application-quit-handler) 'med))
|
|
|
|
(define (queue-prefs-event)
|
|
;; called in event-pump thread
|
|
(queue-event main-eventspace (application-pref-handler) 'med))
|
|
|
|
(define (queue-about-event)
|
|
;; called in event-pump thread
|
|
(queue-event main-eventspace (application-about-handler) 'med))
|
|
|
|
(define (queue-file-event file)
|
|
;; called in event-pump thread
|
|
(queue-event main-eventspace (lambda ()
|
|
((application-file-handler) file))
|
|
'med))
|
|
|
|
(define (queue-start-empty-event)
|
|
;; called in event-pump thread
|
|
(queue-event main-eventspace (application-start-empty-handler)
|
|
'med))
|
|
|
|
(define (begin-busy-cursor)
|
|
(let ([e (current-eventspace)])
|
|
(atomically
|
|
(set-eventspace-wait-cursor-count!
|
|
e
|
|
(add1 (eventspace-wait-cursor-count e)))
|
|
(when (= (eventspace-wait-cursor-count e) 1)
|
|
(for ([e (in-list (get-top-level-windows))])
|
|
(send e set-wait-cursor-mode #t))))))
|
|
|
|
(define (end-busy-cursor)
|
|
(let ([e (current-eventspace)])
|
|
(atomically
|
|
(set-eventspace-wait-cursor-count!
|
|
e
|
|
(sub1 (eventspace-wait-cursor-count e)))
|
|
(when (zero? (eventspace-wait-cursor-count e))
|
|
(for ([e (in-list (get-top-level-windows))])
|
|
(send e set-wait-cursor-mode #f))))))
|
|
|
|
(define (is-busy?) (positive? (eventspace-wait-cursor-count (current-eventspace))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
;; Before exiting, wait until frames are closed, etc.:
|
|
(executable-yield-handler
|
|
(let ([old-eyh (executable-yield-handler)])
|
|
(lambda (v)
|
|
(yield main-eventspace)
|
|
(old-eyh v))))
|
|
|
|
;; When using a REPL in a thread that has an eventspace,
|
|
;; yield to events when the port would block.
|
|
(current-get-interaction-input-port
|
|
(let ([orig (current-get-interaction-input-port)])
|
|
(lambda ()
|
|
(let ([e (thread-cell-ref handler-thread-of)])
|
|
(if e
|
|
(let ([filter (lambda (v)
|
|
(cond
|
|
[(eq? v 0) (yield) 0]
|
|
[(evt? v)
|
|
(parameterize ([current-eventspace e])
|
|
(yield))
|
|
(choice-evt v
|
|
(wrap-evt (eventspace-event-evt e)
|
|
(lambda (_) 0)))]
|
|
[else v]))])
|
|
(filter-read-input-port
|
|
(orig)
|
|
(lambda (str v)
|
|
(filter v))
|
|
(lambda (s skip evt v)
|
|
(filter v))))
|
|
(orig))))))
|