#lang plait ;; Start with "variable.rkt" ;; Add a `{fluid-let {[ ]} }` form that changes ;; to have the value of the first `` while evaluating the body ;; , then changes back after getting a value from the body ;; . (define-type-alias Location Number) (define-type Value (numV [n : Number]) (closV [arg : Symbol] [body : Exp] [env : Env])) (define-type Exp (numE [n : Number]) (idE [s : Symbol]) (plusE [l : Exp] [r : Exp]) (multE [l : Exp] [r : Exp]) (letE [n : Symbol] [rhs : Exp] [body : Exp]) (lamE [n : Symbol] [body : Exp]) (appE [fun : Exp] [arg : Exp]) (setE [var : Symbol] [val : Exp]) (beginE [l : Exp] [r : Exp]) (fluidLetE [s : Symbol] [n : Exp] [body : Exp])) (define-type Binding (bind [name : Symbol] [location : Location])) (define-type-alias Env (Listof Binding)) (define mt-env empty) (define extend-env cons) (define-type Storage (cell [location : Location] [val : Value])) (define-type-alias Store (Listof Storage)) (define mt-store empty) (define override-store cons) (define-type Result (v*s [v : Value] [s : Store])) (module+ test (print-only-errors #t)) ;; parse ---------------------------------------- (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? `{let {[SYMBOL ANY]} ANY} s) (let ([bs (s-exp->list (first (s-exp->list (second (s-exp->list s)))))]) (letE (s-exp->symbol (first bs)) (parse (second bs)) (parse (third (s-exp->list s)))))] [(s-exp-match? `{fluid-let {[SYMBOL ANY]} ANY} s) (let ([bs (s-exp->list (first (s-exp->list (second (s-exp->list s)))))]) (fluidLetE (s-exp->symbol (first bs)) (parse (second bs)) (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? `{set! SYMBOL ANY} s) (setE (s-exp->symbol (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? `{begin ANY ANY} s) (beginE (parse (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))))] [else (error 'parse "invalid input")])) (module+ test (test (parse `2) (numE 2)) (test (parse `x) (idE 'x)) (test (parse `{+ 2 1}) (plusE (numE 2) (numE 1))) (test (parse `{* 3 4}) (multE (numE 3) (numE 4))) (test (parse `{+ {* 3 4} 8}) (plusE (multE (numE 3) (numE 4)) (numE 8))) (test (parse `{let {[x {+ 1 2}]} y}) (letE 'x (plusE (numE 1) (numE 2)) (idE 'y))) (test (parse `{lambda {x} 9}) (lamE 'x (numE 9))) (test (parse `{double 9}) (appE (idE 'double) (numE 9))) (test (parse `{set! b 0}) (setE 'b (numE 0))) (test (parse `{begin 1 2}) (beginE (numE 1) (numE 2))) (test/exn (parse `{{+ 1 2}}) "invalid input")) ;; with form ---------------------------------------- (define-syntax-rule (with [(v-id sto-id) call] body) (type-case Result call [(v*s v-id sto-id) body])) ;; interp ---------------------------------------- (define (interp [a : Exp] [env : Env] [sto : Store]) : Result (type-case Exp a [(numE n) (v*s (numV n) sto)] [(idE s) (v*s (fetch (lookup s env) sto) sto)] [(plusE l r) (with [(v-l sto-l) (interp l env sto)] (with [(v-r sto-r) (interp r env sto-l)] (v*s (num+ v-l v-r) sto-r)))] [(multE l r) (with [(v-l sto-l) (interp l env sto)] (with [(v-r sto-r) (interp r env sto-l)] (v*s (num* v-l v-r) sto-r)))] [(letE n rhs body) (with [(v-rhs sto-rhs) (interp rhs env sto)] (let ([l (new-loc sto-rhs)]) (interp body (extend-env (bind n l) env) (override-store (cell l v-rhs) sto-rhs))))] [(lamE n body) (v*s (closV n body env) sto)] [(appE fun arg) (with [(v-f sto-f) (interp fun env sto)] (with [(v-a sto-a) (interp arg env sto-f)] (type-case Value v-f [(closV n body c-env) (let ([l (new-loc sto-a)]) (interp body (extend-env (bind n l) c-env) (override-store (cell l v-a) sto-a)))] [else (error 'interp "not a function")])))] [(setE var val) (let ([l (lookup var env)]) (with [(v-v sto-v) (interp val env sto)] (v*s v-v (override-store (cell l v-v) sto-v))))] [(beginE l r) (with [(v-l sto-l) (interp l env sto)] (interp r env sto-l))] [(fluidLetE s n body) (local [(define loc (lookup s env)) (define old-v (fetch loc sto))] (with [(v-n sto-n) (interp n env sto)] (with [(v-body sto-body) (interp body env (override-store (cell loc v-n) sto-n))] (v*s v-body (override-store (cell loc old-v) sto-body)))))])) (module+ test (test (interp (parse `2) mt-env mt-store) (v*s (numV 2) mt-store)) (test/exn (interp (parse `x) mt-env mt-store) "free variable") (test (interp (parse `x) (extend-env (bind 'x 1) mt-env) (override-store (cell 1 (numV 9)) mt-store)) (v*s (numV 9) (override-store (cell 1 (numV 9)) mt-store))) (test (interp (parse `{+ 2 1}) mt-env mt-store) (v*s (numV 3) mt-store)) (test (interp (parse `{* 2 1}) mt-env mt-store) (v*s (numV 2) mt-store)) (test (interp (parse `{+ {* 2 3} {+ 5 8}}) mt-env mt-store) (v*s (numV 19) mt-store)) (test (interp (parse `{lambda {x} {+ x x}}) mt-env mt-store) (v*s (closV 'x (plusE (idE 'x) (idE 'x)) mt-env) mt-store)) (test (interp (parse `{let {[x 5]} {+ x x}}) mt-env mt-store) (v*s (numV 10) (override-store (cell 1 (numV 5)) mt-store))) (test (interp (parse `{let {[x 5]} {let {[x {+ 1 x}]} {+ x x}}}) mt-env mt-store) (v*s (numV 12) (override-store (cell 2 (numV 6)) (override-store (cell 1 (numV 5)) mt-store)))) (test (interp (parse `{let {[x 5]} {let {[y 6]} x}}) mt-env mt-store) (v*s (numV 5) (override-store (cell 2 (numV 6)) (override-store (cell 1 (numV 5)) mt-store)))) (test (interp (parse `{let {[x 1]} {let {[f {lambda {y} {+ y x}}]} {let {[x 2]} {f 0}}}}) mt-env mt-store) (v*s (numV 1) (override-store (cell 4 (numV 0)) (override-store (cell 3 (numV 2)) (override-store (cell 2 (closV 'y (parse `{+ y x}) (extend-env (bind 'x 1) mt-env))) (override-store (cell 1 (numV 1)) mt-store)))))) (test (interp (parse `{let {[x 10]} {let {[f {lambda {y} {+ y x}}]} {fluid-let {[x 2]} {f 0}}}}) mt-env mt-store) (v*s (numV 2) (override-store (cell 1 (numV 10)) (override-store (cell 3 (numV 0)) (override-store (cell 1 (numV 2)) (override-store (cell 2 (closV 'y (parse `{+ y x}) (extend-env (bind 'x 1) mt-env))) (override-store (cell 1 (numV 10)) mt-store))))))) (test (interp (parse `{{lambda {x} {+ x x}} 8}) mt-env mt-store) (v*s (numV 16) (override-store (cell 1 (numV 8)) mt-store))) (test (interp (parse `{begin 1 2}) mt-env mt-store) (v*s (numV 2) mt-store)) (test (interp (parse `{let {[x 5]} {begin {set! x 6} x}}) mt-env mt-store) (v*s (numV 6) (override-store (cell 1 (numV 6)) (override-store (cell 1 (numV 5)) mt-store)))) (test/exn (interp (parse `{1 2}) mt-env mt-store) "not a function") (test/exn (interp (parse `{+ 1 {lambda {x} x}}) mt-env mt-store) "not a number") (test/exn (interp (parse `{let {[bad {lambda {x} {+ x y}}]} {let {[y 5]} {bad 2}}}) mt-env mt-store) "free variable")) ;; num+ and num* ---------------------------------------- (define (num-op [op : (Number Number -> Number)] [l : Value] [r : Value]) : Value (cond [(and (numV? l) (numV? r)) (numV (op (numV-n l) (numV-n r)))] [else (error 'interp "not a number")])) (define (num+ [l : Value] [r : Value]) : Value (num-op + l r)) (define (num* [l : Value] [r : Value]) : Value (num-op * l r)) (module+ test (test (num+ (numV 1) (numV 2)) (numV 3)) (test (num* (numV 2) (numV 3)) (numV 6))) ;; lookup ---------------------------------------- (define (lookup [n : Symbol] [env : Env]) : Location (type-case (Listof Binding) env [empty (error 'lookup "free variable")] [(cons b rst-env) (cond [(symbol=? n (bind-name b)) (bind-location b)] [else (lookup n rst-env)])])) (module+ test (test/exn (lookup 'x mt-env) "free variable") (test (lookup 'x (extend-env (bind 'x 8) mt-env)) 8) (test (lookup 'x (extend-env (bind 'x 9) (extend-env (bind 'x 8) mt-env))) 9) (test (lookup 'y (extend-env (bind 'x 9) (extend-env (bind 'y 8) mt-env))) 8)) ;; store operations ---------------------------------------- (define (new-loc [sto : Store]) : Location (+ 1 (max-address sto))) (define (max-address [sto : Store]) : Location (type-case (Listof Storage) sto [empty 0] [(cons c rst-sto) (max (cell-location c) (max-address rst-sto))])) (define (fetch [l : Location] [sto : Store]) : Value (type-case (Listof Storage) sto [empty (error 'interp "unallocated location")] [(cons c rst-sto) (if (equal? l (cell-location c)) (cell-val c) (fetch l rst-sto))])) (module+ test (test (max-address mt-store) 0) (test (max-address (override-store (cell 2 (numV 9)) mt-store)) 2) (test (fetch 2 (override-store (cell 2 (numV 9)) mt-store)) (numV 9)) (test (fetch 2 (override-store (cell 2 (numV 10)) (override-store (cell 2 (numV 9)) mt-store))) (numV 10)) (test (fetch 3 (override-store (cell 2 (numV 10)) (override-store (cell 3 (numV 9)) mt-store))) (numV 9)) (test/exn (fetch 2 mt-store) "unallocated location"))