(define nil ()) (define (eq x y) (or (and (eq? x 'nil) (eq? y #f)) (and (eq? y 'nil) (eq? x #f)) (eq? x y))) (define (atom v) (not (pair? v))) (define pair cons) (define hd car) (define tl cdr) (define-syntax fn (syntax-rules () ((_ rest ...) (lambda rest ...)))) (define-syntax ef (syntax-rules () ((_ test rest ...) (let ((t test)) (if (and t (not (eq t nil))) rest ...))))) (define meval (fn (exp) ((fn (meval) (meval meval nil exp)) (fn (meval env exp) ((fn (lookup values extend) (ef (atom exp) (lookup lookup exp env) ((fn (action) (ef (atom action) (ef (eq (hd exp) 'quote) (hd (tl exp)) (ef (eq (hd exp) 'atom) (atom (meval meval env (hd (tl exp)))) (ef (eq (hd exp) 'eq) (eq (meval meval env (hd (tl exp))) (meval meval env (hd (tl (tl exp))))) (ef (eq (hd exp) 'pair) (pair (meval meval env (hd (tl exp))) (meval meval env (hd (tl (tl exp))))) (ef (eq (hd exp) 'hd) (hd (meval meval env (hd (tl exp)))) (ef (eq (hd exp) 'tl) (tl (meval meval env (hd (tl exp)))) (ef (eq (hd exp) 'ef) (ef (meval meval env (hd (tl exp))) (meval meval env (hd (tl (tl exp)))) (meval meval env (hd (tl (tl (tl exp)))))) (ef (eq (hd exp) 'fn) (pair '__closure (pair env (tl exp))) nil)))))))) (ef (eq (hd action) '__closure__) ((fn (lex-env params fn-body) (meval meval (extend extend params (values values env (tl exp)) lex-env) fn-body)) (hd (tl action)) (hd (tl (tl action))) (hd (tl (tl (tl action))))) nil))) (meval meval env (hd exp))))) (fn (lookup key env) (ef (eq env nil) key (ef (eq (hd (hd env)) key) (tl (hd env)) (lookup lookup key (tl env))))) (fn (values env exps) (ef (atom exps) (lookup exps env) (pair (meval meval env (hd exps)) (values values env (tl exps))))) (fn (extend params values env) (ef (eq params nil) env (ef (atom params) (pair (pair params values) env) (pair (pair (hd params) (hd values)) (extend extend (tl params) (tl values) env))))))))) )