#lang plai-typed (require plai-typed/s-exp-match) ;; Explicit continuations (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) (define-type Cont [doneK] [addSecondK (r : ExprD) (env : Env) (k : Cont)] [doAddK (v1 : Value) (k : Cont)] [subSecondK (r : ExprD) (env : Env) (k : Cont)] [doSubK (v1 : Value) (k : Cont)] [appArgK (arg-expr : ExprD) (env : Env) (k : Cont)] [doAppK (fun-val : Value) (k : Cont)] [doIf0K (then-expr : ExprD) (else-expr : ExprD) (env : Env) (k : Cont)]) (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 k) (type-case ExprD a [numD (n) (continue k (numV n))] [plusD (l r) (interp l env (addSecondK r env k))] [multD (l r) (interp l env (subSecondK r env k))] [atD (pos) (continue k (list-ref env pos))] [lamD (body-expr) (continue k (closV body-expr env))] [appD (fun-expr arg-expr) (interp fun-expr env (appArgK arg-expr env k))] [if0D (test-expr then-expr else-expr) (interp test-expr env (doIf0K then-expr else-expr env k))])) (define (continue k v) (type-case Cont k [doneK () v] [addSecondK (r env k) (interp r env (doAddK v k))] [doAddK (v1 k) (continue k (num+ v1 v))] [subSecondK (r env k) (interp r env (doSubK v k))] [doSubK (v1 k) (continue k (num* v1 v))] [appArgK (arg-expr env k) (interp arg-expr env (doAppK v k))] [doAppK (fun-val k) (interp (closV-body fun-val) (cons v (closV-env fun-val)) k)] [doIf0K (then-expr else-expr env k) (if (numzero? v) (interp then-expr env k) (interp else-expr env k))])) (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 (doneK)) (numV 10)) (test (interp (compile (parse '{+ 10 7}) mt-env) empty (doneK)) (numV 17)) (test (interp (compile (parse '{* 10 7}) mt-env) empty (doneK)) (numV 70)) (test (interp (compile (parse '{{lambda {x} {+ x 12}} {+ 1 17}}) mt-env) empty (doneK)) (numV 30)) (test (interp (compile (parse `x) (extend-env (bindC 'x) mt-env)) (list (numV 10)) (doneK)) (numV 10)) (test (interp (compile (parse `{{lambda {x} {+ x 12}} {+ 1 17}}) mt-env) empty (doneK)) (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 (doneK)) (numV 3)) (test (interp (compile (parse '{if0 0 1 2}) mt-env) empty (doneK)) (numV 1)) (test (interp (compile (parse '{if0 1 1 2}) mt-env) empty (doneK)) (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 (doneK)) (numV 5)) (test/exn (compile (parse `x) mt-env) "free variable"))