eventspace shutdown

collects/mred/private/wx/cocoa/frame.rkt

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

collects/mred/private/wx/cocoa/window.rkt

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

collects/mred/private/wx/common/queue.rkt

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

collects/mred/private/wx/gtk/frame.rkt

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

collects/mred/private/wx/gtk/menu-bar.rkt

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

collects/mred/private/wx/gtk/menu.rkt

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

collects/mred/private/wx/gtk/widget.rkt

@@ -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])
+          [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 (direct-update?) #t)
 
+    (define/public (install-widget-parent p)
+      (set! eventspace (send p get-eventspace)))
+    
     (super-new)
 
     (let ([cell (malloc-immobile-cell this)])

collects/mred/private/wx/gtk/window.rkt

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