(*
** CAS CS525, Spring 2011
** Instructor: Hongwei Xi
*)

(* ****** ****** *)

staload
_(*anon*) = "prelude/DATS/reference.dats"

(* ****** ****** *)

staload "symbol.sats"
staload _(*anon*) = "symbol.dats"

staload "trans1_tc.sats"

(* ****** ****** *)

staload "trans2.sats"

(* ****** ****** *)

#define nil list0_nil
#define cons list0_cons
#define :: list0_cons

#define Some option0_some
#define None option0_none

(* ****** ****** *)

val valprim_void = VPtup (list0_nil)

fun instr_add (
  res: &instrlst, x: instr
) : void = res := list0_cons (x, res)

(* ****** ****** *)

local

extern
castfn valprim_encode (x: valprim): valprim_t
extern
castfn valprim_decode (x: valprim_t): valprim

in // in of [local]

fun v1ar_get_val
  (x: v1ar): valprim = let
  val r = x.v1ar_val
in
  case+ !r of
  | Some vp => valprim_decode (vp)
  | None () => valprim_void // HX: raising an exception?
end // end of [v1ar_get_val]

fun v1ar_initset_val (
  x: v1ar, vp: valprim
) : void = let
  val r = x.v1ar_val
  val vp = valprim_encode (vp)
  val () = !r := option0_some (vp)
in
  // nothing
end // [v1ar_set_val]

end // end of [local]

(* ****** ****** *)

local
typedef funlab = '{
  funlab_name= symbol, funlab_stamp= int
}
assume funlab_t = funlab

val the_funlab_stamp = ref<int> (0)

in // in of [local]

implement
funlab_new () = let
  val n = !the_funlab_stamp
  val () = !the_funlab_stamp := n + 1
  val name = sprintf ("$%s%i", @("foo", n))
  val name = string_of_strptr (name)
  val sym = symbol_make_name (name)
in '{
  funlab_name= sym, funlab_stamp = n
} end // end of [funlab_new]

implement
funlab_get_symbol (x) = x.funlab_name

implement
fprint_funlab (out, x) = fprint_symbol (out, x.funlab_name)

end // end of [local]

(* ****** ****** *)

local

typedef funent = '{
  funent_lab= funlab_t
, funent_narg= int
, funent_body= instrlst
, funent_ret= valprim
}
assume funent_t = funent

in // in of [local]

implement funent_get_lab (x) = x.funent_lab
implement funent_get_narg (x) = x.funent_narg
implement funent_get_body (x) = x.funent_body
implement funent_get_ret (x) = x.funent_ret

end // end of [local]

(* ****** ****** *)

local

typedef funent_map = symenv_t (funent)
val the_funent_map = ref<funent_map> (symenv_make<funent> ())

in // in of [local]

implement
funent_add (x) = {
  val l = funent_get_lab (x)
  val s = funlab_get_symbol (l)
  val map = !the_funent_map
  val map = symenv_insert<funent> (map, s, x)
  val () = !the_funent_map := map
} // end of [funent_add]

end // end of [local]

(* ****** ****** *)

extern
fun aux_exp (e: e1xp, res: &instrlst): valprim

(* ****** ****** *)

fun aux_exp_fix (
  e: e1xp, res: &instrlst
) : valprim = let
  val- E1XPfix (f, xs_arg, e_body) = e.e1xp_node
  val fl = funlab_new ()
  val vp_fun = VPfun (fl)
  val () = v1ar_initset_val (f, vp_fun)
  val narg = loop (xs_arg, 0) where {
    fun loop (xs: v1arlst, n: int): int =
      case+ xs of
      | cons (x, xs) => let
          val vp = VParg (n)
          val () = v1ar_initset_val (x, vp)
        in
          loop (xs, n+1)
        end // end of [cons]
      | nil () => n
    // end of [loop]
  } // end of [val]
  var res: instrlst = nil
  val vp_ret = aux_exp (e_body, res)
  val ent = funent_make (fl, narg, res, vp_ret)
  val () = funent_add (ent)
in
  VPfun (fl)
end // end of [aux_exp_fix]

fun aux_exp_lam (
  e: e1xp, res: &instrlst
) : valprim = let
  val- E1XPlam (xs_arg, e_body) = e.e1xp_node
  val fl = funlab_new ()
  val narg = loop (xs_arg, 0) where {
    fun loop (xs: v1arlst, n: int): int =
      case+ xs of
      | cons (x, xs) => let
          val vp = VParg (n)
          val () = v1ar_initset_val (x, vp)
        in
          loop (xs, n+1)
        end
      | nil () => n
    // end of [loop]
  } // end of [val]
  var res: instrlst = nil
  val vp_ret = aux_exp (e_body, res)
  val res = list0_reverse (res)
  val ent = funent_make (fl, narg, res, vp_ret)
  val () = funent_add (ent)
in
  VPfun (fl)
end // end of [aux_exp_lam]

(* ****** ****** *)

fun aux_explst (
  es: e1xplst, res: &instrlst
) : valprimlst = case+ es of
  | list0_cons (e, es) => let
      val v = aux_exp (e, res)
      val vs = aux_explst (es, res)
    in
      list0_cons (v, vs)
    end // end of [list0_cons]
  | list0_nil () => list0_nil ()
// end of [aux_explst]

(* ****** ****** *)

implement
aux_exp (e0, res) =
  case- e0.e1xp_node of
  | E1XPann (e, _) => aux_exp (e, res)
  | E1XPbool b => VPbool (b)
  | E1XPint i => VPint (i)
  | E1XPstr s => VPstr (s)
// end of [aux_exp]

(* ****** ****** *)

(*
trans2_exp (e: e1xp): (instrlst, valprim)
*)
implement
trans2_exp (e) = let
  var res: instrlst = list0_nil
  val vp = aux_exp (e, res)
  val res = list0_reverse (res)
in
  (res, vp)
end // end of [trans2_exp]

(* ****** ****** *)

(* end of [trans2.dats] *)