Add assertion that does pattern matching; useful for syntax testing.

diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index 5cf497745df7e0f14e79601bdd626e5d0307448e..105fb05bd412443f106929f3efe2fd5b7d817d01 100644 (file)
--- a/tests/unit-testing.scm
+++ b/tests/unit-testing.scm
@@ -649,4 +649,44 @@ USA.
                          (if+ "the same elements as" "different elements from")
                          (marker)
                          "comparing elements with" (name-of comparator)
-                         "in any order")))\f
+                         "in any order")))
+\f
+(define (trivial-matcher pattern expression #!optional value=?)
+  (let ((value=? (if (default-object? value=?) equal? value=?)))
+    (let loop
+       ((p pattern)
+        (e expression)
+        (dict '())
+        (win (lambda (dict) dict #t)))
+      (cond ((match-var? p)
+            (let ((binding (assq p dict)))
+              (if binding
+                  (and (value=? e (cdr binding))
+                       (win dict))
+                  (win (cons (cons p e) dict)))))
+           ((pair? p)
+            (and (pair? e)
+                 (loop (car p)
+                       (car e)
+                       dict
+                       (lambda (dict*)
+                         (loop (cdr p)
+                               (cdr e)
+                               dict*
+                               win)))))
+           (else
+            (and (eqv? p e)
+                 (win dict)))))))
+
+(define (match-var? object)
+  (and (symbol? object)
+       (string-prefix? "?" (symbol->string object))))
+
+(define (match-assertion negate?)
+  (binary-assertion negate?
+                   (lambda (value expected)
+                     (trivial-matcher expected value))
+                   (list "an object" (if- "not") "matching" (marker))))
+
+(define-for-tests assert-matches (match-assertion #f))
+(define-for-tests assert-!matches (match-assertion #t))
\ No newline at end of file