(define-library (csc match)
  (export match)
  (import (scheme base))
  (begin


    (define-syntax matches?
      (syntax-rules (!)
        ((matches? x '())
         (null? x))
        ((matches? x (! bind))
         #t)
        ((matches? x ((! bind)))
         (= 1 (length x)))
        ((matches? x (lit))
         (and (= 1 (length x))
              (eqv? lit (car x))))
        ((matches? x ((! bind) pattern1 pattern2 ...))
         (and (pair? x)
              (matches? (cdr x) (pattern1 pattern2 ...))))
        ((matches? x (lit pattern1 pattern2 ...))
         (and (pair? x)
              (eqv? lit (car x))
              (matches? (cdr x) (pattern1 pattern2 ...))))
        ((matches? x lit)
         (eqv? lit x))))


    (define-syntax bind-pattern
      (syntax-rules (!)
        ((bind-pattern x '() result1 result2 ...)
         (begin result1 result2 ...))
        ((bind-pattern x (! bind) result1 result2 ...)
         (let ((bind x))
           result1 result2 ...))
        ((bind-pattern x ((! bind)) result1 result2 ...)
         (let ((bind (car x)))
           result1 result2 ...))
        ((bind-pattern x (lit) result1 result2 ...)
         (begin result1 result2 ...))
        ((bind-pattern x ((! bind) pattern1 pattern2 ...) result1 result2 ...)
         (let ((bind (car x)))
           (bind-pattern (cdr x) (pattern1 pattern2 ...) result1 result2 ...)))
        ((bind-pattern x (lit pattern1 pattern2 ...) result1 result2 ...)
         (bind-pattern (cdr x) (pattern1 pattern2 ...) result1 result2 ...))
        ((bind-pattern x lit result1 result2 ...)
         (begin result1 result2 ...))))


    (define-syntax match
      (syntax-rules (else)
        ((match x (else result1 result2 ...))
         (begin result1 result2 ...))
        ((match x (pattern result1 result2 ...))
         (if (matches? x pattern)
           (bind-pattern x pattern result1 result2 ...)))
        ((match x (pattern result1 result2 ...) clause1 clause2 ...)
         (if (matches? x pattern)
           (bind-pattern x pattern result1 result2 ...)
           (match x clause1 clause2 ...)))))))