#lang plait (define-type Value (numV [n : Number]) (closV [arg : Symbol] [body : Exp] [env : Env]) (recV [ns : (Listof Symbol)] [vs : (Listof (Boxof Value))])) (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]) (recordE [ns : (Listof Symbol)] [args : (Listof Exp)]) (getE [rec : Exp] [n : Symbol]) (setE [rec : Exp] [n : Symbol] [val : Exp]) (beginE [l : Exp] [r : Exp])) (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 #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? `{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? `{record {SYMBOL ANY} ...} s) (recordE (map (lambda (l) (s-exp->symbol (first (s-exp->list l)))) (rest (s-exp->list s))) (map (lambda (l) (parse (second (s-exp->list l)))) (rest (s-exp->list s))))] [(s-exp-match? `{get ANY SYMBOL} s) (getE (parse (second (s-exp->list s))) (s-exp->symbol (third (s-exp->list s))))] [(s-exp-match? `{set! ANY SYMBOL ANY} s) (setE (parse (second (s-exp->list s))) (s-exp->symbol (third (s-exp->list s))) (parse (fourth (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 `{record {x 2} {y 3}}) (recordE (list 'x 'y) (list (numE 2) (numE 3)))) (test (parse `{get {+ 1 2} a}) (getE (plusE (numE 1) (numE 2)) 'a)) (test (parse `{set! {+ 1 2} a 7}) (setE (plusE (numE 1) (numE 2)) 'a (numE 7))) (test (parse `{begin {+ 1 2} a}) (beginE (plusE (numE 1) (numE 2)) (idE 'a))) (test/exn (parse `{{+ 1 2}}) "invalid input")) ;; interp ---------------------------------------- (define (interp [a : Exp] [env : Env]) : Value (type-case Exp a [(numE n) (numV n)] [(idE s) (lookup s env)] [(plusE l r) (num+ (interp l env) (interp r env))] [(multE l r) (num* (interp l env) (interp r env))] [(letE n rhs body) (interp body (extend-env (bind n (interp rhs env)) env))] [(lamE n body) (closV n body env)] [(appE fun arg) (type-case Value (interp fun env) [(closV n body c-env) (interp body (extend-env (bind n (interp arg env)) c-env))] [else (error 'interp "not a function")])] [(recordE ns as) (recV ns (map (lambda (a) (box (interp a env))) as))] [(getE a n) (type-case Value (interp a env) [(recV ns vs) (unbox (find n ns vs))] [else (error 'interp "not a record")])] [(setE a n v) (type-case Value (interp a env) [(recV ns vs) (let ([f (interp v env)]) (begin (set-box! (find n ns vs) f) f))] [else (error 'interp "not a record")])] [(beginE l r) (begin (interp l env) (interp r env))])) (module+ test (test (interp (parse `2) mt-env) (numV 2)) (test/exn (interp (parse `x) mt-env) "free variable") (test (interp (parse `x) (extend-env (bind 'x (numV 9)) mt-env)) (numV 9)) (test (interp (parse `{+ 2 1}) mt-env) (numV 3)) (test (interp (parse `{* 2 1}) mt-env) (numV 2)) (test (interp (parse `{+ {* 2 3} {+ 5 8}}) mt-env) (numV 19)) (test (interp (parse `{lambda {x} {+ x x}}) mt-env) (closV 'x (plusE (idE 'x) (idE 'x)) mt-env)) (test (interp (parse `{let {[x 5]} {+ x x}}) mt-env) (numV 10)) (test (interp (parse `{let {[x 5]} {let {[x {+ 1 x}]} {+ x x}}}) mt-env) (numV 12)) (test (interp (parse `{let {[x 5]} {let {[y 6]} x}}) mt-env) (numV 5)) (test (interp (parse `{{lambda {x} {+ x x}} 8}) mt-env) (numV 16)) (test (interp (parse `{begin 1 2}) mt-env) (numV 2)) (test (interp (parse `{record {a {+ 1 1}} {b {+ 2 2}}}) mt-env) (recV (list 'a 'b) (list (box (numV 2)) (box (numV 4))))) (test (interp (parse `{get {record {a {+ 1 1}} {b {+ 2 2}}} a}) mt-env) (numV 2)) (test (interp (parse `{get {record {a {+ 1 1}} {b {+ 2 2}}} b}) mt-env) (numV 4)) (test (interp (parse `{let {[o {record {a {+ 1 1}} {b {+ 2 2}}}]} {begin {set! o a 5} o}}) mt-env) (recV (list 'a 'b) (list (box (numV 5)) (box (numV 4))))) (test/exn (interp (parse `{1 2}) mt-env) "not a function") (test/exn (interp (parse `{+ 1 {lambda {x} x}}) mt-env) "not a number") (test/exn (interp (parse `{let {[bad {lambda {x} {+ x y}}]} {let {[y 5]} {bad 2}}}) mt-env) "free variable") (test/exn (interp (parse `{get 6 x}) mt-env) "not a record") (test/exn (interp (parse `{set! 6 x 9}) mt-env) "not a record")) ;; 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 (type-case (Listof Binding) env [empty (error 'lookup "free variable")] [(cons b rst-env) (cond [(symbol=? n (bind-name b)) (bind-val b)] [else (lookup n rst-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))) ;; find ---------------------------------------- ;; Takes a name and two parallel lists, returning an item from the ;; second list where the name matches the item from the first list. (define (find [n : Symbol] [ns : (Listof Symbol)] [vs : (Listof (Boxof Value))]) : (Boxof Value) (cond [(empty? ns) (error 'interp "no such field")] [else (if (symbol=? n (first ns)) (first vs) (find n (rest ns) (rest vs)))])) (module+ test (test (find 'a (list 'a 'b) (list (box (numV 1)) (box (numV 2)))) (box (numV 1))) (test (find 'b (list 'a 'b) (list (box (numV 1)) (box (numV 2)))) (box (numV 2))) (test/exn (find 'a empty empty) "no such field"))