Match with syntax-case

match.scm

#!r6rs
(import (rnrs))

(define-syntax match
  (lambda (x)
    ;; extract identifier in pattern
    (define (parse-pattern pattern)
      (let loop ((p pattern) (acc '()))
        (syntax-case p ()
          (() (reverse acc))
          ((a . d)
           (let ((ar (loop #'a acc)))
             (loop #'d ar)))
          (#(e ...) (loop #'(e ...) acc))
          (a (identifier? #'a) (cons (syntax->datum #'a) acc))
          (else acc))))
    ;; replace with extracted identifiers
    (define (rewrite-expr expr binds)
      (let loop ((expr expr))
        (syntax-case expr ()
          (() '())
          ((a . d) #`(#,(loop #'a) . #,(loop #'d)))
          (#(e ...) #`#(#,@(loop #'(e ...))))
          (a (identifier? #'a)
             (let ((r (memp (lambda (b) (free-identifier=? #'a b)) binds)))
               (or (and r (car r)) #'a)))
          (a #'a))))

    (syntax-case x ()
      ((k input (pattern expr ...) ...)
       #'(let ((in input))
           (k "rec" in () ((pattern expr ...) ...))))
      ((k "rec" input (p ...) ((pattern expr ...) rest ...))
       (with-syntax (((binds ...)
                      (datum->syntax #'k (parse-pattern  #'pattern))))
         (with-syntax (((expr2 ...) (rewrite-expr #'(expr ...) #'(binds ...))))
           #'(k "rec" input
                (p ... (pattern ((lambda (binds ...) expr2 ...) #'binds ...)))
                (rest ...)))))
      ((_ "rec" input (p ...) ())
       #'(syntax-case input () p ...)))))


;; tests
(match '(1 2 3)
  ((a b c) (display (list a b)) (newline)))

(match '((1) #(2) 3)
  (((1) #(b) c) (display (list c `#(,b))) (newline)))

(match '(1 2 3)
  ((2 2 c) (display (list c 'ng)) (newline))
  ((1 b c) (display (list c b)) (newline)))

(match '(1 2 3)
  ((a . d) (display d) (newline)))

(flush-output-port (current-output-port))