From 85a1d8d269383cc061d54cf4e1af0254a6c6ccb7 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Thu, 13 Jan 2022 15:49:18 -0800
Subject: Rewrite match to use exceptions.

This makes the control flow more clear, and eliminates the need to scan
the pattern twice. It also makes it easier to add new forms by
consolidating the pattern logic in one procedure.
---
 csc/match.csc | 60 ++++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 43 insertions(+), 17 deletions(-)

diff --git a/csc/match.csc b/csc/match.csc
index 3e02937..86efab7 100644
--- a/csc/match.csc
+++ b/csc/match.csc
@@ -39,22 +39,48 @@
            result result* ...))))
 
 
+    (define-record-type <no-match>
+      (make-no-match)
+      no-match?)
+
+
+    (define-syntax match-pattern
+      (syntax-rules (_ ! when)
+        ((match-pattern x pattern (when condition) result result* ...)
+         (match-pattern x pattern
+           (if condition
+             (begin result result* ...)
+             (raise (make-no-match)))))
+        ((match-pattern x _ result result* ...)
+         (begin result result* ...))
+        ((match-pattern x '() result result* ...)
+         (if (null? x)
+           (begin result result* ...)
+           (raise (make-no-match))))
+        ((match-pattern x (! constant) result result* ...)
+         (if (equal? x constant)
+           (begin result result* ...)
+           (raise (make-no-match))))
+        ((match-pattern x (pattern) result result* ...)
+         (if (= 1 (length x))
+           (match-pattern (car x) pattern result result* ...)
+           (raise (make-no-match))))
+        ((match-pattern x (pattern . rest) result result* ...)
+         (if (pair? x)
+           (match-pattern (car x) pattern
+             (match-pattern (cdr x) rest result result* ...))
+           (raise (make-no-match))))
+        ((match-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 ...)))))))
+        ((match x (pattern result result* ...))
+         (guard (e ((no-match? e) (if #f #f)))
+           (match-pattern x pattern result result* ...)))
+        ((match x (pattern result result* ...) clause clause* ...)
+         (guard (e ((no-match? e)
+                    (match x clause clause* ...)))
+           (match-pattern x pattern result result* ...)))))))
-- 
cgit v1.3.1