From 247262abbe13b29912a7197eb7b11f68cd5b331a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 23 May 2010 22:09:08 -0700
Subject: [PATCH] Add ASSERT-ERROR.  Small reorganization to improve
 readability.

---
 tests/unit-testing.scm | 69 ++++++++++++++++++++++--------------------
 1 file changed, 37 insertions(+), 32 deletions(-)

diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index 8620e4f4d..6375c5339 100644
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -29,15 +29,11 @@ USA.
 
 (define (run-unit-tests filename/s #!optional environment)
   (report-results
-   (map run-test-definition
+   (map run-unit-test
 	(load-unit-tests filename/s environment))))
 
 (define (load-unit-tests filename/s #!optional environment)
-  (let ((test-environment
-	 (if (default-object? environment)
-	     (make-top-level-environment)
-	     (extend-top-level-environment environment))))
-    (initialize-test-environment! test-environment)
+  (let ((test-environment (make-test-environment! environment)))
     (fluid-let ((*registered-tests* '()))
       (load filename/s test-environment)
       (reverse! *registered-tests*))))
@@ -49,32 +45,27 @@ USA.
 
 (define *registered-tests*)
 
-(define (initialize-test-environment! test-environment)
-  (for-each (lambda (p)
-	      (environment-define test-environment (car p) (cdr p)))
-	    test-definitions))
-
-(define (add-test-definition name value)
-  (let ((p (assq name test-definitions)))
-    (if p
-	(set-cdr! p value)
-	(begin
-	  (set! test-definitions (cons (cons name value) test-definitions))
-	  unspecific))))
-
-(define test-definitions '())
-
 (define (test? object)
   (or (thunk? object)
       (list-of-type? object test?)))
 
 (define-guarantee test "test")
 
-(define (run-test-definition td)
+(define (make-test-environment! #!optional parent)
+  (let ((test-environment
+	 (if (default-object? parent)
+	     (make-top-level-environment)
+	     (extend-top-level-environment parent))))
+    (for-each (lambda (p)
+		(environment-define test-environment (car p) (cdr p)))
+	      test-definitions)
+    test-environment))
+
+(define (run-unit-test name.test)
   ;; Runs sub-tests in left-to-right order.
-  (cons (car td)
+  (cons (car name.test)
 	(reverse!
-	 (let loop ((test (cdr td)) (name "") (results '()))
+	 (let loop ((test (cdr name.test)) (name "") (results '()))
 	   (cond ((thunk? test)
 		  (cons (cons name (run-test-thunk test))
 			results))
@@ -225,6 +216,16 @@ USA.
 	 (,(rename 'DEFINE) ,name ,value)
 	 (,(rename 'ADD-TEST-DEFINITION) ',name ,name))))))
 
+(define (add-test-definition name value)
+  (let ((p (assq name test-definitions)))
+    (if p
+	(set-cdr! p value)
+	(begin
+	  (set! test-definitions (cons (cons name value) test-definitions))
+	  unspecific))))
+
+(define test-definitions '())
+
 (define-for-tests (define-test name test . tests)
   (register-test name
 		 (if (null? tests)
@@ -232,13 +233,6 @@ USA.
 		     (cons test tests)))
   name)
 
-(define (flatten tests)
-  (append-map! (lambda (test)
-		 (if (list? test)
-		     (flatten test)
-		     (list test)))
-	       tests))
-
 (define-for-tests (predicate-assertion predicate description)
   (lambda (value . properties)
     (if (predicate value)
@@ -288,4 +282,15 @@ USA.
 (define-for-tests assert-< (binary-assertion <))
 (define-for-tests assert-<= (binary-assertion <=))
 (define-for-tests assert-> (binary-assertion >))
-(define-for-tests assert->= (binary-assertion >=))
\ No newline at end of file
+(define-for-tests assert->= (binary-assertion >=))
+
+(define-for-tests (assert-error thunk condition-types . properties)
+  (call-with-current-continuation
+   (lambda (k)
+     (apply make-failure
+	    'RESULT-OBJECT 
+	    (bind-condition-handler condition-types
+		(lambda (condition)
+		  (k #f))
+	      thunk)
+	    properties))))
\ No newline at end of file
-- 
2.25.1