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


    (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* ...)
         (let ((y x))
           (if (= 1 (length y))
             (match-pattern (car y) pattern result result* ...)
             (raise (make-no-match)))))
        ((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 (make-no-match)))))
        ((match-pattern x identifier result result* ...)
         (let ((identifier x))
           result result* ...))))


    (define-syntax match
      (syntax-rules ()
        ((match x (arm ...))
         (guard (e ((no-match? e) (if #f #f)))
           (match-pattern x arm ...)))
        ((match x (arm ...) clause clause* ...)
         (let ((y x))
           (guard (e ((no-match? e)
                      (match y clause clause* ...)))
             (match-pattern y arm ...))))))))