(*

  Although we've eliminated the interesting nested and recursive
  calls, we're still relying on ML's argument-passing implementation.

  Let's suppose that our interpreter can't pass arguments with `goto'.
  Instead, we define a few registers and use them for arguments.

*)

(* No change to the types *)

type xvar = string

type xval = Num of int
          | Fun of cxpr * xenv

 and xenv = Empty
          | Extend of xval * xenv

 and xpr = Const of int
         | Minus of xpr * xpr
         | Times of xpr * xpr
         | Lam of xvar * xpr
         | Var of xvar
         | App of xpr * xpr
         | IfZero of xpr * xpr * xpr

 and cxpr = CConst of int
          | CMinus of cxpr * cxpr
          | CTimes of cxpr * cxpr
          | CLam of cxpr
          | CVar of int
          | CApp of cxpr * cxpr
          | CIfZero of cxpr * cxpr * cxpr

 and kont = Done
          | KSubArg of cxpr * xenv * kont
          | KMultArg of cxpr * xenv * kont
          | KSub of xval * kont
          | KMult of xval * kont
          | KAppArg of cxpr * xenv * kont
          | KApp of xval * kont
          | KIfZero of cxpr * cxpr * xenv * kont

type cenv = CEmpty
          | CExtend of xvar * cenv

;;

(* The examples are unchanged *)

let five = Const(5)
let protofac = Lam("f",
		   Lam("n",
		       IfZero(Var("n"),
			      Const(1),
			      Times(Var("n"),
				    App(App(Var("f"), Var("f")),
				        Minus(Var("n"),
					      Const(1)))))))
let fac = App(protofac, protofac)
let onetwenty = App(fac, five)

;;

(* The compiler is unchanged *)

let rec
comp = function (Const(v), e) -> CConst(v)
              | (Minus(m1, m2), e) -> CMinus(comp(m1, e), comp(m2, e))
              | (Times(m1, m2), e) -> CTimes(comp(m1, e), comp(m2, e))
              | (Lam(var, m), e) -> CLam(comp(m, CExtend(var, e)))
              | (App(m1, m2), e) -> CApp(comp(m1, e), comp(m2, e))
              | (IfZero(m1, m2, m3), e) -> CIfZero(comp(m1, e), comp(m2, e), comp(m3, e))
              | (Var(var), e) -> CVar(offset(var, e))

and
offset = fun (var, CExtend(var2, e)) -> if (var = var2) 
					   then 0 
					   else (1 + offset(var, e))

;;

(* The interpreter now uses the following mutable reference cells as
   registers for passing arguments: *)

let mReg = ref (CConst 0)
and eReg = ref Empty
and kReg = ref Done
and vReg = ref (Num 0)

;;

(* Now, the recursive calls really *are* `goto', since there are no
   arguments in the call. *)

let rec
eval = function unit ->
   match (!mReg, !eReg, !kReg) with
      (CConst(v), e, k) -> vReg := Num(v); kontinue()
    | (CMinus(m1, m2), e, k) -> mReg := m1; kReg := KSubArg(m2, e, k); eval()
    | (CTimes(m1, m2), e, k) -> mReg := m1; kReg := KMultArg(m2, e, k); eval()
    | (CLam(m), e, k) -> vReg := Fun(m, e); kontinue()
    | (CApp(m1, m2), e, k) -> mReg := m1; kReg := KAppArg(m2, e, k); eval()
    | (CIfZero(m1, m2, m3), e, k) -> mReg := m1; kReg := KIfZero(m2, m3, e, k); eval()
    | (CVar(n), e, k) -> vReg := lookup(n, e); kontinue()

and
kontinue = function unit ->
   match (!vReg, !kReg) with
     (v, KSubArg(m, e, k)) -> mReg := m; eReg := e; kReg := KSub(v, k); eval()
   | (v, KMultArg(m, e, k)) -> mReg := m; eReg := e; kReg := KMult(v, k); eval()
   | (Num(n2), KSub(Num(n1), k)) -> vReg := Num(n1 - n2); kReg := k; kontinue()
   | (Num(n2), KMult(Num(n1), k)) -> vReg := Num(n1 * n2); kReg := k; kontinue()
   | (v, KAppArg(m, e, k)) -> mReg := m; eReg := e; kReg := KApp(v, k); eval()
   | (v, KApp(Fun(m, e), k)) -> mReg := m; eReg := Extend(v, e); kReg := k; eval()
   | (Num(n), KIfZero(m2, m3, e, k)) -> mReg := (if (n=0) then m2 else m3);
                                        eReg := e; kReg := k; eval()
   | (v, Done) -> v

and
lookup = function (0, Extend(v, e)) -> v
                | (n, Extend(v, e)) -> lookup(n-1, e)

;;

mReg := comp(onetwenty,CEmpty);
eReg := Empty;
kReg := Done;
eval()

;;