gistfile1.txt

(define-library (pattern-match-lambda)
  (import (scheme base))
  (define-syntax if-identifier
    (syntax-rules ()
      ((_ condition seq alt)
       (let-syntax ((foo (syntax-rules () ((_) seq))))
         (let-syntax ((test (syntax-rules ()
                              ((_ condition) (foo))
                              ((_ foo) alt))))
           (test foo))))))

  (define-syntax if-literal
    (syntax-rules ()
      ((_ p (literals ...) seq alt)
       (let-syntax ((bar (syntax-rules () ((_) seq))))
         (let-syntax ((foo (syntax-rules (literals ...)
                             ((_ literals) (bar)) ...
                             ((_ bar) alt))))
           (foo p))))))

  (define-syntax if-placeholder
    (syntax-rules (_)  ;; Literals cannot include underbar in R6RS.
      ((_ _ seq alt) seq)
      ((_ p seq alt) alt)))

  (define-syntax %if-match-vector
    (syntax-rules ()
      ((_ (literals ...) #() ind e seq alt) seq)
      ((_ (literals ...) #(p r ...) ind e seq alt)
       (%if-match (literals ...) p (vector-ref e ind)
                  (let ((i ind))
                    (%if-match-vector (literals ...) #(r ...) (+ i 1) e seq alt))
                  alt))))

  (define-syntax %if-match
    (syntax-rules ()
      ((_ (literals ...) #(p ...) e seq alt)
       (if (and (vector? e) (= (vector-length '#(p ...)) (vector-length e)))
           (%if-match-vector (literals ...) #(p ...) 0 e seq alt)
           (alt)))
      ((_ (literals ...) (p . r) e seq alt)
       (let ((temp e))
         (if (pair? temp)
             (%if-match (literals ...) p (car temp)
                        (%if-match (literals ...) r (cdr temp) seq alt)
                        alt)
             (alt))))
      ((_ (literals ...) () e seq alt)
       (if (null? e) seq (alt)))
      ((_ (literals ...) p e seq alt)
       (if-identifier p
                      (if-literal p (literals ...)
                                  (if (equal? 'p e) seq (alt))
                                  (if-placeholder p
                                                  seq
                                                  (let ((p e)) seq)))
                      (if (equal? p e) seq (alt))))))

  (define-syntax %duplicate-check
    (syntax-rules ()
      ((_) #f)
      ((_ p r ...)
       (letrec-syntax
           ((bar (syntax-rules ()
                   ((_) (syntax-error "duplicate pattern variable in pattern-match-lambda" p ))))
            (foo (syntax-rules (r ...)
                   ((_ r) (bar))
                   ...
                   ((_ x) (%duplicate-check r ...)))))
         (foo p)))))

  (define-syntax duplicate-check
    (syntax-rules ()
      ((_ (pvar ...) (literals ...) #(p ...))
       (duplicate-check (pvar ...) (literals ...) (p ...)))
      ((_ (pvar ...) (literals ...) ((p) . r))
       (duplicate-check (pvar ...) (literals ...) (p . r)))
      ((_ (pvar ...) (literals ...) ((p0 . p1) . r))
       (duplicate-check (pvar ...) (literals ...) (p0 p1 . r)))
      ((_ (pvar ...) (literals ...) (#(p ...) . r))
       (duplicate-check (pvar ...) (literals ...) (p ... . r)))
      ((_ (pvar ...) (literals ...) (p . r))
       (if-identifier p
                      (if-literal p (literals ...)
                                  (duplicate-check (pvar ...) (literals ...) r)
                                  (if-placeholder p
                                                  (duplicate-check (pvar ...) (literals ...) r)
                                                  (duplicate-check (pvar ... p) (literals ...) r)))
                      (duplicate-check (pvar ...) (literals ...) r)))
      ((_ (pvar ...) (literals ...) ())
       (%duplicate-check pvar ...))
      ((_ (pvar ...) (literals ...) p)
       (if-identifier p
                      (if-literal p (literals ...)
                                  (duplicate-check (pvar ...) (literals ...) ())
                                  (if-placeholder p
                                                  (duplicate-check (pvar ...) (literals ...) ())
                                                  (duplicate-check (pvar ... p) (literals ...) ())))
                      (duplicate-check (pvar ...) (literals ...) ())))))

  (define-syntax if-match
    (syntax-rules ()
      ((_ (literals ...) pattern lst seq alt)
       (let ((alt-thunk (lambda() alt)))
         (begin (duplicate-check () (literals ...) pattern)
                (%if-match (literals ...) pattern lst seq alt-thunk))))))

  (define-syntax %pattern-match-lambda
    (syntax-rules (else)
      ((_ (literals ...) lst) (if #f #t))
      ((_ (literals ...) lst (else expr))
       expr)
      ((_ (literals ...) lst (pattern expr) (rest-pattern rest-expr) ...)
       (if-match (literals ...) pattern lst
                 expr
                 (%pattern-match-lambda (literals ...) lst
                                        (rest-pattern rest-expr) ...)))
      ((_ (literals ...) lst (pattern fender expr) (rest-pattern rest-expr) ...)
       (let ((next
              (lambda() (%pattern-match-lambda (literals ...) lst
                                               (rest-pattern rest-expr) ...))))
         (if-match (literals ...) pattern lst
                   (if fender expr (next))
                   (next))))))

  (define-syntax pattern-match-lambda
    (syntax-rules ()
      ((_ (literals ...) clause  ...)
       (lambda lst
         (%pattern-match-lambda (literals ...) lst clause ...)))))


  (export pattern-match-lambda))

(import (scheme base)
        (scheme write)
        (picrin test)
        (pattern-match-lambda))

(test-begin)

(define fact
  (pattern-match-lambda ()
   ((0) 1)
   ((n) (* n (fact (- n 1))))))

(test 120 (fact 5))

(define example
  (pattern-match-lambda ()
    ((x y z) (list 'case1 x y z))
    ((x (y z)) (list 'case2 x y z))
    (((x y) z) (list 'case3 x y z))
    (else 'case3)))

(test '(case1 1 2 3) (example 1 2 3))
(test '(case2 4 5 6) (example 4 '(5 6)))
(test '(case3 7 8 9) (example '(7 8) 9))
(test 'case3 (example 10 11 12 13))

(define example2
  (pattern-match-lambda (foo bar baz)
    ((foo 1) 'foo-case-1)
    ((foo 2) 'foo-case-2)
    ((foo (x #(y z))) (list 'foo-case x y z))
    ((bar x) (list 'bar-case x))
    ((baz x) (list 'baz-case x))
    (else 'else-case)))

(test 'foo-case-1 (example2 'foo 1))
(test '(foo-case 1 2 3) (example2 'foo '(1 #(2 3))))
(test 'foo-case-2 (example2 'foo 2))
(test '(baz-case 4) (example2 'baz 4))

;; Underbar is placeholder
(define example3
  (pattern-match-lambda ()
    ((_) 'arity1)
    ((_ _) 'arity2)
    ((_ _ _) 'arity3)))

(test 'arity3 (example3 1 1 1))

;; If underbar was specified as literal, underbar will match literal.
(define example4
  (pattern-match-lambda (_)
    ((_) 'case1)
    ((x) x)))

(test 'case1 (example4 '_))
(test 'foo (example4 'foo))

;; If there is duplicate template variables, report error.
;; (pattern-match-lambda (_)
;;    ((_) 'case1)
;;    ((x x) x))

;; If there is fender, use it.
(define example5
  (pattern-match-lambda ()
    ((x) (string? x) x)
    ((x) 'not-string)))

(test "1" (example5 "1"))
(test 'not-string (example5 1))
(test-end)