PR 9873 (hopefully)

svn: r12193

collects/framework/private/group.ss

@@ -273,12 +273,14 @@
       (or (not (preferences:get 'framework:exit-when-no-frames))
           (exit:exiting?)
           (not (= 1 number-of-frames))
+          (current-eventspace-has-standard-menus?)
           (exit:user-oks-exit))))
 
   (define (on-close-action)
     (when (preferences:get 'framework:exit-when-no-frames)
       (unless (exit:exiting?)
-        (when (null? (send (get-the-frame-group) get-frames))
+        (when (and (null? (send (get-the-frame-group) get-frames))
+                   (not (current-eventspace-has-standard-menus?)))
           (exit:exit)))))
   
   (define (choose-a-frame parent)

collects/tests/framework/group-test.ss

@@ -5,7 +5,7 @@
   (let ([basics (list "Bring Frame to Front..." "Most Recent Window" 
                       #f)])
     (if (eq? (system-type) 'macosx)
-      (list* "Minimize" "Zoom" #f basics)
+      (list* "Minimize" "Zoom" basics)
       basics)))
 (send-sexp-to-mred
  '(define-syntax car*
@@ -14,23 +14,32 @@
                   (car x)
                   (error 'car* "got a non-pair for ~s" 'x))])))
 
+;; this test uses a new eventspace so that the mred function
+;; current-eventspace-has-standard-menus? returns #f and thus
+;; all of the platforms behave the same way.
 (test
  'exit-on
  (lambda (x) (equal? x '("first")))
  (lambda ()
+   (send-sexp-to-mred `(define new-eventspace (make-eventspace)))
    (send-sexp-to-mred
-    '(begin (send (make-object frame:basic% "first") show #t)
+    '(begin (parameterize ([current-eventspace new-eventspace])
+              (send (make-object frame:basic% "first") show #t))
             (preferences:set 'framework:verify-exit #t)))
-   (wait-for-frame "first")
+   (wait-for-frame "first" 'new-eventspace)
    (send-sexp-to-mred
-    `(queue-callback (lambda () (send (get-top-level-focus-window) close))))
+    `(queue-callback (lambda () 
-   (wait-for-frame "Warning")
+                       (parameterize ([current-eventspace new-eventspace])
+                         (send (get-top-level-focus-window) close)))))
+   (wait-for-frame "Warning" 'new-eventspace)
    (send-sexp-to-mred
-    `(test:button-push "Cancel"))
+    `(parameterize ([current-eventspace new-eventspace])
-   (wait-for-frame "first")
+       (test:button-push "Cancel")))
+   (wait-for-frame "first" 'new-eventspace)
    (send-sexp-to-mred
-    `(map (lambda (x) (send x get-label))
+    `(parameterize ([current-eventspace new-eventspace])
-          (send (group:get-the-frame-group) get-frames)))))
+       (map (lambda (x) (send x get-label))
+            (send (group:get-the-frame-group) get-frames))))))
 
 ;; after the first test, we should have one frame that will always
 ;; be in the group.

collects/tests/framework/test-suite-utils.ss

@@ -1,9 +1,8 @@
+#lang scheme
 
-(module test-suite-utils mzscheme
+(require (only-in mzscheme fluid-let)
-  (require launcher
+         launcher
-	   mzlib/pretty
+         scheme/system
-	   mzlib/list
-           mzlib/process
          "debug.ss")
 
 (provide
@@ -70,7 +69,8 @@
       (if l
           (begin (debug-printf mz-tcp "listening to ~a\n" port)
                  (call-with-output-file port-filename
-                   (lambda (p) (write port p)) 'truncate)
+                   (lambda (p) (write port p))
+                   #:exists 'truncate)
                  l)
           (begin (debug-printf mz-tcp "  tcp-listen failed for port ~a\n" port)
                  (loop (add1 port)))))))
@@ -292,7 +292,11 @@
         ,w))
    `(not (eq? frame (get-top-level-focus-window)))))
 
-  (define (wait-for-frame name)
+(define (wait-for-frame name [eventspace #f])
-    (wait-for `(let ([win (get-top-level-focus-window)])
+  (let ([exp `(let ([win (get-top-level-focus-window)])
                 (and win
-		      (string=? (send win get-label) ,name))))))
+                     (string=? (send win get-label) ,name)))])
+    (if eventspace
+        `(parameterize ([current-eventspace ,eventspace])
+           ,exp)
+        (wait-for exp))))