Updating: improving ATS-parse-emit

Updating: improving ATS-parse-emit

(* ****** ****** *)
//
// ATS-parse-emit-python
//
(* ****** ****** *)
//
// HX-2014-08-04: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./atsparemit.sats"
staload "./atsparemit_syntax.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_typedef.dats"
//
(* ****** ****** *)
extern
fun
the_statmpdeclst_get (): d0eclist
extern
fun
the_statmpdeclst_insert (d0ecl): void
//
(* ****** ****** *)

local
//
val the_statmps =
  ref<d0eclist> (list_nil(*void*))
//
in (* in-of-local *)
//
implement
the_statmpdeclst_get () =
  list_vt2t(list_reverse(!the_statmps))
//
implement
the_statmpdeclst_insert (d0c) = let
  val d0cs = !the_statmps in !the_statmps := list_cons (d0c, d0cs)
end // end of [the_statmpdeclst_insert]
//
end // end of [local]

(* ****** ****** *)
//
extern
fun
emit_the_statmpdeclst
  (out: FILEref, ind: int): void
//
implement
emit_the_statmpdeclst
  (out, ind) = let
//
fun auxlst
(
  out: FILEref, xs: d0eclist
) : void =
(
case+ xs of
| list_nil () => ()
| list_cons (x, xs) => let
    val-D0Cstatmp (tmp, opt) = x.d0ecl_node
  in
    case+ opt of
    | None _ => auxlst (out, xs)
    | Some _ => let
        val () = emit_ENDL (out)
        val () = emit_nspc (out, ind)
        val () =
        (
          emit_text (out, "global "); emit_tmpvar (out, tmp)
        ) (* end of [val] *)
      in
        auxlst (out, xs)
      end // end of [Some]
  end // end of [list_cons]
) (* end of [auxlst] *)
//
in
  auxlst (out, the_statmpdeclst_get ())
end // end of [emit_the_statmpdeclst]
//
(* ****** ****** *)
//
extern
fun
emit_f0arglst_nonlocal
  (out: FILEref, f0as: f0arglst): void
//
implement
emit_f0arglst_nonlocal
  (out, f0as) = let
//
fun auxlst
(
  out: FILEref, f0as: f0arglst, i: int
) : void =
(
case+ f0as of
| list_nil () => ()
| list_cons (f0a, f0as) =>
  (
    case- f0a.f0arg_node of
    | F0ARGsome (arg, _) => let
        val () =
        if i > 0
          then emit_text (out, ", ")
        // end of [if]
        val () = emit_tmpvar (out, arg)
      in
        auxlst (out, f0as, i+1)
      end // end of [F0ARGsome]
  ) (* end of [list_cons] *)
)
//
in
//
case+ f0as of
| list_nil () => ()
| list_cons _ =>
  {
    val () =
    emit_nspc (out, 4(*ind*))
    val () =
    emit_text (out, "nonlocal ")
    val () = auxlst (out, f0as, 0(*i*))
    val () = emit_ENDL (out)
  }
//
end // end of [emit_f0arglst_nonlocal]
//
(* ****** ****** *)
//
extern
fun
emit_tmpdeclst_initize
  (out: FILEref, tds: tmpdeclst): void
//
implement
emit_tmpdeclst_initize
  (out, tds) = let
//
fun auxlst
(
  out: FILEref, tds: tmpdeclst
) : void =
(
case+ tds of
| list_nil () => ()
| list_cons (td, tds) =>
  (
    case+ td.tmpdec_node of
    | TMPDECnone
        (tmp) => auxlst (out, tds)
    | TMPDECsome
        (tmp, _) => let
        val () = emit_nspc (out, 2(*ind*))
        val () = emit_tmpvar (out, tmp)
        val () = emit_text (out, " = None\n")
      in
        auxlst (out, tds)
      end // end of [TMPDECsome]
  ) (* end of [list_cons] *)
)
//
in
  auxlst (out, tds)
end // end of [emit_tmpdeclst_initize]
//
(* ****** ****** *)
//
extern
fun
emit_tmpdeclst_nonlocal
  (out: FILEref, tds: tmpdeclst): void
//
implement
emit_tmpdeclst_nonlocal
  (out, tds) = let
//
fun auxlst
(
  out: FILEref, tds: tmpdeclst, i: int
) : void =
(
case+ tds of
| list_nil () => ()
| list_cons (td, tds) =>
  (
    case+ td.tmpdec_node of
    | TMPDECnone
        (tmp) => auxlst (out, tds, i)
    | TMPDECsome
        (tmp, _) => let
        val () =
        if i > 0 then
          emit_text (out, ", ")
        // end of [if]
        val () = emit_tmpvar (out, tmp)
      in
        auxlst (out, tds, i+1)
      end // end of [TMPDECsome]
  ) (* end of [list_cons] *)
)
//
in
//
case+ tds of
| list_nil () => ()
| list_cons _ =>
  {
    val () =
    emit_nspc (out, 4(*ind*))
    val () =
    emit_text (out, "nonlocal")
    val () = emit_SPACE (out)
    val () = auxlst (out, tds, 0)
    val () = emit_newline (out)
  } (* end of [list_cons] *)
//
end // end of [emit_tmpdeclst_nonlocal]
//
(* ****** ****** *)
//
extern
fun
emit_mbranchlst_initize
  (out: FILEref, inss: instrlst): void
//
implement
emit_mbranchlst_initize
  (out, inss) = let
//
fun auxlst
(
  out: FILEref, inss: instrlst, i: int
) : void =
(
//
case+ inss of
| list_nil () => ()
| list_cons (_, inss) =>
  {
    val () =
      emit_nspc (out, 2(*ind*))
    val () =
    (
      emit_text (out, "mbranch_"); emit_int (out, i); emit_text (out, " = None\n")
    )
    val () = auxlst (out, inss, i+1)
  }
//
) (* end of [auxlst] *)
//
in
  auxlst (out, inss, 1(*i*))
end // end of [emit_mbranchlst_initize]
//
(* ****** ****** *)
//
extern
fun
emit_mbranchlst_nonlocal
  (out: FILEref, inss: instrlst): void
//
implement
emit_mbranchlst_nonlocal
  (out, inss) = let
//
fun auxlst
(
  out: FILEref, inss: instrlst, i: int
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons (_, inss) => let
    val () =
      if i >= 2 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "mbranch_"); emit_int (out, i)
    )
  in
    auxlst (out, inss, i+1)
  end // end of [list_cons]
//
) (* end of [auxlst] *)
//
in
//
case+ inss of
| list_nil () => ()
| list_cons _ =>
  {
    val () =
    emit_nspc (out, 4(*ind*))
    val () =
    emit_text (out, "nonlocal ")
    val () = auxlst (out, inss, 1(*i*))
    val () = emit_ENDL (out)
  } (* end of [list_cons] *)
//
end // end of [emit_mbranchlst_nonlocal]
//
(* ****** ****** *)
//
extern
fun
funlab_get_index (fl: label): int
extern
fun
tmplab_get_index (lab: label): int
//
(* ****** ****** *)
//
extern
fun
the_f0arglst_get (): f0arglst
extern
fun
the_f0arglst_set (f0as: f0arglst): void
//
(* ****** ****** *)
//
extern
fun
the_tmpdeclst_get (): tmpdeclst
extern
fun
the_tmpdeclst_set (tds: tmpdeclst): void
//
(* ****** ****** *)
//
extern
fun
the_funbodylst_get (): instrlst
extern
fun
the_funbodylst_set (inss: instrlst): void
//
(* ****** ****** *)
//
extern
fun
the_branchlablst_get (): labelist
extern
fun
the_branchlablst_set (tls: labelist): void
//
(* ****** ****** *)
//
extern
fun
the_caseofseqlst_get (): instrlst
extern
fun
the_caseofseqlst_set (inss: instrlst): void
//
(* ****** ****** *)

local
//
val the_f0arglst = ref<f0arglst> (list_nil)
val the_tmpdeclst = ref<tmpdeclst> (list_nil)
//
val the_funbodylst = ref<instrlst> (list_nil)
//
val the_branchlablst = ref<labelist> (list_nil)
val the_caseofseqlst = ref<instrlst> (list_nil)
//
in (* in-of-local *)

implement
the_f0arglst_get () = !the_f0arglst
implement
the_f0arglst_set (xs) = !the_f0arglst := xs

implement
the_tmpdeclst_get () = !the_tmpdeclst
implement
the_tmpdeclst_set (xs) = !the_tmpdeclst := xs

implement
the_funbodylst_get () = !the_funbodylst
implement
the_funbodylst_set (xs) = !the_funbodylst := xs

implement
the_branchlablst_get () = !the_branchlablst
implement
the_branchlablst_set (tls) = !the_branchlablst := tls

implement
the_caseofseqlst_get () = !the_caseofseqlst
implement
the_caseofseqlst_set (xs) = !the_caseofseqlst := xs

end // end of [local]

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

implement
funlab_get_index
  (fl0) = let
//
val n0 = fl0.i0de_sym
//
fun
auxlst
(
  xs: instrlst, i: int
) : int = (
//
case+ xs of
| list_nil () => ~1(*error*)
| list_cons (x, xs) =>
  (
    case+ x.instr_node of
    | ATSfunbodyseq _ => let
        val fl = funbodyseq_get_funlab (x)
      in
        if n0 = fl.i0de_sym then i else auxlst (xs, i+1)
      end // end of [ATSfunbodyseq]
    | _ (*non-ATSfunbody*) => auxlst (xs, i)
  ) (* end of [list_cons] *)
//
) (* end of [auxlst] *)
//
in
  auxlst (the_funbodylst_get(), 1)
end // end of [funlab_get_index]

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

implement
tmplab_get_index
  (lab0) = let
//
val n0 = lab0.i0de_sym
//
fun
auxlst
(
  xs: labelist, i: int
) : int =
(
case+ xs of
| list_nil () => ~1(*error*)
| list_cons (x, xs) =>
    if n0 = x.i0de_sym then i else auxlst (xs, i+1)
  // end of [list_cons]
)
//
in
  auxlst (the_branchlablst_get(), 1)
end // end of [tmplab_get_index]

(* ****** ****** *)
//
fun
emit_funlab_index
 (out: FILEref, fl: label): void =
 emit_int (out, funlab_get_index (fl))
//
fun
emit_tmplab_index
 (out: FILEref, lab: label): void =
 emit_int (out, tmplab_get_index (lab))
//
(* ****** ****** *)

extern
fun
branchmap_get_index (ins: instr): int
//
implement
branchmap_get_index
  (x0) = let
//
val p0 = $UN.cast2ptr (x0)
//
fun auxlst
(
  xs: instrlst, i: int
) : int =
(
case xs of
| list_nil () => ~1(*error*)
| list_cons (x, xs) =>
    if $UN.cast2ptr(x) = p0 then i else auxlst (xs, i+1)
  // end of [list_cons]
)
//
in
  auxlst (the_caseofseqlst_get (), 1)
end // end of [branchmap_get_index]

(* ****** ****** *)
//
fun
emit_branchmap_index
 (out: FILEref, ins: instr): void =
 emit_int (out, branchmap_get_index (ins))
//
(* ****** ****** *)
//
fun
emit_branchmap
(
  out: FILEref, ins0: instr
) : void = let
//
fun auxlst
(
  out: FILEref, xs: instrlst, i: int
) : int =
(
case+ xs of
| list_nil () => i
| list_cons (x, xs) =>
  (
    case+ x.instr_node of
    | ATSINSlab (lab) => let
        val ((*void*)) =
          if i >= 2 then emit_text (out, ", ")
        // end of [val]
        val () = emit_int (out, i)
        val () = emit_text (out, ": ")
        val () = emit_label (out, lab)
      in
        auxlst (out, xs, i+1)
      end // end of [ATSINSlab]
    | _(*non-ATSINSlab*) => auxlst (out, xs, i)
  )
) (* end of [auxlst] *)
//
fun auxlst2
(
  out: FILEref, xs: instrlst, i: int
) : void =
(
case+ xs of
| list_nil () => ()
| list_cons (x, xs) => let
    val-ATSbranchseq(inss) = x.instr_node
  in
    auxlst2 (out, xs, auxlst (out, inss, i))
  end // end of [list_cons]
) (* end of [auxlst2] *)
//
val-ATScaseofseq(inss) = ins0.instr_node
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "mbranch_")
val () = emit_branchmap_index (out, ins0)
val () = emit_text (out, " = ")
val ((*opening*)) = emit_text (out, "{ ")
val () = auxlst2 (out, inss, 1(*first*))
val ((*closing*)) = emit_text (out, " }\n")
//
in
  // nothing
end // end of [emit_branchmap]
//
(* ****** ****** *)

fun
emit_branchmaplst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons (ins, inss) =>
  {
    val () = emit_branchmap (out, ins)
    val () = emit_branchmaplst (out, inss)
  }
) (* end of [emit_branchmaplst] *)

(* ****** ****** *)
//
extern
fun
f0body_collect_caseof
  (fbody: f0body): instrlst(*list-of-caseofseq*)
//
extern
fun
instrlst_collect_caseof
  (inss: instrlst): instrlst(*list-of-caseofseq*)
//
(* ****** ****** *)
//
implement
f0body_collect_caseof
  (fbody) = let
in
//
case+
fbody.f0body_node of
| F0BODY (tds, inss) => instrlst_collect_caseof (inss)
//
end // end of [f0body_collect_caseof]
//
implement
instrlst_collect_caseof
  (inss) = let
//
vtypedef res = instrlst_vt
//
fun
aux
(
  ins: instr, res: res
) : res =
(
case+
ins.instr_node of
//
| ATScaseofseq
    (inss) => (
    auxlst (inss, cons_vt (ins, res))
  ) (* end of [ATScaseofseq] *)
| ATSbranchseq (inss) => auxlst (inss, res)
| ATSfunbodyseq (inss) => auxlst (inss, res)
| _ (*rest-of-instr*) => res
//
) (* end of [aux] *)
//
and
auxlst
(
  inss: instrlst, res: res
) : res =
(
case+ inss of
| list_cons
    (ins, inss) => let
    val res = aux (ins, res) in auxlst (inss, res)
  end // end of [list_cons]
| list_nil ((*void*)) => res
)
//
val res = auxlst (inss, list_vt_nil)
//
in
  list_vt2t(list_vt_reverse(res))
end // end of [instrlst_collect_caseof]
//
(* ****** ****** *)
//
extern
fun emit2_instr
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_instr_ln
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_instr_newline
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_instrlst
  (out: FILEref, ind: int, inss: instrlst) : void
//
(* ****** ****** *)
//
extern
fun emit2_ATSfunbodyseq
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_ATSINSmove_con1
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_ATSINSmove_boxrec
  (out: FILEref, ind: int, ins: instr) : void
//
(* ****** ****** *)
//
// HX-2014-08:
// this one should not be used for
// emitting multiple-line instructions
//
implement
emit_instr
  (out, ins) = emit2_instr (out, 0(*ind*), ins)
//
(* ****** ****** *)
//
implement
emit2_instr
  (out, ind, ins0) = let
in
//
case+
ins0.instr_node of
//
| ATSif
  (
    d0e, inss, inssopt
  ) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if ")
    val () = emit_LPAREN (out)
    val () = emit_d0exp (out, d0e)
    val () = emit_RPAREN (out)
    val () = emit_text (out, ":\n")
    val () = emit2_instrlst (out, ind+2, inss)
    val () =
    (
      case+ inssopt of
      | Some(inss) =>
        {
          val () = emit_nspc (out, ind)
          val () = emit_text (out, "else:\n")
          val () = emit2_instrlst (out, ind+2, inss)
        }
      | None((*void*)) => ()
    )
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#endif")
  } (* end of [ATSif] *)
//
| ATSifthen (d0e, inss) =>
  {
//
    val-list_cons (ins, _) = inss
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if(")
    val () = emit_d0exp (out, d0e)
    val ((*closing*)) = emit_text (out, "): ")
    val () = emit_instr (out, ins)
  }
| ATSifnthen (d0e, inss) =>
  {
//
    val-list_cons (ins, _) = inss
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if not(")
    val () = emit_d0exp (out, d0e)
    val ((*closing*)) = emit_text (out, "): ")
    val () = emit_instr (out, ins)
  }
//
| ATSbranchseq (inss) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSbranch")
  }
//
| ATScaseofseq (inss) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATScaseofseq_beg")
    val () = emit_ENDL (out)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "tmplab_py = 1\n")
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "while(1):\n")
    val () = emit_nspc (out, ind+2)
    val () = emit_text (out, "mbranch_")
    val () = emit_branchmap_index (out, ins0)
    val () = emit_text (out, ".get(tmplab_py)()\n")
    val () = emit_nspc (out, ind+2)
    val () = emit_text (out, "if (tmplab_py == 0): break\n")
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATScaseofseq_end")
  }
//
| ATSreturn (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "return ")
    val () = emit_tmpvar (out, tmp)
  }
| ATSreturn_void (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "return#_void")
  }
//
| ATSlinepragma (line, file) =>
  {
    val () = emit_text (out, "#line ")
    val () = emit_PMVint (out, line)
    val () = emit_SPACE (out)
    val () = emit_PMVstring (out, file)
  }
//
| ATSINSlab (lab) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#")
    val () = emit_label (out, lab)
  }
| ATSINSgoto (lab) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "tmplab_py = ")
    val () = emit_tmplab_index (out, lab)
    val () =
    (
      emit_SPACE (out);
      emit_text (out, "; return");
      emit_SHARP (out); emit_label (out, lab)
    ) (* end of [val] *)
  }
//
| ATSINSflab (flab) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_SHARP (out)
    val () = emit_label (out, flab)
  }
| ATSINSfgoto (flab) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "funlab_py = ")
    val () = emit_funlab_index (out, flab)
    val () =
    (
      emit_SPACE (out); emit_SHARP (out); emit_label (out, flab)
    ) (* end of [val] *)
  }
//
| ATSINSmove (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e)
  } (* end of [ATSINSmove] *)
//
| ATSINSmove_void (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      case+ d0e.d0exp_node of
      | ATSempty _ =>
          emit_text (out, "None#ATSINSmove_void")
        // end of [ATSempty]
      | _ (*non-ATSempty*) => emit_d0exp (out, d0e)
    ) : void // end of [val]
  } (* end of [ATSINSmove_void] *)
//
| ATSINSmove_nil (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_text (out, "None")
  }
//
| ATSINSmove_con0 (tmp, tag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_PMVint (out, tag)
  }
//
| ATSINSmove_con1 _ =>
    emit2_ATSINSmove_con1 (out, ind, ins0)
//
| ATSINSmove_boxrec _ =>
    emit2_ATSINSmove_boxrec (out, ind, ins0)
//
| ATStailcalseq (inss) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATStailcalseq_beg")
    val () = emit_ENDL (out)
    val () = emit2_instrlst (out, ind, inss)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATStailcalseq_end")

  } (* end of [ATStailcalseq] *)
//
| ATSINSmove_tlcal (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e)
  } (* end of [ATSINSmove_tlcal] *)
//
| ATSINSargmove_tlcal (tmp1, tmp2) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp1)
    val () = emit_text (out, " = ")
    val () = emit_tmpvar (out, tmp2)
  } (* end of [ATSINSargmove_tlcal] *)
//
| ATSINSextvar_assign (ext, d0e_r) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_d0exp (out, ext)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e_r)
    val () = emit_SEMICOLON (out)
  }
| ATSINSdyncst_valbind (d2c, d0e_r) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_i0de (out, d2c)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e_r)
    val () = emit_SEMICOLON (out)
  }
//
| ATSdynload (dummy) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSdynload()")
    val () = emit_the_statmpdeclst (out, ind)
  }
//
| ATSdynloadset (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSdynloadset\n")
    val () = (
      emit_nspc (out, ind); emit_tmpvar (out, flag); emit_text (out, " = 1")
    ) (* end of [val] *)
  }
//
| ATSdynloadflag_sta (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSdynloadflag_sta\n")
    val () = emit_nspc (out, ind)
    val () = (
      emit_text (out, "global "); emit_tmpvar (out, flag)
    ) (* end of [val] *)
  }
//
| ATSdynloadflag_ext (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSdynloadflag_ext\n")
    val () = emit_nspc (out, ind)
    val () = (
      emit_text (out, "global "); emit_tmpvar (out, flag)
    ) (* end of [val] *)
  }
//
| _ (*rest-of-instr*) =>
  {
    val () = emit_nspc (out, ind)
    val ((*error*)) = fprint! (out, "UNRECOGNIZED-INSTRUCTION: ", ins0)
  }
//
end // end of [emit2_instr]

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

implement
emit2_instr_ln
  (out, ind, ins) =
(
  emit2_instr (out, ind, ins); emit_ENDL (out)
) (* end of [emit2_instr_ln] *)

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

implement
emit2_instr_newline
  (out, ind, ins) =
(
  emit2_instr (out, ind, ins); emit_newline (out)
) (* end of [emit2_instr_newline] *)

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

implement
emit2_instrlst
(
  out, ind, inss
) = (
//
case+ inss of
| list_nil () => ()
| list_cons
    (ins, inss) => let
    val () = emit2_instr (out, ind, ins)
  in
    emit_ENDL (out); emit2_instrlst (out, ind, inss)
  end // end of [list_cons]
//
) (* end of [emit2_instrlst] *)

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

implement
emit2_ATSfunbodyseq
  (out, ind, ins) = let
//
val-ATSfunbodyseq (inss) = ins.instr_node
//
in
  emit2_instrlst (out, ind, inss)
end // end of [emit2_ATS2funbodyseq]

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

implement
emit2_ATSINSmove_con1
  (out, ind, ins0) = let
//
fun
getarglst
(
  inss: instrlst
) : d0explst =
(
case+ inss of
| list_nil () => list_nil ()
| list_cons (ins, inss) => let
    val-ATSINSstore_con1_ofs (_, _, _, d0e) = ins.instr_node
    val d0es = getarglst (inss)
  in
    list_cons (d0e, d0es)
  end // end of [list_cons]
)
//
val-ATSINSmove_con1 (inss) = ins0.instr_node
//
val-list_cons (ins, inss) = inss
val-ATSINSmove_con1_new (tmp, _) = ins.instr_node
//
var opt: tokenopt = None()
//
val inss =
(
case+ inss of
| list_nil () => inss
| list_cons (ins, inss2) =>
  (
    case+ ins.instr_node of
    | ATSINSstore_con1_tag
        (tmp, tag) => let
        val () = opt := Some(tag) in inss2
      end // end of [ATSINSstore_con1_tag]
    | _ (*non-ATSINSstore_con1_tag*) => inss
  )
) : instrlst
//
val d0es = getarglst (inss)
val () = emit_nspc (out, ind)
val () = emit_tmpvar (out, tmp)
val () = emit_text (out, " = ")
val () = emit_LPAREN (out)
val () =
(
case+ opt of
| None () => ()
| Some (tag) => emit_PMVint (out, tag)
) : void // end of [val]
val () =
(
case+ opt of
| None _ => emit_d0explst (out, d0es)
| Some _ => emit_d0explst_1 (out, d0es)
) : void // end of [val]
//
val () = emit_RPAREN (out)
//
in
  // nothing
end // end of [emit2_ATSINSmove_con1]

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

implement
emit2_ATSINSmove_boxrec
  (out, ind, ins0) = let
//
fun
getarglst
(
  inss: instrlst
) : d0explst =
(
case+ inss of
| list_nil () => list_nil ()
| list_cons (ins, inss) => let
    val-ATSINSstore_boxrec_ofs (_, _, _, d0e) = ins.instr_node
    val d0es = getarglst (inss)
  in
    list_cons (d0e, d0es)
  end // end of [list_cons]
)
//
val-ATSINSmove_boxrec (inss) = ins0.instr_node
//
val-list_cons (ins, inss) = inss
val-ATSINSmove_boxrec_new (tmp, _) = ins.instr_node
//
val d0es = getarglst (inss)
//
val () = emit_nspc (out, ind)
val () = emit_tmpvar (out, tmp)
val () = emit_text (out, " = ")
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es)
val () = emit_RPAREN (out)
//
in
  // nothing
end // end of [emit2_ATSINSmove_boxrec]

(* ****** ****** *)
//
#define
ATSEXTCODE_BEG "######\n#ATSextcode_beg()\n######"
#define
ATSEXTCODE_END "######\n#ATSextcode_end()\n######"
//
(* ****** ****** *)

implement
emit_d0ecl
  (out, d0c0) = let
in
//
case+
d0c0.d0ecl_node of
//
| D0Cinclude _ => ()
//
| D0Cifdef _ => ()
| D0Cifndef _ => ()
//
| D0Ctypedef (id, def) =>
    typedef_insert (id.i0de_sym, def)
//
| D0Cassume (id) =>
  {
    val () = emit_ENDL (out)
    val () =
      emit_text (out, "#ATSassume(")
    val () = (
      emit_i0de (out, id); emit_text (out, ")\n")
    ) (* end of [val] *)
  }
//
| D0Cdyncst_mac _ => ()
| D0Cdyncst_extfun _ => ()
//
| D0Cstatmp
    (tmp, opt) =>
  {
    val () = emit_ENDL (out)
    val () = the_statmpdeclst_insert (d0c0)
    val () = (
      case+ opt of
      | Some _ => () | None () => emit_text(out, "#")
    ) (* end of [val] *)
    val () = (
      emit_tmpvar (out, tmp); emit_text (out, " = None\n")
    ) (* end of [val] *)
  } (* end of [D0Cstatmp] *)
//
| D0Cextcode (toks) =>
  {
    val () = emit_ENDL (out)
    val () =
      emit_text (out, ATSEXTCODE_BEG)
    val () = emit_extcode (out, toks) // HX: verbatim output
    val () =
      emit_text (out, ATSEXTCODE_END)
    val ((*void*)) = emit_newline (out)
  } (* end of [D0Cextcode] *)
//
| D0Cfundecl
    (fk, f0d) => emit_f0decl (out, f0d)
//
| D0Cclosurerize
  (
    fl, env, arg, res
  ) => emit_closurerize (out, fl, env, arg, res)
//
| D0Cdynloadflag_init (flag) =>
  {
    val () = emit_ENDL (out)
    val () = (
      emit_tmpvar (out, flag); emit_text (out, " = 0\n")
    ) (* end of [val] *)
  }
//
end // end of [emit_d0ecl]

(* ****** ****** *)
//
extern
fun emit2_tmpdec
  (out: FILEref, ind: int, td: tmpdec) : void
extern
fun emit2_tmpdeclst
  (out: FILEref, ind: int, tds: tmpdeclst) : void
//
(* ****** ****** *)

implement
emit_tmpdec
  (out, td) = emit2_tmpdec (out, 0(*ind*), td)
//
implement
emit2_tmpdec
  (out, ind, td) = let
in
//
case+
td.tmpdec_node of
//
| TMPDECnone (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = (emit_SHARP (out); emit_tmpvar (out, tmp))
  }
| TMPDECsome (tmp, s0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = (emit_tmpvar (out, tmp); emit_text (out, " = None"))
  }
end // end of [emit2_tmpdec]
//
(* ****** ****** *)

implement
emit2_tmpdeclst
(
  out, ind, tds
) = (
//
case+ tds of
| list_nil () => ()
| list_cons (td, tds) =>
  {
    val () = emit2_tmpdec (out, ind, td)
    val () = emit_ENDL (out)
    val () = emit2_tmpdeclst (out, ind, tds)
  }
//
) (* end of [emit2_tmpdeclst] *)

(* ****** ****** *)
//
extern
fun
emit_branchseq
  (out: FILEref, ins0: instr): void
extern
fun
emit_branchseqlst
  (out: FILEref, inss: instrlst): void
//
extern
fun
emit_fundef_nonlocal (out: FILEref): void
//
(* ****** ****** *)

local

fun auxlst
(
  out: FILEref, inss: instrlst
) : void = let
//
val inss =
instrlst_skip_linepragma (inss)
//
val-list_cons (ins, inss) = inss
val-ATSINSlab (lab) = ins.instr_node
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "def")
val () = emit_SPACE (out)
val () = emit_label (out, lab)
val () = emit_text (out, "():\n")
//
val () = emit_fundef_nonlocal (out)
//
val () = emit_nspc (out, 4)
val () = emit_text (out, "tmplab_py = 0\n")
//
in
  auxlst2 (out, lab, inss)
end (* end of [auxlst] *)

and auxlst2
(
  out: FILEref, lab: label, inss: instrlst
) : void = let
in
//
case+ inss of
//
| list_nil ((*none*)) =>
  {
    val () = emit_nspc (out, 4)
    val () = emit_text (out, "return\n")
  } (* end of [list_nil] *)
//
| list_cons
    (ins1, inss2) =>
  (
    case ins1.instr_node of
    | ATSINSlab (lab) =>
      {
        val () = emit_nspc (out, 4)
        val () = emit_label (out, lab)
        val () = emit_text (out, "()\n")
        val () = emit_nspc (out, 4)
        val () = emit_text (out, "return\n")
        val () = auxlst (out, inss)
      }
    | _ (*non-ATSINSlab*) =>
      {
        val () = (
          emit2_instr (out, 4, ins1); emit_ENDL (out)
        ) (* end of [val] *)
        val () = auxlst2 (out, lab, inss2)
      } (* end of [non-ATSINSlab] *)
  ) (* end of [list_cons] *)
//
end // (* end of [auxlst2] *)

in (* in-of-local *)

implement
emit_branchseq
  (out, ins0) = let
//
val-ATSbranchseq (inss) = ins0.instr_node
//
in
  auxlst (out, inss)
end // end of [emit_branchseq]

end // end of [local]

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

fun
emit_branchseqlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons (ins, inss) =>
  {
    val () = emit_branchseq (out, ins)
    val () = emit_branchseqlst (out, inss)
  }
) (* end of [emit_branchseqlst] *)

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

implement
emit_fundef_nonlocal
  (out) = () where
{
//
val f0as = the_f0arglst_get ()
val () = emit_f0arglst_nonlocal (out, f0as)
//
val tmpdecs = the_tmpdeclst_get ()
val () = emit_tmpdeclst_nonlocal (out, tmpdecs)
//
val () =
emit_nspc (out, 4(*ind*))
val () =
emit_text (out, "nonlocal funlab_py, tmplab_py\n")
//
val inss_caseof = the_caseofseqlst_get ()
val () = emit_mbranchlst_nonlocal (out, inss_caseof)
//
} // end of [emit_fundef_nonlocal]

(* ****** ****** *)
//
extern
fun
emit_caseofseq
  (out: FILEref, ins0: instr): void
extern
fun
emit_caseofseqlst
  (out: FILEref, inss: instrlst): void
//
(* ****** ****** *)

fun
emit_caseofseq
(
  out: FILEref, ins0: instr
) : void = let
//
val-ATScaseofseq(inss) = ins0.instr_node
//
val tls = caseofseq_get_tmplablst (ins0)
val ((*update*)) = the_branchlablst_set (tls)
//
in
  emit_branchseqlst (out, inss)
end // end of [emit_caseofseq]

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

fun
emit_caseofseqlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons (ins, inss) =>
  {
    val () = emit_caseofseq (out, ins)
    val () = emit_caseofseqlst (out, inss)
  }
) (* end of [emit_caseofseqlst] *)

(* ****** ****** *)
//
extern
fun emit_f0arg : emit_type (f0arg)
extern
fun emit_f0marg : emit_type (f0marg)
extern
fun emit_f0head : emit_type (f0head)
//
extern
fun emit_f0body : emit_type (f0body)
extern
fun emit_f0body_0 : emit_type (f0body)
extern
fun emit_f0body_tlcal : emit_type (f0body)
extern
fun emit_f0body_tlcal2 : emit_type (f0body)
//
(* ****** ****** *)

implement
emit_f0arg
  (out, f0a) = let
in
//
case+
f0a.f0arg_node of
//
| F0ARGnone _ => emit_text (out, "__NONE__")
| F0ARGsome (arg, s0e) => emit_tmpvar (out, arg)
//
end // end of [emit_f0arg]

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

implement
emit_f0marg
  (out, f0ma) = let
//
fun
loop
(
  out: FILEref, f0as: f0arglst, i: int
) : void =
(
case+ f0as of
| list_nil () => ()
| list_cons (f0a, f0as) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_f0arg (out, f0a); loop (out, f0as, i+1)
  end // end of [list_cons]
)
//
in
  loop (out, f0ma.f0marg_node, 0)
end // end of [emit_f0marg]

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

implement
emit_f0head
  (out, fhd) = let
//
val f0as =
  f0head_get_f0arglst (fhd)
//
val () = the_f0arglst_set (f0as)
//
in
//
case+
fhd.f0head_node of
| F0HEAD
    (fid, f0ma, res) =>
  {
    val () = emit_tmpvar (out, fid)
    val () = emit_LPAREN (out)
    val () = emit_f0marg (out, f0ma)
    val () = emit_RPAREN (out)
    val () = emit_text (out, ":")
  }
//
end // end of [emit_f0head]

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

implement
emit_f0body
  (out, fbody) = let
//
val knd = f0body_classify (fbody)
(*
val () = println! ("emit_f0body: knd = ", knd)
*)
//
val tmpdecs =
  f0body_get_tmpdeclst (fbody)
val inss_body =
  f0body_get_bdinstrlst (fbody)
val inss_caseof =
  f0body_collect_caseof (fbody)
//
val () = the_tmpdeclst_set (tmpdecs)
val () = the_funbodylst_set (inss_body)
val () = the_caseofseqlst_set (inss_caseof)
//
val () = emit_tmpdeclst_initize (out, tmpdecs)
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "funlab_py = None\n")
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "tmplab_py = None\n")
//
val () = emit_mbranchlst_initize (out, inss_caseof)
//
val () = emit_caseofseqlst (out, inss_caseof)
val () = emit_branchmaplst (out, inss_caseof)
//
in
//
case+ knd of
| 1 => emit_f0body_tlcal (out, fbody)
| 2 => emit_f0body_tlcal2 (out, fbody)
| _ (*0*) => emit_f0body_0 (out, fbody)
//
end // end of [emit_f0body]

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

implement
emit_f0body_0
  (out, fbody) = let
//
fun
auxlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons
    (ins0, inss1) => let
    val-list_cons (ins1, inss2) = inss1
    val () = emit2_ATSfunbodyseq (out, 2(*ind*), ins0)
    val () = emit2_instr_ln (out, 2(*ind*), ins1)
  in
    auxlst (out, inss2)
  end // end of [list_cons]
//
) (* end of [auxlst] *)
//
in
//
case+
fbody.f0body_node of
//
| F0BODY (tds, inss) => auxlst (out, inss)
//
end // end of [emit_f0body_0]

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

implement
emit_f0body_tlcal
  (out, fbody) = let
//
fun
auxlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons
    (ins0, inss1) => let
    val-list_cons (ins1, inss2) = inss1
    val () = emit2_ATSfunbodyseq (out, 4(*ind*), ins0)
    val () = emit_nspc (out, 4(*ind*))
    val () = emit_text (out, "if (funlab_py == 0): break\n")
    val () = emit2_instr_ln (out, 2(*ind*), ins1)
  in
    auxlst (out, inss2)
  end // end of [list_cons]
//
) (* end of [auxlst] *)
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "while(1):\n")
val () = emit_nspc (out, 4(*ind*))
val () = emit_text (out, "funlab_py = 0\n")
//
val () =
(
case+
fbody.f0body_node of
//
| F0BODY (tds, inss) => auxlst (out, inss)
//
)
//
in
  // nothing
end // end of [emit_f0body_tlcal]

(* ****** ****** *)
//
extern
fun
emit_mfundef_initize
  (out: FILEref, inss: instrlst): void
//
implement
emit_mfundef_initize
  (out, inss) = let
//
fun auxlst
(
  out: FILEref, xs: instrlst, i: int
) : void =
(
case+ xs of
| list_nil () => ()
| list_cons (x, xs) => let
    val fl =
      funbodyseq_get_funlab (x)
    val () =
    if i >= 2
      then emit_text (out, ", ")
    // end of [if]
    val () = emit_int (out, i)
    val () = emit_text (out, ": ")
    val () = emit_label (out, fl)
    val-list_cons (_, xs) = xs
  in
    auxlst (out, xs, i+1)
  end // end of [list_cons]
)
//
val () =
emit_nspc (out, 2(*ind*))
val () =
emit_text (out, "mfundef = { ")
val () = auxlst (out, inss, 1)
val () = emit_text (out, " }\n")
//
in
  // nothing
end // end of [emit_mfundef_initize]
//
(* ****** ****** *)
//
extern
fun
emit_the_funbodylst (out: FILEref): void
//
implement
emit_the_funbodylst
  (out) = let
//
fun auxfun
(
  out: FILEref, ins0: instr
) : void = let
//
val-ATSfunbodyseq(inss) = ins0.instr_node
//
val-list_cons (ins1, inss) = inss
val-ATSINSflab (fl) = ins1.instr_node
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "def")
val () = emit_SPACE (out)
val () = emit_label (out, fl)
val () = emit_text (out, "():\n")
//
val () = emit_fundef_nonlocal (out)
//
val () = emit_nspc (out, 4)
val () = emit_text (out, "funlab_py = 0\n")
val () = emit2_instrlst (out, 4(*ind*), inss)
//
in
  // nothing
end // end of [auxfun]
//
fun auxlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons _ => let
    val-list_cons (ins0, inss) = inss
    val-list_cons (ins1, inss) = inss
    val () = auxfun (out, ins0)
    val () = emit2_instr_newline (out, 4(*ind*), ins1)
  in
    auxlst (out, inss)
  end // end of [auxlst]
) (* end of [auxlst] *)
//
val inss_body = the_funbodylst_get()
//
val () = auxlst (out, inss_body)
val () = emit_mfundef_initize (out, inss_body)
//
in
  // nothing
end // end of [emit_the_funbodylst]
//
(* ****** ****** *)

implement
emit_f0body_tlcal2
  (out, fbody) = let
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "tmpret_py = None\n")
//
val () = emit_the_funbodylst (out)
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "funlab_py = 1\n")
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "while(1):\n")
val () = emit_nspc (out, 4(*ind*))
val () = emit_text (out, "tmpret_py = mfundef.get(funlab_py)()\n")
val () = emit_nspc (out, 4(*ind*))
val () = emit_text (out, "if (funlab_py == 0): break\n")
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "return tmpret_py\n")
//
in
  // nothing
end // end of [emit_f0body_tlcal2]

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

implement
emit_f0decl
  (out, fdec) = let
in
//
case+
fdec.f0decl_node of
| F0DECLnone (fhd) => ()
| F0DECLsome (fhd, fbody) =>
  {
    val () = emit_ENDL (out)
    val () = emit_text (out, "def")
    val () = emit_SPACE (out)
    val () = emit_f0head (out, fhd)
    val () = emit_ENDL (out)
    val () = emit_f0body (out, fbody)
    val () = emit_newline (out)
  } (* end of [F0DECLsome] *)
//
end // end of [emit_f0decl]

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

implement
emit_toplevel
  (out, d0cs) = let
//
fun
loop
(
  out: FILEref, d0cs: d0eclist
) : void =
(
//
case+ d0cs of
| list_nil () => ()
| list_cons
    (d0c, d0cs) => let
    val () =
      emit_d0ecl (out, d0c)
    // end of [val]
  in
    loop (out, d0cs)
  end // end of [list_cons]
//
) (* end of [loop] *)
//
in
  loop (out, d0cs)
end // end of [emit_toplevel]

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

(* end of [atsparemit_emit2_py.dats] *)

(* ****** ****** *)
//
// ATS-parse-emit-python
//
(* ****** ****** *)
//
// HX-2014-08-04: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./atsparemit.sats"
staload "./atsparemit_syntax.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_typedef.dats"
//
(* ****** ****** *)
extern
fun
the_statmpdeclst_get (): d0eclist
extern
fun
the_statmpdeclst_insert (d0ecl): void
//
(* ****** ****** *)

local
//
val the_statmps =
  ref<d0eclist> (list_nil(*void*))
//
in (* in-of-local *)
//
implement
the_statmpdeclst_get () =
  list_vt2t(list_reverse(!the_statmps))
//
implement
the_statmpdeclst_insert (d0c) = let
  val d0cs = !the_statmps in !the_statmps := list_cons (d0c, d0cs)
end // end of [the_statmpdeclst_insert]
//
end // end of [local]

(* ****** ****** *)
//
extern
fun
emit_the_statmpdeclst
  (out: FILEref, ind: int): void
//
implement
emit_the_statmpdeclst
  (out, ind) = let
//
fun auxlst
(
  out: FILEref, xs: d0eclist
) : void =
(
case+ xs of
| list_nil () => ()
| list_cons (x, xs) => let
    val-D0Cstatmp (tmp, opt) = x.d0ecl_node
  in
    case+ opt of
    | None _ => auxlst (out, xs)
    | Some _ => let
        val () = emit_ENDL (out)
        val () = emit_nspc (out, ind)
        val () =
        (
          emit_text (out, "global "); emit_tmpvar (out, tmp)
        ) (* end of [val] *)
      in
        auxlst (out, xs)
      end // end of [Some]
  end // end of [list_cons]
) (* end of [auxlst] *)
//
in
  auxlst (out, the_statmpdeclst_get ())
end // end of [emit_the_statmpdeclst]
//
(* ****** ****** *)
//
extern
fun
emit_f0arglst_nonlocal
  (out: FILEref, f0as: f0arglst): void
//
implement
emit_f0arglst_nonlocal
  (out, f0as) = let
//
fun auxlst
(
  out: FILEref, f0as: f0arglst, i: int
) : void =
(
case+ f0as of
| list_nil () => ()
| list_cons (f0a, f0as) =>
  (
    case- f0a.f0arg_node of
    | F0ARGsome (arg, _) => let
        val () =
        if i > 0
          then emit_text (out, ", ")
        // end of [if]
        val () = emit_tmpvar (out, arg)
      in
        auxlst (out, f0as, i+1)
      end // end of [F0ARGsome]
  ) (* end of [list_cons] *)
)
//
in
//
case+ f0as of
| list_nil () => ()
| list_cons _ =>
  {
    val () =
    emit_nspc (out, 4(*ind*))
    val () =
    emit_text (out, "nonlocal ")
    val () = auxlst (out, f0as, 0(*i*))
    val () = emit_ENDL (out)
  }
//
end // end of [emit_f0arglst_nonlocal]
//
(* ****** ****** *)
//
extern
fun
emit_tmpdeclst_initize
  (out: FILEref, tds: tmpdeclst): void
//
implement
emit_tmpdeclst_initize
  (out, tds) = let
//
fun auxlst
(
  out: FILEref, tds: tmpdeclst
) : void =
(
case+ tds of
| list_nil () => ()
| list_cons (td, tds) =>
  (
    case+ td.tmpdec_node of
    | TMPDECnone
        (tmp) => auxlst (out, tds)
    | TMPDECsome
        (tmp, _) => let
        val () = emit_nspc (out, 2(*ind*))
        val () = emit_tmpvar (out, tmp)
        val () = emit_text (out, " = None\n")
      in
        auxlst (out, tds)
      end // end of [TMPDECsome]
  ) (* end of [list_cons] *)
)
//
in
  auxlst (out, tds)
end // end of [emit_tmpdeclst_initize]
//
(* ****** ****** *)
//
extern
fun
emit_tmpdeclst_nonlocal
  (out: FILEref, tds: tmpdeclst): void
//
implement
emit_tmpdeclst_nonlocal
  (out, tds) = let
//
fun auxlst
(
  out: FILEref, tds: tmpdeclst, i: int
) : void =
(
case+ tds of
| list_nil () => ()
| list_cons (td, tds) =>
  (
    case+ td.tmpdec_node of
    | TMPDECnone
        (tmp) => auxlst (out, tds, i)
    | TMPDECsome
        (tmp, _) => let
        val () =
        if i > 0 then
          emit_text (out, ", ")
        // end of [if]
        val () = emit_tmpvar (out, tmp)
      in
        auxlst (out, tds, i+1)
      end // end of [TMPDECsome]
  ) (* end of [list_cons] *)
)
//
in
//
case+ tds of
| list_nil () => ()
| list_cons _ =>
  {
    val () =
    emit_nspc (out, 4(*ind*))
    val () =
    emit_text (out, "nonlocal")
    val () = emit_SPACE (out)
    val () = auxlst (out, tds, 0)
    val () = emit_newline (out)
  } (* end of [list_cons] *)
//
end // end of [emit_tmpdeclst_nonlocal]
//
(* ****** ****** *)
//
extern
fun
emit_mbranchlst_initize
  (out: FILEref, inss: instrlst): void
//
implement
emit_mbranchlst_initize
  (out, inss) = let
//
fun auxlst
(
  out: FILEref, inss: instrlst, i: int
) : void =
(
//
case+ inss of
| list_nil () => ()
| list_cons (_, inss) =>
  {
    val () =
      emit_nspc (out, 2(*ind*))
    val () =
    (
      emit_text (out, "mbranch_"); emit_int (out, i); emit_text (out, " = None\n")
    )
    val () = auxlst (out, inss, i+1)
  }
//
) (* end of [auxlst] *)
//
in
  auxlst (out, inss, 1(*i*))
end // end of [emit_mbranchlst_initize]
//
(* ****** ****** *)
//
extern
fun
emit_mbranchlst_nonlocal
  (out: FILEref, inss: instrlst): void
//
implement
emit_mbranchlst_nonlocal
  (out, inss) = let
//
fun auxlst
(
  out: FILEref, inss: instrlst, i: int
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons (_, inss) => let
    val () =
      if i >= 2 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "mbranch_"); emit_int (out, i)
    )
  in
    auxlst (out, inss, i+1)
  end // end of [list_cons]
//
) (* end of [auxlst] *)
//
in
//
case+ inss of
| list_nil () => ()
| list_cons _ =>
  {
    val () =
    emit_nspc (out, 4(*ind*))
    val () =
    emit_text (out, "nonlocal ")
    val () = auxlst (out, inss, 1(*i*))
    val () = emit_ENDL (out)
  } (* end of [list_cons] *)
//
end // end of [emit_mbranchlst_nonlocal]
//
(* ****** ****** *)
//
extern
fun
funlab_get_index (fl: label): int
extern
fun
tmplab_get_index (lab: label): int
//
(* ****** ****** *)
//
extern
fun
the_f0arglst_get (): f0arglst
extern
fun
the_f0arglst_set (f0as: f0arglst): void
//
(* ****** ****** *)
//
extern
fun
the_tmpdeclst_get (): tmpdeclst
extern
fun
the_tmpdeclst_set (tds: tmpdeclst): void
//
(* ****** ****** *)
//
extern
fun
the_funbodylst_get (): instrlst
extern
fun
the_funbodylst_set (inss: instrlst): void
//
(* ****** ****** *)
//
extern
fun
the_branchlablst_get (): labelist
extern
fun
the_branchlablst_set (tls: labelist): void
//
(* ****** ****** *)
//
extern
fun
the_caseofseqlst_get (): instrlst
extern
fun
the_caseofseqlst_set (inss: instrlst): void
//
(* ****** ****** *)

local
//
val the_f0arglst = ref<f0arglst> (list_nil)
val the_tmpdeclst = ref<tmpdeclst> (list_nil)
//
val the_funbodylst = ref<instrlst> (list_nil)
//
val the_branchlablst = ref<labelist> (list_nil)
val the_caseofseqlst = ref<instrlst> (list_nil)
//
in (* in-of-local *)

implement
the_f0arglst_get () = !the_f0arglst
implement
the_f0arglst_set (xs) = !the_f0arglst := xs

implement
the_tmpdeclst_get () = !the_tmpdeclst
implement
the_tmpdeclst_set (xs) = !the_tmpdeclst := xs

implement
the_funbodylst_get () = !the_funbodylst
implement
the_funbodylst_set (xs) = !the_funbodylst := xs

implement
the_branchlablst_get () = !the_branchlablst
implement
the_branchlablst_set (tls) = !the_branchlablst := tls

implement
the_caseofseqlst_get () = !the_caseofseqlst
implement
the_caseofseqlst_set (xs) = !the_caseofseqlst := xs

end // end of [local]

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

implement
funlab_get_index
  (fl0) = let
//
val n0 = fl0.i0de_sym
//
fun
auxlst
(
  xs: instrlst, i: int
) : int = (
//
case+ xs of
| list_nil () => ~1(*error*)
| list_cons (x, xs) =>
  (
    case+ x.instr_node of
    | ATSfunbodyseq _ => let
        val fl = funbodyseq_get_funlab (x)
      in
        if n0 = fl.i0de_sym then i else auxlst (xs, i+1)
      end // end of [ATSfunbodyseq]
    | _ (*non-ATSfunbody*) => auxlst (xs, i)
  ) (* end of [list_cons] *)
//
) (* end of [auxlst] *)
//
in
  auxlst (the_funbodylst_get(), 1)
end // end of [funlab_get_index]

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

implement
tmplab_get_index
  (lab0) = let
//
val n0 = lab0.i0de_sym
//
fun
auxlst
(
  xs: labelist, i: int
) : int =
(
case+ xs of
| list_nil () => ~1(*error*)
| list_cons (x, xs) =>
    if n0 = x.i0de_sym then i else auxlst (xs, i+1)
  // end of [list_cons]
)
//
in
  auxlst (the_branchlablst_get(), 1)
end // end of [tmplab_get_index]

(* ****** ****** *)
//
fun
emit_funlab_index
 (out: FILEref, fl: label): void =
 emit_int (out, funlab_get_index (fl))
//
fun
emit_tmplab_index
 (out: FILEref, lab: label): void =
 emit_int (out, tmplab_get_index (lab))
//
(* ****** ****** *)

extern
fun
branchmap_get_index (ins: instr): int
//
implement
branchmap_get_index
  (x0) = let
//
val p0 = $UN.cast2ptr (x0)
//
fun auxlst
(
  xs: instrlst, i: int
) : int =
(
case xs of
| list_nil () => ~1(*error*)
| list_cons (x, xs) =>
    if $UN.cast2ptr(x) = p0 then i else auxlst (xs, i+1)
  // end of [list_cons]
)
//
in
  auxlst (the_caseofseqlst_get (), 1)
end // end of [branchmap_get_index]

(* ****** ****** *)
//
fun
emit_branchmap_index
 (out: FILEref, ins: instr): void =
 emit_int (out, branchmap_get_index (ins))
//
(* ****** ****** *)
//
fun
emit_branchmap
(
  out: FILEref, ins0: instr
) : void = let
//
fun auxlst
(
  out: FILEref, xs: instrlst, i: int
) : int =
(
case+ xs of
| list_nil () => i
| list_cons (x, xs) =>
  (
    case+ x.instr_node of
    | ATSINSlab (lab) => let
        val ((*void*)) =
          if i >= 2 then emit_text (out, ", ")
        // end of [val]
        val () = emit_int (out, i)
        val () = emit_text (out, ": ")
        val () = emit_label (out, lab)
      in
        auxlst (out, xs, i+1)
      end // end of [ATSINSlab]
    | _(*non-ATSINSlab*) => auxlst (out, xs, i)
  )
) (* end of [auxlst] *)
//
fun auxlst2
(
  out: FILEref, xs: instrlst, i: int
) : void =
(
case+ xs of
| list_nil () => ()
| list_cons (x, xs) => let
    val-ATSbranchseq(inss) = x.instr_node
  in
    auxlst2 (out, xs, auxlst (out, inss, i))
  end // end of [list_cons]
) (* end of [auxlst2] *)
//
val-ATScaseofseq(inss) = ins0.instr_node
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "mbranch_")
val () = emit_branchmap_index (out, ins0)
val () = emit_text (out, " = ")
val ((*opening*)) = emit_text (out, "{ ")
val () = auxlst2 (out, inss, 1(*first*))
val ((*closing*)) = emit_text (out, " }\n")
//
in
  // nothing
end // end of [emit_branchmap]
//
(* ****** ****** *)

fun
emit_branchmaplst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons (ins, inss) =>
  {
    val () = emit_branchmap (out, ins)
    val () = emit_branchmaplst (out, inss)
  }
) (* end of [emit_branchmaplst] *)

(* ****** ****** *)
//
extern
fun
f0body_collect_caseof
  (fbody: f0body): instrlst(*list-of-caseofseq*)
//
extern
fun
instrlst_collect_caseof
  (inss: instrlst): instrlst(*list-of-caseofseq*)
//
(* ****** ****** *)
//
implement
f0body_collect_caseof
  (fbody) = let
in
//
case+
fbody.f0body_node of
| F0BODY (tds, inss) => instrlst_collect_caseof (inss)
//
end // end of [f0body_collect_caseof]
//
implement
instrlst_collect_caseof
  (inss) = let
//
vtypedef res = instrlst_vt
//
fun
aux
(
  ins: instr, res: res
) : res =
(
case+
ins.instr_node of
//
| ATScaseofseq
    (inss) => (
    auxlst (inss, cons_vt (ins, res))
  ) (* end of [ATScaseofseq] *)
| ATSbranchseq (inss) => auxlst (inss, res)
| ATSfunbodyseq (inss) => auxlst (inss, res)
| _ (*rest-of-instr*) => res
//
) (* end of [aux] *)
//
and
auxlst
(
  inss: instrlst, res: res
) : res =
(
case+ inss of
| list_cons
    (ins, inss) => let
    val res = aux (ins, res) in auxlst (inss, res)
  end // end of [list_cons]
| list_nil ((*void*)) => res
)
//
val res = auxlst (inss, list_vt_nil)
//
in
  list_vt2t(list_vt_reverse(res))
end // end of [instrlst_collect_caseof]
//
(* ****** ****** *)
//
extern
fun emit2_instr
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_instr_ln
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_instr_newline
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_instrlst
  (out: FILEref, ind: int, inss: instrlst) : void
//
(* ****** ****** *)
//
extern
fun emit2_ATSfunbodyseq
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_ATSINSmove_con1
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_ATSINSmove_boxrec
  (out: FILEref, ind: int, ins: instr) : void
//
(* ****** ****** *)
//
// HX-2014-08:
// this one should not be used for
// emitting multiple-line instructions
//
implement
emit_instr
  (out, ins) = emit2_instr (out, 0(*ind*), ins)
//
(* ****** ****** *)
//
implement
emit2_instr
  (out, ind, ins0) = let
in
//
case+
ins0.instr_node of
//
| ATSif
  (
    d0e, inss, inssopt
  ) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if ")
    val () = emit_LPAREN (out)
    val () = emit_d0exp (out, d0e)
    val () = emit_RPAREN (out)
    val () = emit_text (out, ":\n")
    val () = emit2_instrlst (out, ind+2, inss)
    val () =
    (
      case+ inssopt of
      | Some(inss) =>
        {
          val () = emit_nspc (out, ind)
          val () = emit_text (out, "else:\n")
          val () = emit2_instrlst (out, ind+2, inss)
        }
      | None((*void*)) => ()
    )
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#endif")
  } (* end of [ATSif] *)
//
| ATSifthen (d0e, inss) =>
  {
//
    val-list_cons (ins, _) = inss
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if(")
    val () = emit_d0exp (out, d0e)
    val ((*closing*)) = emit_text (out, "): ")
    val () = emit_instr (out, ins)
  }
| ATSifnthen (d0e, inss) =>
  {
//
    val-list_cons (ins, _) = inss
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if not(")
    val () = emit_d0exp (out, d0e)
    val ((*closing*)) = emit_text (out, "): ")
    val () = emit_instr (out, ins)
  }
//
| ATSbranchseq (inss) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSbranch")
  }
//
| ATScaseofseq (inss) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATScaseofseq_beg")
    val () = emit_ENDL (out)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "tmplab_py = 1\n")
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "while(1):\n")
    val () = emit_nspc (out, ind+2)
    val () = emit_text (out, "mbranch_")
    val () = emit_branchmap_index (out, ins0)
    val () = emit_text (out, ".get(tmplab_py)()\n")
    val () = emit_nspc (out, ind+2)
    val () = emit_text (out, "if (tmplab_py == 0): break\n")
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATScaseofseq_end")
  }
//
| ATSreturn (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "return ")
    val () = emit_tmpvar (out, tmp)
  }
| ATSreturn_void (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "return#_void")
  }
//
| ATSlinepragma (line, file) =>
  {
    val () = emit_text (out, "#line ")
    val () = emit_PMVint (out, line)
    val () = emit_SPACE (out)
    val () = emit_PMVstring (out, file)
  }
//
| ATSINSlab (lab) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#")
    val () = emit_label (out, lab)
  }
| ATSINSgoto (lab) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "tmplab_py = ")
    val () = emit_tmplab_index (out, lab)
    val () =
    (
      emit_SPACE (out);
      emit_text (out, "; return");
      emit_SHARP (out); emit_label (out, lab)
    ) (* end of [val] *)
  }
//
| ATSINSflab (flab) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_SHARP (out)
    val () = emit_label (out, flab)
  }
| ATSINSfgoto (flab) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "funlab_py = ")
    val () = emit_funlab_index (out, flab)
    val () =
    (
      emit_SPACE (out); emit_SHARP (out); emit_label (out, flab)
    ) (* end of [val] *)
  }
//
| ATSINSmove (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e)
  } (* end of [ATSINSmove] *)
//
| ATSINSmove_void (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      case+ d0e.d0exp_node of
      | ATSempty _ =>
          emit_text (out, "None#ATSINSmove_void")
        // end of [ATSempty]
      | _ (*non-ATSempty*) => emit_d0exp (out, d0e)
    ) : void // end of [val]
  } (* end of [ATSINSmove_void] *)
//
| ATSINSmove_nil (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_text (out, "None")
  }
//
| ATSINSmove_con0 (tmp, tag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_PMVint (out, tag)
  }
//
| ATSINSmove_con1 _ =>
    emit2_ATSINSmove_con1 (out, ind, ins0)
//
| ATSINSmove_boxrec _ =>
    emit2_ATSINSmove_boxrec (out, ind, ins0)
//
| ATStailcalseq (inss) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATStailcalseq_beg")
    val () = emit_ENDL (out)
    val () = emit2_instrlst (out, ind, inss)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATStailcalseq_end")

  } (* end of [ATStailcalseq] *)
//
| ATSINSmove_tlcal (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e)
  } (* end of [ATSINSmove_tlcal] *)
//
| ATSINSargmove_tlcal (tmp1, tmp2) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp1)
    val () = emit_text (out, " = ")
    val () = emit_tmpvar (out, tmp2)
  } (* end of [ATSINSargmove_tlcal] *)
//
| ATSdynload (dummy) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSdynload()")
    val () = emit_the_statmpdeclst (out, ind)
  }
//
| ATSdynloadset (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSdynloadset\n")
    val () = (
      emit_nspc (out, ind); emit_tmpvar (out, flag); emit_text (out, " = 1")
    ) (* end of [val] *)
  }
//
| ATSdynloadflag_sta (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSdynloadflag_sta\n")
    val () = emit_nspc (out, ind)
    val () = (
      emit_text (out, "global "); emit_tmpvar (out, flag)
    ) (* end of [val] *)
  }
//
| ATSdynloadflag_ext (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "#ATSdynloadflag_ext\n")
    val () = emit_nspc (out, ind)
    val () = (
      emit_text (out, "global "); emit_tmpvar (out, flag)
    ) (* end of [val] *)
  }
//
| _ (*rest-of-instr*) =>
  {
    val () = emit_nspc (out, ind)
    val ((*error*)) = fprint! (out, "UNRECOGNIZED-INSTRUCTION: ", ins0)
  }
//
end // end of [emit2_instr]

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

implement
emit2_instr_ln
  (out, ind, ins) =
(
  emit2_instr (out, ind, ins); emit_ENDL (out)
) (* end of [emit2_instr_ln] *)

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

implement
emit2_instr_newline
  (out, ind, ins) =
(
  emit2_instr (out, ind, ins); emit_newline (out)
) (* end of [emit2_instr_newline] *)

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

implement
emit2_instrlst
(
  out, ind, inss
) = (
//
case+ inss of
| list_nil () => ()
| list_cons
    (ins, inss) => let
    val () = emit2_instr (out, ind, ins)
  in
    emit_ENDL (out); emit2_instrlst (out, ind, inss)
  end // end of [list_cons]
//
) (* end of [emit2_instrlst] *)

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

implement
emit2_ATSfunbodyseq
  (out, ind, ins) = let
//
val-ATSfunbodyseq (inss) = ins.instr_node
//
in
  emit2_instrlst (out, ind, inss)
end // end of [emit2_ATS2funbodyseq]

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

implement
emit2_ATSINSmove_con1
  (out, ind, ins0) = let
//
fun
getarglst
(
  inss: instrlst
) : d0explst =
(
case+ inss of
| list_nil () => list_nil ()
| list_cons (ins, inss) => let
    val-ATSINSstore_con1_ofs (_, _, _, d0e) = ins.instr_node
    val d0es = getarglst (inss)
  in
    list_cons (d0e, d0es)
  end // end of [list_cons]
)
//
val-ATSINSmove_con1 (inss) = ins0.instr_node
//
val-list_cons (ins, inss) = inss
val-ATSINSmove_con1_new (tmp, _) = ins.instr_node
//
var opt: tokenopt = None()
//
val inss =
(
case+ inss of
| list_nil () => inss
| list_cons (ins, inss2) =>
  (
    case+ ins.instr_node of
    | ATSINSstore_con1_tag
        (tmp, tag) => let
        val () = opt := Some(tag) in inss2
      end // end of [ATSINSstore_con1_tag]
    | _ (*non-ATSINSstore_con1_tag*) => inss
  )
) : instrlst
//
val d0es = getarglst (inss)
val () = emit_nspc (out, ind)
val () = emit_tmpvar (out, tmp)
val () = emit_text (out, " = ")
val () = emit_LPAREN (out)
val () =
(
case+ opt of
| None () => ()
| Some (tag) => emit_PMVint (out, tag)
) : void // end of [val]
val () =
(
case+ opt of
| None _ => emit_d0explst (out, d0es)
| Some _ => emit_d0explst_1 (out, d0es)
) : void // end of [val]
//
val () = emit_RPAREN (out)
//
in
  // nothing
end // end of [emit2_ATSINSmove_con1]

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

implement
emit2_ATSINSmove_boxrec
  (out, ind, ins0) = let
//
fun
getarglst
(
  inss: instrlst
) : d0explst =
(
case+ inss of
| list_nil () => list_nil ()
| list_cons (ins, inss) => let
    val-ATSINSstore_boxrec_ofs (_, _, _, d0e) = ins.instr_node
    val d0es = getarglst (inss)
  in
    list_cons (d0e, d0es)
  end // end of [list_cons]
)
//
val-ATSINSmove_boxrec (inss) = ins0.instr_node
//
val-list_cons (ins, inss) = inss
val-ATSINSmove_boxrec_new (tmp, _) = ins.instr_node
//
val d0es = getarglst (inss)
//
val () = emit_nspc (out, ind)
val () = emit_tmpvar (out, tmp)
val () = emit_text (out, " = ")
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es)
val () = emit_RPAREN (out)
//
in
  // nothing
end // end of [emit2_ATSINSmove_boxrec]

(* ****** ****** *)
//
#define
ATSEXTCODE_BEG "######\n#ATSextcode_beg()\n######"
#define
ATSEXTCODE_END "######\n#ATSextcode_end()\n######"
//
(* ****** ****** *)

implement
emit_d0ecl
  (out, d0c0) = let
in
//
case+
d0c0.d0ecl_node of
//
| D0Cinclude _ => ()
//
| D0Cifdef _ => ()
| D0Cifndef _ => ()
//
| D0Ctypedef (id, def) =>
    typedef_insert (id.i0de_sym, def)
//
| D0Cassume (id) =>
  {
    val () = emit_ENDL (out)
    val () =
      emit_text (out, "#ATSassume(")
    val () = (
      emit_i0de (out, id); emit_text (out, ")\n")
    ) (* end of [val] *)
  }
//
| D0Cdyncst_mac _ => ()
| D0Cdyncst_extfun _ => ()
//
| D0Cstatmp
    (tmp, opt) =>
  {
    val () = emit_ENDL (out)
    val () = the_statmpdeclst_insert (d0c0)
    val () = (
      case+ opt of
      | Some _ => () | None () => emit_text(out, "#")
    ) (* end of [val] *)
    val () = (
      emit_tmpvar (out, tmp); emit_text (out, " = None\n")
    ) (* end of [val] *)
  } (* end of [D0Cstatmp] *)
//
| D0Cextcode (toks) =>
  {
    val () = emit_ENDL (out)
    val () =
      emit_text (out, ATSEXTCODE_BEG)
    val () = emit_extcode (out, toks) // HX: verbatim output
    val () =
      emit_text (out, ATSEXTCODE_END)
    val ((*void*)) = emit_newline (out)
  } (* end of [D0Cextcode] *)
//
| D0Cfundecl
    (fk, f0d) => emit_f0decl (out, f0d)
//
| D0Cclosurerize
  (
    fl, env, arg, res
  ) => emit_closurerize (out, fl, env, arg, res)
//
| D0Cdynloadflag_init (flag) =>
  {
    val () = emit_ENDL (out)
    val () = (
      emit_tmpvar (out, flag); emit_text (out, " = 0\n")
    ) (* end of [val] *)
  }
//
end // end of [emit_d0ecl]

(* ****** ****** *)
//
extern
fun emit2_tmpdec
  (out: FILEref, ind: int, td: tmpdec) : void
extern
fun emit2_tmpdeclst
  (out: FILEref, ind: int, tds: tmpdeclst) : void
//
(* ****** ****** *)

implement
emit_tmpdec
  (out, td) = emit2_tmpdec (out, 0(*ind*), td)
//
implement
emit2_tmpdec
  (out, ind, td) = let
in
//
case+
td.tmpdec_node of
//
| TMPDECnone (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = (emit_SHARP (out); emit_tmpvar (out, tmp))
  }
| TMPDECsome (tmp, s0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = (emit_tmpvar (out, tmp); emit_text (out, " = None"))
  }
end // end of [emit2_tmpdec]
//
(* ****** ****** *)

implement
emit2_tmpdeclst
(
  out, ind, tds
) = (
//
case+ tds of
| list_nil () => ()
| list_cons (td, tds) =>
  {
    val () = emit2_tmpdec (out, ind, td)
    val () = emit_ENDL (out)
    val () = emit2_tmpdeclst (out, ind, tds)
  }
//
) (* end of [emit2_tmpdeclst] *)

(* ****** ****** *)
//
extern
fun
emit_branchseq
  (out: FILEref, ins0: instr): void
extern
fun
emit_branchseqlst
  (out: FILEref, inss: instrlst): void
//
extern
fun
emit_fundef_nonlocal (out: FILEref): void
//
(* ****** ****** *)

local

fun auxlst
(
  out: FILEref, inss: instrlst
) : void = let
//
val inss =
instrlst_skip_linepragma (inss)
//
val-list_cons (ins, inss) = inss
val-ATSINSlab (lab) = ins.instr_node
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "def")
val () = emit_SPACE (out)
val () = emit_label (out, lab)
val () = emit_text (out, "():\n")
//
val () = emit_fundef_nonlocal (out)
//
val () = emit_nspc (out, 4)
val () = emit_text (out, "tmplab_py = 0\n")
//
in
  auxlst2 (out, lab, inss)
end (* end of [auxlst] *)

and auxlst2
(
  out: FILEref, lab: label, inss: instrlst
) : void = let
in
//
case+ inss of
//
| list_nil ((*none*)) =>
  {
    val () = emit_nspc (out, 4)
    val () = emit_text (out, "return\n")
  } (* end of [list_nil] *)
//
| list_cons
    (ins1, inss2) =>
  (
    case ins1.instr_node of
    | ATSINSlab (lab) =>
      {
        val () = emit_nspc (out, 4)
        val () = emit_label (out, lab)
        val () = emit_text (out, "()\n")
        val () = emit_nspc (out, 4)
        val () = emit_text (out, "return\n")
        val () = auxlst (out, inss)
      }
    | _ (*non-ATSINSlab*) =>
      {
        val () = (
          emit2_instr (out, 4, ins1); emit_ENDL (out)
        ) (* end of [val] *)
        val () = auxlst2 (out, lab, inss2)
      } (* end of [non-ATSINSlab] *)
  ) (* end of [list_cons] *)
//
end // (* end of [auxlst2] *)

in (* in-of-local *)

implement
emit_branchseq
  (out, ins0) = let
//
val-ATSbranchseq (inss) = ins0.instr_node
//
in
  auxlst (out, inss)
end // end of [emit_branchseq]

end // end of [local]

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

fun
emit_branchseqlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons (ins, inss) =>
  {
    val () = emit_branchseq (out, ins)
    val () = emit_branchseqlst (out, inss)
  }
) (* end of [emit_branchseqlst] *)

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

implement
emit_fundef_nonlocal
  (out) = () where
{
//
val f0as = the_f0arglst_get ()
val () = emit_f0arglst_nonlocal (out, f0as)
//
val tmpdecs = the_tmpdeclst_get ()
val () = emit_tmpdeclst_nonlocal (out, tmpdecs)
//
val () =
emit_nspc (out, 4(*ind*))
val () =
emit_text (out, "nonlocal funlab_py, tmplab_py\n")
//
val inss_caseof = the_caseofseqlst_get ()
val () = emit_mbranchlst_nonlocal (out, inss_caseof)
//
} // end of [emit_fundef_nonlocal]

(* ****** ****** *)
//
extern
fun
emit_caseofseq
  (out: FILEref, ins0: instr): void
extern
fun
emit_caseofseqlst
  (out: FILEref, inss: instrlst): void
//
(* ****** ****** *)

fun
emit_caseofseq
(
  out: FILEref, ins0: instr
) : void = let
//
val-ATScaseofseq(inss) = ins0.instr_node
//
val tls = caseofseq_get_tmplablst (ins0)
val ((*update*)) = the_branchlablst_set (tls)
//
in
  emit_branchseqlst (out, inss)
end // end of [emit_caseofseq]

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

fun
emit_caseofseqlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons (ins, inss) =>
  {
    val () = emit_caseofseq (out, ins)
    val () = emit_caseofseqlst (out, inss)
  }
) (* end of [emit_caseofseqlst] *)

(* ****** ****** *)
//
extern
fun emit_f0arg : emit_type (f0arg)
extern
fun emit_f0marg : emit_type (f0marg)
extern
fun emit_f0head : emit_type (f0head)
//
extern
fun emit_f0body : emit_type (f0body)
extern
fun emit_f0body_0 : emit_type (f0body)
extern
fun emit_f0body_tlcal : emit_type (f0body)
extern
fun emit_f0body_tlcal2 : emit_type (f0body)
//
(* ****** ****** *)

implement
emit_f0arg
  (out, f0a) = let
in
//
case+
f0a.f0arg_node of
//
| F0ARGnone _ => emit_text (out, "__NONE__")
| F0ARGsome (arg, s0e) => emit_tmpvar (out, arg)
//
end // end of [emit_f0arg]

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

implement
emit_f0marg
  (out, f0ma) = let
//
fun
loop
(
  out: FILEref, f0as: f0arglst, i: int
) : void =
(
case+ f0as of
| list_nil () => ()
| list_cons (f0a, f0as) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_f0arg (out, f0a); loop (out, f0as, i+1)
  end // end of [list_cons]
)
//
in
  loop (out, f0ma.f0marg_node, 0)
end // end of [emit_f0marg]

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

implement
emit_f0head
  (out, fhd) = let
//
val f0as =
  f0head_get_f0arglst (fhd)
//
val () = the_f0arglst_set (f0as)
//
in
//
case+
fhd.f0head_node of
| F0HEAD
    (fid, f0ma, res) =>
  {
    val () = emit_tmpvar (out, fid)
    val () = emit_LPAREN (out)
    val () = emit_f0marg (out, f0ma)
    val () = emit_RPAREN (out)
    val () = emit_text (out, ":")
  }
//
end // end of [emit_f0head]

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

implement
emit_f0body
  (out, fbody) = let
//
val knd = f0body_classify (fbody)
(*
val () = println! ("emit_f0body: knd = ", knd)
*)
//
val tmpdecs =
  f0body_get_tmpdeclst (fbody)
val inss_body =
  f0body_get_bdinstrlst (fbody)
val inss_caseof =
  f0body_collect_caseof (fbody)
//
val () = the_tmpdeclst_set (tmpdecs)
val () = the_funbodylst_set (inss_body)
val () = the_caseofseqlst_set (inss_caseof)
//
val () = emit_tmpdeclst_initize (out, tmpdecs)
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "funlab_py = None\n")
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "tmplab_py = None\n")
//
val () = emit_mbranchlst_initize (out, inss_caseof)
//
val () = emit_caseofseqlst (out, inss_caseof)
val () = emit_branchmaplst (out, inss_caseof)
//
in
//
case+ knd of
| 1 => emit_f0body_tlcal (out, fbody)
| 2 => emit_f0body_tlcal2 (out, fbody)
| _ (*0*) => emit_f0body_0 (out, fbody)
//
end // end of [emit_f0body]

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

implement
emit_f0body_0
  (out, fbody) = let
//
fun
auxlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons
    (ins0, inss1) => let
    val-list_cons (ins1, inss2) = inss1
    val () = emit2_ATSfunbodyseq (out, 2(*ind*), ins0)
    val () = emit2_instr_ln (out, 2(*ind*), ins1)
  in
    auxlst (out, inss2)
  end // end of [list_cons]
//
) (* end of [auxlst] *)
//
in
//
case+
fbody.f0body_node of
//
| F0BODY (tds, inss) => auxlst (out, inss)
//
end // end of [emit_f0body_0]

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

implement
emit_f0body_tlcal
  (out, fbody) = let
//
fun
auxlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons
    (ins0, inss1) => let
    val-list_cons (ins1, inss2) = inss1
    val () = emit2_ATSfunbodyseq (out, 4(*ind*), ins0)
    val () = emit_nspc (out, 4(*ind*))
    val () = emit_text (out, "if (funlab_py == 0): break\n")
    val () = emit2_instr_ln (out, 2(*ind*), ins1)
  in
    auxlst (out, inss2)
  end // end of [list_cons]
//
) (* end of [auxlst] *)
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "while(1):\n")
val () = emit_nspc (out, 4(*ind*))
val () = emit_text (out, "funlab_py = 0\n")
//
val () =
(
case+
fbody.f0body_node of
//
| F0BODY (tds, inss) => auxlst (out, inss)
//
)
//
in
  // nothing
end // end of [emit_f0body_tlcal]

(* ****** ****** *)
//
extern
fun
emit_mfundef_initize
  (out: FILEref, inss: instrlst): void
//
implement
emit_mfundef_initize
  (out, inss) = let
//
fun auxlst
(
  out: FILEref, xs: instrlst, i: int
) : void =
(
case+ xs of
| list_nil () => ()
| list_cons (x, xs) => let
    val fl =
      funbodyseq_get_funlab (x)
    val () =
    if i >= 2
      then emit_text (out, ", ")
    // end of [if]
    val () = emit_int (out, i)
    val () = emit_text (out, ": ")
    val () = emit_label (out, fl)
    val-list_cons (_, xs) = xs
  in
    auxlst (out, xs, i+1)
  end // end of [list_cons]
)
//
val () =
emit_nspc (out, 2(*ind*))
val () =
emit_text (out, "mfundef = { ")
val () = auxlst (out, inss, 1)
val () = emit_text (out, " }\n")
//
in
  // nothing
end // end of [emit_mfundef_initize]
//
(* ****** ****** *)
//
extern
fun
emit_the_funbodylst (out: FILEref): void
//
implement
emit_the_funbodylst
  (out) = let
//
fun auxfun
(
  out: FILEref, ins0: instr
) : void = let
//
val-ATSfunbodyseq(inss) = ins0.instr_node
//
val-list_cons (ins1, inss) = inss
val-ATSINSflab (fl) = ins1.instr_node
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "def")
val () = emit_SPACE (out)
val () = emit_label (out, fl)
val () = emit_text (out, "():\n")
//
val () = emit_fundef_nonlocal (out)
//
val () = emit_nspc (out, 4)
val () = emit_text (out, "funlab_py = 0\n")
val () = emit2_instrlst (out, 4(*ind*), inss)
//
in
  // nothing
end // end of [auxfun]
//
fun auxlst
(
  out: FILEref, inss: instrlst
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons _ => let
    val-list_cons (ins0, inss) = inss
    val-list_cons (ins1, inss) = inss
    val () = auxfun (out, ins0)
    val () = emit2_instr_newline (out, 4(*ind*), ins1)
  in
    auxlst (out, inss)
  end // end of [auxlst]
) (* end of [auxlst] *)
//
val inss_body = the_funbodylst_get()
//
val () = auxlst (out, inss_body)
val () = emit_mfundef_initize (out, inss_body)
//
in
  // nothing
end // end of [emit_the_funbodylst]
//
(* ****** ****** *)

implement
emit_f0body_tlcal2
  (out, fbody) = let
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "tmpret_py = None\n")
//
val () = emit_the_funbodylst (out)
//
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "funlab_py = 1\n")
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "while(1):\n")
val () = emit_nspc (out, 4(*ind*))
val () = emit_text (out, "tmpret_py = mfundef.get(funlab_py)()\n")
val () = emit_nspc (out, 4(*ind*))
val () = emit_text (out, "if (funlab_py == 0): break\n")
val () = emit_nspc (out, 2(*ind*))
val () = emit_text (out, "return tmpret_py\n")
//
in
  // nothing
end // end of [emit_f0body_tlcal2]

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

implement
emit_f0decl
  (out, fdec) = let
in
//
case+
fdec.f0decl_node of
| F0DECLnone (fhd) => ()
| F0DECLsome (fhd, fbody) =>
  {
    val () = emit_ENDL (out)
    val () = emit_text (out, "def")
    val () = emit_SPACE (out)
    val () = emit_f0head (out, fhd)
    val () = emit_ENDL (out)
    val () = emit_f0body (out, fbody)
    val () = emit_newline (out)
  } (* end of [F0DECLsome] *)
//
end // end of [emit_f0decl]

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

implement
emit_toplevel
  (out, d0cs) = let
//
fun
loop
(
  out: FILEref, d0cs: d0eclist
) : void =
(
//
case+ d0cs of
| list_nil () => ()
| list_cons
    (d0c, d0cs) => let
    val () =
      emit_d0ecl (out, d0c)
    // end of [val]
  in
    loop (out, d0cs)
  end // end of [list_cons]
//
) (* end of [loop] *)
//
in
  loop (out, d0cs)
end // end of [emit_toplevel]

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

(* end of [atsparemit_emit2_py.dats] *)


Updating: very minorly tidying-up

Updating: very minorly tidying-up

(* ****** ****** *)
//
// ATS-parse-emit-js
//
(* ****** ****** *)
//
// HX-2014-08-20: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./atsparemit.sats"
staload "./atsparemit_syntax.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_typedef.dats"
//
(* ****** ****** *)

implement
emit_PMVint
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVint]
//
implement
emit_PMVintrep
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVintrep]
//
(* ****** ****** *)

implement
emit_PMVbool
  (out, tfv) =
(
  emit_text (out, if tfv then "true" else "false")
) (* end of [emit_PMVbool] *)

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

implement
emit_PMVstring
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVstring]

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

implement
emit_PMVfloat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVfloat]

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

implement
emit_PMVi0nt
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVi0nt]

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

implement
emit_PMVf0loat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVf0loat]

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

implement
emit_PMVfunlab
  (out, flab) = let
in
  emit_label (out, flab)
end // end of [emit_PMVfunlab]

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

implement
emit_PMVcfunlab
  (out, fl, d0es) =
{
//
val () =
  emit_label (out, fl)
val () =
  emit_text (out, "__closurerize")
//
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es)
val () = emit_RPAREN (out)
//
} (* end of [emit_PMVcfunlab] *)

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

implement
emit_d0exp
  (out, d0e0) = let
in
//
case+
d0e0.d0exp_node of
//
| D0Eide (id) =>
  {
    val () = emit_i0de (out, id)
  }
//
| D0Eappid (id, d0es) =>
  {
    val () = emit_i0de (out, id)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
| D0Eappexp (d0e, d0es) =>
  {
    val () = emit_d0exp (out, d0e)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| D0Elist (d0es) =>
  {
    val () = emit_text (out, "D0Elist")
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| ATSempty (x) => emit_text (out, "null")
//
| ATSPMVint (int) => emit_PMVint (out, int)
| ATSPMVintrep (int) => emit_PMVintrep (out, int)
//
| ATSPMVbool (tfv) => emit_PMVbool (out, tfv)
//
| ATSPMVstring (str) => emit_PMVstring (out, str)
//
| ATSPMVi0nt (int) => emit_PMVi0nt (out, int)
| ATSPMVf0loat (flt) => emit_PMVf0loat (out, flt)
//
| ATSPMVfunlab (fl) => emit_PMVfunlab (out, fl)
| ATSPMVcfunlab
    (_(*knd*), fl, d0es) => emit_PMVcfunlab (out, fl, d0es)
  // end of [ATSPMVcfunlab]
//
| ATSSELcon _ => emit_SELcon (out, d0e0)
//
| ATSSELrecsin _ => emit_text (out, "ATSSELrecsin(...)")
//
| ATSSELboxrec _ => emit_SELboxrec (out, d0e0)
//
| ATSSELfltrec _ => emit_text (out, "ATSSELfltrec(...)")
//
| ATSfunclo_fun
    (d2e, _(*arg*), _(*res*)) => emit_d0exp (out, d2e)
| ATSfunclo_clo
    (d2e, _(*arg*), _(*res*)) =>
  (
    emit_d0exp (out, d2e);
    emit_LBRACKET (out); emit_int (out, 0); emit_RBRACKET (out)
  ) (* end of [ATSfunclo_clo] *)
//
end // end of [emit_d0exp]

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

local

fun
loop
(
  out: FILEref, d0es: d0explst, i: int
) : void =
(
case+ d0es of
| list_nil () => ()
| list_cons (d0e, d0es) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_d0exp (out, d0e); loop (out, d0es, i+1)
  end // end of [list_cons]
)

in (* in-of-local *)

implement
emit_d0explst (out, d0es) = loop (out, d0es, 0)
implement
emit_d0explst_1 (out, d0es) = loop (out, d0es, 1)

end // end of [local]

(* ****** ****** *)
//
extern
fun
tyrec_labsel
  (tyrec: tyrec, lab: symbol): int
//
implement
tyrec_labsel
  (tyrec, lab) = let
//
fun loop
(
  xs: tyfldlst, i: int
) : int =
(
case+ xs of
| list_cons (x, xs) => let
    val TYFLD (id, s0e) = x.tyfld_node
  in
    if lab = id.i0de_sym then i else loop (xs, i+1)
  end // end of [list_cons
| list_nil ((*void*)) => ~1(*error*)
)
//
in
  loop (tyrec.tyrec_node, 0)
end // end of [tyrec_labsel]
//
(* ****** ****** *)
implement
emit_SELcon
  (out, d0e) = let
//
val-ATSSELcon
  (d0rec, s0e, id) = d0e.d0exp_node
val-S0Eide (name) = s0e.s0exp_node
val-~Some_vt (s0rec) = typedef_search_opt (name)
//
val index = tyrec_labsel (s0rec, id.i0de_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELcon]

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

implement
emit_SELboxrec
  (out, d0e) = let
//
val-ATSSELboxrec
  (d0rec, s0e, id) = d0e.d0exp_node
val-S0Eide (name) = s0e.s0exp_node
val-~Some_vt (s0rec) = typedef_search_opt (name)
//
val index = tyrec_labsel (s0rec, id.i0de_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELboxrec]

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

#define
ATSEXTCODE_BEG "/* ATSextcode_beg() */"
#define
ATSEXTCODE_END "/* ATSextcode_end() */\n"

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

implement
emit_d0ecl
  (out, d0c) = let
in
//
case+
d0c.d0ecl_node of
//
| D0Cinclude _ => ()
//
| D0Cifdef _ => ()
| D0Cifndef _ => ()
//
| D0Ctypedef (id, def) =>
    typedef_insert (id.i0de_sym, def)
  // end of [D0Ctypedef]
//
| D0Cdyncst_mac _ => ()
| D0Cdyncst_extfun _ => ()
//
| D0Cfundecl
    (fk, f0d) => emit_f0decl (out, f0d)
//
| D0Cextcode (toks) =>
  {
    val () = emit_text (out, ATSEXTCODE_BEG)
    val () = emit_extcode (out, toks)
    val () = emit_text (out, ATSEXTCODE_END)
  }
//
| D0Cclosurerize
  (
    fl, env, arg, res
  ) => emit_closurerize (out, fl, env, arg, res)
//
end // end of [emit_d0ecl]

(* ****** ****** *)
//
implement
emit_COMMENT_line (out) =
  emit_text (out, "// COMMENT_line\n")
//
implement
emit_COMMENT_block (out) = ((*ignored*))
//
(* ****** ****** *)

local

fun
aux0_arglst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "arg"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_arglst (out, s0es, n0, i+1)
  end // end of [list_cons]
) (* end of [aux0_arglst] *)

fun
aux0_envlst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "env"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_envlst (out, s0es, n0, i+1)
  end // end of [list_cons]
) (* end of [aux0_envlst] *)

fun
aux1_envlst
(
  out: FILEref
, s0es: s0explst, i: int
) : int =
(
case+ s0es of
| list_nil () => (i)
| list_cons
    (s0e, s0es) => let
    val () =
    if i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "cenv");
      emit_LBRACKET (out); emit_int (out, i+1); emit_RBRACKET (out)
    ) (* end of [val] *)
  in
    aux1_envlst (out, s0es, i+1)
  end // end of [list_cons]
) (* end of [aux1_envlst] *)

in (* in-of-local *)

implement
emit_closurerize
(
  out, fl, env, arg, res
) = let
//
val-S0Elist(s0es_env) = env.s0exp_node
val-S0Elist(s0es_arg) = arg.s0exp_node
//
val () =
emit_text (out, "function\n")
val () = emit_label (out, fl)
val () =
emit_text (out, "__closurerize(")
val () = aux0_envlst (out, s0es_env, 0, 0)
val ((*closing*)) = emit_text (out, ")\n")
//
val ((*opening*)) = emit_text (out, "{\n")
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "return [")
val () = emit_text (out, "function(")
//
val () = emit_text (out, "cenv")
val () = aux0_arglst (out, s0es_arg, 1, 0)
//
val () = emit_text (out, ") { return ")
//
val () = emit_label (out, fl)
val () = emit_LPAREN (out)
val n0 = aux1_envlst (out, s0es_env, 0)
val () = aux0_arglst (out, s0es_arg, n0, 0)
val () = emit_RPAREN (out)
//
val ((*closing*)) = emit_text (out, " ; }")
//
val () = aux0_envlst (out, s0es_env, 1, 0)
val ((*closing*)) = emit_text (out, "]\n")
//
val ((*closing*)) = emit_text (out, "}\n")
//
val () = emit_newline (out)
//
in
  // nothing
end // end of [emit_closurerize]

end // end of [local]

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

(* end of [atsparemit_emit_js.dats] *)

(* ****** ****** *)
//
// ATS-parse-emit-js
//
(* ****** ****** *)
//
// HX-2014-08-20: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./atsparemit.sats"
staload "./atsparemit_syntax.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_typedef.dats"
//
(* ****** ****** *)

implement
emit_PMVint
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVint]
//
implement
emit_PMVintrep
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVintrep]
//
(* ****** ****** *)

implement
emit_PMVbool
  (out, tfv) =
(
  emit_text (out, if tfv then "true" else "false")
) (* end of [emit_PMVbool] *)

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

implement
emit_PMVstring
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVstring]

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

implement
emit_PMVfloat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVfloat]

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

implement
emit_PMVi0nt
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVi0nt]

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

implement
emit_PMVf0loat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVf0loat]

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

implement
emit_PMVfunlab
  (out, flab) = let
in
  emit_label (out, flab)
end // end of [emit_PMVfunlab]

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

implement
emit_PMVcfunlab
  (out, fl, d0es) =
{
//
val () =
  emit_label (out, fl)
val () =
  emit_text (out, "__closurerize")
//
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es)
val () = emit_RPAREN (out)
//
} (* end of [emit_PMVcfunlab] *)

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

implement
emit_d0exp
  (out, d0e0) = let
in
//
case+
d0e0.d0exp_node of
//
| D0Eide (id) =>
  {
    val () = emit_i0de (out, id)
  }
//
| D0Eappid (id, d0es) =>
  {
    val () = emit_i0de (out, id)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
| D0Eappexp (d0e, d0es) =>
  {
    val () = emit_d0exp (out, d0e)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| D0Elist (d0es) =>
  {
    val () = emit_text (out, "D0Elist")
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| ATSempty (x) => emit_text (out, "null")
//
| ATSPMVint (int) => emit_PMVint (out, int)
| ATSPMVintrep (int) => emit_PMVintrep (out, int)
//
| ATSPMVbool (tfv) => emit_PMVbool (out, tfv)
//
| ATSPMVstring (str) => emit_PMVstring (out, str)
//
| ATSPMVi0nt (int) => emit_PMVi0nt (out, int)
| ATSPMVf0loat (flt) => emit_PMVf0loat (out, flt)
//
| ATSPMVfunlab (fl) => emit_PMVfunlab (out, fl)
| ATSPMVcfunlab
    (_(*knd*), fl, d0es) => emit_PMVcfunlab (out, fl, d0es)
  // end of [ATSPMVcfunlab]
//
| ATSSELcon _ => emit_SELcon (out, d0e0)
//
| ATSSELrecsin _ => emit_text (out, "ATSSELrecsin(...)")
//
| ATSSELboxrec _ => emit_SELboxrec (out, d0e0)
//
| ATSSELfltrec _ => emit_text (out, "ATSSELfltrec(...)")
//
| ATSfunclo_fun
    (d2e, _(*arg*), _(*res*)) => emit_d0exp (out, d2e)
| ATSfunclo_clo
    (d2e, _(*arg*), _(*res*)) =>
  (
    emit_d0exp (out, d2e);
    emit_LBRACKET (out); emit_int (out, 0); emit_RBRACKET (out)
  ) (* end of [ATSfunclo_clo] *)
//
end // end of [emit_d0exp]

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

local

fun
loop
(
  out: FILEref, d0es: d0explst, i: int
) : void =
(
case+ d0es of
| list_nil () => ()
| list_cons (d0e, d0es) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_d0exp (out, d0e); loop (out, d0es, i+1)
  end // end of [list_cons]
)

in (* in-of-local *)

implement
emit_d0explst (out, d0es) = loop (out, d0es, 0)
implement
emit_d0explst_1 (out, d0es) = loop (out, d0es, 1)

end // end of [local]

(* ****** ****** *)
//
extern
fun
tyrec_labsel
  (tyrec: tyrec, lab: symbol): int
//
implement
tyrec_labsel
  (tyrec, lab) = let
//
fun loop
(
  xs: tyfldlst, i: int
) : int =
(
case+ xs of
| list_cons (x, xs) => let
    val TYFLD (id, s0e) = x.tyfld_node
  in
    if lab = id.i0de_sym then i else loop (xs, i+1)
  end // end of [list_cons
| list_nil ((*void*)) => ~1(*error*)
)
//
in
  loop (tyrec.tyrec_node, 0)
end // end of [tyrec_labsel]
//
(* ****** ****** *)
implement
emit_SELcon
  (out, d0e) = let
//
val-ATSSELcon
  (d0rec, s0e, id) = d0e.d0exp_node
val-S0Eide (name) = s0e.s0exp_node
val-~Some_vt (s0rec) = typedef_search_opt (name)
//
val index = tyrec_labsel (s0rec, id.i0de_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELcon]

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

implement
emit_SELboxrec
  (out, d0e) = let
//
val-ATSSELboxrec
  (d0rec, s0e, id) = d0e.d0exp_node
val-S0Eide (name) = s0e.s0exp_node
val-~Some_vt (s0rec) = typedef_search_opt (name)
//
val index = tyrec_labsel (s0rec, id.i0de_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELboxrec]

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

#define
ATSEXTCODE_BEG "/* ATSextcode_beg() */"
#define
ATSEXTCODE_END "/* ATSextcode_end() */\n"

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

implement
emit_d0ecl
  (out, d0c) = let
in
//
case+
d0c.d0ecl_node of
//
| D0Cinclude _ => ()
//
| D0Cifdef _ => ()
| D0Cifndef _ => ()
//
| D0Ctypedef (id, def) =>
    typedef_insert (id.i0de_sym, def)
  // end of [D0Ctypedef]
//
| D0Cdyncst_mac _ => ()
| D0Cdyncst_extfun _ => ()
//
| D0Cfundecl
    (fk, f0d) => emit_f0decl (out, f0d)
//
| D0Cextcode (toks) =>
  {
    val () = emit_text (out, ATSEXTCODE_BEG)
    val () = emit_extcode (out, toks)
    val () = emit_text (out, ATSEXTCODE_END)
  }
//
| D0Cclosurerize
  (
    fl, env, arg, res
  ) => emit_closurerize (out, fl, env, arg, res)
//
end // end of [emit_d0ecl]

(* ****** ****** *)
//
implement
emit_COMMENT_line (out) =
  emit_text (out, "// COMMENT_line\n")
//
implement
emit_COMMENT_block (out) = ((*ignored*))
//
(* ****** ****** *)

local

fun
aux0_arglst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "arg"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_arglst (out, s0es, n0, i+1)
  end // end of [list_cons]
) (* end of [aux0_arglst] *)

fun
aux0_envlst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "env"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_envlst (out, s0es, n0, i+1)
  end // end of [list_cons]
) (* end of [aux0_envlst] *)

fun
aux1_envlst
(
  out: FILEref
, s0es: s0explst, i: int
) : int =
(
case+ s0es of
| list_nil () => (i)
| list_cons
    (s0e, s0es) => let
    val () =
    if i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "cenv");
      emit_LBRACKET (out); emit_int (out, i+1); emit_RBRACKET (out)
    ) (* end of [val] *)
  in
    aux1_envlst (out, s0es, i+1)
  end // end of [list_cons]
) (* end of [aux1_envlst] *)

in (* in-of-local *)

implement
emit_closurerize
(
  out, fl, env, arg, res
) = let
//
val-S0Elist(s0es_env) = env.s0exp_node
val-S0Elist(s0es_arg) = arg.s0exp_node
//
val () =
emit_text (out, "function\n")
val () = emit_label (out, fl)
val () =
emit_text (out, "__closurerize(")
val () = aux0_envlst (out, s0es_env, 0, 0)
val ((*closing*)) = emit_text (out, ")\n")
//
val ((*opening*)) = emit_text (out, "{\n")
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "return [")
val () = emit_text (out, "function(")
val () = emit_text (out, "cenv")
val () = aux0_arglst (out, s0es_arg, 1, 0)
//
val () = emit_text (out, ") { return ")
val () = emit_label (out, fl)
val () = emit_LPAREN (out)
val n0 = aux1_envlst (out, s0es_env, 0)
val () = aux0_arglst (out, s0es_arg, n0, 0)
val () = emit_RPAREN (out)
val ((*closing*)) = emit_text (out, " ; }")
//
val () = aux0_envlst (out, s0es_env, 1, 0)
val ((*closing*)) = emit_text (out, "]\n")
//
val ((*closing*)) = emit_text (out, "}\n")
//
val () = emit_newline (out)
//
in
  // nothing
end // end of [emit_closurerize]

end // end of [local]

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

(* end of [atsparemit_emit_js.dats] *)


ATS stype

ATS stype

#include "share/atspre_staload.hats"

%{^
// #include <avr/io.h>
#include <util/delay.h>
%}

staload UN = "prelude/SATS/unsafe.sats"

#define DDRB_OUT       int2char0 0xff
#define PORTB_LEDON    int2char0 0xff
#define PORTB_LEDOFF   int2char0 0x00
#define BLINK_DELAY_MS 500.0

macdef DDRB_PTR  = $extval(ptr, "(0x04 + 0x20)") (* Only for Arduino Mega 2560 *)
macdef PORTB_PTR = $extval(ptr, "(0x05 + 0x20)") (* Only for Arduino Mega 2560 *)

(*
xxx Hongwei comment xxx

https://github.com/githwxi/ATS-Postiats/issues/3#issuecomment-42682765

Maybe it makes sense to introduce an abstract type here:

abstype PORTBval_t = int8
macdef PORTB_LEDON = $extval(PORTBval_t, "0xff")
macdef PORTB_LEDOFF = $extval(PORTBval_t, "0xff")

PORTB_get and PORTB_set can be implemented as templates:

extern
fun{} PORTB_get (): PORTBval_t
extern
fun{} PORTB_set (v: PORTBval_t): void

This will allow you to re-implement them for different chip models.
*)

extern fun c_delay_ms (ms: double): void = "mac#_delay_ms"

implement main0 () = {
  fun loop (): void = {
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDON)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDOFF)
    val () = c_delay_ms (BLINK_DELAY_MS)
    val () = loop ()
  }
  val () = $UN.ptr0_set<char> (DDRB_PTR, DDRB_OUT)
  val () = loop ()
}

#include "share/atspre_staload.hats"

%{^
// #include <avr/io.h>
#include <util/delay.h>
%}

staload UN = "prelude/SATS/unsafe.sats"

#define DDRB_OUT       int2char0 0xff
#define PORTB_LEDON    int2char0 0xff
#define PORTB_LEDOFF   int2char0 0x00
#define BLINK_DELAY_MS 500.0

macdef DDRB_PTR  = $extval(ptr, "(0x04 + 0x20)") (* Only for Arduino Mega 2560 *)
macdef PORTB_PTR = $extval(ptr, "(0x05 + 0x20)") (* Only for Arduino Mega 2560 *)

extern fun c_delay_ms (ms: double): void = "mac#_delay_ms"

fun loop (): void = begin
  $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDON);
  c_delay_ms (BLINK_DELAY_MS);
  $UN.ptr0_set<char> (PORTB_PTR, PORTB_LEDOFF);
  c_delay_ms (BLINK_DELAY_MS);
  loop ();
end

implement main0 () = begin
  $UN.ptr0_set<char> (DDRB_PTR, DDRB_OUT);
  loop ();
end


Updating: minorly tidying-up

Updating: minorly tidying-up

(*
** A simple implementation of
** Game-of-24 in ATS for use in Java
*)

(* ****** ****** *)
//
// HX: no dynloading
//
#define ATS_DYNLOADFLAG 0
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
local
#include "./../GameOf24_card.dats"
in end
local
#include "./../GameOf24_cardset.dats"
in end
local
#include "./../GameOf24_solve.dats"
in end
//
(* ****** ****** *)

staload
UN =
"prelude/SATS/unsafe.sats"

(* ****** ****** *)
//
staload
JNI = "{$JNI}/SATS/jni.sats"
//
stadef jint = $JNI.jint
stadef JNIEnvPtr = $JNI.JNIEnvPtr
stadef jstring (l:addr) = $JNI.jstring(l)
stadef jobject (l:addr) = $JNI.jobject(l)
//
(* ****** ****** *)

staload "./../GameOf24.sats"

(* ****** ****** *)
//
// HX-2013-08:
// [play24] is declared in Java class [GameOf24]
//
extern
fun
JNI_play24
  {l:addr}
(
  env: !JNIEnvPtr
, obj: jobject (l)
, n1: jint, n2: jint, n3: jint, n4: jint
) : void = "ext#Java_GameOf24_play24" // endfun

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

implement
JNI_play24
(
  env, obj, n1, n2, n3, n4
) = let
//
val n1 = $UN.cast{int}(n1)
val n2 = $UN.cast{int}(n2)
val n3 = $UN.cast{int}(n3)
val n4 = $UN.cast{int}(n4)
//
val out = stdout_ref
val res = play24 (n1, n2, n3, n4)
val (
) = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
//
in
//
case+ res of
| list_cons _ =>
  (
    fpprint_cardlst (out, res); fprint_newline (out)
  )
| list_nil () =>
  {
    val () = fprintln! (out, "There is NO solution.")
  }
//
end // end of [JNI_play24]

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

%{$
//
// HX: This is ATS runtime:
//
#include "pats_ccomp_runtime.c"
#include "pats_ccomp_runtime2_dats.c"
#include "pats_ccomp_runtime_memalloc.c"
#include "pats_ccomp_runtime_trywith.c"
%}

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

(* end of [GameOf24.dats] *)

(*
** A simple implementation of
** Game-of-24 in ATS for use in Java
*)

(* ****** ****** *)
//
// HX: no dynloading
//
#define ATS_DYNLOADFLAG 0
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
local
#include "../GameOf24_card.dats"
in (*nothing*) end
//
local
#include "../GameOf24_cardset.dats"
in (*nothing*) end
//
local
#include "../GameOf24_solve.dats"
in (*nothing*) end
//
(* ****** ****** *)

staload "../GameOf24.sats"

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

staload
UN = "prelude/SATS/unsafe.sats"

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

staload JNI = "{$JNI}/SATS/jni.sats"

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

stadef jint = $JNI.jint

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

stadef JNIEnvPtr = $JNI.JNIEnvPtr
stadef jstring (l:addr) = $JNI.jstring(l)
stadef jobject (l:addr) = $JNI.jobject(l)

(* ****** ****** *)
//
// HX-2013-08:
// [play24] is declared in Java class [GameOf24]
//
extern
fun
JNI_play24
  {l:addr}
(
  env: !JNIEnvPtr
, obj: jobject (l)
, n1: jint, n2: jint, n3: jint, n4: jint
) : void = "ext#Java_GameOf24_play24" // endfun

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

implement
JNI_play24
(
  env, obj, n1, n2, n3, n4
) = let
//
val n1 = $UN.cast{int}(n1)
val n2 = $UN.cast{int}(n2)
val n3 = $UN.cast{int}(n3)
val n4 = $UN.cast{int}(n4)
//
val out = stdout_ref
val res = play24 (n1, n2, n3, n4)
val (
) = fprintln! (out, "play24(", n1, ", ", n2, ", ", n3, ", ", n4, "):")
//
in
//
case+ res of
| list_cons _ =>
  (
    fpprint_cardlst (out, res); fprint_newline (out)
  )
| list_nil () =>
  {
    val () = fprintln! (out, "There is NO solution.")
  }
//
end // end of [JNI_play24]

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

%{$
//
// HX: This is ATS runtime:
//
#include "pats_ccomp_runtime.c"
#include "pats_ccomp_runtime2_dats.c"
#include "pats_ccomp_runtime_memalloc.c"
#include "pats_ccomp_runtime_trywith.c"
%}

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

(* end of [GameOf24.dats] *)


Small changes

Small changes

(**
  Some examples that implement and prove correctness of
  bit twiddling hacks from the following page.

  https://graphics.stanford.edu/~seander/bithacks.html
*)

staload "contrib/libats-/wdblair/patsolve/SATS/bitvector.sats"
staload "contrib/libats-/wdblair/prelude/SATS/integer.sats"

(**
  Assume we're only working with 32 bit numbers in this file.
*)
macdef int2bv = bv32_of_int
macdef bool2bv = bv32_of_bool

fun
min {x,y:bv32} (
  x: int (x), y: int (y)
): int (min(x, y)) =
  y lxor ((x lxor y) land ~bool2bv(x < y))

fun
max {x,y:bv32} (
  x: int (x), y: int (y)
): int (max(x, y)) =
  x lxor ((x lxor y) land ~bool2bv(x < y))

fun
swap {x,y:bv32} (
  x: &int (x) >> int (y), y: &int (y) >> int (x)
): void = {
  val () =  x := x lxor y
  val () =  y := y lxor x
  val () =  x := x lxor y
}

fun
swap_bits {b:bv32} {i,j,n:nat | i + n < 32; j + n < 32; abs(i - j) >  n} (
  b: int (b), i: int i, j: int j, n: int n
): int (swap (b, bv32(i), bv32(j), bv32(n))) = let
  val i = int2bv (i)
  val j = int2bv (j)
  val n = int2bv (n)
  val one = int2bv(1)
  //
  val mask = (one << n) - one
  val x = ((b >> i) lxor (b >> j)) land mask
  val r = b lxor ((x << i) lor (x << j))
  //
in
  r
end

fun
is_power_of_two {x:bv32} (
  x: int(x)
): bool (is_power_of_2 (x)) =
  if x = 0 then
    false
  else
    ((x land (x - 1)) = 0)

fun
has_zero_byte {x:bv32} (
  x: int (x)
): bool (has_zero_byte(x)) =
  ~(((x - 0x01010101) land (lnot(x) land 0x80808080)) = 0)

fun
has_byte {x,n:bv32} (
  x: int (x), n: int (n)
): bool (has_byte(x, n)) = let
  val test = x lxor (int2bv(0x01010101) * (n land int2bv(0xFF)))
in
  has_zero_byte (test)
end

(**
  Some examples that implement and prove correctness of
  bit twiddling hacks from the following page.

  https://graphics.stanford.edu/~seander/bithacks.html
*)

staload "contrib/libats-/wdblair/patsolve/SATS/bitvector.sats"
staload "contrib/libats-/wdblair/prelude/SATS/integer.sats"

(**
  Assume we're only working with 32 bit numbers in this file.
*)
macdef int2bv = bv32_of_int
macdef bool2bv = bv32_of_bool

fun
min {x,y:bv32} (
  x: int (x), y: int (y)
): int (min(x, y)) =
  y lxor ((x lxor y) land ~bool2bv(x < y))

fun
max {x,y:bv32} (
  x: int (x), y: int (y)
): int (max(x, y)) =
  x lxor ((x lxor y) land ~bool2bv(x < y))

fun
swap {x,y:bv32} (
  x: &int (x) >> int (y), y: &int (y) >> int (x)
): void = {
  val () =  x := x lxor y
  val () =  y := y lxor x
  val () =  x := x lxor y
}

fun
swap_bits {b:bv32} {i,j,n:nat | i + n < 32; j + n < 32; abs(i - j) >  n} (
  b: int (b), i: int i, j: int j, n: int n
): int (swap (b, bv32(i), bv32(j), bv32(n))) = let
  val i = int2bv (i)
  val j = int2bv (j)
  val n = int2bv (n)
  val one = int2bv(1)
  //
  val mask = (one << n) - one
  val x = ((b >> i) lxor (b >> j)) land mask
  val r = b lxor ((x << i) lor (x << j))
  //
in
  r
end

fun
is_power_of_two {x:bv32} (
  x: int(x)
): bool (is_power_of_2 (x)) =
  if x = 0 then
    false
  else
    ((x land (x - 1)) = 0)

fun
has_zero_byte {x:bv32} (
  x: int (x)
): bool (has_zero_byte(x)) =
  ~(((x - 0x01010101) land (lnot(x) land 0x80808080)) = 0)

fun
has_byte {x,n:bv32} (
  x: int (x), n: int (n)
): bool (has_byte(x, n)) = let
  val test = x lxor (~int2bv(0)/int2bv(255) * (n land int2bv(0xFF)))
in
  has_zero_byte (test)
end