Updating: very minorly

Updating: very minorly

(*
** Testing some operations on reals
*)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
"libats/SATS/Number/real.sats"
//
staload
"libats/DATS/Number/real_double.dats"
//
(* ****** ****** *)
//
extern
fun
quadratic_solve1
 {A,B,C:real | A > 0}
(
  A: real(A), B: real(B), C: real(C)
) : [x:real | A*x*x+B*x+C==i2r(0)] real(x)
//
extern
fun
quadratic_solve2
 {A,B,C:real | A > 0}
(
  A: real(A), B: real(B), C: real(C)
) : [x:real | A*x*x+B*x+C==i2r(0)] real(x)
//
(* ****** ****** *)

#define i2r(x) int2real(x)

(* ****** ****** *)
//
implement
quadratic_solve1
  (A, B, C) = let
//
val Delta = B*B-4*A*C
//
prval () =
  $solver_assert(lemma_sqrt_def)
//
val ((*void*)) = assert(Delta >= 0)
//
in
  (~B+sqrt(Delta))/(2*A)
end // end of [quadratic_solve1]
//
(* ****** ****** *)
//
implement
quadratic_solve2
  (A, B, C) = let
//
val Delta = B*B-4*A*C
//
prval () =
  $solver_assert(lemma_sqrt_def)
//
val ((*void*)) = assert(Delta >= 0)
//
in
  (~B-sqrt(Delta))/(2*A)
end // end of [quadratic_solve2]
//
(* ****** ****** *)

val root1 =
  quadratic_solve1(i2r(1), i2r(1), i2r(~1))
val root2 =
  quadratic_solve2(i2r(1), i2r(1), i2r(~1))

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

val () = println! ("root1 = ", root1)
val () = println! ("root2 = ", root2)

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

implement
main0() = () where
{
//
val () =
println! ("Hello from [quadratic]")
//
} (* end of [main0] *)

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

(* end of [quadratic.dats] *)

(*
** Testing some operations on reals
*)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
"libats/SATS/Number/real.sats"
//
staload
"libats/DATS/Number/real_double.dats"
//
(* ****** ****** *)
//
extern
fun
quadratic_solve1
 {A,B,C:real}
(
  A: real(A), B: real(B), C: real(C)
) : [x:real | A*x*x+B*x+C==i2r(0)] real(x)
//
extern
fun
quadratic_solve2
 {A,B,C:real}
(
  A: real(A), B: real(B), C: real(C)
) : [x:real | A*x*x+B*x+C==i2r(0)] real(x)
//
(* ****** ****** *)

#define i2r(x) int2real(x)

(* ****** ****** *)
//
implement
quadratic_solve1
  (A, B, C) = let
//
val Delta = B*B-4*A*C
//
val ((*void*)) = assert(A > 0)
val ((*void*)) = assert(Delta >= 0)
//
prval () =
  $solver_assert(lemma_sqrt_def)
//
in
  (~B+sqrt(Delta))/(2*A)
end // end of [quadratic_solve1]
//
(* ****** ****** *)
//
implement
quadratic_solve2
  (A, B, C) = let
//
val Delta = B*B-4*A*C
//
val ((*void*)) = assert(A > 0)
val ((*void*)) = assert(Delta >= 0)
//
prval () =
  $solver_assert(lemma_sqrt_def)
//
in
  (~B-sqrt(Delta))/(2*A)
end // end of [quadratic_solve2]
//
(* ****** ****** *)

val root1 =
  quadratic_solve1(i2r(1), i2r(1), i2r(~1))
val root2 =
  quadratic_solve2(i2r(1), i2r(1), i2r(~1))

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

val () = println! ("root1 = ", root1)
val () = println! ("root2 = ", root2)

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

implement
main0() = () where
{
//
val () =
println! ("Hello from [quadratic]")
//
} (* end of [main0] *)

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

(* end of [quadratic.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
** Basis for g-session types
*)

(* ****** ****** *)
//
staload
"./basis_intset.sats"
//
(* ****** ****** *)
//
fun{}
channel_cap(): intGte(1)
//
(* ****** ****** *)
//
abstype
session_msg
  (i:int, j:int, a:vt@ype)
//
(* ****** ****** *)

abstype ssession_nil
abstype ssession_cons(a:type, ssn:type)

(* ****** ****** *)
//
stadef msg = session_msg
//
stadef nil = ssession_nil
//
stadef :: = ssession_cons
stadef cons = ssession_cons
//
(* ****** ****** *)
//
abstype
session_choose
(
  i:int, ssn1:type, ssn2:type
) (* session_choose *)
//
stadef choose = session_choose
//
(* ****** ****** *)
//
absvtype
channel1_vtype
  (G:iset, n:int, ssn:type) = ptr
//
vtypedef
channel1
  (G:iset, n:int, ssn:type) = channel1_vtype(G, n, ssn)
//
vtypedef
cchannel1
  (G:iset, n:int, ssn:type) = channel1_vtype(ncomp(n, G), n, ssn)
//
(* ****** ****** *)
//
fun{}
channel1_get_nrole
  {n:int}{ssn:type}{G:iset}
  (chan: !channel1(G, n, ssn)): int(n)
//
fun{}
channel1_get_group
  {n:int}{ssn:type}{G:iset}
  (chan: !channel1(G, n, ssn)): intset(n,G)
//
(* ****** ****** *)
//
fun
{a:vt0p}
channel1_close
  {n:int}{ssn:type}{G:iset}(chan: channel1(G, n, nil)): void
//
(* ****** ****** *)
//
fun{}
channel1_skipin
  {a:vt0p}
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | ismbr(G, i); ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn)
) : void // end-of-function
praxi
lemma_channel1_skipin
  {a:vt0p}
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | ismbr(G, i); ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn)
) : void // lemma_channel1_skipin
//
fun{}
channel1_skipex
  {a:vt0p}
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | ~ismbr(G, i); ~ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn)
) : void // end-of-function
praxi
lemma_channel1_skipex
  {a:vt0p}
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | ~ismbr(G, i); ~ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn)
) : void // lemma_channel1_skipex
//
(* ****** ****** *)
//
fun
{a:vt0p}
channel1_send
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | i < n; j < n; ismbr(G, i); ~ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn), int(i), int(j), a
) : void // end of [channel1_send]
//
fun
{a:vt0p}
channel1_recv
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | i < n; j < n; ~ismbr(G, i); ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn), int(i), int(j), &a? >> a
) : void // end of [channel1_recv]
//
fun
{a:vt0p}
channel1_recv_val
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | i < n; j < n; ~ismbr(G, i); ismbr(G, j)}
  (!channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn), int(i), int(j)): (a)
//
(* ****** ****** *)
//
datatype
choosetag
(
  a:type, b:type, c:type
) =
  | choosetag_l(a, b, a) of ()
  | choosetag_r(a, b, b) of ()
//
(* ****** ****** *)

fun{}
channel1_choose_l
  {n:int}
  {ssn1,ssn2:type}
  {G:iset}
  {i:nat | i < n; ismbr(G, i)}
(
  !channel1(G, n, choose(i,ssn1,ssn2)) >> channel1(G, n, ssn1), i: int(i)
) : void // end of [channel1_choose_l]
fun{}
channel1_choose_r
  {n:int}
  {ssn1,ssn2:type}
  {G:iset}
  {i:nat | i < n; ismbr(G, i)}
(
  !channel1(G, n, choose(i,ssn1,ssn2)) >> channel1(G, n, ssn2), i: int(i)
) : void // end of [channel1_choose_r]

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

fun{}
channel1_choosetag
  {n:int}
  {ssn1,ssn2:type}
  {G:iset}
  {i:nat | i < n; ~isnil(G); ~ismbr(G, i)}
(
  !channel1(G, n, choose(i,ssn1,ssn2)) >> channel1(G, n, ssn), i: int(i)
) : #[ssn:type] choosetag(ssn1, ssn2, ssn)

(* ****** ****** *)
//
(*
//
// HX-2015-03-06:
// This one does not work with sschoose!!!
//
fun{}
channel1_link
  {n:int}{ssn:type}
  {G1,G2:iset | isnil(G1*G2)}
  (channel1(G1, n, ssn), channel1(G2, n, ssn)): channel1(G1+G2, n, ssn)
*)
//
fun{}
channel1_link
  {n:int}{ssn:type}
  {G1,G2:iset | isful(G1+G2,n)}
  (channel1(G1, n, ssn), channel1(G2, n, ssn)): channel1(G1*G2, n, ssn)
//
(* ****** ****** *)
//
fun{}
channel1_link_elim
  {n:int}{ssn:type}{G:iset}(channel1(G, n, ssn), cchannel1(G, n, ssn)): void
//
(* ****** ****** *)
//
fun{}
cchannel1_create_exn
  {n:nat}{ssn:type}{G:iset}
(
  nrole: int(n), G: intset(n), fserv: channel1(G, n, ssn) -<lincloptr1> void
) : cchannel1(G, n, ssn) // end of [cchannel1_create_exn]
//
(* ****** ****** *)

(* end of [basis_ssntype.sats] *)

(*
** Basis for g-session types
*)

(* ****** ****** *)
//
staload
"./basis_intset.sats"
//
(* ****** ****** *)
//
fun{}
channel_cap(): intGte(1)
//
(* ****** ****** *)
//
abstype
session_msg
  (i:int, j:int, a:vt@ype)
//
(* ****** ****** *)

abstype ssession_nil
abstype ssession_cons(a:type, ssn:type)

(* ****** ****** *)
//
stadef msg = session_msg
//
stadef nil = ssession_nil
//
stadef :: = ssession_cons
stadef cons = ssession_cons
//
(* ****** ****** *)
//
abstype
session_choose
(
  i:int, ssn1:type, ssn2:type
) (* session_choose *)
//
stadef choose = session_choose
//
(* ****** ****** *)
//
absvtype
channel1_vtype
  (G:iset, n:int, ssn:type) = ptr
//
vtypedef
channel1
  (G:iset, n:int, ssn:type) = channel1_vtype(G, n, ssn)
//
vtypedef
cchannel1
  (G:iset, n:int, ssn:type) = channel1_vtype(ncomp(n, G), n, ssn)
//
(* ****** ****** *)
//
fun{}
channel1_get_nrole
  {n:int}{ssn:type}{G:iset}
  (chan: !channel1(G, n, ssn)): int(n)
//
fun{}
channel1_get_group
  {n:int}{ssn:type}{G:iset}
  (chan: !channel1(G, n, ssn)): intset(n,G)
//
(* ****** ****** *)
//
fun
{a:vt0p}
channel1_close
  {n:int}{ssn:type}{G:iset}(chan: channel1(G, n, nil)): void
//
(* ****** ****** *)
//
fun{}
channel1_skipin
  {a:vt0p}
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | ismbr(G, i); ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn)
) : void // end-of-function
praxi
lemma_channel1_skipin
  {a:vt0p}
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | ismbr(G, i); ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn)
) : void // lemma_channel1_skipin
//
fun{}
channel1_skipex
  {a:vt0p}
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | ~ismbr(G, i); ~ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn)
) : void // end-of-function
praxi
lemma_channel1_skipex
  {a:vt0p}
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | ~ismbr(G, i); ~ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn)
) : void // lemma_channel1_skipex
//
(* ****** ****** *)
//
fun
{a:vt0p}
channel1_send
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | i < n; j < n; ismbr(G, i); ~ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn), int(i), int(j), a
) : void // end of [channel1_send]
//
fun
{a:vt0p}
channel1_recv
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | i < n; j < n; ~ismbr(G, i); ismbr(G, j)}
(
  !channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn), int(i), int(j), &a? >> a
) : void // end of [channel1_recv]
//
fun
{a:vt0p}
channel1_recv_val
  {n:int}{ssn:type}{G:iset}
  {i,j:nat | i < n; j < n; ~ismbr(G, i); ismbr(G, j)}
  (!channel1(G, n, msg(i, j, a)::ssn) >> channel1(G, n, ssn), int(i), int(j)): (a)
//
(* ****** ****** *)
//
datatype
choosetag
(
  a:type, b:type, c:type
) =
  | choosetag_l(a, b, a) of ()
  | choosetag_r(a, b, b) of ()
//
(* ****** ****** *)

fun{}
channel1_choose_l
  {n:int}
  {ssn1,ssn2:type}
  {G:iset}
  {i:nat | i < n; ismbr(G, i)}
(
  !channel1(G, n, choose(i,ssn1,ssn2)) >> channel1(G, n, ssn1), i: int(i)
) : void // end of [channel1_choose_l]
fun{}
channel1_choose_r
  {n:int}
  {ssn1,ssn2:type}
  {G:iset}
  {i:nat | i < n; ismbr(G, i)}
(
  !channel1(G, n, choose(i,ssn1,ssn2)) >> channel1(G, n, ssn2), i: int(i)
) : void // end of [channel1_choose_r]

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

fun{}
channel1_choosetag
  {n:int}
  {ssn1,ssn2:type}
  {G:iset}
  {i:nat | i < n; ~isnil(G); ~ismbr(G, i)}
(
  !channel1(G, n, choose(i,ssn1,ssn2)) >> channel1(G, n, ssn), i: int(i)
) : #[ssn:type] choosetag(ssn1, ssn2, ssn)

(* ****** ****** *)
//
(*
//
// HX-2015-03-06:
// This one does not work with sschoose!!!
//
fun{}
channel1_link
  {n:int}{ssn:type}
  {G1,G2:iset | isnil(G1*G2)}
  (channel1(G1, n, ssn), channel1(G2, n, ssn)): channel1(G1+G2, n, ssn)
*)
//
fun{}
channel1_link
  {n:int}{ssn:type}
  {G1,G2:iset | isful(G1+G2,n)}
  (channel1(G1, n, ssn), channel1(G2, n, ssn)): channel1(G1*G2, n, ssn)
//
(* ****** ****** *)
//
fun{}
channel1_link_elim
  {n:int}{ssn:type}{G:iset}(channel1(G, n, ssn), cchannel1(G, n, ssn)): void
//
(* ****** ****** *)
//
fun{}
cchannel1_create_exn
  {n:nat}{ssn:type}{G:iset}
(
  nrole: int(n), G: intset(n), fserv: channel1(G, n, ssn) -<lincloptr1> void
) : cchannel1(G, n, ssn) // end of [cchannel1_create_exn]
//
(* ****** ****** *)

(* end of [basis.sats] *)
//
typedef
session_snd(a:vt@ype) = session_msg(0, 1, a)
typedef
session_rcv(a:vt@ype) = session_msg(1, 0, a)
//
stadef snd = session_snd
stadef rcv = session_rcv
//
vtypedef
chan1pos(ssn:type) = channel1(iset(0), 2, ssn)
vtypedef
chan1neg(ssn:type) = channel1(iset(1), 2, ssn)
//
fun
{a:vt0p}
chan1pos_send{ssn:type}
  (!chan1pos(snd(a)::ssn) >> chan1pos(ssn), a): void
//
fun
{a:vt0p}
chan1pos_recv{ssn:type}
(
  !chan1pos(rcv(a)::ssn) >> chan1pos(ssn), &a? >> a
) : void // end-of-function
fun
{a:vt0p}
chan1pos_recv_val{ssn:type}
  (chp: !chan1pos(rcv(a)::ssn) >> chan1pos(ssn)): (a)
//
fun
{a:vt0p}
chan1neg_recv{ssn:type}
  (!chan1neg(rcv(a)::ssn) >> chan1neg(ssn), a): void
//
fun
{a:vt0p}
chan1neg_send{ssn:type}
(
  !chan1neg(snd(a)::ssn) >> chan1neg(ssn), &a? >> a
) : void // end-of-function
fun
{a:vt0p}
chan1neg_send_val{ssn:type}
  (chn: !chan1neg(snd(a)::ssn) >> chan1neg(ssn)): (a)
//
(* ****** ****** *)
//
fun{}
chan1neg_create_exn
  {ssn:type}(fserv: chan1pos(ssn) -<lincloptr1> void): chan1neg(ssn)
//
(* ****** ****** *)

(* end of [basis_ssntype.sats] *)


Updating: very very minorly

Updating: very very minorly

(* ****** ****** *)
//
// HX: 2016-08-03:
// Some PAGEN-functions
// for creating assignments
//
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"{$LIBATSCC2PY3}/staloadall.hats"
//
staload
"{$LIBATSCC2PY3}/SATS/PYLIBC/random.sats"
staload
"{$LIBATSCC2PY3}/SATS/PYLIBC/datetime.sats"
//
(* ****** ****** *)

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

(* ****** ****** *)
//
extern
fun{}
patsopt_tc_button(key: string): void
extern
fun{}
patsopt_cc_button(key: string): void
extern
fun{}
patsopt_cc2js_button(key: string): void
//
extern
fun{} pats2xhtml_button(key: string): void
//
(* ****** ****** *)
//
implement
{}(*tmp*)
patsopt_tc_button(key) =
{
//
val () =
gprintln!("\
<button
 type=\"button\"
 id=\"")(key)("_patsopt_tc_button\"
 onclick=\"patsopt_tc_onclick('")(key)("')\"
>patsopt_tc</button>\
") (* gprintln! *)
//
} (* end of [patsopt_tc_button] *)
//
implement
{}(*tmp*)
patsopt_cc_button(key) =
{
//
val () =
gprintln!("\
<button
 type=\"button\"
 id=\"")(key)("_patsopt_cc_button\"
 onclick=\"patsopt_cc_onclick('")(key)("')\"
>patsopt_cc</button>\
") (* gprintln! *)
//
} (* end of [patsopt_cc_button] *)
//
implement
{}(*tmp*)
patsopt_cc2js_button(key) =
{
//
val () =
gprintln!("\
<button
 type=\"button\"
 id=\"")(key)("_patsopt_cc2js_button\"
 onclick=\"patsopt_cc2js_onclick('")(key)("')\"
>patsopt_cc2js</button>\
") (* gprintln! *)
//
} (* end of [patsopt_cc2js_button] *)
//
implement
{}(*tmp*)
pats2xhtml_button(key) =
{
//
val () =
gprintln! ("\
<button
 type=\"button\"
 id=\"")(key)("_pats2xhtml_button\"
 onclick=\"pats2xhtml_toggle_onclick('")(key)("')\"
>pats2xhtml-toggle</button>\
") (* gprintln! *)
//
} (* pats2xhtml_button *)
//
(* ****** ****** *)
//
extern
fun{}
patssrc_saveAs_button(key: string): void
extern
fun{}
patssrc_saveAs_input0(key: string): void
extern
fun{}
patsout_saveAs_button(key: string): void
extern
fun{}
patsout_saveAs_input0(key: string): void
//
(* ****** ****** *)
//
implement
{}(*tmp*)
patssrc_saveAs_button(key) =
{
//
val () =
gprintln! ("\
<button
 type=\"button\"
 id=\"")(key)("_patssrc_saveAs_button\"
 onclick=\"patssrc_saveAs_onclick('")(key)("')\"
>saveAs</button>\
") (* gprintln! *)
//
} (* patssrc_saveAs_button *)

implement
{}(*tmp*)
patssrc_saveAs_input0(key) =
{
//
val () =
gprintln! ("\
<input
 type=\"text\"
 id=\"")(key)("_patssrc_saveAs_input\"
 size=18 maxlength=32
 placeholder=\"")(key)("_sol.dats\"></input>\
") (* gprintln! *)
//
} (* patssrc_saveAs_input0 *)
//
implement
{}(*tmp*)
patsout_saveAs_button(key) =
{
//
val () =
gprintln! ("\
<button
 type=\"button\"
 id=\"")(key)("_patsout_saveAs_button\"
 onclick=\"patsout_saveAs_onclick('")(key)("')\"
>saveAs</button>\
") (* gprintln! *)
//
} (* patsout_saveAs_button *)
//
(* ****** ****** *)
//
extern
fun{}
PAGENassign_html(key: string): void
//
extern
fun{}
PAGENassign_head(key: string): void
//
extern
fun{}
PAGENassign_body(key: string): void
//
extern
fun{}
PAGENassign_title(key: string): void
//
(* ****** ****** *)
//
extern
fun{}
PAGENassign_descript(key: string): void
extern
fun{}
PAGENassign_descript2(key: string): void
//
(* ****** ****** *)
//
extern
fun{}
PAGENassign_body_top(key: string): void
extern
fun{}
PAGENassign_body_bottom(key: string): void
//
(* ****** ****** *)
//
implement
{}(*tmp*)
PAGENassign_html
  (key) =
{
//
val () =
gprintln!
(
"<!DOCTYPE html>"
) (* gprintln! *)
//
val () =
gprintln! ("")
//
val () =
PAGENassign_head(key)
//
val () =
PAGENassign_body(key)
//
val () =
gprintln! ("")
//
} (* end of [PAGENassign_html] *)
//
(* ****** ****** *)
//
implement
{}(*tmp*)
PAGENassign_head
  (key) =
{
//
val () =
gprintln! ("")
//
val () =
PAGENassign_title(key)
//
val () =
gprintln! ("\
<meta http-equiv=\"content-type\" content=\"text/html; charset=UTF-8\" />\
") (* end of [val] *)
//
val () =
gprintln! ("\
\
") (* gprintln! *)
//
val () =
gprintln! ("\

\
") (* gprintln! *)
//
val () =
gprintln! ("")
//
} (* end of [PAGENassign_head] *)
//
(* ****** ****** *)
//
implement
{}(*tmp*)
PAGENassign_body
  (key) =
{
//
val () =
gprintln! ("")
//
val () =
PAGENassign_body_top(key)
//
val () =
PAGENassign_descript(key)
val () =
PAGENassign_descript2(key)
//
val () =
PAGENassign_body_bottom(key)
//
val () =
gprintln! ("")
//
} (* end of [PAGENassign_body] *)
//
(* ****** ****** *)
//
implement
{}(*tmp*)
PAGENassign_title
  (key) =
{
//
val () =
gprintln! ("<title>")
val () =
gprintln! ("</title>")
//
} (* end of [PAGENassign_title] *)
//
(* ****** ****** *)
//
implement
{}(*tmp*)
PAGENassign_descript
  (key) =
{
//
val () =
gprintln! ("<descript>")
val () =
gprintln! ("</descript>")
//
} (* end of [PAGENassign_descript] *)
//
(* ****** ****** *)
//
implement
{}(*tmp*)
PAGENassign_descript2
  (key) =
{
//
val () =
gprintln! ("<descript2>")
val () =
gprintln! ("</descript2>")
//
} (* end of [PAGENassign_descript2] *)
//
(* ****** ****** *)
//
implement
{}(*tmp*)
PAGENassign_body_top
  (key) =
{
//
val () =
gprintln!("
Assignment
")
//
} (* end of [PAGENassign_body_top] *)
//
(* ****** ****** *)
//
implement
{}(*tmp*)
PAGENassign_body_bottom
  (key) =
{
//
val () =
gprintln!("

")
//
val () =
gprintln!("\

The Python3 code generating this page is prepared with atscc2py3.

\
") (* gprintln! *)
//
val () =
gprintln!("\
\
") (* gprintln! *)
//
} (* end of [PAGENassign_body_bottom] *)
//
(* ****** ****** *)
//
extern
fun{}
PAGENassign_source_table
(
  key: string, source: string
) : void // end-of-function
//
implement
{}(*tmp*)
PAGENassign_source_table
  (key, source) = let
//
val () =
gprintln!
(
"
"
) (* gprintln! *)
//
val () =
gprintln! ("\

\
") (* gprintln! *)
//
val () =
gprintln! ("\

\
")
//
val () =
patssrc_saveAs_button(key)
val () =
patssrc_saveAs_input0(key)
//
val () =
gprintln! ("\

\
") (* gprintln! *)
//
(*
val () =
patsout_saveAs_button(key)
*)
//
val () =
gprintln! ("\

\
") (* gprintln! *)
//
val () =
gprintln!
("\

<textarea
 id=\"")(key)("_source\"
 rows=24 cols=80
 spellcheck=\"false\">\
") (* gprintln! *)
//
val () = gprint_string(source)
//
val () =
gprintln!
("\
</textarea>

<textarea
 id=\"")(key)("_output\"
 rows=24 cols=80
 spellcheck=\"false\"
 placeholder=\"The output goes here...\">
</textarea>

\
") (* gprintln! *)
//
val () =
gprintln! ("\

source2

output2

\
") (* gprintln! *)
//
val () =
gprintln! ("\

\
")
//
val () = patsopt_tc_button(key)
val () = patsopt_cc_button(key)
val () = patsopt_cc2js_button(key)
val () = pats2xhtml_button(key)
//
val () =
gprintln! ("\

\
") (* gprintln! *)
//
val () =
gprintln! ("
")
//
in
  // nothing
end // end of [PAGENassign_code_table]
//
(* ****** ****** *)

(* end of [PAGEN-assign.dats] *)


Updating: minorly improving

Updating: minorly improving

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload "libc/SATS/unistd.sats"

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

staload "./../SATS/mythread.sats"

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

staload "./../SATS/spinref.sats"
staload _ = "./../DATS/spinref.dats"

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

fun
spinref_incby
  (spnr: spinref(int)): void = let
//
implement(env)
spinref_process$fwork<int><env> (x, env) = x := x + 1
//
in
  spinref_process<int> (spnr)
end // end of [spinref_incby]

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

implement
main0 () =
{
//
val () =
println! ("test_spinref: enter")
//
val SPNR = spinref_create_exn<int> (0)
//
val () =
mythread_create_cloptr
(
llam () =>
  (fix loop(x: spinref(int)): void => (ignoret(sleep(1u)); spinref_incby(x); loop(x)))(SPNR)
)
val () = println! ("The first thread has been created.")
//
val () =
mythread_create_cloptr
(
llam () =>
  (fix loop(x: spinref(int)): void => (ignoret(sleep(1u)); spinref_incby(x); loop(x)))(SPNR)
)
val () = println! ("The second thread has been created.")
//
val () =
( fix loop
  (
    spnr: spinref(int)
  ) : void =>
{
  val n = spinref_get (spnr)
  val () = if n < 2 then (ignoret(sleep(1u)); loop (spnr))
} ) (SPNR) // end of [val]
//
val () =
println! ("test_spinref: leave")
//
} (* end of [main0] *)

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

(* end of [test_spinref.dats] *)

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload "libc/SATS/unistd.sats"

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

staload "./../SATS/mythread.sats"

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

staload "./../SATS/spinref.sats"
staload _ = "./../DATS/spinref.dats"

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

fun spinref_incby
  (spnr: spinref(int)): void = let
//
implement(env)
spinref_process$fwork<int><env> (x, env) = x := x + 1
//
in
  spinref_process<int> (spnr)
end // end of [spinref_incby]

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

implement
main0 () =
{
//
val () =
println! ("test_spinref: enter")
//
val SPNR = spinref_create_exn<int> (0)
//
val () =
mythread_create_cloptr
(
  llam () => (fix loop(x: spinref(int)): void => (spinref_incby(x); ignoret(sleep(1u)); loop(x)))(SPNR)
)
val () = println! ("The first thread has created.")
//
val () =
mythread_create_cloptr
(
  llam () => (fix loop(x: spinref(int)): void => (spinref_incby(x); ignoret(sleep(1u)); loop(x)))(SPNR)
)
val () = println! ("The second thread has created.")
//
val () =
( fix loop
    (spnr: spinref(int)): void =>
{
  val n = spinref_get (spnr)
  val () = if n < 2 then (ignoret(sleep(1u)); loop (spnr))
} ) (SPNR) // end of [val]
//
val () =
println! ("test_spinref: leave")
//
} (* end of [main0] *)

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

(* end of [test_spinref.dats] *)


Updating: working on ATS-parse-emit-python

(* ****** ****** *)
//
// ATS-parse-emit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload
STDIO = "{$PATSLIBC}/SATS/stdio.sats"

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

staload "./atsparemit.sats"
staload "./atsparemit_parsing.sats"
staload "./atsparemit_emit.sats"

(* ****** ****** *)
//
dynload "./atsparemit.sats"
dynload "./atsparemit_syntax.sats"
dynload "./atsparemit_parsing.sats"
dynload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
dynload "./atsparemit_mylib.dats"
//
(* ****** ****** *)
//
dynload "./atsparemit_error.dats"
//
dynload "./atsparemit_print.dats"
//
dynload "./atsparemit_symbol.dats"
//
dynload "./atsparemit_fname.dats"
dynload "./atsparemit_posloc.dats"
//
dynload "./atsparemit_global.dats"
//
dynload "./atsparemit_syntax.dats"
//
dynload "./atsparemit_lexerr.dats"
dynload "./atsparemit_lexbuf.dats"
dynload "./atsparemit_lexing.dats"
//
dynload "./atsparemit_tokbuf.dats"
//
dynload "./atsparemit_parerr.dats"
dynload "./atsparemit_parsing.dats"
dynload "./atsparemit_parsing_d0exp.dats"
dynload "./atsparemit_parsing_d0ecl.dats"
dynload "./atsparemit_parsing_instr.dats"
//
(* ****** ****** *)

dynload "./atsparemit_emit.dats"
dynload "./atsparemit_typedef.dats"

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

dynload "./atsparemit_emit_py.dats"
dynload "./atsparemit_emit2_py.dats"

(* ****** ****** *)
//
datatype
comarg =
COMARGkey of (int, string)
//
typedef comarglst = List0 (comarg)
//
(* ****** ****** *)

datatype
waitkind =
  | WTKnone of ()
  | WTKinput of ()
  | WTKoutput of () // -o / --output
// end of [waitkind]

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

datatype OUTCHAN =
  | OUTCHANref of (FILEref) | OUTCHANptr of (FILEref)
// end of [OUTCHAN]

fun
outchan_get_fileref
  (x: OUTCHAN): FILEref =
(
//
case+ x of
| OUTCHANref (filr) => filr | OUTCHANptr (filp) => filp
//
) (* end of [outchan_get_fileref] *)

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

typedef
cmdstate = @{
  comarg0= comarg
, waitkind= waitkind
// number of processed input files;
, ninputfile= int // waiting for STDIN if it is 0
, outchan= OUTCHAN // current output channel
, standalone= bool (* output is a stand-alone file *)
, nerror= int // number of accumulated errors
} (* end of [cmdstate] *)

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

fun
cmdstate_set_outchan
(
  state: &cmdstate, chan_new: OUTCHAN
) : void = let
//
val chan_old = state.outchan
val ((*void*)) = state.outchan := chan_new
//
in
  case+ chan_old of
  | OUTCHANref (filr) => ()
  | OUTCHANptr (filp) => let
      val err = $STDIO.fclose0 (filp) in (*nothing*)
    end // end of [OUTCHANptr]
end // end of [cmdstate_set_outchan]

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

fun
process_cmdline
(
  state: &cmdstate, arglst: comarglst
) : void = let
in
//
case+ arglst of
| list_nil () => ()
| list_cons (arg, args) =>
    process_cmdline2 (state, arg, arglst)
//
end // end of [process_cmdline]

and
process_cmdline2
(
  state: &cmdstate, arg: comarg, arglst: comarglst
) : void = let
in
end // end of [process_cmdline2]

(* ****** ****** *)
//
extern
fun
comarg_parse (string):<> comarg
//
extern
fun
comarglst_parse{n:nat}
  (argc: int n, argv: !argv(n)): list (comarg, n)
// end of [comarglst_parse]
//
(* ****** ****** *)

implement
comarg_parse
  (str) = let
//
fun
loop
  {n,i:nat | i <= n} .<n-i>.
(
  str: string n, n: int n, i: int i
) :<> comarg =
(
  if i < n
    then (
    if (str[i] != '-')
      then COMARGkey (i, str) else loop (str, n, i+1)
    ) else COMARGkey (n, str)
) (* end of [if] *)
// end of [loop]
//
val str = g1ofg0(str)
val len = string_length (str)
//
in
  loop (str, sz2i(len), 0)
end // end of [comarg_parse]

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

implement
comarglst_parse
  {n}(argc, argv) = let
//
fun
loop
  {i,j:nat | i <= n} .<n-i>.
(
  argv: !argv(n), i: int(i), res: list_vt(comarg, j)
) : list_vt (comarg, n-i+j) =
(
if i < argc
  then let
    val res = list_vt_cons (comarg_parse (argv[i]), res)
  in
    loop (argv, i+1, res)
  end // end of [then]
  else res // end of [else]
// end of [if]
) (* end of [loop] *)
//
val res =
  loop (argv, 0, list_vt_nil())
//
in
  list_vt2t (list_vt_reverse (res))
end // end of [comarglst_parse]

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

implement
main0 (argc, argv) =
{
//
val () =
prerrln!
(
  "Hello from ATS-parse-emit-python!"
) (* end of [val] *)
//
//
val arglst =
  comarglst_parse (argc, argv)
//
val+list_cons (arg0, arglst) = arglst
//
var
state = @{
  comarg0= arg0
, waitkind= WTKnone ()
// number of prcessed
, ninputfile= 0 // input files
, outchan= OUTCHANref (stdout_ref)
, standalone= true (* standalone output *)
, nerror= 0 // number of accumulated errors
} : cmdstate // end of [var]
//
val () = process_cmdline (state, arglst)
//
val () =
prerrln!
(
  "Good-bye from ATS-parse-emit-python!"
) (* end of [val] *)
//
} (* end of [main0] *)

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

(* end of [atsparemit_main_py.dats] *)

(* ****** ****** *)
//
// ATS-parse-emit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload
STDIO = "{$PATSLIBC}/SATS/stdio.sats"

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

staload "./atsparemit.sats"
staload "./atsparemit_parsing.sats"
staload "./atsparemit_emit.sats"

(* ****** ****** *)
//
dynload "./atsparemit.sats"
dynload "./atsparemit_syntax.sats"
dynload "./atsparemit_parsing.sats"
dynload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
dynload "./atsparemit_mylib.dats"
//
(* ****** ****** *)
//
dynload "./atsparemit_error.dats"
//
dynload "./atsparemit_print.dats"
//
dynload "./atsparemit_symbol.dats"
//
dynload "./atsparemit_fname.dats"
dynload "./atsparemit_posloc.dats"
//
dynload "./atsparemit_global.dats"
//
dynload "./atsparemit_syntax.dats"
//
dynload "./atsparemit_lexerr.dats"
dynload "./atsparemit_lexbuf.dats"
dynload "./atsparemit_lexing.dats"
//
dynload "./atsparemit_tokbuf.dats"
//
dynload "./atsparemit_parerr.dats"
dynload "./atsparemit_parsing.dats"
dynload "./atsparemit_parsing_d0exp.dats"
dynload "./atsparemit_parsing_d0ecl.dats"
dynload "./atsparemit_parsing_instr.dats"
//
(* ****** ****** *)

dynload "./atsparemit_emit.dats"
dynload "./atsparemit_typedef.dats"

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

dynload "./atsparemit_emit_py.dats"
dynload "./atsparemit_emit2_py.dats"

(* ****** ****** *)
//
datatype
comarg =
COMARGkey of (int, string)
//
typedef comarglst = List0 (comarg)
//
(* ****** ****** *)

datatype
waitkind =
  | WTKnone of ()
  | WTKinput of ()
  | WTKoutput of () // -o / --output
// end of [waitkind]

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

datatype OUTCHAN =
  | OUTCHANref of (FILEref) | OUTCHANptr of (FILEref)
// end of [OUTCHAN]

fun
outchan_get_fileref
  (x: OUTCHAN): FILEref =
(
//
case+ x of
| OUTCHANref (filr) => filr | OUTCHANptr (filp) => filp
//
) (* end of [outchan_get_fileref] *)

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

typedef
cmdstate = @{
  comarg0= comarg
, waitkind= waitkind
// number of processed input files;
, ninputfile= int // waiting for STDIN if it is 0
, outchan= OUTCHAN // current output channel
, standalone= bool (* output is a stand-alone file *)
, nerror= int // number of accumulated errors
} (* end of [cmdstate] *)

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

fun
cmdstate_set_outchan
(
  state: &cmdstate, chan_new: OUTCHAN
) : void = let
//
val chan_old = state.outchan
val ((*void*)) = state.outchan := chan_new
//
in
  case+ chan_old of
  | OUTCHANref (filr) => ()
  | OUTCHANptr (filp) => let
      val err = $STDIO.fclose0 (filp) in (*nothing*)
    end // end of [OUTCHANptr]
end // end of [cmdstate_set_outchan]

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

fun
process_cmdline
(
  state: &cmdstate, arglst: comarglst
) : void = let
in
//
case+ arglst of
| list_nil () => ()
| list_cons (arg, args) =>
    process_cmdline2 (state, arg, arglst)
//
end // end of [process_cmdline]

and
process_cmdline2
(
  state: &cmdstate, arg: comarg, arglst: comarglst
) : void = let
in
end // end of [process_cmdline2]

(* ****** ****** *)
//
extern
fun
comarg_parse (s: string):<> comarg
//
extern
fun
comarglst_parse{n:nat}
  (argc: int n, argv: !argv(n)):<> list (comarg, n)
// end of [comarglst_parse]
//
(* ****** ****** *)

implement
main0 (argc, argv) =
{
//
val () =
prerrln!
(
  "Hello from ATS-parse-emit-python!"
) (* end of [val] *)
//
//
val arglst =
  comarglst_parse (argc, argv)
//
val+list_cons (arg0, arglst) = arglst
//
var
state = @{
  comarg0= arg0
, waitkind= WTKnone ()
// number of prcessed
, ninputfile= 0 // input files
, outchan= OUTCHANref (stdout_ref)
, standalone= true (* standalone output *)
, nerror= 0 // number of accumulated errors
} : cmdstate // end of [var]
//
val () = process_cmdline (state, arglst)
//
val () =
prerrln!
(
  "Good-bye from ATS-parse-emit-python!"
) (* end of [val] *)
//
} (* end of [main0] *)

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

(* end of [atsparemit_main_py.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
**
** For testing g-sessions
**
** This famous example is taken from
** a paper on multiparty session types
** by Kohei Honda et al.
**
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
** Start time: the 8th of March, 2016
**
*)

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

%{^
//
#include <pthread.h>
//
%} // end of [%{^]

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload
UNISTD = "libc/SATS/unistd.sats"

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

staload
"./../SATS/basis_intset.sats"
staload _ =
"./../DATS/basis_intset.dats"

(* ****** ****** *)
//
staload
"./../SATS/basis_ssntype.sats"
staload
"./../SATS/basis_ssntype2r.sats"
//
(* ****** ****** *)
//
staload _ =
"libats/DATS/deqarray.dats"
//
(* ****** ****** *)
//
staload _ =
"libats/DATS/athread.dats"
staload _ =
"libats/DATS/athread_posix.dats"
//
(* ****** ****** *)
//
staload _ =
"./../DATS/basis_uchan.dats"
staload _ =
"./../DATS/basis_channel0.dats"
staload _ =
"./../DATS/basis_channel1.dats"
staload _ =
"./../DATS/basis_ssntype2r.dats"
//
(* ****** ****** *)

#define N 3

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

#define SELLER 0
#define BUYER1 1
#define BUYER2 2

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

typedef title = string
typedef price = double
typedef proof = string
typedef receipt = string

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

typedef
ssn_s0b1b2_succ =
msg(BUYER2,SELLER,proof) ::
msg(SELLER,BUYER2,receipt) :: nil

typedef
ssn_s0b1b2_fail = nil

typedef
ssn_s0b1b2 =
msg(BUYER1,SELLER,title) ::
msg(SELLER,BUYER1,price) ::
msg(SELLER,BUYER2,price) ::
msg(BUYER1,BUYER2,price) ::
choose(BUYER2,ssn_s0b1b2_succ,ssn_s0b1b2_fail)

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

stadef S0 = iset(SELLER)
stadef B1 = iset(BUYER1)
stadef B2 = iset(BUYER2)

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

local
//
prval() =
lemma_iset_sing_is_member{SELLER}()
prval() =
lemma_iset_sing_isnot_member{SELLER,BUYER1}()
prval() =
lemma_iset_sing_isnot_member{SELLER,BUYER2}()
//
prval() = lemma_iset_sing_isnot_nil{SELLER}()
//
in (* in-of-local *)

fun
fserv_seller
(
  chan:
  channel1(S0, N, ssn_s0b1b2)
) : void = let
//
val
title =
channel1_recv_val(chan, BUYER1, SELLER)
val () =
println! ("SELLER: title = ", title)
//
val
price =
(
case+
title of
| "book1" => 100.0
| "book2" => 200.0
| _(*other*) => 500.0
) : price
//
val () =
channel1_send
  (chan, SELLER, BUYER1, price)
val () =
channel1_send
  (chan, SELLER, BUYER2, price)
//
val () = channel1_skipex(chan)
//
val tag =
  channel1_choosetag(chan, BUYER2)
//
in
//
case+ tag of
| choosetag_l() => fserv_seller_succ(chan)
| choosetag_r() => fserv_seller_fail(chan)
//
end (* end of [fserv_seller] *)

and
fserv_seller_succ
(
  chan:
  channel1(S0, N, ssn_s0b1b2_succ)
) : void = let
//
val
proof =
channel1_recv_val(chan, BUYER2, SELLER)
val
receipt = "receipt-for-sale"
val () =
channel1_send(chan, SELLER, BUYER2, receipt)
//
in
  channel1_close(chan)
end (* end of [fserv_seller_succ] *)

and
fserv_seller_fail
(
  chan:
  channel1(S0, N, ssn_s0b1b2_fail)
) : void =
{
  val () = channel1_close(chan)
  val () = println! ("SELLER: no sale is made!")
} (* end of [fserv_seller_fail] *)

end // end of [local]

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

local

val
title_ref = ref<string>("book1")

in
//
fun the_title_get() = !title_ref
fun the_title_set(title: string): void = !title_ref := title
//
end // end of [local]

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

local
//
prval() =
lemma_iset_sing_is_member{BUYER1}()
prval() =
lemma_iset_sing_isnot_member{BUYER1,SELLER}()
prval() =
lemma_iset_sing_isnot_member{BUYER1,BUYER2}()
//
prval() = lemma_iset_sing_isnot_nil{BUYER1}()
//
in (* in-of-local *)

fun
fserv_buyer1
(
  chan:
  channel1(B1, N, ssn_s0b1b2)
) : void = let
//
val
title = the_title_get()
//
val () =
channel1_send
  (chan, BUYER1, SELLER, title)
//
val
price =
channel1_recv_val
  (chan, SELLER, BUYER1)
val () =
println!("BUYER1: price = ", price)
//
val () = channel1_skipex(chan)
//
val () =
channel1_send
  (chan, BUYER1, BUYER2, price / 2)
//
val tag =
  channel1_choosetag(chan, BUYER2)
//
in
//
case+ tag of
| choosetag_l() => fserv_buyer1_succ(chan)
| choosetag_r() => fserv_buyer1_fail(chan)
//
end // end of [fserv_buyer1]

and
fserv_buyer1_succ
(
  chan:
  channel1(B1, N, ssn_s0b1b2_succ)
) : void =
{
  val () = channel1_skipex(chan)
  val () = channel1_skipex(chan)
  val ((*closed*)) = channel1_close(chan)
} (* end of [fserv_buyer1_succ] *)

and
fserv_buyer1_fail
(
  chan:
  channel1(B1, N, ssn_s0b1b2_fail)
) : void =
{
  val ((*closed*)) = channel1_close(chan)
} (* end of [fserv_buyer1_fail] *)

end // end of [local]

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

local
//
prval() =
lemma_iset_sing_is_member{BUYER2}()
prval() =
lemma_iset_sing_isnot_member{BUYER2,SELLER}()
prval() =
lemma_iset_sing_isnot_member{BUYER2,BUYER1}()
//
prval() = lemma_iset_sing_isnot_nil{BUYER2}()
//
in (* in-of-local *)

fun
fserv_buyer2
(
  chan:
  channel1(B2, N, ssn_s0b1b2)
) : void = let
//
val () = channel1_skipex(chan)
val () = channel1_skipex(chan)
//
val
price =
channel1_recv_val
  (chan, SELLER, BUYER2)
val
price2 =
channel1_recv_val
  (chan, BUYER1, BUYER2)
//
val () =
println!("BUYER2: price = ", price)
val () =
println!("BUYER2: price2 = ", price2)
//
val test = (price - price2 <= 100.0)
//
in
//
if test
then {
  val () =
  channel1_choose_l(chan, BUYER2)
  val () = fserv_buyer2_succ(chan)
} (* end of [then] *)
else {
  val () =
  channel1_choose_r(chan, BUYER2)
  val () = fserv_buyer2_fail(chan)
} (* end of [else] *)
//
end (* end of [fserv_buyer2] *)

and
fserv_buyer2_succ
(
  chan:
  channel1(B2, N, ssn_s0b1b2_succ)
) : void = let
//
val
proof = "proof-of-payment"
val () =
channel1_send
  (chan, BUYER2, SELLER, proof)
//
val
receipt =
channel1_recv_val(chan, SELLER, BUYER2)
val () =
println! ("BUYER2: receipt = ", receipt)
//
in
  channel1_close(chan)
end (* end of [fserv_buyer2_succ] *)

and
fserv_buyer2_fail
(
  chan:
  channel1(B2, N, ssn_s0b1b2_fail)
) : void =
{
  val () = channel1_close(chan)
} (* end of [fserv_buyer2_fail] *)

end // end of [local]

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

implement
main0
(
  argc, argv
) = let
//
val () =
if argc >= 2
  then the_title_set(argv[1])
// end of [if]
//
val S0 = intset_int{N}(SELLER)
val B1 = intset_int{N}(BUYER1)
val B2 = intset_int{N}(BUYER2)
//
val chn0 =
cchannel1_create_exn
(
  N, S0, llam(chp) => fserv_seller(chp)
) (* end of [val] *)
val chn2 =
cchannel1_create_exn
(
  N, B2, llam(chp) => fserv_buyer2(chp)
) (* end of [val] *)
//
val () =
fserv_buyer1
  ($UN.castvwtp0(channel1_link(chn0, chn2)))
//
in
  ignoret($UNISTD.usleep(250000u)) // wait for S0 and B2
end // end of [main0]

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

(* end of [S0B1B2.dats] *)

(*
** For testing g-sessions
**
** This famous example is taken from
** a paper on multiparty session types
** by Kohei Honda et al.
**
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
** Start time: the 8th of March, 2016
**
*)

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

%{^
//
#include <pthread.h>
//
%} // end of [%{^]

(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload
UNISTD = "libc/SATS/unistd.sats"

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

staload
"./../SATS/basis_intset.sats"
staload _ =
"./../DATS/basis_intset.dats"

(* ****** ****** *)
//
staload
"./../SATS/basis_ssntype.sats"
staload
"./../SATS/basis_ssntype2r.sats"
//
(* ****** ****** *)
//
staload _ =
"libats/DATS/deqarray.dats"
//
(* ****** ****** *)
//
staload _ =
"libats/DATS/athread.dats"
staload _ =
"libats/DATS/athread_posix.dats"
//
(* ****** ****** *)
//
staload _ =
"./../DATS/basis_uchan.dats"
staload _ =
"./../DATS/basis_channel0.dats"
staload _ =
"./../DATS/basis_channel1.dats"
staload _ =
"./../DATS/basis_ssntype2r.dats"
//
(* ****** ****** *)

#define N 3

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

#define SELLER 0
#define BUYER1 1
#define BUYER2 2

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

typedef title = string
typedef price = double
typedef proof = string
typedef receipt = string

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

typedef
ssn_s0b1b2_succ =
msg(BUYER2,SELLER,proof) ::
msg(SELLER,BUYER2,receipt) :: nil

typedef
ssn_s0b1b2_fail = nil

typedef
ssn_s0b1b2 =
msg(BUYER1,SELLER,title) ::
msg(SELLER,BUYER1,price) ::
msg(SELLER,BUYER2,price) ::
msg(BUYER1,BUYER2,price) ::
choose(BUYER2,ssn_s0b1b2_succ,ssn_s0b1b2_fail)

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

stadef S0 = iset(SELLER)
stadef B1 = iset(BUYER1)
stadef B2 = iset(BUYER2)

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

local
//
prval() =
lemma_iset_sing_is_member{SELLER}()
prval() =
lemma_iset_sing_isnot_member{SELLER,BUYER1}()
prval() =
lemma_iset_sing_isnot_member{SELLER,BUYER2}()
//
prval() = lemma_iset_sing_isnot_nil{SELLER}()
//
in (* in-of-local *)

fun
fserv_seller
(
  chan:
  channel1(S0, N, ssn_s0b1b2)
) : void = let
//
val
title =
channel1_recv_val(chan, BUYER1, SELLER)
val () =
println! ("SELLER: title = ", title)
//
val
price =
(
case+
title of
| "book1" => 100.0
| "book2" => 200.0
| _(*other*) => 500.0
) : price
//
val () =
channel1_send
  (chan, SELLER, BUYER1, price)
val () =
channel1_send
  (chan, SELLER, BUYER2, price)
//
val () = channel1_skipex(chan)
//
val tag =
  channel1_choosetag(chan, BUYER2)
//
in
//
case+ tag of
| choosetag_l() => fserv_seller_succ(chan)
| choosetag_r() => fserv_seller_fail(chan)
//
end (* end of [fserv_seller] *)

and
fserv_seller_succ
(
  chan:
  channel1(S0, N, ssn_s0b1b2_succ)
) : void = let
//
val
proof =
channel1_recv_val(chan, BUYER2, SELLER)
val
receipt = "receipt-for-sale"
val () =
channel1_send(chan, SELLER, BUYER2, receipt)
//
in
  channel1_close(chan)
end (* end of [fserv_seller_succ] *)

and
fserv_seller_fail
(
  chan:
  channel1(S0, N, ssn_s0b1b2_fail)
) : void =
{
  val () = channel1_close(chan)
} (* end of [fserv_seller_fail] *)

end // end of [local]

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

local

val
title_ref = ref<string>("book1")

in
//
fun the_title_get() = !title_ref
fun the_title_set(title: string): void = !title_ref := title
//
end // end of [local]

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

local
//
prval() =
lemma_iset_sing_is_member{BUYER1}()
prval() =
lemma_iset_sing_isnot_member{BUYER1,SELLER}()
prval() =
lemma_iset_sing_isnot_member{BUYER1,BUYER2}()
//
prval() = lemma_iset_sing_isnot_nil{BUYER1}()
//
in (* in-of-local *)

fun
fserv_buyer1
(
  chan:
  channel1(B1, N, ssn_s0b1b2)
) : void = let
//
val
title = the_title_get()
//
val () =
channel1_send
  (chan, BUYER1, SELLER, title)
//
val
price =
channel1_recv_val(chan, SELLER, BUYER1)
//
val () = channel1_skipex(chan)
//
val () =
channel1_send
  (chan, BUYER1, BUYER2, price / 2)
//
val tag =
  channel1_choosetag(chan, BUYER2)
//
in
//
case+ tag of
| choosetag_l() => fserv_buyer1_succ(chan)
| choosetag_r() => fserv_buyer1_fail(chan)
//
end // end of [fserv_buyer1]

and
fserv_buyer1_succ
(
  chan:
  channel1(B1, N, ssn_s0b1b2_succ)
) : void =
{
  val () = channel1_skipex(chan)
  val () = channel1_skipex(chan)
  val ((*closed*)) = channel1_close(chan)
} (* end of [fserv_buyer1_succ] *)

and
fserv_buyer1_fail
(
  chan:
  channel1(B1, N, ssn_s0b1b2_fail)
) : void =
{
  val ((*closed*)) = channel1_close(chan)
} (* end of [fserv_buyer1_fail] *)

end // end of [local]

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

local
//
prval() =
lemma_iset_sing_is_member{BUYER2}()
prval() =
lemma_iset_sing_isnot_member{BUYER2,SELLER}()
prval() =
lemma_iset_sing_isnot_member{BUYER2,BUYER1}()
//
prval() = lemma_iset_sing_isnot_nil{BUYER2}()
//
in (* in-of-local *)

fun
fserv_buyer2
(
  chan:
  channel1(B2, N, ssn_s0b1b2)
) : void = let
//
val () = channel1_skipex(chan)
val () = channel1_skipex(chan)
//
val
price =
channel1_recv_val
  (chan, SELLER, BUYER2)
val
price2 =
channel1_recv_val
  (chan, BUYER1, BUYER2)
//
val () =
println!("BUYER2: price = ", price)
val () =
println!("BUYER2: price2 = ", price2)
//
val test = (price - price2 <= 100.0)
//
in
//
if test
then {
  val () =
  channel1_choose_l(chan, BUYER2)
  val () = fserv_buyer2_succ(chan)
} (* end of [then] *)
else {
  val () =
  channel1_choose_r(chan, BUYER2)
  val () = fserv_buyer2_fail(chan)
} (* end of [else] *)
//
end (* end of [fserv_buyer2] *)

and
fserv_buyer2_succ
(
  chan:
  channel1(B2, N, ssn_s0b1b2_succ)
) : void = let
//
val
proof = "proof-of-payment"
val () =
channel1_send
  (chan, BUYER2, SELLER, proof)
//
val
receipt =
channel1_recv_val(chan, SELLER, BUYER2)
val () = println! ("receipt = ", receipt)
//
in
  channel1_close(chan)
end (* end of [fserv_buyer2_succ] *)

and
fserv_buyer2_fail
(
  chan:
  channel1(B2, N, ssn_s0b1b2_fail)
) : void =
{
  val () = channel1_close(chan)
} (* end of [fserv_buyer2_fail] *)

end // end of [local]

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

implement
main0
(
  argc, argv
) = let
//
val () =
if argc >= 2
  then the_title_set(argv[1])
// end of [if]
//
val S0 = intset_int{N}(SELLER)
val B1 = intset_int{N}(BUYER1)
val B2 = intset_int{N}(BUYER2)
//
val chn0 =
cchannel1_create_exn
(
  N, S0, llam(chp) => fserv_seller(chp)
) (* end of [val] *)
val chn2 =
cchannel1_create_exn
(
  N, B2, llam(chp) => fserv_buyer2(chp)
) (* end of [val] *)
//
val () =
fserv_buyer1
  ($UN.castvwtp0(channel1_link(chn0, chn2)))
//
in
  ignoret($UNISTD.usleep(250000u)) // wait for S0 and B2
end // end of [main0]

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

(* end of [S0B1B2.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(***********************************************************************)
(*                                                                     *)
(*                       ATS/contrib/libats-hwxi                       *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2013 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** 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.
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)

staload "{$GTK}/SATS/gdk.sats"
staload "{$GTK}/SATS/gtk.sats"
staload "{$GLIB}/SATS/glib.sats"
staload "{$GLIB}/SATS/glib-object.sats"

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

staload "{$CAIRO}/SATS/cairo.sats"

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

staload "./../SATS/gtkcairoclock.sats"

(* ****** ****** *)
//
implement{}
gtkcairoclock_title () = stropt_none()
//
implement{}
gtkcairoclock_timeout_update () = ((*void*))
//
(* ****** ****** *)

fun{}
draw_drawingarea
(
  darea: !GtkDrawingArea1
) : void = let
//
val (
  fpf_win | win
) = gtk_widget_get_window (darea)
//
val isnot = g_object_isnot_null (win)
//
in
//
if isnot then let
  val cr = gdk_cairo_create (win)
  prval () = minus_addback (fpf_win, win | darea)
  var alloc: GtkAllocation?
  val () = gtk_widget_get_allocation (darea, alloc)
  val () = gtkcairoclock_mydraw<> (cr, gint2int(alloc.width), gint2int(alloc.height))
  val () = cairo_destroy (cr)
in
  // nothing
end else let
  prval () = minus_addback (fpf_win, win | darea)
in
  // nothing
end (* end of [if] *)
//
end // end of [draw_drawingarea]

(* ****** ****** *)
//
extern
fun{
} on_destroy
  (widget: !GtkWidget1, event: &GdkEvent, _: gpointer): void
extern
fun{
} on_delete_event
  (widget: !GtkWidget1, event: &GdkEvent, _: gpointer): gboolean
//
(* ****** ****** *)
//
implement{
} on_destroy (widget, event, _) = ((*void*))
implement{
} on_delete_event (widget, event, _) = (gtk_main_quit (); GTRUE)
//
(* ****** ****** *)

extern
fun{} fexpose (!GtkDrawingArea1): gboolean
extern
fun{} ftimeout (!GtkDrawingArea1): gboolean

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

implement{
} fexpose (darea) = let
  val () = draw_drawingarea (darea) in GFALSE
end // end of [fexpose]

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

implement{
} ftimeout (darea) = let
//
val (
) = gtkcairoclock_timeout_update ()
//
val (fpf_win | win) = gtk_widget_get_window (darea)
//
val isnot = g_object_isnot_null (win)
//
prval () = minus_addback (fpf_win, win | darea)
//
in
//
if
isnot
then let
  var alloc: GtkAllocation
  val () = gtk_widget_get_allocation (darea, alloc)
  val () = gtk_widget_queue_draw_area (darea, gint(0), gint(0), alloc.width, alloc.height)
in
  GTRUE // HX: [ftimeout] continues
end else
  GFALSE // HX: [ftimeout] is unregistered
// end of [if]
//
end // end of [ftimeout]

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

#define nullp the_null_ptr

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

implement{}
gtkcairoclock_main
  ((*void*)) = () where
{
//
val win0 =
  gtk_window_new (GTK_WINDOW_TOPLEVEL)
//
val win0 = win0 // HX: fix the master type
//
val () = assertloc (ptrcast(win0) > 0)
val () = gtk_window_set_default_size (win0, gint(400), gint(400))
//
val opt = gtkcairoclock_title ()
val issome = stropt_is_some(opt)
val () =
if
issome
then let
  val title = stropt_unsome (opt)
in
  gtk_window_set_title (win0, gstring(title))
end // end of [if] // end of [val]
//
val darea =
  gtk_drawing_area_new ()
val p_darea = gobjref2ptr (darea)
val () = assertloc (p_darea > 0)
val () = gtk_container_add (win0, darea)
//
val _sid =
g_signal_connect
(
  darea
, (gsignal)"draw"
, G_CALLBACK(fexpose), gpointer(nullp)
) (* end of [val] *)
//
val () = g_object_unref (darea)
//
val _sid =
g_signal_connect
(
  win0
, (gsignal)"destroy"
, G_CALLBACK(on_destroy), gpointer(nullp)
) (* end of [val] *)
val _sid =
g_signal_connect
(
  win0
, (gsignal)"delete-event"
, G_CALLBACK(on_delete_event), gpointer(nullp)
) (* end of [val] *)
//
val int =
  gtkcairoclock_timeout_interval()
//
val _rid =
g_timeout_add
(
  guint(int), (GSourceFunc)ftimeout, gpointer(p_darea)
) (* end of [val] *)
//
val () = gtk_widget_show_all (win0)
//
val () = g_object_unref (win0) // HX: refcount of [win0] decreases from 2 to 1
//
val ((*void*)) = gtk_main ((*void*))
//
} (* end of [gtkcairoclock_main] *)

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

(* end of [gtkcairoclock.dats] *)

(***********************************************************************)
(*                                                                     *)
(*                       ATS/contrib/libats-hwxi                       *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2013 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** 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.
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)

staload "{$GTK}/SATS/gdk.sats"
staload "{$GTK}/SATS/gtk.sats"
staload "{$GLIB}/SATS/glib.sats"
staload "{$GLIB}/SATS/glib-object.sats"

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

staload "{$CAIRO}/SATS/cairo.sats"

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

staload "./../SATS/gtkcairoclock.sats"

(* ****** ****** *)
//
implement{}
gtkcairoclock_title () = stropt_none()
//
implement{}
gtkcairoclock_timeout_update () = ((*void*))
//
(* ****** ****** *)

fun{}
draw_drawingarea
(
  darea: !GtkDrawingArea1
) : void = let
//
val (
  fpf_win | win
) = gtk_widget_get_window (darea)
//
val isnot = g_object_isnot_null (win)
//
in
//
if isnot then let
  val cr = gdk_cairo_create (win)
  prval () = minus_addback (fpf_win, win | darea)
  var alloc: GtkAllocation?
  val () = gtk_widget_get_allocation (darea, alloc)
  val () = gtkcairoclock_mydraw<> (cr, gint2int(alloc.width), gint2int(alloc.height))
  val () = cairo_destroy (cr)
in
  // nothing
end else let
  prval () = minus_addback (fpf_win, win | darea)
in
  // nothing
end (* end of [if] *)
//
end // end of [draw_drawingarea]

(* ****** ****** *)
//
extern
fun{
} on_destroy
  (widget: !GtkWidget1, event: &GdkEvent, _: gpointer): void
extern
fun{
} on_delete_event
  (widget: !GtkWidget1, event: &GdkEvent, _: gpointer): gboolean
//
(* ****** ****** *)
//
implement{
} on_destroy (widget, event, _) = ((*void*))
implement{
} on_delete_event (widget, event, _) = (gtk_main_quit (); GTRUE)
//
(* ****** ****** *)

extern
fun{} fexpose (!GtkDrawingArea1): gboolean
extern
fun{} ftimeout (!GtkDrawingArea1): gboolean

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

implement{
} fexpose (darea) = let
  val () = draw_drawingarea (darea) in GFALSE
end // end of [fexpose]

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

implement{
} ftimeout (darea) = let
//
val (
) = gtkcairoclock_timeout_update ()
//
val (fpf_win | win) = gtk_widget_get_window (darea)
//
val isnot = g_object_isnot_null (win)
//
prval () = minus_addback (fpf_win, win | darea)
//
in
//
if
isnot
then let
  var alloc: GtkAllocation
  val () = gtk_widget_get_allocation (darea, alloc)
  val () = gtk_widget_queue_draw_area (darea, gint(0), gint(0), alloc.width, alloc.height)
in
  GTRUE // HX: [ftimeout] continues
end else
  GFALSE // HX: [ftimeout] is unregistered
// end of [if]
//
end // end of [ftimeout]

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

#define nullp the_null_ptr

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

implement{}
gtkcairoclock_main
  ((*void*)) = () where
{
//
val win0 =
  gtk_window_new (GTK_WINDOW_TOPLEVEL)
//
val win0 = win0 // HX: fix the master type
//
val () = assertloc (ptrcast(win0) > 0)
val () = gtk_window_set_default_size (win0, gint(400), gint(400))
//
val opt = gtkcairoclock_title ()
val issome = stropt_is_some(opt)
val () =
if issome then let
  val title = stropt_unsome (opt)
in
  gtk_window_set_title (win0, gstring(title))
end // end of [if] // end of [val]
//
val darea =
  gtk_drawing_area_new ()
val p_darea = gobjref2ptr (darea)
val () = assertloc (p_darea > 0)
val () = gtk_container_add (win0, darea)
//
val _sid = g_signal_connect
(
  darea, (gsignal)"draw", G_CALLBACK(fexpose), gpointer(nullp)
)
val () = g_object_unref (darea)
//
val _sid = g_signal_connect
(
  win0, (gsignal)"destroy", G_CALLBACK(on_destroy), gpointer(nullp)
)
val _sid = g_signal_connect
(
  win0, (gsignal)"delete-event", G_CALLBACK(on_delete_event), gpointer(nullp)
)
//
val int =
  gtkcairoclock_timeout_interval ()
val _rid = g_timeout_add (guint(int), (GSourceFunc)ftimeout, gpointer(p_darea))
//
val () = gtk_widget_show_all (win0)
//
val () = g_object_unref (win0) // HX: refcount of [win0] decreases from 2 to 1
//
val ((*void*)) = gtk_main ((*void*))
//
} // end of [gtkcairoclock_main]

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

(* end of [gtkcairoclock.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
** Patsopt-atscc2js-eval
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_MAINATSFLAG 1
#define
ATS_DYNLOADNAME "inputform_dynload"
//
(* ****** ****** *)

#include "{$LIBATSCC2JS}/staloadall.hats"

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

abstype button
abstype checkbox

(* ****** ****** *)
//
extern
fun
document_button : string -> button = "mac#"
extern
fun
document_checkbox : string -> checkbox = "mac#"
//
%{^
function
document_button(name)
{
  return document.getElementById("name");
}
function
document_checkbox(name)
{
  return document.getElementById("name");
}
%} // end of [%{^]
//
(* ****** ****** *)
//
datatype
outstring =
| outstring$stdout of (string)
| outstring$stderr of (string)
//
fun
outstring2string
(
  out: outstring
) : string = (
//
case+ out of
| outstring$stdout(x) => x | outstring$stderr(x) => x
//
) (* end of [outstring2string] *)
//
(* ****** ****** *)
//
extern
fun
checkbox_test(checkbox): bool = "mac#"
//
(* ****** ****** *)
//
extern
fun
Patsopt_input_get(): string = "mac#"
extern
fun
Patsopt_output_get(): outstring = "mac#"
extern
fun
Patsopt_output_set(outstring): void = "mac#"
//
(* ****** ****** *)
//
extern
fun
Atscc2js_input_get(): outstring = "mac#"
extern
fun
Atscc2js_output_get(): outstring = "mac#"
extern
fun
Atscc2js_output_set(outstring): void = "mac#"
//
(* ****** ****** *)
//
extern
fun
Evaluate_input_get(): outstring = "mac#"
//
(* ****** ****** *)
//
extern
fun
Patsopt_output_text_set(string): void = "mac#"
//
%{^
function
Patsopt_output_text_set(value)
{
  return document.getElementById("Patsopt_output_text").value = value
}
%} // end of [%{^]
//
(* ****** ****** *)
//
val Patsopt_button = document_button"Patsopt_button"
//
val Atscc2js_box = document_checkbox"Atscc2js_box"
val Atscc2js_button = document_button"Atscc2js_button"
//
val Evaluate_box = document_checkbox"Evaluate_box"
val Evaluate_button = document_button"Evaluate_button"
//
(* ****** ****** *)
//
val
Patsopt_output_ref =
  ref{outstring}(outstring$stderr(""))
val
Atscc2js_output_ref =
  ref{outstring}(outstring$stderr(""))
//
(* ****** ****** *)
//
val
Patsopt_output_box = document_checkbox"Patsopt_output_box"
val
Atscc2js_output_box = document_checkbox"Atscc2js_output_box"
//
(* ****** ****** *)
//
implement
Patsopt_output_get() = Patsopt_output_ref[]
implement
Patsopt_output_set(out) =
{
  val () =
    Patsopt_output_ref[] := out
  // end of [val]
  val () =
  if checkbox_test(Patsopt_output_box)
    then Patsopt_output_text_set(outstring2string(out))
  // end of [if]
}
//
(* ****** ****** *)
//
extern
fun
Patsopt_optstr_get(): string = "mac#"
//
%{^
//
function
Patsopt_optstr_get()
{
  return document.getElementById("Patsopt_optstr").value;
}
//
%} // end of [%{^]
//
(* ****** ****** *)
//
implement
Atscc2js_input_get() = Patsopt_output_get()
implement
Atscc2js_output_get() = Atscc2js_output_ref[]
implement
Atscc2js_output_set(out) =
{
  val () =
    Atscc2js_output_ref[] := out
  // end of [val]
  val () =
  if checkbox_test(Atscc2js_output_box)
    then Patsopt_output_text_set(outstring2string(out))
  // end of [if]
}
//
(* ****** ****** *)

implement
Evaluate_input_get() = Atscc2js_output_get()

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

%{$
//
jQuery(document).ready(function(){inputform_dynload();});
//
%} // end of [%{$]

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

(* end of [inputform.dats] *)

(*
** Patsopt-atscc2js-eval
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_MAINATSFLAG 1
#define
ATS_DYNLOADNAME "inputform_dynload"
//
(* ****** ****** *)

#include "{$LIBATSCC2JS}/staloadall.hats"

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

abstype button
abstype checkbox

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

extern
fun button : string -> button = "mac#"
extern
fun checkbox : string -> checkbox = "mac#"

(* ****** ****** *)
//
datatype
outstring =
| outstring$stdout of (string)
| outstring$stderr of (string)
//
fun
outstring2string
(
  out: outstring
) : string = (
//
case+ out of
| outstring$stdout(x) => x | outstring$stderr(x) => x
//
) (* end of [outstring2string] *)
//
(* ****** ****** *)
//
extern
fun
checkbox_test(checkbox): bool = "mac#"
//
(* ****** ****** *)
//
extern
fun
Patsopt_input_get(): string = "mac#"
extern
fun
Patsopt_output_get(): outstring = "mac#"
extern
fun
Patsopt_output_set(outstring): void = "mac#"
//
(* ****** ****** *)
//
extern
fun
Atscc2js_input_get(): outstring = "mac#"
extern
fun
Atscc2js_output_get(): outstring = "mac#"
extern
fun
Atscc2js_output_set(outstring): void = "mac#"
//
(* ****** ****** *)
//
extern
fun
Evaluate_input_get(): outstring = "mac#"
//
(* ****** ****** *)
//
extern
fun
Patsopt_output_text_set(string): void = "mac#"
//
%{^
function
Patsopt_output_text_set(value)
{
  return document.getElementById("Patsopt_output_text").value = value
}
%} // end of [%{^]
//
(* ****** ****** *)
//
val Patsopt_button = button"Patsopt_button"
//
val Atscc2js_box = checkbox"Atscc2js_box"
val Atscc2js_button = button"Atscc2js_button"
//
val Evaluate_box = checkbox"Evaluate_box"
val Evaluate_button = button"Evaluate_button"
//
(* ****** ****** *)
//
val
Patsopt_output_ref =
  ref{outstring}(outstring$stderr(""))
val
Atscc2js_output_ref =
  ref{outstring}(outstring$stderr(""))
//
(* ****** ****** *)
//
val
Patsopt_output_box = checkbox"Patsopt_output_box"
val
Atscc2js_output_box = checkbox"Atscc2js_output_box"
//
(* ****** ****** *)
//
implement
Patsopt_output_get() = Patsopt_output_ref[]
implement
Patsopt_output_set(out) =
{
  val () =
    Patsopt_output_ref[] := out
  // end of [val]
  val () =
  if checkbox_test(Patsopt_output_box)
    then Patsopt_output_text_set(outstring2string(out))
  // end of [if]
}
//
(* ****** ****** *)
//
extern
fun
Patsopt_optstr_get(): string = "mac#"
//
%{^
//
function
Patsopt_optstr_get()
{
  return document.getElementById("Patsopt_optstr").value;
}
//
%} // end of [%{^]
//
(* ****** ****** *)
//
implement
Atscc2js_input_get() = Patsopt_output_get()
implement
Atscc2js_output_get() = Atscc2js_output_ref[]
implement
Atscc2js_output_set(out) =
{
  val () =
    Atscc2js_output_ref[] := out
  // end of [val]
  val () =
  if checkbox_test(Atscc2js_output_box)
    then Patsopt_output_text_set(outstring2string(out))
  // end of [if]
}
//
(* ****** ****** *)

implement
Evaluate_input_get() = Atscc2js_output_get()

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

%{$
//
jQuery(document).ready(function(){inputform_dynload();});
//
%} // end of [%{$]

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

(* end of [inputform.dats] *)


Read/write multi address of EEPROM

Read/write multi address of EEPROM

#include "config.hats"
#include "{$TOP}/avr_prelude/kernel_staload.hats"

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

#define ADDR 7
#define VAL 12
#define BLINK_DELAY_MS 1000.0

implement main0 () = {
  fun loop (value: (uint8, uint8, uint8)) = {
    val () = println! ("Adddress ",  ADDR, " = ", value.0)
    val () = println! ("Adddress ",  ADDR+1, " = ", value.1)
    val () = println! ("Adddress ",  ADDR+2, " = ", value.2)
    val () = delay_ms (BLINK_DELAY_MS)
    val () = loop (value)
  }

  val () = interrupts ()
  val () = serial_begin (9600UL)
  val () = eeprom_write_byte (ADDR, $UN.cast (VAL))
  val () = eeprom_write_byte (ADDR+1, $UN.cast (VAL*2))
  val () = eeprom_write_byte (ADDR+2, $UN.cast (VAL*3))
  val v1 = eeprom_read_byte (ADDR)
  val v2 = eeprom_read_byte (ADDR+1)
  val v3 = eeprom_read_byte (ADDR+2)
  val () = loop @(v1, v2, v3)
}

#include "config.hats"
#include "{$TOP}/avr_prelude/kernel_staload.hats"

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

#define ADDR 7
#define VAL 111
#define BLINK_DELAY_MS 1000.0

implement main0 () = {
  fun loop (value: uint8) = {
    val () = println! ("Adddress ",  ADDR, " = ", value)
    val () = delay_ms (BLINK_DELAY_MS)
    val () = loop (value)
  }

  val () = interrupts ()
  val () = serial_begin (9600UL)
  val () = eeprom_write_byte (ADDR, $UN.cast (VAL))
  val v  = eeprom_read_byte (ADDR)
  val () = loop (v)
}


Updating: libatscc2erl: support for persistent service

(*
** Atscc2erl:
** Basis for session-types
*)

(* ****** ****** *)
//
// HX-2015-07:
// prefix for external names
//
#define
ATS_EXTERN_PREFIX "libats2erl_session_"
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
staload
"{$LIBATSCC2ERL}/basics_erl.sats"
//
(* ****** ****** *)
//
abstype chsnd(a:vt@ype)
abstype chrcv(a:vt@ype)
//
(* ****** ****** *)

abstype chnil
abstype chcons(a:type, ss:type)

(* ****** ****** *)
//
stadef nil = chnil
//
stadef :: = chcons
stadef cons = chcons
//
(* ****** ****** *)

absvtype chanpos(type) = ptr
absvtype channeg(type) = ptr

(* ****** ****** *)
//
fun
chanpos_send
  {a:vt0p}{ss:type}
(
  chp: !chanpos(chsnd(a)::ss) >> chanpos(ss), x: a
) : void = "mac#%" // end-of-function
//
fun
channeg_recv
  {a:vt0p}{ss:type}
(
  chn: !channeg(chrcv(a)::ss) >> channeg(ss), x: a
) : void = "mac#%" // end-of-function
//
(* ****** ****** *)
//
fun
chanpos_recv
  {a:vt0p}{ss:type}
  (!chanpos(chrcv(a)::ss) >> chanpos(ss)): a = "mac#%"
//
fun
channeg_send
  {a:vt0p}{ss:type}
  (!channeg(chsnd(a)::ss) >> channeg(ss)): a = "mac#%"
//
(* ****** ****** *)
//
fun chanpos_nil_wait (chp: chanpos(nil)): void = "mac#%"
fun channeg_nil_close (chn: channeg(nil)): void = "mac#%"
//
(* ****** ****** *)
//
fun
chanposneg_link
  {ss:type}(chp: chanpos(ss), chn: channeg(ss)): void = "mac#%"
//
(* ****** ****** *)
//
fun
channeg_create{ss:type}
  (fserv: chanpos(ss) -<lincloptr1> void): channeg(ss) = "mac#%"
//
(* ****** ****** *)

symintr channel_send
overload channel_send with chanpos_send
overload channel_send with channeg_recv

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

symintr channel_recv
overload channel_recv with chanpos_recv
overload channel_recv with channeg_send

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

symintr channel_close
overload channel_close with chanpos_nil_wait
overload channel_close with channeg_nil_close

(* ****** ****** *)
//
macdef
channel_send_close
  (chx, x0) = (
//
let val chx = ,(chx) in channel_send(chx, ,(x0)); channel_close(chx) end
//
) (* end of [channel_send_close] *)
//
(* ****** ****** *)
//
macdef
channel_recv_close(chx) =
let val chx = ,(chx); val x0 = channel_recv(chx) in channel_close(chx); x0 end
//
(* ****** ****** *)
//
// HX-2015-07:
// For persisten service
//
(* ****** ****** *)
//
abstype
chansrvc(ss:type) = ptr
abstype
chansrvc2(env:vt@ype, ss:type) = ptr
//
stadef service = chansrvc
stadef service = chansrvc2
//
(* ****** ****** *)
//
fun
chansrvc_create{ss:type}
(
  fserv: chanpos(ss) -<cloref1> void
) : chansrvc(ss) = "mac#%" // end-of-fun
//
fun
chansrvc_request
  {ss:type}
  (chsrv: chansrvc(ss)): channeg(ss) = "mac#%"
//
(* ****** ****** *)
//
fun
chansrvc2_create
  {env:vt0p}{ss:type}
(
  fserv: (env, chanpos(ss)) -<cloref1> void
) : chansrvc2(env, ss) = "mac#%" // end-of-fun
//
fun
chansrvc2_request
  {env:vt0p}{ss:type}
  (env, chansrvc2(env, ss)): channeg(ss) = "mac#%"
//
(* ****** ****** *)
//
fun
chansrvc_register
  {ss:type}
  (name: atom, chsrv: chansrvc(ss)): void = "mac#%"
fun
chansrvc2_register
  {env:vt0p}{ss:type}
  (name: atom, chsrv: chansrvc2(env, ss)): void = "mac#%"
//
(* ****** ****** *)

(* end of [basis.sats] *)

(*
** Atscc2erl:
** Basis for session-types
*)

(* ****** ****** *)
//
// HX-2015-07:
// prefix for external names
//
#define
ATS_EXTERN_PREFIX "libats2erl_session_"
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
staload
"{$LIBATSCC2ERL}/basics_erl.sats"
//
(* ****** ****** *)
//
abstype chsnd(a:vt@ype)
abstype chrcv(a:vt@ype)
//
(* ****** ****** *)

abstype chnil
abstype chcons(a:type, ss:type)

(* ****** ****** *)
//
stadef nil = chnil
//
stadef :: = chcons
stadef cons = chcons
//
(* ****** ****** *)

absvtype chanpos(type) = ptr
absvtype channeg(type) = ptr

(* ****** ****** *)
//
fun
chanpos_send
  {a:vt0p}{ss:type}
(
  chp: !chanpos(chsnd(a)::ss) >> chanpos(ss), x: a
) : void = "mac#%" // end-of-function
//
fun
channeg_recv
  {a:vt0p}{ss:type}
(
  chn: !channeg(chrcv(a)::ss) >> channeg(ss), x: a
) : void = "mac#%" // end-of-function
//
(* ****** ****** *)
//
fun
chanpos_recv
  {a:vt0p}{ss:type}
  (!chanpos(chrcv(a)::ss) >> chanpos(ss)): a = "mac#%"
//
fun
channeg_send
  {a:vt0p}{ss:type}
  (!channeg(chsnd(a)::ss) >> channeg(ss)): a = "mac#%"
//
(* ****** ****** *)
//
fun chanpos_nil_wait (chp: chanpos(nil)): void = "mac#%"
fun channeg_nil_close (chn: channeg(nil)): void = "mac#%"
//
(* ****** ****** *)
//
fun
chanposneg_link
  {ss:type}(chp: chanpos(ss), chn: channeg(ss)): void = "mac#%"
//
(* ****** ****** *)
//
fun
channeg_create{ss:type}
  (fserv: chanpos(ss) -<lincloptr1> void): channeg(ss) = "mac#%"
//
(* ****** ****** *)

symintr channel_send
overload channel_send with chanpos_send
overload channel_send with channeg_recv

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

symintr channel_recv
overload channel_recv with chanpos_recv
overload channel_recv with channeg_send

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

symintr channel_close
overload channel_close with chanpos_nil_wait
overload channel_close with channeg_nil_close

(* ****** ****** *)
//
macdef
channel_send_close
  (chx, x0) = (
//
let val chx = ,(chx) in channel_send(chx, ,(x0)); channel_close(chx) end
//
) (* end of [channel_send_close] *)
//
(* ****** ****** *)
//
macdef
channel_recv_close(chx) =
let val chx = ,(chx); val x0 = channel_recv(chx) in channel_close(chx); x0 end
//
(* ****** ****** *)
//
abstype
chansrvc(ss:type) = ptr
abstype
chansrvc2(env:vt@ype, ss:type) = ptr
//
stadef service = chansrvc
stadef service = chansrvc2
//
(* ****** ****** *)
//
fun
chansrvc_create{ss:type}
(
  fserv: chanpos(ss) -<cloref1> void
) : chansrvc(ss) = "mac#%" // end-of-fun
//
fun
chansrvc_request
  {ss:type}
  (chsrv: chansrvc(ss)): channeg(ss) = "mac#%"
//
(* ****** ****** *)
//
fun
chansrvc2_create
  {env:vt0p}{ss:type}
(
  fserv: (env, chanpos(ss)) -<cloref1> void
) : chansrvc2(env, ss) = "mac#%" // end-of-fun
//
fun
chansrvc2_request
  {env:vt0p}{ss:type}
  (env, chansrvc2(env, ss)): channeg(ss) = "mac#%"
//
(* ****** ****** *)
//
fun
chansrvc_register
  {ss:type}
  (name: atom, chsrv: chansrvc(ss)): void = "mac#%"
fun
chansrvc2_register
  {env:vt0p}{ss:type}
  (name: atom, chsrv: chansrvc2(env, ss)): void = "mac#%"
//
(* ****** ****** *)

(* end of [basis.sats] *)


Updating: very minorly improving

Updating: very minorly improving

(* ****** ****** *)
//
// Title:
// Concepts of Programming Languages
// Number: CAS CS 320
// Semester: Spring 2016
// Class Time: TR 12:30-2:00
// Instructor: Hongwei Xi (hwxiATbuDOTedu)
// Teaching Fellow: Hanwen Wu (hwwuATbuDOTedu)
//
(* ****** ****** *)

(*
** A worm-like game!
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)

#define NROW 32
#define NCOL 32
// #define NCOL 64

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

#define NWORM NROW

(* ****** ****** *)
//
fun succ_row(x: int): int
fun pred_row(x: int): int
//
fun succ_col(x: int): int
fun pred_col(x: int): int
//
(* ****** ****** *)

abstype worm = ptr

(* ****** ****** *)
//
datatype
wnode =
  | WN of (int(*i*), int(*j*))
//
(* ****** ****** *)
//
datatype
xnode =
  | XN0 of () | XN1 of (int(*kind*))
//
(* ****** ****** *)
//
typedef
gamebd = mtrxszref(xnode)
//
typedef
visitbd = mtrxszref(int)
//
typedef
printbd = mtrxszref(string)
//
(* ****** ****** *)
//
fun theWorm_get(): worm = "mac#"
//
fun theWorm_length(): int = "mac#"
//
fun theWorm_insert(): void = "mac#"
fun theWorm_remove(): void = "mac#"
//
fun theWorm_move_rand(): int = "mac#"
//
(* ****** ****** *)
//
fun theGamebd_get(): gamebd = "mac#"
//
fun
theWormlike_scene1((*void*)): void = "mac#"
fun
theWormlike_scene2((*void*)): void = "mac#"
//
(* ****** ****** *)

fun theVisitbd_get(): visitbd = "mac#"
fun theVisitbd_reset((*void*)): void = "mac#"

(* ****** ****** *)
//
fun thePrintbd_get(): printbd = "mac#"
//
(* ****** ****** *)

fun Wormlike_worm_initize(): void = "mac#"
fun Wormlike_keyboard_initize(): void = "mac#"

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

(* end of [Wormlike.sats] *)

(* ****** ****** *)
//
// Title:
// Concepts of Programming Languages
// Number: CAS CS 320
// Semester: Spring 2016
// Class Time: TR 12:30-2:00
// Instructor: Hongwei Xi (hwxiATbuDOTedu)
// Teaching Fellow: Hanwen Wu (hwwuATbuDOTedu)
//
(* ****** ****** *)

(*
** A worm-like game!
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)

#define NROW 32
#define NCOL 32
// #define NCOL 64

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

#define NWORM NROW

(* ****** ****** *)
//
fun succ_row(x: int): int
fun pred_row(x: int): int
//
fun succ_col(x: int): int
fun pred_col(x: int): int
//
(* ****** ****** *)

abstype worm = ptr

(* ****** ****** *)
//
datatype
wnode =
  | WN of (int(*i*), int(*j*))
//
(* ****** ****** *)
//
datatype
xnode =
  | XN0 of () | XN1 of (int(*kind*))
//
(* ****** ****** *)
//
typedef
gamebd = mtrxszref(xnode)
//
typedef
visitbd = mtrxszref(int)
//
typedef
printbd = mtrxszref(string)
//
(* ****** ****** *)
//
fun theWorm_get(): worm = "mac#"
//
fun theWorm_length(): int = "mac#"
//
fun theWorm_insert(): void = "mac#"
fun theWorm_remove(): void = "mac#"
//
fun theWorm_move_rand(): int = "mac#"
//
(* ****** ****** *)
//
fun theGamebd_get(): gamebd = "mac#"
//
fun
theWormlike_scene1((*void*)): void = "mac#"
fun
theWormlike_scene2((*void*)): void = "mac#"
//
(* ****** ****** *)

fun theVisitbd_get(): visitbd = "mac#"
fun theVisitbd_reset((*void*)): void = "mac#"

(* ****** ****** *)
//
fun thePrintbd_get(): printbd = "mac#"
//
(* ****** ****** *)

fun Wormlike_worm_initize(): void = "mac#"

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

(* end of [Wormlike.sats] *)


Don't use $STRING.memset_unsafe

Don't use $STRING.memset_unsafe

#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"
staload "libmbedats/SATS/rtos_rtx_cmsis_os.sats"
staload "libmbedats/SATS/net_eth_EthernetInterface.sats"
staload "libmbedats/SATS/net_lwip_lwip.sats"
staload "libmbedats/SATS/mbed_api_mbed_interface.sats"

%{^
#include "eth_arch.h"

void mbed_mac_address (char* mac) { // My own MAC address
    mac[0] = 0x00;
    mac[1] = 0x02;
    mac[2] = 0xF7;
    mac[3] = 0xF0;
    mac[4] = 0x99;
    mac[5] = 0x99;
}
%}

extern fun eth_arch_enetif_init: netif_init_fn = "mac#"
extern fun eth_arch_enable_interrupts: () -> void = "mac#"
extern fun eth_arch_disable_interrupts: () -> void = "mac#"

fun null_ip_addr_t_p () = $UN.castvwtp0{ip_addr_t_p}(the_null_ptr)

// *** Global State on C ***
%{
#define IP_ADDR_LEN  16
static char c_ip_addr[IP_ADDR_LEN + 1] = "\0";
%}
macdef ip_addr_len = $extval(int, "IP_ADDR_LEN")
macdef ip_addr = $extval(string, "c_ip_addr")

// *** Global State on ATS ***
%{
#define semaphore_member_p(SEMD)  (&(((osSemaphoreDef_t *)(SEMD))->semaphore))
%}
extern fun semaphore_member_p: (osSemaphoreDef_t_p) -> ptr = "mac#"
// state = netif
var netif: struct_netif
fun netif_p (): struct_netif_p = $UN.castvwtp0 (addr@netif)
// state = use_dhctp_{id,def}
var use_dhcp = false
fun use_dhcp_p (): ptr = $UN.castvwtp0 (addr@use_dhcp)
// state = tcpip_inited_{id,def}
var tcpip_inited_id: osSemaphoreId
fun takeout_tcpip_inited_id (): [l:agz] (osSemaphoreId @ l | ptr l) = $UN.castvwtp0 (addr@tcpip_inited_id)
extern praxi addback_tcpip_inited_id {l:agz} (pf: osSemaphoreId @ l): void
var tcpip_inited_def: osSemaphoreDef_t
fun tcpip_inited_def_p (): osSemaphoreDef_t_p = $UN.castvwtp0 (addr@tcpip_inited_def)
var tcpip_inited_data: @[uint32][2]
// state = netif_linked_{id,def}
var netif_linked_id: osSemaphoreId
fun takeout_netif_linked_id (): [l:agz] (osSemaphoreId @ l | ptr l) = $UN.castvwtp0 (addr@netif_linked_id)
extern praxi addback_netif_linked_id {l:agz} (pf: osSemaphoreId @ l): void
var netif_linked_def: osSemaphoreDef_t
fun netif_linked_def_p (): osSemaphoreDef_t_p = $UN.castvwtp0 (addr@netif_linked_def)
var netif_linked_data: @[uint32][2]
// state = netif_up_{id,def}
var netif_up_id: osSemaphoreId
fun takeout_netif_up_id (): [l:agz] (osSemaphoreId @ l | ptr l) = $UN.castvwtp0 (addr@netif_up_id)
extern praxi addback_netif_up_id {l:agz} (pf: osSemaphoreId @ l): void
var netif_up_def: osSemaphoreDef_t
fun netif_up_def_p (): osSemaphoreDef_t_p = $UN.castvwtp0 (addr@netif_up_def)
var netif_up_data: @[uint32][2]
// state = macaddr
local
  var _dat_macaddr: struct_macaddr // hide
in
  fun takeout_macaddr (): [l:agz] (struct_macaddr @ l | ptr l) = $UN.castvwtp0 (addr@_dat_macaddr)
end
extern praxi addback_macaddr {l:agz} (pf: struct_macaddr @ l): void

fun tcpip_init_done (p: ptr): void = {
  val (pf | p) = takeout_tcpip_inited_id ()
  val _ = osSemaphoreRelease (!p)
  prval () = addback_tcpip_inited_id (pf)
}

fun netif_link_callback (nif: struct_netif_p): void =
  if netif_is_link_up (nif) then {
    val (pf | p) = takeout_netif_linked_id ()
    val _ = osSemaphoreRelease (!p)
    prval () = addback_netif_linked_id (pf)
  }

fun netif_status_callback (nif: struct_netif_p): void =
  if netif_is_up (nif) then {
    (* xxx Need the following ?
      strcpy(gateway, inet_ntoa(netif->gw));
      strcpy(networkmask, inet_ntoa(netif->netmask));
     *)
    val _ = inet_ntoa_r (get_netif_ip_addr (netif_p ()), ip_addr, ip_addr_len)
    val (pf | p) = takeout_netif_up_id ()
    val _ = osSemaphoreRelease (!p)
    prval () = addback_netif_up_id (pf)
  }

fun sem_create{l:addr} (def_p: osSemaphoreDef_t_p, dat_p: ptr l, count: int): osSemaphoreId = let
  extern fun memset: (ptr, int, size_t) -> ptr = "mac#"
  val _ = memset(dat_p, 0, sizeof<uint32>)
  val p = semaphore_member_p (def_p)
  val () = $UN.ptr0_set (p, dat_p)
in
  osSemaphoreCreate (def_p, $UN.cast (count))
end

fun init_netif(ipaddr: ip_addr_t_p, netmask: ip_addr_t_p, gw: ip_addr_t_p): void = {
  // Init Semaphores
  val v = sem_create (tcpip_inited_def_p (), addr@tcpip_inited_data, 0)
  val () = $UN.ptr0_set (addr@tcpip_inited_id, v)
  val v = sem_create (netif_linked_def_p (), addr@netif_linked_data, 0)
  val () = $UN.ptr0_set (addr@netif_linked_id, v)
  val v = sem_create (netif_up_def_p (), addr@netif_up_data, 0)
  val () = $UN.ptr0_set (addr@netif_up_id, v)
  // Init & wait
  val () = tcpip_init (tcpip_init_done, the_null_ptr)
  val (pf | p) = takeout_tcpip_inited_id ()
  val _ = osSemaphoreWait (!p, osWaitForever)
  prval () = addback_tcpip_inited_id (pf)
  // Init netif
  extern fun memset: (ptr, int, size_t) -> ptr = "mac#"
  val _ = memset(addr@netif, 0, sizeof<struct_netif>)
  val _ = netif_add(netif_p (), ipaddr, netmask, gw, the_null_ptr, eth_arch_enetif_init, tcpip_input)
  val () = netif_set_default (netif_p ())
  val () = netif_set_link_callback (netif_p (), netif_link_callback);
  val () = netif_set_status_callback (netif_p (), netif_status_callback);
}

fun set_mac_address (): void = {
  // xxx Need to support case of MBED_MAC_ADDRESS_SUM != MBED_MAC_ADDR_INTERFACE ?
  val (pf | p) = takeout_macaddr ()
  val () = mbed_mac_address (p)
  prval () = addback_macaddr (pf)
}

implement EthernetInterface_init () = let
  // Use DHCP
  val () = $UN.ptr0_set<bool> (use_dhcp_p (), true)
  val () = set_mac_address ()
  val () = init_netif(null_ip_addr_t_p (), null_ip_addr_t_p (), null_ip_addr_t_p ())
in
  true
end

implement EthernetInterface_connect (timeout_ms) = let
  fun connect_dhcp (): int32 = let
      val _ = dhcp_start (netif_p ())
      val (pf | p) = takeout_netif_up_id ()
      val r = osSemaphoreWait (!p, $UN.cast timeout_ms)
      prval () = addback_netif_up_id (pf)
    in
      r
    end
  fun connect_ip (): int32 = let
      val () = netif_set_up (netif_p ())
      val (pf | p) = takeout_netif_linked_id ()
      val r = osSemaphoreWait (!p, $UN.cast timeout_ms)
      prval () = addback_netif_linked_id (pf)
    in
      r
    end
  val () = eth_arch_enable_interrupts ()
  val b = $UN.ptr0_get<bool> (use_dhcp_p ())
  val inited = if b then connect_dhcp () else connect_ip ()
in
  if ($UN.cast2int(inited) > 0) then true else false
end

implement EthernetInterface_disconnect () = true where {
  fun init (dhcp: bool) = if dhcp then {
    val _ = dhcp_release (netif_p ())
    val () = dhcp_stop (netif_p ())
  } else {
    val () = netif_set_down (netif_p ())
  }
  val b = $UN.ptr0_get<bool> (use_dhcp_p ())
  val () = init (b)
  val () = eth_arch_disable_interrupts ()
}

implement EthernetInterface_getIPAddress () = ip_addr

(* xxx Need the following ?
char* EthernetInterface::getMACAddress() {
    return mac_addr;
}

char* EthernetInterface::getGateway() {
    return gateway;
}

char* EthernetInterface::getNetworkMask() {
    return networkmask;
}
*)

#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"
staload STRING = "libc/SATS/string.sats"
staload "libmbedats/SATS/rtos_rtx_cmsis_os.sats"
staload "libmbedats/SATS/net_eth_EthernetInterface.sats"
staload "libmbedats/SATS/net_lwip_lwip.sats"
staload "libmbedats/SATS/mbed_api_mbed_interface.sats"

%{^
#include "eth_arch.h"

void mbed_mac_address (char* mac) { // My own MAC address
    mac[0] = 0x00;
    mac[1] = 0x02;
    mac[2] = 0xF7;
    mac[3] = 0xF0;
    mac[4] = 0x99;
    mac[5] = 0x99;
}
%}

extern fun eth_arch_enetif_init: netif_init_fn = "mac#"
extern fun eth_arch_enable_interrupts: () -> void = "mac#"
extern fun eth_arch_disable_interrupts: () -> void = "mac#"

fun null_ip_addr_t_p () = $UN.castvwtp0{ip_addr_t_p}(the_null_ptr)

// *** Global State on C ***
%{
#define IP_ADDR_LEN  16
static char c_ip_addr[IP_ADDR_LEN + 1] = "\0";
%}
macdef ip_addr_len = $extval(int, "IP_ADDR_LEN")
macdef ip_addr = $extval(string, "c_ip_addr")

// *** Global State on ATS ***
%{
#define semaphore_member_p(SEMD)  (&(((osSemaphoreDef_t *)(SEMD))->semaphore))
%}
extern fun semaphore_member_p: (osSemaphoreDef_t_p) -> ptr = "mac#"
// state = netif
var netif: struct_netif
fun netif_p (): struct_netif_p = $UN.castvwtp0 (addr@netif)
// state = use_dhctp_{id,def}
var use_dhcp = false
fun use_dhcp_p (): ptr = $UN.castvwtp0 (addr@use_dhcp)
// state = tcpip_inited_{id,def}
var tcpip_inited_id: osSemaphoreId
fun takeout_tcpip_inited_id (): [l:agz] (osSemaphoreId @ l | ptr l) = $UN.castvwtp0 (addr@tcpip_inited_id)
extern praxi addback_tcpip_inited_id {l:agz} (pf: osSemaphoreId @ l): void
var tcpip_inited_def: osSemaphoreDef_t
fun tcpip_inited_def_p (): osSemaphoreDef_t_p = $UN.castvwtp0 (addr@tcpip_inited_def)
var tcpip_inited_data: @[uint32][2]
// state = netif_linked_{id,def}
var netif_linked_id: osSemaphoreId
fun takeout_netif_linked_id (): [l:agz] (osSemaphoreId @ l | ptr l) = $UN.castvwtp0 (addr@netif_linked_id)
extern praxi addback_netif_linked_id {l:agz} (pf: osSemaphoreId @ l): void
var netif_linked_def: osSemaphoreDef_t
fun netif_linked_def_p (): osSemaphoreDef_t_p = $UN.castvwtp0 (addr@netif_linked_def)
var netif_linked_data: @[uint32][2]
// state = netif_up_{id,def}
var netif_up_id: osSemaphoreId
fun takeout_netif_up_id (): [l:agz] (osSemaphoreId @ l | ptr l) = $UN.castvwtp0 (addr@netif_up_id)
extern praxi addback_netif_up_id {l:agz} (pf: osSemaphoreId @ l): void
var netif_up_def: osSemaphoreDef_t
fun netif_up_def_p (): osSemaphoreDef_t_p = $UN.castvwtp0 (addr@netif_up_def)
var netif_up_data: @[uint32][2]
// state = macaddr
local
  var _dat_macaddr: struct_macaddr // hide
in
  fun takeout_macaddr (): [l:agz] (struct_macaddr @ l | ptr l) = $UN.castvwtp0 (addr@_dat_macaddr)
end
extern praxi addback_macaddr {l:agz} (pf: struct_macaddr @ l): void

fun tcpip_init_done (p: ptr): void = {
  val (pf | p) = takeout_tcpip_inited_id ()
  val _ = osSemaphoreRelease (!p)
  prval () = addback_tcpip_inited_id (pf)
}

fun netif_link_callback (nif: struct_netif_p): void =
  if netif_is_link_up (nif) then {
    val (pf | p) = takeout_netif_linked_id ()
    val _ = osSemaphoreRelease (!p)
    prval () = addback_netif_linked_id (pf)
  }

fun netif_status_callback (nif: struct_netif_p): void =
  if netif_is_up (nif) then {
    (* xxx Need the following ?
      strcpy(gateway, inet_ntoa(netif->gw));
      strcpy(networkmask, inet_ntoa(netif->netmask));
     *)
    val _ = inet_ntoa_r (get_netif_ip_addr (netif_p ()), ip_addr, ip_addr_len)
    val (pf | p) = takeout_netif_up_id ()
    val _ = osSemaphoreRelease (!p)
    prval () = addback_netif_up_id (pf)
  }

fun sem_create{l:addr} (def_p: osSemaphoreDef_t_p, dat_p: ptr l, count: int): osSemaphoreId = let
  val _ = $STRING.memset_unsafe(dat_p, 0, sizeof<uint32>)
  val p = semaphore_member_p (def_p)
  val () = $UN.ptr0_set (p, dat_p)
in
  osSemaphoreCreate (def_p, $UN.cast (count))
end

fun init_netif(ipaddr: ip_addr_t_p, netmask: ip_addr_t_p, gw: ip_addr_t_p): void = {
  // Init Semaphores
  val v = sem_create (tcpip_inited_def_p (), addr@tcpip_inited_data, 0)
  val () = $UN.ptr0_set (addr@tcpip_inited_id, v)
  val v = sem_create (netif_linked_def_p (), addr@netif_linked_data, 0)
  val () = $UN.ptr0_set (addr@netif_linked_id, v)
  val v = sem_create (netif_up_def_p (), addr@netif_up_data, 0)
  val () = $UN.ptr0_set (addr@netif_up_id, v)
  // Init & wait
  val () = tcpip_init (tcpip_init_done, the_null_ptr)
  val (pf | p) = takeout_tcpip_inited_id ()
  val _ = osSemaphoreWait (!p, osWaitForever)
  prval () = addback_tcpip_inited_id (pf)
  // Init netif
  val _ = $STRING.memset_unsafe(addr@netif, 0, sizeof<struct_netif>)
  val _ = netif_add(netif_p (), ipaddr, netmask, gw, the_null_ptr, eth_arch_enetif_init, tcpip_input)
  val () = netif_set_default (netif_p ())
  val () = netif_set_link_callback (netif_p (), netif_link_callback);
  val () = netif_set_status_callback (netif_p (), netif_status_callback);
}

fun set_mac_address (): void = {
  // xxx Need to support case of MBED_MAC_ADDRESS_SUM != MBED_MAC_ADDR_INTERFACE ?
  val (pf | p) = takeout_macaddr ()
  val () = mbed_mac_address (p)
  prval () = addback_macaddr (pf)
}

implement EthernetInterface_init () = let
  // Use DHCP
  val () = $UN.ptr0_set<bool> (use_dhcp_p (), true)
  val () = set_mac_address ()
  val () = init_netif(null_ip_addr_t_p (), null_ip_addr_t_p (), null_ip_addr_t_p ())
in
  true
end

implement EthernetInterface_connect (timeout_ms) = let
  fun connect_dhcp (): int32 = let
      val _ = dhcp_start (netif_p ())
      val (pf | p) = takeout_netif_up_id ()
      val r = osSemaphoreWait (!p, $UN.cast timeout_ms)
      prval () = addback_netif_up_id (pf)
    in
      r
    end
  fun connect_ip (): int32 = let
      val () = netif_set_up (netif_p ())
      val (pf | p) = takeout_netif_linked_id ()
      val r = osSemaphoreWait (!p, $UN.cast timeout_ms)
      prval () = addback_netif_linked_id (pf)
    in
      r
    end
  val () = eth_arch_enable_interrupts ()
  val b = $UN.ptr0_get<bool> (use_dhcp_p ())
  val inited = if b then connect_dhcp () else connect_ip ()
in
  if ($UN.cast2int(inited) > 0) then true else false
end

implement EthernetInterface_disconnect () = true where {
  fun init (dhcp: bool) = if dhcp then {
    val _ = dhcp_release (netif_p ())
    val () = dhcp_stop (netif_p ())
  } else {
    val () = netif_set_down (netif_p ())
  }
  val b = $UN.ptr0_get<bool> (use_dhcp_p ())
  val () = init (b)
  val () = eth_arch_disable_interrupts ()
}

implement EthernetInterface_getIPAddress () = ip_addr

(* xxx Need the following ?
char* EthernetInterface::getMACAddress() {
    return mac_addr;
}

char* EthernetInterface::getGateway() {
    return gateway;
}

char* EthernetInterface::getNetworkMask() {
    return networkmask;
}
*)


Updating: very minorly tidying-up

Updating: very minorly tidying-up

(*
** Parsing constraints in JSON format
*)

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

#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"

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

#define
ATS_DYNLOADFLAG 0 (* no dynloading *)

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

%{^
//
#define \
JSMN_STRICT 1
//
#include "./jsmn.c"
//
%} // end of [%{^]

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

local
#include "libats-/wdblair/jsmn/DATS/jsmn.dats"
in (*nothing*) end

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

(* end of [parsing_mylib.dats] *)

(*
** Parsing constraints in JSON format
*)

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

#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"

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

#define ATS_DYNLOADFLAG 0 (* no run-time dynloading *)

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

local
in
%{
#define JSMN_STRICT 1

#include "jsmn.c"
%}
end

local
in
#include "contrib/libats-/wdblair/jsmn/DATS/jsmn.dats"
end

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

(* end of [parsing_mylib.dats] *)