Improve the match syntax for constants.

I guess you can pattern match using quote as a literal.
That's pretty cool.

4 files changed, 75 insertions, 71 deletions

diff --git a/csc/encoding.csc b/csc/encoding.csc
index 5c06bec..8dbd89c 100644
--- a/csc/encoding.csc
+++ b/csc/encoding.csc
@@ -35,25 +35,25 @@
 
     (define (opcode-switch opcode)
       (match opcode
-        (((! 'const) n) (append (64->le-bytes 1010) (64->le-bytes n)))
-        ((! 'add) (64->le-bytes 1020))
-        ((! 'sub) (64->le-bytes 1030))
-        ((! 'mul) (64->le-bytes 1040))
-        ((! 'div) (64->le-bytes 1050))
-        ((! 'mod) (64->le-bytes 1060))
-        ((! 'alloc) (64->le-bytes 2010))
-        (((! 'peek) n) (append (64->le-bytes 2020) (list n)))
-        (((! 'poke) n) (append (64->le-bytes 2030) (list n)))
-        ((! 'peekbyte) (64->le-bytes 2040))
-        ((! 'pokebyte) (64->le-bytes 2050))
-        ((! 'pop) (64->le-bytes 3010))
-        (((! 'local) n) (append (64->le-bytes 3020) (list n)))
-        (((! 'if) n) (append (64->le-bytes 4010) (64->le-bytes n)))
-        (((! 'call) n) (append (64->le-bytes 4020) (list n)))
-        ((! 'ret) (64->le-bytes 4030))
-        ((! 'exit) (64->le-bytes 4040))
-        ((! 'putc) (64->le-bytes 5010))
-        ((! 'getc) (64->le-bytes 5020))
+        (('const n) (append (64->le-bytes 1010) (64->le-bytes n)))
+        ('add (64->le-bytes 1020))
+        ('sub (64->le-bytes 1030))
+        ('mul (64->le-bytes 1040))
+        ('div (64->le-bytes 1050))
+        ('mod (64->le-bytes 1060))
+        ('alloc (64->le-bytes 2010))
+        (('peek n) (append (64->le-bytes 2020) (list n)))
+        (('poke n) (append (64->le-bytes 2030) (list n)))
+        ('peekbyte (64->le-bytes 2040))
+        ('pokebyte (64->le-bytes 2050))
+        ('pop (64->le-bytes 3010))
+        (('local n) (append (64->le-bytes 3020) (list n)))
+        (('if n) (append (64->le-bytes 4010) (64->le-bytes n)))
+        (('call n) (append (64->le-bytes 4020) (list n)))
+        ('ret (64->le-bytes 4030))
+        ('exit (64->le-bytes 4040))
+        ('putc (64->le-bytes 5010))
+        ('getc (64->le-bytes 5020))
         (_ (error "invalid opcode" opcode))))
 
 
diff --git a/csc/linker.csc b/csc/linker.csc
index b840c15..feec289 100644
--- a/csc/linker.csc
+++ b/csc/linker.csc
@@ -22,12 +22,12 @@
       (map
         (lambda (x)
           (match x
-            ((i . ((! 'if) label))
+            ((i . ('if label))
              ; Compute offset from the current position. Subtract 1
              ; because the instruction pointer is incremented each
              ; time already.
              (list 'if (- (lookup label-map label) i 1)))
-            ((_ . ((! 'call) label))
+            ((_ . ('call label))
              (list 'call (lookup label-map label)))
             ((_ . opcode) opcode)))
         (enumerate program)))
@@ -43,7 +43,7 @@
                  (i 0))
         (match program
           ('() m)
-          ((((! 'label) name) . tail)
+          ((('label name) . tail)
            (loop (insert m name i) tail i))  ; N.b.: i instead of (+ 1 i) because we're going to remove the labels later.
           ((_ . tail) (loop m tail (+ 1 i))))))
 
@@ -52,7 +52,7 @@
       (filter
         (lambda (opcode)
           (match opcode
-            (((! 'label) _) #f)
+            (('label _) #f)
             (_ #t)))
         program))
 
diff --git a/csc/match-test.csc b/csc/match-test.csc
index bcd0d35..8323952 100644
--- a/csc/match-test.csc
+++ b/csc/match-test.csc
@@ -7,11 +7,11 @@
   (assert-equal
     3
     (match 3
-      ((! 0) 0)
-      ((! 1) 1)
-      ((! 2) 2)
-      ((! 3) 3)
-      (_ 4))))
+      ('0 0)
+      ('1 1)
+      ('2 2)
+      ('3 3)
+      ('4 4))))
 
 
 (test match-list
@@ -19,9 +19,9 @@
     2
     (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))))
 
 
@@ -29,7 +29,7 @@
   (assert-equal
     2
     (match '(1 2 3)
-      (((! 1) x (! 3)) x))))
+      (('1 x '3) x))))
 
 
 (test match-destructuring
@@ -45,8 +45,8 @@
     2
     (match '(1 2 3)
       ((_ _ _ _) 0)
-      (((! 2) _ _) 1)
-      (((! 1) _ _) 2)
+      (('2 _ _) 1)
+      (('1 _ _) 2)
       (_ 3))))
 
 
@@ -54,8 +54,8 @@
   (assert-equal
     2
     (match '(1 2 3)
-      (((! 2) . _) 1)
-      (((! 1) . x) (car x))
+      (('2 . _) 1)
+      (('1 . x) (car x))
       (_ 3))))
 
 
@@ -63,8 +63,8 @@
   (assert-equal
     2
     (match 'b
-      ((! 'a) 1)
-      ((! 'b) 2)
+      ('a 1)
+      ('b 2)
       (_ 3))))
 
 
@@ -72,9 +72,9 @@
   (assert-equal
     3
     (match 'b
-      ((! 'a) 1)
-      ((! 'b) when #f 2)
-      ((! 'b) when #t 3)
+      ('a 1)
+      ('b when #f 2)
+      ('b when #t 3)
       (_ 4))))
 
 
@@ -105,7 +105,7 @@
 
 (test match-record-type-any
   (assert-equal
-    #t
+    2
     (match '(1 2 3)
-      ((% %test-record-type . _) #f)
-      ((! '(1 2 3)) #t))))
+      ((% %test-record-type . _) 1)
+      ('(1 2 3) 2))))
diff --git a/csc/match.csc b/csc/match.csc
index 96ec4d3..4db0d07 100644
--- a/csc/match.csc
+++ b/csc/match.csc
@@ -29,39 +29,43 @@
 
 
     (define-syntax match-pattern
-      (syntax-rules (_ ! when %)
+      (syntax-rules (% _ quote when)
         ((match-pattern x pattern when condition result result* ...)
-         (match-pattern x pattern
-           (if condition
-             (let () result result* ...)
-             (raise *no-match*))))
+          (match-pattern x pattern
+            (unless condition
+              (raise *no-match*))
+            result result* ...))
         ((match-pattern x _ result result* ...)
-         (let () result result* ...))
-        ((match-pattern x '() result result* ...)
-         (if (null? x)
-           (let () result result* ...)
-           (raise *no-match*)))
-        ((match-pattern x (! constant) result result* ...)
-         (if (equal? x constant)
-           (let () result result* ...)
-           (raise *no-match*)))
-        ((match-pattern x (pattern) result result* ...)
-         (let ((y x))
-           (if (= 1 (length y))
-             (match-pattern (car y) pattern result result* ...)
-             (raise *no-match*))))
+          (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 (record-matcher x))) patterns result result* ...)))
+            (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))
-           (if (pair? y)
-             (match-pattern (car y) pattern
-               (match-pattern (cdr y) rest result result* ...))
-             (raise *no-match*))))
+          (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* ...))))
+          (let ((identifier x))
+            result result* ...))))
 
 
     (define-syntax match