...

original commit: 4f8c6a5fa391304e17cc5d2ebbfaad806e97d512

collects/tests/framework/main.ss

@@ -5,17 +5,8 @@
 	   "test-suite-utils.ss"
 	   (lib "guis.ss" "tests" "utils"))
 
-  (provide
-   only-these-tests
-   section-name
-   section-jump)
-
   (define initial-port 6012)
 
-  (define section-jump void)
-  (define section-name "<<setup>>")
-  (define only-these-tests #f)
-
   (unless (file-exists? (build-path (current-load-relative-directory) "receive-sexps-port.ss"))
     (call-with-output-file (build-path (current-load-relative-directory) "receive-sexps-port.ss")
       (lambda (port)
@@ -44,8 +35,8 @@
 	      (multi
 	       [("-o" "--only")
 		,(lambda (flag _only-these-tests)
-		   (set! only-these-tests (cons (string->symbol _only-these-tests)
+		   (set-only-these-tests (cons (string->symbol _only-these-tests)
-						(or only-these-tests null))))
+					       (or only-these-tests null))))
 		("Only run test named <test-name>" "test-name")]))])
       
       (let* ([saved-command-line-file (build-path (collection-path "tests" "framework") "saved-command-line.ss")]
@@ -74,21 +65,28 @@
 	    (begin (copy-file preferences-file old-preferences-file)
 		   (printf "  saved preferences file~n"))))
       
-      (for-each (lambda (x)
+      (for-each
-		  (when (member x all-files)
+       (lambda (x)
-		    (shutdown-mred)
+	 (when (member x all-files)
-		    (let/ec k
+	   (shutdown-mred)
-		      (fluid-let ([section-name x]
+	   (let/ec k
-				  [section-jump k])
+	     (dynamic-wind
-			(with-handlers ([(lambda (x) #t)
+	      (lambda ()
-					 (lambda (exn)
+		(set-section-name! x)
-					   (printf "~a~n" (if (exn? exn) (exn-message exn) exn)))])
+		(set-section-jump k))
-			  (printf "beginning ~a test suite~n" x)
+	      (lambda ()
+		(with-handlers ([(lambda (x) #t)
+				 (lambda (exn)
+				   (printf "~a~n" (if (exn? exn) (exn-message exn) exn)))])
+		  (printf "beginning ~a test suite~n" x)
 
-			  (eval `(require ,x))
+		  (eval `(require ,x))
-			  
+		  
-			  (printf "PASSED ~a test suite~n" x))))))
+		  (printf "PASSED ~a test suite~n" x)))
-		files-to-process)))
+	      (lambda ()
+		(reset-section-name!)
+		(reset-section-jump!))))))
+       files-to-process)))
 
   (printf "  restoring preferences file ~s to ~s~n" old-preferences-file preferences-file)
   (when (file-exists? preferences-file)

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

@@ -6,7 +6,10 @@
   (provide
    test-name
    failed-tests
-   (struct eof-result ())
+
+   ;(struct eof-result ())
+   eof-result?
+
    load-framework-automatically
    shutdown-listener shutdown-mred mred-running?
    send-sexp-to-mred queue-sexp-to-mred
@@ -17,7 +20,24 @@
    ;; grabs the frontmost window, executes the sexp and waits for a new frontmost window
    wait-for-new-frame
 
-   wait-for)
+   wait-for
+
+   reset-section-jump!
+   set-section-jump!
+   reset-section-name!
+   set-section-name!
+   set-only-these-tests!)
+
+  (define section-jump void)
+  (define (set-section-jump! _s) (set! section-jump _s))
+  (define (reset-section-jump!) (set! section-jump #f))
+
+  (define section-name "<<setup>>")
+  (define (set-section-name! _s) (set! section-name _s))
+  (define (reset-section-name!) (set! section-name "<<setup>>"))
+
+  (define only-these-tests #f)
+  (define (set-only-these-tests! _t) (set! only-these-tests _t))
 
   (define test-name "<<setup>>")
   (define failed-tests null)
@@ -48,11 +68,10 @@
   (define restart-mred
     (lambda ()
       (shutdown-mred)
-      (let-values ([(base _1 _2) (split-path program)])
+      ((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")))
       (let-values ([(in out) (tcp-accept listener)])
 	(set! in-port in)
 	(set! out-port out))