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.csc | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 60 insertions(+)
 create mode 100644 match.csc

(limited to 'match.csc')

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