This lecture works through a series of implementations of a simple lambda language, showing how to translate the code to use fewer and fewer high-level features. By the end, the only data structure allocation that the interpreter does is dictated by the program itself, i.e. to support closures. file: interp-class.rkt ---cut here--- #lang typed/racket (define-type Exp (U sum if0 Number lam app Symbol)) (struct: sum ([lhs : Exp] [rhs : Exp]) #:transparent) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp]) #:transparent) (struct: lam ([id : Symbol] [bdy : Exp]) #:transparent) (struct: app ([rator : Exp] [rand : Exp]) #:transparent) (define-type Env (HashTable Symbol Value)) (define-type Value (U Number clo)) (struct: clo ([id : Symbol] [body : Exp] [env : Env])) (: mt-env Env) (define mt-env (hash)) (: interp : Exp -> Value) (define (interp e) (interp/env/k e mt-env (λ: ([x : Value]) x))) (: interp/env/k (∀ (X) (Exp Env (Value -> X) -> X))) (define (interp/env/k e env k) (match e [(sum l r) (interp/env/k l env (λ (lv) (interp/env/k r env (λ (rv) (if (and (number? lv) (number? rv)) (k (+ lv rv)) (error 'interp "expected numbers"))))))] [(if0 tst thn els) (interp/env/k tst env (λ (tst-v) (if (equal? tst-v 0) (interp/env/k thn env k) (interp/env/k els env k))))] [(? number? n) (k n)] [(lam id body) (k (clo id body env))] [(app rator rand) (interp/env/k rator env (λ (f) (interp/env/k rand env (λ ([x : Value]) (match f [(clo id body env) (interp/env/k body ((inst hash-set Symbol Value) env id x) k)] [(? number?) (error 'interp "app expected a function")])))))] [(? symbol? x) (k (hash-ref env x))])) (: parse : (Any -> Exp)) (define (parse exp) (match exp [`(+ ,l ,r) (sum (parse l) (parse r))] [(? number? x) x] [`(if0 ,tst ,thn ,els) (if0 (parse tst) (parse thn) (parse els))] [(? symbol? x) x] [`(λ (,(? symbol? x)) ,body) (lam x (parse body))] [`(,f ,x) (app (parse f) (parse x))] [`(let ([,x ,rhs]) ,body) (parse `((λ (,x) ,body) ,rhs))])) (require "test.rkt") (test interp parse) ---cut here--- file: interp0-debrujin.rkt ---cut here--- #lang typed/racket #| Original interpreter |# (define-type Exp (U sum if0 Number lam app id)) (struct: sum ([lhs : Exp] [rhs : Exp]) #:transparent) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp]) #:transparent) (struct: lam ([bdy : Exp]) #:transparent) (struct: app ([rator : Exp] [rand : Exp]) #:transparent) (struct: id ([id : Natural]) #:transparent) (define-type Value (U Number clo)) (struct: clo ([body : Exp] [env : Env])) (define-type Env (Listof Value)) (: interp (Exp -> (U String Value))) (define (interp e) (with-handlers ((exn:fail? exn-message)) (interp/env/depth e '() 0))) (: interp/env/depth (Exp Env Natural -> Value)) (define (interp/env/depth e env depth) (match e [(sum lhs rhs) (define lhs-v (interp/env/depth lhs env depth)) (define rhs-v (interp/env/depth rhs env depth)) (cond [(and (number? lhs-v) (number? rhs-v)) (+ lhs-v rhs-v)] [else (error 'interp "addition expects numbers, received ~s and ~s" lhs-v rhs-v)])] [(if0 tst thn els) (define tst-val (interp/env/depth tst env depth)) (if (and (number? tst-val) (zero? tst-val)) (interp/env/depth thn env depth) (interp/env/depth els env depth))] [(? number? n) n] [(lam body) (clo body env)] [(app rator rand) (define rator-v (interp/env/depth rator env depth)) (define rand-v (interp/env/depth rand env depth)) (match rator-v [(clo body env) (interp/env/depth body (cons rand-v env) (+ depth 1))] [_ (error 'interp "application expects a function in the rator position, got ~s" rator-v)])] [(id n) (list-ref env n)])) (: parse : (Any -> Exp)) (define (parse exp) (let: loop ([exp : Any exp] [depth : Natural 0] [env : (HashTable Symbol Natural) #hash()]) (match exp [`(λ (,x) ,body) (if (symbol? x) (lam (loop body (+ depth 1) (hash-set env x depth))) (error 'parse "expected a symbol for the parameter name, got ~s" x))] [`(if0 ,a ,b ,c) (if0 (loop a depth env) (loop b depth env) (loop c depth env))] [`(+ ,a ,b) (sum (loop a depth env) (loop b depth env))] [`(let ([,x ,rhs]) ,body) (loop `((λ (,x) ,body) ,rhs) depth env)] [(? number? n) n] [(? symbol? x) (id (cast (- depth (hash-ref env x) 1) Natural))] [`(,f ,x) (app (loop f depth env) (loop x depth env))]))) (module+ test (require typed/rackunit) (check-equal? (parse `(λ (x) x)) (lam (id 0))) (check-equal? (parse `(λ (x) (λ (y) x))) (lam (lam (id 1)))) (check-equal? (parse `(λ (x) (λ (y) y))) (lam (lam (id 0)))) (check-equal? (parse `(λ (x) (λ (y) (λ (z) z)))) (lam (lam (lam (id 0))))) (check-equal? (parse `(λ (x) (λ (y) (λ (z) y)))) (lam (lam (lam (id 1))))) (check-equal? (parse `(λ (x) (λ (y) (λ (z) x)))) (lam (lam (lam (id 2)))))) (require "test.rkt") (test interp parse) ---cut here--- file: interp0.rkt ---cut here--- #lang typed/racket #| Original interpreter |# (define-type Exp (U sum if0 Number lam app Symbol)) (struct: sum ([lhs : Exp] [rhs : Exp])) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp])) (struct: lam ([arg : Symbol] [bdy : Exp])) (struct: app ([rator : Exp] [rand : Exp])) (define-type Value (U Number clo)) (struct: clo ([arg : Symbol] [body : Exp] [env : (HashTable Symbol Value)])) (: interp (Exp -> (U String Value))) (define (interp e) (with-handlers ((exn:fail? exn-message)) (interp/env e #hash()))) (: interp/env (Exp (HashTable Symbol Value) -> Value)) (define (interp/env e env) (match e [(sum lhs rhs) (define lhs-v (interp/env lhs env)) (define rhs-v (interp/env rhs env)) (cond [(and (number? lhs-v) (number? rhs-v)) (+ lhs-v rhs-v)] [else (error 'interp "addition expects numbers, received ~s and ~s" lhs-v rhs-v)])] [(if0 tst thn els) (define tst-val (interp/env tst env)) (if (and (number? tst-val) (zero? tst-val)) (interp/env thn env) (interp/env els env))] [(? number? n) n] [(lam arg body) (clo arg body env)] [(app rator rand) (define rator-v (interp/env rator env)) (define rand-v (interp/env rand env)) (match rator-v [(clo arg body env) (interp/env body (hash-set env arg rand-v))] [_ (error 'interp "application expects a function in the rator position, got ~s" rator-v)])] [(? symbol? s) (hash-ref env s)])) (: parse : (Any -> Exp)) (define (parse exp) (match exp [`(λ (,(? symbol? x)) ,body) (lam x (parse body))] [`(if0 ,a ,b ,c) (if0 (parse a) (parse b) (parse c))] [`(+ ,a ,b) (sum (parse a) (parse b))] [`(let ([,x ,rhs]) ,body) (if (symbol? x) (app (lam x (parse body)) (parse rhs)) (error 'parse "expected a symbol for the bound variable, got ~s" x))] [(? number? n) n] [(? symbol? x) x] [`(,f ,x) (app (parse f) (parse x))])) (require "test.rkt") (test interp parse) ---cut here--- file: interp1.rkt ---cut here--- #lang typed/racket #| CPS converted intepreter |# (define-type Exp (U sum if0 Number lam app Symbol)) (struct: sum ([lhs : Exp] [rhs : Exp])) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp])) (struct: lam ([arg : Symbol] [bdy : Exp])) (struct: app ([rator : Exp] [rand : Exp])) (define-type Value (U Number clo)) (struct: clo ([arg : Symbol] [body : Exp] [env : (HashTable Symbol Value)])) (: interp (Exp -> (U String Value))) (define (interp e) (with-handlers ((exn:fail? exn-message)) ((inst interp/env/k Value) e #hash() (λ (x) x)))) (: interp/env/k (∀ (X) (Exp (HashTable Symbol Value) (Value -> X) -> X))) (define (interp/env/k e env k) (match e [(sum lhs rhs) (interp/env/k lhs env (λ (lhs-v) (interp/env/k rhs env (λ (rhs-v) (cond [(and (number? lhs-v) (number? rhs-v)) (k (+ lhs-v rhs-v))] [else (error 'interp "addition expects numbers, received ~s and ~s" lhs-v rhs-v)])))))] [(if0 tst thn els) (interp/env/k tst env (λ (tst-val) (if (and (number? tst-val) (zero? tst-val)) (interp/env/k thn env k) (interp/env/k els env k))))] [(? number? n) (k n)] [(lam arg body) (k (clo arg body env))] [(app rator rand) (interp/env/k rator env (λ (rator-v) (interp/env/k rand env (λ: ([rand-v : Value]) (match rator-v [(clo arg body env) (interp/env/k body (hash-set env arg rand-v) k)] [_ (error 'interp "application expects a function in the rator position, got ~s" rator-v)])))))] [(? symbol? s) (k (hash-ref env s))])) (: parse : (Any -> Exp)) (define (parse exp) (match exp [`(λ (,(? symbol? x)) ,body) (lam x (parse body))] [`(if0 ,a ,b ,c) (if0 (parse a) (parse b) (parse c))] [`(+ ,a ,b) (sum (parse a) (parse b))] [`(let ([,x ,rhs]) ,body) (if (symbol? x) (app (lam x (parse body)) (parse rhs)) (error 'parse "expected a symbol for the bound variable, got ~s" x))] [(? number? n) n] [(? symbol? x) x] [`(,f ,x) (app (parse f) (parse x))])) (require "test.rkt") (test interp parse) ---cut here--- file: interp2.rkt ---cut here--- #lang typed/racket #| Move the konts into their own data structure (but still as functions). |# (define-type Exp (U sum if0 Number lam app Symbol)) (struct: sum ([lhs : Exp] [rhs : Exp])) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp])) (struct: lam ([arg : Symbol] [bdy : Exp])) (struct: app ([rator : Exp] [rand : Exp])) (define-type Value (U Number clo)) (struct: clo ([arg : Symbol] [body : Exp] [env : (HashTable Symbol Value)])) (: interp (Exp -> (U String Value))) (define (interp e) (interp/env/k e #hash() (kont (λ (x) x)))) (struct: kont ([f : (Value -> (U String Value))])) (: apply-kont (kont Value -> (U String Value))) (define (apply-kont k v) ((kont-f k) v)) (: interp/env/k (Exp (HashTable Symbol Value) kont -> (U String Value))) (define (interp/env/k e env k) (match e [(sum lhs rhs) (interp/env/k lhs env (kont (λ (lhs-v) (interp/env/k rhs env (kont (λ (rhs-v) (cond [(and (number? lhs-v) (number? rhs-v)) (apply-kont k (+ lhs-v rhs-v))] [else (format "interp: addition expects numbers, received ~s and ~s" lhs-v rhs-v)])))))))] [(if0 tst thn els) (interp/env/k tst env (kont (λ (tst-val) (if (and (number? tst-val) (zero? tst-val)) (interp/env/k thn env k) (interp/env/k els env k)))))] [(? number? n) (apply-kont k n)] [(lam arg body) (apply-kont k (clo arg body env))] [(app rator rand) (interp/env/k rator env (kont (λ (rator-v) (interp/env/k rand env (kont (λ (rand-v) (match rator-v [(clo arg body env) (interp/env/k body (hash-set env arg rand-v) k)] [_ (format "interp: application expects a function in the rator position, got ~s" rator-v)])))))))] [(? symbol? s) (apply-kont k (hash-ref env s))])) (: parse : (Any -> Exp)) (define (parse exp) (match exp [`(λ (,(? symbol? x)) ,body) (lam x (parse body))] [`(if0 ,a ,b ,c) (if0 (parse a) (parse b) (parse c))] [`(+ ,a ,b) (sum (parse a) (parse b))] [`(let ([,x ,rhs]) ,body) (if (symbol? x) (app (lam x (parse body)) (parse rhs)) (error 'parse "expected a symbol for the bound variable, got ~s" x))] [(? number? n) n] [(? symbol? x) x] [`(,f ,x) (app (parse f) (parse x))])) (require "test.rkt") (test interp parse) ---cut here--- file: interp3.rkt ---cut here--- #lang typed/racket #| Defunctionalize the continuations; that is, move bodies of all of the functions that get stored into a 'kont' in the previous interpreter into a single function and save the free variables of those functions into a data structure. After this, all of the continuations are are just structs |# (define-type Exp (U sum if0 Number lam app Symbol)) (struct: sum ([lhs : Exp] [rhs : Exp])) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp])) (struct: lam ([arg : Symbol] [bdy : Exp])) (struct: app ([rator : Exp] [rand : Exp])) (define-type Value (U Number clo)) (struct: clo ([arg : Symbol] [body : Exp] [env : (HashTable Symbol Value)])) (: interp (Exp -> (U String Value))) (define (interp e) (interp/env/k e #hash() (kont-done))) (define-type kont (U kont-done kont-lhs-v kont-rhs-v kont-tst-val kont-rand-v kont-rator-v)) (struct: kont-done ()) (struct: kont-lhs-v ([rhs : Exp] [env : (HashTable Symbol Value)] [k : kont])) (struct: kont-rhs-v ([lhs-v : Value] [k : kont])) (struct: kont-tst-val ([thn : Exp] [els : Exp] [env : (HashTable Symbol Value)] [k : kont])) (struct: kont-rand-v ([rator-v : Value] [k : kont])) (struct: kont-rator-v ([rand : Exp] [env : (HashTable Symbol Value)] [k : kont])) (: apply-kont (kont Value -> (U String Value))) (define (apply-kont k v) (match k [(kont-lhs-v rhs env k) (define lhs-v v) (interp/env/k rhs env (kont-rhs-v lhs-v k))] [(kont-rhs-v lhs-v k) (define rhs-v v) (cond [(and (number? lhs-v) (number? rhs-v)) (apply-kont k (+ lhs-v rhs-v))] [else (format "interp: addition expects numbers, received ~s and ~s" lhs-v rhs-v)])] [(kont-tst-val thn els env k) (define tst-val v) (if (and (number? tst-val) (zero? tst-val)) (interp/env/k thn env k) (interp/env/k els env k))] [(kont-rand-v rator-v k) (define rand-v v) (match rator-v [(clo arg body env) (interp/env/k body (hash-set env arg rand-v) k)] [_ (format "interp: application expects a function in the rator position, got ~s" rator-v)])] [(kont-rator-v rand env k) (define rator-v v) (interp/env/k rand env (kont-rand-v rator-v k))] [(kont-done) v])) (: interp/env/k (Exp (HashTable Symbol Value) kont -> (U String Value))) (define (interp/env/k e env k) (match e [(sum lhs rhs) (interp/env/k lhs env (kont-lhs-v rhs env k))] [(if0 tst thn els) (interp/env/k tst env (kont-tst-val thn els env k))] [(? number? n) (apply-kont k n)] [(lam arg body) (apply-kont k (clo arg body env))] [(app rator rand) (interp/env/k rator env (kont-rator-v rand env k))] [(? symbol? s) (apply-kont k (hash-ref env s))])) (: parse : (Any -> Exp)) (define (parse exp) (match exp [`(λ (,(? symbol? x)) ,body) (lam x (parse body))] [`(if0 ,a ,b ,c) (if0 (parse a) (parse b) (parse c))] [`(+ ,a ,b) (sum (parse a) (parse b))] [`(let ([,x ,rhs]) ,body) (if (symbol? x) (app (lam x (parse body)) (parse rhs)) (error 'parse "expected a symbol for the bound variable, got ~s" x))] [(? number? n) n] [(? symbol? x) x] [`(,f ,x) (app (parse f) (parse x))])) (require "test.rkt") (test interp parse) ---cut here--- file: interp4.rkt ---cut here--- #lang typed/racket #| Move the arguments to apply-kont and interp into global variables and use set! to update them instead of passing them explicitly. The arguments to those functions are now behaving more like they are in registers. |# (define-type Exp (U sum if0 Number lam app Symbol)) (struct: sum ([lhs : Exp] [rhs : Exp])) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp])) (struct: lam ([arg : Symbol] [bdy : Exp])) (struct: app ([rator : Exp] [rand : Exp])) (define-type Value (U Number clo)) (struct: clo ([arg : Symbol] [body : Exp] [env : (HashTable Symbol Value)])) (: interp (Exp -> (U String Value))) (define (interp _e) (set! e _e) (set! env (let: ([v : (HashTable Symbol Value) #hash()]) v)) (set! interp-k (kont-done)) (interp/env/k)) (define-type kont (U kont-done kont-lhs-v kont-rhs-v kont-tst-val kont-rand-v kont-rator-v)) (struct: kont-done ()) (struct: kont-lhs-v ([rhs : Exp] [env : (HashTable Symbol Value)] [k : kont])) (struct: kont-rhs-v ([lhs-v : Value] [k : kont])) (struct: kont-tst-val ([thn : Exp] [els : Exp] [env : (HashTable Symbol Value)] [k : kont])) (struct: kont-rand-v ([rator-v : Value] [k : kont])) (struct: kont-rator-v ([rand : Exp] [env : (HashTable Symbol Value)] [k : kont])) (: a-k kont) (define a-k (kont-done)) (: v Value) (define v 0) (: apply-kont (-> (U String Value))) (define (apply-kont) (match a-k [(kont-lhs-v rhs _env k) (define lhs-v v) (set! e rhs) (set! env _env) (set! interp-k (kont-rhs-v lhs-v k)) (interp/env/k)] [(kont-rhs-v lhs-v k) (define rhs-v v) (cond [(and (number? lhs-v) (number? rhs-v)) (set! a-k k) (set! v (+ lhs-v rhs-v)) (apply-kont)] [else (format "interp: addition expects numbers, received ~s and ~s" lhs-v rhs-v)])] [(kont-tst-val thn els _env k) (define tst-val v) (cond [(and (number? tst-val) (zero? tst-val)) (set! e thn) (set! env _env) (set! interp-k k) (interp/env/k)] [else (set! e els) (set! env _env) (set! interp-k k) (interp/env/k)])] [(kont-rand-v rator-v k) (define rand-v v) (match rator-v [(clo arg body clo-env) (set! e body) (set! env (hash-set clo-env arg rand-v)) (set! interp-k k) (interp/env/k)] [_ (format "interp: application expects a function in the rator position, got ~s" rator-v)])] [(kont-rator-v rand _env k) (define rator-v v) (set! e rand) (set! env _env) (set! interp-k (kont-rand-v rator-v k)) (interp/env/k)] [(kont-done) v])) (: e Exp) (define e 0) (: env : (HashTable Symbol Value)) (define env '#hash()) (: interp-k kont) (define interp-k (kont-done)) (: interp/env/k (-> (U String Value))) (define (interp/env/k) (match e [(sum lhs rhs) (set! e lhs) (set! interp-k (kont-lhs-v rhs env interp-k)) (interp/env/k)] [(if0 tst thn els) (set! e tst) (set! interp-k (kont-tst-val thn els env interp-k)) (interp/env/k)] [(? number? n) (set! a-k interp-k) (set! v n) (apply-kont)] [(lam arg body) (set! a-k interp-k) (set! v (clo arg body env)) (apply-kont)] [(app rator rand) (set! e rator) (set! interp-k (kont-rator-v rand env interp-k)) (interp/env/k)] [(? symbol? s) (set! a-k interp-k) (set! v (hash-ref env s)) (apply-kont)])) (: parse : (Any -> Exp)) (define (parse exp) (match exp [`(λ (,(? symbol? x)) ,body) (lam x (parse body))] [`(if0 ,a ,b ,c) (if0 (parse a) (parse b) (parse c))] [`(+ ,a ,b) (sum (parse a) (parse b))] [`(let ([,x ,rhs]) ,body) (if (symbol? x) (app (lam x (parse body)) (parse rhs)) (error 'parse "expected a symbol for the bound variable, got ~s" x))] [(? number? n) n] [(? symbol? x) x] [`(,f ,x) (app (parse f) (parse x))])) (require "test.rkt") (test interp parse) ---cut here--- file: interp5.rkt ---cut here--- #lang typed/racket #| Renamed interp-k to a-k (saving one register) |# (define-type Exp (U sum if0 Number lam app Symbol)) (struct: sum ([lhs : Exp] [rhs : Exp])) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp])) (struct: lam ([arg : Symbol] [bdy : Exp])) (struct: app ([rator : Exp] [rand : Exp])) (define-type Value (U Number clo)) (struct: clo ([arg : Symbol] [body : Exp] [env : (HashTable Symbol Value)])) (: interp (Exp -> (U String Value))) (define (interp _e) (set! e _e) (set! env (let: ([v : (HashTable Symbol Value) #hash()]) v)) (set! a-k (kont-done)) (interp/env/k)) (define-type kont (U kont-done kont-lhs-v kont-rhs-v kont-tst-val kont-rand-v kont-rator-v)) (struct: kont-done ()) (struct: kont-lhs-v ([rhs : Exp] [env : (HashTable Symbol Value)] [k : kont])) (struct: kont-rhs-v ([lhs-v : Value] [k : kont])) (struct: kont-tst-val ([thn : Exp] [els : Exp] [env : (HashTable Symbol Value)] [k : kont])) (struct: kont-rand-v ([rator-v : Value] [k : kont])) (struct: kont-rator-v ([rand : Exp] [env : (HashTable Symbol Value)] [k : kont])) (: a-k kont) (define a-k (kont-done)) (: v Value) (define v 0) (: e Exp) (define e 0) (: env : (HashTable Symbol Value)) (define env '#hash()) (: apply-kont (-> (U String Value))) (define (apply-kont) (match a-k [(kont-lhs-v rhs _env k) (define lhs-v v) (set! e rhs) (set! env _env) (set! a-k (kont-rhs-v lhs-v k)) (interp/env/k)] [(kont-rhs-v lhs-v k) (define rhs-v v) (cond [(and (number? lhs-v) (number? rhs-v)) (set! a-k k) (set! v (+ lhs-v rhs-v)) (apply-kont)] [else (format "interp: addition expects numbers, received ~s and ~s" lhs-v rhs-v)])] [(kont-tst-val thn els _env k) (define tst-val v) (cond [(and (number? tst-val) (zero? tst-val)) (set! e thn) (set! env _env) (set! a-k k) (interp/env/k)] [else (set! e els) (set! env _env) (set! a-k k) (interp/env/k)])] [(kont-rand-v rator-v k) (define rand-v v) (match rator-v [(clo arg body clo-env) (set! e body) (set! env (hash-set clo-env arg rand-v)) (set! a-k k) (interp/env/k)] [_ (format "interp: application expects a function in the rator position, got ~s" rator-v)])] [(kont-rator-v rand _env k) (define rator-v v) (set! e rand) (set! env _env) (set! a-k (kont-rand-v rator-v k)) (interp/env/k)] [(kont-done) v])) (: interp/env/k (-> (U String Value))) (define (interp/env/k) (match e [(sum lhs rhs) (set! e lhs) (set! a-k (kont-lhs-v rhs env a-k)) (interp/env/k)] [(if0 tst thn els) (set! e tst) (set! a-k (kont-tst-val thn els env a-k)) (interp/env/k)] [(? number? n) (set! a-k a-k) (set! v n) (apply-kont)] [(lam arg body) (set! a-k a-k) (set! v (clo arg body env)) (apply-kont)] [(app rator rand) (set! e rator) (set! a-k (kont-rator-v rand env a-k)) (interp/env/k)] [(? symbol? s) (set! a-k a-k) (set! v (hash-ref env s)) (apply-kont)])) (: parse : (Any -> Exp)) (define (parse exp) (match exp [`(λ (,(? symbol? x)) ,body) (lam x (parse body))] [`(if0 ,a ,b ,c) (if0 (parse a) (parse b) (parse c))] [`(+ ,a ,b) (sum (parse a) (parse b))] [`(let ([,x ,rhs]) ,body) (if (symbol? x) (app (lam x (parse body)) (parse rhs)) (error 'parse "expected a symbol for the bound variable, got ~s" x))] [(? number? n) n] [(? symbol? x) x] [`(,f ,x) (app (parse f) (parse x))])) (require "test.rkt") (test interp parse) ---cut here--- file: interp6.rkt ---cut here--- #lang typed/racket #| Make the control stack explicit in a stack where we just adjust a pointer to it. |# (define-type Exp (U sum if0 Number lam app Symbol)) (struct: sum ([lhs : Exp] [rhs : Exp])) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp])) (struct: lam ([arg : Symbol] [bdy : Exp])) (struct: app ([rator : Exp] [rand : Exp])) (define-type Value (U Number clo)) (struct: clo ([arg : Symbol] [body : Exp] [env : (HashTable Symbol Value)])) (: interp (Exp -> (U String Value))) (define (interp _e) (set! e _e) (set! env empty-env) (set! stack-ptr 1) (vector-set! stack 0 'kont-done) (interp/env/k)) (: empty-env (HashTable Symbol Value)) (define empty-env #hash()) (define-type StackElem (U KontTag Value Exp (HashTable Symbol Value))) (define-type KontTag (U 'kont-lhs-v 'kont-rhs-v 'kont-tst-val 'kont-rand-v 'kont-rator-v 'kont-done)) (: stack (Vectorof StackElem)) (define stack (make-vector 100 'junk)) (: stack-ptr Natural) (define stack-ptr 1) (: push (StackElem -> Void)) (define (push x) (vector-set! stack stack-ptr x) (set! stack-ptr (+ stack-ptr 1))) (: pop (-> StackElem)) (define (pop) (define sp stack-ptr) ;; we need a local, immutable variable here ;; since TR cannot tell if there are threads ;; that might mutate stack-ptr at just the ;; wrong time and voila our -1 violates ;; the Natural type declaration. (cond [(zero? sp) (error 'pop "stack underflow")] [else (begin0 (vector-ref stack (- sp 1)) (set! stack-ptr (- sp 1)))])) (: pop-Exp (-> Exp)) (define (pop-Exp) (cast (pop) Exp)) (: pop-Env (-> (HashTable Symbol Value))) (define (pop-Env) (cast (pop) (HashTable Symbol Value))) (: pop-KontTag (-> KontTag)) (define (pop-KontTag) (cast (pop) KontTag)) (: v Value) (define v 0) (: e Exp) (define e 0) (: env : (HashTable Symbol Value)) (define env empty-env) (: apply-kont (-> (U String Value))) (define (apply-kont) (case (pop-KontTag) [(kont-lhs-v) (define rhs (pop-Exp)) (define _env (pop-Env)) (define lhs-v v) (set! e rhs) (set! env _env) (push lhs-v) (push 'kont-rhs-v) (interp/env/k)] [(kont-rhs-v) (define lhs-v (pop)) (define rhs-v v) (cond [(and (number? lhs-v) (number? rhs-v)) (set! v (+ lhs-v rhs-v)) (apply-kont)] [else (format "interp: addition expects numbers, received ~s and ~s" lhs-v rhs-v)])] [(kont-tst-val) (define thn (pop-Exp)) (define els (pop-Exp)) (define _env (pop-Env)) (define tst-val v) (cond [(and (number? tst-val) (zero? tst-val)) (set! e thn) (set! env _env) (interp/env/k)] [else (set! e els) (set! env _env) (interp/env/k)])] [(kont-rand-v) (define rator-v (pop)) (define rand-v v) (match rator-v [(clo arg body clo-env) (set! e body) (set! env (hash-set clo-env arg rand-v)) (interp/env/k)] [_ (format "interp: application expects a function in the rator position, got ~s" rator-v)])] [(kont-rator-v) (define rand (pop-Exp)) (define _env (pop-Env)) (define rator-v v) (set! e rand) (set! env _env) (push rator-v) (push 'kont-rand-v) (interp/env/k)] [(kont-done) v])) (: interp/env/k (-> (U String Value))) (define (interp/env/k) (match e [(sum lhs rhs) (set! e lhs) (push env) (push rhs) (push 'kont-lhs-v) (interp/env/k)] [(if0 tst thn els) (set! e tst) (push env) (push els) (push thn) (push 'kont-tst-val) (interp/env/k)] [(? number? n) (set! v n) (apply-kont)] [(lam arg body) (set! v (clo arg body env)) (apply-kont)] [(app rator rand) (set! e rator) (push env) (push rand) (push 'kont-rator-v) (interp/env/k)] [(? symbol? s) (set! v (hash-ref env s)) (apply-kont)])) (: parse : (Any -> Exp)) (define (parse exp) (match exp [`(λ (,(? symbol? x)) ,body) (lam x (parse body))] [`(if0 ,a ,b ,c) (if0 (parse a) (parse b) (parse c))] [`(+ ,a ,b) (sum (parse a) (parse b))] [`(let ([,x ,rhs]) ,body) (if (symbol? x) (app (lam x (parse body)) (parse rhs)) (error 'parse "expected a symbol for the bound variable, got ~s" x))] [(? number? n) n] [(? symbol? x) x] [`(,f ,x) (app (parse f) (parse x))])) (require "test.rkt") (test interp parse) ---cut here--- file: interp7.rkt ---cut here--- #lang typed/racket #| Adjust the environment to be a list using DeBrujin indicies |# (define-type Exp (U sum if0 Number lam app Symbol id)) (struct: sum ([lhs : Exp] [rhs : Exp]) #:transparent) (struct: if0 ([tst : Exp] [thn : Exp] [els : Exp]) #:transparent) (struct: lam ([bdy : Exp]) #:transparent) (struct: app ([rator : Exp] [rand : Exp]) #:transparent) (struct: id ([id : Natural]) #:transparent) (define-type Value (U Number clo)) (struct: clo ([body : Exp] [env : Env])) (define-type Env (Listof Value)) (: interp (Exp -> (U String Value))) (define (interp _e) (set! e _e) (set! env empty-env) (set! stack-ptr 1) (vector-set! stack 0 'kont-done) (interp/env/k)) (: empty-env Env) (define empty-env '()) (define-type StackElem (U KontTag Value Exp Env)) (define-type KontTag (U 'kont-lhs-v 'kont-rhs-v 'kont-tst-val 'kont-rand-v 'kont-rator-v 'kont-done)) (: stack (Vectorof StackElem)) (define stack (make-vector 100 'junk)) (: stack-ptr Natural) (define stack-ptr 1) (: push (StackElem -> Void)) (define (push x) (vector-set! stack stack-ptr x) (set! stack-ptr (+ stack-ptr 1))) (: pop (-> StackElem)) (define (pop) (define sp stack-ptr) ;; we need a local, immutable variable here ;; since TR cannot tell if there are threads ;; that might mutate stack-ptr at just the ;; wrong time and voila our -1 violates ;; the Natural type declaration. (cond [(zero? sp) (error 'pop "stack underflow")] [else (begin0 (vector-ref stack (- sp 1)) (set! stack-ptr (- sp 1)))])) (: pop-Exp (-> Exp)) (define (pop-Exp) (cast (pop) Exp)) (: pop-Env (-> Env)) (define (pop-Env) (cast (pop) Env)) (: pop-KontTag (-> KontTag)) (define (pop-KontTag) (cast (pop) KontTag)) (: v Value) (define v 0) (: e Exp) (define e 0) (: env : Env) (define env empty-env) (: apply-kont (-> (U String Value))) (define (apply-kont) (case (pop-KontTag) [(kont-lhs-v) (define rhs (pop-Exp)) (define _env (pop-Env)) (define lhs-v v) (set! e rhs) (set! env _env) (push lhs-v) (push 'kont-rhs-v) (interp/env/k)] [(kont-rhs-v) (define lhs-v (pop)) (define rhs-v v) (cond [(and (number? lhs-v) (number? rhs-v)) (set! v (+ lhs-v rhs-v)) (apply-kont)] [else (format "interp: addition expects numbers, received ~s and ~s" lhs-v rhs-v)])] [(kont-tst-val) (define thn (pop-Exp)) (define els (pop-Exp)) (define _env (pop-Env)) (define tst-val v) (cond [(and (number? tst-val) (zero? tst-val)) (set! e thn) (set! env _env) (interp/env/k)] [else (set! e els) (set! env _env) (interp/env/k)])] [(kont-rand-v) (define rator-v (pop)) (define rand-v v) (match rator-v [(clo body clo-env) (set! e body) (set! env (cons rand-v clo-env)) (interp/env/k)] [_ (format "interp: application expects a function in the rator position, got ~s" rator-v)])] [(kont-rator-v) (define rand (pop-Exp)) (define _env (pop-Env)) (define rator-v v) (set! e rand) (set! env _env) (push rator-v) (push 'kont-rand-v) (interp/env/k)] [(kont-done) v])) (: interp/env/k (-> (U String Value))) (define (interp/env/k) (match e [(sum lhs rhs) (set! e lhs) (push env) (push rhs) (push 'kont-lhs-v) (interp/env/k)] [(if0 tst thn els) (set! e tst) (push env) (push els) (push thn) (push 'kont-tst-val) (interp/env/k)] [(? number? n) (set! v n) (apply-kont)] [(lam body) (set! v (clo body env)) (apply-kont)] [(app rator rand) (set! e rator) (push env) (push rand) (push 'kont-rator-v) (interp/env/k)] [(id n) (set! v (list-ref env n)) (apply-kont)])) (: parse : (Any -> Exp)) (define (parse exp) (let: loop ([exp : Any exp] [depth : Natural 0] [env : (HashTable Symbol Natural) #hash()]) (match exp [`(λ (,(? symbol? x)) ,body) (lam (loop body (+ depth 1) (hash-set env x depth)))] [`(if0 ,a ,b ,c) (if0 (loop a depth env) (loop b depth env) (loop c depth env))] [`(+ ,a ,b) (sum (loop a depth env) (loop b depth env))] [`(let ([,x ,rhs]) ,body) (loop `((λ (,x) ,body) ,rhs) depth env)] [(? number? n) n] [(? symbol? x) (id (cast (- depth (hash-ref env x) 1) Natural))] [`(,f ,x) (app (loop f depth env) (loop x depth env))]))) (require typed/rackunit) (check-equal? (parse `(λ (x) x)) (lam (id 0))) (check-equal? (parse `(λ (x) (λ (y) x))) (lam (lam (id 1)))) (check-equal? (parse `(λ (x) (λ (y) y))) (lam (lam (id 0)))) (check-equal? (parse `(λ (x) (λ (y) (λ (z) z)))) (lam (lam (lam (id 0))))) (check-equal? (parse `(λ (x) (λ (y) (λ (z) y)))) (lam (lam (lam (id 1))))) (check-equal? (parse `(λ (x) (λ (y) (λ (z) x)))) (lam (lam (lam (id 2))))) (require "test.rkt") (test interp parse) ---cut here--- file: test.rkt ---cut here--- #lang typed/racket (provide test Y) (define-syntax (try stx) (syntax-case stx () [(_ a b) (with-syntax ([l (syntax-line stx)]) #'(try/proc (λ () a) b l))])) (: n Integer) (define n 0) (: try/proc ((-> Any) Any Real -> Void)) (define (try/proc a-thunk b l) (define a (with-handlers ([exn:fail? (λ (x) ;(eprintf "test case on line ~a raised exn\n" l) ;(raise x) (if (exn? x) (exn-message x) (raise x)))]) (a-thunk))) (unless (or (equal? a b) (and (string? a) (regexp? b) (regexp-match? b a))) (error 'test-case-failure "line ~s: ~s not equal to ~s" l a b)) (set! n (+ n 1))) (: test (∀ (X Y) ((X -> Y) (Any -> X) -> Void))) (define (test interp parse) (try (interp (parse `1)) 1) (try (interp (parse `(+ 1 2))) 3) (try (interp (parse `(if0 1 2 3))) 3) (try (interp (parse `(if0 0 1 2))) 1) (try (interp (parse `((λ (x) 1) 2))) 1) (try (interp (parse `(((λ (x) (λ (y) 1)) 2) 3))) 1) (try (interp (parse `(((λ (x) (λ (y) x)) 2) 3))) 2) (try (interp (parse `(((λ (x) (λ (y) y)) 2) 3))) 3) (try (interp (parse `(+ (+ (λ (x) x) 0) 1))) #rx"^interp:") (try (interp (parse `(+ 1 (+ 0 (λ (x) x))))) #rx"^interp:") (try (interp (parse `((1 2) 3))) #rx"^interp:") (try (interp (parse `(0 (1 2)))) #rx"^interp:") (define tri `(λ (tri) (λ (x) (if0 x 0 (+ x (tri (+ x -1))))))) (try (interp (parse `((,Y ,tri) 10))) (+ 10 9 8 7 6 5 4 3 2 1)) (printf "passed ~a tests.\n" n)) (define Y `(λ (body-proc) (let ([fX (λ (fX) (let ([f (λ (x) ((fX fX) x))]) (body-proc f)))]) (fX fX)))) ---cut here---