(define-syntax ?member?
(syntax-rules ()
((_ e () sk fk) fk)
((_ e (x . xs) sk fk)
(let-syntax ((test (syntax-rules (x)
((test x) sk)
((test ?) (?member? e xs sk fk)))))
(test e)))))
(define-syntax match
(syntax-rules (quasiquote unquote make-k)
((match `() <exp> <env> <sk> <fk>) (if (null? <exp>) <sk> <fk>))
((match `,<place> <exp> <env> <sk> <fk>)
(let-syntax ((extend-environment
(syntax-rules (match)
((_ <ext> (match <pattern> <exp2> <env2> <sk2> <fk2>))
(match <pattern> <exp2> (<ext> . <env2>) <sk2> <fk2>))
((_ <ext> <else>) <else>))))
(?member? <place> <env>
(if (equal? <exp> <place>) <sk> <fk>)
(let ((<place> <exp>))
(extend-environment <place> <sk>)))))
((match `(<car> . <cdr>) <exp> <env> <sk> <fk>)
(if (pair? <exp>)
(let ((exp-car (car <exp>)) (exp-cdr (cdr <exp>)))
(match `<car> exp-car <env>
(match `<cdr> exp-cdr <env> <sk> <fk>) <fk>))
<fk>))
((match `<symbol> <exp> <env> <sk> <fk>)
(if (equal? '<symbol> <exp>) <sk> <fk>))))
(define-syntax pattern-case*
(syntax-rules (else)
((pattern-case* <exp>)
(void))
((pattern-case* <exp> (else <body> ...))
(begin <body> ...))
((pattern-case* <exp> (<pattern> <body> ...) <clauses> ...)
(let ((failure (lambda ()
(pattern-case* <exp> <clauses> ...))))
(match <pattern> <exp> () (begin <body> ...) (failure))))))
(define-syntax pattern-case
(syntax-rules ()
((pattern-case <exp> <clauses> ...)
(let ((exp <exp>))
(pattern-case* exp <clauses> ...)))))
(define-syntax pattern-lambda
(syntax-rules ()
((pattern-lambda (<pattern> <body> ...) ...)
(lambda args
(pattern-case args (<pattern> <body> ...) ...)))))
(define append
(pattern-lambda
(`(() ,ys) ys)
(`((,x . ,xs) ,ys) (cons x (append xs ys)))))
(define simpl
(pattern-lambda
(`((+ 0 ,x)) (simpl x))
(`((+ ,x 0)) (simpl x))
(`((* 1 ,x)) (simpl x))
(`((* ,x 1)) (simpl x))
(`((- ,x 0)) (simpl x))
(`((- ,x ,x)) 0)
(`((/ ,x 1)) (simpl x))
(`((/ ,x ,x)) 1)
(`((,op ,x ,y)) `(,op ,(simpl x) ,(simpl y)))
(`(,x) x)))
(define d
(pattern-lambda
(`(,x ,x) 1)
(`(,x (+ ,u ,v)) `(+ ,(d x u) ,(d x v)))
(`(,x (- ,u ,v)) `(- ,(d x u) ,(d x v)))
(`(,x (* ,u ,v)) `(+ (* ,u ,(d x v)) (* ,v ,(d x u))))
(`(,x (/ ,u ,v)) `(/ (- (* ,(d x u) ,v) (* ,(d x v) ,u)) (* ,v ,v)))))
Friday, 18 April 2008
Scheme Pattern Matching with syntax-rules
Subscribe to:
Posts (Atom)