(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-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 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* ...)))))))