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

eventspace shutdown

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-05 11:13:17 -06:00
parent f716ae049a
commit 72b671b665
8 changed files with 184 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/mred/private/wx/cocoa/frame.rkt
View File

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

3
collects/mred/private/wx/cocoa/window.rkt
View File

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

33
collects/mred/private/wx/common/queue.rkt
View File

@ -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,9 +138,25 @@
[(< 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)])
(let ([e
(make-eventspace th
(let ([count 0])
(let ([lo (mcons #f #f)]
@ -248,7 +264,15 @@
(end-atomic)
e))]))))
frames
(semaphore-peek-evt done-sema))))
(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)

16
collects/mred/private/wx/gtk/frame.rkt
View File

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

5
collects/mred/private/wx/gtk/menu-bar.rkt
View File

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

8
collects/mred/private/wx/gtk/menu.rkt
View File

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

14
collects/mred/private/wx/gtk/widget.rkt
View File

@ -2,6 +2,7 @@
(require scheme/foreign
scheme/class
"../../syntax.rkt"
"../common/queue.rkt"
"queue.rkt"
"utils.rkt"
"types.rkt")
@ -30,12 +31,21 @@
(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)
(let ([cell (malloc-immobile-cell this)])

3
collects/mred/private/wx/gtk/window.rkt
View File

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