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.

1 files 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* ...)))))))