From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 6 Dec 2018 07:47:01 +0000 (-0800)
Subject: Add assertion that does pattern matching; useful for syntax testing.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~19
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fc334615474d4346b0b897974798172c9b37ccb9;p=mit-scheme.git

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

diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm
index 5cf497745..105fb05bd 100644
--- 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")))
+			  "in any order")))
+
+(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