#lang plai-typed (require plai-typed/s-exp-match) ;; We implemented has-field (except we called it has instead), then ;; we started the record with fallback, but ran out of time. ;; So it's totally broken right now. ;; (has-field ) -> 0 for true, 1 for false ;(record (x 5) (y 7)) ;(record ...) ;(get (record (+ v 7) (x 5) (y 3)) z) -> whatever v + 7 is (define-type Value [numV (n : number)] [closV (arg : symbol) (body : ExprC) (env : Env)] [recV (ns : (listof symbol)) (vs : (listof Value)) (fallback : ExprC) (env : Env)]) (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)] [recordC (ns : (listof symbol)) (args : (listof ExprC)) (fallback : ExprC)] [getC (rec : ExprC) (n : symbol)] [setC (rec : ExprC) (n : symbol) (val : ExprC)] [hasC (id : symbol) (rec : ExprC)]) (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 true)) (module+ test (test (interp (parse '{has x {record {x 2} {y 3}}}) empty) (numV 0)) (test (interp (parse '{has z {record {x 2} {y 3}}}) empty) (numV 1)) (test/exn (interp (parse '{has x 7}) empty) "not a record")) ;; 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? '{record ANY {SYMBOL ANY} ...} s) (recordC (map (lambda (l) (s-exp->symbol (first (s-exp->list l)))) (rest (rest (s-exp->list s)))) (map (lambda (l) (parse (second (s-exp->list l)))) (rest (rest (s-exp->list s)))) (parse (second (s-exp->list s))))] [(s-exp-match? '{get ANY SYMBOL} s) (getC (parse (second (s-exp->list s))) (s-exp->symbol (third (s-exp->list s))))] [(s-exp-match? '{set ANY SYMBOL ANY} s) (setC (parse (second (s-exp->list s))) (s-exp->symbol (third (s-exp->list s))) (parse (fourth (s-exp->list s))))] [(s-exp-match? '{has SYMBOL ANY} s) (hasC (s-exp->symbol (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 '{record {x 2} {y 3}}) (recordC (list 'x 'y) (list (numC 2) (numC 3)))) (test (parse '{get {+ 1 2} a}) (getC (plusC (numC 1) (numC 2)) 'a)) (test (parse '{set {+ 1 2} a 7}) (setC (plusC (numC 1) (numC 2)) 'a (numC 7))) (test/exn (parse '{{+ 1 2}}) "invalid input")) ;; interp ---------------------------------------- (define (interp [a : ExprC] [env : Env]) : Value (type-case ExprC a [numC (n) (numV n)] [idC (s) (lookup s env)] [plusC (l r) (num+ (interp l env) (interp r env))] [multC (l r) (num* (interp l env) (interp r env))] [letC (n rhs body) (interp body (extend-env (bind n (interp rhs env)) env))] [lamC (n body) (closV n body env)] [appC (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")])] [recordC (ns as) (recV ns (map (lambda (a) (interp a env)) as))] [getC (a n) (type-case Value (interp a env) [recV (ns vs) (find n ns vs)] [else (error 'interp "not a record")])] [setC (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")])] [hasC (id exp) (type-case Value (interp exp env) [recV (ns vs) (if (has id ns vs) (numV 0) (numV 1))] [else (error 'interp "not a record")])])) (define (has [n : symbol] [ns : (listof symbol)] [vs : (listof Value)]) : boolean (cond [(empty? ns) false] [else (if (symbol=? n (first ns)) true (has n (rest ns) (rest vs)))])) #| (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)))])) |# (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 (plusC (idC 'x) (idC '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/exn (interp (parse '{get 5 a}) mt-env) "not a record") (test/exn (interp (parse '{set 5 a 5}) mt-env) "not a record") (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")) ;; 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))) ;; 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"))