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