Skip to content

Instantly share code, notes, and snippets.

@munyari

munyari/funenv.rkt

Created March 9, 2017 03:58
Show Gist options
  • Save munyari/d59097cedc5ac1dfb58fa0fd8ca0ab52 to your computer and use it in GitHub Desktop.
Save munyari/d59097cedc5ac1dfb58fa0fd8ca0ab52 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
funenv.rkt
#lang plai-typed
(define-type ExprC
[numC (n : number)]
[idC (s : symbol)]
[plusC (l : ExprC) (r : ExprC )]
[multC (l : ExprC) (r : ExprC)]
[appC ( s : symbol )
( arg : ExprC)])
(define-type FunDefC
[fdC (name : symbol)
(arg : symbol)
(body : ExprC)])
;; (define (double x ) ( + x x))
(define double-def
(fdC 'double 'x (plusC (idC 'x) (idC 'x))))
;; (define (qudriple x )(double (double x)))
(define quadruple-def
(fdC 'quadruple 'x (appC 'double (appC 'double (idC 'x)))))
(define-type Binding
[bind (name : symbol) (val : number)])
(define-type-alias Env (listof Binding))
(define mt-env empty)
(define extend-env cons)
(define (look-up [ s : symbol] [ lst : Env] ) : number
(cond [(empty? lst ) (error 'lookup "not found")]
[(cons? lst)
(if (symbol=? s (bind-name (first lst)))
(bind-val (first lst))
(look-up s (rest lst)))]))
(test (look-up 'x (list (bind 'x 3)(bind 'x 4))) 3)
(test (look-up 'x (list (bind 'y 3)(bind 'x 4))) 4)
(test/exn (look-up 'z (list (bind 'y 3)(bind 'x 4))) "not found")
(define (interp [a : ExprC][env : Env] [fds : (listof FunDefC)] ) : number
(type-case ExprC a
[numC (n) n]
[idC (s) (look-up s env)]
[plusC (l r) (+ (interp l env fds ) (interp r env fds))]
[multC (l r)
(if (= 0 (interp l env fds)) 0
(* (interp l env fds)(interp r env fds)))]
[appC (s a)
(local ([define fd (get-fundef s fds)])
( interp (fdC-body fd)
(extend-env (bind (fdC-arg fd)(interp a env fds)) mt-env)
fds
))]))
;; get-fundef : symbol (listof fundef) -> fundef
(define (get-fundef s lst)
(cond [(empty? lst) (error 'get-fundef "undefined function")]
[(cons? lst)
(cond [(eq? s (fdC-name (first lst)))
(first lst)]
[else
(get-fundef s (rest lst))])]))
(test (get-fundef 'double (list double-def))
double-def)
(test (get-fundef 'double (list double-def quadruple-def))
double-def)
(test (get-fundef 'double (list quadruple-def double-def))
double-def)
(test (get-fundef 'quadruple (list quadruple-def double-def))
quadruple-def)
(test/exn (get-fundef 'double empty)
"undefined function")
(test (interp (numC 2) mt-env empty)
2)
(test (interp (plusC (numC 2) (numC 1)) mt-env empty)
3)
(test (interp (multC (numC 2) (numC 1)) mt-env empty)
2)
(test (interp (multC (numC 0) (idC 'z)) mt-env empty)
0)
(test (interp (multC (numC 0) (numC 1)) mt-env empty)
0)
(test (interp (multC (plusC ( numC 2)(numC -2)) (numC 1)) mt-env empty)
0)
(test (interp (plusC (multC (numC 2) (numC 3))
(plusC (numC 5) (numC 8))) mt-env empty)
19)
(test (interp (appC 'double (numC 8)) mt-env
(list double-def))
16)
(test (interp (appC 'quadruple (numC 8)) mt-env
(list double-def quadruple-def))
32)
;;;;;;;;;;;; from book
(test (interp (plusC (numC 10) (appC 'const5 (numC 10)))
mt-env
(list (fdC 'const5 '_ (numC 5))))
15)
(test (interp (plusC (numC 10) (appC 'double (plusC (numC 1) (numC 2))))
mt-env
(list (fdC 'double 'x (plusC (idC 'x) (idC 'x)))))
16)
(test (interp (plusC (numC 10) (appC 'quadruple (plusC (numC 1) (numC 2))))
mt-env
(list (fdC 'quadruple 'x (appC 'double (appC 'double (idC 'x))))
(fdC 'double 'x (plusC (idC 'x) (idC 'x)))))
22)
;;;; another
(test/exn (interp (appC 'f1 (numC 3))
mt-env
(list (fdC 'f1 'x (appC 'f2 (numC 4)))
(fdC 'f2 'y (plusC (idC 'x) (idC 'y)))))
"lookup: not found")
Raw
lambda.rkt
#lang plai-typed
(require plai-typed/s-exp-match)
(define-type Value
[numV (n : number)]
[closV (arg : symbol)
(body : 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)])
(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))
;; 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")])]))
(module+ test
(test (interp (numC 2) mt-env)
(numV 2))
(test/exn (interp (idC 'x) mt-env)
"free variable")
(test (interp (idC 'x)
(extend-env (bind 'x (numV 9)) mt-env))
(numV 9))
(test (interp (plusC (numC 2)(numC 1)) mt-env)
(numV 3))
(test (interp (multC (numC 2)(numC 3)) mt-env)
(numV 6))
(test (interp (plusC (multC (numC 2)(numC 3))(plusC (numC 5)(numC 8)))
mt-env)
(numV 19))
(test (interp (lamC 'x (plusC (idC 'x)(idC 'x)))
mt-env)
(closV 'x (plusC (idC 'x) (idC 'x)) mt-env))
(test (interp (letC 'x (numC 5)
(plusC (idC 'x)(idC 'x)))
mt-env)
(numV 10))
(test (interp(letC 'x (numC 5)
(letC 'x (plusC (numC 1)(idC 'x))
(plusC (idC 'x)(idC 'x))))
mt-env)
(numV 12))
(test (interp (letC 'x (numC 5)
(letC 'y (numC 6)
(idC 'x)))
mt-env)
(numV 5))
(test (interp (appC (lamC 'x (plusC (idC 'x )(idC 'x))) (numC 8))
mt-env)
(numV 16))
(test/exn (interp (appC (numC 1) (numC 2)) mt-env)
"not a function")
(test/exn (interp (plusC (numC 1) (lamC 'x (idC 'x))) mt-env)
"not a number")
(test/exn (interp (letC 'bad (lamC 'x (plusC (idC 'x)(idC 'y)))
(letC 'y (numC 5)
(appC (idC 'bad)(numC 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)))
Raw
store.rkt
#lang plai-typed
(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))
;; 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)))]))
(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))
;; 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)])]))
(test (interp (numC 2) mt-env mt-store)
(v*s (numV 2)
mt-store))
(test/exn (interp (idC 'x) mt-env mt-store)
"free variable")
(test (interp (idC 'x)
(extend-env (bind 'x (numV 9)) mt-env)
mt-store)
(v*s (numV 9)
mt-store))
(test (interp (plusC (numC 3)(numC 2)) mt-env mt-store)
(v*s (numV 5)
mt-store))
(test (interp (multC (numC 2)(numC 1)) mt-env mt-store)
(v*s (numV 2)
mt-store))
(test (interp (boxC (numC 5))
mt-env
mt-store)
(v*s (boxV 1)
(override-store (cell 1 (numV 5))
mt-store)))
(test (interp (unboxC (boxC (numC 5)))
mt-env
mt-store)
(v*s (numV 5)
(override-store (cell 1 (numV 5))
mt-store)))
(test (interp (setboxC (boxC (numC 5)) (numC 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 (beginC (numC 1)(numC 2))
mt-env
mt-store)
(v*s (numV 2)
mt-store))
(test (interp (letC 'b (boxC (numC 5))
(beginC
(setboxC (idC 'b) (numC 6))
(unboxC (idC 'b))))
mt-env
mt-store)
(v*s (numV 6)
(override-store (cell 1 (numV 6))
(override-store (cell 1 (numV 5))
mt-store))))
;; 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))
(test (num+ (numV 1) (numV 2))
(numV 3))
(test (num* (numV 2) (numV 3))
(numV 6))
(interp (boxC (plusC (numC 1 ) (numC 2))) mt-env mt-store)
(interp (letC 'f (lamC 'x (boxC (idC 'x)) )
(setboxC (appC (idC 'f) (numC 3))
(appC (idC 'f) (numC 5)))) mt-env mt-store)
(trace interp)
(interp (letC 'f (lamC 'x (boxC (idC 'x)) )
(letC 'b (appC (idC 'f) (numC 7))
(setboxC (idC 'b) (idC 'b))))
mt-env mt-store)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment