#lang plai-typed (require plai-typed/s-exp-match) (define-type-alias Location number) (define-type Value [numV (n : number)] [closV (arg : symbol) (body : ExprC) (env : Env)] [boxV (l : Location)]) (define-type ExprC [numC (n : number)] [idC (s : symbol)] [plusC (l : ExprC) (r : ExprC)] [multC (l : ExprC) (r : ExprC)] [letC (n : symbol) (rhs : ExprC) (body : ExprC)] [lamC (n : symbol) (body : ExprC)] [appC (fun : ExprC) (arg : ExprC)] [boxC (arg : ExprC)] [unboxC (arg : ExprC)] [setboxC (bx : ExprC) (val : ExprC)] [beginC (l : ExprC) (r : ExprC)]) (define-type Binding [bind (name : symbol) (val : Value)]) (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 true)) ;; parse ---------------------------------------- (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? '{let {[SYMBOL ANY]} ANY} s) (let ([bs (s-exp->list (first (s-exp->list (second (s-exp->list s)))))]) (letC (s-exp->symbol (first bs)) (parse (second bs)) (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? '{box ANY} s) (boxC (parse (second (s-exp->list s))))] [(s-exp-match? '{unbox ANY} s) (unboxC (parse (second (s-exp->list s))))] [(s-exp-match? '{set-box! ANY ANY} s) (setboxC (parse (second (s-exp->list s))) (parse (third (s-exp->list s))))] [(s-exp-match? '{begin ANY ANY} s) (beginC (parse (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))))] [else (error 'parse "invalid input")])) (module+ test (test (parse '2) (numC 2)) (test (parse `x) ; note: backquote instead of normal quote (idC 'x)) (test (parse '{+ 2 1}) (plusC (numC 2) (numC 1))) (test (parse '{* 3 4}) (multC (numC 3) (numC 4))) (test (parse '{+ {* 3 4} 8}) (plusC (multC (numC 3) (numC 4)) (numC 8))) (test (parse '{let {[x {+ 1 2}]} y}) (letC 'x (plusC (numC 1) (numC 2)) (idC 'y))) (test (parse '{lambda {x} 9}) (lamC 'x (numC 9))) (test (parse '{double 9}) (appC (idC 'double) (numC 9))) (test (parse '{box 0}) (boxC (numC 0))) (test (parse '{unbox b}) (unboxC (idC 'b))) (test (parse '{set-box! b 0}) (setboxC (idC 'b) (numC 0))) (test (parse '{begin 1 2}) (beginC (numC 1) (numC 2))) (test/exn (parse '{{+ 1 2}}) "invalid input")) ;; interp ---------------------------------------- (define (interp [a : ExprC] [env : Env] [sto : Store]) : Result (type-case ExprC a [numC (n) (v*s (numV n) sto)] [idC (s) (v*s (lookup s env) sto)] [plusC (l r) (type-case Result (interp l env sto) [v*s (v-l sto-l) (type-case Result (interp r env sto-l) [v*s (v-r sto-r) (v*s (num+ v-l v-r) sto-r)])])] [multC (l r) (type-case Result (interp l env sto) [v*s (v-l sto-l) (type-case Result (interp r env sto-l) [v*s (v-r sto-r) (v*s (num* v-l v-r) sto-r)])])] [letC (n rhs body) (type-case Result (interp rhs env sto) [v*s (v-rhs sto-rhs) (interp body (extend-env (bind n v-rhs) env) sto-rhs)])] [lamC (n body) (v*s (closV n body env) sto)] [appC (fun arg) (type-case Result (interp fun env sto) [v*s (v-f sto-f) (type-case Result (interp arg env sto-f) [v*s (v-a sto-a) (type-case Value v-f [closV (n body c-env) (interp body (extend-env (bind n v-a) c-env) sto-a)] [else (error 'interp "not a function")])])])] [boxC (a) (type-case Result (interp a env sto) [v*s (v sto-v) (let ([l (new-loc sto-v)]) (v*s (boxV l) (override-store (cell l v) sto-v)))])] [unboxC (a) (type-case Result (interp a env sto) [v*s (v sto-v) (type-case Value v [boxV (l) (v*s (fetch l sto-v) sto-v)] [else (error 'interp "not a box")])])] [setboxC (bx val) (type-case Result (interp bx env sto) [v*s (v-b sto-b) (type-case Result (interp val env sto-b) [v*s (v-v sto-v) (type-case Value v-b [boxV (l) (v*s v-v (override-store (cell l v-v) sto-v))] [else (error 'interp "not a box")])])])] [beginC (l r) (type-case Result (interp l env sto) [v*s (v-l sto-l) (interp r env sto-l)])])) (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 (numV 9)) mt-env) mt-store) (v*s (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 (plusC (idC 'x) (idC 'x)) mt-env) mt-store)) (test (interp (parse '{let {[x 5]} {+ x x}}) mt-env mt-store) (v*s (numV 10) mt-store)) (test (interp (parse '{let {[x 5]} {let {[x {+ 1 x}]} {+ x x}}}) mt-env mt-store) (v*s (numV 12) mt-store)) (test (interp (parse '{let {[x 5]} {let {[y 6]} x}}) mt-env mt-store) (v*s (numV 5) mt-store)) (test (interp (parse '{{lambda {x} {+ x x}} 8}) mt-env mt-store) (v*s (numV 16) mt-store)) (test (interp (parse '{box 5}) mt-env mt-store) (v*s (boxV 1) (override-store (cell 1 (numV 5)) mt-store))) (test (interp (parse '{unbox {box 5}}) mt-env mt-store) (v*s (numV 5) (override-store (cell 1 (numV 5)) mt-store))) (test (interp (parse '{set-box! {box 5} 6}) mt-env mt-store) (v*s (numV 6) (override-store (cell 1 (numV 6)) (override-store (cell 1 (numV 5)) mt-store)))) (test (interp (parse '{begin 1 2}) mt-env mt-store) (v*s (numV 2) mt-store)) (test (interp (parse '{let {[b (box 5)]} {begin {set-box! b 6} {unbox b}}}) 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]) : Value (cond [(empty? env) (error 'lookup "free variable")] [else (cond [(symbol=? n (bind-name (first env))) (bind-val (first env))] [else (lookup n (rest env))])])) (module+ test (test/exn (lookup 'x mt-env) "free variable") (test (lookup 'x (extend-env (bind 'x (numV 8)) mt-env)) (numV 8)) (test (lookup 'x (extend-env (bind 'x (numV 9)) (extend-env (bind 'x (numV 8)) mt-env))) (numV 9)) (test (lookup 'y (extend-env (bind 'x (numV 9)) (extend-env (bind 'y (numV 8)) mt-env))) (numV 8))) ;; store operations ---------------------------------------- (define (new-loc [sto : Store]) : Location (+ 1 (max-address sto))) (define (max-address [sto : Store]) : Location (cond [(empty? sto) 0] [else (max (cell-location (first sto)) (max-address (rest sto)))])) (define (fetch [l : Location] [sto : Store]) : Value (cond [(empty? sto) (error 'interp "unallocated location")] [else (if (equal? l (cell-location (first sto))) (cell-val (first sto)) (fetch l (rest 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"))