Improve match syntax.

Now ! is required to match against a constant, and by default a name
is bound.

2 files changed, 44 insertions, 29 deletions

diff --git a/match-test.csc b/match-test.csc
index 2728e44..e71a2d3 100644
--- a/match-test.csc
+++ b/match-test.csc
@@ -12,34 +12,47 @@
     (want want))
   (let ((tests (list
                  (test-case
-                   "simple"
+                   "cond"
                    (match 3
-                     (0 0)
-                     (1 1)
-                     (2 2)
-                     (3 3)
+                     ((! 0) 0)
+                     ((! 1) 1)
+                     ((! 2) 2)
+                     ((! 3) 3)
                      (_ 4))
                    3)
                  (test-case
                    "match-list"
                    (match '(1 2 3)
                      ('() 0)
-                     ((1 2) 1)
-                     ((1 2 3) 2)
-                     ((1 2 3 4) 3)
+                     (((! 1) (! 2)) 1)
+                     (((! 1) (! 2) (! 3)) 2)
+                     (((! 1) (! 2) (! 3) (! 4)) 3)
                      (_ 4))
                    2)
                  (test-case
                    "binding"
                    (match '(1 2 3)
-                     ((1 (! x) 3) x))
+                     (((! 1) x (! 3)) x))
                    2)
                  (test-case
+                   "destructuring"
+                   (match '(1 2 3)
+                     ('() 0)
+                     ((head . _) head))
+                   1)
+                 (test-case
                    "ignore"
                    (match '(1 2 3)
                      ((_ _ _ _) 0)
-                     ((2 _ _) 1)
-                     ((1 _ _) 2)
+                     (((! 2) _ _) 1)
+                     (((! 1) _ _) 2)
+                     (_ 3))
+                   2)
+                 (test-case
+                   "improper list"
+                   (match '(1 2 3)
+                     (((! 2) . _) 1)
+                     (((! 1) . x) (car x))
                      (_ 3))
                    2))))
     (for-each
diff --git a/match.csc b/match.csc
index f6c9008..d128195 100644
--- a/match.csc
+++ b/match.csc
@@ -1,5 +1,5 @@
 (define-library (csc match)
-  (export match)
+  (export match matches?)
   (import (scheme base))
   (begin
 
@@ -7,34 +7,36 @@
     (define-syntax matches?
       (syntax-rules (! _)
         ((matches? x _) #t)
-        ((matches? x (! bind)) #t)
+        ((matches? x (! lit))
+         (eqv? x lit))
+        ((matches? x '())
+         (null? x))
         ((matches? x (pattern))
          (and (= 1 (length x))
-              (matches? (car x) pat)))
-        ((matches? x (pattern pattern1 pattern2 ...))
+              (matches? (car x) pattern)))
+        ((matches? x (pattern1 . pattern2))
          (and (pair? x)
-              (matches? (car x) pattern)
-              (matches? (cdr x) (pattern1 pattern2 ...))))
-        ((matches? x lit)
-         (eqv? lit x))))
+              (matches? (car x) pattern1)
+              (matches? (cdr x) pattern2)))
+        ((matches? x bind) #t)))
 
 
     (define-syntax bind-pattern
       (syntax-rules (! _)
-        ((bind-pattern x '() result1 result2 ...)
-         (begin result1 result2 ...))
         ((bind-pattern x _ result1 result2 ...)
          (begin result1 result2 ...))
-        ((bind-pattern x (! bind) result1 result2 ...)
-         (let ((bind x))
-           result1 result2 ...))
+        ((bind-pattern x (! lit) result1 result2 ...)
+         (begin result1 result2 ...))
+        ((bind-pattern x '() result1 result2 ...)
+         (begin result1 result2 ...))
         ((bind-pattern x (pattern) result1 result2 ...)
          (bind-pattern (car x) pattern result1 result2 ...))
-        ((bind-pattern x (pattern pattern1 pattern2 ...) result1 result2 ...)
-         (bind-pattern (car x) pattern
-           (bind-pattern (cdr x) (pattern1 pattern2 ...) result1 result2 ...)))
-        ((bind-pattern x lit result1 result2 ...)
-         (begin result1 result2 ...))))
+        ((bind-pattern x (pattern1 . pattern2) result1 result2 ...)
+         (bind-pattern (car x) pattern1
+           (bind-pattern (cdr x) pattern2 result1 result2 ...)))
+        ((bind-pattern x bind result1 result2 ...)
+         (let ((bind x))
+           result1 result2 ...))))
 
 
     (define-syntax match