...

original commit: c77b722631d483cb8dcf7df518f2366d6cbd9c78

collects/framework/framework.ss

@@ -2,7 +2,7 @@
 (compile-allow-cond-fallthrough #t)
 (compile-allow-set!-undefined #t)
 (require-library "mred-interfaces.ss" "framework")
-(require-library "framework.ss" "framework")
+(require-library "frameworks.ss" "framework")
 (invoke-open-unit/sig
  (compound-unit/sig
    (import)

collects/framework/guiutils.ss

@@ -107,42 +107,33 @@
   
   (define get-choice
     (opt-lambda (message true-choice false-choice [title "Warning"])
-      (let* ([result (void)]
+      (letrec ([result (void)]
-	     [choice-dialog%
+	       [dialog (make-object dialog% title)]
-	      (class dialog% ()
+	       [on-true
-		(inherit show center)
+		(lambda args
-		(private
+		  (set! result #t)
-		  [on-true
+		  (send dialog show #f))]
-		   (lambda args
+	       [on-false
-		     (set! result #t)
+		(lambda rags
-		     (show #f))]
+		  (set! result #f)
-		  [on-false
+		  (send dialog show #f))]
-		   (lambda rags
+	       [vp (make-object vertical-panel% dialog)]
-		     (set! result #f)
+	       [hp (make-object horizontal-panel% dialog)])
-		     (show #f))])
-		(sequence
-		  (super-init () title #t -1 -1)
-		  (let* ([messages
-			  (let loop ([m message])
-			    (let ([match (regexp-match (format "([^~n]*)~n(.*)")
-						       m)])
-			      (if match
-				  (cons (cadr match)
-					(loop (caddr match)))
-				  (list m))))]
-			 [msgs (map
-				(lambda (message)
-				  (begin0
-				   (make-object message% this message)))
-				messages)])
 
-		    (send (make-object button% true-choice this on-true) focus)
+	(let loop ([m message])
-		    (make-object button% false-choice this on-false)
+	  (let ([match (regexp-match (format "^([^~n]*)~n(.*)")
+				     m)])
+	    (if match
+		(begin (make-object message% (cadr match) vp)
+		       (loop (caddr match)))
+		(make-object message% m vp))))
 
-		  (center 'both)
+	(send vp set-alignment 'left 'center)
-		  
+	(send hp set-alignment 'right 'top)
-		  (show #t))))])
+	(send (make-object button% true-choice hp on-true) focus)
-	(make-object choice-dialog%)
+	(make-object button% false-choice hp on-false)
+	(send dialog center 'both)
+	(send dialog show #t)
 	result)))
 
   (define read-snips/chars-from-buffer

collects/tests/framework/README

@@ -11,6 +11,14 @@ There will be a main mzscheme process which will start up a new mred
 as necessary for the test suites. Since some tests actually require
 mred to exit in order to pass, this governor is required. 
 
+To run a test use:
+
+   framework-test <test.ss> ...
+
+where or <test.ss> is the name of one of the tests
+below. Alternatively, pass no command-line arguments to run all of the
+tests.
+
 - exit: |# exit.ss #|
 
   | This tests that exit:exit really exits and that the exit callbacks

collects/tests/framework/exit.ss

@@ -1,7 +1,17 @@
-(send-sexp-to-mred '(exit:exit))
+(test 'exit:exit
-(let loop ()
+      (lambda (x) (not (and (eq? x 'passed)
-  (sleep 3)
+			    (not (mred-running?)))))
-  (when (mred-running?)
+      (lambda ()
-    (printf "still running~n")
+	(with-handlers ([eof-result? (lambda (x) 'passed)])
-    (loop)))
+	  (send-sexp-to-mred '(preferences:set 'framework:verify-exit #f))
-(printf "not running~n")
+	  (send-sexp-to-mred '(exit:exit))
+	  'failed)))
+
+(test 'exit:exit
+      (lambda (x) (not (and (eq? x 'passed)
+			    (not (mred-running?)))))
+      (lambda ()
+	(with-handlers ([eof-result? (lambda (x) 'passed)])
+	  (send-sexp-to-mred '(preferences:set 'framework:verify-exit #t))
+	  (send-sexp-to-mred '(exit:exit))
+	  'failed)))

collects/tests/framework/main.ss

@@ -27,6 +27,8 @@
     (lambda (port)
       (write 6012 port))))
 
+(define-struct eof-result ())
+
 (define-values (shutdown-listener shutdown-mred mred-running? send-sexp-to-mred)
   (let ([listener
 	 (let loop ()
@@ -69,9 +71,14 @@
 	   (set! in-port #f)
 	   (set! in-port #f)))
        (lambda ()
-	 (not (eof-object? (peek-char in-port))))
+	 (if (char-ready? in-port)
+	     (not (eof-object? (peek-char in-port)))
+	     #t))
        (lambda (sexp)
-	 (unless (and in-port out-port)
+	 (unless (and in-port
+		      out-port
+		      (or (not (char-ready? in-port))
+			  (not (eof-object? (peek-char in-port)))))
 	   (restart-mred))
 	 (write sexp out-port)
 	 (newline out-port)
@@ -89,13 +96,17 @@
 								 (loop))
 							   null))))))])
 		  (read in-port))])
-	   (unless (and (list? answer)
+	   (unless (or (eof-object? answer)
-			(= 2 (length answer)))
+		       (and (list? answer)
-	     (error 'framework-test-suite "unpected result from mred: ~s~n" answer))
+			    (= 2 (length answer))))
-	   (case (car answer)
+	     (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer))
-	     [(error) (error 'mred (format "~a; input: ~s" (second answer) sexp))]
+	   (if (eof-object? answer)
-	     [(cant-read) (error 'mred/cant-parse (second answer))]
+	       (raise (make-eof-result))
-	     [(normal) (second answer)])))))))
+	       (case (car answer)
+		 [(error)
+		  (error 'send-sexp-to-mred (format "mred raised \"~a\" with input: ~s" (second answer) sexp))]
+		 [(cant-read) (error 'mred/cant-parse (second answer))]
+		 [(normal) (second answer)]))))))))
 
 (define section-jump void)
 
@@ -107,7 +118,10 @@
 			      (if (exn? x)
 				  (exn-message x)
 				  x))])
-	     (failed? (eval (send-sexp-to-mred test))))])
+	     (failed?
+	      (if (procedure? test)
+		  (test)
+		  (eval (send-sexp-to-mred test)))))])
       (when failed
 	(printf "FAILED ~a: ~a~n" test-name failed)
 	(case jump
@@ -115,6 +129,22 @@
 	  [(continue) (void)]
 	  [else (jump)])))))
 
+(define preferences-file (build-path (find-system-path 'pref-dir)
+				     (case (system-type)
+				       [(macos) "MrEd Preferences"]
+				       [(windows) "mred.pre"]
+				       [(unix) ".mred.prefs"])))
+(define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)])
+			       (build-path base (string-append name ".save"))))
+					 
+
+(when (file-exists? preferences-file)
+  (printf "saving preferences file ~s to ~s~n" preferences-file old-preferences-file)
+  (when (file-exists? old-preferences-file)
+    (error 'framework-test "backup preferences file exists, aborting"))
+  (printf "saved preferences file~n")
+  (copy-file preferences-file old-preferences-file))
+
 (let ([all-files (map symbol->string (load-relative "README"))])
   (for-each (lambda (x)
 	      (when (member x all-files)
@@ -130,5 +160,13 @@
 	    (if (equal? (vector) argv)
 		all-files
 		(vector->list argv))))
+(printf "restoring preferences file ~s to ~s~n" old-preferences-file preferences-file)
+(when (file-exists? preferences-file)
+  (unless (file-exists? old-preferences-file)
+    (error 'framework-test "lost preferences file backup!"))
+  (delete-file preferences-file)
+  (copy-file old-preferences-file preferences-file)
+  (delete-file old-preferences-file))
+(printf "restored preferences file~n")
 
 (shutdown-listener)