(define nfirst (flip take)) (define nrest (flip drop)) (define (? sym) (eq? #\? (car (symbol->string sym)))) (define (! sym) (eq? #\! (car (symbol->string sym)))) (define (plain? sym) (not (or (? sym) (! sym)))) (define to-plain (compose string->symbol cdr symbol->string)) (define (match pattern expression) (define (matchfun p e res cont) (if (null? p) (if (null? e) (list res cont) (cont)) (cond ((plain? (car p)) (cond ((null? e) (cont)) ((eq? (car e) (car p)) (matchfun (cdr p) (cdr e) res cont)) (else (cont)))) ((? (car p)) (if (null? e) (cont) ((lambda (v) (if (eq? v #f) (matchfun (cdr p) (cdr e) (cons (list (to-plain (car p)) (car e)) res) cont) (if (eq? (car e) (cadr v)) (matchfun (cdr p) (cdr e) res cont) (cont)))) (assq (to-plain (car p)) res)))) ((! (car p)) ((lambda (v) (if (eq? v #f) (letrec ((match* (lambda (n) (if (> n (length e)) (cont) (matchfun (cdr p) (nrest e n) (cons (list (car p) (nfirst e n)) res) (lambda () (match* (+ n 1)))))))) (match* 0)) (if (< (length e) (length (cadr v))) (cont) (if (eq? (nfirst e (length (cadr v))) (cadr v)) (matchfun (cdr p) (nrest e (length (cadr v))) res cont) (cont))))) (assq (to-plain (car p)) res))) (else (cont))))) (matchfun pattern expression '() (lambda () nil)))