#lang plai-typed (require plai-typed/s-exp-match) ;; Direct-style interpreter (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 Value [numV (n : number)] [closV (n : symbol) (body : ExprC) (env : Env)]) (define-type Binding [bind (name : symbol) (val : Value)]) (define-type-alias Env (listof Binding)) (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 (interp a env) (type-case ExprC a [numC (n) (numV n)] [plusC (l r) (num+ (interp l env) (interp r env))] [multC (l r) (num* (interp l env) (interp r env))] [idC (name) (lookup name env)] [lamC (n body-expr) (closV n body-expr env)] [appC (fun-expr arg-expr) (let ([fun-val (interp fun-expr env)] [arg-val (interp arg-expr env)]) (interp (closV-body fun-val) (extend-env (bind (closV-n fun-val) arg-val) (closV-env fun-val))))] [if0C (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))) (define (lookup name env) (cond [(empty? env) (error 'lookup "free variable")] [else (if (symbol=? name (bind-name (first env))) (bind-val (first env)) (lookup name (rest env)))])) ;; ---------------------------------------- (module+ test (test (interp (parse '10) mt-env) (numV 10)) (test (interp (parse '{+ 10 7}) mt-env) (numV 17)) (test (interp (parse '{* 10 7}) mt-env) (numV 70)) (test (interp (parse '{{lambda {x} {+ x 12}} {+ 1 17}}) mt-env) (numV 30)) (test (interp (parse `x) (extend-env (bind 'x (numV 10)) mt-env)) (numV 10)) (test (interp (parse `{{lambda {x} {+ x 12}} {+ 1 17}}) mt-env) (numV 30)) (test (interp (parse '{{lambda {x} {{lambda {f} {+ {f 1} {{lambda {x} {f 2}} 3}}} {lambda {y} {+ x y}}}} 0}) mt-env) (numV 3)) (test (interp (parse '{if0 0 1 2}) mt-env) (numV 1)) (test (interp (parse '{if0 1 1 2}) mt-env) (numV 2)) (test (interp (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) (numV 5)) (test/exn (interp (parse `x) mt-env) "free variable") ;; Timing test -------------------- (define c (parse '{{{{lambda {x} {lambda {y} {lambda {z} {+ {+ x x} {+ x x}}}}} 1} 2} 3})) (define (multi-interp n) (if (zero? n) (void) (begin (interp c mt-env) (multi-interp (- n 1))))) (time (multi-interp 5000)))