From 1b10e27b5d20b4c1736e6a22b25f07236b5374c3 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sun, 15 Jan 2017 18:28:09 -0600
Subject: [PATCH] adjust various things so that the group test can be run in a
 single process and without (I believe) depending on the OS's idea of which
 frame has the focus

---
 gui-lib/framework/gui-utils.rkt         |  84 ++++---
 gui-lib/framework/private/autosave.rkt  |   3 +-
 gui-lib/framework/private/editor.rkt    |   6 +-
 gui-lib/framework/private/exit.rkt      |   6 +-
 gui-lib/framework/private/frame.rkt     |   3 +-
 gui-lib/framework/private/group.rkt     |  23 +-
 gui-lib/framework/private/text.rkt      |   6 +-
 gui-lib/info.rkt                        |   2 +-
 gui-test/framework/tests/group-test.rkt | 318 ++++++++++++------------
 9 files changed, 238 insertions(+), 213 deletions(-)

diff --git a/gui-lib/framework/gui-utils.rkt b/gui-lib/framework/gui-utils.rkt
index 9534465e..c8b30067 100644
--- a/gui-lib/framework/gui-utils.rkt
+++ b/gui-lib/framework/gui-utils.rkt
@@ -230,7 +230,8 @@
           (λ () (thunk))
           (λ () (cursor-off))))])))
 
-(define (unsaved-warning filename action-anyway [can-save-now? #f] [parent #f] [cancel? #t])
+(define (unsaved-warning filename action-anyway [can-save-now? #f] [parent #f] [cancel? #t]
+                         #:dialog-mixin [dialog-mixin values])
   (define key-closed #f)
   (define (unsaved-warning-mixin %)
     (class %
@@ -265,39 +266,41 @@
          '(default=2 caution))
      2
      #:dialog-mixin (if (equal? (system-type) 'macosx)
-                        unsaved-warning-mixin
-                        values)))
+                        (compose unsaved-warning-mixin dialog-mixin)
+                        dialog-mixin)))
   (or key-closed
       (case mb-res
         [(1) 'save]
         [(2) 'cancel]
         [(3) 'continue])))
 
-(define get-choice
-  (lambda (message 
-           true-choice
-           false-choice 
-           (title (string-constant warning))
-           (default-result 'disallow-close)
-           (parent #f)
-           (style 'app)
-           (checkbox-proc #f)
-           (checkbox-label (string-constant dont-ask-again)))
-    (let* ([check? (and checkbox-proc (checkbox-proc))]
-           [style  (if (eq? style 'app) `(default=1) `(default=1 ,style))]
-           [style  (if (eq? 'disallow-close default-result)
-                       (cons 'disallow-close style) style)]
-           [style  (if check? (cons 'checked style) style)]
-           [return (λ (mb-res) (case mb-res [(1) #t] [(2) #f] [else mb-res]))])
-      (if checkbox-proc
-          (let-values ([(mb-res checked)
-                        (message+check-box/custom title message checkbox-label
-                                                  true-choice false-choice #f
-                                                  parent style default-result)])
-            (checkbox-proc checked)
-            (return mb-res))
-          (return (message-box/custom title message true-choice false-choice #f
-                                      parent style default-result))))))
+(define (get-choice message
+                    true-choice
+                    false-choice
+                    [title (string-constant warning)]
+                    [default-result 'disallow-close]
+                    [parent #f]
+                    [style 'app]
+                    [checkbox-proc #f]
+                    [checkbox-label (string-constant dont-ask-again)]
+                    #:dialog-mixin [dialog-mixin values])
+  (let* ([check? (and checkbox-proc (checkbox-proc))]
+         [style  (if (eq? style 'app) `(default=1) `(default=1 ,style))]
+         [style  (if (eq? 'disallow-close default-result)
+                     (cons 'disallow-close style) style)]
+         [style  (if check? (cons 'checked style) style)]
+         [return (λ (mb-res) (case mb-res [(1) #t] [(2) #f] [else mb-res]))])
+    (if checkbox-proc
+        (let-values ([(mb-res checked)
+                      (message+check-box/custom title message checkbox-label
+                                                true-choice false-choice #f
+                                                parent style default-result
+                                                #:dialog-mixin dialog-mixin)])
+          (checkbox-proc checked)
+          (return mb-res))
+        (return (message-box/custom title message true-choice false-choice #f
+                                    parent style default-result
+                                    #:dialog-mixin dialog-mixin)))))
 
 ;; manual renaming
 (define gui-utils:trim-string trim-string)
@@ -490,12 +493,14 @@
     (or/c false/c
           (is-a?/c frame%)
           (is-a?/c dialog%))
-    boolean?)
+    boolean?
+    #:dialog-mixin (make-mixin-contract dialog%))
    (symbols 'continue 'save 'cancel))
   ((filename action)
    ((can-save-now? #f)
     (parent #f)
-    (cancel? #t)))
+    (cancel? #t)
+    (dialog-mixin values)))
   
   @{This displays a dialog that warns the user of a unsaved file.
     
@@ -511,6 +516,10 @@
     in the dialog and the result may be @racket['cancel]. If it
     is @racket[#f], then there is no cancel button, and @racket['cancel]
     will not be the result of the function.
+
+    The @racket[dialog-mixin] argument is passed to @racket[message-box/custom].
+
+    @history[#:changed "1.29" @elem{Added the @racket[dialog-mixin] argument.}]
     
     })
  
@@ -525,7 +534,8 @@
         (symbols 'app 'caution 'stop)
         (or/c false/c (case-> (boolean? . -> . void?)
                               (-> boolean?)))
-        string?)
+        string?
+        #:dialog-mixin (make-mixin-contract dialog%))
        any/c)
   ((message true-choice false-choice)
    ((title (string-constant warning))
@@ -533,7 +543,8 @@
     (parent #f)
     (style 'app)
     (checkbox-proc #f)
-    (checkbox-label (string-constant dont-ask-again))))
+    (checkbox-label (string-constant dont-ask-again))
+    (dialog-mixin values)))
   
   @{Opens a dialog that presents a binary choice to the user. The user is
     forced to choose between these two options, ie cancelling or closing the
@@ -565,7 +576,14 @@
     (defaults to the @racket[dont-ask-again] string constant), and that
     checkbox value will be sent to the @racket[checkbox-proc] when the dialog
     is closed.  Note that the dialog will always pop-up --- it is the
-    caller's responsibility to avoid the dialog if not needed.})
+    caller's responsibility to avoid the dialog if not needed.
+
+    The @racket[dialog-mixin] argument is passed to @racket[message-box/custom]
+    or @racket[message+check-box/custom].
+
+    @history[#:changed "1.29" @elem{Added the @racket[dialog-mixin] argument.}]
+
+    })
  
  (proc-doc/names
   gui-utils:get-clicked-clickback-delta
diff --git a/gui-lib/framework/private/autosave.rkt b/gui-lib/framework/private/autosave.rkt
index 04e91a9f..a028866c 100644
--- a/gui-lib/framework/private/autosave.rkt
+++ b/gui-lib/framework/private/autosave.rkt
@@ -256,7 +256,8 @@
               (string-constant autosave-delete-title)
               (string-constant cancel)
               (string-constant warning)
-              #f)
+              #f
+              #:dialog-mixin frame:focus-table-mixin)
              (with-handlers ([exn:fail?
                               (λ (exn)
                                 (message-box
diff --git a/gui-lib/framework/private/editor.rkt b/gui-lib/framework/private/editor.rkt
index c28df987..be579e39 100644
--- a/gui-lib/framework/private/editor.rkt
+++ b/gui-lib/framework/private/editor.rkt
@@ -154,7 +154,8 @@
                       (string-constant cancel)
                       (string-constant warning)
                       #f
-                      (get-top-level-window))
+                      (get-top-level-window)
+                      #:dialog-mixin frame:focus-table-mixin)
                      #t)
                  #t)
              (inner #t can-save-file? filename format)))
@@ -585,7 +586,8 @@
                    #t
                    (or (get-top-level-window)
                        (get-can-close-parent))
-                   allow-cancel?)
+                   allow-cancel?
+                   #:dialog-mixin frame:focus-table-mixin)
               [(continue) #t]
               [(save) (save-file)]
               [else #f])))
diff --git a/gui-lib/framework/private/exit.rkt b/gui-lib/framework/private/exit.rkt
index 1cb98c5d..64c879d5 100644
--- a/gui-lib/framework/private/exit.rkt
+++ b/gui-lib/framework/private/exit.rkt
@@ -6,7 +6,8 @@
            "../gui-utils.rkt"
            mred/mred-sig)
   
-  (import mred^)
+  (import mred^
+          [prefix frame: framework:frame^])
   (export (rename framework:exit^
                   (-exit exit)))
   
@@ -60,7 +61,8 @@
          'app
          (case-lambda
            [() (not (preferences:get 'framework:verify-exit))]
-           [(new) (preferences:set 'framework:verify-exit (not new))]))
+           [(new) (preferences:set 'framework:verify-exit (not new))])
+         #:dialog-mixin frame:focus-table-mixin)
         #t))
   
   (define (-exit)
diff --git a/gui-lib/framework/private/frame.rkt b/gui-lib/framework/private/frame.rkt
index 5dc5f610..cb790133 100644
--- a/gui-lib/framework/private/frame.rkt
+++ b/gui-lib/framework/private/frame.rkt
@@ -1509,7 +1509,8 @@
                          (string-constant no)
                          (string-constant are-you-sure-revert-title)
                          #f
-                         this))
+                         this
+                         #:dialog-mixin focus-table-mixin))
                 (revert))))
         #t))
     
diff --git a/gui-lib/framework/private/group.rkt b/gui-lib/framework/private/group.rkt
index 94b4a30e..6e3169db 100644
--- a/gui-lib/framework/private/group.rkt
+++ b/gui-lib/framework/private/group.rkt
@@ -1,4 +1,4 @@
-#lang scheme/unit
+#lang racket/base
 
   (require string-constants
            racket/class
@@ -6,8 +6,17 @@
            "../preferences.rkt"
            "../gui-utils.rkt"
            mred/mred-sig
-           racket/path)
-  
+           racket/path
+           racket/unit)
+
+;; for use in the test suite
+(define pay-attention-to-current-eventspace-has-standard-menus?
+  (make-parameter #t))
+
+(provide pay-attention-to-current-eventspace-has-standard-menus?
+         group@)
+
+(define-unit group@
   (import mred^
           [prefix application: framework:application^]
           [prefix frame: framework:frame^]
@@ -268,14 +277,16 @@
       (or (not (preferences:get 'framework:exit-when-no-frames))
           (exit:exiting?)
           (not (= 1 number-of-frames))
-          (current-eventspace-has-standard-menus?)
+          (and (pay-attention-to-current-eventspace-has-standard-menus?)
+               (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 (and (null? (send (get-the-frame-group) get-frames))
-                   (not (current-eventspace-has-standard-menus?)))
+                   (not (and (pay-attention-to-current-eventspace-has-standard-menus?)
+                             (current-eventspace-has-standard-menus?))))
           (exit:exit)))))
   
   (define (choose-a-frame parent)
@@ -349,4 +360,4 @@
       (internal-get-the-frame-group)))
   
   (define (get-the-frame-group)
-    (internal-get-the-frame-group))
+    (internal-get-the-frame-group)))
diff --git a/gui-lib/framework/private/text.rkt b/gui-lib/framework/private/text.rkt
index 22d18c38..a6860a82 100644
--- a/gui-lib/framework/private/text.rkt
+++ b/gui-lib/framework/private/text.rkt
@@ -2254,7 +2254,8 @@
                     (gui-utils:get-choice
                      (string-constant save-as-plain-text) 
                      (string-constant yes)
-                     (string-constant no))))
+                     (string-constant no)
+                     #:dialog-mixin frame:focus-table-mixin)))
            (set-file-format 'text)]
           [(and (not all-strings?)
                 (eq? format 'same)
@@ -2263,7 +2264,8 @@
                     (gui-utils:get-choice
                      (string-constant save-in-drs-format)
                      (string-constant yes)
-                     (string-constant no))))
+                     (string-constant no)
+                     #:dialog-mixin frame:focus-table-mixin)))
            (set-file-format 'standard)]
           [else (void)]))
       (inner (void) on-save-file name format))
diff --git a/gui-lib/info.rkt b/gui-lib/info.rkt
index e7a143dc..b3e6e0e0 100644
--- a/gui-lib/info.rkt
+++ b/gui-lib/info.rkt
@@ -30,4 +30,4 @@
 
 (define pkg-authors '(mflatt robby))
 
-(define version "1.28")
+(define version "1.29")
diff --git a/gui-test/framework/tests/group-test.rkt b/gui-test/framework/tests/group-test.rkt
index 44419714..d4405222 100644
--- a/gui-test/framework/tests/group-test.rkt
+++ b/gui-test/framework/tests/group-test.rkt
@@ -1,7 +1,12 @@
 #lang racket/base
-(require "test-suite-utils.rkt")
-
-(module test racket/base)
+(require "private/here-util.rkt"
+         "private/gui.rkt"
+         rackunit
+         racket/class
+         racket/gui/base
+         framework
+         (only-in "../../../gui-lib/framework/private/group.rkt"
+                  pay-attention-to-current-eventspace-has-standard-menus?))
 
 (define windows-menu-prefix 
   (let ([basics (list "Bring Frame to Front…" "Most Recent Window"
@@ -9,180 +14,163 @@
     (if (eq? (system-type) 'macosx)
         (list* "Minimize" "Zoom" basics)
         basics)))
-(send-sexp-to-mred
- '(define-syntax car*
+
+(define pref-ht (make-hash))
+(parameterize ([test:use-focus-table #t]
+               [preferences:low-level-get-preference
+                (λ (sym [fail (λ () #f)])
+                  (hash-ref pref-ht sym fail))]
+               [preferences:low-level-put-preferences
+                (λ (syms vals)
+                  (for ([sym (in-list syms)]
+                        [val (in-list vals)])
+                    (hash-set! pref-ht sym val)))]
+               [pay-attention-to-current-eventspace-has-standard-menus? #f])
+
+  (define-syntax car*
     (syntax-rules ()
-      [(car* x) (if (pair? x)
-                    (car x)
-                    (error 'car* "got a non-pair for ~s" 'x))])))
+      [(car* x-expr)
+       (let ([x x-expr])
+         (if (pair? x)
+             (car x)
+             (begin
+               (eprintf "car* called with ~s\n" 'x-expr)
+               (car x))))]))
 
-;; this test uses a new eventspace so that the gracket 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 (parameterize ([current-eventspace new-eventspace])
-              (send (make-object frame:basic% "first") show #t))
-            (preferences:set 'framework:verify-exit #t)))
-   (wait-for-frame "first" 'new-eventspace)
-   (send-sexp-to-mred
-    `(queue-callback (lambda () 
-                       (parameterize ([current-eventspace new-eventspace])
-                         (send (get-top-level-focus-window) close)))))
-   (wait-for-frame "Warning" 'new-eventspace)
-   (send-sexp-to-mred
-    `(parameterize ([current-eventspace new-eventspace])
-       (test:button-push "Cancel")))
-   (wait-for-frame "first" 'new-eventspace)
-   (send-sexp-to-mred
-    `(parameterize ([current-eventspace new-eventspace])
-       (map (lambda (x) (send x get-label))
-            (send (group:get-the-frame-group) get-frames))))))
+  (define the-first-frame #f)
 
-;; after the first test, we should have one frame that will always
-;; be in the group.
+  (yield
+   (thread
+    (λ ()
+      (queue-callback
+       (λ ()
+         (set! the-first-frame (make-object frame:basic% "first"))
+         (send the-first-frame show #t)))
+      (preferences:set 'framework:verify-exit #t)
+      (wait-for-frame "first")
+      (queue-callback
+       (λ ()
+         (send (test:get-active-top-level-window) close)))
+      (wait-for-frame "Warning")
+      (test:button-push "Cancel")
+      (wait-for-frame "first"))))
+  (check-equal? (map (lambda (x) (send x get-label))
+                     (send (group:get-the-frame-group) get-frames))
+                '("first"))
 
-(test
- 'one-frame-registered
- (lambda (x) (equal? x (list "test" "first")))
- (lambda ()
-   (queue-sexp-to-mred
-    `(send (make-object frame:basic% "test") show #t))
-   (wait-for-frame "test")
-   (queue-sexp-to-mred
-    `(begin0 (map (lambda (x) (send x get-label))
-                  (send (group:get-the-frame-group) get-frames))
-             (send (get-top-level-focus-window) close)))))
+  ;; after the first test, we should have one frame
+  ;; that will always be in the group.
 
-(test
- 'two-frames-registered
- (lambda (x) (equal? x (list "test2" "test1" "first")))
- (lambda ()
-   (queue-sexp-to-mred
-    '(send (make-object frame:basic% "test1") show #t))
-   (wait-for-frame "test1")
-   (queue-sexp-to-mred
-    '(send (make-object frame:basic% "test2") show #t))
-   (wait-for-frame "test2")
-   (queue-sexp-to-mred
-    `(begin0 (let ([frames (send (group:get-the-frame-group) get-frames)])
-               (for-each (lambda (x)
-                           (unless (equal? (send x get-label) "first")
-                             (send x close)))
-                         frames)
-               (map (lambda (x) (send x get-label)) frames))))))
+  (check-equal?
+   (let ()
+     (send (make-object frame:basic% "test") show #t)
+     (define ans (map (lambda (x) (send x get-label))
+                      (send (group:get-the-frame-group) get-frames)))
+     (send (test:get-active-top-level-window) close)
+     ans)
+  (list "test" "first"))
 
-(test
- 'one-frame-unregistered
- (lambda (x) (equal? x (list "test1" "first")))
- (lambda ()
-   (queue-sexp-to-mred
-    '(send (make-object frame:basic% "test1") show #t))
-   (wait-for-frame "test1")
-   (queue-sexp-to-mred
-    '(send (make-object frame:basic% "test2") show #t))
-   (wait-for-frame "test2")
-   (queue-sexp-to-mred
-    `(send (get-top-level-focus-window) close))
-   (queue-sexp-to-mred
-    `(let ([frames (send (group:get-the-frame-group) get-frames)])
+
+  (begin
+    (yield
+     (thread
+      (λ ()
+        (queue-callback
+         (λ () (send (make-object frame:basic% "test1") show #t)))
+        (wait-for-frame "test1")
+        (queue-callback
+         (λ () (send (make-object frame:basic% "test2") show #t)))
+        (wait-for-frame "test2"))))
+    (check-equal?
+     (let ([frames (send (group:get-the-frame-group) get-frames)])
        (for-each (lambda (x)
                    (unless (equal? (send x get-label) "first")
                      (send x close)))
                  frames)
-       (map (lambda (x) (send x get-label)) frames)))))
+       (map (lambda (x) (send x get-label)) frames))
+     (list "test2" "test1" "first")))
 
-(when (eq? (system-type) 'macosx)
-  
-  (test
-   'windows-menu
-   (lambda (x)
-     (equal? x (append windows-menu-prefix (list "first" "test"))))
-   (λ ()
-     (queue-sexp-to-mred
-      '(let ([frame (make-object frame:basic% "test")])
-         (send frame show #t)))
-     (wait-for-frame "test")
-     (queue-sexp-to-mred
-      '(let ([mb (send (get-top-level-focus-window) get-menu-bar)])
+  (begin
+    (yield
+     (thread
+      (λ ()
+        (queue-callback
+         (λ ()
+           (send (make-object frame:basic% "test1") show #t)))
+        (wait-for-frame "test1")
+        (queue-callback
+         (λ ()
+           (send (make-object frame:basic% "test2") show #t)))
+        (wait-for-frame "test2"))))
+    (send (test:get-active-top-level-window) close)
+    (check-equal?
+     (let ([frames (send (group:get-the-frame-group) get-frames)])
+       (for-each (lambda (x)
+                   (unless (equal? (send x get-label) "first")
+                     (send x close)))
+                 frames)
+       (map (lambda (x) (send x get-label)) frames))
+     (list "test1" "first")))
+
+
+  (when (eq? (system-type) 'macosx)
+
+    (check-equal?
+     (begin
+       (send (make-object frame:basic% "test") show #t)
+       (let ([mb (send (test:get-active-top-level-window) get-menu-bar)])
          (send mb on-demand)
          (define labels
            (for/list ([x (send (car* (send mb get-items)) get-items)])
              (and (is-a? x labelled-menu-item<%>) (send x get-label))))
-         (send (get-top-level-focus-window) close)
-         labels))))
-  
-  (test
-   'windows-menu-unshown
-   (lambda (x)
-     (equal? x (append windows-menu-prefix (list "first" "test"))))
-   (lambda ()
-     (queue-sexp-to-mred
-      '(let ([frame1 (make-object frame:basic% "test")]
-             [frame2 (make-object frame:basic% "test-not-shown")])
-         (send frame1 show #t)))
-     (wait-for-frame "test")
-     (queue-sexp-to-mred
-      '(let ([mb (send (get-top-level-focus-window) get-menu-bar)])
-         (send mb on-demand)
-         (define items
-           (for/list ([x (send (car* (send mb get-items)) get-items)])
-             (and (is-a? x labelled-menu-item<%>) (send x get-label))))
-         (send (get-top-level-focus-window) close)
-         items))))
-  
-  (test
-   'windows-menu-sorted1
-   (lambda (x)
-     (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
-   (lambda ()
-     (queue-sexp-to-mred
-      '(let ([frame (make-object frame:basic% "aaa")])
-         (send frame show #t)))
-     (wait-for-frame "aaa")
-     (queue-sexp-to-mred
-      '(let ([frame (make-object frame:basic% "bbb")])
-         (send frame show #t)))
-     (wait-for-frame "bbb")
-     (queue-sexp-to-mred
-      `(let ([frames (send (group:get-the-frame-group) get-frames)])
-         (define mb (send (car* frames) get-menu-bar))
-         (send mb on-demand)
-         (begin0 (map (lambda (x)
-                        (and (is-a? x labelled-menu-item<%>) (send x get-label)))
-                      (send (car* (send mb get-items))
-                            get-items))
-                 (for-each (lambda (x)
-                             (unless (equal? (send x get-label) "first")
-                               (send x close)))
-                           frames))))))
-  
-  (test
-   'windows-menu-sorted2
-   (lambda (x)
-     (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
-   (lambda ()
-     (queue-sexp-to-mred
-      '(let ([frame (make-object frame:basic% "bbb")])
-         (send frame show #t)))
-     (wait-for-frame "bbb")
-     (queue-sexp-to-mred
-      '(let ([frame (make-object frame:basic% "aaa")])
-         (send frame show #t)))
-     (wait-for-frame "aaa")
-     (queue-sexp-to-mred
-      `(let ([frames (send (group:get-the-frame-group) get-frames)])
-         (define mb (send (car* frames) get-menu-bar))
-         (send mb on-demand)
-         (begin0 (map (lambda (x)
-                        (and (is-a? x labelled-menu-item<%>) (send x get-label)))
-                      (send (car* (send mb get-items))
-                            get-items))
-                 (for-each (lambda (x)
-                             (unless (equal? (send x get-label) "first")
-                               (send x close)))
-                           frames)))))))
+         (send (test:get-active-top-level-window) close)
+         labels))
+     (append windows-menu-prefix (list "first" "test")))
+
+    (check-equal?
+     (let ()
+       (define frame1 (make-object frame:basic% "test"))
+       (define frame2 (make-object frame:basic% "test-not-shown"))
+       (send frame1 show #t)
+       (define mb (send (test:get-active-top-level-window) get-menu-bar))
+       (send mb on-demand)
+       (define items
+         (for/list ([x (send (car* (send mb get-items)) get-items)])
+           (and (is-a? x labelled-menu-item<%>) (send x get-label))))
+       (send (test:get-active-top-level-window) close)
+       items)
+     (append windows-menu-prefix (list "first" "test")))
+
+    (define (get-label-and-close-non-first)
+      (define frames (send (group:get-the-frame-group) get-frames))
+      (define mb (send (car* frames) get-menu-bar))
+      (send mb on-demand)
+      (define ans
+        (for/list ([x (in-list (send (car* (send mb get-items))
+                                     get-items))])
+          (and (is-a? x labelled-menu-item<%>) (send x get-label))))
+      (for ([x (in-list frames)])
+        (unless (equal? (send x get-label) "first")
+          (send x close)))
+      ans)
+    
+    (check-equal?
+     (let ()
+       (define aaa-frame (make-object frame:basic% "aaa"))
+       (send aaa-frame show #t)
+       (define bbb-frame (make-object frame:basic% "bbb"))
+       (send bbb-frame show #t)
+       (get-label-and-close-non-first))
+     (append windows-menu-prefix (list "aaa" "bbb" "first")))
+
+    (check-equal?
+     (let ()
+       (define bbb-frame (make-object frame:basic% "bbb"))
+       (send bbb-frame show #t)
+       (define aaa-frame (make-object frame:basic% "aaa"))
+       (send aaa-frame show #t)
+       (get-label-and-close-non-first))
+     (append windows-menu-prefix (list "aaa" "bbb" "first"))))
+
+  ;; close that original frame so the test suite can exit if run from `racket`
+  (send the-first-frame show #f))