eventspace shutdown
This commit is contained in:
Matthew Flatt
parent
f716ae049a
commit
72b671b665
|
|
@ -98,6 +98,7 @@
|
|||
(init [is-dialog? #f])
|
||||
|
||||
(inherit get-cocoa get-parent
|
||||
get-eventspace
|
||||
pre-on-char pre-on-event)
|
||||
|
||||
(super-new [parent parent]
|
||||
|
|
@ -232,8 +233,17 @@
|
|||
(register-frame-shown this on?))))
|
||||
|
||||
(define/override (show on?)
|
||||
(when on?
|
||||
(when (eventspace-shutdown? (get-eventspace))
|
||||
(error (string->symbol
|
||||
(format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%)))
|
||||
"the eventspace hash been shutdown")))
|
||||
(direct-show on?))
|
||||
|
||||
(define/public (destroy)
|
||||
(when child-sheet (send child-sheet destroy))
|
||||
(direct-show #f))
|
||||
|
||||
(define/override (is-shown?)
|
||||
(tell #:type _bool cocoa isVisible))
|
||||
|
||||
|
|
|
|||
|
|
@ -169,6 +169,9 @@
|
|||
(send parent get-eventspace)
|
||||
(current-eventspace)))
|
||||
|
||||
(when (eventspace-shutdown? eventspace)
|
||||
(error '|GUI object initialization| "the eventspace has been shutdown"))
|
||||
|
||||
(set-ivar! cocoa wx this)
|
||||
|
||||
(unless no-show?
|
||||
|
|
|
|||
|
|
@ -114,7 +114,7 @@
|
|||
;; ------------------------------------------------------------
|
||||
;; Eventspaces
|
||||
|
||||
(define-struct eventspace (handler-thread queue-proc frames-hash done-evt)
|
||||
(define-struct eventspace (handler-thread queue-proc frames-hash done-evt [shutdown? #:mutable] done-sema)
|
||||
#:property prop:evt (lambda (v)
|
||||
(wrap-evt (eventspace-done-evt v)
|
||||
(lambda (_) v))))
|
||||
|
|
@ -138,117 +138,141 @@
|
|||
[(< am bm) -1]
|
||||
[else 1]))))
|
||||
|
||||
|
||||
(define-mz scheme_add_managed (_fun _racket ; custodian
|
||||
_racket ; object
|
||||
(_fun #:atomic? #t _racket _pointer -> _void)
|
||||
_pointer ; data
|
||||
_int ; strong?
|
||||
-> _pointer))
|
||||
|
||||
(define (shutdown-eventspace! e ignored-data)
|
||||
(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))))
|
||||
|
||||
(define (make-eventspace* th)
|
||||
(let ([done-sema (make-semaphore 1)]
|
||||
[frames (make-hasheq)])
|
||||
(make-eventspace th
|
||||
(let ([count 0])
|
||||
(let ([lo (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))))
|
||||
(semaphore-try-wait? done-sema)
|
||||
(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)
|
||||
(and (mcar q)
|
||||
(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
|
||||
(let ([e
|
||||
(make-eventspace th
|
||||
(let ([count 0])
|
||||
(let ([lo (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))))
|
||||
(semaphore-try-wait? done-sema)
|
||||
(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)
|
||||
(and (mcar q)
|
||||
(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))])
|
||||
(case-lambda
|
||||
[(v)
|
||||
;; Enqueue
|
||||
(start-atomic)
|
||||
(let ([val (cdr v)])
|
||||
(case (car v)
|
||||
[(lo) (enqueue val lo)]
|
||||
[(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
|
||||
v
|
||||
val
|
||||
(unbox timer)))
|
||||
(check-done))])
|
||||
(case-lambda
|
||||
[(v)
|
||||
;; Enqueue
|
||||
(start-atomic)
|
||||
(let ([val (cdr v)])
|
||||
(case (car v)
|
||||
[(lo) (enqueue val lo)]
|
||||
[(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)
|
||||
(let ([timer-first-ready
|
||||
(lambda (timer)
|
||||
(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
|
||||
(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)
|
||||
(let ([timer-first-ready
|
||||
(lambda (timer)
|
||||
(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
|
||||
(wrap-evt
|
||||
always-evt
|
||||
(lambda (_)
|
||||
(start-atomic)
|
||||
(remove-timer v timer)
|
||||
(end-atomic)
|
||||
(timed-val v))))))))]
|
||||
[timer-first-wait
|
||||
(lambda (timer)
|
||||
(let ([rb (unbox timer)])
|
||||
(and (not (null? rb))
|
||||
(wrap-evt
|
||||
always-evt
|
||||
(lambda (_)
|
||||
(start-atomic)
|
||||
(remove-timer v timer)
|
||||
(end-atomic)
|
||||
(timed-val v))))))))]
|
||||
[timer-first-wait
|
||||
(lambda (timer)
|
||||
(let ([rb (unbox timer)])
|
||||
(and (not (null? rb))
|
||||
(wrap-evt
|
||||
(timed-alarm-evt (rbtree-min (unbox timer)))
|
||||
(lambda (_) #f)))))])
|
||||
(let ([e (choice-evt
|
||||
(wrap-evt (semaphore-peek-evt newly-posted-sema)
|
||||
(lambda (_) #f))
|
||||
(or (first hi)
|
||||
(timer-first-ready timer)
|
||||
(first med)
|
||||
(first lo)
|
||||
(timer-first-wait timer)
|
||||
;; nothing else ready...
|
||||
never-evt))])
|
||||
(end-atomic)
|
||||
e))]))))
|
||||
frames
|
||||
(semaphore-peek-evt done-sema))))
|
||||
(timed-alarm-evt (rbtree-min (unbox timer)))
|
||||
(lambda (_) #f)))))])
|
||||
(let ([e (choice-evt
|
||||
(wrap-evt (semaphore-peek-evt newly-posted-sema)
|
||||
(lambda (_) #f))
|
||||
(or (first hi)
|
||||
(timer-first-ready timer)
|
||||
(first med)
|
||||
(first lo)
|
||||
(timer-first-wait timer)
|
||||
;; nothing else ready...
|
||||
never-evt))])
|
||||
(end-atomic)
|
||||
e))]))))
|
||||
frames
|
||||
(semaphore-peek-evt done-sema)
|
||||
#f
|
||||
done-sema)])
|
||||
(scheme_add_managed (current-custodian)
|
||||
e
|
||||
shutdown-eventspace!
|
||||
#f
|
||||
1)
|
||||
e)))
|
||||
|
||||
(define main-eventspace (make-eventspace* (current-thread)))
|
||||
(define current-eventspace (make-parameter main-eventspace))
|
||||
|
|
@ -308,7 +332,6 @@
|
|||
(sync e)]))]))
|
||||
|
||||
(define event-dispatch-handler (make-parameter void))
|
||||
(define (eventspace-shutdown? e) #f)
|
||||
(define (main-eventspace? e)
|
||||
(eq? e main-eventspace))
|
||||
|
||||
|
|
@ -331,9 +354,9 @@
|
|||
'frame-add
|
||||
'frame-remove)))
|
||||
|
||||
(define (get-top-level-windows)
|
||||
(define (get-top-level-windows [e (current-eventspace)])
|
||||
;; called in event-pump thread
|
||||
(hash-map (eventspace-frames-hash (current-eventspace))
|
||||
(hash-map (eventspace-frames-hash e)
|
||||
(lambda (k v) k)))
|
||||
|
||||
(define (other-modal? win)
|
||||
|
|
|
|||
|
|
@ -97,7 +97,7 @@
|
|||
(inherit get-gtk set-size on-size
|
||||
pre-on-char pre-on-event
|
||||
get-client-delta get-size
|
||||
get-parent)
|
||||
get-parent get-eventspace)
|
||||
|
||||
(define gtk (gtk_window_new GTK_WINDOW_TOPLEVEL))
|
||||
(when (memq 'no-caption style)
|
||||
|
|
@ -207,10 +207,24 @@
|
|||
(set-top-position x y)
|
||||
(gtk_window_resize gtk (max 1 w) (max 1 h)))
|
||||
|
||||
(define/override (show on?)
|
||||
(when (and on?
|
||||
(eventspace-shutdown? (get-eventspace)))
|
||||
(error (string->symbol
|
||||
(format "show method in ~a"
|
||||
(if (frame-relative-dialog-status this)
|
||||
'dialog%
|
||||
'frame%)))
|
||||
"eventspace has been shutdown"))
|
||||
(super show on?))
|
||||
|
||||
(define/override (direct-show on?)
|
||||
(super direct-show on?)
|
||||
(register-frame-shown this on?))
|
||||
|
||||
(define/public (destroy)
|
||||
(direct-show #f))
|
||||
|
||||
(define/override (on-client-size w h)
|
||||
(on-size w h))
|
||||
|
||||
|
|
|
|||
|
|
@ -63,6 +63,8 @@
|
|||
(other-modal? wx))))
|
||||
|
||||
(defclass menu-bar% widget%
|
||||
(inherit install-widget-parent)
|
||||
|
||||
(define menus null)
|
||||
|
||||
(define gtk (gtk_menu_bar_new))
|
||||
|
|
@ -75,7 +77,8 @@
|
|||
|
||||
(define top-wx #f)
|
||||
(define/public (set-top-window top)
|
||||
(set! top-wx top))
|
||||
(set! top-wx top)
|
||||
(install-widget-parent top))
|
||||
(define/public (get-top-window)
|
||||
top-wx)
|
||||
|
||||
|
|
|
|||
|
|
@ -75,6 +75,8 @@
|
|||
callback
|
||||
font)
|
||||
|
||||
(inherit install-widget-parent)
|
||||
|
||||
(define cb callback)
|
||||
|
||||
(define gtk (gtk_menu_new))
|
||||
|
|
@ -88,7 +90,8 @@
|
|||
|
||||
(define parent #f)
|
||||
(define/public (set-parent p)
|
||||
(set! parent p))
|
||||
(set! parent p)
|
||||
(install-widget-parent p))
|
||||
(define/public (get-top-parent)
|
||||
;; Maybe be called in Gtk event-handler thread
|
||||
(and parent
|
||||
|
|
@ -187,7 +190,8 @@
|
|||
(let ([item (new menu-item-handler%
|
||||
[gtk item-gtk]
|
||||
[menu this]
|
||||
[menu-item i])])
|
||||
[menu-item i]
|
||||
[parent this])])
|
||||
(set! items (append items (list (list item item-gtk label chckable?))))
|
||||
(adjust-shortcut item-gtk label)))
|
||||
(gtk_menu_shell_append gtk item-gtk)
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require scheme/foreign
|
||||
scheme/class
|
||||
"../../syntax.rkt"
|
||||
"../common/queue.rkt"
|
||||
"queue.rkt"
|
||||
"utils.rkt"
|
||||
"types.rkt")
|
||||
|
|
@ -30,11 +31,20 @@
|
|||
(define widget%
|
||||
(class object%
|
||||
(init gtk
|
||||
[extra-gtks null])
|
||||
(init-field [eventspace (current-eventspace)])
|
||||
[extra-gtks null]
|
||||
[parent #f])
|
||||
(init-field [eventspace (if parent
|
||||
(send parent get-eventspace)
|
||||
(current-eventspace))])
|
||||
|
||||
(when (eventspace-shutdown? eventspace)
|
||||
(error '|GUI object initialization| "the eventspace has been shutdown"))
|
||||
|
||||
(define/public (get-eventspace) eventspace)
|
||||
(define/public (direct-update?) #t)
|
||||
|
||||
(define/public (install-widget-parent p)
|
||||
(set! eventspace (send p get-eventspace)))
|
||||
|
||||
(super-new)
|
||||
|
||||
|
|
|
|||
|
|
@ -248,7 +248,8 @@
|
|||
[add-to-parent? #t])
|
||||
|
||||
(super-new [gtk gtk]
|
||||
[extra-gtks extra-gtks])
|
||||
[extra-gtks extra-gtks]
|
||||
[parent parent])
|
||||
|
||||
(define save-x 0)
|
||||
(define save-y 0)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user