From 28d27a5074223e9ffd89ac13d6fc8b8e835e8a9a Mon Sep 17 00:00:00 2001
From: Mike Sperber <sperber@deinprogramm.de>
Date: Thu, 13 Aug 2009 06:42:40 +0000
Subject: [PATCH] Make sure the test results are displayed, even when an
 exception occurs running the tests.

svn: r15724
---
 collects/lang/run-teaching-program.ss |  2 +-
 collects/test-engine/scheme-gui.ss    | 12 +++++++++---
 collects/test-engine/scheme-tests.ss  | 10 +++++++++-
 3 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/collects/lang/run-teaching-program.ss b/collects/lang/run-teaching-program.ss
index b15db66059..c8b2d0e3e6 100644
--- a/collects/lang/run-teaching-program.ss
+++ b/collects/lang/run-teaching-program.ss
@@ -59,7 +59,7 @@
                             ,@(map (λ (x) `(require ,x)) teachpacks)
                             ,@body-exps
                             ,@(if enable-testing?
-                                  (if (null? body-exps) '() `((,#'run-tests) (,#'display-results)))
+                                  (if (null? body-exps) '() `((,#'test)))
                                   '()))))
               rep)))]
         [(require)
diff --git a/collects/test-engine/scheme-gui.ss b/collects/test-engine/scheme-gui.ss
index 67abef5d3d..f67b988755 100644
--- a/collects/test-engine/scheme-gui.ss
+++ b/collects/test-engine/scheme-gui.ss
@@ -1,7 +1,8 @@
 (module scheme-gui scheme/base
   
   (require mred framework scheme/class 
-           mzlib/pconvert mzlib/pretty)
+           mzlib/pconvert mzlib/pretty
+	   (for-syntax scheme/base))
   
   (require (except-in "scheme-tests.ss" test) "test-display.scm")
   
@@ -32,8 +33,13 @@
            text-snip))]
       [else (format "~v" value)]))
   
-  (define (test) (run-tests) (pop-up))
-  
+  (define-syntax (test stx) 
+    (syntax-case stx ()
+      [(_)
+       (syntax-property
+	#'(begin (run-tests) (pop-up))
+	'test-call #t)]))
+
   (define (pop-up)
     (let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
       (parameterize ([test-format format-value])
diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss
index d5d92aca98..5663e2a3a7 100644
--- a/collects/test-engine/scheme-tests.ss
+++ b/collects/test-engine/scheme-tests.ss
@@ -225,7 +225,15 @@
     (namespace-set-variable-value! 'test~object te (current-namespace))
     te))
 
-(define (test) (run-tests) (display-results))
+(define-syntax (test stx) 
+  (syntax-case stx ()
+    [(_)
+     (syntax-property
+      #'(dynamic-wind
+	    values
+	    (lambda () (run-tests))
+	    (lambda () (display-results)))
+      'test-call #t)]))
 
 (define-syntax (run-tests stx)
   (syntax-case stx ()