Control.Print.printDepth := 80; Control.Print.printLength := 80; type var = string type loc = string datatype opn = Plus | Times | Minus | Lte datatype value = Bool of bool | Int of int | Unit | Fn of var * exp | Loc of loc and exp = Val of value | Var of var | App of exp * exp | Ref of exp | Deref of exp | Assign of exp * exp | If of exp * exp * exp | Opn of exp * opn * exp type store = loc -> value datatype iexp = Bool_i of bool | Int_i of int | Opn_i of iexp * opn * iexp | Var_i of string | Addr_i of var | Deref_i of iexp datatype icom = Skip_i | Seq_i of icom * icom | If_i of iexp * icom * icom | Assign_i of iexp * iexp | While_i of iexp * icom type iprog = { vars : (var * iexp) list, main : icom } (****************************************************************************) exception Fail of string (* Def for empty store. *) val s0 : store = fn x => raise Fail ("invalid location: " ^ x) (* A closure for generating fresh names. *) val gensym = let val x = ref 0 in fn prefix : string => let val _ = x := !x + 1 in prefix ^ "_" ^ (Int.toString (!x)) end end (********************************** PART 1 **********************************) (* Translates Opn into ML operator functions. *) fun evalop (oper : opn) = case oper of Plus => op+ | Times => op* | Minus => op- | Lte => raise Fail "internal error" (* Determines whether x is free in e. *) fun free (x : var, e : exp) = case e of Val (Fn (y, e')) => x <> y andalso free (x, e') | Val _ => false | Var y => x = y | App (e1, e2) => free (x, e1) orelse free (x, e2) | Ref e' => free (x, e') | Deref e' => free (x, e') | Assign (e1, e2) => free (x, e1) orelse free (x, e2) | If (e1, e2, e3) => free (x, e1) orelse free (x, e2) orelse free (x, e3) | Opn (e1, _, e2) => free (x, e1) orelse free (x, e2) (* Substitutes e2 for x in body. *) fun sub (x : var, e2 : exp, body : exp) = case body of Val (Fn (y, e)) => if x=y then body else if not (free (y, e2)) then Val (Fn (y, sub (x, e2, e))) else (* Alpha-rename the formal argument to avoid variable capture. *) let val fresh = gensym "x" in Val (Fn (fresh, sub (x, e2, sub (y, Var fresh, e)))) end | Val _ => body | Var y => if x=y then e2 else body | App (e, e') => App (sub (x, e2, e), sub (x, e2, e')) | Ref e => Ref (sub (x, e2, e)) | Deref e => Deref (sub (x, e2, e)) | Assign (e, e') => Assign (sub (x, e2, e), sub (x, e2, e')) | If (e, e', e'') => If (sub (x, e2, e), sub (x, e2, e'), sub (x, e2, e'')) | Opn (e, oper, e') => Opn (sub (x, e2, e), oper, sub (x, e2, e')) (* The main eval function. *) fun eval (Val v, s : store) = (s, v) | eval (Var x, s) = raise Fail ("unbound variable: " ^ x) | eval (App (e1, e2), s) = let val (s1, Fn (x,e)) = eval (e1, s) val (s2, v2) = eval (e2, s1) in eval (sub (x, Val v2, e), s2) end | eval (Ref e, s) = let val (s'', v) = eval (e, s) val l = gensym "loc" val s' = fn x => if x=l then v else s'' x in (s', Loc l) end | eval (Deref e, s) = let val (s', Loc l) = eval (e, s) in (s', s' l) end | eval (Assign (e1, e2), s) = let val (s1, Loc l) = eval (e1, s) val (s2, v) = eval (e2, s1) val s3 = fn x => if x=l then v else s2 x in (s3, Unit) end | eval (If (e, e1, e2), s) = let val (s', Bool b) = eval (e, s) in eval (if b then e1 else e2, s') end | eval (Opn (e1, Lte, e2), s) = let val (s1, Int i1) = eval (e1, s) val (s2, Int i2) = eval (e2, s1) in (s2, Bool (i1 <= i2)) end | eval (Opn (e1, oper, e2), s) = let val (s1, Int i1) = eval (e1, s) val (s2, Int i2) = eval (e2, s1) in (s2, Int ((evalop oper) (i1, i2))) end (********************************** PART 2 **********************************) (* Compiles iexps into exps. *) fun ce (Bool_i b) = Val (Bool b) | ce (Int_i i) = Val (Int i) | ce (Opn_i (e1, oper, e2)) = Opn (ce e1, oper, ce e2) | ce (Var_i x) = Deref (Var x) | ce (Addr_i x) = Var x | ce (Deref_i e) = Deref (ce e) (* Compiles iexps into exps for use on the LHS of assignments. *) fun cle (Var_i x) = Var x | cle (Deref_i e) = Deref (cle e) | cle _ = raise Fail "invalid LHS expression" (* Compiles a list of variable initializers. *) (* Equivalent to "let C[[vars]] in e". *) fun cvars (vars : (var * iexp) list, e : exp) : exp = let (* Updates the given body to include the given variable initialization. *) fun cvar ((x : var, e : iexp), body : exp) : exp = App (Val (Fn (x, body)), Ref (ce e)) in foldr cvar e vars end fun cc ({ vars=v, main=c } : iprog) : exp = let val e = case c of Skip_i => Val Unit | Seq_i (s1, s2) => (* (\u. C[[s2]]) C[[s1]] *) App (Val (Fn (gensym "u", cc {vars=[], main=s2})), cc {vars=[], main=s1}) | If_i (e, c1, c2) => (* if E[[e]] then C[[c1]] else C[[c2]] *) If (ce e, cc {vars=[], main=c1}, cc {vars=[], main=c2}) | Assign_i (e1, e2) => (* E_{LHS}[[e1]] := E[[e2]] *) Assign (cle e1, ce e2) | While_i (e, body) => (* Define Y = \f. (\x. f (\u. x x)) (\x. f (\u. x x)). *) (* This is the call-by-value version of the Y combinator. *) (* Note that Y F = F (\u. Y F). *) (* Translate the while loop to: *) (* Y (\f. if E[[e]] then (\u. f u) C[[body]] else unit) *) let val f = gensym "f" val u = gensym "u" val x = gensym "x" val y = gensym "y" val subY = Val (Fn (x, App (Var f, Val (Fn (y, App (Var x, Var x)))))) val Y = Val (Fn (f, App (subY, subY))) val F = Val (Fn (f, If (ce e, App (Val (Fn (u, App (Var f, Val Unit))), cc {vars=[], main=body}), Val Unit))) in App (Y, F) end in cvars (v, e) end val foo = cc ({ vars=[("x", Int_i 3), ("y", Addr_i "x"), ("z", Addr_i "y")], main=Seq_i (Assign_i (Deref_i (Var_i "y"), Opn_i (Deref_i (Var_i "y"), Plus, Int_i 1)), Assign_i (Deref_i (Deref_i (Var_i "z")), Opn_i (Deref_i (Deref_i (Var_i "z")), Plus, Int_i 1))) }) val goo = cc ({ vars=[("x", Int_i 0)], main=While_i (Opn_i (Var_i "x", Lte, Int_i 41), Assign_i (Var_i "x", Opn_i (Var_i "x", Plus, Int_i 1))) })