1 files changed, 80 insertions, 0 deletions
diff --git a/lib/csc/match.csc b/lib/csc/match.csc
new file mode 100644
index 0000000..4db0d07
--- /dev/null
+++ b/lib/csc/match.csc
@@ -0,0 +1,80 @@
+(define-library (csc match)
+  (export
+    define-match-record-type
+    match)
+  (import (scheme base))
+  (begin
+
+
+    (define-record-type <no-match>
+      (make-no-match)
+      no-match?)
+
+
+    (define *no-match* (make-no-match))
+
+
+    (define-syntax define-match-record-type
+      (syntax-rules ()
+        ((define-match-record-type name constructor predicate matcher (field-name* field-getter*) ...)
+          (begin
+            (define-record-type name
+              constructor
+              predicate
+              (field-name* field-getter*) ...)
+            (define (matcher x)
+              (unless (predicate x)
+                (raise *no-match*))
+              (list (cons '!type 'name) (cons 'field-name* (field-getter* x)) ...))))))
+
+
+    (define-syntax match-pattern
+      (syntax-rules (% _ quote when)
+        ((match-pattern x pattern when condition result result* ...)
+          (match-pattern x pattern
+            (unless condition
+              (raise *no-match*))
+            result result* ...))
+        ((match-pattern x _ result result* ...)
+          (let () result result* ...))
+        ((match-pattern x (quote constant) result result* ...)
+          (let ()
+            (unless (equal? x (quote constant))
+              (raise *no-match*))
+            result result* ...))
+        ((match-pattern x (% record-matcher) result result* ...)
+          (let ()
+            (record-matcher x)
+            result result* ...))
+        ((match-pattern x (% record-matcher . patterns) result result* ...)
+          (let ((x* (record-matcher x)))
+            (match-pattern (map cdr (cdr x*)) patterns result result* ...)))
+        ((match-pattern x () result* ...)
+          (syntax-error "Unexpected pattern (). Use '() to match nil."))
+        ((match-pattern x (pattern) result result* ...)
+          (let ((y x))
+            (unless (and (pair? y)
+                         (null? (cdr y)))
+              (raise *no-match*))
+            (match-pattern (car y) pattern result result* ...)))
+        ((match-pattern x (pattern . rest) result result* ...)
+          (let ((y x))
+            (unless (pair? y)
+              (raise *no-match*))
+            (match-pattern (car y) pattern
+              (match-pattern (cdr y) rest result result* ...))))
+        ((match-pattern x identifier result result* ...)
+          (let ((identifier x))
+            result result* ...))))
+
+
+    (define-syntax match
+      (syntax-rules ()
+        ((match x (arm ...))
+         (guard (e ((no-match? e) (if #f #f)))
+           (match-pattern x arm ...)))
+        ((match x (arm ...) clause clause* ...)
+         (let ((y x))
+           (guard (e ((no-match? e)
+                      (match y clause clause* ...)))
+             (match-pattern y arm ...))))))))