(* ****** ****** *)
//
// Atscc2php:
// from ATS to PHP
//
(* ****** ****** *)
//
// HX-2014-08-28: start
// HX-2015-05-22: restructure
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
#if
defined
(
CATSPARSEMIT_targetloc
)
#then
#else
//
#define
CATSPARSEMIT_targetloc "./../CATS-parsemit"
//
#endif // end of [ifdef]
//
(* ****** ****** *)
//
#staload
"{$CATSPARSEMIT}/SATS/catsparse.sats"
#staload
"{$CATSPARSEMIT}/SATS/catsparse_emit.sats"
#staload
"{$CATSPARSEMIT}/SATS/catsparse_syntax.sats"
#staload
"{$CATSPARSEMIT}/SATS/catsparse_typedef.sats"
//
(* ****** ****** *)

local
//
staload
TM =
"libats/libc/SATS/time.sats"
//
typedef 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 PHP code is generated by atscc2php\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"
) (* emit_text *)
) (* end of [emit_PMVbool] *)

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

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

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

implement
emit_PMVstring
  (out, tok) = let
//
(*
    (** Dollar signs inject vars into php strings:
        they need to be escaped.
        Curly brackets are also live, but they should cause
        no issues so long as dollar signs are escaped.

        --m88
    **)
    fun emit_php_string{n:nat} .<n>.
        (out: FILEref, str: string n) : void =
        if string_isnot_empty(str)
        then  case+ str.head() of
                | '$' => (fprint_string(out,"\\$"); 
                          emit_php_string(out,str.tail()))
                |  c  => (fileref_putc(out,c);
                          emit_php_string(out,str.tail()))
        else ()
*)
//
val-
T_STRING(rep) = tok.token_node
//
in
//
ignoret
(
  string_foreach<>(g1ofg0(rep)) 
) where
{
  implement
  (env)//tmp
  string_foreach$fwork<env>
    (c0, env) =
  (
    ifcase
    | c0 = '$' => fprint(out, "\\$")
    | _(*else*) => fprint_char(out, c0)
  )
}
//
end // end of [emit_PMVstring]


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

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, _) =
{
//
val () =
  emit_text(out, "NULL")
//
} (* emit_PMVempty *)
//  
implement
emit_PMVextval
  (out, toks) =
{
//
val () =
  emit_tokenlst(out, toks)
//
} (* emit_PMVextval *)
//
(* ****** ****** *)
//
implement
emit_PMVfunlab
  (out, flab) =
{
  val () = emit_label(out, flab)
}
//
(* ****** ****** *)

implement
emit_PMVcfunlab
  (out, fl, d0es) =
{
//
val () =
  emit_label(out, fl)
val () =
  emit_text(out, "__closurerize")
//
val () = emit_LPAREN(out)
val () = emit_d0explst(out, d0es)
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")
// end of [val]
val () = emit_LPAREN(out)
val () =
(
  emit_d0exp(out, d0e); emit_text(out, ", "); emit_int(out, ctag)
) (* end of [val] *)
val () = emit_RPAREN(out)
//
} (* end of [emit_ATSCKpat_con0] *)

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

(* ****** ****** *)
//
implement
emit_tmpvar
  (out, tmp) = let
//
val
isloc =
tmpvar_is_local(tmp.i0dex_sym)
//
in
//
if (
isloc
) then (
  emit_DOLLAR(out); emit_i0de(out, tmp)
) else (
  emit_text(out, "$GLOBALS['");
  emit_i0de(out, tmp); emit_text (out, "']")
) (* end of [if] *)
//
end (* end of [emit_tmpvar] *)
//
(* ****** ****** *)

implement
emit_d0exp
(out, d0e0) = let
//
(*
val () =
println!
  ("emit_d0exp: d0e0 = ", d0e0)
*)
//
in
//
case+
d0e0.d0exp_node
of (* case+ *)
//
| D0Eide (tmp) => 
  {
    val () = emit_tmpvar(out, tmp)
  }
//
| D0Eappid (fid, d0es) =>
  {
    val () = emit_i0de(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) =>
  {
    val () = emit_PMVint(out, int)
  }
| ATSPMVintrep(int) =>
  {
    val () = emit_PMVintrep(out, int)
  }
//
| ATSPMVbool(tfv) =>
  {
    val () = emit_PMVbool(out, tfv)
  }
//
| ATSPMVfloat(flt) =>
  {
    val () = emit_PMVfloat(out, flt)
  }
//
| ATSPMVstring(str) =>
  {
    val () = emit_PMVstring(out, str)
  }
//
| ATSPMVi0nt(int) =>
  {
    val () = emit_PMVi0nt(out, int)
  }
| ATSPMVf0loat(flt) =>
  {
    val () = emit_PMVf0loat(out, flt)
  }
//
| ATSPMVempty(x) =>
  {
    val () = emit_PMVempty(out, 0)
  }
//
| ATSPMVextval(toks) =>
  {
    val () = emit_PMVextval(out, toks)
  }
//
| ATSPMVrefarg0(d0e) =>
  {
    val () = emit_d0exp(out, d0e)
  }
| ATSPMVrefarg1(d0e) =>
  {
    val () = emit_d0exp(out, d0e)
  }
//
| ATSPMVfunlab(flab) =>
  {
    val () = emit_SQUOTE(out)
    val () = emit_PMVfunlab(out, flab)
    val () = emit_SQUOTE(out)
  } (* end of [ATSPMVfunlab] *)
//
| ATSPMVcfunlab
    (_(*knd*), flab, d0es) =>
  {
    val () = emit_PMVcfunlab(out, flab, d0es)
  } (* end of [ATSPMVcfunlab] *)
//
| ATSPMVcastfn
  (
    _(*fid*), _(*s0e*), arg
  ) =>
  {
    val () = emit_d0exp(out, arg)
  }
//
| ATSCSTSPmyloc
    (tok) => emit_CSTSPmyloc(out, tok)
//
| 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)
//
| ATSCKiseqz(d0e) => emit_ATSCKiseqz(out, d0e)
| ATSCKisneqz(d0e) => emit_ATSCKisneqz(out, d0e)
| ATSCKptriscons(d0e) => emit_ATSCKptriscons(out, d0e)
| ATSCKptrisnull(d0e) => emit_ATSCKptrisnull(out, d0e)
//
| 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_text( out, "->" )
    val () = emit_d0exp(out, _mtd)
//
    val () = emit_d0exparg (out, _arg)
//
  } (* end of [ATSextmcall] *)
//
| ATSfunclo_fun
    (d0e, _(*arg*), _(*res*)) =>
  {
    val () =
    (
      case+
      d0e.d0exp_node
      of (* case+ *)
      | ATSPMVfunlab(fl) => emit_PMVfunlab(out, fl)
      | _(*non-ATSPMVfunlab*) => emit_d0exp(out, d0e)
    ) (* end of [val] *)
  }
| ATSfunclo_clo
    (d0e, _(*arg*), _(*res*)) =>
  (
    emit_d0exp(out, d0e);
    emit_LBRACKET(out); emit_int(out, 0(*fun*)); emit_RBRACKET(out)
  ) (* 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 index = tyrec_labsel (s0rec, id.i0dex_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELcon]

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

implement
emit_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 index = tyrec_labsel (s0rec, id.i0dex_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELboxrec]

(* ****** ****** *)
//
implement
emit_COMMENT_line
  (out, tok) =
  emit_text (out, "// COMMENT_line(...)\n")
//
implement
emit_COMMENT_block
  (out, tok) =
  emit_text (out, "// COMMENT_block(...)\n")
//
(* ****** ****** *)

local

fun
aux0_arglst
(
  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, ", ")
    val () =
    (
      emit_text (out, "$arg"); 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, ", ")
    val () =
    (
      emit_text (out, "$env"); 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 () => (i)
| list_cons
    (s0e, s0es) => let
    val () =
    if i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "$cenv");
      emit_LBRACKET (out); emit_int (out, i+1); emit_RBRACKET (out)
    ) (* 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, fl, env, arg, res
) = let
//
val-S0Elist(s0es_env) = env.s0exp_node
val-S0Elist(s0es_arg) = arg.s0exp_node
//
val () =
emit_text (out, "function\n")
val () = emit_label (out, fl)
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, "return ")
val () = emit_text (out, "array(")
val () = emit_text (out, "function(")
//
val () = emit_text (out, "$cenv")
val () = aux0_arglst (out, s0es_arg, 1, 0)
//
val () = emit_text (out, ") { return ")
//
val () = emit_label (out, fl)
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 ((*closing*)) = emit_text (out, "; }")
//
val () = aux0_envlst (out, s0es_env, 1, 0)
val ((*closing*)) = emit_text (out, ");\n}\n")
//
val () = emit_newline (out)
//
in
  // nothing
end // end of [emit_closurerize]

end // end of [local]

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

(* end of [atscc2php_emit.dats] *)
