From ed1432fb3549f4a1012e1e3cff71fd9c874f8dfc Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 6 Jan 2017 19:45:41 -0800
Subject: [PATCH] Enhance test framework with some useful utilities.

---
 tests/load.scm         |  7 +++++--
 tests/unit-testing.scm | 40 ++++++++++++++++++++++++++++++++++------
 2 files changed, 39 insertions(+), 8 deletions(-)

diff --git a/tests/load.scm b/tests/load.scm
index c1ae22e73..14e9e0a97 100644
--- a/tests/load.scm
+++ b/tests/load.scm
@@ -25,7 +25,7 @@ USA.
 |#
 
 (let ((environment (make-top-level-environment)))
-  (environment-link-name environment '(runtime mit-macros) 'PARSE-DEFINE-FORM)
+  (environment-link-name environment '(runtime mit-macros) 'parse-define-form)
   (load (merge-pathnames "unit-testing" (current-load-pathname))
 	environment)
   (for-each (lambda (name)
@@ -33,4 +33,7 @@ USA.
 		  (unbind-variable system-global-environment name))
 	      (link-variables system-global-environment name
 			      environment name))
-	    '(RUN-UNIT-TEST RUN-UNIT-TESTS THROW-TEST-ERRORS?)))
\ No newline at end of file
+	    '(run-unit-test
+	      run-unit-tests
+	      show-passing-results?
+	      throw-test-errors?)))
\ No newline at end of file
diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index 66f933568..523a91ccf 100644
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -146,7 +146,7 @@ USA.
 
 ;;;; Reporting
 
-(define show-passing-results? #f)
+(define show-passing-results? (make-settable-parameter #f))
 
 (define (report-result test-name elapsed-time sub-test-results port)
   (let ((n-sub-test-results (length sub-test-results))
@@ -171,7 +171,7 @@ USA.
 				       (cdr sub-test-result)
 				       port)))
 	    sub-test-results))
-	  (show-passing-results?
+	  ((show-passing-results?)
 	   (fresh-line port)
 	   (write-char #\; port)
 	   (write test-name port)
@@ -293,7 +293,7 @@ USA.
 				 properties)))
 	    condition-type:error
 	    (lambda (condition)
-	      (if (not throw-test-errors?)
+	      (if (not (throw-test-errors?))
 		  (k (apply make-failure
 			    'CONDITION condition
 			    properties)))))
@@ -312,11 +312,11 @@ USA.
 			     properties))))
 	 condition-type:error
 	 (lambda (condition)
-	   (if (not throw-test-errors?)
+	   (if (not (throw-test-errors?))
 	       (apply fail 'CONDITION condition properties))))
    thunk))
 
-(define throw-test-errors? #f)
+(define throw-test-errors? (make-settable-parameter #f))
 
 (define (bind-condition-handlers bindings thunk)
   (if (pair? bindings)
@@ -399,11 +399,29 @@ USA.
   (binary-assertion (lambda (actual-value expected-list)
 		      (and (member actual-value expected-list) #t))))
 
+(define-for-tests (assert-list= = value expected . properties)
+  (if (not (and (list? value)
+		(= (length value) (length expected))
+		(every = value expected)))
+      (apply fail
+	     'RESULT-OBJECT value
+	     'EXPECTATION-OBJECT expected
+	     'EQUALITY-PREDICATE =
+	     properties)))
+
+(define-for-tests (assert-lset= = value expected . properties)
+  (if (not (lset= = value expected))
+      (apply fail
+	     'RESULT-OBJECT value
+	     'EXPECTATION-OBJECT expected
+	     'EQUALITY-PREDICATE =
+	     properties)))
+
 (define-for-tests (assert-error thunk condition-types . properties)
   (call-with-current-continuation
    (lambda (k)
      (apply fail
-	    'RESULT-OBJECT 
+	    'RESULT-OBJECT
 	    (bind-condition-handler condition-types
 		(lambda (condition)
 		  condition		;ignore
@@ -411,6 +429,16 @@ USA.
 	      thunk)
 	    properties))))
 
+(define-for-tests (error-assertion . condition-types)
+  (lambda (thunk . properties)
+    (apply assert-error thunk condition-types properties)))
+
+(define-for-tests assert-simple-error
+  (error-assertion condition-type:simple-error))
+
+(define-for-tests assert-wta-error
+  (error-assertion condition-type:wrong-type-argument))
+
 (define-for-tests keep-it-fast!?
   (let ((v (get-environment-variable "FAST")))
     (if (or (eq? v #f) (string-null? v))
-- 
2.25.1