| 123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194 |
- (library (match-definitions)
- (export trie-merge compile-pattern interpret-tree)
- (import (chezscheme))
- (define (push-box! b v)
- (set-box! b (cons v (unbox b))))
- (define (length=? l n)
- (if (null? l)
- (= n 0)
- (if (pair? l)
- (length=? (cdr l) (- n 1))
- #f)))
- (define syntax-car
- (lambda (ls)
- (syntax-case ls ()
- ((x . y) #'x))))
- (define syntax-cdr
- (lambda (ls)
- (syntax-case ls ()
- ((x . y) #'y))))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; This is the code for merging a list of instructions into a trie
- (define terminator (cons '() '()))
- (define (trie-merge seqs)
- (cond ((null? seqs)
- '())
- ((member '() seqs)
- (cons terminator
- (trie-merge (filter pair? seqs))))
- (else (let* ((p (partition-by-head (caar seqs) seqs))
- (tails (car p))
- (rest (cdr p)))
- (cons `(,(caar seqs) . ,(trie-merge tails))
- (trie-merge rest))))))
- (define (partition-by-head head seqs)
- (cond ((null? seqs)
- terminator)
- (else (let* ((p (partition-by-head head (cdr seqs)))
- (l (car p))
- (r (cdr p)))
- (if (equal? (syntax->datum head)
- (syntax->datum (caar seqs)))
- (cons (cons (cdar seqs) l) r)
- (cons l (cons (car seqs) r)))))))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; This is the interpreter for trees of matching instructions.
- ;; matching instructions are as defined in compile-pattern,
- ;; and the trees terminate with an (execute <code>) command
- ;; The interpreter handles scope explicitly and manages a
- ;; fail continuation to do backtracking.
- (define-syntax interpret-tree
- (syntax-rules (execute bind compare-equal? guard decons)
- ((interpret-tree scope () stack failure)
- failure)
- ((interpret-tree scope (((execute <body>) (())) <alternatives> ...) stack failure)
- (let* scope <body>))
- ((interpret-tree scope (((bind <var>) <then> ...) <alternatives> ...) stack failure)
- (let ((top (car stack))
- (new-stack (cdr stack)))
- (interpret-tree ((<var> top) . scope) (<then> ...) new-stack
- (interpret-tree scope (<alternatives> ...) stack failure))))
- ((interpret-tree scope (((compare-equal? <s-expr>) <then> ...) <alternatives> ...)
- stack failure)
- (let ((top (car stack))
- (new-stack (cdr stack)))
- (if (let* scope (equal? top <s-expr>))
- (interpret-tree scope (<then> ...) new-stack failure)
- (interpret-tree scope (<alternatives> ...) stack failure))))
- ((interpret-tree scope (((guard <predicate>) <then> ...) <alternatives> ...)
- stack failure)
- (if (let* scope <predicate>)
- (interpret-tree scope (<then> ...) stack failure)
- (interpret-tree scope (<alternatives> ...) stack failure)))
-
- ((interpret-tree scope (((decons) <then> ...) <alternatives> ...) stack failure)
- (let ((top (car stack))
- (new-stack (cdr stack))
- (fail-thunk (lambda ()
- (interpret-tree scope (<alternatives> ...) stack failure))))
- (if (pair? top)
- (let ((stack (cons (car top) (cons (cdr top) new-stack))))
- (interpret-tree scope (<then> ...) stack (fail-thunk)))
- (fail-thunk))))))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; This part compiles a pattern into a sequence of matching instructions
- ;; that performs the testing and binding operations
- ;;
- ;; Update this part to change or extend the pattern language.
- ;; <pat> ::= <var> | '<data> | `<qq>
- ;; | (list <pat> ...)
- ;;
- ;; <qq> ::= <atom> | ,<pat> | (<qq> . <qq>)
- (define (identifier-mem? x ls)
- (and (not (null? ls))
- (or (bound-identifier=? x (car ls))
- (identifier-mem? x (cdr ls)))))
- (define (var? s) (symbol? (syntax->datum s)))
- (define (atomic? s)
- (let ((s (syntax->datum s)))
- (or (null? s)
- (symbol? s) (number? s)
- (boolean? s) (string? s))))
- (define (quoted? s)
- (let ((s (syntax->datum s)))
- (and (length=? s 2) (eq? 'quote (car s)))))
- (define (quasiquoted? s)
- (let ((s (syntax->datum s)))
- (and (length=? s 2) (eq? 'quasiquote (car s)))))
- (define (unquote? s)
- (let ((s (syntax->datum s)))
- (and (length=? s 2) (eq? 'unquote (car s)))))
- (define (compile-pattern box pat rest)
- (cond ((var? pat) (compile-var box pat rest))
- ((quoted? pat)
- (let ((pat (syntax-car (syntax-cdr pat))))
- (compile-quoted box pat rest)))
- ((quasiquoted? pat)
- (let ((pat (syntax-car (syntax-cdr pat))))
- (compile-quasiquoted box pat rest)))
- (else (error 'compile-pattern "Invalid pattern" pat))))
- (define (compile-var box var rest)
- (if (identifier-mem? var (unbox box))
- (cons #`(compare-equal? #,var) (rest))
- (begin
- (push-box! box var)
- (cons #`(bind #,var) (rest)))))
- (define (compile-quoted box dat rest)
- (cons #`(compare-equal? '#,dat) (rest)))
- (define (compile-quasiquoted box pat rest)
- (cond ((atomic? pat) (compile-quoted box pat rest))
- ((unquote? pat) (compile-pattern box (syntax-car (syntax-cdr pat)) rest))
- (else (let ((x (syntax-car pat))
- (y (syntax-cdr pat)))
- (cons #'(decons)
- (compile-quasiquoted
- box x
- (lambda ()
- (compile-quasiquoted
- box y
- rest))))))))
- )
- (library (match)
- (export match)
- (import (chezscheme) (match-definitions))
- (define-syntax (match stx)
- (define (compile-pattern^ entry)
- (compile-pattern (box '())
- (car entry)
- (lambda ()
- (list #`(execute #,(cadr entry))))))
- (syntax-case stx (else)
- ((match <exp> (<pattern> <body> ...) ... (else <fail> ...))
- (let* ((rules #'((<pattern> (begin <body> ...)) ...))
- (instructions (map compile-pattern^ (syntax->list rules)))
- (trie (trie-merge instructions)))
- #`(let ((stack (list <exp>)))
- (interpret-tree ()
- #,trie
- stack
- (begin <fail> ...)))))
- ((match <exp> (<pattern> <body> ...) ...)
- #'(match <exp> (<pattern> <body> ...) ... (else (error 'match "Failed to match"))))))
- )
|
