...

original commit: a1c58bdd0fe81e8a514397ef7cb076bb0912668e

collects/framework/framework.ss

@@ -3,7 +3,7 @@
 	   (lib "mred.ss" "mred")
 	   (lib "mred-sig.ss" "mred")
            
-	   (prefix test: "test.ss")
+	   "test.ss"
 	   "test-sig.ss"
            
 	   (prefix prefs-file: "prefs-file.ss")

collects/framework/private/exit.ss

@@ -69,4 +69,4 @@
 	  (when (can-exit?)
 	    (on-exit)
 	    (queue-callback (lambda () (exit))))
-	  (set! exiting? #f))))))
+	  (set! exiting? #f))))))

collects/framework/private/frame.ss

@@ -143,7 +143,7 @@
           (super-instantiate ())
           (accept-drop-files #t)
             
-          (make-object menu% "&Window" (make-object (get-menu-bar%) this))
+          (make-object menu% "&Windows" (make-object (get-menu-bar%) this))
           (reorder-menus this)
           (send (group:get-the-frame-group) insert-frame this)
           [define panel (make-root-area-container (get-area-container%) this)]
@@ -583,7 +583,7 @@
       
       (define editor-mixin
         (mixin (standard-menus<%>) (-editor<%>)
-          (init file-name)
+          (init (file-name #f))
 
           (inherit get-area-container get-client-size 
                    show get-edit-target-window get-edit-target-object)

collects/framework/private/gen-standard-menus.ss

@@ -69,11 +69,11 @@
                     (instantiate (get-menu-item%) ()
                       (label ,(join menu-before-string menu-after-string
                                     `(,(an-item->string-name item))))
-                      (parent ,(menu-item-menu-name item))
+                      (menu ,(menu-item-menu-name item))
                       (callback (let ([,callback-name (lambda (item evt) (,callback-name item evt))])
                                   ,callback-name))
                       (shortcut ,key)
-                      (help (,(an-item->help-string-name item)))
+                      (help-string (,(an-item->help-string-name item)))
                       (demand-callback (lambda (menu-item) (,(an-item->on-demand-name item) menu-item)))))))))
   
   ;; build-after-super-clause : ((X -> symbol) -> X -> (listof clause))
@@ -187,4 +187,4 @@
             (reorder-menus this)))
        port))
     'text
-    'truncate))
+    'truncate))

collects/framework/private/scheme.ss

@@ -150,6 +150,15 @@
                       #f])
                    #f)))
            (scheme-paren:get-comments))))
+
+
+      (rename [super-on-close on-close])
+      (override on-close)
+      (define (on-close)
+	(remove-indents-callback)
+	(remove-paren-callback)
+	(super-on-close))
+
       (define remove-indents-callback
         (preferences:add-callback
          'framework:tabify
@@ -1038,4 +1047,4 @@
 		     (reset lambda-list-box lambda-keywords)
 		     #t))])
 	   (preferences:add-callback 'framework:tabify (lambda (p v) (update-list-boxes v)))
-	   main-panel))))))))
+	   main-panel))))))))

collects/framework/test.ss

@@ -5,9 +5,12 @@
 	   (lib "mred-sig.ss" "mred")
 	   (lib "mred.ss" "mred"))
 
-  (provide-signature-elements framework:test^)
+  (provide-signature-elements ((unit test : framework:test^)))
 
-  (define-values/invoke-unit/sig framework:test^
+  (define-values/invoke-unit/sig ((unit test : framework:test^))
-    framework:test@
+    (compound-unit/sig
+      (import [m : mred^])
+      (link [test : framework:test^ (framework:test@ m)])
+      (export (unit test)))
     #f
-    mred^))
+    mred^))

collects/tests/framework/README

@@ -114,5 +114,3 @@ test as last time, or `all' to run all of the tests.
 
 	
 |#)
-
-`(load.ss)

collects/tests/framework/canvas.ss

@@ -1,7 +1,10 @@
+(module canvas mzscheme
+  (require "test-suite-utils.ss")
+
 (define (test-creation class name)
   (test
    name
-   (lambda (x) #t)
+   (lambda (x) (eq? 'passed x))
    (lambda ()
      (send-sexp-to-mred
       `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)]
@@ -10,7 +13,8 @@
 	 (send f show #t)))
       (wait-for-frame "test canvas")
       (send-sexp-to-mred
-       `(send (get-top-level-focus-window) show #f)))))
+       `(send (get-top-level-focus-window) show #f))
+      'passed)))
 
 (test-creation '(canvas:basic-mixin editor-canvas%)
 	       'canvas:basic-mixin-creation)
@@ -21,3 +25,4 @@
 	       'canvas:wide-snip-mixin-creation)
 (test-creation 'canvas:wide-snip%
 	       'canvas:wide-snip%-creation)
+)

collects/tests/framework/debug.ss

@@ -1,44 +1,50 @@
 (module debug mzscheme
   (provide debug-printf debug-when)
 
-  ;; all of the steps in the tcp connection
+  (define-syntax debug-when
-  (define tcp? #f)
+    (lambda (stx)
 
-  ;; administrative messages about preferences files and
+      ;; all of the steps in the tcp connection
-  ;; command line flags
+      (define mz-tcp? #f)
-  (define admin? #f)
+      (define mr-tcp? mz-tcp?)
+      
+      ;; administrative messages about preferences files and
+      ;; command line flags
+      (define admin? #f)
+      
+      ;; tests that passed and those that failed
+      (define schedule? #t)
+      
+      ;; of the sexpression transactions between mz and mred
+      (define messages? #t)
 
-  ;; tests that passed and those that failed
+      (syntax-case stx (mr-tcp mz-tcp admin schedule messages)
-  (define schedule? #t)
+	[(_ mr-tcp rest ...)
-
+	 (if mr-tcp?
-  ;; of the sexpression transactions between mz and mred
+	     (syntax (begin rest ...))
-  (define messages? #t)
+	     (syntax (void)))]
+	[(_ mz-tcp rest ...)
+	 (if mz-tcp?
+	     (syntax (begin rest ...))
+	     (syntax (void)))]
+	[(_ admin rest ...)
+	 (if admin?
+	     (syntax (begin rest ...))
+	     (syntax (void)))]
+	[(_ schedule rest ...)
+	 (if schedule?
+	     (syntax (begin rest ...))
+	     (syntax (void)))]
+	[(_ messages rest ...)
+	 (if messages?
+	     (syntax (begin rest ...))
+	     (syntax (void)))]
+	[(_ unk rest ...)
+	 (raise-syntax-error 'debug-when "unknown flag" stx (syntax unk))])))
 
   (define-syntax debug-printf
     (lambda (stx)
       (syntax-case stx ()
 	[(_ flag fmt-string rest ...)
 	 (with-syntax ([flag-name (format ">> ~a: " (syntax-object->datum (syntax flag)))])
-	   (syntax (debug-when flag (printf (string-append flag-name fmt-string) rest ...))))])))
+	   (syntax (debug-when flag (printf (string-append flag-name fmt-string) rest ...))))]))))
-
-    (define-syntax debug-when
-      (lambda (stx)
-	(syntax-case stx (tcp admin schedule messages)
-	  [(_ tcp rest ...)
-	   (syntax
-	    (when tcp?
-	      rest ...))]
-	  [(_ admin rest ...)
-	   (syntax
-	    (when admin?
-	      rest ...))]
-	  [(_ schedule rest ...)
-	   (syntax
-	    (when schedule?
-	      rest ...))]
-	  [(_ messages rest ...)
-	   (syntax
-	    (when messages?
-	      rest ...))]
-	  [(_ unk rest ...)
-	   (raise-syntax-error 'debug-when "unknown flag" stx (syntax unk))]))))

collects/tests/framework/exit.ss

@@ -1,3 +1,6 @@
+(module exit mzscheme
+  (require "test-suite-utils.ss")
+
 (test 'exit/no-prompt
       (lambda (x)
 	(and (eq? x 'passed)
@@ -99,3 +102,4 @@
 	 (with-handlers ([eof-result? (lambda (x) 'passed)])
 	   (send-sexp-to-mred
 	    `(exit:exit))))))
+)

collects/tests/framework/frame.ss

@@ -1,50 +1,69 @@
-(define (test-creation name class-expression)
+(module frame mzscheme
+  (require "test-suite-utils.ss")
+
+(define (test-creation name class-expression . args)
   (test
    name
-   (lambda (x) x)
+   (lambda (x) (eq? 'passed x))
    (lambda ()
-     (send-sexp-to-mred
+     (let ([frame-label
-      `(begin (preferences:set 'framework:exit-when-no-frames #f)
+	    (send-sexp-to-mred
-	      (send (make-object ,class-expression "test") show #t)))
+	     `(let ([f (instantiate ,class-expression () ,@args)])
-     (wait-for-frame "test")
+		(preferences:set 'framework:exit-when-no-frames #f)
-     (queue-sexp-to-mred
+		(send f show #t)
-      '(send (get-top-level-focus-window) close))
+		(send f get-label)))])
-     #t)))
+       (wait-for-frame frame-label)
+       (queue-sexp-to-mred
+	'(send (get-top-level-focus-window) close))
+       'passed))))
 
 (test-creation
  'basic%-creation
- 'frame:basic%)
+ 'frame:basic%
+ '(label "test"))
 (test-creation
  'basic-mixin-creation
- '(frame:basic-mixin frame%))
+ '(frame:basic-mixin frame%)
+ '(label "test"))
 
 (test-creation
  'info-mixin-creation
- '(frame:info-mixin frame:basic%))
+ '(frame:info-mixin frame:basic%)
+ '(label "test"))
+
 (test-creation
  'info%-creation
- 'frame:info%)
+ 'frame:info%
+ '(label "test"))
 
 (test-creation
  'text-info-mixin-creation
- '(frame:text-info-mixin frame:info%))
+ '(frame:text-info-mixin frame:info%)
+ '(label "test"))
 (test-creation
  'text-info%-creation
- 'frame:text-info%)
+ 'frame:text-info%
+ '(label "test"))
 
 (test-creation
  'pasteboard-info-mixin-creation
- '(frame:pasteboard-info-mixin frame:info%))
+ '(frame:pasteboard-info-mixin frame:info%)
+ '(label "test"))
+
 (test-creation
  'pasteboard-info%-creation
- 'frame:pasteboard-info%)
+ 'frame:pasteboard-info%
+ '(label "test"))
 
 (test-creation
  'standard-menus%-creation
- 'frame:standard-menus%)
+ 'frame:standard-menus%
+ '(label "test"))
+
 (test-creation
  'standard-menus-mixin
- '(frame:standard-menus-mixin frame:basic%))
+ '(frame:standard-menus-mixin frame:basic%)
+ '(label "test"))
 
 (test-creation
  'text%-creation
@@ -95,15 +114,18 @@
     (test
      name
      (lambda (x)
-       (delete-file tmp-file)
+       (when (file-exists? tmp-file)
+	 (delete-file tmp-file))
        (equal? x test-file-contents))
      (lambda ()
-       (send-sexp-to-mred
+       (let ([frame-name 
-	`(begin
+	      (send-sexp-to-mred
-	   (preferences:set 'framework:exit-when-no-frames #f)
+	       `(let ([frame (instantiate ,class-expression ())])
-	   (preferences:set 'framework:file-dialogs 'common)
+		  (preferences:set 'framework:exit-when-no-frames #f)
-	   (send (make-object ,class-expression "test open") show #t)))
+		  (preferences:set 'framework:file-dialogs 'common)
-       (wait-for-frame "test open")
+		  (send frame show #t)
+		  (send frame get-label)))])
+       (wait-for-frame frame-name)
        (send-sexp-to-mred
 	`(test:menu-select "File" "Open..."))
        (wait-for-frame "Get file")
@@ -128,37 +150,10 @@
 		 [t (send (send w get-editor) get-text)])
 	    (test:close-top-level-window w)
 	    t))
-	(wait-for-frame "test open")
+	(wait-for-frame frame-name)
 	(queue-sexp-to-mred
-	 `(send (get-top-level-focus-window) close)))))))
+	 `(send (get-top-level-focus-window) close))))))))
 
 (test-open "frame:editor open" 'frame:text%)
 (test-open "frame:searchable open" 'frame:searchable%)
-(test-open "frame:text-info open" 'frame:text-info-file%)
+(test-open "frame:text-info open" 'frame:text-info-file%))
-
-(test
- "set!-ing menu callback in standard-menus-frame"
- (lambda (x) (eq? x 'passed))
- (lambda ()
-   (send-sexp-to-mred
-    `(let* ([set!-cb-frame%
-             (class frame:standard-menus% ()
-               (private [value 'failed])
-               (public
-                 [get-value
-                  (lambda () value)]
-                 [update-printing-proc 
-                  (lambda ()
-                    (set! file-menu:print 
-                          (lambda x (set! value 'passed))))])
-               (override
-                 [file-menu:print (lambda x (void))])
-               (sequence (super-init "set!-cb frame")))]
-            [f (make-object set!-cb-frame%)])
-       (send f update-printing-proc)
-       (send f show #t)))
-   (wait-for-frame "set!-cb frame")
-   (send-sexp-to-mred
-    `(test:menu-select "File" "Print..."))
-   (send-sexp-to-mred
-    `(send (get-top-level-focus-window) get-value))))

collects/tests/framework/framework-test-engine.ss

@@ -1,11 +1,9 @@
-(require (lib "errortrace.ss" "errortrace"))
+;(require (lib "errortrace.ss" "errortrace"))
 
 (module framework-test-engine mzscheme
   (require (lib "pconvert.ss")
 	   (lib "mred.ss" "mred")
-	   (lib "errortrace.ss" "errortrace")
+	   "debug.ss")
-	   "debug.ss"
-	   )
 
   (define errs null)
   (define sema (make-semaphore 1))
@@ -16,43 +14,50 @@
 
   (define (exception->string x)
     (if (exn? x)
-;	(let ([p (open-output-string)])
+	(let ([p (open-output-string)])
-;	  (print-error-trace p x)
+	  (parameterize ([current-error-port p])
-;	  (string-append (exn-message x) (string #\newline) (get-output-string p)))
+	    ((error-display-handler) (exn-message x) x))
-	(exn-message x)
+	  (get-output-string p))
-	(format "~s" x)))
+	(format "uncaught exn: ~s" x)))
 
   (thread
    (lambda ()
-     (let ([port (load
+     (with-handlers ([(lambda (x) #t)
-		  (build-path
+		      (lambda (x)
-		   (collection-path "tests" "framework")
+			(printf "test suite thread died: ~a~n"
-		   "receive-sexps-port.ss"))])
+				(if (exn? x)
-       (debug-printf tcp "about to connect to ~a~n" port)
+				    (exn-message x)
-       (let*-values ([(in out) (tcp-connect "127.0.0.1" port)])
+				    (format "~s" x))))])
-	 (let loop ()
+       (let ([port (load
-	   (debug-printf tcp "about to read~n")
+		    (build-path
-	   (let ([sexp (read in)])
+		     (collection-path "tests" "framework")
-	     (debug-printf tcp "got something~n")
+		     "receive-sexps-port.ss"))])
-	     (if (eof-object? sexp)
+	 (debug-printf mr-tcp "about to connect to ~a~n" port)
-		 (begin
+	 (let*-values ([(in out) (tcp-connect "127.0.0.1" port)])
-		   (close-input-port in)
+	   (let loop ()
-		   (close-output-port out)
+	     (debug-printf mr-tcp "about to read~n")
-		   (exit))
+	     (let ([sexp (read in)])
-		 (begin
+	       (if (eof-object? sexp)
-		   (write
+		   (begin
-		    (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
+		     (debug-printf mr-tcp "got eof~n")
-		      (if (null? these-errs)
+		     (close-input-port in)
-			  (with-handlers ([(lambda (x) #t) 
+		     (close-output-port out)
-					   (lambda (x) (list 'error (exception->string x)))])
+		     (exit))
-			    (list 'normal (print-convert (eval sexp))))
+		   (begin
-			  (list 'error
+		     (debug-printf mr-tcp "got expression to evaluate~n")
-				(apply string-append
+		     (write
-				       (map (lambda (x) (string-append (exception->string x) (string #\newline)))
+		      (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))])
-					    these-errs)))))
+			(if (null? these-errs)
-		    out)
+			    (with-handlers ([not-break-exn?
-		   (loop)))))))))
+					     (lambda (x) (list 'error (exception->string x)))])
-  
+			      (list 'normal (print-convert (eval sexp))))
+			    (list 'last-error
+				  (apply string-append
+					 (map (lambda (x) (string-append (exception->string x) (string #\newline)))
+					      these-errs)))))
+		      out)
+		     (loop))))))))))
+
   (let ([od (event-dispatch-handler)]
 	[port (current-output-port)])
     (event-dispatch-handler

collects/tests/framework/group-test.ss

@@ -1,3 +1,6 @@
+(module group-test mzscheme
+  (require "test-suite-utils.ss")
+
 (test
  'exit-off
  (lambda (x) (not (equal? x "test")))
@@ -140,3 +143,5 @@
 	(for-each (lambda (x) (send x close)) frames))))))
 
 
+
+)

collects/tests/framework/handler-test.ss

@@ -1,3 +1,6 @@
+(module handler-test mzscheme
+  (require "test-suite-utils.ss")
+
 (let* ([filename "framework-group-test.ss"]
        [tmp-filename (build-path (find-system-path 'temp-dir) filename)])
 
@@ -39,4 +42,6 @@
      (wait-for-frame filename)
      (send-sexp-to-mred
       `(let ([f (car (get-top-level-windows))])
-	 (send (send f get-editor) get-filename))))))
+	 (send (send f get-editor) get-filename))))))
+
+)

collects/tests/framework/keys.ss

@@ -1,3 +1,6 @@
+(module keys mzscheme
+  (require "test-suite-utils.ss")
+
 (test
  'keymap:aug-keymap%/get-table
  (lambda (x)
@@ -121,3 +124,5 @@
 		   (scheme:text-mixin text:basic%))])
 	       (sequence (super-init name)))
 	    scheme-specs)
+
+)

collects/tests/framework/mem.ss

@@ -1,4 +1,7 @@
-;; mem-boxes : (list-of (list string (list-of (weak-box TST))))
+(module mem mzscheme
+  (require "test-suite-utils.ss")
+
+; mem-boxes : (list-of (list string (list-of (weak-box TST))))
 (send-sexp-to-mred '(define mem-boxes null))
 
 (define mem-count 10)
@@ -32,13 +35,17 @@
             [anything? #f])
         (for-each
          (lambda (boxl)
-           (let* ([tag (first boxl)]
+           (let* ([tag (car boxl)]
-                  [boxes (second boxl)]
+                  [boxes (cadr boxl)]
                   [calc-results
                    (lambda ()
-                     (foldl (lambda (b n) (if (weak-box-value b) (+ n 1) n))
+		     (let loop ([boxes boxes]
-                            0
+				[n 0])
-                            boxes))])
+		       (cond
+			 [(null? boxes) n]
+			 [else (if (weak-box-value (car boxes))
+				   (loop (cdr boxes) (+ n 1))
+				   (loop (cdr boxes) n))])))])
 	     (let loop ([tries 16])
 	       (unless (zero? tries)
 		 (when (> (calc-results) 0)
@@ -117,3 +124,4 @@
 ;(test-frame-allocate 'frame:pasteboard%)
 ;(test-frame-allocate 'frame:pasteboard-info-file%)
 (done)
+)

collects/tests/framework/panel.ss

@@ -1,61 +1,66 @@
+(module panel mzscheme
+  (require "test-suite-utils.ss")
+
 (test 
  'single-panel
  (lambda (x) (eq? x 'passed))
  `(let* ([semaphore (make-semaphore 0)]
 	 [semaphore-frame%
-	  (class frame% args
+	  (class frame% 
-	    (override
+	    (override on-close)
-	     [on-close (lambda () (semaphore-post semaphore))])
+	    [define on-close (lambda () (semaphore-post semaphore))]
-	    (sequence
+	    (super-instantiate ()))]
-	      (apply super-init args)))]
 	 [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% (lines parent label stretchable-width? stretchable-height?)
+	  (class canvas% 
+	    (init-field lines)
+	    (init label)
 	    (inherit get-dc get-client-size)
-	    (override
+	    (override on-paint)
-	     [on-paint
+	    (define (on-paint)
-	      (lambda ()
+	      (let-values ([(width height) (get-client-size)])
-		(let-values ([(width height) (get-client-size)])
+		(let ([dc (get-dc)]
-		  (let ([dc (get-dc)]
+		      [single-width (/ width lines)]
-			[single-width (/ width lines)]
+		      [single-height (/ height lines)])
-			[single-height (/ height lines)])
+		  (send dc set-pen black-pen)
-		    (send dc set-pen black-pen)
+		  (let loop ([i lines])
-		    (let loop ([i lines])
+		    (cond
-		      (cond
+		      [(zero? i) (void)]
-			[(zero? i) (void)]
+		      [else
-			[else
+		       (let loop ([j lines])
-			 (let loop ([j lines])
+			 (cond
-			   (cond
+			   [(zero? j) (void)]
-			     [(zero? j) (void)]
+			   [else 
-			     [else 
+			    (send dc set-brush
-			      (send dc set-brush
+				  (if (= 0 (modulo (+ i j) 2))
-				    (if (= 0 (modulo (+ i j) 2))
+				      blue-brush green-brush))
-					blue-brush green-brush))
+			    (send dc draw-rectangle
-			      (send dc draw-rectangle
+				  (* single-width (- i 1))
-				    (* single-width (- i 1))
+				  (* single-height (- j 1))
-				    (* single-height (- j 1))
+				  single-width
-				    single-width
+				  single-height)
-				    single-height)
+			    (loop (- j 1))]))
-			      (loop (- j 1))]))
+		       (loop (- i 1))])))))
-			 (loop (- i 1))])))))])
+	    (super-instantiate ())
-	    (inherit set-label min-width min-height stretchable-height stretchable-width)
+
-	    (sequence
+	    ;; soon to be obsolete, hopefully.
-	      (super-init parent)
+	    (inherit set-label)
-	      (stretchable-width stretchable-width?)
+	    (set-label label)
-	      (stretchable-height stretchable-height?)
+
-	      (min-width 50)
+	    (inherit min-width min-height)
-	      (min-height 50)
+	    (min-width 50)
-	      (set-label label)))]
+	    (min-height 50))]
-	  
 	 [border-panel (make-object horizontal-panel% f '(border))]
 	 [single-panel (make-object panel:single% border-panel)]
-	 [children (list (make-object grid-canvas% 3 single-panel "Small" #f #f)
+	 [children
-			 (make-object grid-canvas% 3 single-panel "Wide" #f #t)
+	  (list
-			 (make-object grid-canvas% 3 single-panel "Tall" #t #f)
+	   (instantiate grid-canvas% () (lines 3) (parent single-panel) (label "Small") (stretchable-width #f) (stretchable-height #f))
-			 (make-object grid-canvas% 3 single-panel "Wide and Tall" #t #t))]
+	   (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
@@ -128,3 +133,4 @@
     (yield semaphore)
     (send f show #f)
     result))
+)

collects/tests/framework/pasteboard.ss

@@ -1,20 +1,24 @@
+(module pasteboard mzscheme
+  (require "test-suite-utils.ss")
+
 (define (test-creation frame class name)
   (test
    name
    (lambda (x) #t)
    (lambda ()
-     (send-sexp-to-mred
+     (let ([frame-label
-      `(let* ([% (class-asi ,frame
+	    (send-sexp-to-mred
-		   (override
+	     `(let* ([% (class ,frame
-		     [get-editor%
+			  (override get-editor%)
-		      (lambda ()
+			  [define (get-editor%)
-			,class)]))]
+			    ,class])]
-	      [f (make-object % "test pasteboard")])
+		     [f (instantiate % ())])
-	 (preferences:set 'framework:exit-when-no-frames #f)
+		(preferences:set 'framework:exit-when-no-frames #f)
-	 (send f show #t)))
+		(send f show #t)
-      (wait-for-frame "test pasteboard")
+		(send f get-label)))])
-      (queue-sexp-to-mred
+       (wait-for-frame frame-label)
-       `(send (get-top-level-focus-window) close)))))
+       (queue-sexp-to-mred
+	`(send (get-top-level-focus-window) close))))))
 
 (test-creation 'frame:editor%
 	       '(editor:basic-mixin pasteboard%)
@@ -43,3 +47,4 @@
 (test-creation 'frame:pasteboard%
 	       'pasteboard:info%
 	       'pasteboard:info-creation)
+)

collects/tests/framework/prefs.ss

@@ -1,3 +1,9 @@
+(module prefs mzscheme
+  (require "test-suite-utils.ss"
+	   (lib "etc.ss")
+	   (lib "list.ss"))
+  
+
 (local [(define pref-file (build-path (find-system-path 'pref-dir)
 				      (case (system-type)
 					[(macos) "MrEd Preferences"]
@@ -34,7 +40,14 @@
 		(preferences:get ',pref-sym)))
 
   (with-handlers ([eof-result? (lambda (x) (void))])
-    (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f) (exit:exit))))
+    (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f)
+			       (exit:exit)
+
+			       ;; do this yield here so that exit:exit
+			       ;; actually exits on this interaction.
+			       ;; right now, exit:exit queue's a new event to exit
+			       ;; instead of just exiting immediately.
+			       (yield (make-semaphore 0)))))
 
   (test 'preference-get-after-restart
 	(check-eq? 'new-pref)
@@ -45,7 +58,8 @@
 (test 'dialog-appears
       (lambda (x) (eq? 'passed x))
       (lambda ()
-	(send-sexp-to-mred '(preferences:show-dialog))
+	(send-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)])
@@ -54,3 +68,5 @@
 					     'failed
 					     'passed)
 					 'passed))))))
+)
+

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

@@ -63,39 +63,37 @@
   (define listener
     (let loop ()
       (let ([port (load port-filename)])
-	(with-handlers ([(lambda (x) #t)
+	(with-handlers ([not-break-exn?
 			 (lambda (x)
 			   (let ([next (+ port 1)])
 			     (call-with-output-file port-filename
 			       (lambda (p)
 				 (write next p))
 			       'truncate)
-			     (debug-printf tcp "  tcp-listen failed for port ~a, attempting ~a~n"
+			     (debug-printf mz-tcp "  tcp-listen failed for port ~a, attempting ~a~n"
 					   port
 					   next)
 			     (loop)))])
-	  (debug-printf tcp "listening to ~a~n" port)
+	  (debug-printf mz-tcp "listening to ~a~n" port)
 	  (tcp-listen port)))))
 
   (define in-port #f)
   (define out-port #f)
 
-  (define restart-mred
+  (define (restart-mred)
-    (lambda ()
+    (shutdown-mred)
-      (shutdown-mred)
+    ((case (system-type)
-      ((case (system-type)
+       [(macos) system*]
-	 [(macos) system*]
+       [else (lambda (x) (thread (lambda () (system* x))))])
-	 [else (lambda (x) (thread (lambda () (system* x))))])
+     (mred-program-launcher-path "Framework Test Engine"))
-       (mred-program-launcher-path "Framework Test Engine"))
+    (debug-printf mz-tcp "accepting listener~n")
-      (debug-printf tcp "accepting listener~n")
+    (let-values ([(in out) (tcp-accept listener)])
-      (let-values ([(in out) (tcp-accept listener)])
+      (set! in-port in)
-	(set! in-port in)
+      (set! out-port out))
-	(set! out-port out))
+    (when load-framework-automatically?
-      (when load-framework-automatically?
+      (queue-sexp-to-mred
-	(queue-sexp-to-mred
+       '(begin (eval '(require (lib "framework.ss" "framework")))
-	 `(begin
+	       (eval '(require (lib "gui.ss" "tests" "utils")))))))
-	    (require (lib "framework.ss" "framework")
-		     (lib "gui.ss" "tests" "utils")))))))
 
   (define load-framework-automatically
     (case-lambda
@@ -109,16 +107,16 @@
   (define shutdown-listener
     (lambda ()
       (shutdown-mred)
-      (debug-printf tcp "closing listener~n")
+      (debug-printf mz-tcp "closing listener~n")
       (tcp-close listener)))
 
   (define shutdown-mred
     (lambda ()
       (when (and in-port
 		 out-port)
-	(with-handlers ([(lambda (x) #t) (lambda (x) (void))])
+	(with-handlers ([not-break-exn? (lambda (x) (void))])
 	  (close-output-port out-port))
-	(with-handlers ([(lambda (x) #t) (lambda (x) (void))])
+	(with-handlers ([not-break-exn? (lambda (x) (void))])
 	  (close-input-port in-port))
 	(set! in-port #f)
 	(set! in-port #f))))
@@ -145,83 +143,84 @@
     (or (regexp-match re:tcp-read-error (exn-message exn))
 	(regexp-match re:tcp-write-error (exn-message exn))))
 
-  (define send-sexp-to-mred
+  (define (send-sexp-to-mred sexp)
-    (let ([failed-last-time? #f])
+    (let/ec k
-      (lambda (sexp)
+      (let ([show-text 
-	(let/ec k
+	     (lambda (sexp)
-	  (let ([show-text 
+	       
-		 (lambda (sexp)
+	       (debug-when messages
-		   
+			   (parameterize ([pretty-print-print-line
-		   (debug-when messages
+					   (let ([prompt "  "]
-		     (parameterize ([pretty-print-print-line
+						 [old-liner (pretty-print-print-line)])
-				     (let ([prompt "  "]
+					     (lambda (ln port ol cols)
-					   [old-liner (pretty-print-print-line)])
+					       (let ([ov (old-liner ln port ol cols)])
-				       (lambda (ln port ol cols)
+						 (if ln 
-					 (let ([ov (old-liner ln port ol cols)])
+						     (begin (display prompt port)
-					   (if ln 
+							    (+ (string-length prompt) ov))
-					       (begin (display prompt port)
+						     ov))))])
-						      (+ (string-length prompt) ov))
+			     (pretty-print sexp)
-					       ov))))])
+			     (newline))))])
-		       (pretty-print sexp)
+	(unless (and in-port
-		       (newline))))])
+		     out-port
-	    (unless (and in-port
+		     (with-handlers ([tcp-error?
-			 out-port
+				      (lambda (x) #f)])
-			 (with-handlers ([tcp-error?
+		       (or (not (char-ready? in-port))
-					  (lambda (x) #f)])
+			   (not (eof-object? (peek-char in-port))))))
-			   (or (not (char-ready? in-port))
+	  (restart-mred))
-			       (not (eof-object? (peek-char in-port))))))
+	(debug-printf messages "  ~a // ~a: sending to mred:~n" section-name test-name)
-	      (restart-mred))
+	(show-text sexp)
-	    (debug-printf messages "  ~a // ~a: sending to mred:~n" section-name test-name)
+	(with-handlers ([not-break-exn?
-	    (show-text sexp)
+			 (lambda (x)
-	    (with-handlers ([(lambda (x) #t)
+			   (cond
-			     (lambda (x)
+			     ;; this means that mred was closed
-			       (cond
+			     ;; so we can restart it and try again.
-				;; this means that mred was closed
+			     [(tcp-error? x) 
-				;; so we can restart it and try again.
+			      (restart-mred)
-				[(tcp-error? x) 
+			      (write sexp out-port)
-				 (restart-mred)
+			      (newline out-port)]
-				 (write sexp out-port)
+			     [else (raise x)]))])
-				 (newline out-port)]
+	  (write sexp out-port)
-				[else (raise x)]))])
+	  (newline out-port))
-	      (write sexp out-port)
+	(let ([answer
-	      (newline out-port))
+	       (with-handlers ([not-break-exn?
-	    (let ([answer
+				(lambda (x)
-		   (with-handlers ([(lambda (x) #t)
+				  (if (tcp-error? x);; assume tcp-error means app closed
-				    (lambda (x)
+				      eof
-				      (if (tcp-error? x);; assume tcp-error means app closed
+				      (list 'cant-read
-					  eof
+					    (string-append
-					  (list 'cant-read
+					     (exn-message x)
-						(string-append
+					     "; rest of string: "
-						 (exn-message x)
+					     (format
-						 "; rest of string: "
+					      "~s"
-						 (format
+					      (apply
-						  "~s"
+					       string
-						  (apply
+					       (let loop ()
-						   string
+						 (if (char-ready? in-port)
-						   (let loop ()
+						     (let ([char (read-char in-port)])
-						     (if (char-ready? in-port)
+						       (if (eof-object? char)
-							 (let ([char (read-char in-port)])
+							   null
-							   (if (eof-object? char)
+							   (cons char (loop))))
-							       null
+						     null))))))))])
-							       (cons char (loop))))
+		 (read in-port))])
-							 null))))))))])
+	  (debug-printf messages "  ~a // ~a: received from mred:~n" section-name test-name)
-		     (read in-port))])
+	  (show-text answer)
-	      (unless (or (eof-object? answer)
+	  (unless (or (eof-object? answer)
-			  (and (list? answer)
+		      (and (list? answer)
-			       (= 2 (length answer))))
+			   (= 2 (length answer))
-		(error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
+			   (memq (car answer)
-	      (if (eof-object? answer)
+				 '(error last-error cant-read normal))))
-		  (raise (make-eof-result))
+	    (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
-		  (case (car answer)
+	  (if (eof-object? answer)
-		    [(error)
+	      (raise (make-eof-result))
-		     (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))]
+	      (case (car answer)
-		    [(cant-read) (error 'mred/cant-parse (second answer))]
+		[(error)
-		    [(normal) 
+		 (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))]
-		     (debug-printf messages "  ~a // ~a: received from mred:~n" section-name test-name)
+		[(last-error)
-		     (show-text (second answer))
+		 (error 'send-sexp-to-mred "mred (last time) raised \"~a\"" (second answer))]
-		     (eval (second answer))]))))))))
+		[(cant-read) (error 'mred/cant-parse (second answer))]
+		[(normal) 
+		 (eval (second answer))]))))))
 
-  
   (define test
     (case-lambda
      [(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)]
@@ -230,7 +229,7 @@
 	(when (or (not only-these-tests)
 		  (memq test-name only-these-tests))
 	  (let* ([result
-		  (with-handlers ([(lambda (x) #t)
+		  (with-handlers ([not-break-exn?
 				   (lambda (x)
 				     (if (exn? x)
 					 (exn-message x)
@@ -239,7 +238,14 @@
 			(sexp/proc)
 			(begin0 (send-sexp-to-mred sexp/proc)
 				(send-sexp-to-mred ''check-for-errors))))]
-		 [failed (not (passed? result))])
+		 [failed (with-handlers ([not-break-exn?
+					  (lambda (x)
+					    (string-append
+					     "passed? test raised exn: "
+					     (if (exn? x)
+						 (exn-message x)
+						 (format "~s" x))))])
+			   (not (passed? result)))])
 	    (when failed
 	      (debug-printf schedule "FAILED ~a:~n  ~s~n" test-name result)
 	      (set! failed-tests (cons (cons section-name test-name) failed-tests))

collects/tests/framework/text.ss

@@ -1,23 +1,30 @@
+(module text mzscheme
+  (require "test-suite-utils.ss")
+
 (define (test-creation frame% class name)
   (test
    name
-   (lambda (x) #t)
+   (lambda (x) (eq? x 'passed))
    (lambda ()
-     (send-sexp-to-mred
+     (let ([label
-      `(let* ([% (class-asi ,frame%
+	    (send-sexp-to-mred
-		   (override
+	     `(let ([f (instantiate (class ,frame%
-		    [get-editor% (lambda () ,class)]))]
+				      (override get-editor%)
-	      [f (make-object % "test text")])
+				      [define (get-editor%) ,class]
-	 (preferences:set 'framework:exit-when-no-frames #f)
+				      (super-instantiate ()))
-	 (send f show #t)))
+				    ())])
-     (wait-for-frame "test text")
+		(preferences:set 'framework:exit-when-no-frames #f)
-     (send-sexp-to-mred `(test:keystroke #\a))
+		(send f show #t)
-     (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
+		(send f get-label)))])
-     (send-sexp-to-mred
+       (wait-for-frame label)
-      `(begin (send (send (get-top-level-focus-window) get-editor) lock #t)
+       (send-sexp-to-mred `(test:keystroke #\a))
-	      (send (send (get-top-level-focus-window) get-editor) lock #f)))
+       (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text)))
-     (queue-sexp-to-mred
+       (send-sexp-to-mred
-      `(send (get-top-level-focus-window) close)))))
+	`(begin (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))
+       'passed))))
 
 
 (test-creation 'frame:text%
@@ -27,17 +34,6 @@
 	       'text:basic%
 	       'text:basic-creation)
 
-(define (return-args class)
-  `(class ,class ()
-     (sequence
-       (super-init void))))
-(test-creation 'frame:text%
-	       (return-args '(text:return-mixin text:basic%))
-	       'text:return-mixin-creation)
-(test-creation 'frame:text%
-	       (return-args 'text:return%)
-	       'text:return-creation)
-
 (test-creation 'frame:text%
 	       '(editor:file-mixin text:keymap%)
 	       'editor:file-mixin-creation)
@@ -67,4 +63,6 @@
 	       'text:info-mixin-creation)
 (test-creation '(frame:searchable-mixin frame:text%)
 	       'text:info%
-	       'text:info-creation)
+	       'text:info-creation)
+
+)