Updating: very minorly improving

Updating: very minorly improving

(*
** A queue of channels
*)
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
(*
#define ATS_PACKNAME "queue2"
*)
//
#define ATS_EXTERN_PREFIX "queue2_"
#define ATS_STATIC_PREFIX "_queue2_"
//
(* ****** ****** *)

%{^
%%
-module(queue2_dats).
%%
-export([main0_erl/0]).
%%
-compile(nowarn_unused_vars).
-compile(nowarn_unused_function).
%%
-export([ats2erlpre_cloref1_app/2]).
-export([libats2erl_session_chque_server/0]).
-export([libats2erl_session_chanpos_server/2]).
-export([libats2erl_session_channeg_server/2]).
%%
-include("./libatscc2erl/libatscc2erl_all.hrl").
-include("./libatscc2erl/Sessiontype_mylibats2erl_all.hrl").
%%
%} // end of [%{]

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$LIBATSCC2ERL}/staloadall.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

staload "./../SATS/basis.sats"
staload "./../DATS/basis_chan2.dats"

(* ****** ****** *)
//
(*
//
datatype
ssque(a:t@ype, int) =
  | ssque_nil(a, 0) of ()
  | {n:pos}
    ssque_deq(a, n) of (snd(a), ssque(a,n-1))
  | {n:pos}
    ssque_top(a, n) of (snd(a), ssque(a,n-0))
  | {n:nat}
    ssque_enq(a, n) of (rcv(a), ssque(a,n+1))
//
*)
abstype ssque(a:t@ype, n:int)
//
(* ****** ****** *)
//
datatype
chanpos_ssque
  (a:t@ype, type, int) =
  | chanpos_ssque_nil(a, nil, 0) of ()
  | {n:pos}
    chanpos_ssque_deq(a,chsnd(a)::ssque(a,n-1),n) of ()
  | {n:pos}
    chanpos_ssque_top(a,chsnd(a)::ssque(a,n-0),n) of ()
  | {n:nat}
    chanpos_ssque_enq(a,chrcv(a)::ssque(a,n+1),n) of ()
//
(* ****** ****** *)
//
extern
fun
chanpos_ssque
  {a:t@ype}{n:nat}
  (!chanpos(ssque(a,n)) >> chanpos(ss))
: #[ss:type] chanpos_ssque(a, ss, n) = "mac#%"
//
(* ****** ****** *)
//
extern
fun
channeg_ssque_nil
  {a:t@ype}
  (!channeg(ssque(a,0)) >> channeg(nil)): void = "mac#%"
extern
fun
channeg_ssque_deq
  {a:t@ype}{n:pos}
  (!channeg(ssque(a,n)) >> channeg(chsnd(a)::ssque(a,n-1))): void = "mac#%"
and
channeg_ssque_top
  {a:t@ype}{n:pos}
  (!channeg(ssque(a,n)) >> channeg(chsnd(a)::ssque(a,n-0))): void = "mac#%"
and
channeg_ssque_enq
  {a:t@ype}{n:nat}
  (!channeg(ssque(a,n)) >> channeg(chrcv(a)::ssque(a,n+1))): void = "mac#%"
//
(* ****** ****** *)

implement
chanpos_ssque
  {a}{n}(chpos) = let
//
val
chpos2 = $UN.castvwtp1{chanpos2}(chpos)
val tag = chanpos2_recv{natLt(4)}(chpos2)
//
prval () = $UN.cast2void(chpos2)
//
in
//
case+ tag of
| 0 => let
    prval () = $UN.prop_assert{n==0}()
    prval () =
    $UN.castview2void(chpos) in chanpos_ssque_nil()
  end // end of [prval]
| 1 => let
    prval () = $UN.prop_assert{n > 0}()
    prval () =
    $UN.castview2void(chpos) in chanpos_ssque_deq()
  end // end of [prval]
| 2 => let
    prval () = $UN.prop_assert{n > 0}()
    prval () =
    $UN.castview2void(chpos) in chanpos_ssque_top()
  end // end of [prval]
| 3 => let
    prval () =
    $UN.castview2void(chpos) in chanpos_ssque_enq()
  end // end of [prval]
//
end // end of [chanpos_ssque]
//
(* ****** ****** *)

implement
channeg_ssque_nil
  (chneg) = () where
{
//
val
chneg2 =
$UN.castvwtp1{channeg2}(chneg)
//
val () =
  channeg2_recv{int}(chneg2, 0)
//
prval () = $UN.cast2void(chneg2)
//
prval () = $UN.castview2void(chneg)
//
} (* end of [channeg_ssque_nil] *)

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

implement
channeg_ssque_deq
  (chneg) = () where
{
//
val
chneg2 =
$UN.castvwtp1{channeg2}(chneg)
//
val () =
  channeg2_recv{int}(chneg2, 1)
//
prval () = $UN.cast2void(chneg2)
//
prval () = $UN.castview2void(chneg)
//
} (* end of [channeg_ssque_deq] *)

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

implement
channeg_ssque_top
  (chneg) = () where
{
//
val
chneg2 =
$UN.castvwtp1{channeg2}(chneg)
//
val () =
  channeg2_recv{int}(chneg2, 2)
//
prval () = $UN.cast2void(chneg2)
//
prval () = $UN.castview2void(chneg)
//
} (* end of [channeg_ssque_top] *)

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

implement
channeg_ssque_enq
  (chneg) = () where
{
//
val
chneg2 =
$UN.castvwtp1{channeg2}(chneg)
//
val () =
  channeg2_recv{int}(chneg2, 3)
//
prval () = $UN.cast2void(chneg2)
//
prval () = $UN.castview2void(chneg)
//
} (* end of [channeg_ssque_enq] *)

(* ****** ****** *)
//
extern
fun
queue_nil{a:t0p}(): channeg(ssque(a, 0)) = "mac#%"
//
extern
fun
queue_free_nil{a:t0p}(channeg(ssque(a, 0))): void = "mac#%"
//
extern
fun
queue_deq
  {a:t0p}{n:pos}
  (que: !channeg(ssque(a,n)) >> channeg(ssque(a,n-1))): (a) = "mac#%"
//
extern
fun
queue_top
  {a:t0p}{n:pos}
  (que: !channeg(ssque(a,n)) >> channeg(ssque(a,n-0))): (a) = "mac#%"
//
extern
fun
queue_enq
  {a:t0p}{n:nat}
  (que: !channeg(ssque(a,n)) >> channeg(ssque(a,n+1)), x0: a): void = "mac#%"
//
(* ****** ****** *)

implement
queue_nil
  {a}((*void*)) = let
//
fun
fserv
(
  chp: chanpos(ssque(a,0))
) : void = let
//
val opt = chanpos_ssque(chp)
//
in
//
case+ opt of
| chanpos_ssque_nil() =>
    chanpos_nil_wait (chp)
| chanpos_ssque_enq() => let
    val
    x_fst = chanpos_recv{a}(chp)
  in
    fserv2 (x_fst, queue_nil(), chp)
  end // end of [chanpos_ssque_enq]
//
end // end of [fserv]
//
and
fserv2
{n:nat}
(
  x: a
, chn: channeg(ssque(a,n))
, chp: chanpos(ssque(a,n+1))
) : void = let
//
val opt = chanpos_ssque(chp)
//
in
//
case+ opt of
| chanpos_ssque_deq() => let
    val () = chanpos_send{a}(chp, x)
  in
    chanposneg_link (chp, chn)
  end // end of [chanpos_ssque_deq]
| chanpos_ssque_top() => let
    val () = chanpos_send{a}(chp, x)
  in
    fserv2 (x, chn, chp)
  end // end of [chanpos_ssque_deq]
| chanpos_ssque_enq() => let
    val y = chanpos_recv{a}(chp)
    val () = channeg_ssque_enq (chn)
    val () = channeg_recv{a}(chn, y)
  in
    fserv2 (x, chn, chp)
  end // end of [chanpos_ssque_enq]
//
end // end of [fserv2]
//
in
  channeg_create(llam (chp) => fserv (chp))
end // end of [queue_nil]

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

implement
queue_free_nil
  {a}(chn) = () where
{
//
val () = channeg_ssque_nil(chn)
val () = channeg_nil_close(chn)
//
} (* end of [queue_free_nil] *)

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

implement
queue_deq
  {a}(chn) =
(
  channeg_ssque_deq(chn); channeg_send{a}(chn)
) (* end of [queue_deq] *)

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

implement
queue_top
  {a}(chn) =
(
  channeg_ssque_top(chn); channeg_send{a}(chn)
) (* end of [queue_top] *)

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

implement
queue_enq
  {a}(chn, x0) =
(
  channeg_ssque_enq(chn); channeg_recv{a}(chn, x0)
) (* end of [queue_enq] *)

(* ****** ****** *)
//
extern
fun
queue_map_cloref
  {a:t0p}{b:t0p}{n:nat}
(
  que: channeg(ssque(a,n)), n: int(n), f: (a) -<cloref1> b
) : channeg(ssque(b,n)) // end-of-function
//
(* ****** ****** *)

implement
queue_map_cloref
  {a}{b}{n}(que, n, f) = let
//
fun
loop{i,j:nat}
(
  que: channeg(ssque(a, i))
, i: int(i), res: channeg(ssque(b, j))
) : channeg(ssque(b, i+j)) =
(
//
if
i > 0
then let
  val x = queue_deq(que)
  val () = queue_enq(res, f(x))
in
  loop(que, i-1, res)
end // end of [then]
else let
  val () = queue_free_nil(que) in res
end // end of [else]
//
) (* end of [loop] *)
//
in
  loop(que, n, queue_nil())
end // end of [queue_map_cloref]

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

extern
fun
main0_erl
(
// argumentless
) : void = "mac#"
//
implement
main0_erl((*void*)) =
{
//
#define N 100
//
val Q0 = queue_nil{int}()
//
val () = queue_enq (Q0, 0)
val () = queue_enq (Q0, 1)
val () = queue_enq (Q0, 2)
//
val x0 = queue_top (Q0)
val () = println! ("x0(0) = ", x0)
val x0 = queue_deq (Q0)
val () = println! ("x0(0) = ", x0)
val x1 = queue_deq (Q0)
val () = println! ("x1(1) = ", x1)
//
val () = queue_enq (Q0, 3)
val () = queue_enq (Q0, 4)
//
val x2 = queue_top (Q0)
val () = println! ("x2(2) = ", x2)
val x2 = queue_deq (Q0)
val () = println! ("x2(2) = ", x2)
val x3 = queue_deq (Q0)
val () = println! ("x3(3) = ", x3)
//
val () = queue_enq (Q0, 5)
val () = queue_enq (Q0, 6)
val () = queue_enq (Q0, 7)
//
val x4 = queue_top (Q0)
val () = println! ("x4(4) = ", x4)
val x4 = queue_deq (Q0)
val () = println! ("x4(4) = ", x4)
val x5 = queue_top (Q0)
val () = println! ("x5(5) = ", x5)
val x5 = queue_deq (Q0)
val () = println! ("x5(5) = ", x5)
val x6 = queue_deq (Q0)
val () = println! ("x7(6) = ", x6)
//
val () = queue_enq (Q0, 8)
val Q1 = queue_map_cloref{int}{int}(Q0, 2, lam(x) => 2 * x)
//
val x7 = queue_top (Q1)
val () = println! ("x7(7) = ", x7)
val x7 = queue_deq (Q1)
val () = println! ("x7(7) = ", x7)
val x8 = queue_deq (Q1)
val () = println! ("x8(8) = ", x8)
//
val ((*freed*)) = queue_free_nil{int}(Q1)
//
} (* end of [main0] *)

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

(* end of [queue2.dats] *)

(*
** A queue of channels
*)
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
(*
#define ATS_PACKNAME "queue2"
*)
//
#define ATS_EXTERN_PREFIX "queue2_"
#define ATS_STATIC_PREFIX "_queue2_"
//
(* ****** ****** *)

%{^
%%
-module(queue2_dats).
%%
-export([main0_erl/0]).
%%
-compile(nowarn_unused_vars).
-compile(nowarn_unused_function).
%%
-export([ats2erlpre_cloref1_app/2]).
-export([libats2erl_session_chque_server/0]).
-export([libats2erl_session_chanpos_server/2]).
-export([libats2erl_session_channeg_server/2]).
%%
-include("./libatscc2erl/libatscc2erl_all.hrl").
-include("./libatscc2erl/Sessiontype_mylibats2erl_all.hrl").
%%
%} // end of [%{]

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$LIBATSCC2ERL}/staloadall.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

staload "./../SATS/basis.sats"
staload "./../DATS/basis_chan2.dats"

(* ****** ****** *)
//
(*
//
datatype
ssque(a:t@ype, int) =
  | ssque_nil(a, 0) of ()
  | {n:pos}
    ssque_deq(a, n) of (snd(a), ssque(a,n-1))
  | {n:pos}
    ssque_top(a, n) of (snd(a), ssque(a,n-0))
  | {n:nat}
    ssque_enq(a, n) of (rcv(a), ssque(a,n+1))
//
*)
abstype ssque(a:t@ype, n:int)
//
(* ****** ****** *)
//
datatype
chanpos_ssque
  (a:t@ype, type, int) =
  | chanpos_ssque_nil(a, nil, 0) of ()
  | {n:pos}
    chanpos_ssque_deq(a,chsnd(a)::ssque(a,n-1),n) of ()
  | {n:pos}
    chanpos_ssque_top(a,chsnd(a)::ssque(a,n-0),n) of ()
  | {n:nat}
    chanpos_ssque_enq(a,chrcv(a)::ssque(a,n+1),n) of ()
//
(* ****** ****** *)
//
extern
fun
chanpos_ssque
  {a:t@ype}{n:nat}
  (!chanpos(ssque(a,n)) >> chanpos(ss))
: #[ss:type] chanpos_ssque(a, ss, n) = "mac#%"
//
(* ****** ****** *)
//
extern
fun
channeg_ssque_nil
  {a:t@ype}
  (!channeg(ssque(a,0)) >> channeg(nil)): void = "mac#%"
extern
fun
channeg_ssque_deq
  {a:t@ype}{n:pos}
  (!channeg(ssque(a,n)) >> channeg(chsnd(a)::ssque(a,n-1))): void = "mac#%"
and
channeg_ssque_top
  {a:t@ype}{n:pos}
  (!channeg(ssque(a,n)) >> channeg(chsnd(a)::ssque(a,n-0))): void = "mac#%"
and
channeg_ssque_enq
  {a:t@ype}{n:nat}
  (!channeg(ssque(a,n)) >> channeg(chrcv(a)::ssque(a,n+1))): void = "mac#%"
//
(* ****** ****** *)

implement
chanpos_ssque
  {a}{n}(chpos) = let
//
val
chpos2 = $UN.castvwtp1{chanpos2}(chpos)
val tag = chanpos2_recv{natLt(4)}(chpos2)
//
prval () = $UN.cast2void(chpos2)
//
in
//
case+ tag of
| 0 => let
    prval () = $UN.prop_assert{n==0}()
    prval () =
    $UN.castview2void(chpos) in chanpos_ssque_nil()
  end // end of [prval]
| 1 => let
    prval () = $UN.prop_assert{n > 0}()
    prval () =
    $UN.castview2void(chpos) in chanpos_ssque_deq()
  end // end of [prval]
| 2 => let
    prval () = $UN.prop_assert{n > 0}()
    prval () =
    $UN.castview2void(chpos) in chanpos_ssque_top()
  end // end of [prval]
| 3 => let
    prval () =
    $UN.castview2void(chpos) in chanpos_ssque_enq()
  end // end of [prval]
//
end // end of [chanpos_ssque]
//
(* ****** ****** *)

implement
channeg_ssque_nil
  (chneg) = () where
{
//
val
chneg2 =
$UN.castvwtp1{channeg2}(chneg)
//
val () =
  channeg2_recv{int}(chneg2, 0)
//
prval () = $UN.cast2void(chneg2)
//
prval () = $UN.castview2void(chneg)
//
} (* end of [channeg_ssque_nil] *)

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

implement
channeg_ssque_deq
  (chneg) = () where
{
//
val
chneg2 =
$UN.castvwtp1{channeg2}(chneg)
//
val () =
  channeg2_recv{int}(chneg2, 1)
//
prval () = $UN.cast2void(chneg2)
//
prval () = $UN.castview2void(chneg)
//
} (* end of [channeg_ssque_deq] *)

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

implement
channeg_ssque_top
  (chneg) = () where
{
//
val
chneg2 =
$UN.castvwtp1{channeg2}(chneg)
//
val () =
  channeg2_recv{int}(chneg2, 2)
//
prval () = $UN.cast2void(chneg2)
//
prval () = $UN.castview2void(chneg)
//
} (* end of [channeg_ssque_top] *)

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

implement
channeg_ssque_enq
  (chneg) = () where
{
//
val
chneg2 =
$UN.castvwtp1{channeg2}(chneg)
//
val () =
  channeg2_recv{int}(chneg2, 3)
//
prval () = $UN.cast2void(chneg2)
//
prval () = $UN.castview2void(chneg)
//
} (* end of [channeg_ssque_enq] *)

(* ****** ****** *)
//
extern
fun
queue_nil{a:t0p}(): channeg(ssque(a, 0)) = "mac#%"
//
extern
fun
queue_free_nil{a:t0p}(channeg(ssque(a, 0))): void = "mac#%"
//
extern
fun
queue_deq
  {a:t0p}{n:pos}
  (que: !channeg(ssque(a,n)) >> channeg(ssque(a,n-1))): (a) = "mac#%"
//
extern
fun
queue_top
  {a:t0p}{n:pos}
  (que: !channeg(ssque(a,n)) >> channeg(ssque(a,n-0))): (a) = "mac#%"
//
extern
fun
queue_enq
  {a:t0p}{n:nat}
  (que: !channeg(ssque(a,n)) >> channeg(ssque(a,n+1)), x0: a): void = "mac#%"
//
(* ****** ****** *)

implement
queue_nil
  {a}((*void*)) = let
//
fun
fserv
(
  chp: chanpos(ssque(a,0))
) : void = let
//
val opt = chanpos_ssque(chp)
//
in
//
case+ opt of
| chanpos_ssque_nil() =>
    chanpos_nil_wait (chp)
| chanpos_ssque_enq() => let
    val
    x_fst = chanpos_recv{a}(chp)
  in
    fserv2 (x_fst, queue_nil(), chp)
  end // end of [chanpos_ssque_enq]
//
end // end of [fserv]
//
and
fserv2
{n:nat}
(
  x: a
, chn: channeg(ssque(a,n))
, chp: chanpos(ssque(a,n+1))
) : void = let
//
val opt = chanpos_ssque(chp)
//
in
//
case+ opt of
| chanpos_ssque_deq() => let
    val () = chanpos_send{a}(chp, x)
  in
    chanposneg_link (chp, chn)
  end // end of [chanpos_ssque_deq]
| chanpos_ssque_top() => let
    val () = chanpos_send{a}(chp, x)
  in
    fserv2 (x, chn, chp)
  end // end of [chanpos_ssque_deq]
| chanpos_ssque_enq() => let
    val y = chanpos_recv{a}(chp)
    val () = channeg_ssque_enq (chn)
    val () = channeg_recv{a}(chn, y)
  in
    fserv2 (x, chn, chp)
  end // end of [chanpos_ssque_enq]
//
end // end of [fserv2]
//
in
  channeg_create(llam (chp) => fserv (chp))
end // end of [queue_nil]

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

implement
queue_free_nil
  {a}(chn) = () where
{
//
val () = channeg_ssque_nil(chn)
val () = channeg_nil_close(chn)
//
} (* end of [queue_free_nil] *)

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

implement
queue_deq
  {a}(chn) =
(
  channeg_ssque_deq(chn); channeg_send{a}(chn)
) (* end of [queue_deq] *)

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

implement
queue_top
  {a}(chn) =
(
  channeg_ssque_top(chn); channeg_send{a}(chn)
) (* end of [queue_top] *)

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

implement
queue_enq
  {a}(chn, x0) =
(
  channeg_ssque_enq(chn); channeg_recv{a}(chn, x0)
) (* end of [queue_enq] *)

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

extern
fun
main0_erl
(
// argumentless
) : void = "mac#"
//
implement
main0_erl((*void*)) =
{
//
#define N 100
//
val Q0 = queue_nil{int}()
//
val () = queue_enq (Q0, 0)
val () = queue_enq (Q0, 1)
val () = queue_enq (Q0, 2)
//
val x0 = queue_top (Q0)
val () = println! ("x0(0) = ", x0)
val x0 = queue_deq (Q0)
val () = println! ("x0(0) = ", x0)
val x1 = queue_deq (Q0)
val () = println! ("x1(1) = ", x1)
//
val () = queue_enq (Q0, 3)
val () = queue_enq (Q0, 4)
//
val x2 = queue_top (Q0)
val () = println! ("x2(2) = ", x2)
val x2 = queue_deq (Q0)
val () = println! ("x2(2) = ", x2)
val x3 = queue_deq (Q0)
val () = println! ("x3(3) = ", x3)
//
val () = queue_enq (Q0, 5)
val () = queue_enq (Q0, 6)
val () = queue_enq (Q0, 7)
//
val x4 = queue_top (Q0)
val () = println! ("x4(4) = ", x4)
val x4 = queue_deq (Q0)
val () = println! ("x4(4) = ", x4)
val x5 = queue_top (Q0)
val () = println! ("x5(5) = ", x5)
val x5 = queue_deq (Q0)
val () = println! ("x5(5) = ", x5)
val x6 = queue_deq (Q0)
val () = println! ("x7(6) = ", x6)
//
val () = queue_enq (Q0, 8)
//
val x7 = queue_top (Q0)
val () = println! ("x7(7) = ", x7)
val x7 = queue_deq (Q0)
val () = println! ("x7(7) = ", x7)
val x8 = queue_deq (Q0)
val () = println! ("x8(8) = ", x8)
//
val ((*freed*)) = queue_free_nil{int}(Q0)
//
} (* end of [main0] *)

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

(* end of [queue2.dats] *)


link to template file in arithmetic

link to template file in arithmetic

// This is a standard function-pack
// strongly recommend to include it everywhere
// to avoid very long-time debug sessions.

// in `template.dats` file in this `dir` you can also find
// another template it is as much usefull as the oriiginal one

#include "share/atspre_staload.hats"

val _ = println! ("(1+2)/(3+4) = ", (1+2)/(3+4))

val _ = println! ("-1 = ", x) where {
    val x = ~1
}

val _ = (
    println! ("0.123 = ", 0.123);
    println! ("0.000314 = ", 314E-6);
)

val _ = (
  println! ("float is ", x, " and double is ", y);
) where {
  val x = 2.0f; // float
  val y = 2.0; // double
}

val+ 3 = op+(1,2)

implement main0 () = ()

// This is a standard function-pack
// strongly recommend to include it everywhere
// to avoid very long-time debug sessions.

#include "share/atspre_staload.hats"

val _ = println! ("(1+2)/(3+4) = ", (1+2)/(3+4))

val _ = println! ("-1 = ", x) where {
    val x = ~1
}

val _ = (
    println! ("0.123 = ", 0.123);
    println! ("0.000314 = ", 314E-6);
)

val _ = (
  println! ("float is ", x, " and double is ", y);
) where {
  val x = 2.0f; // float
  val y = 2.0; // double
}

val+ 3 = op+(1,2)

implement main0 () = ()


Updating: experimenting with multi-party sessions

(* ****** ****** *)
//
// HX-2015-07-11:
// let the multi-party begin!
//
(* ****** ****** *)

staload "libats/SATS/ilist_prf.sats"

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

(*
Bob -> Alice: <String> ::
Bob -> Alice: {
  Time: Alice -> Bob: <Time> :: end
  Greet: Alice -> Bob: <String> :: end
}
*)

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

sortdef party = int

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

abstype
tagging(party, party, type)

(* ****** ****** *)
//
abstype
trans(party, party, a:vt@ype) // p1->p2
//
abstype
trans_end(p1: party, p2: party) // p1->p2
//
(* ****** ****** *)

abstype Time

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

stadef A = 0
stadef B = 1
stadef C = 2

(* ****** ****** *)
//
datatype
HelloWorld2 =
| HelloWorld2 of
  ( trans(B, A, String)
  , tagging(B, A, HelloWorld2_rest)
  )
//
and
HelloWorld2_rest =
| HelloWorld2_rest_Time of
    (trans(A, B, Time), trans_end(A, B))
| HelloWorld2_rest_Greet of
    (trans(A, B, String), trans_end(A, B))
//
(* ****** ****** *)

sortdef parties = ilist

abstype
mtrans(party, parties, a:vt@ype)
abstype
mtrans_end(p: party, ps: parties)

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

abstype mtagging(party, parties, type)

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

stadef AC = ilist_cons(A, ilist_cons(C, ilist_nil))

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

datatype
HelloWorld3 =
| HelloWorld3 of
  ( trans(B, A, String)
  , trans(B, C, String)
  , mtagging(B, AC, HelloWorld3_rest)
  )

and
HelloWorld3_rest =
  | HelloWorld3_rest_A of (trans(A, B, Time), trans_end(A, B))
  | HelloWorld3_rest_C of (trans(C, B, Time), trans_end(C, B))

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

(* end of [multi-party.dats] *)

(* ****** ****** *)
//
// HX-2015-07-11:
// let the multi-party start!
//
(* ****** ****** *)

(*
Bob -> Alice: <String> ::
Bob -> Alice: {
  Time: Alice -> Bob: <Time> :: end
  Greet: Alice -> Bob: <String> :: end
}
*)

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

datasort party = // abstract

(* ****** ****** *)
//
abstype
trans(party, party, a:vt@ype) // p1->p2
//
abstype
trans_end(p1: party, p2: party) // p1->p2
//
(* ****** ****** *)

abstype Time

(* ****** ****** *)
//
datatype
HelloWorld
(Bob:party, Alice:party) =
| HelloWorld(Bob, Alice) of
    (trans(Bob, Alice, String), HelloWorld2(Bob, Alice))
//
and
HelloWorld2
(Bob:party, Alice:party) =
  | HelloWorld2_Time of (trans(Alice, Bob, Time), trans_end(Alice, Bob))
  | HelloWorld2_Greet of (trans(Alice, Bob, String), trans_end(Alice, Bob))
//
(* ****** ****** *)

(* end of [multi-party.dats] *)


Adding some pattern matches for new stuff that isn't supported by CIL backed, yet.

(* ****** ****** *)
//
// 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) => ()
| D0Cextcode _ => ()
| D0Cclosurerize (_, _, _, _) => ()
//
| 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?
    // 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] *)