Skip to content

Instantly share code, notes, and snippets.

@orchid-hybrid
Last active August 29, 2015 14:08
Show Gist options
  • Save orchid-hybrid/4901f7dd330be112d52e to your computer and use it in GitHub Desktop.
Save orchid-hybrid/4901f7dd330be112d52e to your computer and use it in GitHub Desktop.
very simple pattern match compiler

This has grown into a repo itself, here is the latest version:

Version 1: Matching data against a simple pattern

The syntax for patterns is

<pat> ::= <var>
        | (<symbol> <pat> ...)

The virtual machine for processing patterns has the following instructions

<inst> ::= (bind <var>)
         | (compare-and-destructure <sym> <int>)

The virtual machine operates on a stack processing a list of instructions sequentially with an 'early escape' failure continuation. Initially the stack just contains the data being processed as a single element. Instructions are interpreted like this:

  • (bind <var>) will pop an element off the top of the stack and bind to it
  • (compare-and-destrcture <sym> <int>) checks that the top of the stack is a list with CAR equal to and length equal to , if so it appends all the list elements onto the stack otherwise fails.

Compilation is done as follows:

[[ <var> ]] = (bind <var>)
[[ (<symbol> <pat> ...) ]] = (compare-and-destructure <symbol> length-of-list) [[ <pat> ]] ...

Example

The pattern (if a b c)

compiles into (compare-and-destructure if 4) (bind a) (bind b) (bind c)

and matching this against the input data (if #t yes no) would be executed like this:

(list '(if #t yes no)) 
(list #t 'yes 'no)
 { a = #t }
(list 'yes 'no)
 { b = yes }
(list 'no)
 { c = no }
(list)

Another example is that the pattern (or (t) (f)) would compile into (compare-and-destructure or 3) (compare-and-destructure t 1) (compare-and-destructure f 1)

Version 2: Matching against a series of patterns

In order to match an object against a whole list of patterns and share some of the destructuring effort between similar cases we change the virtual machine to process a tree of instructions rather than a linear list. The execution of the VM will run similar to prolog with a depth-first search over the tree with a failure continuation which will be used to roll back and try other cases.

Add the following instruction

<inst> ::= ... | (execute <scheme>)

whose meaning is to run the scheme code inside the bindings that the pattern matcher did.

Compilation is done by compiling each pattern then merging the lists into a tree based on common prefixes.

Example of use

(define (my-eval exp env)
  (match exp
    ((int i) => i)
    ((add a b) => (+ (my-eval a env) (my-eval b env)))
    ((abs p b) => (list 'cls exp env))
    ((var a) => (cond ((assoc a env) => cdr)
                      (else (error "unbound variable" a))))
    ((app f a) =>  (match (my-eval f env)
                     ((cls (abs p b) cenv) => (my-eval b (cons (cons p (my-eval a env)) cenv)))
                     (else (error "not a valid function: " f))))
    (else (error "invalid expression: " exp))))

(my-eval '(app (app (abs a (abs b (add (var a) (var b)))) (int 1)) (int 2)) '())
;; => 3

take from https://gist.github.com/tca/6aae08b905487f74cfbb

Version 3: matching against quasiquotated patterns

The previous pattern matchers make more sense for matching something like prolog functors than lisp lists. In particular there doesn't seem to be any good way to extend it to support matching for patterns describing variable length lists like (<pattern> . x). This is really useful in scheme programming so do implement this we should treat s-expressions as built out of pairs and atoms. Here's a new pattern language syntax:

<pat> ::= <var>
        | `<qpat>   ; (quasiquote <qpat>)
        | '<s-exp>  ; (quote <exp>)
<qpat> ::= <sym>
        | ,<pat>   ; (unquote <qpat>)
        | (<qpat> . <qpat>)

The virtual machine now handles slightly different operations

  • (bind <var>)
  • (compare-equal? <s-exp>) - pop off the top of the stack and check that it is equal to expression
  • (compare-eq? <atom>)
  • (decons) - Split a cons and push its car, cdr onto the stack (fail if it's not a cons)
  • (execute <body>)

Version 4: bugfixes

In this version two important bugs were fixed.

  • The first in sift-by, the accumulators needed reversed. Without that the ordering of the patterns was being mixed and permuted.
  • The second was that variables were being bound even in the failure continuation. The fix for this was to manage a scope manually.

Here is the test case for the second one, on (if x y) it binds t to y in the else case:

;; BUG in pattern matcher found
(define (foo t)
  ;; #;3> (foo '(if a b))
  ;; (funcall b)
  (match t
    (`(if ,b ,t ,e) => (list 'if b t e))
    (`(begin . ,rest) => (list 'begin rest))
    (`(evil ,x ,x) => (list 'evil x))
    (else (list 'funcall t))))
(module pat (match)
(import chicken scheme)
;; <pat> ::= (<symbol> <pat> ...) | <var>
(begin-for-syntax
(define (concatenate lists)
(apply append lists))
;; data Rose a = a :- [Rose a]
;; merge = map merge' . groupBy ((==)`on`head) . filter (not . null)
;; merge' strings = head (head strings) :- merge (map tail strings)
(define (sift-by comparator thing things)
(let loop ((to-process things)
(yes (list thing))
(no '()))
(if (null? to-process)
(values yes no)
(let ((this (car to-process)))
(if (comparator thing this)
(loop (cdr to-process) (cons this yes) no)
(loop (cdr to-process) yes (cons this no)))))))
(define (group-by comparator things)
(if (null? things)
'()
(let ((x (car things)))
(call-with-values (lambda () (sift-by comparator x (cdr things)))
(lambda (ys zs)
(cons (cons x ys)
(group-by comparator zs)))))))
(define (filter pred list)
(if (null? list)
'()
(if (pred (car list))
(cons (car list) (filter pred (cdr list)))
(filter pred (cdr list)))))
(define (merge sequences)
(define comparator (lambda (x y) (equal? (car x) (car y))))
(define (not-null? n) (not (null? n)))
(map merge* (group-by comparator (filter not-null? sequences))))
(define (merge* sequences)
;; invariant: all sequences have the same car
(list 'branch
(caar sequences)
(merge (map cdr sequences))))
(define (compile-pattern pat)
(cond ((symbol? pat) (list `(bind ,pat)))
((and (list? pat)
(symbol? (car pat)))
(concatenate (cons (list `(compare-and-destructure ',(car pat) ,(length pat)))
(map compile-pattern (cdr pat)))))
(else (print pat) (error "not a proper pattern"))))
(define (compile-patterns patterns bodies)
;; patterns must finish with bodies
;; and bodies
(merge (map append
(map compile-pattern patterns)
(map (lambda (body) (list (list 'execute body))) bodies))))
(define match-expander-er
(lambda (form rename compare?)
(let ((pats (car (cdr form)))
(results (cadr (cdr form)))
(stack (caddr (cdr form)))
(fail (cadddr (cdr form)))
(%interpret-pat (rename 'interpret-pat)))
`(,%interpret-pat ,(compile-patterns pats results)
,stack
,fail))))
)
(define-syntax interpret-pat
(syntax-rules (compare-and-destructure bind)
((interpret-pat () stack failure)
failure)
((interpret-pat ((branch (execute <body>) ()) <alternatives> ...) stack failure)
<body>)
((interpret-pat ((branch (bind <var>) <then>) <alternatives> ...) stack failure)
(let ((<var> (car stack))
(new-stack (cdr stack)))
(interpret-pat <then> new-stack (interpret-pat (<alternatives> ...) stack failure))))
((interpret-pat ((branch (compare-and-destructure <symbol> <length>) <then>) <alternatives> ...) stack failure)
(let ((top (car stack))
(new-stack (cdr stack)))
(if (and (list? top)
(eq? (car top) <symbol>)
(= (length top) <length>))
(let ((stack (append (cdr top) new-stack)))
(interpret-pat <then> stack failure))
(interpret-pat (<alternatives> ...) stack failure))))))
(define-syntax match
(syntax-rules (=>)
((match t (<pat> => <body>) ... (else <else>))
(let ((stack (list t)))
(match-expander (<pat> ...) (<body> ...)
stack
<else>)))
((match t (<pat> => <body>) ...)
(match t (<pat> => <body>) ...
(else (error "pattern match fell through"))))))
(define-syntax match-expander
(er-macro-transformer match-expander-er))
;; Error: during expansion of (match-expander290 ...) - unbound variable: compile-patterns
;; (define (foo t)
;; (match t
;; ((foo (e x) y) => (list 'foo-e x y x))
;; ((foo x (f y)) => (list 'foo-f x y x))
;; ((foo x y) => (list 'foo x y x))
;; ((bar x y) => (list 'bar x y x))))
)
;; <pat> ::= (<symbol> <pat> ...) | <var>
(define (concatenate lists)
(apply append lists))
;; data Rose a = a :- [Rose a]
;; merge = map merge' . groupBy ((==)`on`head) . filter (not . null)
;; merge' strings = head (head strings) :- merge (map tail strings)
(define (sift-by comparator thing things)
(let loop ((to-process things)
(yes (list thing))
(no '()))
(if (null? to-process)
(values yes no)
(let ((this (car to-process)))
(if (comparator thing this)
(loop (cdr to-process) (cons this yes) no)
(loop (cdr to-process) yes (cons this no)))))))
(define (group-by comparator things)
(if (null? things)
'()
(let ((x (car things)))
(call-with-values (lambda () (sift-by comparator x (cdr things)))
(lambda (ys zs)
(cons (cons x ys)
(group-by comparator zs)))))))
(define (filter pred list)
(if (null? list)
'()
(if (pred (car list))
(cons (car list) (filter pred (cdr list)))
(filter pred (cdr list)))))
(define (merge sequences)
(define comparator (lambda (x y) (equal? (car x) (car y))))
(define (not-null? n) (not (null? n)))
(map merge* (group-by comparator (filter not-null? sequences))))
(define (merge* sequences)
;; invariant: all sequences have the same car
(list 'branch
(caar sequences)
(merge (map cdr sequences))))
(define (compile-pattern pat)
(cond ((symbol? pat) (list `(bind ,pat)))
((and (list? pat)
(symbol? (car pat)))
(concatenate (cons (list `(compare-and-destructure ',(car pat) ,(length pat)))
(map compile-pattern (cdr pat)))))
(else (error "not a proper pattern"))))
(define (compile-patterns patterns bodies)
;; patterns must finish with bodies
;; and bodies
(merge (map append
(map compile-pattern patterns)
(map (lambda (body) (list (list 'execute body))) bodies))))
(define-syntax interpret-pat
(syntax-rules (compare-and-destructure bind)
((interpret-pat () stack failure)
failure)
((interpret-pat ((branch (execute <body>) ()) <alternatives> ...) stack failure)
<body>)
((interpret-pat ((branch (bind <var>) <then>) <alternatives> ...) stack failure)
(let ((<var> (car stack))
(new-stack (cdr stack)))
(interpret-pat <then> new-stack (interpret-pat (<alternatives> ...) stack failure))))
((interpret-pat ((branch (compare-and-destructure <symbol> <length>) <then>) <alternatives> ...) stack failure)
(let ((top (car stack))
(new-stack (cdr stack)))
(if (and (list? top)
(eq? (car top) <symbol>)
(= (length top) <length>))
(let ((stack (append (cdr top) new-stack)))
(interpret-pat <then> stack failure))
(interpret-pat (<alternatives> ...) stack failure))))))
(define (foo t)
(let ((stack (list t)))
(interpret-pat ((branch (compare-and-destructure 'a 2) ((branch (bind x) ((branch (execute x) ())))))
(branch (compare-and-destructure 'b 2) ((branch (bind y) ((branch (execute y) ()))))))
stack
(display "fail :)"))))
(define (bar t)
;; (compile-patterns (list '(f x (t)) '(f (f) y)) (list ''yes ''no))
(let ((stack (list t)))
(interpret-pat
((branch
(compare-and-destructure 'f 3)
((branch (bind x) ((branch (compare-and-destructure 't 1) ((branch (execute 'yes) ())))))
(branch (compare-and-destructure 'f 1) ((branch (bind y) ((branch (execute 'no) ()))))))))
stack
(display "FILA"))))
;; <pat> ::= (<symbol> <pat> ...) | <var>
(define (concatenate lists)
(apply append lists))
(define (compile-pattern pat)
(cond ((symbol? pat) (list `(bind ,pat)))
((and (list? pat)
(symbol? (car pat)))
(concatenate (cons (list `(compare-and-destructure ',(car pat) ,(length pat)))
(map compile-pattern (cdr pat)))))
(else (error "not a proper pattern"))))
(define-syntax interpret-patcode
(syntax-rules (bind compare-and-destructure)
((interpret-patcode () stack body)
body)
((interpret-patcode ((bind <var>) code ...) stack body)
(let ((<var> (car stack))
(stack (cdr stack)))
(interpret-patcode (code ...) stack body)))
((interpret-patcode ((compare-and-destructure head len) code ...) stack body)
(let ((top (car stack))
(stack (cdr stack)))
(if (and (list? top)
(eq? (car top) head)
(= (length top) len))
(let ((stack (append (cdr top) stack)))
(interpret-patcode (code ...) stack body))
(begin (display (list "pattern match failed" top head len))
(newline)))))))
(define (foo t)
(let ((stack (list t)))
(interpret-patcode ((compare-and-destructure 'foo 3) (bind bar) (bind baz))
stack
(list bar baz))))
(define (bar t)
(let ((stack (list t)))
(interpret-patcode ((compare-and-destructure 'lambda 3) (compare-and-destructure 'x 1) (compare-and-destructure '+ 3) (bind p) (bind q))
stack
(list p q))))
;; > (compile-pattern '(lambda (x) (+ p q)))
;; ((compare-and-destructure 'lambda 3) (compare-and-destructure 'x 1) (compare-and-destructure '+ 3) (bind p) (bind q))
;; > (bar '(foo bar))
;; (pattern match failed (foo bar) lambda 3)
;; > (bar '(lambda a b))
;; (pattern match failed a x 1)
;; > (bar '(lambda (x) b))
;; ( pattern match failed b + 3)
;; > (bar '(lambda (x) (+ uuu vvv)))
;; (uuu vvv)
(module pat (match)
(import chicken scheme)
;; OLD SYNTAX: <pat> ::= (<symbol> <pat> ...) | <var>
;; NEW SYNTAX:
;; <pat> ::= <var>
;; | `<qpat> ; (quasiquote <qpat>)
;; | '<s-exp> ; (quote <exp>)
;; <qpat> ::= <sym>
;; | ,<pat> ; (unquote <qpat>)
;; | (<qpat> . <qpat>)
(begin-for-syntax
(define (concatenate lists)
(apply append lists))
;; data Rose a = a :- [Rose a]
;; merge = map merge' . groupBy ((==)`on`head) . filter (not . null)
;; merge' strings = head (head strings) :- merge (map tail strings)
(define (sift-by comparator thing things)
(let loop ((to-process things)
(yes (list thing))
(no '()))
(if (null? to-process)
(values (reverse yes) (reverse no)) ;; !!!!!!!!!!
(let ((this (car to-process)))
(if (comparator thing this)
(loop (cdr to-process) (cons this yes) no)
(loop (cdr to-process) yes (cons this no)))))))
(define (group-by comparator things)
(if (null? things)
'()
(let ((x (car things)))
(call-with-values (lambda () (sift-by comparator x (cdr things)))
(lambda (ys zs)
(cons (cons x ys)
(group-by comparator zs)))))))
(define (filter pred list)
(if (null? list)
'()
(if (pred (car list))
(cons (car list) (filter pred (cdr list)))
(filter pred (cdr list)))))
(define (merge sequences)
(define comparator (lambda (x y) (equal? (car x) (car y))))
(define (not-null? n) (not (null? n)))
(map merge* (group-by comparator (filter not-null? sequences))))
(define (merge* sequences)
;; invariant: all sequences have the same car
(list 'branch
(caar sequences)
(merge (map cdr sequences))))
(define (compile-pattern pat)
(cond ((symbol? pat) (list `(bind ,pat)))
((and (list? pat)
(= 2 (length pat)))
(case (car pat)
((quote) (list `(compare-equal? ',(cadr pat))))
((quasiquote) (compile-quasipattern (cadr pat)))))
(else (error "Invalid pattern"))))
(define (compile-quasipattern qpat)
(cond ((or (symbol? qpat) (null? qpat)) (list `(compare-eq? ',qpat)))
((and (list? qpat)
(= 2 (length qpat))
(eq? (car qpat) 'unquote))
(compile-pattern (cadr qpat)))
((pair? qpat) (cons '(decons) (append (compile-quasipattern (car qpat))
(compile-quasipattern (cdr qpat)))))
(else (error "invalid qpat"))))
(define (compile-patterns patterns bodies)
;; patterns must finish with bodies
;; and bodies
(merge (map append
(map compile-pattern patterns)
(map (lambda (body) (list (list 'execute body))) bodies))))
(define match-expander-er
(lambda (form rename compare?)
(let ((pats (car (cdr form)))
(results (cadr (cdr form)))
(stack (caddr (cdr form)))
(fail (cadddr (cdr form)))
(%interpret-pat (rename 'interpret-pat)))
`(,%interpret-pat ,(compile-patterns pats results)
,stack
,fail))))
)
;; (bind <var>)
;; (compare-equal? <s-exp>)
;; (compare-eq? <atom>)
;; (decons)
;; (execute <body>)
(define-syntax interpret-pat
(syntax-rules (compare-and-destructure bind)
((interpret-pat () stack failure)
failure)
((interpret-pat ((branch (execute <body>) ()) <alternatives> ...) stack failure)
<body>)
((interpret-pat ((branch (bind <var>) <then>) <alternatives> ...) stack failure)
(let ((<var> (car stack))
(new-stack (cdr stack)))
(interpret-pat <then> new-stack (interpret-pat (<alternatives> ...) stack failure))))
((interpret-pat ((branch (compare-eq? <atom>) <then>) <alternatives> ...) stack failure)
(let ((top (car stack))
(new-stack (cdr stack)))
(if (eq? top <atom>)
(interpret-pat <then> new-stack failure)
(interpret-pat (<alternatives> ...) stack failure))))
((interpret-pat ((branch (compare-equal? <s-expr>) <then>) <alternatives> ...) stack failure)
(let ((top (car stack))
(new-stack (cdr stack)))
(if (equal? top <s-expr>)
(interpret-pat <then> new-stack failure)
(interpret-pat (<alternatives> ...) stack failure))))
((interpret-pat ((branch (decons) <then>) <alternatives> ...) stack failure)
(let ((top (car stack))
(new-stack (cdr stack)))
(if (pair? top)
(let ((stack (cons (car top) (cons (cdr top) new-stack))))
(interpret-pat <then> stack failure))
(interpret-pat (<alternatives> ...) stack failure))))
;; ((interpret-pat ((branch (compare-and-destructure <symbol> <length>) <then>) <alternatives> ...) stack failure)
;; (let ((top (car stack))
;; (new-stack (cdr stack)))
;; (if (and (list? top)
;; (eq? (car top) <symbol>)
;; (= (length top) <length>))
;; (let ((stack (append (cdr top) new-stack)))
;; (interpret-pat <then> stack failure))
;; (interpret-pat (<alternatives> ...) stack failure))))
))
(define-syntax match
(syntax-rules (=>)
((match t (<pat> => <body>) ... (else <else>))
(let ((stack (list t)))
(match-expander (<pat> ...) (<body> ...)
stack
<else>)))
((match t (<pat> => <body>) ...)
(match t (<pat> => <body>) ...
(else (error "pattern match fell through"))))))
(define-syntax match-expander
(er-macro-transformer match-expander-er))
;; Error: during expansion of (match-expander290 ...) - unbound variable: compile-patterns
;; (define (foo t)
;; (match t
;; ((foo (e x) y) => (list 'foo-e x y x))
;; ((foo x (f y)) => (list 'foo-f x y x))
;; ((foo x y) => (list 'foo x y x))
;; ((bar x y) => (list 'bar x y x))))
;; Interesting pattern matching test taken from Oleg's page http://okmij.org/ftp/Scheme/macros.html#match-case-simple
(define (int code env)
(match code
(`(quote ,x) => x)
(`(let ((,x ,e)) ,body) =>
(let ((xv (int e env)))
(int body (cons (cons x xv) env))))
(`(lambda () ,body) => ; thunk
(lambda () (int body env))) ; closed over the env
(`(lambda (,x) ,body) => ; 1-arg function
(lambda (xv)
(int body (cons (cons x xv) env))))
; the general case of lambda is skipped to keep the example small
(`(lambda ,argl ,body) => ; arglist
(lambda arglv
(int body (cons (cons argl arglv) env))))
(`(,op . ,args) =>
(let* ((opv (int op env))
(argvs (map (lambda (c) (int c env)) args)))
(apply opv argvs)))
(x => (if (symbol? x) (lookup x env) x))
))
(define (lookup x env)
(cond
((assq x env) => cdr)
(else (error "Can't find " x))))
(define env0
(map (lambda (x) (cons x (eval x (interaction-environment))))
'(+ - display))) ; add more
(define (run-tests)
(int 1 env0) ; 1
(int '1 env0) ; '1 is the same as 1
(int '(quote x) env0) ; x
(int '(display 'x) env0) ; x
;(int '(display x) env0) ; error: unbound x
(int '(let ((x (+ 1 2 3))) (display x)) env0) ; 6
((int '(lambda () 1) env0)) ; 1
((int '(lambda (x) x) env0) 1) ; 1
(((int '(lambda (x) (lambda (y) (+ x y))) env0) 2) 3) ; 5 (test closure)
((int '(lambda l (display l)) env0) 1 2 3) ; (1 2 3)
)
;; #;5> (compile-patterns '(`(quote ,x) `(let ((,x ,e)) ,body) `(lambda () ,body) `(,op . ,args) x) '(1 2 3 4 5))
;; ((branch (decons) ((branch (compare-eq? (quote quote)) ((branch (decons) ((branch (bind x) ((branch (compare-eq? (quote ())) ((branch (execute 1) ()))))))))) (branch (compare-eq? (quote let)) ((branch (decons) ((branch (decons) ((branch (decons) ((branch (bind x) ((branch (decons) ((branch (bind e) ((branch (compare-eq? (quote ())) ((branch (compare-eq? (quote ())) ((branch (decons) ((branch (bind body) ((branch (compare-eq? (quote ())) ((branch (execute 2) ()))))))))))))))))))))))))) (branch (bind op) ((branch (bind args) ((branch (execute 4) ()))))) (branch (compare-eq? (quote lambda)) ((branch (decons) ((branch (compare-eq? (quote ())) ((branch (decons) ((branch (bind body) ((branch (compare-eq? (quote ())) ((branch (execute 3) ()))))))))))))))) (branch (bind x) ((branch (execute 5) ()))))
;; ((branch (decons)
;; ((branch (compare-eq? (quote quote))
;; ((branch (decons)
;; ((branch (bind x)
;; ((branch (compare-eq? (quote ()))
;; ((branch (execute 1) ())))))))))
;; (branch (compare-eq? (quote let))
;; ((branch (decons)
;; ((branch (decons)
;; ((branch (decons)
;; ((branch (bind x)
;; ((branch (decons)
;; ((branch (bind e)
;; ((branch (compare-eq? (quote ()))
;; ((branch (compare-eq? (quote ()))
;; ((branch (decons)
;; ((branch (bind body)
;; ((branch (compare-eq? (quote ()))
;; ((branch (execute 2) ())))))))))))))))))))))))))
;; (branch (bind op)
;; ((branch (bind args)
;; ((branch (execute 4) ())))))
;; (branch (compare-eq? (quote lambda))
;; ((branch (decons)
;; ((branch (compare-eq? (quote ()))
;; ((branch (decons)
;; ((branch (bind body)
;; ((branch (compare-eq? (quote ()))
;; ((branch (execute 3) ())))))))))))))))
;; (branch (bind x)
;; ((branch (execute 5) ()))))
)
(module pat (match)
(import chicken scheme)
;; <pat> ::= <var>
;; | `<qpat> ; (quasiquote <qpat>)
;; | '<s-exp> ; (quote <exp>)
;; <qpat> ::= <sym>
;; | ,<pat> ; (unquote <qpat>)
;; | (<qpat> . <qpat>)
(begin-for-syntax
;;;;;;;;;;;;;
;; Some list stuff that we need
(define (concatenate lists)
(apply append lists))
;; data Rose a = a :- [Rose a]
;; merge = map merge' . groupBy ((==)`on`head) . filter (not . null)
;; merge' strings = head (head strings) :- merge (map tail strings)
(define (sift-by comparator thing things)
(let loop ((to-process things)
(yes (list thing))
(no '()))
(if (null? to-process)
(values (reverse yes) (reverse no)) ;; !!!!!!!!!!
(let ((this (car to-process)))
(if (comparator thing this)
(loop (cdr to-process) (cons this yes) no)
(loop (cdr to-process) yes (cons this no)))))))
(define (group-by comparator things)
(if (null? things)
'()
(let ((x (car things)))
(call-with-values (lambda () (sift-by comparator x (cdr things)))
(lambda (ys zs)
(cons (cons x ys)
(group-by comparator zs)))))))
(define (filter pred list)
(if (null? list)
'()
(if (pred (car list))
(cons (car list) (filter pred (cdr list)))
(filter pred (cdr list)))))
(define (merge sequences)
(define comparator (lambda (x y) (equal? (car x) (car y))))
(define (not-null? n) (not (null? n)))
(map merge* (group-by comparator (filter not-null? sequences))))
(define (merge* sequences)
;; invariant: all sequences have the same car
(list 'branch
(caar sequences)
(merge (map cdr sequences))))
;;;;;;;;;;;;;
;; Compilation from a list of patterns to a tree of instructions
(define (compile-pattern pat)
(cond ((symbol? pat) (list `(bind ,pat)))
((and (list? pat)
(= 2 (length pat)))
(case (car pat)
((quote) (list `(compare-equal? ',(cadr pat))))
((quasiquote) (compile-quasipattern (cadr pat)))))
(else (error "Invalid pattern"))))
(define (compile-quasipattern qpat)
(cond ((or (symbol? qpat) (null? qpat)) (list `(compare-equal? ',qpat)))
((and (list? qpat)
(= 2 (length qpat))
(eq? (car qpat) 'unquote))
(compile-pattern (cadr qpat)))
((pair? qpat) (cons '(decons) (append (compile-quasipattern (car qpat))
(compile-quasipattern (cdr qpat)))))
(else (error "invalid qpat"))))
(define (compile-patterns patterns bodies)
;; patterns must finish with bodies
;; and bodies
(merge (map append
(map compile-pattern patterns)
(map (lambda (body) (list (list 'execute body))) bodies))))
(define match-expander-er
(lambda (form rename compare?)
(let ((pats (car (cdr form)))
(results (cadr (cdr form)))
(stack (caddr (cdr form)))
(fail (cadddr (cdr form)))
(%interpret-pat (rename 'interpret-pat)))
`(,%interpret-pat ()
,(compile-patterns pats results)
,stack
,fail))))
)
;;;;;;;;;;;;;
;; Interpreting the tree of instructions into scheme code
;; (bind <var>)
;; (compare-equal? <s-exp>)
;; (decons)
;; (execute <body>)
(define-syntax interpret-pat
(syntax-rules (compare-and-destructure bind)
((interpret-pat scope () stack failure)
failure)
((interpret-pat scope ((branch (execute <body>) ()) <alternatives> ...) stack failure)
(let* scope <body>))
((interpret-pat scope ((branch (bind <var>) <then>) <alternatives> ...) stack failure)
(let ((top (car stack))
(new-stack (cdr stack)))
(interpret-pat ((<var> top) . scope) <then> new-stack
(interpret-pat scope (<alternatives> ...) stack failure))))
((interpret-pat scope ((branch (compare-equal? <s-expr>) <then>) <alternatives> ...) stack failure)
(let ((top (car stack))
(new-stack (cdr stack)))
(if (equal? top <s-expr>)
(interpret-pat scope <then> new-stack failure)
(interpret-pat scope (<alternatives> ...) stack failure))))
((interpret-pat scope ((branch (decons) <then>) <alternatives> ...) stack failure)
(let ((top (car stack))
(new-stack (cdr stack)))
(if (pair? top)
(let ((stack (cons (car top) (cons (cdr top) new-stack))))
(interpret-pat scope <then> stack failure))
(interpret-pat scope (<alternatives> ...) stack failure))))
))
(define-syntax match
(syntax-rules (=> else)
((match t (<pat> => <body>) ... (else <else>))
(let ((stack (list t)))
(match-expander (<pat> ...) (<body> ...) stack <else>)))
((match t (<pat> => <body>) ...)
(match t (<pat> => <body>) ...
(else (error "pattern match fell through"))))))
(define-syntax match-expander
(er-macro-transformer match-expander-er))
)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment