#lang plai-typed (require plai-typed/s-exp-match) ;; Compile variable references to numerical offsets (define-type ExprC [numC (n : number)] [plusC (lhs : ExprC) (rhs : ExprC)] [multC (lhs : ExprC) (rhs : ExprC)] [idC (name : symbol)] [lamC (param : symbol) (body : ExprC)] [appC (fun-expr : ExprC) (arg-expr : ExprC)] [if0C (tst : ExprC) (thn : ExprC) (els : ExprC)]) (define-type ExprD [numD (n : number)] [plusD (lhs : ExprD) (rhs : ExprD)] [multD (lhs : ExprD) (rhs : ExprD)] [atD (pos : number)] [lamD (body : ExprD)] [appD (fun-expr : ExprD) (arg-expr : ExprD)] [if0D (tst : ExprD) (thn : ExprD) (els : ExprD)]) (define-type Value [numV (n : number)] [closV (body : ExprD) (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 true)) ;; ---------------------------------------- (define (parse [s : s-expression]) : ExprC (cond [(s-exp-match? `NUMBER s) (numC (s-exp->number s))] [(s-exp-match? `SYMBOL s) (idC (s-exp->symbol s))] [(s-exp-match? '{+ ANY ANY} s) (plusC (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? '{* ANY ANY} s) (multC (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? '{lambda {SYMBOL} ANY} s) (lamC (s-exp->symbol (first (s-exp->list (second (s-exp->list s))))) (parse (third (s-exp->list s))))] [(s-exp-match? '{ANY ANY} s) (appC (parse (first (s-exp->list s))) (parse (second (s-exp->list s))))] [(s-exp-match? '{if0 ANY ANY ANY} s) (if0C (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) (numC 3)) (test (parse `x) (idC 'x)) (test (parse '{+ 1 2}) (plusC (numC 1) (numC 2))) (test (parse '{* 1 2}) (multC (numC 1) (numC 2))) (test (parse '{lambda {x} x}) (lamC 'x (idC 'x))) (test (parse '{1 2}) (appC (numC 1) (numC 2))) (test (parse '{if0 0 1 2}) (if0C (numC 0) (numC 1) (numC 2))) (test/exn (parse '{}) "invalid input")) ;; ---------------------------------------- (define (compile a env) (type-case ExprC a [numC (n) (numD n)] [plusC (l r) (plusD (compile l env) (compile r env))] [multC (l r) (multD (compile l env) (compile r env))] [idC (name) (atD (locate name env))] [lamC (n body-expr) (lamD (compile body-expr (extend-env (bindC n) env)))] [appC (fun-expr arg-expr) (appD (compile fun-expr env) (compile arg-expr env))] [if0C (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 ExprD 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 5000)))