Updating: very minorly improving

Updating: very minorly improving

(*
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
** EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
** OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
** NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
** HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
** WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
** OTHER DEALINGS IN THE SOFTWARE.
*)

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

(*
** A library for
** parsing combinators in CPS-stype
*)

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: December, 2015
//
(* ****** ****** *)
//
abstype
kparser_type(a:t@ype+) = ptr
//
typedef
kparser(a:t@ype) = kparser_type(a)
//
(* ****** ****** *)
//
typedef
cfun1(a:t@ype, b:t@ype) = (a) -<cloref1> b
typedef
cfun2(a1:t@ype, a2:t@ype, b:t@ype) = (a1, a2) -<cloref1> b
typedef
cfun3(a1:t@ype, a2:t@ype, a3:t@ype, b:t@ype) = (a1, a2, a3) -<cloref1> b
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_fail(): kparser(a)
//
extern
fun
{a:t@ype}
kparser_just(x: a): kparser(a)
//
(* ****** ****** *)

extern
fun
{a:t@ype}
kparser_option
(
  kp: kparser(INV(a))
) : kparser(Option(a)) // end-of-fun

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

extern
fun
{a:t@ype}
kparser_satisfy
(
  kparser(INV(a)), test: cfun1(a, bool)
) : kparser(a) // end-of-fun

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

extern
fun
{a:t@ype}
kparser_skip_if
(
  kparser(INV(a)), test: cfun1(a, bool)
) : kparser(int) // end-of-fun
extern
fun
{a:t@ype}
kparser_skip_ifnot
(
  kparser(INV(a)), test: cfun1(a, bool)
) : kparser(int) // end-of-fun

(* ****** ****** *)
//
extern
fun
{a1
,a2:t@ype}
kparser_join2
(
  kparser(INV(a1)), kparser(INV(a2))
) : kparser(@(a1, a2)) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a1
,a2
,a3:t@ype}
kparser_join3
(
  kparser(INV(a1)), kparser(INV(a2)), kparser(INV(a3))
) : kparser(@(a1, a2, a3)) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
{b:t@ype}
kparser_fmap
  (kparser(INV(a)), fopr: cfun1(a, b)) : kparser(b)
//
extern
fun
{a1
,a2:t@ype
}{b:t@ype}
kparser_fmap2
(
  kparser(INV(a1)), kparser(INV(a2)), fopr: cfun2(a1, a2, b)
) : kparser(b) // end-of-fun
//
(* ****** ****** *)
//
extern
fun{
a1,a2:t@ype
} kparser_first
  (kp1: kparser(INV(a1)), kp2: kparser(INV(a2))): kparser(a1)
//
extern
fun{
a1,a2:t@ype
} kparser_second
  (kp1: kparser(INV(a1)), kp2: kparser(INV(a2))): kparser(a2)
//
overload << with kparser_first
overload >> with kparser_second
//
(* ****** ****** *)
//
extern
fun
{a1
,a2
,a3:t@ype
}{b:t@ype}
kparser_fmap3
(
  kp1: kparser(INV(a1))
, kp2: kparser(INV(a2))
, kp3: kparser(INV(a3))
, fopr: cfun3(a1, a2, a3, b)
) : kparser(b) // end-of-fun
//
(* ****** ****** *)
//
extern
fun{
a1,a2,a3:t@ype
} kparser_middle
(
  kp1: kparser(INV(a1))
, kp2: kparser(INV(a2))
, kp3: kparser(INV(a3))
) : kparser(a2) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_orelse
  (kp1: kparser(INV(a)), kp2: kparser(a)): kparser(a)
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_cloref
  (((*void*)) -<cloref1> kparser(a)): kparser(a)
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_repeat0(kp: kparser(INV(a))): kparser(List0(a))
extern
fun
{a:t@ype}
kparser_repeat1(kp: kparser(INV(a))): kparser(List1(a))
//
(* ****** ****** *)
//
// HX-2015-12
// For parsing sequences of chars
//
(* ****** ****** *)
//
// HX-2015-12:
// This one remains abstract
//
extern
fun{}
kparser_char((*void*)): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_alpha((*void*)): kparser(char)
extern
fun{}
kparser_alnum((*void*)): kparser(char)
extern
fun{}
kparser_digit((*void*)): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_litchar(c0: char): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_literal(lit: string): kparser(int)
//
(* ****** ****** *)
//
abstype
parinp_type = ptr
abstype
parout_type = ptr
//
typedef parinp = parinp_type
typedef parout = parout_type
//
(* ****** ****** *)
//
typedef
parcont(a:t@ype) =
  (a, parinp) -<cloref1> parout
//
(* ****** ****** *)

exception ParFailExn of ((*void*))

(* ****** ****** *)
//
typedef
parinp_nullify
  (a:t@ype) =
  (parinp, parcont(a)) -<cloref1> parout
//
(* ****** ****** *)
//
extern
castfn
kparser_encode
  {a:t@ype}(parinp_nullify(a)): kparser(a)
//
extern
castfn
kparser_decode
  {a:t@ype}(kp: kparser(a)): parinp_nullify(a)
//
(* ****** ****** *)
//
extern
fun{}
parcont_fail(inp: parinp): parout
//
implement
{}(*tmp*)
parcont_fail(inp) = $raise ParFailExn()
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
kparser_fail() =
kparser_encode
  (lam(inp, kont) => parcont_fail(inp))
//
implement
{a}(*tmp*)
kparser_just(x) =
  kparser_encode(lam(inp, kont) => kont(x, inp))
//
(* ****** ****** *)

implement
{a}(*tmp*)
kparser_option
  (kpar) = let
//
val kpar = kparser_decode(kpar)
//
in
//
kparser_encode(
//
lam(inp, kont) => (
try
kpar
( inp
, lam(x, inp2) => kont(Some(x), inp2)
) (* kpar *)
with ~ParFailExn() => kont(None(), inp)
) (* end of [lam] *)
) (* kparser_encode *)
//
end // end of [kparser_option]

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

implement
{a}(*tmp*)
kparser_satisfy
  (kpar, test) = let
//
val kpar = kparser_decode(kpar)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kpar
( inp
, lam(x, inp) =>
  if test(x) then kont(x, inp) else parcont_fail(inp)
)
//
) (* kparser_encode *)
//
end // end of [kparser_satisfy]

(* ****** ****** *)
//
implement
{a}(*tmp*)
kparser_skip_if
  (kpar, test) = let
//
val
kpar = kparser_decode(kpar)
//
fun
auxskip
(
  inp: parinp, kont: parcont(int)
) : parout = let
in
//
kpar
( inp
, lam(x, inp2) =>
  if test(x)
    then auxskip(inp2, kont) else kont(0, inp)
  // end of [if]
)
//
end // end of [auxskip]
//
in
//
kparser_encode(lam(inp, kont) => auxskip(inp, kont))
//
end // end of [kparser_skip_if]
//
implement
{a}(*tmp*)
kparser_skip_ifnot
  (kpar, test) = kparser_skip_if<a>(kpar, lam(x) => ~test(x))
//
(* ****** ****** *)

implement
{a1,a2}
kparser_join2
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(@(x1, x2), inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_join2]

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

implement
{a1,a2,a3}
kparser_join3
  (kp1, kp2, kp3) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
val kp3 = kparser_decode(kp3)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2
  ( inp
  , lam(x2, inp) =>
    kp3(inp, lam(x3, inp) => kont(@(x1, x2, x3), inp))
  )
)
//
) (* kparser_encode *)
//
end // end of [kparser_join3]

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

implement
{a}{b}
kparser_fmap
  (kp, fopr) = let
//
val kp = kparser_decode(kp)
//
in
//
kparser_encode(
//
lam(inp, kont) => kp(inp, lam(x, inp) => kont(fopr(x), inp))
//
) (* kparser_encode *)
//
end // end of [kparser_fmap]

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

implement
{a1,a2}{b}
kparser_fmap2
  (kp1, kp2, fopr) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(fopr(x1, x2), inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_fmap2]

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

implement
{a1,a2,a3}{b}
kparser_fmap3
  (kp1, kp2, kp3, fopr) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
val kp3 = kparser_decode(kp3)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2
  ( inp
  , lam(x2, inp) =>
    kp3(inp, lam(x3, inp) => kont(fopr(x1, x2, x3), inp))
  )
)
//
) (* kparser_encode *)
//
end // end of [kparser_fmap3]

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

implement
{a1,a2}
kparser_first
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(x1, inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_first]

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

implement
{a1,a2}
kparser_second
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(x2, inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_second]

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

implement
{a}(*tmp*)
kparser_orelse
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
  try kp1(inp, kont) with ~ParFailExn() => kp2(inp, kont)
//
) (* kparser_encode *)
//
end // end of [kparser_orelse]

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

implement
{a}(*tmp*)
kparser_cloref
  (fkp) = let
(*
val () =
println! ("kparser_cloref")
*)
in
//
kparser_encode(
//
lam(inp, kont) =>
  let val kp = kparser_decode(fkp()) in kp(inp, kont) end
//
) (* kparser_encode *)
//
end // end of [kparser_cloref]

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

implement
{a}(*tmp*)
kparser_repeat0
  (kpar) = let
//
val kpar = kparser_decode(kpar)
//
fun
kaux
( inp: parinp, kont: parcont(List0(a))
) : parout = let
//
in
//
try
kpar
( inp
, lam(x, inp) =>
  kaux
  ( inp
  , lam(xs, inp) => kont(cons(x, xs), inp)
  )
)
with ~ParFailExn() => kont(list_nil(), inp)
//
end // end of [aux]
//
in
  kparser_encode(lam(inp, kont) => kaux(inp, kont))
end // end of [kparser_repeat0]

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

implement
{a}(*tmp*)
kparser_repeat1
  (kpar) = let
(*
val () = println! ("kparser_repeat1")
*)
in
//
kparser_fmap2<a,List0(a)><List1(a)>
  (kpar, kparser_repeat0<a>(kpar), lam(x, xs) => cons(x, xs))
//
end // end of [kparser_repeat1]

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

(*
//
// HX-2015-12-25:
// this one works, too!
//
implement{a}
kparser_repeat0(kp) =
kparser_orelse(
  kparser_cloref<List0(a)>(lam() => kparser_repeat1<a>(kp)), kparser_just<List0(a)>(list_nil())
) (* kparser_orelse *)
)
//
*)

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

implement
{}(*tmp*)
kparser_alpha
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isalpha(c))
end // end of [kparser_alpha]

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

implement
{}(*tmp*)
kparser_alnum
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isalnum(c))
end // end of [kparser_alnum]

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

implement
{}(*tmp*)
kparser_digit
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isdigit(c))
end // end of [kparser_digit]

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

implement
{}(*tmp*)
kparser_litchar
  (c0) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c1) => c0 = c1)
end // end of [kparser_litchar]

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

implement
{}(*tmp*)
kparser_literal
  (lit) = let
//
val
[n:int]
lit = g1ofg0(lit)
//
val
ncs = sz2i(string_length(lit))
//
fun
loop(i: natLte(n)): kparser(int) =
if i < ncs
  then kparser_litchar(lit[i]) >> loop(i+1) else kparser_just(0)
// end of [if]
//
in
  loop(0)
end // end of [kparser_literal]

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

#ifdef
PARINP_EQ_LIST_CHAR
//
local
//
assume
parinp_type =
List0(char)
//
in (* in-of-local *)
//
implement
{}(*tmp*)
kparser_char
  ((*void*)) =
kparser_encode
  {char}(
//
lam(inp, kont) =>
(
  case+ inp of
  | list_cons(c, inp2) => kont(c, inp2) | list_nil() => $raise ParFailExn()
)
//
) (* kparser_char *)
//
end // end of [local]
//
#endif // #ifdef PARINP_EQ_LIST_CHAR

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

#ifdef
PARINP_EQ_STREAM_CHAR
//
local
//
assume
parinp_type =
stream(char)
//
in (* in-of-local *)
//
implement
{}(*tmp*)
kparser_char
  ((*void*)) =
kparser_encode
  {char}(
//
lam(inp, kont) =>
(
  case+ !inp of
  | stream_cons(c, inp2) => kont(c, inp2) | stream_nil() => $raise ParFailExn()
)
//
) (* kparser_char *)
//
end // end of [local]
//
#endif // #ifdef PARINP_EQ_STREAM_CHAR

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

(* end of [kparcomb.hats] *)

(*
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
** EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
** OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
** NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
** HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
** WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
** OTHER DEALINGS IN THE SOFTWARE.
*)

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

(*
** A library for
** parsing combinators in CPS-stype
*)

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: December, 2015
//
(* ****** ****** *)
//
abstype
kparser_type(a:t@ype+) = ptr
//
typedef
kparser(a:t@ype) = kparser_type(a)
//
(* ****** ****** *)
//
typedef
cfun1(a:t@ype, b:t@ype) = (a) -<cloref1> b
typedef
cfun2(a1:t@ype, a2:t@ype, b:t@ype) = (a1, a2) -<cloref1> b
typedef
cfun3(a1:t@ype, a2:t@ype, a3:t@ype, b:t@ype) = (a1, a2, a3) -<cloref1> b
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_fail(): kparser(a)
//
extern
fun
{a:t@ype}
kparser_just(x: a): kparser(a)
//
(* ****** ****** *)

extern
fun
{a:t@ype}
kparser_satisfy
(
  kparser(INV(a)), test: cfun1(a, bool)
) : kparser(a) // end-of-fun

(* ****** ****** *)
//
extern
fun
{a1
,a2:t@ype}
kparser_join2
(
  kparser(INV(a1)), kparser(INV(a2))
) : kparser(@(a1, a2)) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a1
,a2
,a3:t@ype}
kparser_join3
(
  kparser(INV(a1)), kparser(INV(a2)), kparser(INV(a3))
) : kparser(@(a1, a2, a3)) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
{b:t@ype}
kparser_fmap
  (kparser(INV(a)), fopr: cfun1(a, b)) : kparser(b)
//
extern
fun
{a1
,a2:t@ype
}{b:t@ype}
kparser_fmap2
(
  kparser(INV(a1)), kparser(INV(a2)), fopr: cfun2(a1, a2, b)
) : kparser(b) // end-of-fun
//
(* ****** ****** *)
//
extern
fun{
a1,a2:t@ype
} kparser_first
  (kp1: kparser(INV(a1)), kp2: kparser(INV(a2))): kparser(a1)
//
extern
fun{
a1,a2:t@ype
} kparser_second
  (kp1: kparser(INV(a1)), kp2: kparser(INV(a2))): kparser(a2)
//
overload << with kparser_first
overload >> with kparser_second
//
(* ****** ****** *)
//
extern
fun
{a1
,a2
,a3:t@ype
}{b:t@ype}
kparser_fmap3
(
  kp1: kparser(INV(a1))
, kp2: kparser(INV(a2))
, kp3: kparser(INV(a3))
, fopr: cfun3(a1, a2, a3, b)
) : kparser(b) // end-of-fun
//
(* ****** ****** *)
//
extern
fun{
a1,a2,a3:t@ype
} kparser_middle
(
  kp1: kparser(INV(a1))
, kp2: kparser(INV(a2))
, kp3: kparser(INV(a3))
) : kparser(a2) // end-of-fun
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_orelse
  (kp1: kparser(INV(a)), kp2: kparser(a)): kparser(a)
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_cloref
  (((*void*)) -<cloref1> kparser(a)): kparser(a)
//
(* ****** ****** *)
//
extern
fun
{a:t@ype}
kparser_repeat0(kp: kparser(INV(a))): kparser(List0(a))
extern
fun
{a:t@ype}
kparser_repeat1(kp: kparser(INV(a))): kparser(List1(a))
//
(* ****** ****** *)
//
// HX-2015-12
// For parsing sequences of chars
//
(* ****** ****** *)
//
// HX-2015-12:
// This one remains abstract
//
extern
fun{}
kparser_char((*void*)): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_alpha((*void*)): kparser(char)
extern
fun{}
kparser_alnum((*void*)): kparser(char)
extern
fun{}
kparser_digit((*void*)): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_litchar(c0: char): kparser(char)
//
(* ****** ****** *)
//
extern
fun{}
kparser_literal(lit: string): kparser(int)
//
(* ****** ****** *)
//
abstype
parinp_type = ptr
abstype
parout_type = ptr
//
typedef parinp = parinp_type
typedef parout = parout_type
//
(* ****** ****** *)
//
typedef
parcont(a:t@ype) =
  (a, parinp) -<cloref1> parout
//
(* ****** ****** *)

exception ParFailExn of ((*void*))

(* ****** ****** *)
//
typedef
parinp_nullify
  (a:t@ype) =
  (parinp, parcont(a)) -<cloref1> parout
//
(* ****** ****** *)
//
extern
castfn
kparser_encode
  {a:t@ype}(parinp_nullify(a)): kparser(a)
//
extern
castfn
kparser_decode
  {a:t@ype}(kp: kparser(a)): parinp_nullify(a)
//
(* ****** ****** *)
//
extern
fun{}
parcont_fail(inp: parinp): parout
//
implement
{}(*tmp*)
parcont_fail(inp) = $raise ParFailExn()
//
(* ****** ****** *)
//
implement
{a}(*tmp*)
kparser_fail() =
kparser_encode
  (lam(inp, kont) => parcont_fail(inp))
//
implement
{a}(*tmp*)
kparser_just(x) =
  kparser_encode(lam(inp, kont) => kont(x, inp))
//
(* ****** ****** *)

implement
{a}(*tmp*)
kparser_satisfy
  (kpar, test) = let
//
val kpar = kparser_decode(kpar)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kpar
( inp
, lam(x, inp) =>
  if test(x) then kont(x, inp) else parcont_fail(inp)
)
//
) (* kparser_encode *)
//
end // end of [kparser_satisfy]

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

implement
{a1,a2}
kparser_join2
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(@(x1, x2), inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_join2]

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

implement
{a1,a2,a3}
kparser_join3
  (kp1, kp2, kp3) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
val kp3 = kparser_decode(kp3)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2
  ( inp
  , lam(x2, inp) =>
    kp3(inp, lam(x3, inp) => kont(@(x1, x2, x3), inp))
  )
)
//
) (* kparser_encode *)
//
end // end of [kparser_join3]

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

implement
{a}{b}
kparser_fmap
  (kp, fopr) = let
//
val kp = kparser_decode(kp)
//
in
//
kparser_encode(
//
lam(inp, kont) => kp(inp, lam(x, inp) => kont(fopr(x), inp))
//
) (* kparser_encode *)
//
end // end of [kparser_fmap]

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

implement
{a1,a2}{b}
kparser_fmap2
  (kp1, kp2, fopr) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(fopr(x1, x2), inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_fmap2]

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

implement
{a1,a2,a3}{b}
kparser_fmap3
  (kp1, kp2, kp3, fopr) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
val kp3 = kparser_decode(kp3)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2
  ( inp
  , lam(x2, inp) =>
    kp3(inp, lam(x3, inp) => kont(fopr(x1, x2, x3), inp))
  )
)
//
) (* kparser_encode *)
//
end // end of [kparser_fmap3]

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

implement
{a1,a2}
kparser_first
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(x1, inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_first]

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

implement
{a1,a2}
kparser_second
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
kp1
( inp
, lam(x1, inp) =>
  kp2(inp, lam(x2, inp) => kont(x2, inp))
)
//
) (* kparser_encode *)
//
end // end of [kparser_second]

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

implement
{a}(*tmp*)
kparser_orelse
  (kp1, kp2) = let
//
val kp1 = kparser_decode(kp1)
val kp2 = kparser_decode(kp2)
//
in
//
kparser_encode(
//
lam(inp, kont) =>
  try kp1(inp, kont) with ~ParFailExn() => kp2(inp, kont)
//
) (* kparser_encode *)
//
end // end of [kparser_orelse]

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

implement
{a}(*tmp*)
kparser_cloref
  (fkp) = let
(*
val () =
println! ("kparser_cloref")
*)
in
//
kparser_encode(
//
lam(inp, kont) =>
  let val kp = kparser_decode(fkp()) in kp(inp, kont) end
//
) (* kparser_encode *)
//
end // end of [kparser_cloref]

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

implement
{a}(*tmp*)
kparser_repeat0
  (kpar) = let
//
val kpar = kparser_decode(kpar)
//
fun
kaux
( inp: parinp, kont: parcont(List0(a))
) : parout = let
//
in
//
try
kpar
( inp
, lam(x, inp) =>
  kaux
  ( inp
  , lam(xs, inp) => kont(cons(x, xs), inp)
  )
)
with ~ParFailExn() => kont(list_nil(), inp)
//
end // end of [aux]
//
in
  kparser_encode(lam(inp, kont) => kaux(inp, kont))
end // end of [kparser_repeat0]

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

implement
{a}(*tmp*)
kparser_repeat1
  (kpar) = let
(*
val () = println! ("kparser_repeat1")
*)
in
//
kparser_fmap2<a,List0(a)><List1(a)>
  (kpar, kparser_repeat0<a>(kpar), lam(x, xs) => cons(x, xs))
//
end // end of [kparser_repeat1]

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

(*
//
// HX-2015-12-25:
// this one works, too!
//
implement{a}
kparser_repeat0(kp) =
kparser_orelse(
  kparser_cloref<List0(a)>(lam() => kparser_repeat1<a>(kp)), kparser_just<List0(a)>(list_nil())
) (* kparser_orelse *)
)
//
*)

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

implement
{}(*tmp*)
kparser_alpha
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isalpha(c))
end // end of [kparser_alpha]

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

implement
{}(*tmp*)
kparser_alnum
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isalnum(c))
end // end of [kparser_alnum]

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

implement
{}(*tmp*)
kparser_digit
  ((*void*)) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c) => isdigit(c))
end // end of [kparser_digit]

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

implement
{}(*tmp*)
kparser_litchar
  (c0) = let
  val kp = kparser_char<>()
in
  kparser_satisfy<char>(kp, lam(c1) => c0 = c1)
end // end of [kparser_litchar]

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

implement
{}(*tmp*)
kparser_literal
  (lit) = let
//
val
[n:int]
lit = g1ofg0(lit)
//
val
ncs = sz2i(string_length(lit))
//
fun
loop(i: natLte(n)): kparser(int) =
if i < ncs
  then kparser_litchar(lit[i]) >> loop(i+1) else kparser_just(0)
// end of [if]
//
in
  loop(0)
end // end of [kparser_literal]

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

#ifdef
PARINP_EQ_LIST_CHAR
//
local
//
assume
parinp_type =
List0(char)
//
in (* in-of-local *)
//
implement
{}(*tmp*)
kparser_char
  ((*void*)) =
kparser_encode
  {char}(
//
lam(inp, kont) =>
(
  case+ inp of
  | list_cons(c, inp2) => kont(c, inp2) | list_nil() => $raise ParFailExn()
)
//
) (* kparser_char *)
//
end // end of [local]
//
#endif // #ifdef PARINP_EQ_LIST_CHAR

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

#ifdef
PARINP_EQ_STREAM_CHAR
//
local
//
assume
parinp_type =
stream(char)
//
in (* in-of-local *)
//
implement
{}(*tmp*)
kparser_char
  ((*void*)) =
kparser_encode
  {char}(
//
lam(inp, kont) =>
(
  case+ !inp of
  | stream_cons(c, inp2) => kont(c, inp2) | stream_nil() => $raise ParFailExn()
)
//
) (* kparser_char *)
//
end // end of [local]
//
#endif // #ifdef PARINP_EQ_STREAM_CHAR

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

(* end of [kparcomb.hats] *)


Keeping pace with upstream.

Keeping pace with upstream.

Also, added local/argument distinction (currently, by analysing
tmpvar names).

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

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

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_symbol (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 () = emit_text (out, "ldloc")
    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_symbol (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 () = emit_text (out, "stloc")
    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 => ()
  where {
    val () = emit_text (out, "#include")
    val () = emit_SPACE (out)
//    val () = emit_text (out, include)
    val () = emit_newline (out)
  }
//
| D0Cifdef (i0de, d0eclist) => ()
| D0Cifndef (i0de, d0eclist) => ()
//
| 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] *)


Various improvements to atsparemit-CIL. Still untested.

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

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_symbol (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 () = emit_text (out, "ldloc")
    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_symbol (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 () = emit_text (out, "stloc")
    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 => ()
  where {
    val () = emit_text (out, "#include")
    val () = emit_SPACE (out)
//    val () = emit_text (out, include)
    val () = emit_newline (out)
  }
//
| D0Cifdef (i0de, d0eclist) => ()
| D0Cifndef (i0de, d0eclist) => ()
//
| 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"
//
(* ****** ****** *)

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_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_symbol (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]

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

implement
emit_d0exp
  (out, d0e) = let
in
//
case+
d0e.d0exp_node of
//
| _ => ()
//
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) => emit_i0de (out, id) // FIXME: how to emit type decl?
//
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]
//
(* ****** ****** *)
implement
emit_f0body
  (out, fbody) = let
//
val tmpdecs =
  f0body_get_tmpdeclst (fbody)
val inss_body =
  f0body_get_bdinstrlst (fbody)
//
val () = the_tmpdeclst_set (tmpdecs)
val () = the_funbodylst_set (inss_body)
val () = emit_LBRACE (out)
// TODO: insert body
val () = emit_newline (out)
val () = emit_text (out, ".maxstack 1")
// 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_text (out, "IL_0000: ret")
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]

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

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]

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

implement
emit_d0ecl
  (out, d0c) = let
in
//
case+
d0c.d0ecl_node of
//
| D0Cinclude include => ()
  where {
    val () = emit_text (out, "#include")
    val () = emit_SPACE (out)
//    val () = emit_text (out, include)
    val () = emit_newline (out)
  }
//
| D0Cifdef (i0de, d0eclist) => ()
| D0Cifndef (i0de, d0eclist) => ()
//
| 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] *)


Add header

Add header

(*
 * For LinkSprite 16X2 LCD Keypad Shield for Arduino
 * http://store.linksprite.com/linksprite-16x2-lcd-keypad-shield-for-arduino-version-b/
 * http://www.linksprite.com/wiki/index.php5?title=16_X_2_LCD_Keypad_Shield_for_Arduino
 *)
#define ATS_DYNLOADFLAG 0 // no dynloading at run-time
#include "share/atspre_define.hats"
#include "share/atspre_staload.hats"
staload "SATS/arduino.sats"
staload "SATS/lcd.sats"
staload UN = "prelude/SATS/unsafe.sats"

%{
inline uint8_t atspre_uint8_bit_or(uint8_t a, uint8_t b) { return (a | b); }
inline uint8_t atspre_uint8_bit_and(uint8_t a, uint8_t b) { return (a & b); }
%}
extern fun uint8_bit_or: (uint8, uint8) -> uint8 = "mac#atspre_uint8_bit_or"
extern fun uint8_bit_and: (uint8, uint8) -> uint8 = "mac#atspre_uint8_bit_and"

(* Private struct *)
vtypedef LCD_struct = @{
  rs_pin          = uint8 // LOW: command.  HIGH: character.
, rw_pin          = uint8 // LOW: write to LCD.  HIGH: read from LCD.
, enable_pin      = uint8 // activated by a HIGH pulse.
, data_pins       = @(uint8, uint8, uint8, uint8)
, displayfunction = uint8
, displaycontrol  = uint8
, displaymode     = uint8
, numlines        = uint8
, currline        = uint8
}
absvtype LCD_minus_struct (l:addr)
extern castfn
LCD_takeout_struct (* xxx Should lock *)
(
  tcp: !LCD >> LCD_minus_struct l
) : #[l:addr] (LCD_struct @ l | ptr l)
extern praxi
LCD_addback_struct (* xxx Should unlock *)
  {l:addr}
(
  pfat: LCD_struct @ l
| tcp: !LCD_minus_struct l >> LCD
) : void

(* Low level functions *)
extern fun lcd_display: {l:addr} (!LCD_struct @ l | ptr l) -> void
extern fun lcd_command: {l:addr} (!LCD_struct @ l | ptr l, uint8) -> void
extern fun lcd_send: {l:addr} (!LCD_struct @ l | ptr l, uint8, HIGHLOW) -> void
extern fun lcd_pulseEnable: {l:addr} (!LCD_struct @ l | ptr l) -> void
extern fun lcd_write4bits: {l:addr} (!LCD_struct @ l | ptr l, uint8) -> void

local
  var _global_lcd_struct: LCD_struct
in
  implement lcd_open (rs, rw, enable, d0, d1, d2, d3) = let
    val lcd = $UN.castvwtp0 (addr@_global_lcd_struct)
    val (pfat | p) = LCD_takeout_struct (lcd)
    val () = p->rs_pin     := rs
    val () = p->rw_pin     := rw
    val () = p->enable_pin := enable
    val () = p->data_pins  := @(d0, d1, d2, d3)
    val () = pinMode (p->rs_pin, OUTPUT)
    val () = pinMode (p->rw_pin, OUTPUT)
    val () = pinMode (p->enable_pin, OUTPUT)
    val LCD_4BITMODE = $UN.cast 0x00
    val LCD_2LINE    = $UN.cast 0x08
    val LCD_5x8DOTS  = $UN.cast 0x00
    val () = p->displayfunction := uint8_bit_or (LCD_4BITMODE, uint8_bit_or (LCD_2LINE, LCD_5x8DOTS))
    prval () = LCD_addback_struct(pfat | lcd)
    fun lcd_begin (lcd: !LCD, lines: uint8): void = {
      val (pfat | p) = LCD_takeout_struct (lcd)
      val () = p->numlines := lines
      val () = p->currline := $UN.cast 0
      val () = _delay_us 50000.0
      val () = digitalWrite (p->rs_pin, LOW)
      val () = digitalWrite (p->enable_pin, LOW)
      val () = digitalWrite (p->rw_pin, LOW)
      val displayfunction = p->displayfunction
      // this is according to the hitachi HD44780 datasheet / figure 24, pg 46
      // we start in 8bit mode, try to set 4 bit mode
      val () = lcd_write4bits (pfat | p, $UN.cast 0x03)
      val () = _delay_us 4500.0
      val () = lcd_write4bits (pfat | p, $UN.cast 0x03) // second try
      val () = _delay_us 4500.0
      val () = lcd_write4bits (pfat | p, $UN.cast 0x03) // third go!
      val () = _delay_us 150.0
      val () = lcd_write4bits (pfat | p, $UN.cast 0x02) // finally, set to 4-bit interface
      // finally, set # lines, font size, etc.
      val LCD_FUNCTIONSET = $UN.cast 0x20
      val () = lcd_command (pfat | p, uint8_bit_or (LCD_FUNCTIONSET, displayfunction))
      // turn the display on with no cursor or blinking default
      val LCD_DISPLAYON = $UN.cast 0x04
      val LCD_CURSOROFF = $UN.cast 0x00
      val LCD_BLINKOFF  = $UN.cast 0x00
      val () = p->displaycontrol := uint8_bit_or (LCD_DISPLAYON, uint8_bit_or (LCD_CURSOROFF, LCD_BLINKOFF))
      val () = lcd_display (pfat | p)
      // Initialize to default text direction (for romance languages)
      val LCD_ENTRYLEFT           = $UN.cast 0x02
      val LCD_ENTRYSHIFTDECREMENT = $UN.cast 0x00
      val () = p->displaymode := uint8_bit_or (LCD_ENTRYLEFT, LCD_ENTRYSHIFTDECREMENT)
      val displaymode = p->displaymode
      // set the entry mode
      val LCD_ENTRYMODESET = $UN.cast 0x04
      val () = lcd_command (pfat | p, uint8_bit_or (LCD_ENTRYMODESET, displaymode))
      prval () = LCD_addback_struct(pfat | lcd)
      // clear it off
      val () = lcd_clear lcd
    }
    val () = lcd_begin (lcd, $UN.cast 2)
  in
    lcd
  end
end

implement lcd_close (lcd) = {
  val () = $UN.castvwtp0(lcd) (* Consume lcd *)
}

implement lcd_clear (lcd) = {
  val LCD_CLEARDISPLAY = $UN.cast 0x01
  val (pfat | p) = LCD_takeout_struct (lcd)
  val () = lcd_command (pfat | p, LCD_CLEARDISPLAY) // clear display, set cursor position to zero
  prval () = LCD_addback_struct(pfat | lcd)
  val () = _delay_us 2000.0 // this command takes a long time!
}

implement lcd_setCursor (lcd, col, row) = {
  val LCD_SETDDRAMADDR = $UN.cast 0x80
  val row_ofs = if row > 0 then 0x40 else 0x00
  val (pfat | p) = LCD_takeout_struct (lcd)
  val () = lcd_command(pfat | p,  uint8_bit_or (LCD_SETDDRAMADDR, col + $UN.cast row_ofs))
  prval () = LCD_addback_struct(pfat | lcd)
}

implement lcd_print (lcd, str, start, len) = {
  fun w (lcd: !LCD, p: ptr): void = {
    val c = $UN.ptr0_get<uint8> (p)
    val () = lcd_write (lcd, c)
  }
  fun loop (lcd: !LCD, p: ptr, r: int): void = {
    val () = if r > 0 then (w (lcd, p); loop (lcd, ptr_succ<char> (p), r - 1))
  }
  val p0 = string2ptr (str)
  val p0 = ptr_add<char> (p0, start)
  val () = loop (lcd, p0, len)
}

implement lcd_write (lcd, value) = {
  val (pfat | p) = LCD_takeout_struct (lcd)
  val () = lcd_send (pfat | p, value, HIGH)
  prval () = LCD_addback_struct(pfat | lcd)
}

implement lcd_display (pfat | p) = {
  val LCD_DISPLAYON = $UN.cast 0x04
  val () = p->displaycontrol := LCD_DISPLAYON
  val displaycontrol = p->displaycontrol
  val LCD_DISPLAYCONTROL = $UN.cast 0x08
  val () = lcd_command (pfat | p, uint8_bit_or (LCD_DISPLAYCONTROL, displaycontrol))
}

implement lcd_command (pfat | p, value) = {
  val () = lcd_send (pfat | p, value, LOW)
}

implement lcd_send (pfat | p, value, mode) = {
  val () = digitalWrite (p->rs_pin, mode)
  val () = digitalWrite (p->rw_pin, LOW)
  val () = lcd_write4bits (pfat | p, value >> 4)
  val () = lcd_write4bits (pfat | p, value)
}

implement lcd_pulseEnable (pfat | p) = {
  val () = digitalWrite (p->enable_pin, LOW)
  val () = _delay_us 1.0
  val () = digitalWrite (p->enable_pin, HIGH)
  val () = _delay_us 1.0 // enable pulse must be >450ns
  val () = digitalWrite (p->enable_pin, LOW)
  val () = _delay_us 100.0 // commands need > 37us to settle
}

implement lcd_write4bits (pfat | p, value) = {
  fun uint8_to_highlow (v: uint8): HIGHLOW = $UN.cast (uint8_bit_and (v, $UN.cast 0x01))
  val () = pinMode (p->data_pins.0, OUTPUT)
  val () = digitalWrite (p->data_pins.0, uint8_to_highlow (value >> 0))
  val () = pinMode (p->data_pins.1, OUTPUT)
  val () = digitalWrite (p->data_pins.1, uint8_to_highlow (value >> 1))
  val () = pinMode (p->data_pins.2, OUTPUT)
  val () = digitalWrite (p->data_pins.2, uint8_to_highlow (value >> 2))
  val () = pinMode (p->data_pins.3, OUTPUT)
  val () = digitalWrite (p->data_pins.3, uint8_to_highlow (value >> 3))
  val () = lcd_pulseEnable (pfat | p)
}