From e7d0eefb6f766968fe0de26556da1353ec9bd0ab Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Sun, 9 Jan 2022 11:16:17 -0800
Subject: Add a library for pattern matching.

---
 match-test.csc | 42 ++++++++++++++++++++++++++++++++++++++++
 match.csc      | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 102 insertions(+)
 create mode 100644 match-test.csc
 create mode 100644 match.csc

diff --git a/match-test.csc b/match-test.csc
new file mode 100644
index 0000000..3fed862
--- /dev/null
+++ b/match-test.csc
@@ -0,0 +1,42 @@
+(import (scheme base)
+        (only (csc testing) define-test errorf subtest)
+        (csc match))
+
+
+(define-test (test-match t)
+  (define-record-type <test-case>
+    (test-case name expr want)
+    test-case?
+    (name name)
+    (expr expr)
+    (want want))
+  (let ((tests (list
+                 (test-case
+                   "simple"
+                   (match 3
+                     (0 0)
+                     (1 1)
+                     (2 2)
+                     (3 3)
+                     (else 4))
+                   3)
+                 (test-case
+                   "match-list"
+                   (match '(1 2 3)
+                     ('() 0)
+                     ((1 2) 1)
+                     ((1 2 3) 2)
+                     ((1 2 3 4) 3)
+                     (else 4))
+                   2)
+                 (test-case
+                   "binding"
+                   (match '(1 2 3)
+                     ((1 (! x) 3) x))
+                   2))))
+    (for-each
+      (lambda (tc)
+        (subtest t (name tc)
+          (unless (equal? (expr tc) (want tc))
+            (errorf t "match = {}, want {}." (expr tc) (want tc)))))
+      tests)))
diff --git a/match.csc b/match.csc
new file mode 100644
index 0000000..95b2b32
--- /dev/null
+++ b/match.csc
@@ -0,0 +1,60 @@
+(define-library (csc match)
+  (export match)
+  (import (scheme base))
+  (begin
+
+
+    (define-syntax matches?
+      (syntax-rules (!)
+        ((matches? x '())
+         (null? x))
+        ((matches? x (! bind))
+         #t)
+        ((matches? x ((! bind)))
+         (= 1 (length x)))
+        ((matches? x (lit))
+         (and (= 1 (length x))
+              (eqv? lit (car x))))
+        ((matches? x ((! bind) pattern1 pattern2 ...))
+         (and (pair? x)
+              (matches? (cdr x) (pattern1 pattern2 ...))))
+        ((matches? x (lit pattern1 pattern2 ...))
+         (and (pair? x)
+              (eqv? lit (car x))
+              (matches? (cdr x) (pattern1 pattern2 ...))))
+        ((matches? x lit)
+         (eqv? lit x))))
+
+
+    (define-syntax bind-pattern
+      (syntax-rules (!)
+        ((bind-pattern x '() result1 result2 ...)
+         (begin result1 result2 ...))
+        ((bind-pattern x (! bind) result1 result2 ...)
+         (let ((bind x))
+           result1 result2 ...))
+        ((bind-pattern x ((! bind)) result1 result2 ...)
+         (let ((bind (car x)))
+           result1 result2 ...))
+        ((bind-pattern x (lit) result1 result2 ...)
+         (begin result1 result2 ...))
+        ((bind-pattern x ((! bind) pattern1 pattern2 ...) result1 result2 ...)
+         (let ((bind (car x)))
+           (bind-pattern (cdr x) (pattern1 pattern2 ...) result1 result2 ...)))
+        ((bind-pattern x (lit pattern1 pattern2 ...) result1 result2 ...)
+         (bind-pattern (cdr x) (pattern1 pattern2 ...) result1 result2 ...))
+        ((bind-pattern x lit result1 result2 ...)
+         (begin result1 result2 ...))))
+
+
+    (define-syntax match
+      (syntax-rules (else)
+        ((match x (else result1 result2 ...))
+         (begin result1 result2 ...))
+        ((match x (pattern result1 result2 ...))
+         (if (matches? x pattern)
+           (bind-pattern x pattern result1 result2 ...)))
+        ((match x (pattern result1 result2 ...) clause1 clause2 ...)
+         (if (matches? x pattern)
+           (bind-pattern x pattern result1 result2 ...)
+           (match x clause1 clause2 ...)))))))
-- 
cgit v1.3.1