From 24a195eee26660b10a0889c1390b9d48d0db64fb Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 7 Jan 2011 06:39:27 -0600
Subject: [PATCH] make the framework test suite only modify gui objects on the
 eventspace handler thread

original commit: a32adbe7db6e8302bbd2bf0d21b6ad9cb04ad0d1
---
 collects/tests/framework/debug.rkt            |  2 +-
 collects/tests/framework/frame.rkt            |  8 +++---
 .../tests/framework/framework-test-engine.rkt |  5 ++++
 collects/tests/framework/prefs.rkt            | 26 +++++++++----------
 collects/tests/framework/test-suite-utils.rkt | 11 ++++----
 5 files changed, 29 insertions(+), 23 deletions(-)

diff --git a/collects/tests/framework/debug.rkt b/collects/tests/framework/debug.rkt
index 80ac35aa..32ef5676 100644
--- a/collects/tests/framework/debug.rkt
+++ b/collects/tests/framework/debug.rkt
@@ -13,7 +13,7 @@
 (define schedule? #t)
 
 ;; all of the sexpression transactions between mz and mred
-(define messages? #f)
+(define messages? #t)
 
 (define-syntax (debug-when stx)
   (syntax-case stx (mr-tcp mz-tcp admin schedule messages)
diff --git a/collects/tests/framework/frame.rkt b/collects/tests/framework/frame.rkt
index 3debb4e4..a6a87253 100644
--- a/collects/tests/framework/frame.rkt
+++ b/collects/tests/framework/frame.rkt
@@ -12,9 +12,11 @@
      (lambda ()
        (let ([frame-label
               (send-sexp-to-mred
-               `(let ([f (instantiate ,class-expression () ,@args)])
-                  (send f show #t)
-                  (send f get-label)))])
+               `(queue-callback/res
+                 (λ ()
+                   (let ([f (instantiate ,class-expression () ,@args)])
+                     (send f show #t)
+                     (send f get-label)))))])
          (wait-for-frame frame-label)
          (queue-sexp-to-mred
           '(send (get-top-level-focus-window) close))
diff --git a/collects/tests/framework/framework-test-engine.rkt b/collects/tests/framework/framework-test-engine.rkt
index 54e22cd8..59eb3fca 100644
--- a/collects/tests/framework/framework-test-engine.rkt
+++ b/collects/tests/framework/framework-test-engine.rkt
@@ -22,6 +22,11 @@
 
 (namespace-require 'racket/gui)
 
+(eval '(define (queue-callback/res thunk)
+         (define c (make-channel))
+         (queue-callback (λ () (channel-put c (thunk))))
+         (channel-get c)))
+
 (void
  (thread
   (lambda ()
diff --git a/collects/tests/framework/prefs.rkt b/collects/tests/framework/prefs.rkt
index 5f3cecb4..05494642 100644
--- a/collects/tests/framework/prefs.rkt
+++ b/collects/tests/framework/prefs.rkt
@@ -21,8 +21,8 @@
   (when (file-exists? prefs-file)
     (copy-file prefs-file saved-prefs-file)
     (delete-file prefs-file)
-    (debug-printf admin "saved preferences file from ~s to ~s\n"
-                  prefs-file saved-prefs-file))
+    (debug-printf admin "saved preferences file from ~s\n" prefs-file)
+    (debug-printf admin "                         to ~s\n" saved-prefs-file))
   
   (shutdown-mred)
   
@@ -92,20 +92,20 @@
   (test 'dialog-appears
         (lambda (x) (eq? 'passed x))
         (lambda ()
-          (send-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
-                                     (preferences:show-dialog)))
+          (queue-sexp-to-mred '(begin (send (make-object frame:basic% "frame") show #t)
+                                      (preferences:show-dialog)))
           (wait-for-frame "Preferences")
-          (send-sexp-to-mred '(begin (preferences:hide-dialog)
-                                     (let ([f (get-top-level-focus-window)])
-                                       (if f
-                                           (if (string=? "Preferences" (send f get-label))
-                                               'failed
-                                               'passed)
-                                           'passed))))))
+          (queue-sexp-to-mred '(begin (preferences:hide-dialog)
+                                      (let ([f (get-top-level-focus-window)])
+                                        (if f
+                                            (if (string=? "Preferences" (send f get-label))
+                                                'failed
+                                                'passed)
+                                            'passed))))))
   
   (when (file-exists? saved-prefs-file)
-    (debug-printf admin "restoring preferences file from ~s to ~s\n"
-                  saved-prefs-file prefs-file)
+    (debug-printf admin "restoring preferences file from ~s\n" saved-prefs-file)
+    (debug-printf admin "                             to ~s\n" prefs-file)
     (when (file-exists? prefs-file)
       (delete-file prefs-file))
     (copy-file saved-prefs-file prefs-file)
diff --git a/collects/tests/framework/test-suite-utils.rkt b/collects/tests/framework/test-suite-utils.rkt
index 0ed18caa..2bd63538 100644
--- a/collects/tests/framework/test-suite-utils.rkt
+++ b/collects/tests/framework/test-suite-utils.rkt
@@ -140,12 +140,11 @@
 (define queue-sexp-to-mred
   (lambda (sexp)
     (send-sexp-to-mred
-     `(let ([thunk (lambda () ,sexp)]
-            [sema (make-semaphore 0)])
-        (queue-callback (lambda ()
-                          (thunk)
-                          (semaphore-post sema)))
-        (semaphore-wait sema)))))
+     `(let ([thunk (lambda () ,sexp)]  ;; lotech hygiene
+            [c (make-channel)])
+        (queue-callback (lambda () (channel-put c (thunk))))
+        (channel-wait c)))))
+
 
 (define re:tcp-read-error (regexp "tcp-read:"))
 (define re:tcp-write-error (regexp "tcp-write:"))