Questions to myself.

Questions to myself.

(* ****** ****** *)
//
// ATS-parse-emit-python
//
(* ****** ****** *)
//
// AS-2014-08-17: 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_topenv.dats"
//
(* ****** ****** *)

fn
symbol_is_arg (x: symbol) :<> bool = let
  val name = g1ofg0_string (symbol_get_name (x))
in
  if strlen (name) >= 4 then
   string_get_at (name, 0) = 'a' && string_get_at (name, 1) = 'r' && string_get_at (name, 2) = 'g'
   && isdigit (string_get_at (name, 3))
  else false
end // end of [symbol_is_arg]

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

implement
emit_ENDL (out) = emit_text (out, "\n")

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

implement
emit_SPACE (out) = emit_text (out, " ")

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

implement
emit_SHARP (out) = emit_text (out, "#")

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

implement
emit_LPAREN (out) = emit_text (out, "(")
implement
emit_RPAREN (out) = emit_text (out, ")")

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

implement
emit_LBRACE (out) = emit_text (out, "{")
implement
emit_RBRACE (out) = emit_text (out, "}")

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

implement
emit_LBRACKET (out) = emit_text (out, "[")
implement
emit_RBRACKET (out) = emit_text (out, "]")

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

implement
emit_flush (out) = fileref_flush (out)
implement
emit_newline (out) = fprint_newline (out)

(* ****** ****** *)
//
implement
emit_int (out, x) = fprint_int (out, x)
//
implement
emit_text (out, x) = fprint_string (out, x)
//
(* ****** ****** *)
//
implement
emit_symbol (out, x) =
  fprint_string (out, symbol_get_name (x))
//
(* ****** ****** *)

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_PMVi0nt
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVi0nt]

(* ****** ****** *)
//
implement
emit_PMVbool
  (out, tfv) =
(
  emit_text (out, if tfv then "1" else "0")
) (* 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_i0de
  (out, id) = emit_symbol (out, id.i0de_sym)
implement
emit_label
  (out, lab) = emit_symbol (out, lab.i0de_sym)
//
(* ****** ****** *)
//
extern
fun emit_instrlst
  (out: FILEref, inss: instrlst) : void
//
extern
fun
emit_s0exp : emit_type (s0exp)
extern
fun
emit_s0explst : emit_type (s0explst)
//
(* ****** ****** *)
//
implement
emit_s0exp
  (out, s0e) = let
//
//
in
//
case+
s0e.s0exp_node of
//
| S0Eide (id) => emit_symbol (out, id)
| S0Elist (s0es) => () // shouldn't happen? marked as "temp"
| S0Eappid (id, s0es) =>
    // FIXME: what about other types? e.g. array types? struct types?
    () where {
      val () = emit_i0de (out, id)
      val () = emit_LPAREN (out)
      val () = emit_s0explst (out, s0es)
      val () = emit_RPAREN (out)
    }
//
end // end of [emit_s0exp]
//
(* ****** ****** *)

implement
emit_s0explst
  (out, s0es) = let
//
fun
loop
(
  out: FILEref, s0es: s0explst, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons (s0e, s0es) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_s0exp (out, s0e); loop (out, s0es, i+1)
  end // end of [list_cons]
)
//
in
  loop (out, s0es, 0)
end // end of [emit_s0explst]

(* ****** ****** *)
//
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 (labs: 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 (xs) = !the_branchlablst := xs

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

end // end of [local]

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

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_newline (out)
    // end of [val]
  in
    emit_d0exp (out, d0e);
    emit_newline (out);
    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]

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

implement
emit_d0exp
  (out, d0e) = let
in
//
case+
d0e.d0exp_node of
//
| D0Eide (id) =>
  {
    val () =
      if symbol_is_arg (id)
        then emit_text (out, "ldarg")
        else emit_text (out, "ldloc")
    // end of [val]
    val () = emit_SPACE (out)
    val () = emit_symbol (out, id)
  }
//
| D0Eappid (id, d0es) =>
  {
    val () = emit_d0explst (out, d0es)
    val () = emit_text (out, "call")
    val () = emit_SPACE (out)
    val () = emit_i0de (out, id) // FIXME: need also type of [id]!
  }
//
//
| ATSPMVint (tok) =>
  {
    val () = emit_text (out, "ldc.i4")
    val () = emit_SPACE (out)
    val () = emit_PMVint (out, tok)
  } (* end of [ATSPMVint] *)
| ATSPMVi0nt (tok) =>
  {
    val () = emit_text (out, "ldc.i4")
    val () = emit_SPACE (out)
    val () = emit_PMVi0nt (out, tok)
  } (* end of [ATSPMVi0nt] *)
//
| ATSPMVbool (tfv) =>
  {
    val () = emit_text (out, "ldc.i4")
    val () = emit_SPACE (out)
    val () = emit_PMVbool (out, tfv)
  } (* end of [ATSPMVbool] *)
//
| ATSPMVstring (tok) =>
  {
    val () = emit_text (out, "ldstr")
    val () = emit_SPACE(out)
    val () = emit_PMVstring (out, tok)
  } (* end of [ATSPMVstring] *)
//
| ATSPMVf0loat (tok) => emit_text (out, "ATSPMVf0loat(...)")
//
| _ => ()
//
end // end of [emit_d0exp]

(* ****** ****** *)
//
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)
//
(* ****** ****** *)

implement
emit_f0arg
  (out, f0a) = let
in
//
case+
f0a.f0arg_node of
//
| F0ARGnone s0e => emit_text (out, "__NONE__") // FIXME: how to emit type decl?
| F0ARGsome (id, s0e) =>
  {
    val () = emit_s0exp (out, s0e)
    val () = emit_SPACE (out)
    val () = emit_i0de (out, id)
  } (* end of [F0ARGsome] *)
//
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
    (id(*name of function*), f0ma(*list of arguments*), res(*result type*)) =>
  {
    val () = emit_s0exp (out, res)
    val () = emit_SPACE (out)
    val () = emit_i0de (out, id)
    val () = emit_LPAREN (out)
    val () = emit_f0marg (out, f0ma)
    val () = emit_RPAREN (out)
  }
//
end // end of [emit_f0head]

(* ****** ****** *)
//
extern
fun
emit_tmpdeclst
  (out: FILEref, tds: tmpdeclst): void
//
implement
emit_tmpdeclst
  (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) // probably ATStmpdec_void()
    | TMPDECsome
        (tmp, s0e) => let
        val () =
          if i > 0 then
            emit_text(out, ", ")
        // end of [val]
        val () = emit_s0exp (out, s0e)
        val () = emit_SPACE (out)
        val () = emit_i0de (out, tmp)
        val () = emit_newline (out)
      in
        auxlst (out, tds, i+1)
      end // end of [TMPDECsome]
  ) (* end of [list_cons] *)
)
//
in
  auxlst (out, tds, 0)
end // end of [emit_tmpdeclst_initize]
//
(* ****** ****** *)
//
extern
fun emit_instr
  (out: FILEref, ins: instr) : void
//
implement
emit_instr
  (out, ins0) = let
in
//
case+
ins0.instr_node of
//
| ATSif
  (
    d0e(*test*), inss(*then*), inssopt(*else*)
  ) =>
  {
    // TODO: labels must be assigned automatically... but how?
    val () = emit_d0exp (out, d0e)
    val () = emit_newline (out)
    val () = emit_text (out, "brfalse L1")
    val () = emit_newline (out)
    val () = emit_instrlst (out, inss)
    val () =
    (
      case+ inssopt of
      | Some(inss) =>
        {
          val () = emit_text (out, "br L2")
          val () = emit_newline (out)
          val () = emit_text (out, "L1:")
          val () = emit_newline (out)
          val () = emit_instrlst (out, inss)
        }
      | None((*void*)) => ()
    )
    val () = emit_text (out, "L2:") // next instruction, whatever it may be
    val () = emit_newline (out)
  } (* end of [ATSif] *)
// TODO: ATSifthen, ATSifnthen, ATScaseofseq, ATSbranchseq
// TODO: ATSlinepragma
//
| ATSreturn (tmp) =>
  {
    // FIXME: if tmp is actually funarg, we must use ldarg
    val () = emit_text (out, "ldloc")
    val () = emit_SPACE (out)
    val () = emit_i0de (out, tmp)
    val () = emit_newline (out)
    val () = emit_text (out, "ret")
  }
//
| ATSreturn_void (tmp) =>
  {
    val () = emit_text (out, "ret")
  }
//
| ATSlinepragma (line, file) =>
  {
    // skip
  }
//
| ATSINSlab (lab) =>
  {
    val () = emit_label (out, lab)
    val () = emit_text (out, ":")
  }
//
| ATSINSgoto (lab) =>
  {
    val () = emit_text (out, "br")
    val () = emit_SPACE (out)
    val () = emit_label (out, lab)
  }
//
| ATSINSflab (flab) =>
  {
    val () = emit_label (out, flab)
    val () = emit_text (out, ":")
  }
//
| ATSINSfgoto (flab) =>
  {
    val () = emit_text (out, "br")
    val () = emit_SPACE (out)
    val () = emit_label (out, flab)
  }
//
| ATSINSmove (tmp, d0e) =>
  {
    val () = emit_d0exp (out, d0e)
    val () = emit_newline (out)
    val () =
      if symbol_is_arg (tmp.i0de_sym)
        then emit_text (out, "starg")
        else emit_text (out, "stloc")
    // end of [val]
    val () = emit_SPACE (out)
    val () = emit_i0de (out, tmp)
  } (* end of [ATSINSmove] *)
| ATSINSmove_void (_, d0e) =>
  {
    val () = emit_d0exp (out, d0e)
  } (* end of [ATSINSmove_void] *)
// TODO: ATSdynload0, ATSdynload1, ATSdynloadset
//
| _ =>
  {
    val () = emit_text (out, "**INSTR**")
  }
//
end // end of [emit_instr]

(* ****** ****** *)
implement
emit_instrlst
(
  out, inss
) = (
//
case+ inss of
| list_nil () => ()
| list_cons (ins, inss) =>
  {
    val () = emit_instr (out, ins)
    val () = emit_ENDL (out)
    val () = emit_instrlst (out, inss)
  }
//
) (* end of [emit_instrlst] *)

(* ****** ****** *)
//
extern
fun emit_ATSfunbodyseq
  (out: FILEref, ins: instr) : void
//
implement
emit_ATSfunbodyseq
  (out, ins) = let
//
val-ATSfunbodyseq (inss) = ins.instr_node
//
in
  emit_instrlst (out, inss)
end // end of [emit_ATSfunbodyseq]

(* ****** ****** *)
//
extern
fun emit_f0body_0 : emit_type (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 () = emit_ATSfunbodyseq (out, ins0)
    val () = emit_instr (out, 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
  (out, fbody) = let
//
val tmpdecs =
  f0body_get_tmpdeclst (fbody)
//
val () = the_tmpdeclst_set (tmpdecs)
val () = emit_LBRACE (out)
val () = emit_newline (out)
// TODO: how to compute maxstack?
val () = emit_text (out, ".maxstack 1")
val () = emit_newline (out)
// emit locals
val () = emit_text (out, ".locals")
val () = emit_SPACE (out)
val () = emit_text (out, "init")
val () = emit_SPACE (out)
val () = emit_LPAREN (out)
val () = emit_newline (out)
val () = emit_tmpdeclst (out, tmpdecs)
val () = emit_RPAREN (out)
val () = emit_newline (out)
// .locals init (
//    class [Mono.Cecil]Mono.Cecil.AssemblyNameDefinition V_0,
//    int32 V_1
// )
val () = emit_f0body_0 (out, fbody)
val () = emit_newline (out)
val () = emit_RBRACE (out)
in
//
//
end // end of [emit_f0body]

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

implement
emit_f0decl
  (out, fdec) = let
in
//
case+
fdec.f0decl_node of
| F0DECLnone (fhd) =>
  // does this actually mean function declaration (e.g. forward function decl)?
  ()
| F0DECLsome (fhd, fbody) =>
  {
    val () = emit_text (out, ".method")
    val () = emit_SPACE (out)
    val () = emit_text (out, "static")
    // TODO: public/private?
    // static -> private
    val () = emit_SPACE (out)
    val () = emit_text (out, "public")
    val () = emit_SPACE (out)
    // FIXME: where is the type of this function??
    // TODO: use
    val () = emit_f0head (out, fhd)
    val () = emit_SPACE (out)
    val () = emit_text (out, "cil")
    val () = emit_SPACE (out)
    val () = emit_text (out, "managed")
    val () = emit_newline (out)
    val () = emit_f0body (out, fbody)
    val () = emit_newline (out)
  } (* end of [F0DECLsome] *)
//
end // end of [emit_f0decl]

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

//
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]

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

implement
emit_d0ecl
  (out, d0c) = let
in
//
case+
d0c.d0ecl_node of
//
| D0Cinclude include =>
  {
    val () = emit_text (out, "#include")
    val () = emit_SPACE (out)
//    val () = emit_text (out, include)
    val () = emit_newline (out)
  }
//
| D0Cifdef (i0de, d0eclist) =>
  {
    val () = emit_text (out, "#ifdef")
    val () = emit_SPACE (out)
    val () = emit_newline (out)
  }
| D0Cifndef (i0de, d0eclist) =>
  {
    val () = emit_text (out, "#ifndef")
    val () = emit_SPACE (out)
    val () = emit_newline (out)
  }
//
| D0Ctypedef (id, def) =>
  {
    val () = typedef_insert (id.i0de_sym, def)
  } (* end of [D0Ctypedef] *)
//
| D0Cdyncst_mac i0de => ()
| D0Cdyncst_extfun (i0de, s0explst, s0exp) => ()
//
| D0Cfundecl (fk, f0d) => emit_f0decl (out, f0d)
//
end // end of [emit_d0ecl]

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

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

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

(* end of [atsparemit_emit_cil.dats] *)

(* ****** ****** *)
//
// ATS-parse-emit-python
//
(* ****** ****** *)
//
// AS-2014-08-17: 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_topenv.dats"
//
(* ****** ****** *)

fn
symbol_is_arg (x: symbol) :<> bool = let
  val name = g1ofg0_string (symbol_get_name (x))
in
  if strlen (name) >= 4 then
   string_get_at (name, 0) = 'a' && string_get_at (name, 1) = 'r' && string_get_at (name, 2) = 'g'
   && isdigit (string_get_at (name, 3))
  else false
end // end of [symbol_is_arg]

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

implement
emit_ENDL (out) = emit_text (out, "\n")

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

implement
emit_SPACE (out) = emit_text (out, " ")

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

implement
emit_SHARP (out) = emit_text (out, "#")

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

implement
emit_LPAREN (out) = emit_text (out, "(")
implement
emit_RPAREN (out) = emit_text (out, ")")

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

implement
emit_LBRACE (out) = emit_text (out, "{")
implement
emit_RBRACE (out) = emit_text (out, "}")

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

implement
emit_LBRACKET (out) = emit_text (out, "[")
implement
emit_RBRACKET (out) = emit_text (out, "]")

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

implement
emit_flush (out) = fileref_flush (out)
implement
emit_newline (out) = fprint_newline (out)

(* ****** ****** *)
//
implement
emit_int (out, x) = fprint_int (out, x)
//
implement
emit_text (out, x) = fprint_string (out, x)
//
(* ****** ****** *)
//
implement
emit_symbol (out, x) =
  fprint_string (out, symbol_get_name (x))
//
(* ****** ****** *)

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_PMVi0nt
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVi0nt]

(* ****** ****** *)
//
implement
emit_PMVbool
  (out, tfv) =
(
  emit_text (out, if tfv then "1" else "0")
) (* 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_i0de
  (out, id) = emit_symbol (out, id.i0de_sym)
implement
emit_label
  (out, lab) = emit_symbol (out, lab.i0de_sym)
//
(* ****** ****** *)
//
extern
fun emit_instrlst
  (out: FILEref, inss: instrlst) : void
//
extern
fun
emit_s0exp : emit_type (s0exp)
extern
fun
emit_s0explst : emit_type (s0explst)
//
(* ****** ****** *)
//
implement
emit_s0exp
  (out, s0e) = let
//
//
in
//
case+
s0e.s0exp_node of
//
| S0Eide (id) => emit_symbol (out, id)
| S0Elist (s0es) => () // shouldn't happen? marked as "temp"
| S0Eappid (id, s0es) =>
    // FIXME: what about other types? e.g. array types? struct types?
    () where {
      val () = emit_i0de (out, id)
      val () = emit_LPAREN (out)
      val () = emit_s0explst (out, s0es)
      val () = emit_RPAREN (out)
    }
//
end // end of [emit_s0exp]
//
(* ****** ****** *)

implement
emit_s0explst
  (out, s0es) = let
//
fun
loop
(
  out: FILEref, s0es: s0explst, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons (s0e, s0es) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_s0exp (out, s0e); loop (out, s0es, i+1)
  end // end of [list_cons]
)
//
in
  loop (out, s0es, 0)
end // end of [emit_s0explst]

(* ****** ****** *)
//
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 (labs: 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 (xs) = !the_branchlablst := xs

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

end // end of [local]

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

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_newline (out)
    // end of [val]
  in
    emit_d0exp (out, d0e);
    emit_newline (out);
    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]

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

implement
emit_d0exp
  (out, d0e) = let
in
//
case+
d0e.d0exp_node of
//
| D0Eide (id) =>
  {
    val () =
      if symbol_is_arg (id)
        then emit_text (out, "ldarg")
        else emit_text (out, "ldloc")
    // end of [val]
    val () = emit_SPACE (out)
    val () = emit_symbol (out, id)
  }
//
| D0Eappid (id, d0es) =>
  {
    val () = emit_d0explst (out, d0es)
    val () = emit_text (out, "call")
    val () = emit_SPACE (out)
    val () = emit_i0de (out, id) // FIXME: need also type of [id]!
  }
//
//
| ATSPMVint (tok) =>
  {
    val () = emit_text (out, "ldc.i4")
    val () = emit_SPACE (out)
    val () = emit_PMVint (out, tok)
  } (* end of [ATSPMVint] *)
| ATSPMVi0nt (tok) =>
  {
    val () = emit_text (out, "ldc.i4")
    val () = emit_SPACE (out)
    val () = emit_PMVi0nt (out, tok)
  } (* end of [ATSPMVi0nt] *)
//
| ATSPMVbool (tfv) =>
  {
    val () = emit_text (out, "ldc.i4")
    val () = emit_SPACE (out)
    val () = emit_PMVbool (out, tfv)
  } (* end of [ATSPMVbool] *)
//
| ATSPMVstring (tok) =>
  {
    val () = emit_text (out, "ldstr")
    val () = emit_SPACE(out)
    val () = emit_PMVstring (out, tok)
  } (* end of [ATSPMVstring] *)
//
| ATSPMVf0loat (tok) => emit_text (out, "ATSPMVf0loat(...)")
//
| _ => ()
//
end // end of [emit_d0exp]

(* ****** ****** *)
//
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)
//
(* ****** ****** *)

implement
emit_f0arg
  (out, f0a) = let
in
//
case+
f0a.f0arg_node of
//
| F0ARGnone s0e => emit_text (out, "__NONE__") // FIXME: how to emit type decl?
| F0ARGsome (id, s0e) =>
  {
    val () = emit_s0exp (out, s0e)
    val () = emit_SPACE (out)
    val () = emit_i0de (out, id)
  } (* end of [F0ARGsome] *)
//
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
    (id(*name of function*), f0ma(*list of arguments*), res(*result type*)) =>
  {
    val () = emit_s0exp (out, res)
    val () = emit_SPACE (out)
    val () = emit_i0de (out, id)
    val () = emit_LPAREN (out)
    val () = emit_f0marg (out, f0ma)
    val () = emit_RPAREN (out)
  }
//
end // end of [emit_f0head]

(* ****** ****** *)
//
extern
fun
emit_tmpdeclst
  (out: FILEref, tds: tmpdeclst): void
//
implement
emit_tmpdeclst
  (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) // probably ATStmpdec_void()
    | TMPDECsome
        (tmp, s0e) => let
        val () =
          if i > 0 then
            emit_text(out, ", ")
        // end of [val]
        val () = emit_s0exp (out, s0e)
        val () = emit_SPACE (out)
        val () = emit_i0de (out, tmp)
        val () = emit_newline (out)
      in
        auxlst (out, tds, i+1)
      end // end of [TMPDECsome]
  ) (* end of [list_cons] *)
)
//
in
  auxlst (out, tds, 0)
end // end of [emit_tmpdeclst_initize]
//
(* ****** ****** *)
//
extern
fun emit_instr
  (out: FILEref, ins: instr) : void
//
implement
emit_instr
  (out, ins0) = let
in
//
case+
ins0.instr_node of
//
| ATSif
  (
    d0e(*test*), inss(*then*), inssopt(*else*)
  ) =>
  {
    // TODO: labels must be assigned automatically... but how?
    val () = emit_d0exp (out, d0e)
    val () = emit_newline (out)
    val () = emit_text (out, "brfalse L1")
    val () = emit_newline (out)
    val () = emit_instrlst (out, inss)
    val () =
    (
      case+ inssopt of
      | Some(inss) =>
        {
          val () = emit_text (out, "br L2")
          val () = emit_newline (out)
          val () = emit_text (out, "L1:")
          val () = emit_newline (out)
          val () = emit_instrlst (out, inss)
        }
      | None((*void*)) => ()
    )
    val () = emit_text (out, "L2:") // next instruction, whatever it may be
    val () = emit_newline (out)
  } (* end of [ATSif] *)
// TODO: ATSifthen, ATSifnthen, ATScaseofseq, ATSbranchseq
// TODO: ATSlinepragma
//
| ATSreturn (tmp) =>
  {
    // FIXME: if tmp is actually funarg, we must use ldarg
    val () = emit_text (out, "ldloc")
    val () = emit_SPACE (out)
    val () = emit_i0de (out, tmp)
    val () = emit_newline (out)
    val () = emit_text (out, "ret")
  }
//
| ATSreturn_void (tmp) =>
  {
    val () = emit_text (out, "ret")
  }
//
| ATSlinepragma (line, file) =>
  {
    // skip
  }
//
| ATSINSlab (lab) =>
  {
    val () = emit_label (out, lab)
    val () = emit_text (out, ":")
  }
//
| ATSINSgoto (lab) =>
  {
    val () = emit_text (out, "br")
    val () = emit_SPACE (out)
    val () = emit_label (out, lab)
  }
//
| ATSINSflab (flab) =>
  {
    val () = emit_label (out, flab)
    val () = emit_text (out, ":")
  }
//
| ATSINSfgoto (flab) =>
  {
    val () = emit_text (out, "br")
    val () = emit_SPACE (out)
    val () = emit_label (out, flab)
  }
//
| ATSINSmove (tmp, d0e) =>
  {
    val () = emit_d0exp (out, d0e)
    val () = emit_newline (out)
    val () =
      if symbol_is_arg (tmp.i0de_sym)
        then emit_text (out, "starg")
        else emit_text (out, "stloc")
    // end of [val]
    val () = emit_SPACE (out)
    val () = emit_i0de (out, tmp)
  } (* end of [ATSINSmove] *)
| ATSINSmove_void (_, d0e) =>
  {
    val () = emit_d0exp (out, d0e)
  } (* end of [ATSINSmove_void] *)
// TODO: ATSdynload0, ATSdynload1, ATSdynloadset
//
| _ =>
  {
    val () = emit_text (out, "**INSTR**")
  }
//
end // end of [emit_instr]

(* ****** ****** *)
implement
emit_instrlst
(
  out, inss
) = (
//
case+ inss of
| list_nil () => ()
| list_cons (ins, inss) =>
  {
    val () = emit_instr (out, ins)
    val () = emit_ENDL (out)
    val () = emit_instrlst (out, inss)
  }
//
) (* end of [emit_instrlst] *)

(* ****** ****** *)
//
extern
fun emit_ATSfunbodyseq
  (out: FILEref, ins: instr) : void
//
implement
emit_ATSfunbodyseq
  (out, ins) = let
//
val-ATSfunbodyseq (inss) = ins.instr_node
//
in
  emit_instrlst (out, inss)
end // end of [emit_ATSfunbodyseq]

(* ****** ****** *)
//
extern
fun emit_f0body_0 : emit_type (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 () = emit_ATSfunbodyseq (out, ins0)
    val () = emit_instr (out, 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
  (out, fbody) = let
//
val tmpdecs =
  f0body_get_tmpdeclst (fbody)
//
val () = the_tmpdeclst_set (tmpdecs)
val () = emit_LBRACE (out)
val () = emit_newline (out)
// TODO: how to compute maxstack?
val () = emit_text (out, ".maxstack 1")
val () = emit_newline (out)
// emit locals
val () = emit_text (out, ".locals")
val () = emit_SPACE (out)
val () = emit_text (out, "init")
val () = emit_SPACE (out)
val () = emit_LPAREN (out)
val () = emit_newline (out)
val () = emit_tmpdeclst (out, tmpdecs)
val () = emit_RPAREN (out)
val () = emit_newline (out)
// .locals init (
//    class [Mono.Cecil]Mono.Cecil.AssemblyNameDefinition V_0,
//    int32 V_1
// )
val () = emit_f0body_0 (out, fbody)
val () = emit_newline (out)
val () = emit_RBRACE (out)
in
//
//
end // end of [emit_f0body]

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

implement
emit_f0decl
  (out, fdec) = let
in
//
case+
fdec.f0decl_node of
| F0DECLnone (fhd) =>
  // does this actually mean function declaration (e.g. forward function decl)?
  ()
| F0DECLsome (fhd, fbody) =>
  {
    val () = emit_text (out, ".method")
    val () = emit_SPACE (out)
    val () = emit_text (out, "static")
    // TODO: public/private?
    val () = emit_SPACE (out)
    val () = emit_text (out, "public")
    val () = emit_SPACE (out)
    // FIXME: where is the type of this function??
    val () = emit_f0head (out, fhd)
    val () = emit_SPACE (out)
    val () = emit_text (out, "cil")
    val () = emit_SPACE (out)
    val () = emit_text (out, "managed")
    val () = emit_newline (out)
    val () = emit_f0body (out, fbody)
    val () = emit_newline (out)
  } (* end of [F0DECLsome] *)
//
end // end of [emit_f0decl]

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

//
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]

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

implement
emit_d0ecl
  (out, d0c) = let
in
//
case+
d0c.d0ecl_node of
//
| D0Cinclude include =>
  {
    val () = emit_text (out, "#include")
    val () = emit_SPACE (out)
//    val () = emit_text (out, include)
    val () = emit_newline (out)
  }
//
| D0Cifdef (i0de, d0eclist) =>
  {
    val () = emit_text (out, "#ifdef")
    val () = emit_SPACE (out)
    val () = emit_newline (out)
  }
| D0Cifndef (i0de, d0eclist) =>
  {
    val () = emit_text (out, "#ifndef")
    val () = emit_SPACE (out)
    val () = emit_newline (out)
  }
//
| D0Ctypedef (id, def) =>
  {
    val () = typedef_insert (id.i0de_sym, def)
  } (* end of [D0Ctypedef] *)
//
| D0Cdyncst_mac i0de => ()
| D0Cdyncst_extfun (i0de, s0explst, s0exp) => ()
//
| D0Cfundecl (fk, f0d) => emit_f0decl (out, f0d)
//
end // end of [emit_d0ecl]

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

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

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

(* end of [atsparemit_emit_cil.dats] *)


Updating: working on chardev-1

Updating: working on chardev-1

(*
** A simple char device
*)

(* ****** ****** *)
//
// HX-2014-10-24:
// nothing fancy here;
// just trying to get it working
//
(* ****** ****** *)
//
// HX-2014-10-21:
// no use for dynloading
//
#define ATS_DYNLOADFLAG 0
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$KERNELATS}/prelude/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/basics.sats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/SATS/errno.sats"
staload
"{$LINUX}/SATS/types.sats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/SATS/init.sats"
staload
"{$LINUX}/SATS/module.sats"
staload
"{$LINUX}/SATS/kernel.sats"
staload $PRINTK // HX: opening NS
//
staload "{$LINUX}/SATS/fs.sats"
//
staload "{$LINUX}/SATS/asm/uaccess.sats"
//
(* ****** ****** *)

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

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

%{^
MODULE_LICENSE("Dual BSD/GPL") ;
%} // end of [%{^]

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

static
fun init_module(): interr = "mac#"
static
fun cleanup_module(): void = "mac#"

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

%{^
static int Major = 0;
static int Device_open = 0;
static int Device_open_count = 0;
%} // end of [%{^]

macdef
Major = $extval(int, "Major")
macdef
Device_open = $extval(int, "Device_open")
macdef
Device_open_count = $extval(int, "Device_open_count")

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

%{^
#define BUFLEN 80 // Max length of the message from the device
#define DEVICE_NAME "chardev-1" /* Dev name as it appears in /proc/devices */
//
typedef
char *charptr ;
char Message[BUFLEN];
charptr Message0_ptr = &Message[0];
charptr Message1_ptr = &Message[0];
//
%} // end of [%{^]

typedef charptr = $extype"charptr"

macdef
DEVICE_NAME = $extval(string, "DEVICE_NAME")
macdef
Message0_ptr = $extval(charptr, "Message0_ptr")
macdef
Message1_ptr = $extval(charptr, "Message1_ptr")

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

%{^
//
static int device_open(struct inode *, struct file *);
static int device_release(struct inode *, struct file *);
static ssize_t device_read(struct file *, char *, size_t, loff_t *);
static ssize_t device_write(struct file *, const char *, size_t, loff_t *);
//
%} // end of [%{^]

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

%{^

struct
file_operations
fops = {
  .read = device_read,
  .write = device_write,
  .open = device_open,
  .release = device_release
} ;

static void *fops_ptr = &(fops);

%} // end of [%{^]

macdef
fops_ptr = $extval(fops_ptr1, "fops_ptr")

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

implement
init_module
(
) = let
//
extvar
"Major" =
register_chrdev(0u, DEVICE_NAME, fops_ptr)
//
val Major = g1ofg0(Major)
//
in
//
if
(Major > 0)
then let
//
val () =
$extfcall
(
  void
, "printk", KERN_INFO_"The assigned major number is: %d\n", Major
) (* end of [val] *)
//
in
  0(*SUCCESS*)
end // end of [then]
else let
//
val () =
$extfcall
(
  void
, "printk", KERN_ALERT_"Registering chardev failed with %d\n", Major
) (* end of [val] *)
//
in
  Major
end // end of [else]
//
end (* end of [init_module] *)

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

implement
cleanup_module
(
// argumentless
) = () where
{
//
val
Major =
(
if Major > 0
  then g0i2u(Major) else 0u
// end of [if]
) : uint // end of [val]
//
val () = unregister_chrdev(Major, DEVICE_NAME)
//
} (* end of [cleanup_module] *)

(* ****** ****** *)
//
static
fun device_open_ (inode_ptr1, file_ptr1): interr = "mac#"
static
fun device_release_ (inode_ptr1, file_ptr1): interr = "mac#"
//
(* ****** ****** *)

implement
device_open_
  (inx, filp) = let
in
//
if
(Device_open = 0)
then let
//
extvar
"Device_open" = Device_open + 1
extvar
"Device_open_count" = Device_open_count + 1
//
val () =
$extfcall
(
  void
, "sprintf"
, Message0_ptr, "Hello(%d) from the chardev\n", Device_open_count
) : void // end of [val]
//
extvar
"Message1_ptr" = Message0_ptr
//
in
  0(*SUCCESS*)
end // end of [then]
else ~(EBUSY) // end of [else]
//
end // end of [device_open_]

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

implement
device_release_
  (inx, filp) = let
//
extvar
"Device_open_count" = Device_open_count - 1
//
in
  0(*SUCCESS*)
end // end of [device_release_]

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

%{$
//
static
inline
int
device_open
(
struct inode *p0, struct file *p1
) { return device_open_(p0, p1) ; }
//
static
inline
int
device_release
(
struct inode *p0, struct file *p1
) { return device_release_(p0, p1) ; }
//
%} // end of [%{$]

(* ****** ****** *)
//
static
fun
device_read_{n:int}
(
  file_ptr1, buf: &ubytes(n), size_t(n), ofs: &loff_t
) : ssize_t = "mac#" // end-of-function
static
fun
device_write_{n:int}
(
  file_ptr1, buf: &ubytes(n), size_t(n), ofs: &loff_t
) : ssize_t = "mac#" // end-of-function
//
(* ****** ****** *)

implement
device_read_
  (filp, buf, n, ofs) = let
//
val n2 =
string_nlength<>
  ($UN.cast{string}(Message1_ptr), n)
//
val nread =
$extfcall
(
  size_t
, "copy_to_user", addr@buf, Message1_ptr, n2
) (* end of [val] *)
//
extvar
"Message1_ptr" =
add_ptr_bsz ($UN.cast{ptr}(Message1_ptr), nread)
//
in
  $UN.cast{ssize_t}(nread)
end // end of [device_read_]

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

implement
device_write_
  (filp, buf, n, ofs) = let
//
val () =
$extfcall
(
  void
, "printk"
, KERN_ALERT_"Sorry, this operation isn't supported.\n"
) (* end of [val] *)
//
in
  $UN.cast{ssize_t}(~(EINVAL))
end // end of [device_write_]

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

%{$
//
static
inline
ssize_t
device_read
(
struct file *p0, char *buf, size_t n, loff_t *ofs
) { return device_read_(p0, buf, n, ofs) ; }
//
static
inline
ssize_t
device_write
(
struct file *p0, const char *buf, size_t n, loff_t *ofs
) { return device_write_(p0, (void*)buf, n, ofs) ; }
//
%} // end of [%{$]

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

(* end of [chardev-1.dats] *)

(*
** A simple char device
*)

(* ****** ****** *)
//
// HX-2014-10-24:
// nothing fancy here;
// just trying to get it working
//
(* ****** ****** *)
//
// HX-2014-10-21:
// no use for dynloading
//
#define ATS_DYNLOADFLAG 0
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$KERNELATS}/prelude/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/basics.sats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/SATS/errno.sats"
staload
"{$LINUX}/SATS/types.sats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/SATS/init.sats"
staload
"{$LINUX}/SATS/module.sats"
staload
"{$LINUX}/SATS/kernel.sats"
staload $PRINTK // HX: opening NS
//
staload "{$LINUX}/SATS/fs.sats"
//
(* ****** ****** *)

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

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

%{^
MODULE_LICENSE("Dual BSD/GPL") ;
%} // end of [%{^]

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

static
fun init_module(): interr = "mac#"
static
fun cleanup_module(): void = "mac#"

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

%{^
static int Major = 0;
static int Device_open = 0;
static int Device_open_count = 0;
%} // end of [%{^]

macdef
Major = $extval(int, "Major")
macdef
Device_open = $extval(int, "Device_open")
macdef
Device_open_count = $extval(int, "Device_open_count")

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

%{^
#define BUFLEN 80 // Max length of the message from the device
#define DEVICE_NAME "chardev-1" /* Dev name as it appears in /proc/devices */
//
typedef
char *charptr ;
char Message[BUFLEN];
charptr Message0_ptr = &Message[0];
charptr Message1_ptr = &Message[0];
//
%} // end of [%{^]

typedef charptr = $extype"charptr"

macdef
DEVICE_NAME = $extval(string, "DEVICE_NAME")
macdef
Message0_ptr = $extval(charptr, "Message0_ptr")
macdef
Message1_ptr = $extval(charptr, "Message1_ptr")

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

%{^
//
static int device_open(struct inode *, struct file *);
static int device_release(struct inode *, struct file *);
static ssize_t device_read(struct file *, char *, size_t, loff_t *);
static ssize_t device_write(struct file *, const char *, size_t, loff_t *);
//
%} // end of [%{^]

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

%{^

struct
file_operations
fops = {
  .read = device_read,
  .write = device_write,
  .open = device_open,
  .release = device_release
} ;

static void *fops_ptr = &(fops);

%} // end of [%{^]

macdef
fops_ptr = $extval(fops_ptr1, "fops_ptr")

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

implement
init_module
(
) = let
//
extvar
"Major" =
register_chrdev(0u, DEVICE_NAME, fops_ptr)
//
val Major = g1ofg0(Major)
//
in
//
if
(Major > 0)
then let
//
val () =
$extfcall
(
  void
, "printk", KERN_INFO_"The assigned major number is: %d\n", Major
) (* end of [val] *)
//
in
  0(*SUCCESS*)
end // end of [then]
else let
//
val () =
$extfcall
(
  void
, "printk", KERN_ALERT_"Registering chardev failed with %d\n", Major
) (* end of [val] *)
//
in
  Major
end // end of [else]
//
end (* end of [init_module] *)

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

implement
cleanup_module
(
// argumentless
) = () where
{
//
val
Major =
(
if Major > 0
  then g0i2u(Major) else 0u
// end of [if]
) : uint // end of [val]
//
val () = unregister_chrdev(Major, DEVICE_NAME)
//
} (* end of [cleanup_module] *)

(* ****** ****** *)
//
static
fun device_open_ (inode_ptr1, file_ptr1): interr = "mac#"
static
fun device_release_ (inode_ptr1, file_ptr1): interr = "mac#"
//
(* ****** ****** *)

implement
device_open_
  (inx, filp) = let
in
//
if
(Device_open = 0)
then let
//
extvar
"Device_open" = Device_open + 1
extvar
"Device_open_count" = Device_open_count + 1
//
val () =
$extfcall
(
  void
, "sprintf"
, Message0_ptr, "Hello(%d) from the chardev\n", Device_open_count
) : void // end of [val]
//
extvar
"Message1_ptr" = Message0_ptr
//
in
  0(*SUCCESS*)
end // end of [then]
else ~(EBUSY) // end of [else]
//
end // end of [device_open_]

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

implement
device_release_
  (inx, filp) = let
//
extvar
"Device_open_count" = Device_open_count - 1
//
in
  0(*SUCCESS*)
end // end of [device_release_]

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

%{$
//
static
inline
int
device_open
(
struct inode *p0, struct file *p1
) { return device_open_(p0, p1) ; }
//
static
inline
int
device_release
(
struct inode *p0, struct file *p1
) { return device_release_(p0, p1) ; }
//
%} // end of [%{$]

(* ****** ****** *)
//
static
fun
device_read_{n:int}
(
  file_ptr1, buf: &ubytes(n), size_t(n), ofs: &loff_t
) : ssize_t = "mac#" // end-of-function
static
fun
device_write_{n:int}
(
  file_ptr1, buf: &ubytes(n), size_t(n), ofs: &loff_t
) : ssize_t = "mac#" // end-of-function
//
(* ****** ****** *)

implement
device_read_
  (filp, buf, n, ofs) = let
//
val n2 =
string_nlength<>
  ($UN.cast{string}(Message1_ptr), n)
//
val nread =
$extfcall
(
  size_t
, "copy_to_user", addr@buf, Message1_ptr, n2
) (* end of [val] *)
//
extvar
"Message1_ptr" =
add_ptr_bsz ($UN.cast{ptr}(Message1_ptr), nread)
//
in
  $UN.cast{ssize_t}(nread)
end // end of [device_read_]

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

implement
device_write_
  (filp, buf, n, ofs) = let
//
val () =
$extfcall
(
  void
, "printk"
, KERN_ALERT_"Sorry, this operation isn't supported.\n"
) (* end of [val] *)
//
in
  $UN.cast{ssize_t}(~(EINVAL))
end // end of [device_write_]

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

%{$
//
static
inline
ssize_t
device_read
(
struct file *p0, char *buf, size_t n, loff_t *ofs
) { return device_read_(p0, buf, n, ofs) ; }
//
static
inline
ssize_t
device_write
(
struct file *p0, const char *buf, size_t n, loff_t *ofs
) { return device_write_(p0, (void*)buf, n, ofs) ; }
//
%} // end of [%{$]

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

(* end of [chardev-1.dats] *)


Use vector header defined in ATS

Use vector header defined in ATS

%{^
#include "hardware_serial.h"

#if defined(UBRRH) && defined(UBRRL)
#define ADDR_UBRRH (UBRRH)
#define ADDR_UBRRL (UBRRL)
#define ADDR_UCSRA (UCSRA)
#define ADDR_UCSRB (UCSRB)
#define ADDR_UCSRC (UCSRC)
#define ADDR_UDR   (UDR)
#define BIT_RXEN   (RXEN)
#define BIT_TXEN   (TXEN)
#define BIT_RXCIE  (RXCIE)
#define BIT_UDRIE  (UDRIE)
#define BIT_U2X    (U2X)
#define BIT_UPE    (PE)
#elif defined(UBRR0H) && defined(UBRR0L)
#define ADDR_UBRRH (UBRR0H)
#define ADDR_UBRRL (UBRR0L)
#define ADDR_UCSRA (UCSR0A)
#define ADDR_UCSRB (UCSR0B)
#define ADDR_UCSRC (UCSR0C)
#define ADDR_UDR   (UDR0)
#define BIT_RXEN   (RXEN0)
#define BIT_TXEN   (TXEN0)
#define BIT_RXCIE  (RXCIE0)
#define BIT_UDRIE  (UDRIE0)
#define BIT_U2X    (U2X0)
#define BIT_UPE    (UPE0)
#else
#error no serial port defined  (port 0)
#endif

bool ats_serial_transmitting;
%}

#define ATS_DYNLOADFLAG 0 // no dynloading at run-time
#include "share/atspre_define.hats"
#include "share/atspre_staload.hats"
#include "config.hats"

staload "{$TOP}/SATS/arduino.sats"
staload "{$TOP}/SATS/hardware_serial.sats"
staload UN = "prelude/SATS/unsafe.sats"

abst@ype hardware_serial = $extype"struct hardware_serial"
macdef hserial   = $extval(cPtr0(hardware_serial), "(&Serial)")

macdef F_CPU = $extval(ulint, "F_CPU")

abst@ype ring_buffer = $extype"struct ring_buffer"
macdef rx_buffer = $extval(cPtr0(ring_buffer), "&rx_buffer")
macdef tx_buffer = $extval(cPtr0(ring_buffer), "&tx_buffer")

macdef ADDR_UBRRH = $extval(ptr, "&ADDR_UBRRH")
macdef ADDR_UBRRL = $extval(ptr, "&ADDR_UBRRL")
macdef ADDR_UCSRA = $extval(ptr, "&ADDR_UCSRA")
macdef ADDR_UCSRB = $extval(ptr, "&ADDR_UCSRB")
macdef ADDR_UCSRC = $extval(ptr, "&ADDR_UCSRC")
macdef ADDR_UDR   = $extval(ptr, "&ADDR_UDR")
macdef BIT_RXEN   = $extval(uint8, "BIT_RXEN")
macdef BIT_TXEN   = $extval(uint8, "BIT_TXEN")
macdef BIT_RXCIE  = $extval(uint8, "BIT_RXCIE")
macdef BIT_UDRIE  = $extval(uint8, "BIT_UDRIE")
macdef BIT_U2X    = $extval(uint8, "BIT_U2X")
macdef BIT_TXC0   = $extval(uint8, "TXC0")
macdef BIT_UPE    = $extval(uint8, "BIT_UPE")
macdef VAL_U2X    = $extval(uint8, "(1 << BIT_U2X)")

macdef transmitting = $extval(ptr, "&ats_serial_transmitting")

extern fun ringbuf_insert_nowait: (uchar, cPtr0(ring_buffer)) -> void  = "mac#"
extern fun ringbuf_insert_wait:   (uchar, cPtr0(ring_buffer)) -> void  = "mac#"
extern fun ringbuf_is_empty:      (cPtr0(ring_buffer))        -> bool  = "mac#"
extern fun ringbuf_get_size:      (cPtr0(ring_buffer))        -> uint  = "mac#"
extern fun ringbuf_peek:          (cPtr0(ring_buffer))        -> uchar = "mac#"
extern fun ringbuf_remove:        (cPtr0(ring_buffer))        -> uchar = "mac#"
extern fun ringbuf_clear:         (cPtr0(ring_buffer))        -> void  = "mac#"

extern fun c_sbi:            (ptr, uint8) -> void  = "mac#"
extern fun c_cbi:            (ptr, uint8) -> void  = "mac#"
extern fun c_rbi:            (ptr, uint8) -> uint8 = "mac#"

extern fun ats_serial_rx_vect: () -> void = "ext#"
extern fun ats_serial_tx_vect: () -> void = "ext#"

fun set_transmitting (t:bool): void = $UN.ptr0_set<bool> (transmitting, t)
fun get_transmitting (): bool       = $UN.ptr0_get<bool> (transmitting)

implement ats_serial_rx_vect () = {
  val b  = c_rbi (ADDR_UCSRA, BIT_UPE)
  val c  = $UN.ptr0_get<uchar> (ADDR_UDR)
  val () = if ($UN.cast2int b) = 0 then ringbuf_insert_nowait (c, rx_buffer)
}

implement ats_serial_tx_vect () =
  if ringbuf_is_empty tx_buffer then {
    // Buffer empty, so disable interrupts
    val () = c_cbi (ADDR_UCSRB, BIT_UDRIE)
  } else {
    // There is more data in the output buffer. Send the next byte
    val c  = ringbuf_remove tx_buffer
    val () = $UN.ptr0_set<uchar> (ADDR_UDR, c)
  }

implement serial_begin (baud) = {
  fun get_baud_setting_u2x (): ulint = let
    val v = VAL_U2X // xxx 1U << BIT_U2X
    val () = $UN.ptr0_set<uint8> (ADDR_UCSRA, v)
    val setting = (F_CPU / 4UL / baud - 1UL) / 2UL
  in
    setting
  end
  fun get_baud_setting (): ulint = let
    val () = $UN.ptr0_set<uint8> (ADDR_UCSRA, $UN.cast 0)
    val setting = (F_CPU / 8UL / baud - 1UL) / 2UL
  in
    setting
  end
  // hardcoded exception for compatibility with the bootloader shipped
  // with the Duemilanove and previous boards and the firmware on the 8U2
  // on the Uno and Mega 2560.
  val use_u2x = not(F_CPU = 16000000UL andalso baud = 57600UL)
  val tmp = if use_u2x then get_baud_setting_u2x () else get_baud_setting ()
  fun test (setting:ulint): bool = setting > 4095UL
  val baud_setting = if ((test tmp) andalso use_u2x) then get_baud_setting () else tmp

  // assign the baud_setting, a.k.a. ubbr (USART Baud Rate Register)
  val () = $UN.ptr0_set<uint8> (ADDR_UBRRL, $UN.cast (g0uint_lsr (baud_setting, 8)))
  val () = $UN.ptr0_set<uint8> (ADDR_UBRRL, $UN.cast baud_setting)

  val () = set_transmitting (false)

  val () = c_sbi (ADDR_UCSRB, BIT_RXEN)
  val () = c_sbi (ADDR_UCSRB, BIT_TXEN)
  val () = c_sbi (ADDR_UCSRB, BIT_RXCIE)
  val () = c_cbi (ADDR_UCSRB, BIT_UDRIE)
}

implement serial_flush () = {
  // UDR is kept full while the buffer is not empty, so TXC triggers when EMPTY && SENT
  fun loop () = let
    val t = get_transmitting ()
    val b = c_rbi (ADDR_UCSRA, BIT_TXC0)
  in
    if (t andalso (($UN.cast2int b) = 0)) then loop ()
  end
  val () = loop ()
  val () = set_transmitting (false)
}

implement serial_available () =
  ringbuf_get_size rx_buffer

implement serial_peek () =
  if (ringbuf_is_empty (rx_buffer)) then
    ~1
  else
    $UN.cast (ringbuf_peek (rx_buffer))

implement serial_read () =
  if (ringbuf_is_empty (rx_buffer)) then
    ~1
  else
    $UN.cast (ringbuf_remove (rx_buffer))

implement serial_write (c) = let
  val () = ringbuf_insert_wait ($UN.cast c, tx_buffer)
  val () = c_sbi (ADDR_UCSRB, BIT_UDRIE)
  // clear the TXC bit -- "can be cleared by writing a one to its bit location"
  val () = set_transmitting (true)
  val () = c_sbi (ADDR_UCSRA, BIT_TXC0)
in
  $UN.cast 1
end

implement serial_end () = {
  // wait for transmission of outgoing data
  fun loop () = if not(ringbuf_is_empty (tx_buffer)) then loop ()
  val () = loop ()
  val () = c_cbi (ADDR_UCSRB, BIT_RXEN)
  val () = c_cbi (ADDR_UCSRB, BIT_TXEN)
  val () = c_cbi (ADDR_UCSRB, BIT_RXCIE)
  val () = c_cbi (ADDR_UCSRB, BIT_UDRIE)
  // clear any received data
  val () = ringbuf_clear (rx_buffer)
}

%{$
#if !defined(USART_RX_vect) && !defined(USART0_RX_vect) && !defined(USART_RXC_vect)
  #error "Don't know what the Data Received vector is called for the first UART"
#else
#if defined(USART_RX_vect)
ISR(USART_RX_vect)
#elif defined(USART0_RX_vect)
ISR(USART0_RX_vect)
#elif defined(USART_RXC_vect)
ISR(USART_RXC_vect) // ATmega8
#endif
{
    ats_serial_rx_vect();
}
#endif

#if !defined(UART0_UDRE_vect) && !defined(UART_UDRE_vect) && !defined(USART0_UDRE_vect) && !defined(USART_UDRE_vect)
  #error "Don't know what the Data Register Empty vector is called for the first UART"
#else
#if defined(UART0_UDRE_vect)
ISR(UART0_UDRE_vect)
#elif defined(UART_UDRE_vect)
ISR(UART_UDRE_vect)
#elif defined(USART0_UDRE_vect)
ISR(USART0_UDRE_vect)
#elif defined(USART_UDRE_vect)
ISR(USART_UDRE_vect)
#endif
{
    ats_serial_tx_vect();
}
#endif
%}

%{^
#include "hardware_serial.h"

#if defined(UBRRH) && defined(UBRRL)
#define ADDR_UBRRH (UBRRH)
#define ADDR_UBRRL (UBRRL)
#define ADDR_UCSRA (UCSRA)
#define ADDR_UCSRB (UCSRB)
#define ADDR_UCSRC (UCSRC)
#define ADDR_UDR   (UDR)
#define BIT_RXEN   (RXEN)
#define BIT_TXEN   (TXEN)
#define BIT_RXCIE  (RXCIE)
#define BIT_UDRIE  (UDRIE)
#define BIT_U2X    (U2X)
#define BIT_UPE    (PE)
#elif defined(UBRR0H) && defined(UBRR0L)
#define ADDR_UBRRH (UBRR0H)
#define ADDR_UBRRL (UBRR0L)
#define ADDR_UCSRA (UCSR0A)
#define ADDR_UCSRB (UCSR0B)
#define ADDR_UCSRC (UCSR0C)
#define ADDR_UDR   (UDR0)
#define BIT_RXEN   (RXEN0)
#define BIT_TXEN   (TXEN0)
#define BIT_RXCIE  (RXCIE0)
#define BIT_UDRIE  (UDRIE0)
#define BIT_U2X    (U2X0)
#define BIT_UPE    (UPE0)
#else
#error no serial port defined  (port 0)
#endif

#if !defined(USART_RX_vect) && !defined(USART0_RX_vect) && !defined(USART_RXC_vect)
  #error "Don't know what the Data Received vector is called for the first UART"
#else
#if defined(USART_RX_vect)
ISR(USART_RX_vect)
#elif defined(USART0_RX_vect)
ISR(USART0_RX_vect)
#elif defined(USART_RXC_vect)
ISR(USART_RXC_vect) // ATmega8
#endif
{
    ats_serial_rx_vect();
}
#endif

#if !defined(UART0_UDRE_vect) && !defined(UART_UDRE_vect) && !defined(USART0_UDRE_vect) && !defined(USART_UDRE_vect)
  #error "Don't know what the Data Register Empty vector is called for the first UART"
#else
#if defined(UART0_UDRE_vect)
ISR(UART0_UDRE_vect)
#elif defined(UART_UDRE_vect)
ISR(UART_UDRE_vect)
#elif defined(USART0_UDRE_vect)
ISR(USART0_UDRE_vect)
#elif defined(USART_UDRE_vect)
ISR(USART_UDRE_vect)
#endif
{
    ats_serial_tx_vect();
}
#endif

bool ats_serial_transmitting;
%}

#define ATS_DYNLOADFLAG 0 // no dynloading at run-time
#include "share/atspre_define.hats"
#include "share/atspre_staload.hats"
#include "config.hats"

staload "{$TOP}/SATS/arduino.sats"
staload "{$TOP}/SATS/hardware_serial.sats"
staload UN = "prelude/SATS/unsafe.sats"

abst@ype hardware_serial = $extype"struct hardware_serial"
macdef hserial   = $extval(cPtr0(hardware_serial), "(&Serial)")

macdef F_CPU = $extval(ulint, "F_CPU")

abst@ype ring_buffer = $extype"struct ring_buffer"
macdef rx_buffer = $extval(cPtr0(ring_buffer), "&rx_buffer")
macdef tx_buffer = $extval(cPtr0(ring_buffer), "&tx_buffer")

macdef ADDR_UBRRH = $extval(ptr, "&ADDR_UBRRH")
macdef ADDR_UBRRL = $extval(ptr, "&ADDR_UBRRL")
macdef ADDR_UCSRA = $extval(ptr, "&ADDR_UCSRA")
macdef ADDR_UCSRB = $extval(ptr, "&ADDR_UCSRB")
macdef ADDR_UCSRC = $extval(ptr, "&ADDR_UCSRC")
macdef ADDR_UDR   = $extval(ptr, "&ADDR_UDR")
macdef BIT_RXEN   = $extval(uint8, "BIT_RXEN")
macdef BIT_TXEN   = $extval(uint8, "BIT_TXEN")
macdef BIT_RXCIE  = $extval(uint8, "BIT_RXCIE")
macdef BIT_UDRIE  = $extval(uint8, "BIT_UDRIE")
macdef BIT_U2X    = $extval(uint8, "BIT_U2X")
macdef BIT_TXC0   = $extval(uint8, "TXC0")
macdef BIT_UPE    = $extval(uint8, "BIT_UPE")
macdef VAL_U2X    = $extval(uint8, "(1 << BIT_U2X)")

macdef transmitting = $extval(ptr, "&ats_serial_transmitting")

extern fun ringbuf_insert_nowait: (uchar, cPtr0(ring_buffer)) -> void  = "mac#"
extern fun ringbuf_insert_wait:   (uchar, cPtr0(ring_buffer)) -> void  = "mac#"
extern fun ringbuf_is_empty:      (cPtr0(ring_buffer))        -> bool  = "mac#"
extern fun ringbuf_get_size:      (cPtr0(ring_buffer))        -> uint  = "mac#"
extern fun ringbuf_peek:          (cPtr0(ring_buffer))        -> uchar = "mac#"
extern fun ringbuf_remove:        (cPtr0(ring_buffer))        -> uchar = "mac#"
extern fun ringbuf_clear:         (cPtr0(ring_buffer))        -> void  = "mac#"

extern fun c_sbi:            (ptr, uint8) -> void  = "mac#"
extern fun c_cbi:            (ptr, uint8) -> void  = "mac#"
extern fun c_rbi:            (ptr, uint8) -> uint8 = "mac#"

extern fun ats_serial_rx_vect: () -> void = "ext#"
extern fun ats_serial_tx_vect: () -> void = "ext#"

fun set_transmitting (t:bool): void = $UN.ptr0_set<bool> (transmitting, t)
fun get_transmitting (): bool       = $UN.ptr0_get<bool> (transmitting)

implement ats_serial_rx_vect () = {
  val b  = c_rbi (ADDR_UCSRA, BIT_UPE)
  val c  = $UN.ptr0_get<uchar> (ADDR_UDR)
  val () = if ($UN.cast2int b) = 0 then ringbuf_insert_nowait (c, rx_buffer)
}

implement ats_serial_tx_vect () =
  if ringbuf_is_empty tx_buffer then {
    // Buffer empty, so disable interrupts
    val () = c_cbi (ADDR_UCSRB, BIT_UDRIE)
  } else {
    // There is more data in the output buffer. Send the next byte
    val c  = ringbuf_remove tx_buffer
    val () = $UN.ptr0_set<uchar> (ADDR_UDR, c)
  }

implement serial_begin (baud) = {
  fun get_baud_setting_u2x (): ulint = let
    val v = VAL_U2X // xxx 1U << BIT_U2X
    val () = $UN.ptr0_set<uint8> (ADDR_UCSRA, v)
    val setting = (F_CPU / 4UL / baud - 1UL) / 2UL
  in
    setting
  end
  fun get_baud_setting (): ulint = let
    val () = $UN.ptr0_set<uint8> (ADDR_UCSRA, $UN.cast 0)
    val setting = (F_CPU / 8UL / baud - 1UL) / 2UL
  in
    setting
  end
  // hardcoded exception for compatibility with the bootloader shipped
  // with the Duemilanove and previous boards and the firmware on the 8U2
  // on the Uno and Mega 2560.
  val use_u2x = not(F_CPU = 16000000UL andalso baud = 57600UL)
  val tmp = if use_u2x then get_baud_setting_u2x () else get_baud_setting ()
  fun test (setting:ulint): bool = setting > 4095UL
  val baud_setting = if ((test tmp) andalso use_u2x) then get_baud_setting () else tmp

  // assign the baud_setting, a.k.a. ubbr (USART Baud Rate Register)
  val () = $UN.ptr0_set<uint8> (ADDR_UBRRL, $UN.cast (g0uint_lsr (baud_setting, 8)))
  val () = $UN.ptr0_set<uint8> (ADDR_UBRRL, $UN.cast baud_setting)

  val () = set_transmitting (false)

  val () = c_sbi (ADDR_UCSRB, BIT_RXEN)
  val () = c_sbi (ADDR_UCSRB, BIT_TXEN)
  val () = c_sbi (ADDR_UCSRB, BIT_RXCIE)
  val () = c_cbi (ADDR_UCSRB, BIT_UDRIE)
}

implement serial_flush () = {
  // UDR is kept full while the buffer is not empty, so TXC triggers when EMPTY && SENT
  fun loop () = let
    val t = get_transmitting ()
    val b = c_rbi (ADDR_UCSRA, BIT_TXC0)
  in
    if (t andalso (($UN.cast2int b) = 0)) then loop ()
  end
  val () = loop ()
  val () = set_transmitting (false)
}

implement serial_available () =
  ringbuf_get_size rx_buffer

implement serial_peek () =
  if (ringbuf_is_empty (rx_buffer)) then
    ~1
  else
    $UN.cast (ringbuf_peek (rx_buffer))

implement serial_read () =
  if (ringbuf_is_empty (rx_buffer)) then
    ~1
  else
    $UN.cast (ringbuf_remove (rx_buffer))

implement serial_write (c) = let
  val () = ringbuf_insert_wait ($UN.cast c, tx_buffer)
  val () = c_sbi (ADDR_UCSRB, BIT_UDRIE)
  // clear the TXC bit -- "can be cleared by writing a one to its bit location"
  val () = set_transmitting (true)
  val () = c_sbi (ADDR_UCSRA, BIT_TXC0)
in
  $UN.cast 1
end

implement serial_end () = {
  // wait for transmission of outgoing data
  fun loop () = if not(ringbuf_is_empty (tx_buffer)) then loop ()
  val () = loop ()
  val () = c_cbi (ADDR_UCSRB, BIT_RXEN)
  val () = c_cbi (ADDR_UCSRB, BIT_TXEN)
  val () = c_cbi (ADDR_UCSRB, BIT_RXCIE)
  val () = c_cbi (ADDR_UCSRB, BIT_UDRIE)
  // clear any received data
  val () = ringbuf_clear (rx_buffer)
}


Updating: working on chardev-1

Updating: working on chardev-1

(*
** A simple char device
*)

(* ****** ****** *)
//
// HX-2014-10-24:
// nothing fancy here;
// just trying to get it working
//
(* ****** ****** *)
//
// HX-2014-10-21:
// no use for dynloading
//
#define ATS_DYNLOADFLAG 0
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$KERNELATS}/prelude/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/basics.sats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/SATS/errno.sats"
staload
"{$LINUX}/SATS/types.sats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/SATS/init.sats"
staload
"{$LINUX}/SATS/module.sats"
staload
"{$LINUX}/SATS/kernel.sats"
staload $PRINTK // HX: opening NS
//
staload "{$LINUX}/SATS/fs.sats"
//
staload "{$LINUX}/SATS/asm/uaccess.sats"
//
(* ****** ****** *)

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

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

%{^
MODULE_LICENSE("Dual BSD/GPL") ;
%} // end of [%{^]

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

static
fun init_module(): interr = "mac#"
static
fun cleanup_module(): void = "mac#"

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

%{^
static int Major = 0;
static int Device_open = 0;
static int Device_open_count = 0;
%} // end of [%{^]

macdef
Major = $extval(int, "Major")
macdef
Device_open = $extval(int, "Device_open")
macdef
Device_open_count = $extval(int, "Device_open_count")

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

%{^
#define BUFLEN 80 // Max length of the message from the device
#define DEVICE_NAME "chardev-1" /* Dev name as it appears in /proc/devices */
//
typedef
char *charptr ;
char Message[BUFLEN];
charptr Message0_ptr = &Message[0];
charptr Message1_ptr = &Message[0];
//
%} // end of [%{^]

typedef charptr = $extype"charptr"

macdef
DEVICE_NAME = $extval(string, "DEVICE_NAME")
macdef
Message0_ptr = $extval(charptr, "Message0_ptr")
macdef
Message1_ptr = $extval(charptr, "Message1_ptr")

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

%{^
//
static int device_open(struct inode *, struct file *);
static int device_release(struct inode *, struct file *);
static ssize_t device_read(struct file *, char *, size_t, loff_t *);
static ssize_t device_write(struct file *, const char *, size_t, loff_t *);
//
%} // end of [%{^]

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

%{^

struct
file_operations
fops = {
  .read = device_read,
  .write = device_write,
  .open = device_open,
  .release = device_release
} ;

static void *fops_ptr = &(fops);

%} // end of [%{^]

macdef
fops_ptr = $extval(fops_ptr1, "fops_ptr")

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

implement
init_module
(
) = let
//
extvar
"Major" =
register_chrdev(0u, DEVICE_NAME, fops_ptr)
//
val Major = g1ofg0(Major)
//
in
//
if
(Major > 0)
then let
//
val () =
$extfcall
(
  void
, "printk", KERN_INFO_"The assigned major number is: %d\n", Major
) (* end of [val] *)
//
in
  0(*SUCCESS*)
end // end of [then]
else let
//
val () =
$extfcall
(
  void
, "printk", KERN_ALERT_"Registering chardev failed with %d\n", Major
) (* end of [val] *)
//
in
  Major
end // end of [else]
//
end (* end of [init_module] *)

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

implement
cleanup_module
(
// argumentless
) = () where
{
//
val
Major =
(
if Major > 0
  then g0i2u(Major) else 0u
// end of [if]
) : uint // end of [val]
//
val () = unregister_chrdev(Major, DEVICE_NAME)
//
} (* end of [cleanup_module] *)

(* ****** ****** *)
//
static
fun device_open_ (inode_ptr1, file_ptr1): interr = "mac#"
static
fun device_release_ (inode_ptr1, file_ptr1): interr = "mac#"
//
(* ****** ****** *)

implement
device_open_
  (inx, filp) = let
in
//
if
(Device_open = 0)
then let
//
extvar
"Device_open" = Device_open + 1
extvar
"Device_open_count" = Device_open_count + 1
//
val () =
$extfcall
(
  void
, "sprintf"
, Message0_ptr, "Hello(%d) from the chardev\n", Device_open_count
) : void // end of [val]
//
extvar
"Message1_ptr" = Message0_ptr
//
in
  0(*SUCCESS*)
end // end of [then]
else ~(EBUSY) // end of [else]
//
end // end of [device_open_]

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

implement
device_release_
  (inx, filp) = let
//
extvar
"Device_open" = Device_open - 1
//
in
  0(*SUCCESS*)
end // end of [device_release_]

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

%{$
//
static
inline
int
device_open
(
struct inode *p0, struct file *p1
) { return device_open_(p0, p1) ; }
//
static
inline
int
device_release
(
struct inode *p0, struct file *p1
) { return device_release_(p0, p1) ; }
//
%} // end of [%{$]

(* ****** ****** *)
//
static
fun
device_read_{n:int}
(
  file_ptr1, buf: &ubytes(n), size_t(n), ofs: &loff_t
) : ssize_t = "mac#" // end-of-function
static
fun
device_write_{n:int}
(
  file_ptr1, buf: &ubytes(n), size_t(n), ofs: &loff_t
) : ssize_t = "mac#" // end-of-function
//
(* ****** ****** *)

implement
device_read_
  (filp, buf, n, ofs) = let
//
val n2 =
string_nlength<>
  ($UN.cast{string}(Message1_ptr), n)
//
val nread =
$extfcall
(
  size_t
, "copy_to_user", addr@buf, Message1_ptr, n2
) (* end of [val] *)
//
extvar
"Message1_ptr" =
add_ptr_bsz ($UN.cast{ptr}(Message1_ptr), nread)
//
in
  $UN.cast{ssize_t}(nread)
end // end of [device_read_]

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

implement
device_write_
  (filp, buf, n, ofs) = let
//
val () =
$extfcall
(
  void
, "printk"
, KERN_ALERT_"Sorry, this operation isn't supported.\n"
) (* end of [val] *)
//
in
  $UN.cast{ssize_t}(~(EINVAL))
end // end of [device_write_]

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

%{$
//
static
inline
ssize_t
device_read
(
struct file *p0, char *buf, size_t n, loff_t *ofs
) { return device_read_(p0, buf, n, ofs) ; }
//
static
inline
ssize_t
device_write
(
struct file *p0, const char *buf, size_t n, loff_t *ofs
) { return device_write_(p0, (void*)buf, n, ofs) ; }
//
%} // end of [%{$]

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

(* end of [chardev-1.dats] *)

(*
** A simple char device
*)

(* ****** ****** *)
//
// HX-2014-10-24:
// nothing fancy here;
// just trying to get it working
//
(* ****** ****** *)
//
// HX-2014-10-21:
// no use for dynloading
//
#define ATS_DYNLOADFLAG 0
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$KERNELATS}/prelude/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/basics.sats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/SATS/errno.sats"
staload
"{$LINUX}/SATS/types.sats"
//
(* ****** ****** *)
//
staload
"{$LINUX}/SATS/init.sats"
staload
"{$LINUX}/SATS/module.sats"
staload
"{$LINUX}/SATS/kernel.sats"
staload $PRINTK // HX: opening NS
//
staload "{$LINUX}/SATS/fs.sats"
//
staload "{$LINUX}/SATS/asm/uaccess.sats"
//
(* ****** ****** *)

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

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

%{^
MODULE_LICENSE("Dual BSD/GPL") ;
%} // end of [%{^]

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

static
fun init_module(): interr = "mac#"
static
fun cleanup_module(): void = "mac#"

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

%{^
static int Major = 0;
static int Device_open = 0;
static int Device_open_count = 0;
%} // end of [%{^]

macdef
Major = $extval(int, "Major")
macdef
Device_open = $extval(int, "Device_open")
macdef
Device_open_count = $extval(int, "Device_open_count")

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

%{^
#define BUFLEN 80 // Max length of the message from the device
#define DEVICE_NAME "chardev-1" /* Dev name as it appears in /proc/devices */
//
typedef
char *charptr ;
char Message[BUFLEN];
charptr Message0_ptr = &Message[0];
charptr Message1_ptr = &Message[0];
//
%} // end of [%{^]

typedef charptr = $extype"charptr"

macdef
DEVICE_NAME = $extval(string, "DEVICE_NAME")
macdef
Message0_ptr = $extval(charptr, "Message0_ptr")
macdef
Message1_ptr = $extval(charptr, "Message1_ptr")

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

%{^
//
static int device_open(struct inode *, struct file *);
static int device_release(struct inode *, struct file *);
static ssize_t device_read(struct file *, char *, size_t, loff_t *);
static ssize_t device_write(struct file *, const char *, size_t, loff_t *);
//
%} // end of [%{^]

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

%{^

struct
file_operations
fops = {
  .read = device_read,
  .write = device_write,
  .open = device_open,
  .release = device_release
} ;

static void *fops_ptr = &(fops);

%} // end of [%{^]

macdef
fops_ptr = $extval(fops_ptr1, "fops_ptr")

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

implement
init_module
(
) = let
//
extvar
"Major" =
register_chrdev(0u, DEVICE_NAME, fops_ptr)
//
val Major = g1ofg0(Major)
//
in
//
if
(Major > 0)
then let
//
val () =
$extfcall
(
  void
, "printk", KERN_INFO_"The assigned major number is: %d\n", Major
) (* end of [val] *)
//
in
  0(*SUCCESS*)
end // end of [then]
else let
//
val () =
$extfcall
(
  void
, "printk", KERN_ALERT_"Registering chardev failed with %d\n", Major
) (* end of [val] *)
//
in
  Major
end // end of [else]
//
end (* end of [init_module] *)

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

implement
cleanup_module
(
// argumentless
) = () where
{
//
val
Major =
(
if Major > 0
  then g0i2u(Major) else 0u
// end of [if]
) : uint // end of [val]
//
val () = unregister_chrdev(Major, DEVICE_NAME)
//
} (* end of [cleanup_module] *)

(* ****** ****** *)
//
static
fun device_open_ (inode_ptr1, file_ptr1): interr = "mac#"
static
fun device_release_ (inode_ptr1, file_ptr1): interr = "mac#"
//
(* ****** ****** *)

implement
device_open_
  (inx, filp) = let
in
//
if
(Device_open = 0)
then let
//
extvar
"Device_open" = Device_open + 1
extvar
"Device_open_count" = Device_open_count + 1
//
val () =
$extfcall
(
  void
, "sprintf"
, Message0_ptr, "Hello(%d) from the chardev\n", Device_open_count
) : void // end of [val]
//
extvar
"Message1_ptr" = Message0_ptr
//
in
  0(*SUCCESS*)
end // end of [then]
else ~(EBUSY) // end of [else]
//
end // end of [device_open_]

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

implement
device_release_
  (inx, filp) = let
//
extvar
"Device_open_count" = Device_open_count - 1
//
in
  0(*SUCCESS*)
end // end of [device_release_]

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

%{$
//
static
inline
int
device_open
(
struct inode *p0, struct file *p1
) { return device_open_(p0, p1) ; }
//
static
inline
int
device_release
(
struct inode *p0, struct file *p1
) { return device_release_(p0, p1) ; }
//
%} // end of [%{$]

(* ****** ****** *)
//
static
fun
device_read_{n:int}
(
  file_ptr1, buf: &ubytes(n), size_t(n), ofs: &loff_t
) : ssize_t = "mac#" // end-of-function
static
fun
device_write_{n:int}
(
  file_ptr1, buf: &ubytes(n), size_t(n), ofs: &loff_t
) : ssize_t = "mac#" // end-of-function
//
(* ****** ****** *)

implement
device_read_
  (filp, buf, n, ofs) = let
//
val n2 =
string_nlength<>
  ($UN.cast{string}(Message1_ptr), n)
//
val nread =
$extfcall
(
  size_t
, "copy_to_user", addr@buf, Message1_ptr, n2
) (* end of [val] *)
//
extvar
"Message1_ptr" =
add_ptr_bsz ($UN.cast{ptr}(Message1_ptr), nread)
//
in
  $UN.cast{ssize_t}(nread)
end // end of [device_read_]

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

implement
device_write_
  (filp, buf, n, ofs) = let
//
val () =
$extfcall
(
  void
, "printk"
, KERN_ALERT_"Sorry, this operation isn't supported.\n"
) (* end of [val] *)
//
in
  $UN.cast{ssize_t}(~(EINVAL))
end // end of [device_write_]

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

%{$
//
static
inline
ssize_t
device_read
(
struct file *p0, char *buf, size_t n, loff_t *ofs
) { return device_read_(p0, buf, n, ofs) ; }
//
static
inline
ssize_t
device_write
(
struct file *p0, const char *buf, size_t n, loff_t *ofs
) { return device_write_(p0, (void*)buf, n, ofs) ; }
//
%} // end of [%{$]

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

(* end of [chardev-1.dats] *)


Updating: improving atscc2js

Updating: improving atscc2js

(* ****** ****** *)
//
// 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"
//
(* ****** ****** *)

implement
emit_ENDL (out) = emit_text (out, "\n")

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

implement
emit_SPACE (out) = emit_text (out, " ")

(* ****** ****** *)
//
implement
emit_COLON (out) = emit_text (out, ":")
//
implement
emit_SEMICOLON (out) = emit_text (out, ";")
//
(* ****** ****** *)

implement
emit_SHARP (out) = emit_text (out, "#")

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

implement
emit_DOLLAR (out) = emit_text (out, "$")

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

implement
emit_DOT (out) = emit_text (out, ".")

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

implement
emit_SQUOTE (out) = emit_text (out, "'")
implement
emit_DQUOTE (out) = emit_text (out, "\"")

(* ****** ****** *)
//
implement
emit_LPAREN (out) = emit_text (out, "(")
implement
emit_RPAREN (out) = emit_text (out, ")")
//
implement
emit_LBRACKET (out) = emit_text (out, "[")
implement
emit_RBRACKET (out) = emit_text (out, "]")
//
implement
emit_LBRACE (out) = emit_text (out, "{")
implement
emit_RBRACE (out) = emit_text (out, "}")
//
(* ****** ****** *)

implement
emit_flush (out) = fileref_flush (out)
implement
emit_newline (out) = fprint_newline (out)

(* ****** ****** *)
//
implement
emit_nspc (out, ind) =
(
//
if ind > 0 then
  (emit_text (out, " "); emit_nspc (out, ind-1))
//
) (* end of [emit_nspc] *)
//
(* ****** ****** *)
//
implement
emit_int (out, x) = fprint_int (out, x)
//
implement
emit_text (out, x) = fprint_string (out, x)
//
(* ****** ****** *)
//
implement
emit_symbol (out, x) =
  fprint_string (out, symbol_get_name (x))
//
(* ****** ****** *)
//
implement
emit_i0de
  (out, id) = emit_symbol (out, id.i0de_sym)
implement
emit_label
  (out, lab) = emit_symbol (out, lab.i0de_sym)
//
(* ****** ****** *)

implement
emit_tokenlst
  (out, toks) = let
//
fun
auxtok
(
  out: FILEref, tok: token
) : void =
(
case+
tok.token_node of
//
| T_KWORD _ => ()
//
| T_ENDL () => emit_ENDL (out)
| T_SPACES (cs) => emit_text (out, cs)
//
| T_COMMENT_line () => emit_COMMENT_line (out)
| T_COMMENT_block () => emit_COMMENT_block (out)
//
| T_INT (_, rep) => emit_text (out, rep)
| T_FLOAT (_, rep) => emit_text (out, rep)
//
| T_STRING (str) => emit_text (out, str)
//
| T_IDENT_alp (name) => emit_text (out, name)
| T_IDENT_srp (name) =>
  (
    emit_SHARP (out); emit_text (out, name)
  ) (* end of [T_IDENT_srp] *)
//
| T_IDENT_sym (name) => emit_text (out, name)
//
| T_LPAREN () => emit_LPAREN (out)
| T_RPAREN () => emit_RPAREN (out)
//
| T_LBRACKET () => emit_LBRACKET (out)
| T_RBRACKET () => emit_RBRACKET (out)
//
| T_LBRACE () => emit_LBRACE (out)
| T_RBRACE () => emit_RBRACE (out)
//
| T_LT () => emit_text (out, "<")
| T_GT () => emit_text (out, ">")
//
| T_MINUS () => emit_text (out, "-")
//
| T_COLON () => emit_text (out, ":")
//
| T_COMMA () => emit_text (out, ",")
| T_SEMICOLON () => emit_text (out, ";")
//
| T_SLASH () => emit_text (out, "/")
//
| _ (*unrecognized*) =>
  {
    val () = fprint! (out, "TOKERR(", tok, ")")
  }
) (* end of [auxtok] *)
//
in
//
case+ toks of
| list_nil () => ()
| list_cons (tok, toks) =>
  (
    auxtok (out, tok); emit_extcode (out, toks)
  ) (* end of [list_cons] *)
//
end // end of [emit_tokenlst]

(* ****** ****** *)
//
implement
emit_extval
  (out, toks) = emit_tokenlst (out, toks)
implement
emit_extcode
  (out, toks) = emit_tokenlst (out, toks)
//
(* ****** ****** *)

(* end of [atsparemit_emit.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"
//
(* ****** ****** *)

implement
emit_ENDL (out) = emit_text (out, "\n")

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

implement
emit_SPACE (out) = emit_text (out, " ")

(* ****** ****** *)
//
implement
emit_COLON (out) = emit_text (out, ":")
//
implement
emit_SEMICOLON (out) = emit_text (out, ";")
//
(* ****** ****** *)

implement
emit_SHARP (out) = emit_text (out, "#")

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

implement
emit_DOLLAR (out) = emit_text (out, "$")

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

implement
emit_DOT (out) = emit_text (out, ".")

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

implement
emit_SQUOTE (out) = emit_text (out, "'")
implement
emit_DQUOTE (out) = emit_text (out, "\"")

(* ****** ****** *)
//
implement
emit_LPAREN (out) = emit_text (out, "(")
implement
emit_RPAREN (out) = emit_text (out, ")")
//
implement
emit_LBRACKET (out) = emit_text (out, "[")
implement
emit_RBRACKET (out) = emit_text (out, "]")
//
implement
emit_LBRACE (out) = emit_text (out, "{")
implement
emit_RBRACE (out) = emit_text (out, "}")
//
(* ****** ****** *)

implement
emit_flush (out) = fileref_flush (out)
implement
emit_newline (out) = fprint_newline (out)

(* ****** ****** *)
//
implement
emit_nspc (out, ind) =
(
//
if ind > 0 then
  (emit_text (out, " "); emit_nspc (out, ind-1))
//
) (* end of [emit_nspc] *)
//
(* ****** ****** *)
//
implement
emit_int (out, x) = fprint_int (out, x)
//
implement
emit_text (out, x) = fprint_string (out, x)
//
(* ****** ****** *)
//
implement
emit_symbol (out, x) =
  fprint_string (out, symbol_get_name (x))
//
(* ****** ****** *)
//
implement
emit_i0de
  (out, id) = emit_symbol (out, id.i0de_sym)
implement
emit_label
  (out, lab) = emit_symbol (out, lab.i0de_sym)
//
(* ****** ****** *)

implement
emit_tokenlst
  (out, toks) = let
//
fun
auxtok
(
  out: FILEref, tok: token
) : void =
(
case+
tok.token_node of
//
| T_KWORD _ => ()
//
| T_ENDL () => emit_ENDL (out)
| T_SPACES (cs) => emit_text (out, cs)
//
| T_COMMENT_line () => emit_COMMENT_line (out)
| T_COMMENT_block () => emit_COMMENT_block (out)
//
| T_INT (_, rep) => emit_text (out, rep)
//
| T_STRING (str) => emit_text (out, str)
//
| T_IDENT_alp (name) => emit_text (out, name)
| T_IDENT_srp (name) =>
  (
    emit_SHARP (out); emit_text (out, name)
  ) (* end of [T_IDENT_srp] *)
//
| T_IDENT_sym (name) => emit_text (out, name)
//
| T_LPAREN () => emit_LPAREN (out)
| T_RPAREN () => emit_RPAREN (out)
//
| T_LBRACKET () => emit_LBRACKET (out)
| T_RBRACKET () => emit_RBRACKET (out)
//
| T_LBRACE () => emit_LBRACE (out)
| T_RBRACE () => emit_RBRACE (out)
//
| T_LT () => emit_text (out, "<")
| T_GT () => emit_text (out, ">")
//
| T_MINUS () => emit_text (out, "-")
//
| T_COLON () => emit_text (out, ":")
//
| T_COMMA () => emit_text (out, ",")
| T_SEMICOLON () => emit_text (out, ";")
//
| T_SLASH () => emit_text (out, "/")
//
| _ (*unrecognized*) =>
  {
    val () = fprint! (out, "TOKERR(", tok, ")")
  }
) (* end of [auxtok] *)
//
in
//
case+ toks of
| list_nil () => ()
| list_cons (tok, toks) =>
  (
    auxtok (out, tok); emit_extcode (out, toks)
  ) (* end of [list_cons] *)
//
end // end of [emit_tokenlst]

(* ****** ****** *)
//
implement
emit_extval
  (out, toks) = emit_tokenlst (out, toks)
implement
emit_extcode
  (out, toks) = emit_tokenlst (out, toks)
//
(* ****** ****** *)

(* end of [atsparemit_emit.dats] *)