Updating: working more on ATS-extsolve-z3

(*
##
## ATS-extsolve-z3:
## Solving ATS-constraints with Z3
##
*)

(* ****** ****** *)
//
#ifndef
PATSOLVE_Z3_SOLVING
#include "./myheader.hats"
#endif // end of [ifndef]
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
staload "./patsolve_z3_solving_ctx.dats"
//
(* ****** ****** *)

assume sort_vtype = Z3_sort

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

implement
sort_decref
  (ty) = () where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val () = Z3_sort_dec_ref(ctx, ty)
  prval ((*void*)) = fpf(ctx)
}

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

implement
sort_incref
  (ty) = ty2 where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val ty2 = Z3_sort_inc_ref(ctx, ty)
  prval ((*void*)) = fpf(ctx)
}

(* ****** ****** *)
//
implement
sort_int () = res where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val res = Z3_mk_int_sort (ctx)
  prval ((*void*)) = fpf (ctx)
}
//
(* ****** ****** *)
//
implement
sort_bool () = res where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val res = Z3_mk_bool_sort (ctx)
  prval ((*void*)) = fpf (ctx)
}
//
(* ****** ****** *)
//
implement
sort_real () = res where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val res = Z3_mk_real_sort (ctx)
  prval ((*void*)) = fpf (ctx)
}
//
(* ****** ****** *)
//
implement
sort_mk_type () = sort_mk_abstract("type")
implement
sort_mk_t0ype () = sort_mk_abstract("t0ype")
//
implement
sort_mk_vtype () = sort_mk_abstract("type")
implement
sort_mk_vt0ype () = sort_mk_abstract("t0ype")
//
(* ****** ****** *)
//
(*
implement
sort_mk_abstract(name) = sort_int()
*)
//
implement
sort_mk_abstract
  (name) = res where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val sym = Z3_mk_string_symbol (ctx, name)
  val res = Z3_mk_uninterpreted_sort (ctx, sym)
  prval ((*void*)) = fpf (ctx)
}
//
(* ****** ****** *)

implement
sort_error
  (s2t0) = res where
{
//
val () =
prerrln!
  ("sort_error: s2t0 = ", s2t0)
//
val () = assertloc(false)
val res = sort_error(s2t0)
//
} (* end of [sort_error] *)

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

implement
sort_make_s2rt(s2t0) = let
//
(*
val () =
println! ("sort_make: s2t0 = ", s2t0)
*)
//
in
//
case+ s2t0 of
//
| S2RTint() => sort_int()
| S2RTaddr() => sort_int()
| S2RTbool() => sort_bool()
//
| S2RTreal() => sort_real()
(*
| S2RTstring() => sort_string()
*)
//
| S2RTtype() => sort_mk_type()
| S2RTt0ype() => sort_mk_t0ype()
| S2RTvtype() => sort_mk_vtype()
| S2RTvt0ype() => sort_mk_vt0ype()
//
| _(*unrecognized*) => sort_error(s2t0)
//
end (* end of [sort_make_s2rt] *)

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

(* end of [patsolve_z3_solving_sort.dats] *)

(*
##
## ATS-extsolve-z3:
## Solving ATS-constraints with Z3
##
*)

(* ****** ****** *)
//
#ifndef
PATSOLVE_Z3_SOLVING
#include "./myheader.hats"
#endif // end of [ifndef]
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
staload "./patsolve_z3_solving_ctx.dats"
//
(* ****** ****** *)

assume sort_vtype = Z3_sort

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

implement
sort_decref
  (ty) = () where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val () = Z3_sort_dec_ref(ctx, ty)
  prval ((*void*)) = fpf(ctx)
}

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

implement
sort_incref
  (ty) = ty2 where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val ty2 = Z3_sort_inc_ref(ctx, ty)
  prval ((*void*)) = fpf(ctx)
}

(* ****** ****** *)
//
implement
sort_int () = res where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val res = Z3_mk_int_sort (ctx)
  prval ((*void*)) = fpf (ctx)
}
//
(* ****** ****** *)
//
implement
sort_bool () = res where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val res = Z3_mk_bool_sort (ctx)
  prval ((*void*)) = fpf (ctx)
}
//
(* ****** ****** *)
//
implement
sort_real () = res where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val res = Z3_mk_real_sort (ctx)
  prval ((*void*)) = fpf (ctx)
}
//
(* ****** ****** *)
//
implement
sort_mk_type () = sort_mk_abstract("type")
implement
sort_mk_t0ype () = sort_mk_abstract("t0ype")
//
implement
sort_mk_vtype () = sort_mk_abstract("type")
implement
sort_mk_vt0ype () = sort_mk_abstract("t0ype")
//
(* ****** ****** *)
//
(*
implement
sort_mk_abstract(name) = sort_int()
*)
//
implement
sort_mk_abstract
  (name) = res where
{
  val (fpf | ctx) =
    the_Z3_context_vget()
  // end of [val]
  val sym = Z3_mk_string_symbol (ctx, name)
  val res = Z3_mk_uninterpreted_sort (ctx, sym)
  prval ((*void*)) = fpf (ctx)
}
//
(* ****** ****** *)

implement
sort_error
  (s2t0) = res where
{
//
val () =
prerrln!
  ("sort_error: s2t0 = ", s2t0)
//
val () = assertloc(false)
val res = sort_error(s2t0)
//
} (* end of [sort_error] *)

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

implement
sort_make_s2rt(s2t0) = let
//
val () =
println! ("sort_make: s2t0 = ", s2t0)
//
in
//
case+ s2t0 of
//
| S2RTint() => sort_int()
| S2RTaddr() => sort_int()
| S2RTbool() => sort_bool()
//
| S2RTreal() => sort_real()
(*
| S2RTstring() => sort_string()
*)
//
| S2RTtype() => sort_mk_type()
| S2RTt0ype() => sort_mk_t0ype()
| S2RTvtype() => sort_mk_vtype()
| S2RTvt0ype() => sort_mk_vt0ype()
//
| _(*unrecognized*) => sort_error(s2t0)
//
end (* end of [sort_make_s2rt] *)

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

(* end of [patsolve_z3_solving_sort.dats] *)


Updating: very minorly tidying-up

Updating: very minorly tidying-up

(* ****** ****** *)
//
staload
"libats/ML/SATS/basis.sats"
//
staload "./../OOPLATS.sats"
//
(* ****** ****** *)

abstype symbol(t@ype)

(* ****** ****** *)
//
extern
val
symbol$print :
  symbol(cfun(class, value, void))
extern
val
symbol$fprint :
  symbol(cfun(class, FILEref, value, void))
//
(* ****** ****** *)
//
extern
fun
class_getsym{a:t@ype}(class, symbol(a)): a
//
(* ****** ****** *)

fun
evalmsg$print
  (class, value): void = let
//
val
fprint_mtd =
class_getsym (class, symbol$fprint)
//
in
  fprint_mtd (class, stdout_ref, value)
end // end of [evalmsg$print]

(* ****** ****** *)
//
extern
val
the_object_class : class
//
(* ****** ****** *)
//
(*
val () =
class_setmtd
  (the_object_class, symbol$print, evalmsg$print)
*)
//
(* ****** ****** *)
//
extern
fun tocls_int(x: int): class
extern
fun tocls_double(x: double): class
extern
fun tocls_string(x: string): class
//
symintr tocls
//
overload tocls with tocls_int
overload tocls with tocls_double
overload tocls with tocls_string
//
(* ****** ****** *)
//
fun
print_int
  (x: int): void = evalmsg$print(tocls(x), toval(x))
fun
print_double
  (x: double): void = evalmsg$print(tocls(x), toval(x))
fun
print_string
  (x: string): void = evalmsg$print(tocls(x), toval(x))
//
(* ****** ****** *)

(* end of [test02.dats] *)

(* ****** ****** *)
//
staload
"libats/ML/SATS/basis.sats"
//
staload "./../OOPLATS.sats"
//
(* ****** ****** *)

abstype symbol(t@ype)

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

extern
val
symbol$print :
  symbol(cfun(class, value, void))
extern
val
symbol$fprint :
  symbol(cfun(class, FILEref, value, void))
//
(* ****** ****** *)
//
extern
fun
class_getsym{a:t@ype}(class, symbol(a)): a
//
(* ****** ****** *)

fun
evalmsg$print
  (class, value): void = let
//
val
fprint_mtd =
class_getsym (class, symbol$fprint)
//
in
  fprint_mtd (class, stdout_ref, value)
end // end of [evalmsg$print]

(* ****** ****** *)
//
extern
val
the_object_class : class
//
(* ****** ****** *)
//
(*
val () =
class_setmtd
  (the_object_class, symbol$print, evalmsg$print)
*)
//
(* ****** ****** *)
//
extern
fun tocls_int(x: int): class
extern
fun tocls_double(x: double): class
extern
fun tocls_string(x: string): class
//
symintr tocls
//
overload tocls with tocls_int
overload tocls with tocls_double
overload tocls with tocls_string
//
(* ****** ****** *)
//
fun
print_int
  (x: int): void = evalmsg$print(tocls(x), toval(x))
fun
print_double
  (x: double): void = evalmsg$print(tocls(x), toval(x))
fun
print_string
  (x: string): void = evalmsg$print(tocls(x), toval(x))
//
(* ****** ****** *)

(* end of [test02.dats] *)


(*
##
## ATS-extsolve-z3:
## Solving ATS-constraints with Z3
##
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
#define
Z3_targetloc
"$PATSHOMERELOC/contrib/SMT/Z3"
//
#define
PATSOLVE_targetloc "./.ATS-extsolve"
//
(* ****** ****** *)

staload "{$Z3}/SATS/z3.sats"

(* ****** ****** *)
//
staload
"{$PATSOLVE}/patsolve_cnstrnt.sats"
staload
"{$PATSOLVE}/patsolve_parsing.sats"
//
(* ****** ****** *)
//
staload "./patsolve_z3_solving.sats"
//
(* ****** ****** *)
//
absview
smtenv_push_v
//
extern
fun
smtenv_push
  (env: !smtenv): (smtenv_push_v | void)
//
extern
fun
smtenv_pop
  (pf: smtenv_push_v | env: !smtenv): void
//
(* ****** ****** *)
//
extern
fun
c3nstr_solve_errmsg
  (c3t: c3nstr, unsolved: uint): int
//
implement
c3nstr_solve_errmsg
  (c3t, unsolved) = 0 where
{
//
val () = (
//
if
unsolved = 0u
then let
  val out = stderr_ref
  val loc = c3t.c3nstr_loc
in
  fprintln! (out, "Unsolved constraint @ ", loc, ":", c3t);
end // end of [then]
//
) (* end of [val] *)
//
} (* end of [c3nstr_solve_errmsg] *)
//
(* ****** ****** *)

extern
fun
c3nstr_solve_prop
(
  loc0: loc_t
, env: !smtenv, s2p: s2exp, nerr: &int >> _
) : int (*status*) // end-of-function

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

extern
fun
c3nstr_solve_itmlst
(
  loc0: loc_t, env: !smtenv
, s3is: s3itmlst, unsolved: &uint >> _, nerr: &int >> _
) : int(*status*) // end-of-function

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

extern
fun
c3nstr_solve_itmlst_cnstr
(
  loc0: loc_t, env: !smtenv
, s3is: s3itmlst, c3t: c3nstr, unsolved: &uint >> _, nerr: &int >> _
) : int(*status*) // end-of-function

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

extern fun
c3nstr_solve_itmlst_disj
(
  loc0: loc_t, env: !smtenv
, s3is: s3itmlst, s3iss: s3itmlstlst, unsolved: &uint >> _, nerr: &int >> _
) : int(*status*) // end-of-function

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

extern
fun
c3nstr_solve_main
(
  env: !smtenv, c3t: c3nstr, unsolved : &uint >> _, nerr: &int >> _
) : int(*status*) // end of [c3nstr_solve_main]

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

implement
c3nstr_solve_prop
(
  loc0, env, s2p, nerr
) = let
//
val s2p =
  formula_make_s2exp (env, s2p)
//
val ans =
  smtenv_formula_solve (env, s2p)
//
in
//
if ans then ~1(*solved*) else 0 (*unsolved*)
//
end // end of [c3nstr_solve_prop]

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

implement
c3nstr_solve_itmlst
(
  loc0, env, s3is, unsolved, nerr
) = let
//
val () =
println!
  ("c3str_solve_itmlst: s3is = ", s3is)
//
in
//
case+ s3is of
| list_nil
    ((*void*)) => ~1(*solved*)
  // end of [list_nil]
| list_cons
    (s3i, s3is) =>
  (
  case+ s3i of
  | S3ITMsvar (s2v) => let
      val () = smtenv_add_s2var (env, s2v)
    in
      c3nstr_solve_itmlst (loc0, env, s3is, unsolved, nerr)
    end // end of [S3ITMsvar]
  | S3ITMhypo (h3p) => let
      val s2p = s2exp_make_h3ypo (h3p)
      val ((*void*)) = smtenv_add_s2exp (env, s2p)
    in
      c3nstr_solve_itmlst (loc0, env, s3is, unsolved, nerr)
    end // end of [S3ITMhypo]
  | S3ITMsVar (s2V) =>
      c3nstr_solve_itmlst (loc0, env, s3is, unsolved, nerr)
  | S3ITMcnstr c3t =>
      c3nstr_solve_itmlst_cnstr (loc0, env, s3is, c3t, unsolved, nerr)
  | S3ITMcnstr_ref
      (loc1, ctr) => (
      case+ ctr of
      | Some(c3t) =>
          c3nstr_solve_itmlst_cnstr (loc1, env, s3is, c3t, unsolved, nerr)
        // end of [Some]
      | None((*void*)) => ~1(*solved*)
    ) (* end of [S3ITMcnstr] *)
  | S3ITMdisj (s3iss_disj) =>
      c3nstr_solve_itmlst_disj (loc0, env, s3is, s3iss_disj, unsolved, nerr)
    // end of [S3ITMdisj]
  ) // end of [list_cons]
//
end // end of [c3nstr_solve_itmlst]

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

implement
c3nstr_solve_itmlst_cnstr
(
  loc0, env, s3is, c3t, unsolved, nerr
) = let
  val (pf|()) = smtenv_push (env)
  val ans1 =
    c3nstr_solve_main (env, c3t, unsolved, nerr)
  // end of [val]
  val ((*void*)) = smtenv_pop (pf | env)
  val ans2 =
    c3nstr_solve_itmlst (loc0, env, s3is, unsolved, nerr)
  // end of [val]
in
  if ans1 >= 0 then 0(*unsolved*) else ans2
end // end of [c3nstr_solve_itmlst_cnstr]

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

implement
c3nstr_solve_itmlst_disj
(
  loc0, env
, s3is0, s3iss(*disj*), unsolved, nerr
) = let
(*
val () = (
  println! ("c3nstr_solve_itmlst_disj: s3iss = ...")
) (* end of [val] *)
*)
in
//
case+ s3iss of
| list_nil
    ((*void*)) => ~1 (*solved*)
  // end of [list_nil]
| list_cons
    (s3is, s3iss) => let
    val (pf|()) = smtenv_push (env)
    val s3is1 = list_append (s3is, s3is0)
    val ans = c3nstr_solve_itmlst (loc0, env, s3is1, unsolved, nerr)
    val ((*void*)) = smtenv_pop (pf | env)
  in
    c3nstr_solve_itmlst_disj (loc0, env, s3is0, s3iss, unsolved, nerr)
  end // end of [list_cons]
//
end // end of [c3nstr_solve_itmlst_disj]

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

implement
c3nstr_solve_main
(
  env, c3t, unsolved, nerr
) = let
//
val loc0 = c3t.c3nstr_loc
//
var status: int =
(
//
// ~1: solved; 0: unsolved
//
case+
c3t.c3nstr_node of
| C3NSTRprop s2p =>
    c3nstr_solve_prop(loc0, env, s2p, nerr)
  // end of [C3NSTRprop]
| C3NSTRitmlst s3is =>
    c3nstr_solve_itmlst(loc0, env, s3is, unsolved, nerr)
  // end of [C3NSTRitmlst]
//
) : int // end of [val]
//
val () = (
//
if
status >= 0
then {
  val iswarn =
    c3nstr_solve_errmsg (c3t, unsolved)
  // end of [val]
  val () = if iswarn > 0 then (status := ~1)
} // end of [then]
//
) (* end of [val] *)
//
val () =
  if status >= 0 then (unsolved := unsolved + 1u)
//
in
  status (* ~1/0: solved/unsolved *)
end // end of [c3nstr_solve_main]

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

implement
{}(*tmp*)
c3nstr_z3_solve
  (c3t0) = let
//
val env = smtenv_create()
//
var unsolved: uint = 0u and err: int = 0
val _(*ans*) = c3nstr_solve_main (env, c3t0, unsolved, err)
//
val ((*void*)) = smtenv_destroy (env)
in
//
case+ 0 of
| _ when
    unsolved = 0u => let
    val () = (
      prerrln! "typechecking is finished successfully!"
    ) (* end of [val] *)
  in
    // nothing
  end // end of [unsolved = 0]
| _ (* unsolved > 0 *) =>
  {
    val () = prerr "typechecking has failed"
    val () =
    if unsolved <= 1u then prerr ": there is one unsolved constraint"
    val () =
    if unsolved >= 2u then prerr ": there are some unsolved constraints"
    val () = (
      prerrln! ": please inspect the above reported error message(s) for information."
    ) (* end of [val] *)
  } (* end of [_ when unsolved > 0] *)
//
end // end of [c3nstr_z3_solve]

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

#define PATSOLVE_Z3_SOLVING 1

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

local
//
#include "./SOLVING/patsolve_z3_solving_sort.dats"
//
in
  // nothing
end // end of [local]

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

local
//
#include "./SOLVING/patsolve_z3_solving_form.dats"
//
in
  // nothing
end // end of [local]

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

local
//
#include "./SOLVING/patsolve_z3_solving_smtenv.dats"
//
in
  // nothing
end // end of [local]

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

(* end of [patsolve_z3_solving.dats] *)

(*
##
## ATS-extsolve-z3:
## Solving ATS-constraints with Z3
##
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
#define
PATSOLVE_targetloc "./.ATS-extsolve"
//
(* ****** ****** *)
//
staload
"{$PATSOLVE}/patsolve_cnstrnt.sats"
staload
"{$PATSOLVE}/patsolve_parsing.sats"
//
(* ****** ****** *)
//
staload "./patsolve_z3_solving.sats"
//
(* ****** ****** *)
//
absview
smtenv_push_v
//
extern
fun
smtenv_push
  (env: !smtenv): (smtenv_push_v | void)
//
extern
fun
smtenv_pop
  (pf: smtenv_push_v | env: !smtenv): void
//
(* ****** ****** *)
//
extern
fun
c3nstr_solve_errmsg
  (c3t: c3nstr, unsolved: uint): int
//
implement
c3nstr_solve_errmsg
  (c3t, unsolved) = 0 where
{
//
val () = (
//
if
unsolved = 0u
then let
  val out = stderr_ref
  val loc = c3t.c3nstr_loc
in
  fprintln! (out, "Unsolved constraint @ ", loc, ":", c3t);
end // end of [then]
//
) (* end of [val] *)
//
} (* end of [c3nstr_solve_errmsg] *)
//
(* ****** ****** *)

extern
fun
c3nstr_solve_prop
(
  loc0: loc_t
, env: !smtenv, s2p: s2exp, nerr: &int >> _
) : int (*status*) // end-of-function

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

extern
fun
c3nstr_solve_itmlst
(
  loc0: loc_t, env: !smtenv
, s3is: s3itmlst, unsolved: &uint >> _, nerr: &int >> _
) : int(*status*) // end-of-function

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

extern
fun
c3nstr_solve_itmlst_cnstr
(
  loc0: loc_t, env: !smtenv
, s3is: s3itmlst, c3t: c3nstr, unsolved: &uint >> _, nerr: &int >> _
) : int(*status*) // end-of-function

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

extern fun
c3nstr_solve_itmlst_disj
(
  loc0: loc_t, env: !smtenv
, s3is: s3itmlst, s3iss: s3itmlstlst, unsolved: &uint >> _, nerr: &int >> _
) : int(*status*) // end-of-function

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

extern
fun
c3nstr_solve_main
(
  env: !smtenv, c3t: c3nstr, unsolved : &uint >> _, nerr: &int >> _
) : int(*status*) // end of [c3nstr_solve_main]

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

implement
c3nstr_solve_prop
(
  loc0, env, s2p, nerr
) = let
//
val s2p =
  formula_make_s2exp (env, s2p)
//
val ans =
  smtenv_formula_solve (env, s2p)
//
in
//
if ans then ~1(*solved*) else 0 (*unsolved*)
//
end // end of [c3nstr_solve_prop]

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

implement
c3nstr_solve_itmlst
(
  loc0, env, s3is, unsolved, nerr
) = let
//
val () =
println!
  ("c3str_solve_itmlst: s3is = ", s3is)
//
in
//
case+ s3is of
| list_nil
    ((*void*)) => ~1(*solved*)
  // end of [list_nil]
| list_cons
    (s3i, s3is) =>
  (
  case+ s3i of
  | S3ITMsvar (s2v) => let
      val () = smtenv_add_s2var (env, s2v)
    in
      c3nstr_solve_itmlst (loc0, env, s3is, unsolved, nerr)
    end // end of [S3ITMsvar]
  | S3ITMhypo (h3p) => let
      val s2p = s2exp_make_h3ypo (h3p)
      val ((*void*)) = smtenv_add_s2exp (env, s2p)
    in
      c3nstr_solve_itmlst (loc0, env, s3is, unsolved, nerr)
    end // end of [S3ITMhypo]
  | S3ITMsVar (s2V) =>
      c3nstr_solve_itmlst (loc0, env, s3is, unsolved, nerr)
  | S3ITMcnstr c3t =>
      c3nstr_solve_itmlst_cnstr (loc0, env, s3is, c3t, unsolved, nerr)
  | S3ITMcnstr_ref
      (loc1, ctr) => (
      case+ ctr of
      | Some(c3t) =>
          c3nstr_solve_itmlst_cnstr (loc1, env, s3is, c3t, unsolved, nerr)
        // end of [Some]
      | None((*void*)) => ~1(*solved*)
    ) (* end of [S3ITMcnstr] *)
  | S3ITMdisj (s3iss_disj) =>
      c3nstr_solve_itmlst_disj (loc0, env, s3is, s3iss_disj, unsolved, nerr)
    // end of [S3ITMdisj]
  ) // end of [list_cons]
//
end // end of [c3nstr_solve_itmlst]

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

implement
c3nstr_solve_itmlst_cnstr
(
  loc0, env, s3is, c3t, unsolved, nerr
) = let
  val (pf|()) = smtenv_push (env)
  val ans1 =
    c3nstr_solve_main (env, c3t, unsolved, nerr)
  // end of [val]
  val ((*void*)) = smtenv_pop (pf | env)
  val ans2 =
    c3nstr_solve_itmlst (loc0, env, s3is, unsolved, nerr)
  // end of [val]
in
  if ans1 >= 0 then 0(*unsolved*) else ans2
end // end of [c3nstr_solve_itmlst_cnstr]

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

implement
c3nstr_solve_itmlst_disj
(
  loc0, env
, s3is0, s3iss(*disj*), unsolved, nerr
) = let
(*
val () = (
  println! ("c3nstr_solve_itmlst_disj: s3iss = ...")
) (* end of [val] *)
*)
in
//
case+ s3iss of
| list_nil
    ((*void*)) => ~1 (*solved*)
  // end of [list_nil]
| list_cons
    (s3is, s3iss) => let
    val (pf|()) = smtenv_push (env)
    val s3is1 = list_append (s3is, s3is0)
    val ans = c3nstr_solve_itmlst (loc0, env, s3is1, unsolved, nerr)
    val ((*void*)) = smtenv_pop (pf | env)
  in
    c3nstr_solve_itmlst_disj (loc0, env, s3is0, s3iss, unsolved, nerr)
  end // end of [list_cons]
//
end // end of [c3nstr_solve_itmlst_disj]

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

implement
c3nstr_solve_main
(
  env, c3t, unsolved, nerr
) = let
//
val loc0 = c3t.c3nstr_loc
//
var status: int =
(
//
// ~1: solved; 0: unsolved
//
case+
c3t.c3nstr_node of
| C3NSTRprop s2p =>
    c3nstr_solve_prop(loc0, env, s2p, nerr)
  // end of [C3NSTRprop]
| C3NSTRitmlst s3is =>
    c3nstr_solve_itmlst(loc0, env, s3is, unsolved, nerr)
  // end of [C3NSTRitmlst]
//
) : int // end of [val]
//
val () = (
//
if
status >= 0
then {
  val iswarn =
    c3nstr_solve_errmsg (c3t, unsolved)
  // end of [val]
  val () = if iswarn > 0 then (status := ~1)
} // end of [then]
//
) (* end of [val] *)
//
val () =
  if status >= 0 then (unsolved := unsolved + 1u)
//
in
  status (* ~1/0: solved/unsolved *)
end // end of [c3nstr_solve_main]

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

implement
{}(*tmp*)
c3nstr_z3_solve
  (c3t0) = let
//
val env = smtenv_create()
//
var unsolved: uint = 0u and err: int = 0
val _(*ans*) = c3nstr_solve_main (env, c3t0, unsolved, err)
//
val ((*void*)) = smtenv_destroy (env)
in
//
case+ 0 of
| _ when
    unsolved = 0u => let
    val () = (
      prerrln! "typechecking is finished successfully!"
    ) (* end of [val] *)
  in
    // nothing
  end // end of [unsolved = 0]
| _ (* unsolved > 0 *) =>
  {
    val () = prerr "typechecking has failed"
    val () =
    if unsolved <= 1u then prerr ": there is one unsolved constraint"
    val () =
    if unsolved >= 2u then prerr ": there are some unsolved constraints"
    val () = (
      prerrln! ": please inspect the above reported error message(s) for information."
    ) (* end of [val] *)
  } (* end of [_ when unsolved > 0] *)
//
end // end of [c3nstr_z3_solve]

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

#define PATSOLVE_Z3_SOLVING 1

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

local
//
#include "./SOLVING/patsolve_z3_solving_sort.dats"
//
in
  // nothing
end // end of [local]

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

local
//
#include "./SOLVING/patsolve_z3_solving_form.dats"
//
in
  // nothing
end // end of [local]

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

local
//
#include "./SOLVING/patsolve_z3_solving_smtenv.dats"
//
in
  // nothing
end // end of [local]

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

(* end of [patsolve_z3_solving.dats] *)


Add dependent types into EEPROM API

Add dependent types into EEPROM API

%{#
#include <avr/eeprom.h>
%}
fun eeprom_read_byte {n:nat} (address: int n): uint8 = "mac#"
fun eeprom_write_byte {n:nat} (address: int n, value: uint8): void = "mac#"

%{#
#include <avr/eeprom.h>
%}
fun eeprom_read_byte (address: int): uint8 = "mac#"
fun eeprom_write_byte (address: int, value: uint8): void = "mac#"


Updating: improving atscc2php

Updating: improving atscc2php

(* ****** ****** *)
//
// ATS-parse-emit-php
//
(* ****** ****** *)
//
// HX-2014-08-20: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./atsparemit.sats"
staload "./atsparemit_syntax.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_typedef.dats"
//
(* ****** ****** *)
//
extern
fun
emit_tmpdeclst_initize
(
  out: FILEref, tds: tmpdeclst
) : void // end-of-fun
//
implement
emit_tmpdeclst_initize
  (out, tds) = let
//
fun auxlst
(
  out: FILEref, tds: tmpdeclst
) : void = let
in
//
case+ tds of
| list_nil () => ()
| list_cons (td, tds) =>
  (
    case+ td.tmpdec_node of
    | TMPDECnone
        (tmp) => auxlst (out, tds)
    | TMPDECsome
        (tmp, _) => let
        val () =
        emit_nspc (out, 2(*ind*))
        val () = (
          emit_text (out, "// "); emit_tmpvar (out, tmp); emit_ENDL (out)
        ) (* end of [val] *)
      in
        auxlst (out, tds)
      end // end of [TMPDECsome]
  ) (* end of [list_cons] *)
//
end // end of [auxlist]
//
in
  auxlst (out, tds)
end // end of [emit_tmpdeclst_initize]
//
(* ****** ****** *)
//
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
//
(* ****** ****** *)
//
local
//
val the_f0arglst = ref<f0arglst> (list_nil)
val the_tmpdeclst = ref<tmpdeclst> (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

end // end of [local]

(* ****** ****** *)
//
extern
fun emit2_instr
  (out: FILEref, ind: int, ins: instr) : void
//
extern
fun emit2_instr_ln
  (out: FILEref, ind: int, ins: instr) : void
//
extern
fun emit2_instrlst
  (out: FILEref, ind: int, inss: instrlst) : void
//
(* ****** ****** *)
//
extern
fun emit2_ATSfunbodyseq
  (out: FILEref, ind: int, ins: instr) : void
//
extern
fun emit2_ATSINSmove_con1
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_ATSINSmove_boxrec
  (out: FILEref, ind: int, ins: instr) : void
//
(* ****** ****** *)
//
// HX-2014-08:
// this one should not be used for
// emitting multiple-line instructions
//
implement
emit_instr
  (out, ins) = emit2_instr (out, 0(*ind*), ins)
//
(* ****** ****** *)

implement
emit2_instr
  (out, ind, ins0) = let
in
//
case+
ins0.instr_node of
//
| ATSif
  (
    d0e, inss, inssopt
  ) => let
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if")
    val () = emit_LPAREN (out)
    val () = emit_d0exp (out, d0e)
    val () = emit_RPAREN (out)
    val () = emit_text (out, " {\n")
    val () = emit2_instrlst (out, ind+2, inss)
  in
    case+ inssopt of
    | None _ =>
      {
        val () = emit_nspc (out, ind)
        val ((*closing*)) = emit_text (out, "} // endif")
      } (* end of [None] *)
    | Some (inss) =>
      {
        val () = emit_nspc (out, ind)
        val () = emit_text (out, "} else {\n")
        val () = emit2_instrlst (out, ind+2, inss)
        val () = emit_nspc (out, ind)
        val ((*closing*)) = emit_text (out, "} // endif")
      } (* end of [Some] *)
  end // end of [ATSif]
//
| ATSifthen (d0e, inss) =>
  {
//
    val-list_cons (ins, _) = inss
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if(")
    val () = emit_d0exp (out, d0e)
    val () = emit_text (out, ") ")
    val () = emit_instr (out, ins)
  }
//
| ATSifnthen (d0e, inss) =>
  {
//
    val-list_cons (ins, _) = inss
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if(!")
    val () = emit_d0exp (out, d0e)
    val ((*closing*)) = emit_text (out, ") ")
    val () = emit_instr (out, ins)
  }
//
| ATSbranchseq (inss) =>
  {
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATSbranchseq_beg")
//
    val () = emit_ENDL (out)
    val () = emit2_instrlst (out, ind, inss)
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "break;\n")
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATSbranchseq_end")
//
  } (* end of [ATSbranchseq] *)
//
| ATScaseofseq (inss) =>
  {
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATScaseofseq_beg")
    val () = emit_ENDL (out)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "do {\n")
//
    val () = emit2_instrlst (out, ind+2, inss)
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "} while(0);\n")
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATScaseofseq_end")
//
  } (* end of [ATScaseofseq] *)
//
| ATSreturn (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      emit_text (out, "return "); emit_tmpvar (out, tmp)
    ) (* end of [val] *)
    val () = emit_SEMICOLON (out)
  }
| ATSreturn_void (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "return/*_void*/")
    val () = emit_SEMICOLON (out)
  }
//
| ATSINSlab (lab) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      emit_label (out, lab); emit_COLON (out)
    ) (* end of [val] *)
  } (* end of [ATSINSlab] *)
//
| ATSINSgoto (lab) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      emit_text (out, "goto "); emit_label (out, lab)
    ) (* end of [val] *)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSgoto] *)
//
| ATSINSflab (flab) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      emit_label (out, flab); emit_COLON (out)
    ) (* end of [val] *)
  } (* end of [ATSINSflab] *)
//
| ATSINSfgoto (flab) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      emit_text (out, "goto "); emit_label (out, flab)
    ) (* end of [val] *)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSfgoto] *)
//
| ATSINSmove (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSmove] *)
//
| ATSINSmove_void (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      case+ d0e.d0exp_node of
      | ATSempty _ =>
          emit_text (out, "// ATSINSmove_void")
        // end of [ATSempty]
      | _ (*non-ATSempty*) => emit_d0exp (out, d0e)
    ) : void // end of [val]
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSmove_void] *)
//
| ATSINSmove_nil (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_text (out, "null")
    val () = emit_SEMICOLON (out)
  }
| ATSINSmove_con0 (tmp, tag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_PMVint (out, tag)
    val () = emit_SEMICOLON (out)
  }
//
| ATSINSmove_con1 _ =>
    emit2_ATSINSmove_con1 (out, ind, ins0)
| ATSINSmove_boxrec _ =>
    emit2_ATSINSmove_boxrec (out, ind, ins0)
//
| ATStailcalseq (inss) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATStailcalseq_beg")
    val () = emit_ENDL (out)
    val () = emit2_instrlst (out, ind, inss)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATStailcalseq_end")
  } (* end of [ATStailcalseq] *)
//
| ATSINSmove_tlcal (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSmove_tlcal] *)
//
| ATSINSargmove_tlcal (tmp1, tmp2) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp1)
    val () = emit_text (out, " = ")
    val () = emit_tmpvar (out, tmp2)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSargmove_tlcal] *)
//
| ATSdynload (dummy) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATSdynload()")
  }
//
| ATSdynload0 (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "var\n")
    val () =
    (
      emit_tmpvar (out, flag); emit_text (out, " = 0 ;")
    )
  }
| ATSdynload1 (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATSdynload1(...)")
  }
| ATSdynloadset (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () =
    (
      emit_tmpvar (out, flag); emit_text (out, " = 1 ; // flag is set")
    )
  }
//
| _ (*rest-of-instr*) =>
  {
    val () = emit_nspc (out, ind)
    val ((*error*)) = fprint! (out, "UNRECOGNIZED-INSTRUCTION: ", ins0)
  }
//
end // end of [emit2_instr]

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

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

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

implement
emit2_instrlst
(
  out, ind, inss
) = (
//
case+ inss of
| list_nil () => ()
| list_cons (ins, inss) =>
  {
    val () = emit2_instr_ln (out, ind, ins)
    val () = emit2_instrlst (out, ind, inss)
  }
//
) (* end of [emit2_instrlst] *)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

implement
emit_f0body
  (out, fbody) = let
//
val tmpdecs =
  f0body_get_tmpdeclst (fbody)
val inss_body =
  f0body_get_bdinstrlst (fbody)
//
val () = the_tmpdeclst_set (tmpdecs)
//
val () = emit_text (out, "{\n")
//
val () = emit_text (out, "/*\n")
//
val () =
  emit_tmpdeclst_initize (out, tmpdecs)
//
val () = emit_text (out, "*/\n")
//
val ((*main*)) = emit_f0body_0 (out, fbody)
//
val ((*closing*)) =
  emit_text (out, "} // end-of-function\n")
//
in
  // nothing
end (* end of [emit_f0body] *)

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

implement
emit_f0body_0
  (out, fbody) = let
//
fun
auxlst
(
  out: FILEref, inss: instrlst, i: int
) : void =
(
case+ inss of
//
| list_nil () => ()
//
| list_cons
    (ins0, inss1) => let
    val-list_cons(ins1, inss2) = inss1
    val () = if i > 0 then emit_text (out, "//\n")
    val () = emit2_ATSfunbodyseq (out, 2(*ind*), ins0)
    val ((*return*)) = emit2_instr_ln (out, 2(*ind*), ins1)
  in
    auxlst (out, inss2, i+1)
  end // end of [list_cons]
//
) (* end of [auxlst] *)
//
in
//
case+
fbody.f0body_node of
//
| F0BODY (tds, inss) =>
  {
    val () = auxlst (out, inss, 0(*i*))
  }
//
end // end of [emit_f0body_0]

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

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

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

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

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

(* end of [atsparemit_emit2_php.dats] *)

(* ****** ****** *)
//
// ATS-parse-emit-php
//
(* ****** ****** *)
//
// HX-2014-08-20: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./atsparemit.sats"
staload "./atsparemit_syntax.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_typedef.dats"
//
(* ****** ****** *)
//
extern
fun
emit_tmpdeclst_initize
  (out: FILEref, tds: tmpdeclst): void
//
implement
emit_tmpdeclst_initize
  (out, tds) = let
//
fun auxlst
(
  out: FILEref, tds: tmpdeclst
) : void = let
in
//
case+ tds of
| list_nil () => ()
| list_cons (td, tds) =>
  (
    case+ td.tmpdec_node of
    | TMPDECnone
        (tmp) => auxlst (out, tds)
    | TMPDECsome
        (tmp, _) => let
        val () =
        emit_nspc (out, 2(*ind*))
        val () = emit_ENDL (out)
        val () = (
          emit_text (out, "// "); emit_tmpvar (out, tmp);
        ) (* end of [val] *)
      in
        auxlst (out, tds)
      end // end of [TMPDECsome]
  ) (* end of [list_cons] *)
//
end // end of [auxlist]
//
in
  auxlst (out, tds)
end // end of [emit_tmpdeclst_initize]
//
(* ****** ****** *)
//
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
//
(* ****** ****** *)
//
local
//
val the_f0arglst = ref<f0arglst> (list_nil)
val the_tmpdeclst = ref<tmpdeclst> (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

end // end of [local]

(* ****** ****** *)
//
extern
fun emit2_instr
  (out: FILEref, ind: int, ins: instr) : void
//
extern
fun emit2_instrlst
  (out: FILEref, ind: int, inss: instrlst) : void
//
(* ****** ****** *)
//
extern
fun emit2_ATSfunbodyseq
  (out: FILEref, ind: int, ins: instr) : void
//
extern
fun emit2_ATSINSmove_con1
  (out: FILEref, ind: int, ins: instr) : void
extern
fun emit2_ATSINSmove_boxrec
  (out: FILEref, ind: int, ins: instr) : void
//
(* ****** ****** *)
//
// HX-2014-08:
// this one should not be used for
// emitting multiple-line instructions
//
implement
emit_instr
  (out, ins) = emit2_instr (out, 0(*ind*), ins)
//
(* ****** ****** *)

implement
emit2_instr
  (out, ind, ins0) = let
in
//
case+
ins0.instr_node of
//
| ATSif
  (
    d0e, inss, inssopt
  ) => let
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if ")
    val () = emit_LPAREN (out)
    val () = emit_d0exp (out, d0e)
    val () = emit_RPAREN (out)
    val () = emit_text (out, " {")
    val () = emit2_instrlst (out, ind+2, inss)
  in
    case+ inssopt of
    | None _ =>
      {
        val () = emit_ENDL (out)
        val () = emit_nspc (out, ind)
        val ((*closing*)) = emit_text (out, "} // endif")
      } (* end of [None] *)
    | Some (inss) =>
      {
        val () = emit_ENDL (out)
        val () = emit_nspc (out, ind)
        val () = emit_text (out, "} else {")
        val () = emit2_instrlst (out, ind+2, inss)
        val () = emit_ENDL (out)
        val () = emit_nspc (out, ind)
        val ((*closing*)) = emit_text (out, "} // endif")
      } (* end of [Some] *)
  end // end of [ATSif]
//
| ATSifthen (d0e, inss) =>
  {
//
    val-list_cons (ins, _) = inss
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if(")
    val () = emit_d0exp (out, d0e)
    val () = emit_text (out, ") ")
    val () = emit_instr (out, ins)
  }
//
| ATSifnthen (d0e, inss) =>
  {
//
    val-list_cons (ins, _) = inss
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "if(!")
    val () = emit_d0exp (out, d0e)
    val ((*closing*)) = emit_text (out, ") ")
    val () = emit_instr (out, ins)
  }
//
| ATSbranchseq (inss) =>
  {
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATSbranchseq_beg")
//
    val () = emit2_instrlst (out, ind, inss)
//
    val () = emit_ENDL (out)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "break;")
    val () = emit_ENDL (out)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATSbranchseq_end")
//
  } (* end of [ATSbranchseq] *)
//
| ATScaseofseq (inss) =>
  {
//
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATScaseofseq_beg")
    val () = emit_ENDL (out)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "do {")
//
    val () = emit2_instrlst (out, ind+2, inss)
//
    val () = emit_ENDL (out)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "} while(0) ;")
    val () = emit_ENDL (out)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATScaseofseq_end")
//
  } (* end of [ATScaseofseq] *)
//
| ATSreturn (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "return ")
    val () = emit_tmpvar (out, tmp)
    val () = emit_SEMICOLON (out)
  }
| ATSreturn_void (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "return/*_void*/")
    val () = emit_SEMICOLON (out)
  }
//
| ATSINSlab (lab) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      emit_label (out, lab); emit_COLON (out)
    ) (* end of [val] *)
  } (* end of [ATSINSlab] *)
//
| ATSINSgoto (lab) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      emit_text (out, "goto "); emit_label (out, lab)
    ) (* end of [val] *)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSgoto] *)
//
| ATSINSflab (flab) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      emit_label (out, flab); emit_COLON (out)
    ) (* end of [val] *)
  } (* end of [ATSINSflab] *)
//
| ATSINSfgoto (flab) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      emit_text (out, "goto "); emit_label (out, flab)
    ) (* end of [val] *)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSfgoto] *)
//
| ATSINSmove (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSmove] *)
//
| ATSINSmove_void (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = (
      case+ d0e.d0exp_node of
      | ATSempty _ =>
          emit_text (out, "// ATSINSmove_void")
        // end of [ATSempty]
      | _ (*non-ATSempty*) => emit_d0exp (out, d0e)
    ) : void // end of [val]
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSmove_void] *)
//
| ATSINSmove_nil (tmp) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_text (out, "null")
    val () = emit_SEMICOLON (out)
  }
| ATSINSmove_con0 (tmp, tag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_PMVint (out, tag)
    val () = emit_SEMICOLON (out)
  }
//
| ATSINSmove_con1 _ =>
    emit2_ATSINSmove_con1 (out, ind, ins0)
| ATSINSmove_boxrec _ =>
    emit2_ATSINSmove_boxrec (out, ind, ins0)
//
| ATStailcalseq (inss) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATStailcalseq_beg")
    val () = emit2_instrlst (out, ind, inss)
    val () = emit_ENDL (out)
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATStailcalseq_end")
  } (* end of [ATStailcalseq] *)
//
| ATSINSmove_tlcal (tmp, d0e) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp)
    val () = emit_text (out, " = ")
    val () = emit_d0exp (out, d0e)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSmove_tlcal] *)
//
| ATSINSargmove_tlcal (tmp1, tmp2) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_tmpvar (out, tmp1)
    val () = emit_text (out, " = ")
    val () = emit_tmpvar (out, tmp2)
    val () = emit_SEMICOLON (out)
  } (* end of [ATSINSargmove_tlcal] *)
//
| ATSdynload (dummy) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATSdynload()")
  }
//
| ATSdynload0 (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "var\n")
    val () =
    (
      emit_tmpvar (out, flag); emit_text (out, " = 0 ;")
    )
  }
| ATSdynload1 (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () = emit_text (out, "// ATSdynload1(...)")
  }
| ATSdynloadset (flag) =>
  {
    val () = emit_nspc (out, ind)
    val () =
    (
      emit_tmpvar (out, flag); emit_text (out, " = 1 ; // flag is set")
    )
  }
//
| _ (*rest-of-instr*) =>
  {
    val () = emit_nspc (out, ind)
    val ((*error*)) = fprint! (out, "UNRECOGNIZED-INSTRUCTION: ", ins0)
  }
//
end // end of [emit2_instr]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

implement
emit_f0body
  (out, fbody) = let
//
val tmpdecs =
  f0body_get_tmpdeclst (fbody)
val inss_body =
  f0body_get_bdinstrlst (fbody)
//
val () = the_tmpdeclst_set (tmpdecs)
//
val () = emit_text (out, "{")
//
val () = emit_text (out, "\n/*")
//
val () =
  emit_tmpdeclst_initize (out, tmpdecs)
//
val () = emit_text (out, "\n*/")
//
val ((*main*)) = emit_f0body_0 (out, fbody)
//
val () = emit_text (out, "\n} // end-of-function\n")
//
in
  // nothing
end (* end of [emit_f0body] *)

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

implement
emit_f0body_0
  (out, fbody) = let
//
fun
auxlst
(
  out: FILEref, inss: instrlst, i: int
) : void =
(
case+ inss of
| list_nil () => ()
| list_cons
    (ins0, inss1) => let
    val-list_cons (ins1, inss2) = inss1
    val () = if i > 0 then emit_ENDL (out)
    val () = emit2_ATSfunbodyseq (out, 2(*ind*), ins0)
    val ((*newline*)) = emit_ENDL (out)
    val ((*ATSreturn*)) = emit2_instr (out, 2(*ind*), ins1)
  in
    auxlst (out, inss2, i+1)
  end // end of [list_cons]
//
) (* end of [auxlst] *)
//
in
//
case+
fbody.f0body_node of
//
| F0BODY (tds, inss) =>
  {
    val () = auxlst (out, inss, 0(*i*))
  }
//
end // end of [emit_f0body_0]

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

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

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

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

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

(* end of [atsparemit_emit2_php.dats] *)


Better code format

Better code format

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

staload "{$TOP}/SATS/arduino.sats"
staload "{$TOP}/SATS/lcd.sats"

#define MY_DELAY_MS 400.0
#define LCD_WIDTH 16

val g_str_atsrun = "<ATS running!>"
val g_str_message = "                 ATS is a statically typed programming language that unifies implementation with formal specification. It is equipped with a highly expressive type system rooted in the framework Applied Type System, which gives the language its name. In particular, both dependent types and linear types are available in ATS.                 "

implement main0 () = {
  fun loop {n:int}{i:nat | i < n}
           (lcd: !LCD, str: string (n), pos: size_t (i)): void = {
    val () = lcd_setCursor (lcd, 1, 0)
    val () = lcd_print (lcd, g_str_atsrun, i2sz 0, length g_str_atsrun)
    val () = lcd_setCursor (lcd, 0, 1)
    val () = lcd_print (lcd, str, pos, i2sz LCD_WIDTH)
    val () = _delay_ms (MY_DELAY_MS)
    val () = if pos + LCD_WIDTH < length str
             then loop (lcd, str, pos + 1)
  }
  fun forever {n:int}{i:nat | i < n}
              (lcd: !LCD, str: string (n), pos: size_t (i)): void = {
    val () = loop (lcd, str, pos)
    val () = forever (lcd, str, pos)
  }
  val lcd = lcd_open (8, 13, 9, 4, 5, 6, 7)
  val () = forever (lcd, g_str_message, i2sz 0)
  val () = lcd_close lcd
}

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

staload "{$TOP}/SATS/arduino.sats"
staload "{$TOP}/SATS/lcd.sats"

#define MY_DELAY_MS 400.0
#define LCD_WIDTH 16

val g_string = "                 ATS is a statically typed programming language that unifies implementation with formal specification. It is equipped with a highly expressive type system rooted in the framework Applied Type System, which gives the language its name. In particular, both dependent types and linear types are available in ATS.                 "

implement main0 () = {
  fun loop {n:int}{i:nat | i < n}
           (lcd: !LCD, str: string (n), pos: size_t (i)): void = {
    val () = lcd_setCursor (lcd, 1, 0)
    val () = lcd_print (lcd, "<ATS running!>", i2sz 0, length "<ATS running!>")
    val () = lcd_setCursor (lcd, 0, 1)
    val () = lcd_print (lcd, str, pos, i2sz LCD_WIDTH)
    val () = _delay_ms (MY_DELAY_MS)
    val () = if pos + LCD_WIDTH < length str then loop (lcd, str, pos + 1)
  }
  fun forever {n:int}{i:nat | i < n}
           (lcd: !LCD, str: string (n), pos: size_t (i)): void = {
    val () = loop (lcd, str, pos)
    val () = forever (lcd, str, pos)
  }
  val lcd = lcd_open (8, 13, 9, 4, 5, 6, 7)
  val () = forever (lcd, g_string, i2sz 0)
  val () = lcd_close lcd
}


Updating: minorly improving

Updating: minorly improving

//
// Animating Quicksort
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
staload "libats/ML/SATS/basis.sats"
staload "libats/ML/SATS/list0.sats"
staload "libats/ML/SATS/array0.sats"
//
staload _ = "libats/ML/DATS/list0.dats"
staload _ = "libats/ML/DATS/array0.dats"
//
(* ****** ****** *)
//
staload "libats/SATS/hashfun.sats"
staload "libats/SATS/hashtbl_chain.sats"
//
staload _ = "libats/DATS/hashfun.dats"
staload _ = "libats/DATS/hashtbl_chain.dats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/testing/SATS/randgen.sats"
staload _ =
"{$LIBATSHWXI}/testing/DATS/randgen.dats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/teaching/BUCS/DATS/BUCS.dats"
//
(* ****** ****** *)

#define MYMAX 100

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

typedef int2 = (int, int)

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

local

val theExchlst =
  ref<List0(int2)> (list_nil)

in (* in-of-local *)

fun theExchlst_add
  (i1: int, i2: int): void =
(
  !theExchlst := cons ((i1, i2), !theExchlst)
)
fun
theExchlst_get_all
(
// argumentlst
) : List0(int2) = let
  val xys = !theExchlst
  val ((*void*)) = !theExchlst := nil ()
in
  list_vt2t (list_reverse (xys))
end // end of [theExchlst_get_all]

end // end of [local]

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

extern
fun{
a:t@ype
} array0_swap
  (A: array0 (a), i: size_t, j: size_t): void
// end of [array0_swap]

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

implement
{a}(*tmp*)
array0_swap
  (A, i, j) =
{
  val tmp = A[i]
  val () = A[i] := A[j]
  val () = A[j] := tmp
  val () = theExchlst_add (sz2i(i), sz2i(j))
}

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

extern
fun{
a:t@ype
} quicksort (A: array0 (a)): void

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

extern
fun{
a:t@ype
} quicksort2
(
  A: array0 (a), st: size_t, len: size_t
) : void // end of [quicksort2]

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

extern
fun{a:t@ype}
qsort_partition
(
  A: array0 (a), st: size_t, len: size_t
) : size_t // end of [qsort_partition]

(* ****** ****** *)
//
implement
{a}(*tmp*)
quicksort (A) =
  quicksort2 (A, i2sz(0), A.size)
//
(* ****** ****** *)

implement
{a}(*tmp*)
quicksort2 (A, st, len) =
(
if
len >= 2
then let
  val len_f = qsort_partition<a> (A, st, len)
  val ((*void*)) = quicksort2<a> (A, st, len_f)
  val len_r = len - len_f
  val ((*void*)) = quicksort2<a> (A, succ(st+len_f), pred(len_r))
in
  // nothing
end // end of [then]
else () // end of [else]
//
) (* end of [qsort] *)

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

implement
{a}(*tmp*)
qsort_partition
  (A, st, len) = let
//
val len = g1ofg0 (len)
val () = assertloc (len > 0)
val last = pred (st + len)
val pind = st + i2sz(randint(sz2i(len)))
val () = array0_swap (A, pind, last)
val pivot = A[last]
//
fun loop
(
  k1: size_t, k2: size_t
) : size_t =
  if k2 < last then let
    val sgn = gcompare_val<a> (pivot, A[k2])
  in
    if sgn <= 0
      then loop (k1, succ(k2))
      else (array0_swap(A, k1, k2); loop (succ(k1), succ(k2)))
    // end of [if]
  end else k1 // end of [loop]
//
val k1 = loop (st, st)
val () = array0_swap (A, k1, last)
//
in
  (k1 - st)
end // end of [qort_partition]

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

local

implement
randgen_val<int> () = randint (MYMAX)

in (* in-of-local *)

fun
genScript{n:int}
(
  out: FILEref, asz: size_t(n)
) :
(
  array0 (int), List0(int2)
) = let
//
val A =
randgen_arrayref<int> (asz)
//
val A = array0 (A, asz)
val A2 = array0_copy (A)
//
val () = quicksort (A2)
//
(*
val () = fprint (out, A, asz)
val () = fprint_newline (out)
val () = fprint (out, A2, asz)
val () = fprint_newline (out)
*)
//
in
  (A, theExchlst_get_all ())
end (* end of [genScript] *)

end // end of [local]

(* ****** ****** *)
//
staload "{$CAIRO}/SATS/cairo.sats"
//
staload "{$LIBATSHWXI}/teaching/mydraw/SATS/mydraw.sats"
staload "{$LIBATSHWXI}/teaching/mydraw/SATS/mydraw_cairo.sats"
//
staload "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw_bargraph.dats"
//
staload _(*anon*) = "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw.dats"
staload _(*anon*) = "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw_cairo.dats"
//
(* ****** ****** *)
//
staload "{$LIBATSHWXI}/teaching/myGTK/SATS/gtkcairotimer.sats"
staload "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_toplevel.dats"
//
staload CP = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/ControlPanel.dats"
staload DP = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/DrawingPanel.dats"
staload MAIN = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_main.dats"
staload TIMER = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_timer.dats"
//
(* ****** ****** *)

dynload "./gtkcairotimer_toplevel.dats"

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

local
//
val () = srandom_with_time ()
//
val xy0 = ref<int2> ((~1, 0))
//
val (A0, xys0) =
  genScript (stdout_ref, i2sz(96))
//
val theExchlst2 = ref<List0(int2)> (xys0)
//
in (* in-of-local *)

val ASZ = array0_copy (A0)

extern
fun
ASZ_reset (): void
implement
ASZ_reset () = {
//
val () = srandom_with_time ()
//
var i: size_t
val () = !xy0 := ((~1, 0))
val () = for (i := i2sz(0); i < A0.size; i := succ(i)) ASZ[i] := A0[i]
val () = !theExchlst2 := xys0
//
} (* end of [ASZ_reset] *)

extern
fun
ASZ_update (): void
implement
ASZ_update () = let
//
  val ij = !xy0
  val xys = !theExchlst2
//
  val () = (
    case+ xys of
    | nil () => !xy0 := ((~1, 0))
    | cons (xy, xys) => (!xy0 := xy; !theExchlst2 := xys)
  ) (* end of [val] *)
//
  val i = ij.0 and j = ij.1
//
in
  if i >= 0 then array0_interchange (ASZ, g0i2u(i), g0i2u(j))
end (* end of [ASZ_update] *)

end // end of [local]

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

implement
the_timer_reset_after<> () = ASZ_reset ()

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

extern
fun
cairo_draw_array0
(
  cr: !cairo_ref1
, point, point, point, point, array0(int)
) : void // end-of-fun

(* ****** ****** *)
//
extern
fun
colorgen (x: int): color
//
implement
colorgen (x) = let
//
  val x = $UN.cast{uint32}(x)
  val hval = $extfcall (uint32, "atslib_inthash_jenkins", x)
  val hval = $UN.cast{uint}(hval)
//
  val r = $UN.cast{int}(hval mod 256u)
  val hval = hval / 256u
  val g = $UN.cast{int}(hval mod 256u)
  val hval = hval / 256u
  val b = $UN.cast{int}(hval mod 256u)
//
in
  color_make (r/256.0, g/256.0, b/256.0)
end // end of [colorgen]
//
(* ****** ****** *)

implement
cairo_draw_array0
(
  cr, p1, p2, p3, p4, ASZ
) = let
//
val p_cr = ptrcast (cr)
//
implement
mydraw_get0_cairo<> () = let
//
extern
castfn __cast {l:addr} (ptr(l)): vttakeout (void, cairo_ref(l))
//
in
  __cast (p_cr)
end // end of [mydraw_get0_cairo]
//
implement
mydraw_bargraph$color<> (i) = colorgen (ASZ[i])

implement
mydraw_bargraph$height<> (i) = 1.0 * (ASZ[i]+1) / MYMAX
//
val asz = ASZ.size
val asz = sz2i (asz)
val asz = ckastloc_gintGt (asz, 0)
//
in
  mydraw_bargraph (asz, p1, p2, p3, p4)
end // end of [cairo_draw_array0]

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

extern
fun
mydraw_clock
  (cr: !cairo_ref1, width: int, height: int) : void
// end of [mydraw_clock]

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

implement
mydraw_clock
  (cr, W, H) = let
//
val W =
g0int2float_int_double(W)
and H =
g0int2float_int_double(H)
//
val WH = min (W, H)
//
val xm = (W - WH) / 2
val ym = (H - WH) / 2
//
val v0 = vector_make (xm, ym)
//
val p1 = point_make (0. , WH) + v0
val p2 = point_make (WH , WH) + v0
val p3 = point_make (WH , 0.) + v0
val p4 = point_make (0. , 0.) + v0
//
val () =
if the_timer_is_running () then ASZ_update ()
//
val (pf | ()) = cairo_save (cr)
val () = cairo_draw_array0 (cr, p1, p2, p3, p4, ASZ)
val ((*void*)) = cairo_restore (pf | cr)
//
in
  // nothing
end // [mydraw_clock]

(* ****** ****** *)
//
%{^
typedef char **charptrptr ;
%} ;
abstype charptrptr = $extype"charptrptr"
//
(* ****** ****** *)

implement
main0{n}
(
  argc, argv
) = let
//
var argc: int = argc
var argv: charptrptr = $UN.castvwtp1{charptrptr}(argv)
//
val () = $extfcall (void, "gtk_init", addr@(argc), addr@(argv))
//
implement
gtkcairotimer_title<> () = stropt_some"InsertionSort"
implement
gtkcairotimer_timeout_interval<> () = 100U // millisecs
implement
gtkcairotimer_mydraw<> (cr, width, height) = mydraw_clock (cr, width, height)
//
val ((*void*)) = gtkcairotimer_main ((*void*))
//
in
  // nothing
end // end of [main0]

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

(* end of [insertsort_anim2.dats] *)

//
// Animating Quicksort
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
staload "libats/ML/SATS/basis.sats"
staload "libats/ML/SATS/list0.sats"
staload "libats/ML/SATS/array0.sats"
//
staload _ = "libats/ML/DATS/list0.dats"
staload _ = "libats/ML/DATS/array0.dats"
//
(* ****** ****** *)
//
staload "libats/SATS/hashfun.sats"
staload "libats/SATS/hashtbl_chain.sats"
//
staload _ = "libats/DATS/hashfun.dats"
staload _ = "libats/DATS/hashtbl_chain.dats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/testing/SATS/randgen.sats"
staload _ =
"{$LIBATSHWXI}/testing/DATS/randgen.dats"
//
(* ****** ****** *)
//
staload
"{$LIBATSHWXI}/teaching/BUCS/DATS/BUCS.dats"
//
(* ****** ****** *)

#define MYMAX 100

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

typedef int2 = (int, int)

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

local

val theExchlst =
  ref<List0(int2)> (list_nil)

in (* in-of-local *)

fun theExchlst_add
  (i1: int, i2: int): void =
(
  !theExchlst := cons ((i1, i2), !theExchlst)
)
fun
theExchlst_get_all
(
// argumentlst
) : List0(int2) = let
  val xys = !theExchlst
  val ((*void*)) = !theExchlst := nil ()
in
  list_vt2t (list_reverse (xys))
end // end of [theExchlst_get_all]

end // end of [local]

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

extern
fun{
a:t@ype
} array0_swap
  (A: array0 (a), i: size_t, j: size_t): void
// end of [array0_swap]

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

implement
{a}(*tmp*)
array0_swap
  (A, i, j) =
{
  val tmp = A[i]
  val () = A[i] := A[j]
  val () = A[j] := tmp
  val () = theExchlst_add (sz2i(i), sz2i(j))
}

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

extern
fun{
a:t@ype
} quicksort (A: array0 (a)): void

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

extern
fun{
a:t@ype
} quicksort2
(
  A: array0 (a), st: size_t, len: size_t
) : void // end of [quicksort2]

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

extern
fun{a:t@ype}
qsort_partition
(
  A: array0 (a), st: size_t, len: size_t
) : size_t // end of [qsort_partition]

(* ****** ****** *)
//
implement
{a}(*tmp*)
quicksort (A) =
  quicksort2 (A, i2sz(0), A.size)
//
(* ****** ****** *)

implement
{a}(*tmp*)
quicksort2 (A, st, len) =
(
if
len >= 2
then let
  val len_f = qsort_partition<a> (A, st, len)
  val ((*void*)) = quicksort2<a> (A, st, len_f)
  val len_r = len - len_f
  val ((*void*)) = quicksort2<a> (A, succ(st+len_f), pred(len_r))
in
  // nothing
end // end of [then]
else () // end of [else]
//
) (* end of [qsort] *)

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

implement
{a}(*tmp*)
qsort_partition
  (A, st, len) = let
//
val last = pred(st+len)
val pivot = A[last] // need randomness?
//
fun loop
(
  k1: size_t, k2: size_t
) : size_t =
  if k2 < last then let
    val sgn = gcompare_val<a> (pivot, A[k2])
  in
    if sgn <= 0
      then loop (k1, succ(k2))
      else (array0_swap(A, k1, k2); loop (succ(k1), succ(k2)))
    // end of [if]
  end else k1 // end of [loop]
//
val k1 = loop (st, st)
val () = array0_swap (A, k1, last)
//
in
  (k1 - st)
end // end of [qort_partition]

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

local

implement
randgen_val<int> () = randint (MYMAX)

in (* in-of-local *)

fun
genScript{n:int}
(
  out: FILEref, asz: size_t(n)
) :
(
  array0 (int), List0(int2)
) = let
//
val A =
randgen_arrayref<int> (asz)
//
val A = array0 (A, asz)
val A2 = array0_copy (A)
//
val () = quicksort (A2)
//
(*
val () = fprint (out, A, asz)
val () = fprint_newline (out)
val () = fprint (out, A2, asz)
val () = fprint_newline (out)
*)
//
in
  (A, theExchlst_get_all ())
end (* end of [genScript] *)

end // end of [local]

(* ****** ****** *)
//
staload "{$CAIRO}/SATS/cairo.sats"
//
staload "{$LIBATSHWXI}/teaching/mydraw/SATS/mydraw.sats"
staload "{$LIBATSHWXI}/teaching/mydraw/SATS/mydraw_cairo.sats"
//
staload "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw_bargraph.dats"
//
staload _(*anon*) = "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw.dats"
staload _(*anon*) = "{$LIBATSHWXI}/teaching/mydraw/DATS/mydraw_cairo.dats"
//
(* ****** ****** *)
//
staload "{$LIBATSHWXI}/teaching/myGTK/SATS/gtkcairotimer.sats"
staload "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_toplevel.dats"
//
staload CP = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/ControlPanel.dats"
staload DP = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/DrawingPanel.dats"
staload MAIN = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_main.dats"
staload TIMER = "{$LIBATSHWXI}/teaching/myGTK/DATS/gtkcairotimer/gtkcairotimer_timer.dats"
//
(* ****** ****** *)

dynload "./gtkcairotimer_toplevel.dats"

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

local
//
val xy0 = ref<int2> ((0, 0))
//
val ((*void*)) = srandom_with_time ()
//
val (A0, xys0) =
  genScript (stdout_ref, i2sz(64))
//
val theExchlst2 = ref<List0(int2)> (xys0)
//
in (* in-of-local *)

val ASZ = array0_copy (A0)

extern
fun
ASZ_reset (): void
implement
ASZ_reset () = {
//
var i: size_t
val () = !xy0 := ((0, 0))
val () = for (i := i2sz(0); i < A0.size; i := succ(i)) ASZ[i] := A0[i]
val () = !theExchlst2 := xys0
//
} (* end of [ASZ_reset] *)

extern
fun
ASZ_update (): void
implement
ASZ_update () = let
//
  val ij = !xy0
  val xys = !theExchlst2
//
  val () = (
    case+ xys of
    | nil () => !xy0 := ((0, 0))
    | cons (xy, xys) => (!xy0 := xy; !theExchlst2 := xys)
  ) (* end of [val] *)
//
  val i = ij.0 and j = ij.1
//
in
  if i >= 0 then array0_interchange (ASZ, g0i2u(i), g0i2u(j))
end (* end of [ASZ_update] *)

end // end of [local]

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

implement
the_timer_reset_after<> () = ASZ_reset ()

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

extern
fun
cairo_draw_array0
(
  cr: !cairo_ref1
, point, point, point, point, array0(int)
) : void // end-of-fun

(* ****** ****** *)
//
extern
fun
colorgen (x: int): color
//
implement
colorgen (x) = let
//
  val x = $UN.cast{uint32}(x)
  val hval = $extfcall (uint32, "atslib_inthash_jenkins", x)
  val hval = $UN.cast{uint}(hval)
//
  val r = $UN.cast{int}(hval mod 256u)
  val hval = hval / 256u
  val g = $UN.cast{int}(hval mod 256u)
  val hval = hval / 256u
  val b = $UN.cast{int}(hval mod 256u)
//
in
  color_make (r/256.0, g/256.0, b/256.0)
end // end of [colorgen]
//
(* ****** ****** *)

implement
cairo_draw_array0
(
  cr, p1, p2, p3, p4, ASZ
) = let
//
val p_cr = ptrcast (cr)
//
implement
mydraw_get0_cairo<> () = let
//
extern
castfn __cast {l:addr} (ptr(l)): vttakeout (void, cairo_ref(l))
//
in
  __cast (p_cr)
end // end of [mydraw_get0_cairo]
//
implement
mydraw_bargraph$color<> (i) = colorgen (ASZ[i])

implement
mydraw_bargraph$height<> (i) = 1.0 * (ASZ[i]+1) / MYMAX
//
val asz = ASZ.size
val asz = sz2i (asz)
val asz = ckastloc_gintGt (asz, 0)
//
in
  mydraw_bargraph (asz, p1, p2, p3, p4)
end // end of [cairo_draw_array0]

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

extern
fun
mydraw_clock
  (cr: !cairo_ref1, width: int, height: int) : void
// end of [mydraw_clock]

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

implement
mydraw_clock
  (cr, W, H) = let
//
val W =
g0int2float_int_double(W)
and H =
g0int2float_int_double(H)
//
val WH = min (W, H)
//
val xm = (W - WH) / 2
val ym = (H - WH) / 2
//
val v0 = vector_make (xm, ym)
//
val p1 = point_make (0. , WH) + v0
val p2 = point_make (WH , WH) + v0
val p3 = point_make (WH , 0.) + v0
val p4 = point_make (0. , 0.) + v0
//
val () =
if the_timer_is_running () then ASZ_update ()
//
val (pf | ()) = cairo_save (cr)
val () = cairo_draw_array0 (cr, p1, p2, p3, p4, ASZ)
val ((*void*)) = cairo_restore (pf | cr)
//
in
  // nothing
end // [mydraw_clock]

(* ****** ****** *)
//
%{^
typedef char **charptrptr ;
%} ;
abstype charptrptr = $extype"charptrptr"
//
(* ****** ****** *)

implement
main0{n}
(
  argc, argv
) = let
//
var argc: int = argc
var argv: charptrptr = $UN.castvwtp1{charptrptr}(argv)
//
val () = $extfcall (void, "gtk_init", addr@(argc), addr@(argv))
//
implement
gtkcairotimer_title<> () = stropt_some"InsertionSort"
implement
gtkcairotimer_timeout_interval<> () = 100U // millisecs
implement
gtkcairotimer_mydraw<> (cr, width, height) = mydraw_clock (cr, width, height)
//
val ((*void*)) = gtkcairotimer_main ((*void*))
//
in
  // nothing
end // end of [main0]

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

(* end of [insertsort_anim2.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
** Poorman's Drawing
** Sierpinski triangles
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_MAINATSFLAG 1
//
#define
ATS_DYNLOADNAME
"Sierpinski_3angle_txt__dynload"
//
#define
ATS_STATIC_PREFIX "Sierpinski_3angle_txt__"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSCC2JS}/SATS/print.sats"
//
staload
_ = "{$LIBATSCC2JS}/DATS/print.dats"
//
(* ****** ****** *)

#define NROW 48
#define NCOL 80

(* ****** ****** *)
//
val
theCanvas =
matrixref_make_elt{int}(NROW, NCOL, 0)
//
(* ****** ****** *)
//
fun
theCanvas_clear() =
matrixref_foreach_cloref
  (theCanvas, NROW, NCOL, lam(i, j) => (theCanvas[i,NCOL,j] := 0))
//
(* ****** ****** *)
//
fun
theCanvas_print() =
matrixref_foreach_cloref
(
  theCanvas
, NROW, NCOL
, lam(i, j) =>
  let
    val x = theCanvas[i,NCOL,j]
  in
    print_string(if x = 0 then " " else "X"); if j=NCOL-1 then print_newline()
  end // end of [let]
) (* end of [matrixref_foreach] *)
//
(* ****** ****** *)
//
extern
fun
draw_point(x: int, y: int): void
//
implement
draw_point(x, y) = let
//
val x = g1ofg0(x) and y = g1ofg0(y)
//
(*
val () = println! ("draw_point: x = ", x)
val () = println! ("draw_point: y = ", y)
*)
//
in
  if x < 0 then ()
  else if y < 0 then ()
  else if x >= NCOL then ()
  else if y >= NROW then ()
  else (theCanvas[y, NCOL, x] := 1)
end // end of [draw_point]
//
(* ****** ****** *)

typedef
point = $tup(int, int)

(* ****** ****** *)
//
extern
fun
midpoint(p1: point, p2: point): point
//
(* ****** ****** *)

implement
midpoint(p1, p2) = $tup((p1.0+p2.0)/2, (p1.1+p2.1)/2)

(* ****** ****** *)
//
extern
fun
draw_hline
  (x1: int, x2: int, y: int): void
//
(* ****** ****** *)

implement
draw_hline
  (x1, x2, y) = let
//
fun loop (x1: int): void =
  if x1 <= x2
    then (draw_point(x1, y); loop(x1+1)) else ()
  // end of [if]
//
in
  loop (x1)
end // end of [draw_hline]
//
(* ****** ****** *)
//
extern
fun
draw_triangle_0
  (p1: point, p2: point, p3: point): void
extern
fun
draw_triangle_1
  (p1: point, p2: point, p3: point): void
//
(* ****** ****** *)

implement
draw_triangle_0
  (p1, p2, p3) = let
//
val x1 = p1.0 and y1 = p1.1
val x2 = p2.0 and y2 = p2.1
val x3 = p3.0 and y3 = p3.1
//
val () = assertloc (y2 = y3)
val () = assertloc (x1 + x1 = x2 + x3)
//
val dir =
  (if y1 >= y2 then 1 else ~1): int
//
fun
loop
(
  x2: int, x3: int, y2: int
) : void = let
//
val () = draw_point(x2, y2)
val () = draw_point(x3, y2)
//
in
  if y1 != y2
    then loop(x2+1, x3-1, y2+dir) else ()
  // end of [if]
end // end of [loop]
//
in
  draw_hline(x2+1, x3-1, y2); loop (x2, x3, y2)
end // end of [draw_triangle_0]

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

implement
draw_triangle_1
  (p1, p2, p3) = let
//
val x1 = p1.0 and y1 = p1.1
val x2 = p2.0 and y2 = p2.1
val x3 = p3.0 and y3 = p3.1
//
val () = assertloc (y2 = y3)
val () = assertloc (x1 + x1 = x2 + x3)
//
val dir =
  (if y1 >= y2 then 1 else ~1): int
//
fun
loop
(
  x2: int, x3: int, y2: int
) : void = let
//
val () = draw_hline(x2, x3, y2)
//
in
  if y1 != y2 then loop(x2+1, x3-1, y2+dir) else ()
end // end of [loop]
//
in
  loop (x2, x3, y2)
end // end of [draw_triangle_1]

(* ****** ****** *)
//
extern
fun
draw_sierpinski
  (p1: point, p2: point, p3: point, n: int): void
extern
fun
draw_sierpinski_aux
  (p1: point, p2: point, p3: point, n: int): void
//
(* ****** ****** *)

implement
draw_sierpinski
  (p1, p2, p3, n) =
(
  if n > 0
    then draw_sierpinski_aux(p1, p2, p3, n)
    else ()
  // end of [if]
) (* end of [draw_sierpinski] *)

implement
draw_sierpinski_aux
  (p1, p2, p3, n) = let
//
  val p12 = midpoint(p1, p2)
  val p23 = midpoint(p2, p3)
  val p31 = midpoint(p3, p1)
//
  val () = draw_triangle_1(p23, p12, p31)
  val () = draw_sierpinski(p1, p12, p31, n-1)
  val () = draw_sierpinski(p12, p2, p23, n-1)
  val () = draw_sierpinski(p31, p23, p3, n-1)
//
in
  // nothing
end // end of [draw_sierpinski_aux]

(* ****** ****** *)
//
extern
fun
draw_sierpinski_demo
  (level: int): void = "mac#"
//
(* ****** ****** *)

implement
draw_sierpinski_demo
  (level) = let
//
val p1 = $tup(32, 0 )
val p2 = $tup(0 , 32)
val p3 = $tup(64, 32)
//
val () = theCanvas_clear()
val () = draw_triangle_0(p1, p2, p3)
val () = draw_sierpinski(p1, p2, p3, level)
val () = theCanvas_print()
//
in
  // nothing
end // end of [draw_sierpinski_demo]

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

%{$
//
var theLevel = 0;
var theLevelMax = 5;

function
draw2_sierpinski_demo()
{
//
var
level = theLevel;
//
theLevel = (level+1)%theLevelMax;
//
var _ =
ats2jspre_the_print_store_clear();
//
var _ = draw_sierpinski_demo(level);
//
document.getElementById("theDrawingString").innerHTML = ats2jspre_the_print_store_join();
//
setTimeout(draw2_sierpinski_demo, 1000);
//
return;
//
} // end of [draw2_sierpinski_demo]
//
jQuery(document).ready(function(){Sierpinski_3angle_txt__dynload(); draw2_sierpinski_demo();});
//
%} // end of [%{$]

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

(* end of [Sierpinski_3angle_txt.dats] *)

(*
**
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
#define
ATS_MAINATSFLAG 1
//
#define
ATS_DYNLOADNAME
"Sierpinski_3angle_txt__dynload"
//
#define
ATS_STATIC_PREFIX "Sierpinski_3angle_txt__"
//
(* ****** ****** *)
//
#include
"{$LIBATSCC2JS}/staloadall.hats"
//
(* ****** ****** *)
//
staload
"{$LIBATSCC2JS}/SATS/print.sats"
//
staload
_ = "{$LIBATSCC2JS}/DATS/print.dats"
//
(* ****** ****** *)

#define NROW 48
#define NCOL 80

(* ****** ****** *)
//
val
theCanvas =
matrixref_make_elt{int}(NROW, NCOL, 0)
//
(* ****** ****** *)
//
fun
theCanvas_clear() =
matrixref_foreach_cloref
  (theCanvas, NROW, NCOL, lam(i, j) => (theCanvas[i,NCOL,j] := 0))
//
(* ****** ****** *)
//
fun
theCanvas_print() =
matrixref_foreach_cloref
(
  theCanvas
, NROW, NCOL
, lam(i, j) =>
  let
    val x = theCanvas[i,NCOL,j]
  in
    print_string(if x = 0 then " " else "X"); if j=NCOL-1 then print_newline()
  end // end of [let]
) (* end of [matrixref_foreach] *)
//
(* ****** ****** *)
//
extern
fun
draw_point(x: int, y: int): void
//
implement
draw_point(x, y) = let
//
val x = g1ofg0(x) and y = g1ofg0(y)
//
(*
val () = println! ("draw_point: x = ", x)
val () = println! ("draw_point: y = ", y)
*)
//
in
  if x < 0 then ()
  else if y < 0 then ()
  else if x >= NCOL then ()
  else if y >= NROW then ()
  else (theCanvas[y, NCOL, x] := 1)
end // end of [draw_point]
//
(* ****** ****** *)

typedef
point = $tup(int, int)

(* ****** ****** *)
//
extern
fun
midpoint(p1: point, p2: point): point
//
(* ****** ****** *)

implement
midpoint(p1, p2) = $tup((p1.0+p2.0)/2, (p1.1+p2.1)/2)

(* ****** ****** *)
//
extern
fun
draw_hline
  (x1: int, x2: int, y: int): void
//
(* ****** ****** *)

implement
draw_hline
  (x1, x2, y) = let
//
fun loop (x1: int): void =
  if x1 <= x2
    then (draw_point(x1, y); loop(x1+1)) else ()
  // end of [if]
//
in
  loop (x1)
end // end of [draw_hline]
//
(* ****** ****** *)
//
extern
fun
draw_triangle_0
  (p1: point, p2: point, p3: point): void
extern
fun
draw_triangle_1
  (p1: point, p2: point, p3: point): void
//
(* ****** ****** *)

implement
draw_triangle_0
  (p1, p2, p3) = let
//
val x1 = p1.0 and y1 = p1.1
val x2 = p2.0 and y2 = p2.1
val x3 = p3.0 and y3 = p3.1
//
val () = assertloc (y2 = y3)
val () = assertloc (x1 + x1 = x2 + x3)
//
val dir =
  (if y1 >= y2 then 1 else ~1): int
//
fun
loop
(
  x2: int, x3: int, y2: int
) : void = let
//
val () = draw_point(x2, y2)
val () = draw_point(x3, y2)
//
in
  if y1 != y2
    then loop(x2+1, x3-1, y2+dir) else ()
  // end of [if]
end // end of [loop]
//
in
  draw_hline(x2+1, x3-1, y2); loop (x2, x3, y2)
end // end of [draw_triangle_0]

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

implement
draw_triangle_1
  (p1, p2, p3) = let
//
val x1 = p1.0 and y1 = p1.1
val x2 = p2.0 and y2 = p2.1
val x3 = p3.0 and y3 = p3.1
//
val () = assertloc (y2 = y3)
val () = assertloc (x1 + x1 = x2 + x3)
//
val dir =
  (if y1 >= y2 then 1 else ~1): int
//
fun
loop
(
  x2: int, x3: int, y2: int
) : void = let
//
val () = draw_hline(x2, x3, y2)
//
in
  if y1 != y2 then loop(x2+1, x3-1, y2+dir) else ()
end // end of [loop]
//
in
  loop (x2, x3, y2)
end // end of [draw_triangle_1]

(* ****** ****** *)
//
extern
fun
draw_sierpinski
  (p1: point, p2: point, p3: point, n: int): void
extern
fun
draw_sierpinski_aux
  (p1: point, p2: point, p3: point, n: int): void
//
(* ****** ****** *)

implement
draw_sierpinski
  (p1, p2, p3, n) =
(
  if n > 0
    then draw_sierpinski_aux(p1, p2, p3, n)
    else ()
  // end of [if]
) (* end of [draw_sierpinski] *)

implement
draw_sierpinski_aux
  (p1, p2, p3, n) = let
//
  val p12 = midpoint(p1, p2)
  val p23 = midpoint(p2, p3)
  val p31 = midpoint(p3, p1)
//
  val () = draw_triangle_1(p23, p12, p31)
  val () = draw_sierpinski(p1, p12, p31, n-1)
  val () = draw_sierpinski(p12, p2, p23, n-1)
  val () = draw_sierpinski(p31, p23, p3, n-1)
//
in
  // nothing
end // end of [draw_sierpinski_aux]

(* ****** ****** *)
//
extern
fun
draw_sierpinski_demo
  (level: int): void = "mac#"
//
(* ****** ****** *)

implement
draw_sierpinski_demo
  (level) = let
//
val p1 = $tup(32, 0 )
val p2 = $tup(0 , 32)
val p3 = $tup(64, 32)
//
val () = theCanvas_clear()
val () = draw_triangle_0(p1, p2, p3)
val () = draw_sierpinski(p1, p2, p3, level)
val () = theCanvas_print()
//
in
  // nothing
end // end of [draw_sierpinski_demo]

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

%{$
//
var theLevel = 0;
var theLevelMax = 5;

function
draw2_sierpinski_demo()
{
//
var
level = theLevel;
//
theLevel = (level+1)%theLevelMax;
//
var _ =
ats2jspre_the_print_store_clear();
//
var _ = draw_sierpinski_demo(level);
//
document.getElementById("theDrawingString").innerHTML = ats2jspre_the_print_store_join();
//
setTimeout(draw2_sierpinski_demo, 1000);
//
return;
//
} // end of [draw2_sierpinski_demo]
//
jQuery(document).ready(function(){Sierpinski_3angle_txt__dynload(); draw2_sierpinski_demo();});
//
%} // end of [%{$]

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

(* end of [Sierpinski_3angle_txt.dats] *)


Updating: working on chardev-1

Updating: working on chardev-1

(*
** A simple char device
*)

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

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

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

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

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

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

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

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

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

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

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

typedef charptr = $extype"charptr"

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

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

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

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

%{^

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

static void *fops_ptr = &(fops);

%} // end of [%{^]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(*
** A simple char device
*)

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

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

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

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

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

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

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

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

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

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

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

typedef charptr = $extype"charptr"

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

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

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

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

%{^

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

static void *fops_ptr = &(fops);

%} // end of [%{^]

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

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

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

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

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

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

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

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

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

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

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

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

implement
device_read_
  (filp, buf, n, ofs) = let
in
  g0i2i(0)
end // end of [device_read_]

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

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

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

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

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

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


implement tcp_socket_connection_connect API

#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"
staload "libmbedats/SATS/net_lwip_Socket_Socket.sats"
staload "libmbedats/SATS/net_lwip_Socket_Endpoint.sats"
staload "libmbedats/SATS/net_lwip_Socket_TCPSocketConnection.sats"

vtypedef TCPSocketConnection_struct = @{
  is_connected= bool
, sock=         Socket
, endpoint=     Endpoint
}

absvtype TCPSocketConnection_minus_struct (l:addr)

extern castfn
TCPSocketConnection_takeout_struct
(
  tcp: !TCPSocketConnection >> TCPSocketConnection_minus_struct l
) : #[l:addr] (TCPSocketConnection_struct @ l | ptr l)

extern praxi
TCPSocketConnection_addback_struct
  {l:addr}
(
  pfat: TCPSocketConnection_struct @ l
| tcp: !TCPSocketConnection_minus_struct l >> TCPSocketConnection
) : void

implement
tcp_socket_connection_open () = let
  val (pfgc, pfat | p) = ptr_alloc<TCPSocketConnection_struct> ()
  val () = p->is_connected := false
  val () = p->sock := socket_open ()
  val () = p->endpoint := endpoint_open ()
in
  $UN.castvwtp0{TCPSocketConnection}((pfat, pfgc | p))
end

implement
tcp_socket_connection_connect (tcp, host, port) = let
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val rs = socket_initsock (p->sock, SOCK_STREAM)
  val ret = if rs = false then false else let
      val re = endpoint_set_address (p->endpoint, host, port)
    in
      if re = false then false else let
          abst@ype socklen_t = $extype"socklen_t"
          extern fun lwip_connect: (int, struct_sockaddr_in_p, socklen_t) -> int = "mac#"
          val fd = socket_sock_fd (p->sock)
          val rh = endpoint_remoteHost (p->endpoint)
          val rc = lwip_connect (fd, rh, $UN.cast (sizeof<struct_sockaddr_in>))
        in
          if rc < 0 then let
              val _ = socket_finisock (p->sock, true)
            in
              false
            end else let
              val () = p->is_connected := true
            in
              true
            end
        end
    end
  prval () = TCPSocketConnection_addback_struct(pfat | tcp)
in
  ret
end

implement
tcp_socket_connection_close (tcp) = {
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val () = endpoint_close (p->endpoint)
  val () = socket_close (p->sock)
  val () = $UN.castvwtp0((pfat | p))
  val () = __free (tcp) where {
    extern fun __free {vt:vtype} (x: vt): void = "atspre_mfree_gc"
  }
}

#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"
staload "libmbedats/SATS/net_lwip_Socket_Socket.sats"
staload "libmbedats/SATS/net_lwip_Socket_Endpoint.sats"
staload "libmbedats/SATS/net_lwip_Socket_TCPSocketConnection.sats"

vtypedef TCPSocketConnection_struct = @{
  is_connected= bool
, sock=         Socket
, endpoint=     Endpoint
}

absvtype TCPSocketConnection_minus_struct (l:addr)

extern castfn
TCPSocketConnection_takeout_struct
(
  tcp: !TCPSocketConnection >> TCPSocketConnection_minus_struct l
) : #[l:addr] (TCPSocketConnection_struct @ l | ptr l)

extern praxi
TCPSocketConnection_addback_struct
  {l:addr}
(
  pfat: TCPSocketConnection_struct @ l
| tcp: !TCPSocketConnection_minus_struct l >> TCPSocketConnection
) : void

implement
tcp_socket_connection_open () = let
  val (pfgc, pfat | p) = ptr_alloc<TCPSocketConnection_struct> ()
  val () = p->is_connected := false
  val () = p->sock := socket_open ()
  val () = p->endpoint := endpoint_open ()
in
  $UN.castvwtp0{TCPSocketConnection}((pfat, pfgc | p))
end

implement
tcp_socket_connection_connect (tcp, host, port) = let
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val rs = socket_initsock (p->sock, SOCK_STREAM)
  val ret = if rs = false then false else let
      val re = endpoint_set_address (p->endpoint, host, port)
    in
      if re = false then false else let
        in
          true // xxx
        end
    end
  // xxx
  prval () = TCPSocketConnection_addback_struct(pfat | tcp)
in
  ret
end

implement
tcp_socket_connection_close (tcp) = {
  val (pfat | p) = TCPSocketConnection_takeout_struct (tcp)
  val () = endpoint_close (p->endpoint)
  val () = socket_close (p->sock)
  val () = $UN.castvwtp0((pfat | p))
  val () = __free (tcp) where {
    extern fun __free {vt:vtype} (x: vt): void = "atspre_mfree_gc"
  }
}