Interpreter with Mutation

Oct 3, 2015

—

An interpreter written in typed racket

	#lang plai-typed

	(define-type
	ExprE
	[numE
	(n : number)]
	[varE
	(i : symbol)]
	[lamE
	(arg : symbol)
	(body : ExprE)]
	[appE
	(fun : ExprE)
	(arg : ExprE)]
	[plusE
	(l : ExprE)
	(r : ExprE)]
	[multE
	(l : ExprE)
	(r : ExprE)]
	[setE
	(var : symbol)
	(arg : ExprE)]
	[seqE
	(b1 : ExprE)
	(b2 : ExprE)])

	(define-type
	Value
	[numV
	(n : number)]
	[closV
	(arg : symbol)
	(body : ExprE)
	(env : Env)])

	(define-type
	Result
	[v*s
	(v : Value)
	(s : Store)])

	(define-type
	Location
	[locL (ll : number)])

	(define-type
	Storage
	[cell
	(location : Location)
	(val : Value)])
	(define-type
	Binding
	[bind
	(name : symbol)
	(value : Location)])

	(define-type-alias
	Env
	(listof
	Binding))
	(define-type-alias
	Store
	(listof
	Storage))


	(define
	mt-env
	empty)
	(define
	mt-store
	empty)

	(define
	extend-env
	cons)
	(define
	override-store
	cons)


	(define
	(num+
	[l : Value]
	[r : Value])
	: Value
	(cond
	[(and
	(numV? l)
	(numV? r))
	(numV
	(+
	(numV-n l)
	(numV-n r)))]
	[else (error 'num+ "arg not a number")]))

	(define
	(num*
	[l : Value]
	[r : Value])
	: Value
	(cond
	[(and
	(numV? l)
	(numV? r))
	(numV
	(*
	(numV-n l)
	(numV-n r)))]
	[else (error 'num+ "arg not a number")]))



	(define
	(lookup
	[n : symbol]
	[env : Env])
	: Location
	(cond
	[(empty?
	env)
	(error 'lookup "name not found")]
	[else
	(cond
	[(symbol=?
	n
	(bind-name (first env)))
	(bind-value (first env))]
	[else
	(lookup
	n
	(rest env))])]))



	(define
	(fetch
	[n : Location]
	[sto : Store])
	: Value
	(cond
	[(empty?
	sto)
	(error 'lookup "name not found")]
	[else
	(cond
	[(equal?
	n
	(cell-location (first sto)))
	(cell-val (first sto))]
	[else
	(fetch
	n
	(rest sto))])]))


	(define
	(interpE
	[exp : ExprE]
	[env : Env]
	[sto : Store])
	: Result
	(type-case ExprE exp
	[numE (n)
	(v*s
	(numV n)
	sto)]
	[varE (c)
	(v*s
	(fetch
	(lookup
	c
	env)
	sto)
	sto)]
	[lamE (a b)
	(v*s
	(closV a b env)
	sto)]
	[plusE (l r)
	(type-case
	Result (interpE l env sto)
	[v*s (v-l s-l)
	(type-case
	Result (interpE r env s-l)
	[v*s (v-r s-r)
	(v*s
	(num+ v-l v-r)
	s-r)])])]
	[multE (l r)
	(type-case
	Result (interpE l env sto)
	[v*s (v-l s-l)
	(type-case
	Result (interpE r env s-l)
	[v*s (v-r s-r)
	(v*s
	(num* v-l v-r)
	s-r)])])]
	[setE (var val)
	(type-case Result (interpE val env sto)
	[v*s (v-b s-b)
	(let ([where (lookup var env)])
	(v*s
	v-b
	(override-store
	(cell
	where
	v-b)
	s-b)))])]
	[seqE (b1 b2)
	(type-case
	Result
	(interpE b1 env sto)
	[v*s (v-b1 s-b1)
	(interpE b2 env sto)])]

	[appE (f a)
	(type-case Result (interpE f env sto)
	[v*s (v-f s-f)
	(type-case Result (interpE a env s-f)
	[v*s (v-a s-a)
	(let ([where (new-loc 0)])
	(interpE
	(closV-body v-f)
	(extend-env
	(bind
	(closV-arg v-f)
	where)
	(closV-env v-f))
	(override-store
	(cell
	where v-a)
	s-a)))])])]
	))

	(define (new-loc [u : number])
	(let ([n (box 0)])
	(begin
	(set-box! n (add1 (unbox n)))
	(locL (unbox n)))))

view raw

interp_p60objects.rkt

hosted with ❤ by GitHub

Interpreter with Mutation

Share this:

Like this:

Discover more from Gaurav Sharma's Blog