what happened here?

2011-01-07 09:23:51 -06:00 · 2011-01-07 09:23:51 -06:00 · bf031be73e
commit bf031be73e
parent a32adbe7db
15 changed files with 255 additions and 277 deletions
--- a/collects/tests/framework/canvas.rkt
+++ b/collects/tests/framework/canvas.rkt
@ -1,18 +1,18 @@
-(module canvas mzscheme
-  (require "test-suite-utils.ss")
+#lang racket/base
+(require "test-suite-utils.ss")

 (define (test-creation class name)
  (test
   name
   (lambda (x) (eq? 'passed x))
   (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)]
 	      [c (make-object ,class (send f get-area-container))])
 	 (send c set-editor (make-object text:wide-snip%))
 	 (send f show #t)))
      (wait-for-frame "test canvas")
-      (send-sexp-to-mred
+      (queue-sexp-to-mred
       `(send (get-top-level-focus-window) show #f))
      'passed)))

@ -25,4 +25,3 @@
 	       'canvas:wide-snip-mixin-creation)
 (test-creation 'canvas:wide-snip%
 	       'canvas:wide-snip%-creation)
-)
--- a/collects/tests/framework/debug.rkt
+++ b/collects/tests/framework/debug.rkt
@ -1,4 +1,5 @@
-#lang mzscheme
+#lang racket/base
+(require (for-syntax racket/base))
 (provide debug-printf debug-when)

 ;; all of the steps in the tcp connection
--- a/collects/tests/framework/exit.rkt
+++ b/collects/tests/framework/exit.rkt
@ -1,5 +1,5 @@
-(module exit mzscheme
-  (require "test-suite-utils.ss")
+#lang racket/base
+(require "test-suite-utils.ss")

 (test 'exit/no-prompt
      (lambda (x)
@ -47,4 +47,3 @@
 	 (with-handlers ([eof-result? (lambda (x) 'passed)])
 	   (send-sexp-to-mred
 	    `(exit:exit))))))
-)
--- a/collects/tests/framework/frame.rkt
+++ b/collects/tests/framework/frame.rkt
@ -1,4 +1,5 @@
-(module frame mzscheme
+#lang racket/base
+
  (require "test-suite-utils.ss")
  
  (send-sexp-to-mred '(send (make-object frame:basic%
@ -11,12 +12,10 @@
     (lambda (x) (eq? 'passed x))
     (lambda ()
       (let ([frame-label
-              (send-sexp-to-mred
-               `(queue-callback/res
-                 (λ ()
-                   (let ([f (instantiate ,class-expression () ,@args)])
-                     (send f show #t)
-                     (send f get-label)))))])
+              (queue-sexp-to-mred
+               `(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))
@ -110,7 +109,7 @@
         (equal? x test-file-contents))
       (lambda ()
         (let ([frame-name 
-                (send-sexp-to-mred
+                (queue-sexp-to-mred
                 `(let ([frame (new ,class-expression)])
                    (preferences:set 'framework:file-dialogs 'common)
                    (send frame show #t)
@ -122,10 +121,11 @@
           (call-with-output-file tmp-file
             (lambda (port)
               (display test-file-contents port))
-             'truncate)
+             #:exists 'truncate)
+           (queue-sexp-to-mred
+            `(send (find-labelled-window "Filename:") focus))
           (send-sexp-to-mred
-            `(begin (send (find-labelled-window "Filename:") focus)
-                    ,(case (system-type)
+            `(begin ,(case (system-type)
                       [(macos macosx) `(test:keystroke #\a '(meta))]
                       [(unix) `(test:keystroke #\a '(meta))]
                       [(windows) `(test:keystroke #\a '(control))]
@ -135,11 +135,11 @@
                    (test:keystroke #\return)))
           (wait-for-frame tmp-file-name)
           (begin0
+             (queue-sexp-to-mred
+              `(let* ([w (get-top-level-focus-window)])
+                 (send (send w get-editor) get-text)))
             (send-sexp-to-mred
-              `(let* ([w (get-top-level-focus-window)]
-                      [t (send (send w get-editor) get-text)])
-                 (test:close-top-level-window w)
-                 t))
+              `(test:close-top-level-window (get-top-level-focus-window)))
             (wait-for-frame frame-name)
             (queue-sexp-to-mred
              `(send (get-top-level-focus-window) close))))))))
@ -147,4 +147,3 @@
  (test-open "frame:searchable open" 'frame:searchable%)
  (test-open "frame:text open" 'frame:text%)

-  )
--- a/collects/tests/framework/group-test.rkt
+++ b/collects/tests/framework/group-test.rkt
@ -1,4 +1,4 @@
-#lang mzscheme
+#lang racket/base
 (require "test-suite-utils.ss")

 (define windows-menu-prefix 
@ -48,10 +48,10 @@
 'one-frame-registered
 (lambda (x) (equal? x (list "test" "first")))
 (lambda ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    `(send (make-object frame:basic% "test") show #t))
   (wait-for-frame "test")
-   (send-sexp-to-mred
+   (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)))))
@ -60,13 +60,13 @@
 'two-frames-registered
 (lambda (x) (equal? x (list "test2" "test1" "first")))
 (lambda ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    '(send (make-object frame:basic% "test1") show #t))
   (wait-for-frame "test1")
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    '(send (make-object frame:basic% "test2") show #t))
   (wait-for-frame "test2")
-   (send-sexp-to-mred
+   (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")
@ -78,15 +78,15 @@
 'one-frame-unregistered
 (lambda (x) (equal? x (list "test1" "first")))
 (lambda ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    '(send (make-object frame:basic% "test1") show #t))
   (wait-for-frame "test1")
-   (send-sexp-to-mred
+   (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))
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    `(let ([frames (send (group:get-the-frame-group) get-frames)])
       (for-each (lambda (x)
                   (unless (equal? (send x get-label) "first")
@ -101,11 +101,11 @@
   (lambda (x)
     (equal? x (append windows-menu-prefix (list "first" "test"))))
   (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(let ([frame (make-object frame:basic% "test")])
         (send frame show #t)))
     (wait-for-frame "test")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(begin0 (map (lambda (x)
                      (and (is-a? x labelled-menu-item<%>) (send x get-label)))
                    (send (car* (send (send (get-top-level-focus-window)
@ -119,12 +119,12 @@
   (lambda (x)
     (equal? x (append windows-menu-prefix (list "first" "test"))))
   (lambda ()
-     (send-sexp-to-mred
+     (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")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(begin0 (map (lambda (x)
                      (and (is-a? x labelled-menu-item<%>) (send x get-label)))
                    (send (car* (send (send (get-top-level-focus-window)
@ -138,15 +138,15 @@
   (lambda (x)
     (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
   (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(let ([frame (make-object frame:basic% "aaa")])
         (send frame show #t)))
     (wait-for-frame "aaa")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(let ([frame (make-object frame:basic% "bbb")])
         (send frame show #t)))
     (wait-for-frame "bbb")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      `(let ([frames (send (group:get-the-frame-group) get-frames)])
         (begin0 (map (lambda (x)
                        (and (is-a? x labelled-menu-item<%>) (send x get-label)))
@ -163,15 +163,15 @@
   (lambda (x)
     (equal? x (append windows-menu-prefix (list "aaa" "bbb" "first"))))
   (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(let ([frame (make-object frame:basic% "bbb")])
         (send frame show #t)))
     (wait-for-frame "bbb")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(let ([frame (make-object frame:basic% "aaa")])
         (send frame show #t)))
     (wait-for-frame "aaa")
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      `(let ([frames (send (group:get-the-frame-group) get-frames)])
         (begin0 (map (lambda (x)
                        (and (is-a? x labelled-menu-item<%>) (send x get-label)))
--- a/collects/tests/framework/keys.rkt
+++ b/collects/tests/framework/keys.rkt
@ -1,13 +1,13 @@
-(module keys mzscheme
-  (require "test-suite-utils.ss")
-  (require mzlib/include)
+#lang racket/base
+
+(require "test-suite-utils.ss")
  
  (test
   'keymap:aug-keymap%/get-table
   (lambda (x)
     (equal? '((c:k "abc")) x))
   (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(let ([k (make-object keymap:aug-keymap%)])
         (send k add-function "abc" void)
         (send k map-function "c:k" "abc")
@ -18,7 +18,7 @@
   (lambda (x)
     (equal? x '((c:k "def"))))
   (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(let ([k (make-object keymap:aug-keymap%)]
             [ht (make-hasheq)])
         (send k add-function "abc" void)
@ -31,7 +31,7 @@
   (lambda (x)
     (equal? x '((c:k "abc-k2"))))
   (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(let ([k (make-object keymap:aug-keymap%)]
             [k1 (make-object keymap:aug-keymap%)]
             [k2 (make-object keymap:aug-keymap%)])
@ -48,7 +48,7 @@
   (lambda (x)
     (equal? x '((c:k "abc-k"))))
   (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      '(let ([k (make-object keymap:aug-keymap%)]
             [k1 (make-object keymap:aug-keymap%)])
         (send k1 add-function "abc-k1" void)
@ -64,7 +64,7 @@
     (lambda (x)
       (string=? x str2))
     (lambda ()
-       (send-sexp-to-mred
+       (queue-sexp-to-mred
        `(keymap:canonicalize-keybinding-string ,str2)))))
  
  (test-canonicalize 1 "c:a" "c:a")
@ -260,13 +260,13 @@
      (list '((#\c control) (#\[ control))))
     ))
  
-  (send-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
-  (send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
+  (queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
+  (queue-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
  (wait-for-frame "dummy to trick frame group")
  
  ;; test-key : key-spec -> 
  ;;   evaluates a test case represented as a key-spec
-  (define (test-key key-spec)
+  (define (test-key key-spec i)
    (let* ([key-sequences 
            ((case (system-type)
               [(macos macosx) key-spec-macos]
@ -280,7 +280,7 @@
              (let ([text-expect (buff-spec-string after)]
                    [start-expect (buff-spec-start after)]
                    [end-expect (buff-spec-end after)])
-                (test key-sequence
+                (test (list key-sequence i)
                      (lambda (x) (equal? x (vector text-expect start-expect end-expect)))
                      `(let* ([text (send (get-top-level-focus-window) get-editor)])
                         (send text erase)
@ -295,15 +295,16 @@
  
  
  (define (test-specs frame-name frame-class specs)
-    (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
+    (queue-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
    (wait-for-frame frame-name)
-    (for-each test-key specs)
-    (send-sexp-to-mred `(send (get-top-level-focus-window) close)))
+    (for ([spec (in-list specs)]
+          [i (in-naturals)])
+      (test-key spec i))
+    (queue-sexp-to-mred `(send (get-top-level-focus-window) close)))
  
  (test-specs "global keybindings test" 'frame:text% global-specs)
  (test-specs "scheme mode keybindings test" 
              '(class frame:editor%
                 (define/override (get-editor%) scheme:text%)
                 (super-new))
-              scheme-specs))
-
+              scheme-specs)
--- a/collects/tests/framework/load.rkt
+++ b/collects/tests/framework/load.rkt
@ -1,5 +1,5 @@
-(module load mzscheme
-  (require "test-suite-utils.ss")
+#lang racket/base
+(require "test-suite-utils.ss")

  (load-framework-automatically #f)

@ -47,4 +47,4 @@
                         (with-syntax ([eles eles])
                           #''eles))])))
           (eval '(require framework/framework-sig))
-           (eval '(for-each eval (signature->symbols framework^))))))
+           (eval '(for-each eval (signature->symbols framework^)))))
--- a/collects/tests/framework/mem.rkt
+++ b/collects/tests/framework/mem.rkt
@ -1,4 +1,4 @@
-#lang mzscheme
+#lang racket/base
 (require "test-suite-utils.ss")

 ; mem-boxes : (list-of (list string (list-of (weak-box TST))))
@ -7,7 +7,7 @@
 (define mem-count 10)

 (define (test-allocate tag open close)
-  (send-sexp-to-mred
+  (queue-sexp-to-mred
   `(let ([new-boxes
           (let loop ([n ,mem-count])
             (cond
@ -32,7 +32,7 @@
      (set! mem-boxes (cons (list ,tag new-boxes) mem-boxes)))))

 (define (done)
-  (send-sexp-to-mred
+  (queue-sexp-to-mred
   `(begin
      (yield) (collect-garbage)
      (yield) (collect-garbage)
@ -110,7 +110,7 @@

 (define (test-frame-allocate %)
  (let ([name (format "~s" %)])
-    (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
+    (queue-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f))
    (test-allocate name
                   `(lambda ()
                      (let ([f (make-object ,% ,name)])
@ -123,7 +123,7 @@
                      (when (send f is-shown?)
                        (error 'test-frame-allocate "~a instance didn't close" ',%))
                      (yield) (yield)))
-    (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))
+    (queue-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))))

 (test-allocate "frame%"
               '(lambda ()
--- a/collects/tests/framework/panel-single.rkt
+++ b/collects/tests/framework/panel-single.rkt
@ -1,134 +1,135 @@
-#lang mzscheme
+#lang racket/base
 (require "test-suite-utils.ss")

 (test 
 'single-panel
 (lambda (x) (eq? x 'passed))
- `(let* ([semaphore (make-semaphore 0)]
-	 [semaphore-frame%
-	  (class frame% 
-	    (define/augment (on-close) (semaphore-post semaphore))
-	    (super-new))]
-	 [f (make-object semaphore-frame% "Single Panel Test")]
-	 [blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)]
-	 [green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)]
-	 [black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)]
-	 [grid-canvas%
-	  (class canvas% 
-	    (init-field lines)
-	    (init label)
-	    (inherit get-dc get-client-size)
-	    (override on-paint)
-	    (define (on-paint)
-	      (let-values ([(width height) (get-client-size)])
-		(let ([dc (get-dc)]
-		      [single-width (/ width lines)]
-		      [single-height (/ height lines)])
-		  (send dc set-pen black-pen)
-		  (let loop ([i lines])
-		    (cond
-		      [(zero? i) (void)]
-		      [else
-		       (let loop ([j lines])
-			 (cond
-			   [(zero? j) (void)]
-			   [else 
-			    (send dc set-brush
-				  (if (= 0 (modulo (+ i j) 2))
-				      blue-brush green-brush))
-			    (send dc draw-rectangle
-				  (* single-width (- i 1))
-				  (* single-height (- j 1))
-				  single-width
-				  single-height)
-			    (loop (- j 1))]))
-		       (loop (- i 1))])))))
-	    (super-instantiate ())
+ (λ ()
+   (queue-sexp-to-mred
+    `(let* ([semaphore (make-semaphore 0)]
+            [semaphore-frame%
+             (class frame% 
+               (define/augment (on-close) (semaphore-post semaphore))
+               (super-new))]
+            [f (make-object semaphore-frame% "Single Panel Test")]
+            [blue-brush (send the-brush-list find-or-create-brush "navy" 'solid)]
+            [green-brush (send the-brush-list find-or-create-brush "lightblue" 'solid)]
+            [grid-canvas%
+             (class canvas% 
+               (init-field lines)
+               (init label)
+               (inherit get-dc get-client-size)
+               (override on-paint)
+               (define (on-paint)
+                 (let-values ([(width height) (get-client-size)])
+                   (let ([dc (get-dc)]
+                         [single-width (/ width lines)]
+                         [single-height (/ height lines)])
+                     (send dc set-pen "black" 1 'transparent)
+                     (let loop ([i lines])
+                       (cond
+                         [(zero? i) (void)]
+                         [else
+                          (let loop ([j lines])
+                            (cond
+                              [(zero? j) (void)]
+                              [else 
+                               (send dc set-brush
+                                     (if (= 0 (modulo (+ i j) 2))
+                                         blue-brush green-brush))
+                               (send dc draw-rectangle
+                                     (* single-width (- i 1))
+                                     (* single-height (- j 1))
+                                     single-width
+                                     single-height)
+                               (loop (- j 1))]))
+                          (loop (- i 1))])))))
+               (super-instantiate ())
               
-	    ;; soon to be obsolete, hopefully.
-	    (inherit set-label)
-	    (set-label label)
+               ;; soon to be obsolete, hopefully.
+               (inherit set-label)
+               (set-label label)
               
-	    (inherit min-width min-height)
-	    (min-width 50)
-	    (min-height 50))]
-	 [border-panel (make-object horizontal-panel% f '(border))]
-	 [single-panel (make-object panel:single% border-panel)]
-	 [children
-	  (list
-	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f))
-	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide") (stretchable-width #f) (stretchable-height #t))
-	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Tall") (stretchable-width #t) (stretchable-height #f))
-	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))]
-	 [active-child (car children)]
-	 [radios (make-object horizontal-panel% f)]
-	 [make-radio
-	  (lambda (label choices callback)
-	    (let* ([panel (make-object vertical-panel% radios '(border))]
-		   [message (make-object message% label panel)]
-		   [radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))]
-		   [button (make-object button%
-			     "Cycle" panel
-			     (lambda (_1 _2)
-			       (let ([before (send radio get-selection)]
-				     [tot (send radio get-number)])
-				 (let loop ([n tot])
-				   (unless (zero? n)
-				     (send radio set-selection (- tot n))
-				     (callback radio)
-				     (sleep/yield 1)
-				     (loop (- n 1))))
-				 (send radio set-selection before)
-				 (callback radio))))])
-	      radio))]
-	 [radio
-	  (make-radio
-	   "Active Child"
-	   (map (lambda (x) (send x get-label)) children)
-	   (lambda (radio)
-	     (let loop ([n (length children)]
-			[cs children])
-	       (cond
-		 [(null? cs) (void)]
-		 [else (let ([c (car cs)])
-			 (if (string=? (send radio get-item-label (send radio get-selection))
-				       (send c get-label))
-			     (begin (set! active-child c)
-				    (send single-panel active-child active-child))
-			     (loop (- n 1)
-				   (cdr cs))))]))))]
-	 [vertical-alignment 'center]
-	 [horizontal-alignment 'center]
-	 [update-alignment (lambda () 
-			     (send single-panel set-alignment horizontal-alignment vertical-alignment))]
-	 [horiz
-	  (make-radio 
-	   "Horizontal Alignment"
-	   (list "left" "center" "right")
-	   (lambda (radio)
-	     (set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
-	     (update-alignment)))]
-	 [vert
-	  (make-radio
-	   "Vertical Alignment"
-	   (list "top" "center" "bottom")
-	   (lambda (radio)
-	     (set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
-	     (update-alignment)))]
-	 [buttons (make-object horizontal-panel% f)]
-	 [result 'failed]
-	 [failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))]
-	 [passed (make-object button% "Passed" buttons (lambda (_1 _2) 
-							 (set! result 'passed)
-							 (semaphore-post semaphore)))])
-    (send border-panel min-width 100)
-    (send border-panel min-height 100)
-    (send vert set-selection 1)
-    (send horiz set-selection 1)
-    (send buttons stretchable-height #f)
-    (send buttons set-alignment 'right 'center)
-    (send radios stretchable-height #f)
-    (send f show #t)
-    (yield semaphore)
-    (send f show #f)
-    result))
+               (inherit min-width min-height)
+               (min-width 50)
+               (min-height 50))]
+            [border-panel (make-object horizontal-panel% f '(border))]
+            [single-panel (make-object panel:single% border-panel)]
+            [children
+             (list
+              (new grid-canvas% (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f))
+              (new grid-canvas% (lines 3) (parent single-panel) (label "Wide") (stretchable-width #t) (stretchable-height #f))
+              (new grid-canvas% (lines 3) (parent single-panel) (label "Tall") (stretchable-width #f) (stretchable-height #t))
+              (new grid-canvas% (lines 3) (parent single-panel) (label "Wide and Tall") (stretchable-width #t) (stretchable-height #t)))]
+            [active-child (car children)]
+            [radios (make-object horizontal-panel% f)]
+            [make-radio
+             (lambda (label choices callback)
+               (let* ([panel (make-object vertical-panel% radios '(border))]
+                      [message (make-object message% label panel)]
+                      [radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))]
+                      [button (make-object button%
+                                "Cycle" panel
+                                (lambda (_1 _2)
+                                  (let ([before (send radio get-selection)]
+                                        [tot (send radio get-number)])
+                                    (let loop ([n tot])
+                                      (unless (zero? n)
+                                        (send radio set-selection (- tot n))
+                                        (callback radio)
+                                        (sleep/yield 1)
+                                        (loop (- n 1))))
+                                    (send radio set-selection before)
+                                    (callback radio))))])
+                 radio))]
+            [radio
+             (make-radio
+              "Active Child"
+              (map (lambda (x) (send x get-label)) children)
+              (lambda (radio)
+                (let loop ([n (length children)]
+                           [cs children])
+                  (cond
+                    [(null? cs) (void)]
+                    [else (let ([c (car cs)])
+                            (if (string=? (send radio get-item-label (send radio get-selection))
+                                          (send c get-label))
+                                (begin (set! active-child c)
+                                       (send single-panel active-child active-child))
+                                (loop (- n 1)
+                                      (cdr cs))))]))))]
+            [vertical-alignment 'center]
+            [horizontal-alignment 'center]
+            [update-alignment (lambda () 
+                                (send single-panel set-alignment horizontal-alignment vertical-alignment))]
+            [horiz
+             (make-radio 
+              "Horizontal Alignment"
+              (list "left" "center" "right")
+              (lambda (radio)
+                (set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
+                (update-alignment)))]
+            [vert
+             (make-radio
+              "Vertical Alignment"
+              (list "top" "center" "bottom")
+              (lambda (radio)
+                (set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection))))
+                (update-alignment)))]
+            [buttons (make-object horizontal-panel% f)]
+            [result 'failed]
+            [failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))]
+            [passed (make-object button% "Passed" buttons (lambda (_1 _2) 
+                                                            (set! result 'passed)
+                                                            (semaphore-post semaphore)))])
+       (send border-panel min-width 100)
+       (send border-panel min-height 100)
+       (send vert set-selection 1)
+       (send horiz set-selection 1)
+       (send buttons stretchable-height #f)
+       (send buttons set-alignment 'right 'center)
+       (send radios stretchable-height #f)
+       (send f show #t)
+       (yield semaphore)
+       (send f show #f)
+       result))))
--- a/collects/tests/framework/pasteboard.rkt
+++ b/collects/tests/framework/pasteboard.rkt
@ -1,5 +1,5 @@
-(module pasteboard mzscheme
-  (require "test-suite-utils.ss")
+#lang racket/base
+(require "test-suite-utils.ss")

 (define (test-creation frame class name)
  (test
@ -7,12 +7,10 @@
   (lambda (x) #t)
   (lambda ()
     (let ([frame-label
-	    (send-sexp-to-mred
-	     `(let* ([% (class ,frame
-			  (override get-editor%)
-			  [define (get-editor%)
-			    ,class])]
-		     [f (instantiate % ())])
+	    (queue-sexp-to-mred
+             `(let* ([f (new (class ,frame
+                               (define/override (get-editor%) ,class)
+                               (super-new)))])
 		(preferences:set 'framework:exit-when-no-frames #f)
 		(send f show #t)
 		(send f get-label)))])
@ -47,4 +45,3 @@
 (test-creation 'frame:pasteboard%
 	       'pasteboard:info%
 	       'pasteboard:info-creation)
-)
--- a/collects/tests/framework/prefs.rkt
+++ b/collects/tests/framework/prefs.rkt
@ -1,29 +1,11 @@
-(module prefs mzscheme
-  (require "test-suite-utils.ss"
-	   mzlib/list)
+#lang racket/base
+(require "test-suite-utils.ss")
  
  (define ((check-eq? x) y) (eq? x y))
  (define pref-sym 'plt:not-a-real-preference)
  (define marshalling-pref-sym 'plt:not-a-real-preference-marshalling)
  (define default-test-sym 'plt:not-a-real-preference-default-test)
  
-  (define saved-prefs-file
-    (let loop ([n 0])
-      (let ([candidate
-             (build-path (find-system-path 'temp-dir)
-                         (format "saved-prefs.~a" n))])
-        (if (file-exists? candidate)
-            (loop (+ n 1))
-            candidate)))) 
-  
-  (define prefs-file (find-system-path 'pref-file))
-  
-  (when (file-exists? prefs-file)
-    (copy-file prefs-file saved-prefs-file)
-    (delete-file prefs-file)
-    (debug-printf admin "saved preferences file from ~s\n" prefs-file)
-    (debug-printf admin "                         to ~s\n" saved-prefs-file))
-  
  (shutdown-mred)
  
  (test
@ -103,11 +85,3 @@
                                                'passed)
                                            'passed))))))
  
-  (when (file-exists? saved-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)
-    (delete-file saved-prefs-file)))
-
--- a/collects/tests/framework/scheme.rkt
+++ b/collects/tests/framework/scheme.rkt
@ -1,4 +1,4 @@
-#lang scheme
+#lang racket/base

 (require "test-suite-utils.ss")

@ -14,7 +14,7 @@
   (lambda (x) 
     (equal? x expected))
   (λ ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      `(let ([t (new scheme:text%)])
         (send t insert ,str)
         (scheme:text-balanced? t ,start ,end))))))
--- a/collects/tests/framework/search.rkt
+++ b/collects/tests/framework/search.rkt
@ -1,5 +1,5 @@
-#lang scheme
-
+#lang racket/base
+(require (for-syntax racket/base))
 (require "test-suite-utils.ss")

 (define-syntax (test-search stx)
@ -13,7 +13,7 @@
   (string->symbol (format "search.ss: line ~a" line))
   (lambda (x) (equal? bubble-table x))
   (lambda ()
-     (send-sexp-to-mred
+     (queue-sexp-to-mred
      `(let ([t (new (text:searching-mixin (editor:keymap-mixin text:basic%)))]
             [normalize
              (λ (ht) (sort (hash-table-map ht list)
--- a/collects/tests/framework/test-suite-utils.rkt
+++ b/collects/tests/framework/test-suite-utils.rkt
@ -1,8 +1,10 @@
-#lang scheme
+#lang racket/base

 (require (only-in mzscheme fluid-let)
         launcher
-         scheme/system
+         racket/system
+         racket/tcp
+         racket/pretty
         "debug.ss")

 (provide
@ -140,11 +142,10 @@
 (define queue-sexp-to-mred
  (lambda (sexp)
    (send-sexp-to-mred
-     `(let ([thunk (lambda () ,sexp)]  ;; lotech hygiene
+     `(let ([thunk (lambda () ,sexp)]  ;; low tech hygiene
            [c (make-channel)])
        (queue-callback (lambda () (channel-put c (thunk))))
-        (channel-wait c)))))
-
+        (channel-get c)))))

 (define re:tcp-read-error (regexp "tcp-read:"))
 (define re:tcp-write-error (regexp "tcp-write:"))
@ -152,7 +153,7 @@
  (or (regexp-match re:tcp-read-error (exn-message exn))
      (regexp-match re:tcp-write-error (exn-message exn))))

-(namespace-require 'scheme) ;; in order to make the eval below work right.
+(namespace-require 'racket) ;; in order to make the eval below work right.
 (define (send-sexp-to-mred sexp)
  (let/ec k
    (let ([show-text
@ -225,12 +226,12 @@
            (raise (make-eof-result))
            (case (car answer)
              [(error)
-               (error 'send-sexp-to-mred "gracket raised \"~a\"" (second answer))]
+               (error 'send-sexp-to-mred "gracket raised \"~a\"" (list-ref answer 1))]
              [(last-error)
-               (error 'send-sexp-to-mred "gracket (last time) raised \"~a\"" (second answer))]
-              [(cant-read) (error 'mred/cant-parse (second answer))]
+               (error 'send-sexp-to-mred "gracket (last time) raised \"~a\"" (list-ref answer 1))]
+              [(cant-read) (error 'mred/cant-parse (list-ref answer 1))]
              [(normal) 
-               (eval (second answer))]))))))
+               (eval (list-ref answer 1))]))))))

 (define test
  (case-lambda
@ -286,7 +287,15 @@
                 (sleep ,pause-time)
                 (loop (- n 1))))))))))

-(define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp))
+(define (wait-for sexp #:queue? [queue? #f]) 
+  (wait-for/wrapper
+   (lambda (x) x)
+   (if queue?
+       `(let ([t (λ () ,sexp)]
+              [c (make-channel)])
+          (queue-callback (λ () (channel-put c (t))))
+          (channel-get c))
+       sexp)))

 (define (wait-for-new-frame sexp)
  (wait-for/wrapper
--- a/collects/tests/framework/text.rkt
+++ b/collects/tests/framework/text.rkt
@ -1,9 +1,10 @@
-#lang scheme
+#lang racket/base

-(require "test-suite-utils.ss")
+(require racket/file
+         "test-suite-utils.ss")

 (define dummy-frame-title "dummy to avoid quitting")
-(send-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
+(queue-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))

 (define (test-creation frame% class name)
  (test
@ -12,29 +13,26 @@
     (equal? x (list dummy-frame-title))) ;; ensure no frames left
   (lambda ()
     (let ([label
-            (send-sexp-to-mred
-             `(let ([f (instantiate (class ,frame%
-                                      (override get-editor%)
-                                      [define (get-editor%) ,class]
-                                      (super-instantiate ()))
-                         ())])
+            (queue-sexp-to-mred
+             `(let ([f (new (class ,frame%
+                              (define/override (get-editor%) ,class)
+                              (super-new)))])
                (send (send f get-editor) set-max-undo-history 10)
                (send f show #t)
                (send f get-label)))])
       (wait-for-frame label)
       (send-sexp-to-mred `(test:keystroke #\a))
-       (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
-       (send-sexp-to-mred
+       (wait-for #:queue? #t `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
+       (queue-sexp-to-mred
        `(begin 
           ;; remove the `a' to avoid save dialog boxes (and test them, I suppose)
           (send (send (get-top-level-focus-window) get-editor) undo) 
           (send (send (get-top-level-focus-window) get-editor) undo)
           
           (send (send (get-top-level-focus-window) get-editor) lock #t)
-           (send (send (get-top-level-focus-window) get-editor) lock #f)))
-       (queue-sexp-to-mred
-        `(send (get-top-level-focus-window) close))
-       (send-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))
+           (send (send (get-top-level-focus-window) get-editor) lock #f)
+           (send (get-top-level-focus-window) close)))
+       (queue-sexp-to-mred `(map (lambda (x) (send x get-label)) (get-top-level-windows)))))))

 #|
  (test-creation 'frame:text%
@ -88,7 +86,7 @@
 'highlight-range1
 (lambda (x) (equal? x 1))
 (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
@ -98,7 +96,7 @@
 'highlight-range2
 (lambda (x) (equal? x 0))
 (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       ((send t highlight-range 1 2 "red"))
@ -109,7 +107,7 @@
 'highlight-range3
 (lambda (x) (equal? x 0))
 (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
@ -121,7 +119,7 @@
 'highlight-range4
 (lambda (x) (equal? x 1))
 (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
@ -135,7 +133,7 @@
 'highlight-range5
 (lambda (x) (equal? x 0))
 (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       (send t highlight-range 1 2 "red")
@ -151,7 +149,7 @@
     (delete-file tmp-file)
     (equal? x 0))
   (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    `(let ([t (new text:basic%)])
       (send t insert "abc")
       (send t save-file ,tmp-file)
@ -172,7 +170,7 @@
 'print-to-dc
 (λ (x) (equal? x 'no-error))
 (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    '(let* ([t (new text:basic%)]
            [bmp (make-object bitmap% 100 40)]
            [dc (new bitmap-dc% (bitmap bmp))])
@ -186,7 +184,7 @@
 'print-to-dc2
 (λ (x) (equal? x 'no-error))
 (λ ()
-   (send-sexp-to-mred
+   (queue-sexp-to-mred
    `(let* ([f (new frame% [label ""])]
            [t (new text:basic%)]
            [ec (new editor-canvas% [parent f] [editor t])]