#lang plait ;; Define `dist` and `swap` functions in Curly ;; Add an {add } form to add a field ;; to a record (define-type Value (numV [n : Number]) (closV [arg : Symbol] [body : Exp] [env : Env]) (recV [ns : (Listof Symbol)] [vs : (Listof 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]) (addE [rec : Exp] [name : Symbol] [val : 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])) (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? `{add ANY SYMBOL ANY} s) (addE (parse (second (s-exp->list s))) (s-exp->symbol (third (s-exp->list s))) (parse (fourth (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/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))] [(addE r n v) (type-case Value (interp r env) [(recV ns vs) (if (member n ns) (error 'interp "field already there") (recV (append ns (list n)) (append vs (list (interp v env)))))] [else (error 'interp "not a record")])] [(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) (interp a env)) as))] [(getE a n) (type-case Value (interp a env) [(recV ns vs) (find n ns vs)] [else (error 'interp "not a record")])] [(setE a n v) (type-case Value (interp a env) [(recV ns vs) (recV ns (update n (interp v env) ns vs))] [else (error 'interp "not a record")])])) (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 `{record {a {+ 1 1}} {b {+ 2 2}}}) mt-env) (recV (list 'a 'b) (list (numV 2) (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 `{set {record {a {+ 1 1}} {b {+ 2 2}}} a 5}) mt-env) (recV (list 'a 'b) (list (numV 5) (numV 4)))) (test (interp (parse `{let {[r1 {record {a {+ 1 1}} {b {+ 2 2}}}]} {let {[r2 {set r1 a 5}]} {+ {get r1 a} {get r2 a}}}}) mt-env) (numV 7)) (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 & update ---------------------------------------- ;; 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 Value)]) : Value (cond [(empty? ns) (error 'interp "no such field")] [else (if (symbol=? n (first ns)) (first vs) (find n (rest ns) (rest vs)))])) ;; Takes a name n, value v, and two parallel lists, returning a list ;; like the second of the given lists, but with v in place ;; where n matches the item from the first list. (define (update [n : Symbol] [v : Value] [ns : (Listof Symbol)] [vs : (Listof Value)]) : (Listof Value) (cond [(empty? ns) (error 'interp "no such field")] [else (if (symbol=? n (first ns)) (cons v (rest vs)) (cons (first vs) (update n v (rest ns) (rest vs))))])) (module+ test (test (find 'a (list 'a 'b) (list (numV 1) (numV 2))) (numV 1)) (test (find 'b (list 'a 'b) (list (numV 1) (numV 2))) (numV 2)) (test/exn (find 'a empty empty) "no such field") (test (update 'a (numV 0) (list 'a 'b) (list (numV 1) (numV 2))) (list (numV 0) (numV 2))) (test (update 'b (numV 0) (list 'a 'b) (list (numV 1) (numV 2))) (list (numV 1) (numV 0))) (test/exn (update 'a (numV 0) empty empty) "no such field") (test (interp (parse `{let {[dist {lambda {r} {+ {get r x} {get r y}}}]} {dist {record {x 1} {y 2}}}} ) mt-env) (numV 3)) (test (interp (parse `{let {[swap {lambda {r} {let {[r_x {get r x}]} {let {[r_y {get r y}]} {record {x r_y} {y r_x}}}}}]} {swap {record {x 2} {y 3} {z 4}}}}) mt-env) (recV (list 'x 'y) (list (numV 3) (numV 2)))) (test (interp (parse `{let {[swap {lambda {r} {let {[r_x {get r x}]} {let {[r_y {get r y}]} {set {set r x r_y} y r_x}}}}]} {swap {record {x 2} {y 3} {z 4}}}}) mt-env) (recV (list 'x 'y 'z) (list (numV 3) (numV 2) (numV 4)))) (test (interp (parse `{let {[swap {lambda {r} {set {set r x {get r y}} y {get r x}}}]} {swap {record {x 2} {y 3} {z 4}}}}) mt-env) (recV (list 'x 'y 'z) (list (numV 3) (numV 2) (numV 4)))))