#lang plait ;; Compile variable references to numerical offsets (define-type Exp (numE [n : Number]) (plusE [lhs : Exp] [rhs : Exp]) (multE [lhs : Exp] [rhs : Exp]) (idE [name : Symbol]) (lamE [param : Symbol] [body : Exp]) (appE [fun-expr : Exp] [arg-expr : Exp]) (if0E [tst : Exp] [thn : Exp] [els : Exp])) (define-type ExpD (numD [n : Number]) (plusD [lhs : ExpD] [rhs : ExpD]) (multD [lhs : ExpD] [rhs : ExpD]) (atD [pos : Number]) (lamD [body : ExpD]) (appD [fun-expr : ExpD] [arg-expr : ExpD]) (if0D [tst : ExpD] [thn : ExpD] [els : ExpD])) (define-type Value (numV [n : Number]) (closV [body : ExpD] [env : Env])) (define-type BindingC (bindC [name : Symbol])) (define-type-alias EnvC (Listof BindingC)) (define-type-alias Env (Listof Value)) (define mt-env empty) (define extend-env cons) (module+ test (print-only-errors #t)) ;; ---------------------------------------- (define (parse [s : S-Exp]) : Exp (cond [(s-exp-match? `NUMBER s) (numE (s-exp->number s))] [(s-exp-match? `SYMBOL s) (idE (s-exp->symbol s))] [(s-exp-match? `{+ ANY ANY} s) (plusE (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? `{* ANY ANY} s) (multE (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? `{lambda {SYMBOL} ANY} s) (lamE (s-exp->symbol (first (s-exp->list (second (s-exp->list s))))) (parse (third (s-exp->list s))))] [(s-exp-match? `{ANY ANY} s) (appE (parse (first (s-exp->list s))) (parse (second (s-exp->list s))))] [(s-exp-match? `{if0 ANY ANY ANY} s) (if0E (parse (second (s-exp->list s))) (parse (third (s-exp->list s))) (parse (fourth (s-exp->list s))))] [else (error 'parse "invalid input")])) (module+ test (test (parse `3) (numE 3)) (test (parse `x) (idE 'x)) (test (parse `{+ 1 2}) (plusE (numE 1) (numE 2))) (test (parse `{* 1 2}) (multE (numE 1) (numE 2))) (test (parse `{lambda {x} x}) (lamE 'x (idE 'x))) (test (parse `{1 2}) (appE (numE 1) (numE 2))) (test (parse `{if0 0 1 2}) (if0E (numE 0) (numE 1) (numE 2))) (test/exn (parse `{}) "invalid input")) ;; ---------------------------------------- (define (compile a env) (type-case Exp a [(numE n) (numD n)] [(plusE l r) (plusD (compile l env) (compile r env))] [(multE l r) (multD (compile l env) (compile r env))] [(idE name) (atD (locate name env))] [(lamE n body-expr) (lamD (compile body-expr (extend-env (bindC n) env)))] [(appE fun-expr arg-expr) (appD (compile fun-expr env) (compile arg-expr env))] [(if0E test-expr then-expr else-expr) (if0D (compile test-expr env) (compile then-expr env) (compile else-expr env))])) (define (locate name env) (cond [(empty? env) (error 'locate "free variable")] [else (if (symbol=? name (bindC-name (first env))) 0 (+ 1 (locate name (rest env))))])) ;; ---------------------------------------- (define (interp a env) (type-case ExpD a [(numD n) (numV n)] [(plusD l r) (num+ (interp l env) (interp r env))] [(multD l r) (num* (interp l env) (interp r env))] [(atD pos) (list-ref env pos)] [(lamD body-expr) (closV body-expr env)] [(appD fun-expr arg-expr) (let ([fun-val (interp fun-expr env)] [arg-val (interp arg-expr env)]) (interp (closV-body fun-val) (cons arg-val (closV-env fun-val))))] [(if0D test-expr then-expr else-expr) (if (numzero? (interp test-expr env)) (interp then-expr env) (interp else-expr env))])) (define (num-op op) (lambda (x y) (numV (op (numV-n x) (numV-n y))))) (define num+ (num-op +)) (define num* (num-op *)) (define (numzero? x) (zero? (numV-n x))) ;; ---------------------------------------- (module+ test (test (interp (compile (parse `10) mt-env) empty) (numV 10)) (test (interp (compile (parse `{+ 10 7}) mt-env) empty) (numV 17)) (test (interp (compile (parse `{* 10 7}) mt-env) empty) (numV 70)) (test (interp (compile (parse `{{lambda {x} {+ x 12}} {+ 1 17}}) mt-env) empty) (numV 30)) (test (interp (compile (parse `x) (extend-env (bindC 'x) mt-env)) (list (numV 10))) (numV 10)) (test (interp (compile (parse `{{lambda {x} {+ x 12}} {+ 1 17}}) mt-env) empty) (numV 30)) (test (interp (compile (parse `{{lambda {x} {{lambda {f} {+ {f 1} {{lambda {x} {f 2}} 3}}} {lambda {y} {+ x y}}}} 0}) mt-env) empty) (numV 3)) (test (interp (compile (parse `{if0 0 1 2}) mt-env) empty) (numV 1)) (test (interp (compile (parse `{if0 1 1 2}) mt-env) empty) (numV 2)) (test (interp (compile (parse `{{lambda {mkrec} {{lambda {fib} ;; Call fib on 4: {fib 4}} ;; Create recursive fib: {mkrec {lambda {fib} ;; Fib: {lambda {n} {if0 n 1 {if0 {+ n -1} 1 {+ {fib {+ n -1}} {fib {+ n -2}}}}}}}}}} ;; mkrec: {lambda {body-proc} {{lambda {fX} {fX fX}} {lambda {fX} {body-proc {lambda {x} {{fX fX} x}}}}}}}) mt-env) empty) (numV 5)) (test/exn (compile (parse `x) mt-env) "free variable") ;; Timing test -------------------- (define d (compile (parse `{{{{lambda {x} {lambda {y} {lambda {z} {+ {+ x x} {+ x x}}}}} 1} 2} 3}) mt-env)) (define (multi-interp n) (if (zero? n) (void) (begin (interp d empty) (multi-interp (- n 1))))) (time (multi-interp 10000)))