(package*
match/v1.0.0
(provide:
(define-syntax
match-syntax-error
(syntax-rules
()
((_) (match-syntax-error "invalid match-syntax-error usage"))))
(define-syntax
match
(syntax-rules
()
((match) (match-syntax-error "missing match expression"))
((match atom) (match-syntax-error "missing match clause"))
((match (app ...) (pat . body) ...)
(let ((v (app ...)))
(match-next v (app ...) (set! (app ...)) (pat . body) ...)))
((match #(vec ...) (pat . body) ...)
(let ((v #(vec ...))) (match-next v v (set! v) (pat . body) ...)))
((match atom (pat . body) ...)
(match-next atom atom (set! atom) (pat . body) ...))))
(define-syntax
match-next
(syntax-rules
(=>)
((match-next v g s) (error 'match "no matching pattern"))
((match-next v g s (pat (=> failure) . body) . rest)
(let ((failure (lambda () (match-next v g s . rest))))
(match-one v pat g s (match-drop-ids (begin . body)) (failure) ())))
((match-next v g s (pat . body) . rest)
(match-next v g s (pat (=> failure) . body) . rest))))
(define-syntax
match-one
(syntax-rules
()
((match-one v (p q . r) g s sk fk i)
(match-check-ellipse
q
(match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())
(match-two v (p q . r) g s sk fk i)))
((match-one . x) (match-two . x))))
(define-syntax
match-two
(syntax-rules
(_ ___ quote quasiquote ? $ = and or not set! get!)
((match-two v () g s (sk ...) fk i) (if (null? v) (sk ... i) fk))
((match-two v 'p g s (sk ...) fk i) (if (equal? v 'p) (sk ... i) fk))
((match-two v `p g s sk fk i) (match-quasiquote v p g s sk fk i))
((match-two v (and) g s (sk ...) fk i) (sk ... i))
((match-two v (and p q ...) g s sk fk i)
(match-one v p g s (match-one v (and q ...) g s sk fk) fk i))
((match-two v (or) g s sk fk i) fk)
((match-two v (or p) g s sk fk i) (match-one v p g s sk fk i))
((match-two v (or p ...) g s sk fk i)
(match-extract-vars (or p ...) (match-gen-or v (p ...) g s sk fk i) i ()))
((match-two v (not p) g s (sk ...) fk i)
(match-one v p g s (match-drop-ids fk) (sk ... i) i))
((match-two v (get! getter) g s (sk ...) fk i)
(let ((getter (lambda () g))) (sk ... i)))
((match-two v (set! setter) g (s ...) (sk ...) fk i)
(let ((setter (lambda (x) (s ... x)))) (sk ... i)))
((match-two v (? pred p ...) g s sk fk i)
(if (pred v) (match-one v (and p ...) g s sk fk i) fk))
((match-two v (= proc p) g s sk fk i)
(let ((w (proc v))) (match-one w p g s sk fk i)))
((match-two v (p ___ . r) g s sk fk i)
(match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()))
((match-two v (p) g s sk fk i)
(if (and (pair? v) (null? (cdr v)))
(let ((w (car v))) (match-one w p (car v) (set-car! v) sk fk i))
fk))
((match-two v (p . q) g s sk fk i)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-one
w
p
(car v)
(set-car! v)
(match-one x q (cdr v) (set-cdr! v) sk fk)
fk
i))
fk))
((match-two v #(p ...) g s sk fk i)
(if (vector? v) (match-vector v 0 () (p ...) sk fk i) fk))
((match-two v _ g s (sk ...) fk i) (sk ... i))
((match-two v x g s (sk ...) fk (id ...))
(let-syntax
((new-sym?
(syntax-rules
(id ...)
((new-sym? x sk2 fk2) sk2)
((new-sym? y sk2 fk2) fk2))))
(new-sym?
random-sym-to-match
(let ((x v)) (sk ... (id ... x)))
(if (equal? v x) (sk ... (id ...)) fk))))))
(define-syntax
match-quasiquote
(syntax-rules
(unquote . ,@quasiquote)
((_ v ,p g s sk fk i) (match-one v p g s sk fk i))
((_ v (,@p . rest) g s sk fk i)
(if (pair? v)
(match-one v (p . tmp) (match-quasiquote tmp rest g s sk fk) fk i)
fk))
((_ v `p g s sk fk i . depth)
(match-quasiquote v p g s sk fk i #f . depth))
((_ v ,p g s sk fk i x . depth) (match-quasiquote v p g s sk fk i . depth))
((_ v ,@p g s sk fk i x . depth)
(match-quasiquote v p g s sk fk i . depth))
((_ v (p . q) g s sk fk i . depth)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
(match-quasiquote
w
p
g
s
(match-quasiquote-step x q g s sk fk depth)
fk
i
.
depth))
fk))
((_ v #(elt ...) g s sk fk i . depth)
(if (vector? v)
(let ((ls (vector->list v)))
(match-quasiquote ls (elt ...) g s sk fk i . depth))
fk))
((_ v x g s sk fk i . depth) (match-one v 'x g s sk fk i))))
(define-syntax
match-quasiquote-step
(syntax-rules
()
((match-quasiquote-step x q g s sk fk depth i)
(match-quasiquote x q g s sk fk i . depth))))
(define-syntax match-drop-ids (syntax-rules () ((_ expr ids ...) expr)))
(define-syntax
match-gen-or
(syntax-rules
()
((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...))
(let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
(match-gen-or-step v p g s (match-drop-ids (sk2 id ...)) fk (i ...))))))
(define-syntax
match-gen-or-step
(syntax-rules
()
((_ v () g s sk fk i) fk)
((_ v (p) g s sk fk i) (match-one v p g s sk fk i))
((_ v (p . q) g s sk fk i)
(match-one v p g s sk (match-gen-or-step v q g s sk fk i) i))))
(define-syntax
match-gen-ellipses
(syntax-rules
()
((_ v p () g s (sk ...) fk i ((id id-ls) ...))
(match-check-identifier
p
(let ((p v)) (sk ... i))
(let loop ((ls v) (id-ls '()) ...)
(cond ((null? ls) (let ((id (reverse id-ls)) ...) (sk ... i)))
((pair? ls)
(let ((w (car ls)))
(match-one
w
p
(car ls)
(set-car! ls)
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
fk
i)))
(else fk)))))
((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...))
(match-verify-no-ellipses
(r ...)
(let* ((tail-len (length '(r ...))) (ls v) (len (length ls)))
(if (< len tail-len)
fk
(let loop ((ls ls) (n len) (id-ls '()) ...)
(cond ((= n tail-len)
(let ((id (reverse id-ls)) ...)
(match-one ls (r ...) #f #f (sk ... i) fk i)))
((pair? ls)
(let ((w (car ls)))
(match-one
w
p
(car ls)
(set-car! ls)
(match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk
i)))
(else fk)))))))))
(define-syntax
match-verify-no-ellipses
(syntax-rules
()
((_ (x . y) sk)
(match-check-ellipse
x
(match-syntax-error
"multiple ellipse patterns not allowed at same level")
(match-verify-no-ellipses y sk)))
((_ x sk) sk)))
(define-syntax
match-vector
(syntax-rules
(___)
((_ v n pats (p q) sk fk i)
(match-check-ellipse
q
(match-vector-ellipses v n pats p sk fk i)
(match-vector-two v n pats (p q) sk fk i)))
((_ v n pats (p ___) sk fk i) (match-vector-ellipses v n pats p sk fk i))
((_ . x) (match-vector-two . x))))
(define-syntax
match-vector-two
(syntax-rules
()
((_ v n ((pat index) ...) () sk fk i)
(if (vector? v)
(let ((len (vector-length v)))
(if (= len n) (match-vector-step v ((pat index) ...) sk fk i) fk))
fk))
((_ v n (pats ...) (p . q) sk fk i)
(match-vector v (+ n 1) (pats ... (p n)) q sk fk i))))
(define-syntax
match-vector-step
(syntax-rules
()
((_ v () (sk ...) fk i) (sk ... i))
((_ v ((pat index) . rest) sk fk i)
(let ((w (vector-ref v index)))
(match-one
w
pat
(vector-ref v index)
(vector-set! v index)
(match-vector-step v rest sk fk)
fk
i)))))
(define-syntax
match-vector-ellipses
(syntax-rules
()
((_ v n ((pat index) ...) p sk fk i)
(if (vector? v)
(let ((len (vector-length v)))
(if (>= len n)
(match-vector-step
v
((pat index) ...)
(match-vector-tail v p n len sk fk)
fk
i)
fk))
fk))))
(define-syntax
match-vector-tail
(syntax-rules
()
((_ v p n len sk fk i)
(match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
(define-syntax
match-vector-tail-two
(syntax-rules
()
((_ v p n len (sk ...) fk i ((id id-ls) ...))
(let loop ((j n) (id-ls '()) ...)
(if (>= j len)
(let ((id (reverse id-ls)) ...) (sk ... i))
(let ((w (vector-ref v j)))
(match-one
w
p
(vector-ref v j)
(vetor-set! v j)
(match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
fk
i)))))))
(define-syntax
match-extract-vars
(syntax-rules
(_ ___ ? $ = quote quasiquote and or not get! set!)
((match-extract-vars (? pred . p) k i v) (match-extract-vars p k i v))
((match-extract-vars ($ rec . p) k i v) (match-extract-vars p k i v))
((match-extract-vars (= proc p) k i v) (match-extract-vars p k i v))
((match-extract-vars 'x (k ...) i v) (k ... v))
((match-extract-vars `x k i v)
(match-extract-quasiquote-vars x k i v (#t)))
((match-extract-vars (and . p) k i v) (match-extract-vars p k i v))
((match-extract-vars (or . p) k i v) (match-extract-vars p k i v))
((match-extract-vars (not . p) k i v) (match-extract-vars p k i v))
((match-extract-vars (p q . r) k i v)
(match-check-ellipse
q
(match-extract-vars (p . r) k i v)
(match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
((match-extract-vars (p . q) k i v)
(match-extract-vars p (match-extract-vars-step q k i v) i ()))
((match-extract-vars #(p ...) k i v) (match-extract-vars (p ...) k i v))
((match-extract-vars _ (k ...) i v) (k ... v))
((match-extract-vars ___ (k ...) i v) (k ... v))
((match-extract-vars p (k ...) (i ...) v)
(let-syntax
((new-sym?
(syntax-rules
(i ...)
((new-sym? p sk fk) sk)
((new-sym? x sk fk) fk))))
(new-sym? random-sym-to-match (k ... ((p p-ls) . v)) (k ... v))))))
(define-syntax
match-extract-vars-step
(syntax-rules
()
((_ p k i v ((v2 v2-ls) ...))
(match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))))
(define-syntax
match-extract-quasiquote-vars
(syntax-rules
(quasiquote . ,unquote-splicing)
((match-extract-quasiquote-vars `x k i v d)
(match-extract-quasiquote-vars x k i v (#t . d)))
((match-extract-quasiquote-vars ,@x k i v d)
(match-extract-quasiquote-vars ,x k i v d))
((match-extract-quasiquote-vars ,x k i v (#t))
(match-extract-vars x k i v))
((match-extract-quasiquote-vars ,x k i v (#t . d))
(match-extract-quasiquote-vars x k i v d))
((match-extract-quasiquote-vars (x . y) k i v (#t . d))
(match-extract-quasiquote-vars
x
(match-extract-quasiquote-vars-step y k i v d)
i
()))
((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
(match-extract-quasiquote-vars (x ...) k i v d))
((match-extract-quasiquote-vars x (k ...) i v (#t . d)) (k ... v))))
(define-syntax
match-extract-quasiquote-vars-step
(syntax-rules
()
((_ x k i v d ((v2 v2-ls) ...))
(match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))))
(define-syntax
match-lambda
(syntax-rules () ((_ clause ...) (lambda (expr) (match expr clause ...)))))
(define-syntax
match-lambda*
(syntax-rules () ((_ clause ...) (lambda expr (match expr clause ...)))))
(define-syntax
match-let
(syntax-rules
()
((_ (vars ...) . body) (match-let/helper let () () (vars ...) . body))
((_ loop . rest) (match-named-let loop () . rest))))
(define-syntax
match-letrec
(syntax-rules
()
((_ vars . body) (match-let/helper letrec () () vars . body))))
(define-syntax
match-let/helper
(syntax-rules
()
((_ let ((var expr) ...) () () . body) (let ((var expr) ...) . body))
((_ let ((var expr) ...) ((pat tmp) ...) () . body)
(let ((var expr) ...) (match-let* ((pat tmp) ...) . body)))
((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
(match-let/helper
let
(v ... (tmp expr))
(p ... ((a . b) tmp))
rest
.
body))
((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
(match-let/helper
let
(v ... (tmp expr))
(p ... (#(a ...) tmp))
rest
.
body))
((_ let (v ...) (p ...) ((a expr) . rest) . body)
(match-let/helper let (v ... (a expr)) (p ...) rest . body))))
(define-syntax
match-named-let
(syntax-rules
()
((_ loop ((pat expr var) ...) () . body)
(let loop ((var expr) ...) (match-let ((pat var) ...) . body)))
((_ loop (v ...) ((pat expr) . rest) . body)
(match-named-let loop (v ... (pat expr tmp)) rest . body))))
(define-syntax
match-let*
(syntax-rules
()
((_ () . body) (begin . body))
((_ ((pat expr) . rest) . body)
(match expr (pat (match-let* rest . body))))))
(define-syntax
match-check-ellipse
(syntax-rules
()
((match-check-ellipse (a . b) success-k failure-k) failure-k)
((match-check-ellipse #(a ...) success-k failure-k) failure-k)
((match-check-ellipse id success-k failure-k)
(let-syntax
((ellipse?
(syntax-rules
()
((ellipse? (foo id) sk fk) sk)
((ellipse? other sk fk) fk))))
(ellipse? (a b c) success-k failure-k)))))
(define-syntax
match-check-identifier
(syntax-rules
()
((_ (x . y) success-k failure-k) failure-k)
((_ #(x ...) success-k failure-k) failure-k)
((_ x success-k failure-k)
(let-syntax
((sym? (syntax-rules () ((sym? x sk fk) sk) ((sym? y sk fk) fk))))
(sym? abracadabra success-k failure-k))))))
(maintainer: "Matthew Martin <matt.a.martin@gmail.com>")
(author: "Alex Shinn <foof@synthcode.com>")
(homepage: "http://synthcode.com/scheme/")
(description:
"An R5RS hygienic pattern matcher backwards compatible with Andrew Wright's MATCH syntax.")
(keywords: syntax)
(license: public-domain))