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


    (define-syntax matches?
      (syntax-rules (_ !)
        ((matches? x _) #t)
        ((matches? x '())
         (null? x))
        ((matches? x (! constant))
         (equal? x constant))
        ((matches? x (pattern))
         (and (= 1 (length x))
              (matches? (car x) pattern)))
        ((matches? x (pattern1 . pattern2))
         (and (pair? x)
              (matches? (car x) pattern1)
              (matches? (cdr x) pattern2)))
        ((matches? x identifier) #t)))


    (define-syntax bind-pattern
      (syntax-rules (_ !)
        ((bind-pattern x _ result result* ...)
         (begin result result* ...))
        ((bind-pattern x '() result result* ...)
         (begin result result* ...))
        ((bind-pattern x (! constant) result result* ...)
         (begin result result* ...))
        ((bind-pattern x (pattern) result result* ...)
         (bind-pattern (car x) pattern result result* ...))
        ((bind-pattern x (pattern1 . pattern2) result result* ...)
         (bind-pattern (car x) pattern1
           (bind-pattern (cdr x) pattern2 result result* ...)))
        ((bind-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 ...)))))))