Enhance test framework with some useful utilities.

diff --git a/tests/load.scm b/tests/load.scm
index c1ae22e73019a118836874e9d6b5cb4a99e19bd7..14e9e0a97299686d5e7dffaa05f687573d62d811 100644 (file)
--- 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 66f933568cf0e4df59f9b10aa2a6abda88b3658f..523a91ccf5ba72e17ee9477bd18daacffd3d4d36 100644 (file)
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -146,7 +146,7 @@ USA.
 \f
 ;;;; 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)))
+\f
 (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))