From 68986fe0410584c6934c835bb0ee784655f5f8c5 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Tue, 11 Jan 2022 22:01:23 -0800
Subject: Move scheme compiler into a separate directory.

---
 csc/match.csc | 60 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 60 insertions(+)
 create mode 100644 csc/match.csc

(limited to 'csc/match.csc')

diff --git a/csc/match.csc b/csc/match.csc
new file mode 100644
index 0000000..3e02937
--- /dev/null
+++ b/csc/match.csc
@@ -0,0 +1,60 @@
+(define-library (csc match)
+  (export match)
+  (import (scheme base))
+  (begin
+
+
+    (define-syntax matches?
+      (syntax-rules (_ !)
+        ((matches? x _) #t)
+        ((matches? x '())
+         (null? x))
+        ((matches? x (! constant))
+         (equal? x constant))
+        ((matches? x (pattern))
+         (and (= 1 (length x))
+              (matches? (car x) pattern)))
+        ((matches? x (pattern1 . pattern2))
+         (and (pair? x)
+              (matches? (car x) pattern1)
+              (matches? (cdr x) pattern2)))
+        ((matches? x identifier) #t)))
+
+
+    (define-syntax bind-pattern
+      (syntax-rules (_ !)
+        ((bind-pattern x _ result result* ...)
+         (begin result result* ...))
+        ((bind-pattern x '() result result* ...)
+         (begin result result* ...))
+        ((bind-pattern x (! constant) result result* ...)
+         (begin result result* ...))
+        ((bind-pattern x (pattern) result result* ...)
+         (bind-pattern (car x) pattern result result* ...))
+        ((bind-pattern x (pattern1 . pattern2) result result* ...)
+         (bind-pattern (car x) pattern1
+           (bind-pattern (cdr x) pattern2 result result* ...)))
+        ((bind-pattern x identifier result result* ...)
+         (let ((identifier x))
+           result result* ...))))
+
+
+    (define-syntax match
+      (syntax-rules (when)
+        ((match x (pattern (when condition) result result* ...))
+         (if (matches? x pattern)
+           (bind-pattern x pattern
+             (if condition
+               (begin result result* ...)))))
+        ((match x (pattern result1 result2 ...))
+         (if (matches? x pattern)
+           (bind-pattern x pattern result1 result2 ...)))
+        ((match x (pattern (when condition) result result* ...) clause clause* ...)
+         (if (and (matches? x pattern)
+                  (bind-pattern x pattern condition))
+           (bind-pattern x pattern result result* ...)
+           (match x clause clause* ...)))
+        ((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