Updating: very minorly improving

Updating: very minorly improving

(* ****** ****** *)
//
// Atscc2erl:
// from ATS to Erlang
//
(* ****** ****** *)
//
// HX-2015-06-29: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#define
CATSPARSEMIT_targetloc "./.CATS-parsemit"
//
(* ****** ****** *)
//
staload "{$CATSPARSEMIT}/catsparse.sats"
//
staload "{$CATSPARSEMIT}/catsparse_syntax.sats"
//
staload "{$CATSPARSEMIT}/catsparse_emit.sats"
//
staload "{$CATSPARSEMIT}/catsparse_typedef.sats"
staload "{$CATSPARSEMIT}/catsparse_fundecl.sats"
//
(* ****** ****** *)

local

staload
TM = "libc/SATS/time.sats"
stadef time_t = $TM.time_t

in (* in-of-local *)

implement
emit_time_stamp (out) = let
//
var tm: time_t
val () = tm := $TM.time_get ()
val (pfopt | p_tm) = $TM.localtime (tm)
//
val () = emit_text (out, "%%%%%%\n");
val () = emit_text (out, "%%\n");
val () = emit_text (out, "%% The Erlang code is generated by atscc2erl\n")
val () = emit_text (out, "%% The starting compilation time is: ")
//
val () =
if
p_tm > 0
then let
  prval Some_v @(pf1, fpf1) = pfopt
  val tm_min = $TM.tm_get_min (!p_tm)
  val tm_hour = $TM.tm_get_hour (!p_tm)
  val tm_mday = $TM.tm_get_mday (!p_tm)
  val tm_mon = 1 + $TM.tm_get_mon (!p_tm)
  val tm_year = 1900 + $TM.tm_get_year (!p_tm)
  prval () = fpf1 (pf1)
in
  $extfcall
  (
    void
  , "fprintf"
  , out, "%i-%i-%i: %2ih:%2im\n", tm_year, tm_mon, tm_mday, tm_hour, tm_min
  )
end // end of [then]
else let
  prval None_v () = pfopt
in
  emit_text (out, "**TIME-ERROR**\n")
end // end of [else]
//
val () = emit_text (out, "%%\n")
val () = emit_text (out, "%%%%%%\n")
//
in
  // emit_newline (out)
end // end of [emit_time_stamp]

end // end of [local]

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

implement
emit_PMVint
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVint]
//
implement
emit_PMVintrep
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVintrep]
//
(* ****** ****** *)

implement
emit_PMVbool
  (out, tfv) = (
//
emit_text
( out
, if tfv then "true" else "false"
) (* end of [emit_text] *)
//
) (* end of [emit_PMVbool] *)

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

implement
emit_PMVstring
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVstring]

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

implement
emit_PMVfloat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVfloat]

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

implement
emit_PMVi0nt
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVi0nt]

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

implement
emit_PMVf0loat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVf0loat]

(* ****** ****** *)
//
implement
emit_PMVempty
  (out, _) = emit_text (out, "null")
//
implement
emit_PMVextval
  (out, toks) = emit_tokenlst (out, toks)
//
(* ****** ****** *)
//
extern
fun
f0ide_get_arity (fid: i0de): int
//
implement
f0ide_get_arity
  (fid) = let
//
val
opt =
f0head_search_opt(fid.i0dex_sym)
//
in
//
case+ opt of
| ~None_vt() => ~1
| ~Some_vt(fhd) =>
  (
    case+
    fhd.f0head_node
    of // case+
    | F0HEAD(fid, fma, _) =>
        list_length (fma.f0marg_node)
      // end of [F0HEAD]
  ) (* end of [Some_vt] *)
//
end // end of [f0ide_get_arity]
//
(* ****** ****** *)
//
extern
fun
emit_f0ide
  : emit_type (i0de) = "ext#atscc2erl_emit_f0ide"
extern
fun
emit_flabel
  : emit_type (label) = "ext#atscc2erl_emit_flabel"
//
implement
emit_f0ide
  (out, fid) = let
//
val sym = fid.i0dex_sym
val name = symbol_get_name(sym)
//
val c0 =
  $UN.ptr0_get<char> (string2ptr(name))
//
val () = if c0 = '_' then emit_text(out, "f")
//
in
  emit_symbol(out, sym)
end // end of [emit_f0ide]
//
implement
emit_flabel
  (out, flab) = emit_f0ide (out, flab)
//
(* ****** ****** *)
//
implement
emit_PMVfunlab
  (out, flab) =
{
//
val n0 = f0ide_get_arity(flab)
//
val () = emit_text(out, "fun ")
val () = emit_flabel (out, flab)
val () = (emit_text(out, "/"); emit_int(out, n0))
//
} (* end of [emit_PMVfunlab] *)
//
(* ****** ****** *)

implement
emit_PMVcfunlab
  (out, flab, d0es_env) =
{
//
val () =
  emit_flabel (out, flab)
//
val () =
  emit_text (out, "__closurerize")
//
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es_env)
val () = emit_RPAREN (out)
//
} (* end of [emit_PMVcfunlab] *)

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

implement
emit_CSTSPmyloc
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_CSTSPmyloc]

(* ****** ****** *)
//
extern
fun
emit_fname_d0exp
  : (FILEref, string, d0exp) -> void
extern
fun
emit_fname_d0exp2
  : (FILEref, string, d0exp, d0exp) -> void
//
implement
emit_fname_d0exp
  (out, fname, d0e) =
{
//
val () =
  emit_text (out, fname)
val () = emit_LPAREN (out)
val () = emit_d0exp (out, d0e)
val () = emit_RPAREN (out)
//
} (* end of [emit_fname_d0exp] *)
//
implement
emit_fname_d0exp2
  (out, fname, d0e1, d0e2) =
{
//
val () =
  emit_text (out, fname)
//
val () = emit_LPAREN (out)
val () =
(
  emit_d0exp (out, d0e1); emit_text (out, ", "); emit_d0exp (out, d0e2)
)
val () = emit_RPAREN (out)
//
} (* end of [emit_fname_d0exp2] *)
//
(* ****** ****** *)
//
implement
emit_ATSCKiseqz(out, d0e) =
  emit_fname_d0exp(out, "?ATSCKiseqz", d0e)
implement
emit_ATSCKisneqz(out, d0e) =
  emit_fname_d0exp(out, "?ATSCKisneqz", d0e)
//
(* ****** ****** *)
//
implement
emit_ATSCKptriscons(out, d0e) =
  emit_fname_d0exp(out, "?ATSCKptriscons", d0e)
implement
emit_ATSCKptrisnull(out, d0e) =
  emit_fname_d0exp(out, "?ATSCKptrisnull", d0e)
//
(* ****** ****** *)
//
implement
emit_ATSCKpat_int
  (out, d0e, i0) =
  emit_fname_d0exp2 (out, "?ATSCKpat_int", d0e, i0)
implement
emit_ATSCKpat_bool
  (out, d0e, b0) =
  emit_fname_d0exp2 (out, "?ATSCKpat_bool", d0e, b0)
implement
emit_ATSCKpat_string
  (out, d0e, s0) =
  emit_fname_d0exp2 (out, "?ATSCKpat_string", d0e, s0)
//
(* ****** ****** *)

implement
emit_ATSCKpat_con0
  (out, d0e, ctag) =
{
//
val () =
emit_text (out, "?ATSCKpat_con0(")
val () = (
  emit_d0exp (out, d0e); emit_text (out, ", "); emit_int (out, ctag); emit_RPAREN (out)
) (* end of [val] *)
//
} (* end of [emit_ATSCKpat_con0] *)

implement
emit_ATSCKpat_con1
  (out, d0e, ctag) =
{
//
val () =
emit_text (out, "?ATSCKpat_con1(")
val () = (
  emit_d0exp (out, d0e); emit_text (out, ", "); emit_int (out, ctag); emit_RPAREN (out)
) (* end of [val] *)
//
} (* end of [emit_ATSCKpat_con1] *)

(* ****** ****** *)
//
implement
emit_tmpvar
  (out, tmp) = let
//
val
sym = tmp.i0dex_sym
val
name =
g1ofg0(symbol_get_name(sym))
//
in
//
if
isneqz(name)
then let
//
  val p0 = string2ptr(name)
  val C0 = toupper($UN.ptr0_get<char>(p0))
//
  val p1 = ptr0_succ<char>(p0)
  val name1 = $UN.cast{string}(p1)
//
in
  emit_char(out, C0); emit_text(out, name1)
end // end of [then]
else () // end of [else]
//
end // end of [emit_tmpvar]
//
(* ****** ****** *)

fun
s0exp_get_arity
  (s0e: s0exp): int =
(
case+
s0e.s0exp_node
of // case+
| S0Elist(s0es) => list_length(s0es) | _ => ~1
) (* end of [s0exp_get_arity] *)

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

implement
emit_d0exp
  (out, d0e0) = let
in
//
case+
d0e0.d0exp_node of
//
| D0Eide (tmp) =>
  {
    val () = emit_tmpvar (out, tmp)
  }
//
| D0Eappid (fid, d0es) =>
  {
    val () = emit_f0ide (out, fid)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
| D0Eappexp (d0e, d0es) =>
  {
    val () = emit_d0exp (out, d0e)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| D0Elist (d0es) =>
  {
    val () = emit_text (out, "D0Elist")
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| ATSPMVint (int) => emit_PMVint (out, int)
| ATSPMVintrep (int) => emit_PMVintrep (out, int)
//
| ATSPMVbool (tfv) => emit_PMVbool (out, tfv)
//
| ATSPMVfloat (flt) => emit_PMVfloat (out, flt)
//
| ATSPMVstring (str) => emit_PMVstring (out, str)
//
| ATSPMVi0nt (int) => emit_PMVi0nt (out, int)
| ATSPMVf0loat (flt) => emit_PMVf0loat (out, flt)
//
| ATSPMVempty (dummy) => emit_PMVempty (out, 0)
| ATSPMVextval (toklst) => emit_PMVextval (out, toklst)
//
| ATSPMVrefarg0 (d0e) => emit_d0exp (out, d0e)
| ATSPMVrefarg1 (d0e) => emit_d0exp (out, d0e)
//
| ATSPMVfunlab (fl) => emit_PMVfunlab (out, fl)
| ATSPMVcfunlab
    (_(*knd*), fl, d0es) => emit_PMVcfunlab (out, fl, d0es)
  // end of [ATSPMVcfunlab]
//
| ATSPMVcastfn
    (_(*fid*), _(*s0e*), arg) => emit_d0exp (out, arg)
//
| ATSCSTSPmyloc (tok) => emit_CSTSPmyloc (out, tok)
//
//
| ATSCKiseqz(d0e) => emit_ATSCKiseqz (out, d0e)
| ATSCKisneqz(d0e) => emit_ATSCKisneqz (out, d0e)
| ATSCKptriscons(d0e) => emit_ATSCKptriscons (out, d0e)
| ATSCKptrisnull(d0e) => emit_ATSCKptrisnull (out, d0e)
//
| ATSCKpat_int
    (d0e, int) => emit_ATSCKpat_int (out, d0e, int)
| ATSCKpat_bool
    (d0e, bool) => emit_ATSCKpat_bool (out, d0e, bool)
| ATSCKpat_string
    (d0e, string) => emit_ATSCKpat_string (out, d0e, string)
//
| ATSCKpat_con0
    (d0e, ctag) => emit_ATSCKpat_con0 (out, d0e, ctag)
| ATSCKpat_con1
    (d0e, ctag) => emit_ATSCKpat_con1 (out, d0e, ctag)
//
| ATSSELcon _ => emit_SELcon (out, d0e0)
| ATSSELrecsin _ => emit_SELrecsin (out, d0e0)
| ATSSELboxrec _ => emit_SELboxrec (out, d0e0)
| ATSSELfltrec _ => emit_text (out, "ATSSELfltrec(...)")
//
| ATSextfcall
    (_fun, _arg) => {
    val () = emit_i0de (out, _fun)
    val () = emit_d0exparg (out, _arg)
  } (* end of [ATSextfcall] *)
| ATSextmcall
    (_obj, _mtd, _arg) => {
//
    val () = emit_d0exp (out, _obj)
    val () = emit_DOT (out)
    val () = emit_d0exp (out, _mtd)
//
    val () = emit_d0exparg (out, _arg)
//
  } (* end of [ATSextmcall] *)
//
| ATSfunclo_fun
  (
    d0e_fun, s0e_arg, _(*res*)
  ) =>
  {
    val () =
    emit_text
      (out, "?ATSfunclo_fun")
    // end of [val]
    val () =
    (
      emit_LPAREN (out); emit_d0exp (out, d0e_fun); emit_RPAREN (out)
    ) (* end of [val] *)
  } (* end of [ATSfunclo_fun] *)
//
| ATSfunclo_clo
  (
    d0e_fun, _(*arg*), _(*res*)
  ) =>
  {
    val () =
    emit_text(out, "?ATSfunclo_clo")
    val () =
    (
      emit_LPAREN (out); emit_d0exp (out, d0e_fun); emit_RPAREN (out)
    ) (* end of [val] *)
  } (* end of [ATSfunclo_clo] *)
//
end // end of [emit_d0exp]

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

local

fun
loop
(
  out: FILEref, d0es: d0explst, i: int
) : void =
(
case+ d0es of
| list_nil () => ()
| list_cons (d0e, d0es) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_d0exp (out, d0e); loop (out, d0es, i+1)
  end // end of [list_cons]
)

in (* in-of-local *)

implement
emit_d0explst (out, d0es) = loop (out, d0es, 0)
implement
emit_d0explst_1 (out, d0es) = loop (out, d0es, 1)

end // end of [local]

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

implement
emit_d0exparg
  (out, d0es) =
{
//
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es)
val () = emit_RPAREN (out)
//
} (* end of [emit_d0exparg] *)

(* ****** ****** *)
//
extern
fun
tyrec_labsel
  (tyrec: tyrec, lab: symbol): int
//
implement
tyrec_labsel
  (tyrec, lab) = let
//
fun loop
(
  xs: tyfldlst, i: int
) : int =
(
case+ xs of
| list_cons (x, xs) => let
    val TYFLD (id, s0e) = x.tyfld_node
  in
    if lab = id.i0dex_sym then i else loop (xs, i+1)
  end // end of [list_cons
| list_nil ((*void*)) => ~1(*error*)
)
//
in
  loop (tyrec.tyrec_node, 0)
end // end of [tyrec_labsel]
//
(* ****** ****** *)

implement
emit_SELcon
  (out, d0e) = let
//
val-
ATSSELcon
  (d0rec, s0e, id) = d0e.d0exp_node
//
val-S0Eide(name) = s0e.s0exp_node
val-~Some_vt(s0rec) = typedef_search_opt(name)
//
val tupi = tyrec_labsel(s0rec, id.i0dex_sym)
//
val () =
emit_text
  (out, "?ATSSELcon")
//
val () = emit_LPAREN (out)
//
val () =
(
  emit_d0exp (out, d0rec); emit_text (out, ", "); emit_int (out, tupi)
) (* end of [val] *)
//
val () = emit_RPAREN (out)
//
in
  // nothing
end // end of [emit_SELcon]

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

implement
emit_SELrecsin
  (out, d0e) = let
//
val-
ATSSELrecsin
  (d0rec, s0e, id) = d0e.d0exp_node
//
in
  emit_d0exp (out, d0rec)
end // end of [emit_SELrecsin]

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

implement
emit_SELboxrec
  (out, d0e) = let
//
val-
ATSSELboxrec
  (d0rec, s0e, id) = d0e.d0exp_node
//
val-S0Eide(name) = s0e.s0exp_node
val-~Some_vt(s0rec) = typedef_search_opt(name)
//
val tupi = tyrec_labsel(s0rec, id.i0dex_sym)
//
val () =
emit_text
  (out, "?ATSSELboxrec")
//
val () = emit_LPAREN (out)
//
val () =
(
  emit_d0exp (out, d0rec); emit_text (out, ", "); emit_int (out, tupi)
) (* end of [val] *)
//
val () = emit_RPAREN (out)
//
in
  // nothing
end // end of [emit_SELboxrec]

(* ****** ****** *)
//
implement
emit_COMMENT_line
  (out, tok) = let
//
val-
T_COMMENT_line
  (str) = tok.token_node
//
in
  emit_text (out, str)
end // end of [emit_COMMENT_line]
//
implement
emit_COMMENT_block
  (out, tok) = let
//
val-
T_COMMENT_block
  (str) = tok.token_node
//
in
  emit_text (out, str)
end // end of [emit_COMMENT_block]
//
(* ****** ****** *)

local

fun
aux0_cenv
(
  out: FILEref
, s0es: s0explst
) : void = let
//
fun
auxlst
(
  i: int, s0es: s0explst
) : void =
(
case+ s0es of
| list_nil() => ()
| list_cons
    (_, s0es) => let
    val () =
      emit_text(out, ", ")
    val () =
    (
      emit_text(out, "Cenv"); emit_int(out, i)
    )
  in
    auxlst(i+1, s0es)
  end // end of [auxlst]
)
//
val () = emit_LBRACE(out)
val () = (emit_text(out, "_"); auxlst(1, s0es))
val () = emit_RBRACE(out)
//
in
  // nothing
end (* end of [aux0_cenv] *)

fun
aux0_arglst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void = (
//
case+ s0es of
| list_nil
    ((*void*)) => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0
      then emit_text (out, ", ")
    // end of [val]
    val () =
    (
      emit_text (out, "XArg"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_arglst (out, s0es, n0, i+1)
  end // end of [list_cons]
//
) (* end of [aux0_arglst] *)

fun
aux0_envlst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void = (
//
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0
      then emit_text (out, ", ")
    // end of [val]
    val () =
    (
      emit_text (out, "XEnv"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_envlst (out, s0es, n0, i+1)
  end // end of [list_cons]
//
) (* end of [aux0_envlst] *)

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

in (* in-of-local *)

implement
emit_closurerize
(
  out, flab, env, arg, res
) = let
//
val-S0Elist(s0es_env) = env.s0exp_node
val-S0Elist(s0es_arg) = arg.s0exp_node
//
val () = emit_ENDL (out)
//
val () =
emit_text (out, "%%fun%%\n")
val () = emit_flabel (out, flab)
val () =
emit_text (out, "__closurerize(")
val () = aux0_envlst (out, s0es_env, 0, 0)
val ((*closing*)) = emit_text (out, ") -> \n")
//
val ((*opening*)) = emit_text (out, "%{\n")
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "{")
val () = emit_text (out, "fun(")
//
val () = aux0_cenv (out, s0es_env)
val () = aux0_arglst (out, s0es_arg, 1, 0)
//
val () = emit_text (out, ") -> ")
//
val () = emit_flabel (out, flab)
//
val () = emit_LPAREN (out)
val n0 = aux1_envlst (out, s0es_env, 0)
val () = aux0_arglst (out, s0es_arg, n0, 0)
val () = emit_RPAREN (out)
//
val () = emit_text (out, " end")
//
val () = aux0_envlst (out, s0es_env, 1, 0)
val ((*closing*)) = emit_text (out, "}.\n%}\n")
//
val ((*flushing*)) = emit_newline (out)
//
in
  // nothing
end // end of [emit_closurerize]

end // end of [local]

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

(* end of [atscc2erl_emit.dats] *)

(* ****** ****** *)
//
// Atscc2erl:
// from ATS to Erlang
//
(* ****** ****** *)
//
// HX-2015-06-29: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#define
CATSPARSEMIT_targetloc "./.CATS-parsemit"
//
(* ****** ****** *)
//
staload "{$CATSPARSEMIT}/catsparse.sats"
//
staload "{$CATSPARSEMIT}/catsparse_syntax.sats"
//
staload "{$CATSPARSEMIT}/catsparse_emit.sats"
//
staload "{$CATSPARSEMIT}/catsparse_typedef.sats"
staload "{$CATSPARSEMIT}/catsparse_fundecl.sats"
//
(* ****** ****** *)

local

staload
TM = "libc/SATS/time.sats"
stadef time_t = $TM.time_t

in (* in-of-local *)

implement
emit_time_stamp (out) = let
//
var tm: time_t
val () = tm := $TM.time_get ()
val (pfopt | p_tm) = $TM.localtime (tm)
//
val () = emit_text (out, "%%%%%%\n");
val () = emit_text (out, "%%\n");
val () = emit_text (out, "%% The Erlang code is generated by atscc2erl\n")
val () = emit_text (out, "%% The starting compilation time is: ")
//
val () =
if
p_tm > 0
then let
  prval Some_v @(pf1, fpf1) = pfopt
  val tm_min = $TM.tm_get_min (!p_tm)
  val tm_hour = $TM.tm_get_hour (!p_tm)
  val tm_mday = $TM.tm_get_mday (!p_tm)
  val tm_mon = 1 + $TM.tm_get_mon (!p_tm)
  val tm_year = 1900 + $TM.tm_get_year (!p_tm)
  prval () = fpf1 (pf1)
in
  $extfcall
  (
    void
  , "fprintf"
  , out, "%i-%i-%i: %2ih:%2im\n", tm_year, tm_mon, tm_mday, tm_hour, tm_min
  )
end // end of [then]
else let
  prval None_v () = pfopt
in
  emit_text (out, "**TIME-ERROR**\n")
end // end of [else]
//
val () = emit_text (out, "%%\n")
val () = emit_text (out, "%%%%%%\n")
//
in
  // emit_newline (out)
end // end of [emit_time_stamp]

end // end of [local]

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

implement
emit_PMVint
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVint]
//
implement
emit_PMVintrep
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVintrep]
//
(* ****** ****** *)

implement
emit_PMVbool
  (out, tfv) = (
//
emit_text
( out
, if tfv then "true" else "false"
) (* end of [emit_text] *)
//
) (* end of [emit_PMVbool] *)

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

implement
emit_PMVstring
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVstring]

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

implement
emit_PMVfloat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVfloat]

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

implement
emit_PMVi0nt
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVi0nt]

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

implement
emit_PMVf0loat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVf0loat]

(* ****** ****** *)
//
implement
emit_PMVempty
  (out, _) = emit_text (out, "null")
//
implement
emit_PMVextval
  (out, toks) = emit_tokenlst (out, toks)
//
(* ****** ****** *)
//
extern
fun
f0ide_get_arity (fid: i0de): int
//
implement
f0ide_get_arity
  (fid) = let
//
val
opt =
f0head_search_opt(fid.i0dex_sym)
//
in
//
case+ opt of
| ~None_vt() => ~1
| ~Some_vt(fhd) =>
  (
    case+
    fhd.f0head_node
    of // case+
    | F0HEAD(fid, fma, _) =>
        list_length (fma.f0marg_node)
      // end of [F0HEAD]
  ) (* end of [Some_vt] *)
//
end // end of [f0ide_get_arity]
//
(* ****** ****** *)
//
extern
fun
emit_f0ide
  : emit_type (i0de) = "ext#atscc2erl_emit_f0ide"
extern
fun
emit_flabel
  : emit_type (label) = "ext#atscc2erl_emit_flabel"
//
implement
emit_f0ide
  (out, fid) = let
//
val sym = fid.i0dex_sym
val name = symbol_get_name(sym)
//
val c0 =
  $UN.ptr0_get<char> (string2ptr(name))
//
val () = if c0 = '_' then emit_text(out, "f")
//
in
  emit_symbol(out, sym)
end // end of [emit_f0ide]
//
implement
emit_flabel
  (out, flab) = emit_f0ide (out, flab)
//
(* ****** ****** *)
//
implement
emit_PMVfunlab
  (out, flab) =
{
//
val n0 = f0ide_get_arity(flab)
//
val () = emit_text(out, "fun ")
val () = emit_flabel (out, flab)
val () = (emit_text(out, "/"); emit_int(out, n0))
//
} (* end of [emit_PMVfunlab] *)
//
(* ****** ****** *)

implement
emit_PMVcfunlab
  (out, flab, d0es_env) =
{
//
val () =
  emit_flabel (out, flab)
//
val () =
  emit_text (out, "__closurerize")
//
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es_env)
val () = emit_RPAREN (out)
//
} (* end of [emit_PMVcfunlab] *)

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

implement
emit_CSTSPmyloc
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_CSTSPmyloc]

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

implement
emit_ATSCKiseqz(out, d0e) =
{
//
val () = emit_text (out, "?ATSCKiseqz(")
val () = (emit_d0exp (out, d0e); emit_RPAREN (out))
//
} (* end of [emit_ATSCKiseqz] *)

implement
emit_ATSCKisneqz(out, d0e) =
{
//
val () = emit_text (out, "?ATSCKisneqz(")
val () = (emit_d0exp (out, d0e); emit_RPAREN (out))
//
} (* end of [emit_ATSCKisneqz] *)

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

implement
emit_ATSCKptriscons(out, d0e) =
{
//
val () = emit_text (out, "?ATSCKptriscons(")
val () = (emit_d0exp (out, d0e); emit_RPAREN (out))
//
} (* end of [emit_ATSCKptriscons] *)

implement
emit_ATSCKptrisnull(out, d0e) =
{
//
val () = emit_text (out, "?ATSCKptrisnull(")
val () = (emit_d0exp (out, d0e); emit_RPAREN (out))
//
} (* end of [emit_ATSCKptrisnull] *)

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

implement
emit_ATSCKpat_int
  (out, d0e, i0) =
{
//
val () =
emit_text (out, "?ATSCKpat_int(")
val () = (
  emit_d0exp (out, d0e);
  emit_text (out, ", "); emit_d0exp (out, i0); emit_RPAREN (out)
) (* end of [val] *)
//
} (* end of [emit_ATSCKpat_int] *)

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

implement
emit_ATSCKpat_bool
  (out, d0e, b0) =
{
//
val () =
emit_text (out, "?ATSCKpat_bool(")
val () = (
  emit_d0exp (out, d0e);
  emit_text (out, ", "); emit_d0exp (out, b0); emit_RPAREN (out)
) (* end of [val] *)
//
} (* end of [emit_ATSCKpat_bool] *)

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

implement
emit_ATSCKpat_string
  (out, d0e, s0) =
{
//
val () =
emit_text (out, "?ATSCKpat_string(")
val () = (
  emit_d0exp (out, d0e);
  emit_text (out, ", "); emit_d0exp (out, s0); emit_RPAREN (out)
) (* end of [val] *)
//
} (* end of [emit_ATSCKpat_string] *)

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

implement
emit_ATSCKpat_con0
  (out, d0e, ctag) =
{
//
val () =
emit_text (out, "?ATSCKpat_con0(")
val () = (
  emit_d0exp (out, d0e); emit_text (out, ", "); emit_int (out, ctag); emit_RPAREN (out)
) (* end of [val] *)
//
} (* end of [emit_ATSCKpat_con0] *)

implement
emit_ATSCKpat_con1
  (out, d0e, ctag) =
{
//
val () =
emit_text (out, "?ATSCKpat_con1(")
val () = (
  emit_d0exp (out, d0e); emit_text (out, ", "); emit_int (out, ctag); emit_RPAREN (out)
) (* end of [val] *)
//
} (* end of [emit_ATSCKpat_con1] *)

(* ****** ****** *)
//
implement
emit_tmpvar
  (out, tmp) = let
//
val
sym = tmp.i0dex_sym
val
name =
g1ofg0(symbol_get_name(sym))
//
in
//
if
isneqz(name)
then let
//
  val p0 = string2ptr(name)
  val C0 = toupper($UN.ptr0_get<char>(p0))
//
  val p1 = ptr0_succ<char>(p0)
  val name1 = $UN.cast{string}(p1)
//
in
  emit_char(out, C0); emit_text(out, name1)
end // end of [then]
else () // end of [else]
//
end // end of [emit_tmpvar]
//
(* ****** ****** *)

fun
s0exp_get_arity
  (s0e: s0exp): int =
(
case+
s0e.s0exp_node
of // case+
| S0Elist(s0es) => list_length(s0es) | _ => ~1
) (* end of [s0exp_get_arity] *)

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

implement
emit_d0exp
  (out, d0e0) = let
in
//
case+
d0e0.d0exp_node of
//
| D0Eide (tmp) =>
  {
    val () = emit_tmpvar (out, tmp)
  }
//
| D0Eappid (fid, d0es) =>
  {
    val () = emit_f0ide (out, fid)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
| D0Eappexp (d0e, d0es) =>
  {
    val () = emit_d0exp (out, d0e)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| D0Elist (d0es) =>
  {
    val () = emit_text (out, "D0Elist")
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| ATSPMVint (int) => emit_PMVint (out, int)
| ATSPMVintrep (int) => emit_PMVintrep (out, int)
//
| ATSPMVbool (tfv) => emit_PMVbool (out, tfv)
//
| ATSPMVfloat (flt) => emit_PMVfloat (out, flt)
//
| ATSPMVstring (str) => emit_PMVstring (out, str)
//
| ATSPMVi0nt (int) => emit_PMVi0nt (out, int)
| ATSPMVf0loat (flt) => emit_PMVf0loat (out, flt)
//
| ATSPMVempty (dummy) => emit_PMVempty (out, 0)
| ATSPMVextval (toklst) => emit_PMVextval (out, toklst)
//
| ATSPMVrefarg0 (d0e) => emit_d0exp (out, d0e)
| ATSPMVrefarg1 (d0e) => emit_d0exp (out, d0e)
//
| ATSPMVfunlab (fl) => emit_PMVfunlab (out, fl)
| ATSPMVcfunlab
    (_(*knd*), fl, d0es) => emit_PMVcfunlab (out, fl, d0es)
  // end of [ATSPMVcfunlab]
//
| ATSPMVcastfn
    (_(*fid*), _(*s0e*), arg) => emit_d0exp (out, arg)
//
| ATSCSTSPmyloc (tok) => emit_CSTSPmyloc (out, tok)
//
//
| ATSCKiseqz(d0e) => emit_ATSCKiseqz (out, d0e)
| ATSCKisneqz(d0e) => emit_ATSCKisneqz (out, d0e)
| ATSCKptriscons(d0e) => emit_ATSCKptriscons (out, d0e)
| ATSCKptrisnull(d0e) => emit_ATSCKptrisnull (out, d0e)
//
| ATSCKpat_int
    (d0e, int) => emit_ATSCKpat_int (out, d0e, int)
| ATSCKpat_bool
    (d0e, bool) => emit_ATSCKpat_bool (out, d0e, bool)
| ATSCKpat_string
    (d0e, string) => emit_ATSCKpat_string (out, d0e, string)
//
| ATSCKpat_con0
    (d0e, ctag) => emit_ATSCKpat_con0 (out, d0e, ctag)
| ATSCKpat_con1
    (d0e, ctag) => emit_ATSCKpat_con1 (out, d0e, ctag)
//
| ATSSELcon _ => emit_SELcon (out, d0e0)
| ATSSELrecsin _ => emit_SELrecsin (out, d0e0)
| ATSSELboxrec _ => emit_SELboxrec (out, d0e0)
| ATSSELfltrec _ => emit_text (out, "ATSSELfltrec(...)")
//
| ATSextfcall
    (_fun, _arg) => {
    val () = emit_i0de (out, _fun)
    val () = emit_d0exparg (out, _arg)
  } (* end of [ATSextfcall] *)
| ATSextmcall
    (_obj, _mtd, _arg) => {
//
    val () = emit_d0exp (out, _obj)
    val () = emit_DOT (out)
    val () = emit_d0exp (out, _mtd)
//
    val () = emit_d0exparg (out, _arg)
//
  } (* end of [ATSextmcall] *)
//
| ATSfunclo_fun
  (
    d0e_fun, s0e_arg, _(*res*)
  ) =>
  {
    val () =
    emit_text
      (out, "?ATSfunclo_fun")
    // end of [val]
    val () =
    (
      emit_LPAREN (out); emit_d0exp (out, d0e_fun); emit_RPAREN (out)
    ) (* end of [val] *)
  } (* end of [ATSfunclo_fun] *)
//
| ATSfunclo_clo
  (
    d0e_fun, _(*arg*), _(*res*)
  ) =>
  {
    val () =
    emit_text(out, "?ATSfunclo_clo")
    val () =
    (
      emit_LPAREN (out); emit_d0exp (out, d0e_fun); emit_RPAREN (out)
    ) (* end of [val] *)
  } (* end of [ATSfunclo_clo] *)
//
end // end of [emit_d0exp]

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

local

fun
loop
(
  out: FILEref, d0es: d0explst, i: int
) : void =
(
case+ d0es of
| list_nil () => ()
| list_cons (d0e, d0es) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_d0exp (out, d0e); loop (out, d0es, i+1)
  end // end of [list_cons]
)

in (* in-of-local *)

implement
emit_d0explst (out, d0es) = loop (out, d0es, 0)
implement
emit_d0explst_1 (out, d0es) = loop (out, d0es, 1)

end // end of [local]

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

implement
emit_d0exparg
  (out, d0es) =
{
//
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es)
val () = emit_RPAREN (out)
//
} (* end of [emit_d0exparg] *)

(* ****** ****** *)
//
extern
fun
tyrec_labsel
  (tyrec: tyrec, lab: symbol): int
//
implement
tyrec_labsel
  (tyrec, lab) = let
//
fun loop
(
  xs: tyfldlst, i: int
) : int =
(
case+ xs of
| list_cons (x, xs) => let
    val TYFLD (id, s0e) = x.tyfld_node
  in
    if lab = id.i0dex_sym then i else loop (xs, i+1)
  end // end of [list_cons
| list_nil ((*void*)) => ~1(*error*)
)
//
in
  loop (tyrec.tyrec_node, 0)
end // end of [tyrec_labsel]
//
(* ****** ****** *)

implement
emit_SELcon
  (out, d0e) = let
//
val-
ATSSELcon
  (d0rec, s0e, id) = d0e.d0exp_node
//
val-S0Eide(name) = s0e.s0exp_node
val-~Some_vt(s0rec) = typedef_search_opt(name)
//
val tupi = tyrec_labsel(s0rec, id.i0dex_sym)
//
val () =
emit_text
  (out, "?ATSSELcon")
//
val () = emit_LPAREN (out)
//
val () =
(
  emit_d0exp (out, d0rec); emit_text (out, ", "); emit_int (out, tupi)
) (* end of [val] *)
//
val () = emit_RPAREN (out)
//
in
  // nothing
end // end of [emit_SELcon]

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

implement
emit_SELrecsin
  (out, d0e) = let
//
val-
ATSSELrecsin
  (d0rec, s0e, id) = d0e.d0exp_node
//
in
  emit_d0exp (out, d0rec)
end // end of [emit_SELrecsin]

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

implement
emit_SELboxrec
  (out, d0e) = let
//
val-
ATSSELboxrec
  (d0rec, s0e, id) = d0e.d0exp_node
//
val-S0Eide(name) = s0e.s0exp_node
val-~Some_vt(s0rec) = typedef_search_opt(name)
//
val tupi = tyrec_labsel(s0rec, id.i0dex_sym)
//
val () =
emit_text
  (out, "?ATSSELboxrec")
//
val () = emit_LPAREN (out)
//
val () =
(
  emit_d0exp (out, d0rec); emit_text (out, ", "); emit_int (out, tupi)
) (* end of [val] *)
//
val () = emit_RPAREN (out)
//
in
  // nothing
end // end of [emit_SELboxrec]

(* ****** ****** *)
//
implement
emit_COMMENT_line
  (out, tok) = let
//
val-
T_COMMENT_line
  (str) = tok.token_node
//
in
  emit_text (out, str)
end // end of [emit_COMMENT_line]
//
implement
emit_COMMENT_block
  (out, tok) = let
//
val-
T_COMMENT_block
  (str) = tok.token_node
//
in
  emit_text (out, str)
end // end of [emit_COMMENT_block]
//
(* ****** ****** *)

local

fun
aux0_cenv
(
  out: FILEref
, s0es: s0explst
) : void = let
//
fun
auxlst
(
  i: int, s0es: s0explst
) : void =
(
case+ s0es of
| list_nil() => ()
| list_cons
    (_, s0es) => let
    val () =
      emit_text(out, ", ")
    val () =
    (
      emit_text(out, "Cenv"); emit_int(out, i)
    )
  in
    auxlst(i+1, s0es)
  end // end of [auxlst]
)
//
val () = emit_LBRACE(out)
val () = (emit_text(out, "_"); auxlst(1, s0es))
val () = emit_RBRACE(out)
//
in
  // nothing
end (* end of [aux0_cenv] *)

fun
aux0_arglst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void = (
//
case+ s0es of
| list_nil
    ((*void*)) => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0
      then emit_text (out, ", ")
    // end of [val]
    val () =
    (
      emit_text (out, "XArg"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_arglst (out, s0es, n0, i+1)
  end // end of [list_cons]
//
) (* end of [aux0_arglst] *)

fun
aux0_envlst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void = (
//
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0
      then emit_text (out, ", ")
    // end of [val]
    val () =
    (
      emit_text (out, "XEnv"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_envlst (out, s0es, n0, i+1)
  end // end of [list_cons]
//
) (* end of [aux0_envlst] *)

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

in (* in-of-local *)

implement
emit_closurerize
(
  out, flab, env, arg, res
) = let
//
val-S0Elist(s0es_env) = env.s0exp_node
val-S0Elist(s0es_arg) = arg.s0exp_node
//
val () = emit_ENDL (out)
//
val () =
emit_text (out, "%%fun%%\n")
val () = emit_flabel (out, flab)
val () =
emit_text (out, "__closurerize(")
val () = aux0_envlst (out, s0es_env, 0, 0)
val ((*closing*)) = emit_text (out, ") -> \n")
//
val ((*opening*)) = emit_text (out, "%{\n")
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "{")
val () = emit_text (out, "fun(")
//
val () = aux0_cenv (out, s0es_env)
val () = aux0_arglst (out, s0es_arg, 1, 0)
//
val () = emit_text (out, ") -> ")
//
val () = emit_flabel (out, flab)
//
val () = emit_LPAREN (out)
val n0 = aux1_envlst (out, s0es_env, 0)
val () = aux0_arglst (out, s0es_arg, n0, 0)
val () = emit_RPAREN (out)
//
val () = emit_text (out, " end")
//
val () = aux0_envlst (out, s0es_env, 1, 0)
val ((*closing*)) = emit_text (out, "}.\n%}\n")
//
val ((*flushing*)) = emit_newline (out)
//
in
  // nothing
end // end of [emit_closurerize]

end // end of [local]

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

(* end of [atscc2erl_emit.dats] *)


Updating: improving arduino/QueenPuzzle

Updating: improving arduino/QueenPuzzle

(*
#
# QueenPuzzle
#
*)
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

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

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

(* ****** ****** *)
//
%{^
typedef char *charptr;
%} // end of [%{^]
//
abstype charptr = $extype"charptr"
//
(* ****** ****** *)
//
%{^
#define N 8
int theArray[N] =
{
  0,0,0,0,0,0,0,0
} ;
%} // end of [%{^]
#define N 8
macdef theArray =
  $extval(arrayref(int,N),"theArray")
//
(* ****** ****** *)
//
fnx
find_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n)
) : bool = let
//
fun
loop
(
  i: natLte(n)
) : natLte(n) =
(
if
i < n
then
  if A[i] > 0 then loop (i+1) else i
else n
) (* end of [loop] *)
//
val i0 = loop (0)
//
in
//
if
i0 < n
then
(
  A[i0] := 1; find2_next (A, n, i0)
) (* end of [then] *)
else
(
  A[n-1] := A[n-1] + 1; find2_next (A, n, n-1)
) (* end of [else] *)
//
end // end of [find_next]

and
find2_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n), i: natLt(n)
) : bool = let
//
fun
test
(
  A: arrayref(int, n), i: natLt(n), j: intGte(0)
) : bool =
(
if j >= i then true else
  (if A[i] = A[j] then false else if (i-j=abs(A[i]-A[j])) then false else test (A, i, j+1))
) (* end of [test] *)
//
in
//
if
A[i] <= n
then let
in
//
if test(A, i, 0)
  then
  (if i+1=n then true else find_next(A, n))
  else (A[i] := A[i]+1; find2_next(A, n, i))
//
end // end of [then]
else let
  val () = A[i] := 0
in
  if i > 0 then (A[i-1] := A[i-1]+1; find2_next (A, n, i-1)) else false
end // end of [else]
//
end // end of [find2_next]

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

macdef LEDPIN = 13
macdef BAUD_RATE = 9600

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = () where
{
//
val () = pinMode(LEDPIN, OUTPUT)
val () = Serial_ptr._begin(BAUD_RATE)
//
} (* end of [setup] *)
//
(* ****** ****** *)
//
implement
fprint_val<int>
  (out, x) = let
//
fun
ndot(n: int): void =
if n > 0 then
(
  Serial_ptr.print(". "); ndot(n-1)
) (* end of [if] *)
//
val () = ndot(x-1)
val () = Serial_ptr.print("Q ")
val () = ndot(N-x)
val () = Serial_ptr.println((*void*))
//
in
  // nothing
end // end of [fprint_val]

(* ****** ****** *)
//
implement
fprint_string (out, x) = Serial_ptr.print(x)
//
(* ****** ****** *)
//
implement
fprint_array$sep<> (out) = ()
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
//
implement
loop () =
myloop() where
{
fun
myloop(): void = let
//
val
out = $extval (FILEref, "0")
//
(*
val () =
randomSeed($UN.cast{uint}(millis()))
*)
//
val A = theArray
val found = find_next (A, N)
//
val () =
if found then
{
  val () =
  fprint_arrayref (out, A, i2sz(N))
  val () = Serial_ptr.println()
} (* end of [then] *)
//
val () =
if ~found then
{
//
  val () =
  fprint_string (out, "All solutions are found!")
  val () = Serial_ptr.println()
//
} (* end of [then] *)
//
val () = digitalWrite(LEDPIN, 1)
val () = delay(250)
val () = digitalWrite(LEDPIN, 0)
val () = delay(1000)
//
in
  myloop ()
end // end of [myloop]
//
} (* end of [loop] *)
//
(* ****** ****** *)

(* end of [QueenPuzzle.dats] *)

(*
#
# QueenPuzzle
#
*)
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

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

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

(* ****** ****** *)
//
%{^
typedef char *charptr;
%} // end of [%{^]
//
abstype charptr = $extype"charptr"
//
(* ****** ****** *)
//
%{^
#define N 8
int theArray[N] =
{
  0,0,0,0,0,0,0,0
} ;
%} // end of [%{^]
#define N 8
macdef theArray =
  $extval(arrayref(int,N),"theArray")
//
(* ****** ****** *)
//
fnx
find_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n)
) : bool = let
//
fun
loop
(
  i: natLte(n)
) : natLte(n) =
(
if
i < n
then
  if A[i] > 0 then loop (i+1) else i
else n
) (* end of [loop] *)
//
val i0 = loop (0)
//
in
//
if
i0 < n
then
(
  A[i0] := 1; find2_next (A, n, i0)
) (* end of [then] *)
else
(
  A[n-1] := A[n-1] + 1; find2_next (A, n, n-1)
) (* end of [else] *)
//
end // end of [find_next]

and
find2_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n), i: natLt(n)
) : bool = let
//
fun
test
(
  A: arrayref(int, n), i: natLt(n), j: intGte(0)
) : bool =
(
if j >= i then true else
  (if A[i] = A[j] then false else if (i-j=abs(A[i]-A[j])) then false else test (A, i, j+1))
) (* end of [test] *)
//
in
//
if
A[i] <= n
then let
in
//
if test(A, i, 0)
  then
  (if i+1=n then true else find_next(A, n))
  else (A[i] := A[i]+1; find2_next(A, n, i))
//
end // end of [then]
else let
  val () = A[i] := 0
in
  if i > 0 then (A[i-1] := A[i-1]+1; find2_next (A, n, i-1)) else false
end // end of [else]
//
end // end of [find2_next]

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

macdef LEDPIN = 13
macdef BAUD_RATE = 9600

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = () where
{
//
val () = pinMode(LEDPIN, OUTPUT)
val () = Serial_ptr._begin(BAUD_RATE)
//
} (* end of [setup] *)
//
(* ****** ****** *)
//
implement
fprint_val<int>
  (out, x) = let
//
fun
ndot (n: int): void =
  if n > 0 then (Serial_ptr.print(". "); ndot(n-1))
//
val () = ndot(x-1)
val () = Serial_ptr.print("Q ")
val () = ndot(N-x)
val () = Serial_ptr.println()
//
in
  // nothing
end // end of [fprint_val]

(* ****** ****** *)
//
implement
fprint_string (out, x) = Serial_ptr.print(x)
//
(* ****** ****** *)
//
implement
fprint_array$sep<> (out) = ()
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
//
implement
loop () =
myloop() where
{
fun
myloop(): void = let
//
val
out = $extval (FILEref, "0")
//
(*
val () =
randomSeed($UN.cast{uint}(millis()))
*)
//
val A = theArray
val found = find_next (A, N)
//
val () =
if found then
{
  val () =
  fprint_arrayref (out, A, i2sz(N))
  val () = Serial_ptr.println()
} (* end of [then] *)
//
val () =
if ~found then
{
//
  val () =
  fprint_string (out, "All solutions are found!")
  val () = Serial_ptr.println()
//
} (* end of [then] *)
//
val () = digitalWrite(LEDPIN, 1)
val () = delay(250)
val () = digitalWrite(LEDPIN, 0)
val () = delay(1000)
//
in
  myloop ()
end // end of [myloop]
//
} (* end of [loop] *)
//
(* ****** ****** *)

(* end of [QueenPuzzle.dats] *)


More comments

More comments

%{^
#include "hardware_serial.h"

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

bool ats_serial_transmitting;
%}

#define ATS_DYNLOADFLAG 0 // no dynloading at run-time
#include "config.hats"
#include "{$TOP}/avr_prelude/kernel_staload.hats"

staload "{$TOP}/avr_prelude/SATS/string0.sats"
staload _ = "{$TOP}/avr_prelude/DATS/string0.dats"
staload "{$TOP}/SATS/arduino.sats"
staload "{$TOP}/SATS/hardware_serial.sats"
staload UN = "prelude/SATS/unsafe.sats"

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

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

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

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

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

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

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

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

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

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

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

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

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

  val () = set_transmitting (false)

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

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

implement serial_available () =
  ringbuf_get_size rx_buffer

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

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

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

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

// atspre_print_char
implement print_char (c) = {
    val _ = serial_write c
}

// atspre_print_string
implement print_string (s) = {
  implement{env}
  string0_foreach$fwork
    (c, env) = {val _ = serial_write (c)}
  val _ = string0_foreach s
}

// atspre_print_newline
implement print_newline () = {
    val _ = serial_write ('\r')
    val _ = serial_write ('\n')
    val () = serial_flush ()
}

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

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

%{^
#include "hardware_serial.h"

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

bool ats_serial_transmitting;
%}

#define ATS_DYNLOADFLAG 0 // no dynloading at run-time
#include "config.hats"
#include "{$TOP}/avr_prelude/kernel_staload.hats"

staload "{$TOP}/avr_prelude/SATS/string0.sats"
staload _ = "{$TOP}/avr_prelude/DATS/string0.dats"
staload "{$TOP}/SATS/arduino.sats"
staload "{$TOP}/SATS/hardware_serial.sats"
staload UN = "prelude/SATS/unsafe.sats"

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

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

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

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

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

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

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

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

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

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

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

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

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

  val () = set_transmitting (false)

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

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

implement serial_available () =
  ringbuf_get_size rx_buffer

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

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

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

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

implement print_char (c) = {
    val _ = serial_write c
}

implement print_string (s) = {
  implement{env}
  string0_foreach$fwork
    (c, env) = {val _ = serial_write (c)}
  val _ = string0_foreach s
}

implement print_newline () = {
    val _ = serial_write ('\r')
    val _ = serial_write ('\n')
    val () = serial_flush ()
}

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

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


Updating: very minorly improving

Updating: very minorly improving

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February, 2016
//
(* ****** ****** *)
//
// Following a Promela-example in
// (Spin Model Checker Primer Reference)
//
(* ****** ****** *)

(*
proctype
Agent(chan listen; chan talk)
{
    do
    :: talk!hold(listen)
    :: talk!deny(listen) -> break
    :: talk!grant(listen) ->
        wait:
        listen?return0; break
    od;
    server!return0(listen)
}
*)

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

abstype channel

(* ****** ****** *)
//
extern
fun
channel_recv{a:type}(channel): a
extern
fun
channel_send{a:type}(channel, a): void
//
extern
fun
channel_create(cap: intGte(0)): channel
//
(* ****** ****** *)

extern
fun
channel_is_empty : channel -> bool
extern
fun
channel_isnot_empty : channel -> bool

(* ****** ****** *)
//
datatype
ClientOpt =
  | DENY of ()
  | DENY of (channel)
  | HOLD of (channel)
  | GRANT of (channel)
//
datatype
ClientReply = RETURN0 of ()
//
datatype
ServerOpt =
  | RETURN0 of (channel)
  | REQUEST0 of (channel)
//
(* ****** ****** *)

extern val RANDOM: int

(* ****** ****** *)
//
val
theServer = channel_create(0)
//
(* ****** ****** *)
//
extern
fun
Agent
(
  agent: channel, client: channel
) : void // end of [Agent]
//
(* ****** ****** *)
//
implement
Agent(agent, client) = let
//
fun
loop
( agent: channel
, client: channel
) : void = (
//
case
RANDOM of
| 0 => let
    val () =
    channel_send(client, HOLD(agent))
  in
    loop(agent, client)
  end // end of [_]
| 1 =>
    channel_send(client, DENY(agent))
| _ => let
    val () =
    channel_send(client, GRANT(agent))
    val+RETURN0() =
      channel_recv{ClientReply}(agent)
    // end of [val]
  in
    // break
  end // end of [_]
//
) (* end of [loop] *)
//
val () = loop(agent, client)
//
in
  channel_send(theServer, agent)
end // end of [Agent]
//
(* ****** ****** *)

(*
#define M 2
active [M] proctype Client()
{
    chan me = [0] of { mtype, chan };
    chan agent;
end:
    do
    :: timeout ->
        server!request(me);
        do
        :: me?hold(agent)
        :: me?deny(agent) -> break
        :: me?grant(agent) -> agent!return0; break
        od
    od
}
*)

(* ****** ****** *)
//
extern
fun Client(): void
//
(* ****** ****** *)
//
implement
Client() = let
//
fun
loop
(
  client: channel
) : void =
(
//
case+
RANDOM
of // case
| _ => let
    val () =
    channel_send(theServer, REQUEST0(client))
  in
    loop2(client)
  end // end of [loop]
//
) (* end of [loop] *)
//
and
loop2
(
  client: channel
) : void = let
  val opt = channel_recv{ClientOpt}(client)
in
//
case+ opt of
| DENY() => ()
| DENY(agent) => ()
| HOLD(agent) => loop2(client)
| GRANT(agent) => channel_send(agent, RETURN0())
//
end // end of [loop2]
//
in
  loop(channel_create(0))
end // end of [Client]

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

(*
active
proctype Server()
{
    chan agents[N] = [0] of { mtype };
    chan pool = [N] of { chan };
    chan client, agent;
    byte i;
    do
    :: i < N -> pool!agents[i]; i++
    :: else -> break
    od;
    end:
    do
    :: server?request(client) ->
        if
        :: empty(pool) ->
            client!deny(0)
        :: nempty(pool) ->
            pool?agent;
            run Agent(agent,client)
        fi
    :: server?return0(agent) ->
        pool!agent
    od
}
*)

(* ****** ****** *)
//
extern
fun Server((*void*)): void
//
implement
Server() = let
//
fun
loop
(
  pool: channel
) : void = let
//
val
opt =
channel_recv{ServerOpt}(theServer)
//
in
//
case+ opt of
| RETURN0(agent) => let
    val () =
    channel_send{channel}(pool, agent)
  in
    loop(pool)
  end // end of [RETURN0]
| REQUEST0(client) =>
  if channel_isnot_empty(pool)
    then let
      val agent =
        channel_recv{channel}(pool)
      // end of [val]
      val () = Agent(agent, client)
    in
      loop(pool)
    end // end of [then]
    else let
      val () =
      channel_send(client, DENY((*void*)))
    in
      loop(pool)
    end // end of [else]
//
end // end of [loop]
//
val
pool = channel_create(5)
//
in
  loop(pool)
end // end of [Server]
//
(* ****** ****** *)

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

(* ****** ****** *)
//
// Author: Hongwei Xi
// Authoremail: gmhwxiATgmailDOTcom
// Start time: February, 2016
//
(* ****** ****** *)
//
// Following a Promela-example in
// (Spin Model Checker Primer Reference)
//
(* ****** ****** *)

(*
proctype
Agent(chan listen; chan talk)
{
    do
    :: talk!hold(listen)
    :: talk!deny(listen) -> break
    :: talk!grant(listen) ->
        wait:
        listen?return0; break
    od;
    server!return0(listen)
}
*)

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

abstype channel

(* ****** ****** *)
//
extern
fun
channel_recv{a:type}(channel): a
extern
fun
channel_send{a:type}(channel, a): void
//
extern
fun
channel_create(cap: intGte(0)): channel
//
(* ****** ****** *)

extern
fun
channel_is_empty : channel -> bool
extern
fun
channel_isnot_empty : channel -> bool

(* ****** ****** *)
//
datatype
ClientOpt =
  | DENY of ()
  | DENY of (channel)
  | HOLD of (channel)
  | GRANT of (channel)
//
datatype
ClientReply = RETURN0 of ()
//
datatype
ServerOpt =
  | RETURN0 of (channel)
  | REQUEST0 of (channel)
//
(* ****** ****** *)
//
val
theServer = channel_create(0)
//
(* ****** ****** *)

extern val RANDOM: int

(* ****** ****** *)
//
extern
fun
Agent
(
  agent: channel, client: channel
) : void // end of [Agent]
//
(* ****** ****** *)
//
implement
Agent(agent, client) = let
//
fun
loop
( agent: channel
, client: channel
) : void = (
//
case
RANDOM of
| 0 => let
    val () =
    channel_send(client, HOLD(agent))
  in
    loop(agent, client)
  end // end of [_]
| 1 =>
    channel_send(client, DENY(agent))
| _ => let
    val () =
    channel_send(client, GRANT(agent))
    val+RETURN0() =
      channel_recv{ClientReply}(agent)
    // end of [val]
  in
    // break
  end // end of [_]
//
) (* end of [loop] *)
//
val () = loop(agent, client)
//
in
  channel_send(theServer, agent)
end // end of [Agent]
//
(* ****** ****** *)

(*
#define M 2
active [M] proctype Client()
{
    chan me = [0] of { mtype, chan };
    chan agent;
end:
    do
    :: timeout ->
        server!request(me);
        do
        :: me?hold(agent)
        :: me?deny(agent) -> break
        :: me?grant(agent) -> agent!return0; break
        od
    od
}
*)

(* ****** ****** *)
//
extern
fun Client(): void
//
(* ****** ****** *)
//
implement
Client() = let
//
fun
loop
(
  client: channel
) : void =
(
//
case+
RANDOM
of // case
| _ => let
    val () =
    channel_send(theServer, REQUEST0(client))
  in
    loop2(client)
  end // end of [loop]
//
) (* end of [loop] *)
//
and
loop2
(
  client: channel
) : void = let
  val opt = channel_recv{ClientOpt}(client)
in
//
case+ opt of
| DENY() => ()
| DENY(agent) => ()
| HOLD(agent) => loop2(client)
| GRANT(agent) => channel_send(agent, RETURN0())
//
end // end of [loop2]
//
in
  loop(channel_create(0))
end // end of [Client]

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

(*
active
proctype Server()
{
    chan agents[N] = [0] of { mtype };
    chan pool = [N] of { chan };
    chan client, agent;
    byte i;
    do
    :: i < N -> pool!agents[i]; i++
    :: else -> break
    od;
    end:
    do
    :: server?request(client) ->
        if
        :: empty(pool) ->
            client!deny(0)
        :: nempty(pool) ->
            pool?agent;
            run Agent(agent,client)
        fi
    :: server?return0(agent) ->
        pool!agent
    od
}
*)

(* ****** ****** *)
//
extern
fun Server((*void*)): void
//
implement
Server() = let
//
fun
loop
(
  pool: channel
) : void = let
//
val
opt =
channel_recv{ServerOpt}(theServer)
//
in
//
case+ opt of
| RETURN0(agent) => let
    val () =
    channel_send{channel}(pool, agent)
  in
    loop(pool)
  end // end of [RETURN0]
| REQUEST0(client) =>
  if channel_isnot_empty(pool)
    then let
      val agent =
        channel_recv{channel}(pool)
      // end of [val]
      val () = Agent(agent, client)
    in
      loop(pool)
    end // end of [then]
    else let
      val () =
      channel_send(client, DENY((*void*)))
    in
      loop(pool)
    end // end of [else]
//
end // end of [loop]
//
val
pool = channel_create(5)
//
in
  loop(pool)
end // end of [Server]
//
(* ****** ****** *)

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


Case for unbox tuple has BUG?

Case for unbox tuple has BUG?

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

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

#define LED 9
#define BUTTON 7
#define DELAY_MS 10.0

typedef state_dat = @{ state= natLt(2), brightness= natLt(256), start_time= ulint }
#define STATE_LEDOFF 0
#define STATE_LEDON  1

fun state_transition (sd:state_dat):state_dat = @{ state= state, brightness= br, start_time= start } where {
  val state = case+ sd.state of
              | STATE_LEDOFF => STATE_LEDON
              | STATE_LEDON  => STATE_LEDOFF
  val br = sd.brightness
  val start = millis ()
}

fun state_helddown (sd:state_dat):state_dat = @{ state= state, brightness= br, start_time= start } where {
  val state = sd.state
  val start = sd.start_time
  val t = if (state = STATE_LEDON) && (millis () - sd.start_time > $UN.cast 500)
            then sd.brightness + 1
            else sd.brightness
  val br = if gt_g0int_int (t, 255) then 0 else $UN.cast t
}

fun do_state (b: natLt(2), old_b:natLt(2), sd:state_dat): state_dat =
  if b = HIGH && old_b = LOW then state_transition sd
  else if b = HIGH && old_b = HIGH then state_helddown sd
       else sd

fun do_action (sd:state_dat): void =
  case+ sd.state of
  | STATE_LEDON  => analogWrite(LED, sd.brightness)
  | STATE_LEDOFF => analogWrite(LED, 0)

implement main () = {
  fun loop (old_b:natLt(2), sd:state_dat) = {
    val b = digitalRead (BUTTON)
    val nsd = do_state (b, old_b, sd)
    val () = delay_ms (DELAY_MS)
    val () = do_action nsd
    val () = loop (b, nsd)
  }
  val () = pinMode (LED, OUTPUT)
  val () = pinMode (BUTTON, INPUT)
  val () = loop (LOW, @{ state= STATE_LEDOFF, brightness= 128, start_time= $UN.cast 0 })
}

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

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

#define LED 9
#define BUTTON 7
#define DELAY_MS 10.0

typedef state_dat = @{ state= natLt(2), brightness= natLt(256), start_time= ulint }
#define STATE_LEDOFF 0
#define STATE_LEDON  1

fun state_transition (sd:state_dat):state_dat = @{ state= state, brightness= br, start_time= start } where {
  val state = case+ sd.state of
              | STATE_LEDOFF => STATE_LEDON
              | STATE_LEDON  => STATE_LEDOFF
  val br = sd.brightness
  val start = millis ()
}

fun state_helddown (sd:state_dat):state_dat = @{ state= state, brightness= br, start_time= start } where {
  val state = sd.state
  val start = sd.start_time
  val t = if (state = STATE_LEDON) && (millis () - sd.start_time > $UN.cast 500)
            then sd.brightness + 1
            else sd.brightness
  val br = if gt_g0int_int (t, 255) then 0 else $UN.cast t
}

fun do_state (b: natLt(2), old_b:natLt(2), sd:state_dat): state_dat =
  case+ @(b, old_b) of
  | @(HIGH, LOW)  => state_transition sd
  | @(HIGH, HIGH) => state_helddown sd
  | _ => sd

fun do_action (sd:state_dat): void =
  case+ sd.state of
  | STATE_LEDON  => analogWrite(LED, sd.brightness)
  | STATE_LEDOFF => analogWrite(LED, 0)

implement main () = {
  fun loop (old_b:natLt(2), sd:state_dat) = {
    val b = digitalRead (BUTTON)
    val nsd = do_state (b, old_b, sd)
    val () = delay_ms (DELAY_MS)
    val () = do_action nsd
    val () = loop (b, nsd)
  }
  val () = pinMode (LED, OUTPUT)
  val () = pinMode (BUTTON, INPUT)
  val () = loop (LOW, @{ state= STATE_LEDOFF, brightness= 128, start_time= $UN.cast 0 })
}


Include C raw source code

Include C raw source code

%{^
#include "LPC17xx.h"
%}

%{
volatile int g_LoopDummy;

void c_blink(void)
{
	LPC_GPIO1->FIODIR |= 1 << 18; // P1.18 connected to LED1
	while(1)
	{
		int i;

		LPC_GPIO1->FIOPIN ^= 1 << 18; // Toggle P1.18
		for (i = 0 ; i < 5000000 && !g_LoopDummy ; i++)
		{
		}
	}
}
%}

extern fun c_blink (): void = "mac#"

implement main0 () = c_blink ()


updating jsmn

updating jsmn

%{#
#include "libats-/wdblair/jsmn/CATS/jsmn.cats"
%}

(**
    Will Blair
    December 2015
*)

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

#define
ATS_PACKNAME "ATSCNTRB.jsmn"
#define
ATS_EXTERN_PREFIX "atscntrb_jsmn_" // prefix for external names

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

typedef jsmntype_t = int

macdef JSMN_PRIMITIVE = $extval(jsmntype_t, "JSMN_PRIMITIVE")
macdef JSMN_OBJECT = $extval(jsmntype_t, "JSMN_OBJECT")
macdef JSMN_ARRAY = $extval(jsmntype_t, "JSMN_ARRAY")
macdef JSMN_STRING = $extval(jsmntype_t, "JSMN_STRING")

typedef jsmnerr_t = int

(** Not enough tokens were provided *)
macdef JSMN_ERROR_NOMEM = $extval(jsmnerr_t, "JSMN_ERROR_NOMEM")
(** Invalid character inside JSON string *)
macdef JSMN_ERROR_INVAL = $extval(jsmnerr_t, "JSMN_ERROR_INVAL")
(** The string is not a full JSON packet, more bytes expected *)
macdef JSMN_ERROR_PART = $extval(jsmnerr_t, "JSMN_ERROR_PART")

abst@ype jsmn_parser = $extype "jsmn_parser"
abst@ype jsmntok_t = $extype "jsmntok_t"

abst@ype jsmntokptr = $extype "jsmntok_t*"

fun jsmn_init (&jsmn_parser? >> _): void = "mac#%"

fun jsmn_parse {k,l:addr} {m,n:int} (
    !bytes m @ k, !bytes (sizeof(jsmntok_t)*n) @ l |
        &jsmn_parser, ptr k, size_t m, ptr l, uint n
): jsmnerr_t = "mac#%"

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

fun jsmntok_type (jsmntokptr): jsmntype_t = "mac#%"

overload .type with jsmntok_type

fun jsmntok_size (jsmntokptr): int = "mac#%"

fun jsmntok_start (jsmntokptr): int = "mac#%"

overload .start with jsmntok_start

fun jsmntok_end (jsmntokptr): int = "mac#%"

(**
  The end keyword is reserved.
*)
overload .ending with jsmntok_end

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

(**
    Intended as a way to easily get the source string associated with
    a jsmn token.
*)
fun{}
jsmn_src (): string

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

fun
jsmntokptr_numtokens(jsmntokptr): int

overload .numtokens with jsmntokptr_numtokens

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

// end of [jsmn]

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

%{#
#include "contrib/libats-/wdblair/jsmn/CATS/jsmn.cats"
%}

(**
    Will Blair
    December 2015
*)

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

#define
ATS_PACKNAME "ATSCNTRB.jsmn"
#define
ATS_EXTERN_PREFIX "atscntrb_jsmn_" // prefix for external names

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

typedef jsmntype_t = int

macdef JSMN_PRIMITIVE = $extval(jsmntype_t, "JSMN_PRIMITIVE")
macdef JSMN_OBJECT = $extval(jsmntype_t, "JSMN_OBJECT")
macdef JSMN_ARRAY = $extval(jsmntype_t, "JSMN_ARRAY")
macdef JSMN_STRING = $extval(jsmntype_t, "JSMN_STRING")

typedef jsmnerr_t = int

(** Not enough tokens were provided *)
macdef JSMN_ERROR_NOMEM = $extval(jsmnerr_t, "JSMN_ERROR_NOMEM")
(** Invalid character inside JSON string *)
macdef JSMN_ERROR_INVAL = $extval(jsmnerr_t, "JSMN_ERROR_INVAL")
(** The string is not a full JSON packet, more bytes expected *)
macdef JSMN_ERROR_PART = $extval(jsmnerr_t, "JSMN_ERROR_PART")

abst@ype jsmn_parser = $extype "jsmn_parser"
abst@ype jsmntok_t = $extype "jsmntok_t"

abst@ype jsmntokptr = $extype "jsmntok_t*"

fun jsmn_init (&jsmn_parser? >> _): void = "mac#%"

fun jsmn_parse {k,l:addr} {m,n:int} (
    !bytes m @ k, !bytes (sizeof(jsmntok_t)*n) @ l |
        &jsmn_parser, ptr k, size_t m, ptr l, uint n
): jsmnerr_t = "mac#%"

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

fun jsmntok_type (jsmntokptr): jsmntype_t = "mac#%"

overload .type with jsmntok_type

fun jsmntok_size (jsmntokptr): int = "mac#%"

fun jsmntok_start (jsmntokptr): int = "mac#%"

overload .start with jsmntok_start

fun jsmntok_end (jsmntokptr): int = "mac#%"

(**
  The end keyword is reserved.
*)
overload .ending with jsmntok_end

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

(**
    Intended as a way to easily get the source string associated with
    a jsmn token.
*)
fun{}
jsmn_src (): string

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

fun
jsmntokptr_numtokens(jsmntokptr): int

overload .numtokens with jsmntokptr_numtokens

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

// end of [jsmn]

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


Updating: very minorly fixing

Updating: very minorly fixing

(* ****** ****** *)
//
// CATS-parsemit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload
"./../SATS/catsparse.sats"
staload
"./../SATS/catsparse_parsing.sats"

(* ****** ****** *)
//
implement abort() =
  let val () = ($raise(FatalErrorExn())): void in () end
//
(* ****** ****** *)

(* end of [catsparse_error.dats] *)

(* ****** ****** *)
//
// CATS-parsemit
//
(* ****** ****** *)
//
// HX-2014-07-02: start
//
(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)

staload UN = $UNSAFE

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

staload
"./../SATS/catsparse.sats"
staload
"./../SATS/catsparse_parsing.sats"

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

implement
abort() = $raise(FatalErrorExn())

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

(* end of [catsparse_error.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
**
** A simple GTK example
** involving textview and textbuffer
**
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
** Start Time: April 18, 2014
**
*)

(* ****** ****** *)
//
#define
ATS_PACKNAME "TextProcessing"
//
(* ****** ****** *)

#include "share/atspre_staload.hats"

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

staload
TOPWIN = {
//
typedef T = ptr
//
fun
initize
(x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$HX_GLOBALS}/HATS/globvar.hats"
//
} (* end of [TOPWIN] *)

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

staload
KEYPRESSED = {
//
#include "share/atspre_define.hats"
#include "{$HX_GLOBALS}/HATS/gcount.hats"
//
} (* end of [KEYPRESSED] *)

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

staload
HADJUST = {
//
typedef T = ptr
//
fun
initize
(x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$HX_GLOBALS}/HATS/globvar.hats"
//
} (* end of [HADJUST] *)

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

staload
VADJUST = {
//
typedef T = ptr
//
fun
initize
(x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$HX_GLOBALS}/HATS/globvar.hats"
//
} (* end of [VADJUST] *)

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

staload
TEXTBUF = {
//
typedef T = ptr
//
fun
initize
(x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$HX_GLOBALS}/HATS/globvar.hats"
//
} (* end of [TEXTBUF] *)

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

staload
TEXTBUF2 = {
//
typedef T = ptr
//
fun
initize
(x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$HX_GLOBALS}/HATS/globvar.hats"
//
} (* end of [TEXTBUF2] *)

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

(* end of [TextProcessing_toplevel.dats] *)

(*
**
** A simple GTK example
** involving textview and textbuffer
**
** Author: Hongwei Xi
** Authoremail: gmhwxiATgmailDOTcom
** Start Time: April 18, 2014
**
*)

(* ****** ****** *)
//
#define
ATS_PACKNAME "TextProcessing"
//
(* ****** ****** *)

#include "share/atspre_staload.hats"

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

staload
TOPWIN = {
//
typedef T = ptr
//
fun
initize (x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$LIBATSHWXI}/globals/HATS/globvar.hats"
//
} (* end of [TOPWIN] *)

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

staload
KEYPRESSED = {
//
#include "share/atspre_define.hats"
#include "{$LIBATSHWXI}/globals/HATS/gcount.hats"
//
} (* end of [KEYPRESSED] *)

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

staload
HADJUST = {
//
typedef T = ptr
//
fun
initize (x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$LIBATSHWXI}/globals/HATS/globvar.hats"
//
} (* end of [HADJUST] *)

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

staload
VADJUST = {
//
typedef T = ptr
//
fun
initize (x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$LIBATSHWXI}/globals/HATS/globvar.hats"
//
} (* end of [VADJUST] *)

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

staload
TEXTBUF = {
//
typedef T = ptr
//
fun
initize (x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$LIBATSHWXI}/globals/HATS/globvar.hats"
//
} (* end of [TEXTBUF] *)

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

staload
TEXTBUF2 = {
//
typedef T = ptr
//
fun
initize (x: &T? >> T): void = x := the_null_ptr
//
#include "share/atspre_define.hats"
#include "{$LIBATSHWXI}/globals/HATS/globvar.hats"
//
} (* end of [TEXTBUF2] *)

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

(* end of [TextProcessing_toplevel.dats] *)