(** Tast -> JavaScript, by object mapping. A dialect, not a third target.

    docs/DISCUSS.md item 5 settled the design fork before any of this was
    written, and the settlement is the whole shape of this file: {b a Flan
    struct becomes a plain JS object and a [Vec] becomes a JS array.} The
    alternative — an [ArrayBuffer] standing in for linear memory, with typed
    array reads and writes — is asm.js, which is what wasm exists to replace,
    and it is precisely wrong for a backend whose reason to exist is calling
    JS libraries. Games go to wasm. This is for web apps.

    {1 What this is a dialect of}

    Object mapping means the host's garbage collector owns every value, and
    that is not a detail that can be papered over: {b the memory model does not
    come along.} There are no addresses in JavaScript, so there is no
    [(Ptr T)], no [free], no arena, no allocator and no [with-allocator]. A
    program that uses them is not a program this backend compiles badly — it is
    a program this backend {e refuses}, by name and with a location, which is
    the house rule at [check.ml:14] applied at the one place that can see the
    target. Nothing here approximates.

    The refusals are in [refuse_ty] and in the [unsupported] calls through the
    walk below. Each one names the feature and says which property of the
    object mapping excludes it, because "js: unsupported" is a bug report
    addressed to nobody.

    {1 The mapping, in one table}

    - [i8 i16 i32 u8 u16 u32], an enum, a [bool], [f32], [f64] — a JS number
      (a boolean for [bool]). Every arithmetic result is normalised back into
      the type's range at the site that produced it: see {!section:ints}.
    - [i64] and [u64] — a [BigInt]. A double holds 53 bits exactly and these
      types hold 64, so there is no honest alternative; it is slower and it is
      right, and a wrong number silently is the outcome this repository refuses
      everywhere else.
    - A struct — a plain object, [{x: 1, y: 2}], keyed by the field's own name.
      Readable output is a goal, and this is most of it.
    - [[n T]], a fixed array — a JS array, or a [Uint8Array] when [T] is [u8].
    - [[T]], a slice, and [string] — [{a, o, n}]: the backing store, an offset
      into it and a length. A slice is a non-owning view in Flan and this is a
      non-owning view here: writing through one writes the original, and a
      copy of a slice shares its storage, both of which are what the other two
      backends do with a (ptr, len) pair.
    - A union — [{case: "Name", field: ...}]. [(Option T)] — [null] for
      [None] and [{v: x}] for [Some], so that [(Some 0)] and [None] are not the
      same value, which [0]-as-falsy would make them.
    - [(Fn [..] R)] — a JS function. Function {e values} come along; they carry
      no capture in Flan either.

    {b [string] and [[u8]] are the same representation, and that is not a
    shortcut.} [Tast.Bytes] and [Tast.StrOfBytes] are documented there as
    non-instructions — in both existing backends a [string] {e is} a (ptr, len)
    pair over bytes, and the two prims reinterpret rather than convert. Making
    [string] a JS string would make [(len s)] count UTF-16 code units where
    every other backend counts bytes, and the prelude is byte-oriented
    throughout ([rune-count], [valid-utf8?], [decode-rune] all take [[u8]]).
    So the JS string appears in exactly one place: the argument of
    [$str(...)], where a literal is spelled, and it is UTF-8 encoded on the
    way in. Decoding happens at [write-stdout] and nowhere else.

    The backing store of a [u8] sequence is a [Uint8Array] rather than an
    [Array] — the brief's "honest mapping" — and it buys more than honesty:
    a [Uint8Array] masks on store, so [u8] wrapping is the store itself, and
    it is the type a JS library that wants bytes already accepts.

    {1:copies Value semantics, which is the trap}

    A Flan struct and a fixed array are {e values}: binding, passing,
    returning or storing one copies it, which is what [emit.ml] spends a
    memcpy on at every one of those sites. A JS object assigns by reference.
    Left alone, [(let [b a] ...)] on a struct would alias where the LLVM build
    copied, and a mutation after the copy would diverge — silently, and only
    in a program that actually mutates a copy.

    So every site where [emit.ml] copies, this emits a clone: a [let] binding,
    a [set], a call argument, a [return], a field or element store, a struct
    or array literal's parts, and a [match] arm's binds. A generated
    [Point$copy] per struct does it, recursively, because a field may be a
    struct or an array of them. The clone is skipped where the value is
    already fresh — a literal, a call's result, a new slice — which is what
    keeps the output readable rather than a wall of [$copy].

    A [Vec] is move-only in Flan and owns its storage, so a JS array is the
    right thing for it and aliasing is the right behaviour: the trap is only
    where Flan copies. Slices are views and copy as views, by the same rule.

    {1:ints Integer semantics}

    The known hard part, and the one place a silent wrong number is reachable.
    The rule is that {b every value of type [T] is, at rest, always in [T]'s
    range}, so comparisons, printing and equality need no normalisation of
    their own and only the arithmetic sites do:

    - 32 bits — [| 0] for the signed kinds, [>>> 0] for the unsigned ones, and
      [Math.imul] for a multiply, which is exact modulo 2^32 where [a * b] is
      not.
    - 8 and 16 bits — [<< 24 >> 24], [<< 16 >> 16], [& 0xff], [& 0xffff].
    - 64 bits — [BigInt.asIntN(64, ...)] and [BigInt.asUintN(64, ...)].
    - A shift's count is masked to the operand's width, mirroring [emit.ml]'s
      shift arm, which masks because LLVM makes an over-wide shift poison. The
      mechanism is different — JS already masks a 32-bit shift and does not
      mask an 8-bit one, because it has no 8-bit shift — so the mask is
      written out rather than relied on.
    - A divide truncates toward zero ([Math.trunc], not [| 0], which is only
      the same below 2^31), and a remainder follows C, which JS's [%] already
      does.
    - [f32] rounds through [Math.fround] after every operation, because a JS
      number is a double and a [float] is not.

    A divide by zero, [INT_MIN / -1] and a float-to-integer cast out of range
    all produce the same message and the same exit status [flan_rt.c] does —
    [ArithError]'s unhandled sentence, verbatim, and 134. Without that,
    [(/ x 0)] in JS is [Infinity], and [Infinity | 0] is [0]: a wrong number,
    silently, which is the worst outcome available.

    {1 What is refused, and why each}

    Pointers and [deref], [free], allocators and [with-allocator], [Map],
    [Pool] and [(Handle T)], [declare-c] and the FFI, [embed], conditions and
    restarts ([signal], [handler-bind], [restart-case], [invoke-restart]), and
    the type-erased container runtime's own entry points. The first group has
    no counterpart in a garbage-collected object graph; the FFI and [embed]
    are a host boundary this backend does not have; conditions are a stack
    walk over a transfer channel and are a lane of their own, not a stub.

    {1 Output}

    One CommonJS file, with a small runtime at the top and the program under
    it, ending in [process.exit(main())]. [require] rather than [import] so
    that a bare [node out.js] runs it with no [package.json] to arrange.
    Output goes through [fs.writeSync(1, ...)] rather than
    [process.stdout.write], because node's stdout is asynchronous and a
    [process.exit] after a write on it truncates the output — which would
    look exactly like a codegen bug. *)

exception Unsupported of string

let unsupported fmt = Printf.ksprintf (fun s -> raise (Unsupported s)) fmt

let at loc fmt =
  Printf.ksprintf
    (fun s -> raise (Unsupported (Loc.to_string loc ^ ": " ^ s)))
    fmt

(* ── Names ──────────────────────────────────────────────────────────

   A Flan name is not a JS identifier: [rand-u32], [bytes=?], [append!] and
   [fn/sort-bytes!/0] are all ordinary. The rule below is injective, which is
   what matters — two Flan names must never land on one JS name — and readable
   second: [-] is the common case and becomes [_], so [rand-u32] reads as
   [rand_u32], and an underscore that was actually written becomes [$_] so
   that the two cannot collide. Everything else becomes [$] and two hex
   digits. Nothing the rule produces starts with [$], which is how every
   identifier this file invents for itself stays out of the way. *)

let reserved =
  [ "break"; "case"; "catch"; "class"; "const"; "continue"; "debugger";
    "default"; "delete"; "do"; "else"; "export"; "extends"; "finally"; "for";
    "function"; "if"; "import"; "in"; "instanceof"; "new"; "return"; "super";
    "switch"; "this"; "throw"; "try"; "typeof"; "var"; "void"; "while";
    "with"; "yield"; "let"; "static"; "enum"; "await"; "implements";
    "package"; "protected"; "interface"; "private"; "public"; "null"; "true";
    "false"; "arguments"; "eval"; "undefined"; "NaN"; "Infinity" ]

let ident name =
  let b = Buffer.create (String.length name + 4) in
  String.iter
    (fun c ->
       match c with
       | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> Buffer.add_char b c
       | '-' -> Buffer.add_char b '_'
       | '_' -> Buffer.add_string b "$_"
       | c -> Buffer.add_string b (Printf.sprintf "$%02x" (Char.code c)))
    name;
  let s = Buffer.contents b in
  let s =
    match s.[0] with '0' .. '9' -> "_" ^ s | _ -> s | exception _ -> "_empty"
  in
  if List.mem s reserved then s ^ "_" else s

(* A field or a case name reaches the output as a property. The same rule, so
   that a struct with fields [x] and [x-y] keeps them apart, and so that
   [v.pos_x] reads as the field the source spelled. *)
let prop name = ident name

let fname n = ident n
let gvar n = "g_" ^ ident n

(* ── Types: what the mapping admits ─────────────────────────────────── *)

let rec refuse_ty loc (t : Types.t) =
  match t with
  | Types.Int _ | Types.Float _ | Types.Bool | Types.String | Types.Unit
  | Types.Never | Types.Named _ | Types.Enum _ -> ()
  | Types.Slice t | Types.Array (_, t) | Types.Option t -> refuse_ty loc t
  | Types.Vec t -> refuse_ty loc t
  | Types.Fn (ps, r) -> List.iter (refuse_ty loc) ps; refuse_ty loc r
  | Types.Ptr _ ->
    at loc
      "(Ptr T) is not in the JS dialect — JavaScript has no addresses, so a \
       pointer has nothing to be. Pass the value, or a (Vec T) for storage \
       that is shared"
  | Types.Alloc ->
    at loc
      "Allocator is not in the JS dialect — the host's collector owns every \
       value here, so there is no allocation to direct"
  | Types.Map (_, _) ->
    at loc
      "(Map K V) is not in the JS dialect yet — Odin's open-addressed map is a \
       type-erased runtime over raw bytes and the JS answer is a Map keyed by \
       a structural key, which is its own lane"
  | Types.Pool _ ->
    at loc
      "(Pool T) is not in the JS dialect — a pool hands out slot indices into \
       storage it owns, which is the memory model this dialect leaves behind"
  | Types.Handle _ ->
    at loc
      "(Handle T) is not in the JS dialect — a handle is an index into a Pool, \
       and there is no Pool here"
  | Types.Var n ->
    at loc "a type variable (%s) reached the backend, which cannot happen" n

(* Aggregates in the sense that matters here: the types whose assignment
   copies in Flan and would alias in JS. A slice is deliberately not one —
   it is a view, and a copy of a view shares storage in every backend. *)
let rec is_agg (t : Types.t) =
  match t with
  | Types.Named _ | Types.Array _ -> true
  | Types.Option t -> is_agg t
  | _ -> false

let _ = is_agg

(* ── The emitted runtime ────────────────────────────────────────────

   Small, and every line of it is either a representation decision from the
   header or a message that has to agree with runtime/flan_rt.c character for
   character. The survey diffs stderr, so a reworded sentence here is a
   DIFFER. *)

let runtime =
  {js|"use strict";
// The Flan runtime for the JS dialect. See lib/js.ml for what maps to what.
const $fs = require("fs");

// A slice, a string and a [u8] are one shape: a backing store, an offset and
// a length. The store is a Uint8Array for bytes and an Array otherwise; both
// answer a[i] and both are written through, which is what a view must do.
function $view(a, o, n) { return { a: a, o: o, n: n }; }
function $str(s) { const b = Buffer.from(s, "utf8"); return $view(new Uint8Array(b.buffer, b.byteOffset, b.length), 0, b.length); }
function $bytes(xs) { const a = Uint8Array.from(xs); return $view(a, 0, a.length); }
function $buf(s) {
  const a = s.a;
  return a instanceof Uint8Array ? a.subarray(s.o, s.o + s.n)
                                 : Uint8Array.from(a.slice(s.o, s.o + s.n));
}
function $out(s) { if (s.n > 0) $fs.writeSync(1, $buf(s)); }

// Exit 134 is abort()'s status without abort()'s signal, and stdout is
// written synchronously above, so the message lands after the output that
// led to it exactly as flan_rt.c's fflush(stdout) arranges.
function $die(msg) { $fs.writeSync(2, msg); process.exit(134); }
function $bounds(loc, i, n) {
  $die(loc + ": index " + i + " is out of bounds for length " + n + "\n");
}
function $slicefail(loc, lo, hi, n) {
  $die(loc + ": slice [" + lo + " " + hi + ") is out of bounds for length " + n + "\n");
}
function $divzero(loc, a) { $die(loc + ": divide by zero: (/ " + a + " 0)\n"); }
function $remzero(loc, a) { $die(loc + ": remainder by zero: (% " + a + " 0)\n"); }
function $divovf(loc, op, a, b) {
  $die(loc + ": (" + op + " " + a + " " + b + ") overflows: the quotient is one past the largest value the type holds, and this is the only pair of operands for which that is true\n");
}
function $castrange(loc, lo, hi) {
  $die(loc + ": this value does not fit the integer type it is cast to, which holds [" + lo + " " + hi + "]\n");
}

// Checked indexing and slicing. The comparison is the unsigned one flan_rt.c
// makes: a negative index is a huge length there and out of bounds here.
function $at(s, i, loc) {
  if (i < 0 || i >= s.n) $bounds(loc, i, s.n);
  return s.a[s.o + i];
}
function $set(s, i, v, loc) {
  if (i < 0 || i >= s.n) $bounds(loc, i, s.n);
  s.a[s.o + i] = v;
}
function $slice(s, lo, hi, loc) {
  if (lo > hi || hi > s.n || lo < 0) $slicefail(loc, lo, hi, s.n);
  return $view(s.a, s.o + lo, hi - lo);
}
// A fixed array is its own store; indexing one is the same check without a view.
function $aat(a, i, loc) {
  if (i < 0 || i >= a.length) $bounds(loc, i, a.length);
  return a[i];
}
function $aset(a, i, v, loc) {
  if (i < 0 || i >= a.length) $bounds(loc, i, a.length);
  a[i] = v;
}
function $aslice(a, lo, hi, loc) {
  if (lo > hi || hi > a.length || lo < 0) $slicefail(loc, lo, hi, a.length);
  return $view(a, lo, hi - lo);
}

// %lld and %llu. A BigInt prints its digits and nothing else, which is what
// the two shims in flan_rt.c do.
function $i64s(x) { return $str(String(x)); }
// C's "%g": six significant digits, exponent form outside [1e-4, 1e6), and
// trailing zeros stripped. Written out because String(x) is none of those.
function $g(x) {
  if (Number.isNaN(x)) return "nan";
  if (!Number.isFinite(x)) return x > 0 ? "inf" : "-inf";
  if (x === 0) return Object.is(x, -0) ? "-0" : "0";
  const e = Number(x.toExponential(5).split("e")[1]);
  if (e < -4 || e >= 6) {
    let m = x.toExponential(5).split("e")[0];
    if (m.indexOf(".") >= 0) m = m.replace(/0+$/, "").replace(/\.$/, "");
    const s = e < 0 ? "-" : "+";
    const a = Math.abs(e);
    return m + "e" + s + (a < 10 ? "0" + a : String(a));
  }
  let t = x.toFixed(Math.max(0, 5 - e));
  if (t.indexOf(".") >= 0) t = t.replace(/0+$/, "").replace(/\.$/, "");
  return t;
}
function $f64s(x) { return $str($g(x)); }

// strtoll and strtod over the leading text, which is what the C shims do:
// no digits is 0, and strtoll saturates at the ends of the type.
function $tobytesi64(s) {
  const t = Buffer.from($buf(s)).toString("latin1");
  const m = /^[ \t\n\r\f\v]*[+-]?[0-9]+/.exec(t);
  if (!m) return 0n;
  let v = BigInt(m[0].replace(/^[ \t\n\r\f\v]*/, ""));
  const lo = -(2n ** 63n), hi = 2n ** 63n - 1n;
  return v < lo ? lo : v > hi ? hi : v;
}
function $tobytesf64(s) {
  const t = Buffer.from($buf(s)).toString("latin1");
  const m = /^[ \t\n\r\f\v]*[+-]?(?:[0-9]*\.?[0-9]+(?:[eE][+-]?[0-9]+)?|[0-9]+\.)/.exec(t);
  return m ? parseFloat(m[0]) : 0;
}

// The escape table of flan_escape_bytes, including its 1024-byte buffer and
// its ellipsis, because a printed structure must read the same on both.
function $esc(s) {
  const p = $buf(s);
  const o = [34];
  let cut = 0;
  for (let i = 0; i < p.length; i++) {
    if (o.length + 5 + 4 >= 1024) { cut = 1; break; }
    const c = p[i];
    if (c === 34) { o.push(92, 34); }
    else if (c === 92) { o.push(92, 92); }
    else if (c === 10) { o.push(92, 110); }
    else if (c === 9) { o.push(92, 116); }
    else if (c === 13) { o.push(92, 114); }
    else if (c < 0x20) {
      const h = "\\x" + c.toString(16).padStart(2, "0");
      for (let k = 0; k < h.length; k++) o.push(h.charCodeAt(k));
    } else o.push(c);
  }
  if (cut) o.push(46, 46, 46);
  o.push(34);
  return $bytes(o);
}

function $argv() {
  const xs = process.argv.slice(1).map($str);
  return $view(xs, 0, xs.length);
}
|js}

(* ── The module state ───────────────────────────────────────────────── *)

type m = {
  out : Buffer.t;                       (* the program text *)
  structs : (string, Tast.structure) Hashtbl.t;
  unions : (string, Tast.union) Hashtbl.t;
  checks : bool;
  mutable strs : (string * string) list; (* literal -> its const name *)
  mutable nstr : int;
  mutable copies : string list;          (* struct names needing a $copy *)
  mutable tags : string list;            (* union names needing a $tag *)
}

type f = {
  md : m;
  b : Buffer.t;
  mutable ind : int;
  mutable n : int;                       (* temporaries *)
  names : string array;                  (* slot index -> JS name *)
  slots : Types.t array;
  ret : Types.t;
  mutable loops : (string * string) list; (* break label, continue label *)
}

let line f fmt =
  Printf.ksprintf
    (fun s ->
       Buffer.add_string f.b (String.make (f.ind * 2) ' ');
       Buffer.add_string f.b s;
       Buffer.add_char f.b '\n')
    fmt

let fresh f = f.n <- f.n + 1; Printf.sprintf "t%d" f.n

(* A JS string literal for a run of bytes. Printable ASCII stays readable;
   anything else goes out as numbers, because the output file's own encoding
   must not decide what a byte literal meant. *)
let js_string s =
  let b = Buffer.create (String.length s + 2) in
  Buffer.add_char b '"';
  String.iter
    (fun c ->
       match c with
       | '"' -> Buffer.add_string b "\\\""
       | '\\' -> Buffer.add_string b "\\\\"
       | '\n' -> Buffer.add_string b "\\n"
       | '\t' -> Buffer.add_string b "\\t"
       | '\r' -> Buffer.add_string b "\\r"
       | c when Char.code c >= 0x20 && Char.code c < 0x7f -> Buffer.add_char b c
       | c -> Buffer.add_string b (Printf.sprintf "\\u%04x" (Char.code c)))
    s;
  Buffer.add_char b '"';
  Buffer.contents b

let printable s =
  let ok = ref true in
  String.iter
    (fun c -> if Char.code c < 0x20 || Char.code c >= 0x7f then ok := false)
    s;
  !ok

(* Literals are interned: one const per distinct text, built once at load, so
   that a string in a loop is not re-encoded per iteration and so that the
   identity of a literal is stable the way a .rodata address is. *)
let string_const m s =
  match List.assoc_opt s m.strs with
  | Some n -> n
  | None ->
    let n = Printf.sprintf "$s%d" m.nstr in
    m.nstr <- m.nstr + 1;
    m.strs <- (s, n) :: m.strs;
    n

let locstr loc = js_string (Loc.to_string loc)

(* ── Copying a value ────────────────────────────────────────────────

   See the header's "Value semantics" section. [copy_of] is the JS expression
   that produces a private copy of [v] at type [t], and [None] means the type
   copies by assignment already. *)

let rec copy_of m (t : Types.t) v =
  match t with
  | Types.Named n when Hashtbl.mem m.structs n ->
    if not (List.mem n m.copies) then m.copies <- n :: m.copies;
    Some (Printf.sprintf "%s$copy(%s)" (ident n) v)
  | Types.Named n when Hashtbl.mem m.unions n ->
    if not (List.mem n m.copies) then m.copies <- n :: m.copies;
    Some (Printf.sprintf "%s$copy(%s)" (ident n) v)
  | Types.Array (_, e) -> (
    match copy_of m e "x" with
    | None -> Some (Printf.sprintf "%s.slice()" v)
    | Some c -> Some (Printf.sprintf "%s.map((x) => %s)" v c))
  | Types.Option e -> (
    match copy_of m e "x" with
    | None -> None
    | Some c ->
      Some (Printf.sprintf "(%s === null ? null : { v: ((x) => %s)(%s.v) })" v c v))
  | _ -> None

(* A value that was just built is already private; cloning it would be a copy
   of a copy. Everything else may be a second name for storage someone else
   holds. A call's result is fresh because [return] clones on the way out. *)
let rec fresh_value (e : Tast.expr) =
  match e.Tast.e with
  | Tast.Make _ | Tast.Arr _ | Tast.Zero _ | Tast.Uninit _ | Tast.Call _
  | Tast.CallPtr _ | Tast.MakeCase _ | Tast.Int _ | Tast.Float _
  | Tast.Bool _ | Tast.Str _ | Tast.Unit | Tast.None_ -> true
  | Tast.Some_ v -> fresh_value v
  | Tast.Prim (Tast.Rt _, _) -> true
  | _ -> false

(* ── Integer normalisation ──────────────────────────────────────────── *)

let big k = match k with Types.I64 | Types.U64 -> true | _ -> false

(* Put an expression back inside its type's range. The header's table.

   [s] is parenthesised first, and that is not decoration: [>>>] binds tighter
   than [&], [|] and [^] in JavaScript, so [a & b >>> 0] is [a & (b >>> 0)] and
   a [bit-and] on a [u32] would answer -1 where the other backends answer
   4294967295. The probe caught exactly that. *)
let norm (k : Types.ikind) s =
  let s = "(" ^ s ^ ")" in
  match k with
  | Types.I64 -> Printf.sprintf "BigInt.asIntN(64, %s)" s
  | Types.U64 -> Printf.sprintf "BigInt.asUintN(64, %s)" s
  | Types.I32 -> Printf.sprintf "(%s | 0)" s
  | Types.U32 -> Printf.sprintf "(%s >>> 0)" s
  | Types.I16 -> Printf.sprintf "((%s) << 16 >> 16)" s
  | Types.U16 -> Printf.sprintf "((%s) & 0xffff)" s
  | Types.I8 -> Printf.sprintf "((%s) << 24 >> 24)" s
  | Types.U8 -> Printf.sprintf "((%s) & 0xff)" s

let fround (k : Types.fkind) s =
  match k with Types.F32 -> Printf.sprintf "Math.fround(%s)" s | Types.F64 -> s

(* The literal spelling of an integer of a given kind: a BigInt gets its [n]. *)
let int_lit k (v : int64) =
  match k with
  | Types.I64 -> Printf.sprintf "%Ldn" v
  | Types.U64 ->
    if Int64.compare v 0L >= 0 then Printf.sprintf "%Ldn" v
    else Printf.sprintf "%sn" (Printf.sprintf "%Lu" v)
  | Types.U32 | Types.U16 | Types.U8 ->
    Printf.sprintf "%Ld" (Int64.logand v (Int64.of_int 0xffffffff))
  | _ -> Printf.sprintf "%Ld" v

let float_lit (x : float) =
  if Float.is_integer x && Float.abs x < 1e21 then Printf.sprintf "%.1f" x
  else if Float.is_nan x then "NaN"
  else if x = Float.infinity then "Infinity"
  else if x = Float.neg_infinity then "-Infinity"
  else
    (* Shortest round-tripping decimal. OCaml's %.17g always round-trips; the
       shorter spellings are tried first so the output stays readable. *)
    let rec go p =
      if p > 17 then Printf.sprintf "%.17g" x
      else
        let s = Printf.sprintf "%.*g" p x in
        if float_of_string s = x then s else go (p + 1)
    in
    go 1

(* ── Zero of a type, which is ZII settled here ──────────────────────── *)

let rec zero m loc (t : Types.t) =
  refuse_ty loc t;
  match t with
  | Types.Int k -> if big k then "0n" else "0"
  | Types.Float _ -> "0.0"
  | Types.Bool -> "false"
  | Types.Enum _ -> "0"
  | Types.Unit -> "undefined"
  | Types.String | Types.Slice _ -> "$view([], 0, 0)"
  | Types.Option _ -> "null"
  | Types.Array (n, e) ->
    (match e with
     | Types.Int Types.U8 -> Printf.sprintf "new Uint8Array(%Ld)" n
     | _ ->
       (* The parentheses are not decoration: an arrow whose body starts with
          a brace is parsed as a block, so [() => { x: 0 }] is a label and a
          syntax error rather than an object. *)
       Printf.sprintf "Array.from({ length: %Ld }, () => (%s))" n
         (zero m loc e))
  | Types.Named n when Hashtbl.mem m.structs n ->
    let s = Hashtbl.find m.structs n in
    Printf.sprintf "{ %s }"
      (String.concat ", "
         (List.map
            (fun (fl : Tast.field) ->
               Printf.sprintf "%s: %s" (prop fl.Tast.fname)
                 (zero m loc fl.Tast.fty))
            s.Tast.fields))
  | Types.Named n when Hashtbl.mem m.unions n ->
    (* Declaration order from zero is the tag, so an all-bytes-zero union is
       the first case with a zeroed payload. Tast.case_index says so. *)
    let u = Hashtbl.find m.unions n in
    (match u.Tast.cases with
     | [] -> at loc "union %s has no cases" n
     | c :: _ ->
       Printf.sprintf "{ case: %s%s }" (js_string c.Tast.vname)
         (String.concat ""
            (List.map
               (fun (fl : Tast.field) ->
                  Printf.sprintf ", %s: %s" (prop fl.Tast.fname)
                    (zero m loc fl.Tast.fty))
               c.Tast.vfields)))
  | Types.Fn _ -> "null"
  | Types.Vec _ -> "[]"
  | t -> at loc "no zero value for %s in the JS dialect" (Types.to_string t)

(* ── Places and expressions ─────────────────────────────────────────── *)

let struct_of m loc (t : Types.t) =
  match t with
  | Types.Named n when Hashtbl.mem m.structs n -> Hashtbl.find m.structs n
  | t -> at loc "a field of %s, which is not a struct" (Types.to_string t)

let elem_ty loc (t : Types.t) =
  match t with
  | Types.Slice e | Types.Array (_, e) -> e
  | Types.String -> Types.Int Types.U8
  | t -> at loc "indexing %s is not in the JS dialect" (Types.to_string t)

let is_bytes (t : Types.t) =
  match t with
  | Types.String -> true
  | Types.Slice (Types.Int Types.U8) | Types.Array (_, Types.Int Types.U8) ->
    true
  | _ -> false

let rec value f (e : Tast.expr) : string =
  refuse_ty e.Tast.loc e.Tast.ty;
  match e.Tast.e with
  | Tast.Int (v, k) ->
    (match e.Tast.ty with
     | Types.Enum _ -> Printf.sprintf "%Ld" v
     | _ -> int_lit k v)
  | Tast.Float (x, _) -> float_lit x
  | Tast.Bool b -> if b then "true" else "false"
  | Tast.Str s ->
    let n = string_const f.md s in
    n
  | Tast.Unit -> "undefined"
  | Tast.Zero t -> zero f.md e.Tast.loc t
  (* [uninit] is the opt-out from zeroing. There is no uninitialised memory
     here to opt out of, so it is the zero — which is more than the program
     asked for and never less. *)
  | Tast.Uninit t -> zero f.md e.Tast.loc t
  | Tast.Local i -> f.names.(i)
  | Tast.Global n -> gvar n
  | Tast.FnAddr (Tast.Flanfn n) | Tast.FnAddr (Tast.Fnval n) -> fname n
  | Tast.FnAddr (Tast.Rtfn n) ->
    at e.Tast.loc
      "the runtime entry point %s has no JS counterpart — it is C in \
       flan_rt.c, and this dialect has no C"
      n
  | Tast.Prim (p, args) -> prim f e p args
  | Tast.Call (n, args) ->
    Printf.sprintf "%s(%s)" (fname n) (String.concat ", " (call_args f args))
  | Tast.CallPtr (fn, args) ->
    let fv = spill f fn in
    Printf.sprintf "%s(%s)" fv (String.concat ", " (call_args f args))
  (* [Field] is a struct's field almost everywhere, and [Render] is the
     exception: the structural printer reads an [Option]'s tag as field 0 and
     its payload as field 1, and a union's tag as field 0, because that is the
     LLVM layout. Neither shape exists here — an Option is null-or-a-box and a
     union carries its case by name — so both are answered rather than
     refused, and a union's tag goes through a generated [Shape$tag] that maps
     the name back to the declaration order [Tast.case_index] fixed. *)
  | Tast.Field (x, i) -> (
    match x.Tast.ty with
    | Types.Option _ ->
      let v = spill f x in
      if i = 0 then Printf.sprintf "(%s === null ? 0 : 1)" v
      else Printf.sprintf "%s.v" v
    | Types.Named n when Hashtbl.mem f.md.unions n ->
      if i <> 0 then
        at e.Tast.loc "field %d of the union %s, which has only a tag" i n;
      if not (List.mem n f.md.tags) then f.md.tags <- n :: f.md.tags;
      Printf.sprintf "%s$tag(%s)" (ident n) (spill f x)
    | _ ->
      let s = struct_of f.md e.Tast.loc x.Tast.ty in
      let fl = List.nth s.Tast.fields i in
      Printf.sprintf "%s.%s" (spill f x) (prop fl.Tast.fname))
  | Tast.CaseField (x, case, i) ->
    let n =
      match x.Tast.ty with
      | Types.Named n -> n
      | t -> at e.Tast.loc "case field of %s" (Types.to_string t)
    in
    let u = Hashtbl.find f.md.unions n in
    (match Tast.case_index u case with
     | Some (_, c) ->
       Printf.sprintf "%s.%s" (spill f x)
         (prop (List.nth c.Tast.vfields i).Tast.fname)
     | None -> at e.Tast.loc "no case %s of %s" case n)
  | Tast.Make (n, parts) ->
    let s = Hashtbl.find f.md.structs n in
    let vs = List.map (fun p -> bind_value f p) parts in
    Printf.sprintf "{ %s }"
      (String.concat ", "
         (List.map2
            (fun (fl : Tast.field) v ->
               Printf.sprintf "%s: %s" (prop fl.Tast.fname) v)
            s.Tast.fields vs))
  | Tast.MakeCase (n, case, parts) ->
    let u = Hashtbl.find f.md.unions n in
    (match Tast.case_index u case with
     | None -> at e.Tast.loc "no case %s of %s" case n
     | Some (_, c) ->
       let vs = List.map (fun p -> bind_value f p) parts in
       Printf.sprintf "{ case: %s%s }" (js_string case)
         (String.concat ""
            (List.map2
               (fun (fl : Tast.field) v ->
                  Printf.sprintf ", %s: %s" (prop fl.Tast.fname) v)
               c.Tast.vfields vs)))
  | Tast.Arr parts ->
    let vs = List.map (fun p -> bind_value f p) parts in
    (match e.Tast.ty with
     | Types.Array (_, Types.Int Types.U8) ->
       Printf.sprintf "Uint8Array.of(%s)" (String.concat ", " vs)
     | _ -> Printf.sprintf "[%s]" (String.concat ", " vs))
  | Tast.Some_ v -> Printf.sprintf "{ v: %s }" (bind_value f v)
  | Tast.None_ -> "null"
  | Tast.Addr _ | Tast.Deref _ ->
    at e.Tast.loc
      "an address is not in the JS dialect — JavaScript has no addresses, so \
       (addr-of x) and a deref have nothing to name"
  | Tast.Signal _ ->
    at e.Tast.loc
      "signalling a condition is not in the JS dialect yet — the handler \
       stack and the transfer channel are a lane of their own"
  | Tast.Handled _ ->
    at e.Tast.loc
      "handler-bind is not in the JS dialect yet — the handler stack and the \
       transfer channel are a lane of their own"
  | Tast.RestartCase _ ->
    at e.Tast.loc
      "restart-case is not in the JS dialect yet — a restart is a frame on a \
       stack this backend does not build"
  | Tast.InvokeRestart _ ->
    at e.Tast.loc
      "invoke-restart is not in the JS dialect yet — a restart is a frame on \
       a stack this backend does not build"
  | Tast.WithAlloc _ ->
    at e.Tast.loc
      "with-allocator is not in the JS dialect — the host's collector owns \
       every value here, so there is no allocator to rebind"
  (* Everything below is statement-shaped: it needs a temporary to be a value.
     [stmt] writes into the name this hands it. *)
  | Tast.Do _ | Tast.Let _ | Tast.If _ | Tast.While _ | Tast.Match _
  | Tast.UnwrapSome _ | Tast.Set _ | Tast.Return _ | Tast.Break _
  | Tast.Continue _ ->
    if Types.equal e.Tast.ty Types.Unit || Types.equal e.Tast.ty Types.Never
    then begin
      stmt f None e;
      "undefined"
    end
    else begin
      let t = fresh f in
      line f "let %s;" t;
      stmt f (Some t) e;
      t
    end

(* An expression whose JS text has no side effect and no evaluation order to
   respect. Used to decide whether an operand has to go through a temporary
   before the next one is compiled. *)
and simple (e : Tast.expr) =
  match e.Tast.e with
  | Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit
  | Tast.Local _ | Tast.Global _ | Tast.None_ | Tast.FnAddr _ -> true
  | Tast.Field (x, _) | Tast.CaseField (x, _, _) -> simple x
  | _ -> false

(* Evaluate into a name if the expression is not already one. *)
and spill f (e : Tast.expr) =
  if simple e then value f e
  else begin
    let t = fresh f in
    line f "const %s = %s;" t (value f e);
    t
  end

(* A list of expressions, left to right, with the order preserved: once one of
   them has to emit a statement, every operand before it is already in a
   temporary, so nothing is re-ordered. *)
and evals f (es : Tast.expr list) =
  let rec go acc = function
    | [] -> List.rev acc
    | [ last ] -> List.rev (value f last :: acc)
    | e :: rest ->
      let v = if simple e then value f e else spill f e in
      go (v :: acc) rest
  in
  go [] es

(* A value about to be bound to something that outlives the expression. See
   the header's "Value semantics". *)
and bind_value f (e : Tast.expr) =
  let v = value f e in
  if fresh_value e then v
  else match copy_of f.md e.Tast.ty v with Some c -> c | None -> v

and call_args f (args : Tast.expr list) =
  let vs = evals f args in
  List.map2
    (fun (a : Tast.expr) v ->
       if fresh_value a then v
       else match copy_of f.md a.Tast.ty v with Some c -> c | None -> v)
    args vs

(* ── Primitives ─────────────────────────────────────────────────────── *)

and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
  let loc = e.Tast.loc in
  match (p, args) with
  | (Tast.Add | Tast.Sub | Tast.Mul | Tast.Div | Tast.Rem), [ x; y ] ->
    arith f e p x y
  | (Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge), [ x; y ] ->
    let op =
      match p with
      | Tast.Eq -> "===" | Tast.Ne -> "!==" | Tast.Lt -> "<"
      | Tast.Le -> "<=" | Tast.Gt -> ">" | _ -> ">="
    in
    (match evals f [ x; y ] with
     | [ a; b ] -> Printf.sprintf "(%s %s %s)" a op b
     | _ -> assert false)
  | Tast.Not, [ x ] -> Printf.sprintf "(!%s)" (value f x)
  | (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ]
    -> bitwise f e p x y
  | Tast.Len, [ x ] -> (
    match x.Tast.ty with
    | Types.Array (n, _) -> Printf.sprintf "%Ld" n
    | Types.String | Types.Slice _ -> Printf.sprintf "%s.n" (spill f x)
    | t -> at loc "(len %s) is not in the JS dialect" (Types.to_string t))
  | Tast.At, target :: idx -> index f loc target idx
  | Tast.Slice, [ target; lo; hi ] -> (
    match evals f [ target; lo; hi ] with
    | [ t; a; b ] ->
      let fn = match target.Tast.ty with
        | Types.Array _ -> "$aslice" | _ -> "$slice"
      in
      Printf.sprintf "%s(%s, %s, %s, %s)" fn t a b (locstr loc)
    | _ -> assert false)
  | Tast.SliceFromPtr, _ ->
    at loc
      "(slice-from-ptr p n) is not in the JS dialect — it makes a slice out of \
       an address, and JavaScript has no addresses"
  (* [Bytes] and [StrOfBytes] are reinterprets in every backend: a string is a
     run of bytes here as it is there. See the header. *)
  | (Tast.Bytes | Tast.StrOfBytes), [ x ] -> value f x
  | Tast.BytesToF64, [ x ] -> Printf.sprintf "$tobytesf64(%s)" (value f x)
  | Tast.BytesToI64, [ x ] -> Printf.sprintf "$tobytesi64(%s)" (value f x)
  | Tast.F64ToBytes, [ x ] -> Printf.sprintf "$f64s(%s)" (value f x)
  | (Tast.I64ToBytes | Tast.U64ToBytes), [ x ] ->
    Printf.sprintf "$i64s(%s)" (value f x)
  | Tast.EscapeBytes, [ x ] -> Printf.sprintf "$esc(%s)" (value f x)
  | Tast.WriteStdout, [ x ] -> Printf.sprintf "$out(%s)" (value f x)
  | Tast.Exit, [ x ] ->
    Printf.sprintf "process.exit(Number(%s))" (value f x)
  | Tast.Argv, [] -> "$argv()"
  | Tast.Cast t, [ x ] -> cast f loc t x
  | Tast.AddrOf, _ ->
    at loc
      "(addr-of x) is not in the JS dialect — JavaScript has no addresses"
  | (Tast.SizeOf _ | Tast.AlignOf _), _ ->
    at loc
      "a size or an alignment is not in the JS dialect — an object has no \
       layout here, which is the whole point of the object mapping"
  | Tast.Rt sym, _ ->
    at loc
      "%s is the type-erased container runtime, which is C in flan_rt.c — the \
       JS dialect has no counterpart for it yet"
      sym
  | _ -> at loc "this primitive is not in the JS dialect yet"

(* [(at grid y x)] is one node with a list of indices, innermost last. Each
   step but the last goes through a temporary, because the element it names is
   the container the next step indexes. *)
and index f loc target idxs =
  let tv = spill f target in
  (* The location on the check is the *index expression's*, not the form's:
     emit.ml's [element_addr] passes [i.Tast.loc] to [check_at], and the
     survey diffs stderr, so a bounds message that names a different column is
     a DIFFER. [slice] is the other way round and uses the form's, which is
     why the two are not shared. *)
  let step base (bty : Types.t) (i : Tast.expr) iv =
    let fn = match bty with Types.Array _ -> "$aat" | _ -> "$at" in
    if f.md.checks then
      Printf.sprintf "%s(%s, %s, %s)" fn base iv (locstr i.Tast.loc)
    else
      match bty with
      | Types.Array _ -> Printf.sprintf "%s[%s]" base iv
      | _ -> Printf.sprintf "%s.a[%s.o + %s]" base base iv
  in
  let rec go base bty = function
    | [] -> base
    | [ i ] -> step base bty i (value f i)
    | i :: rest ->
      let one = step base bty i (value f i) in
      let t = fresh f in
      line f "const %s = %s;" t one;
      go t (elem_ty loc bty) rest
  in
  go tv target.Tast.ty idxs

and arith f (e : Tast.expr) p x y =
  let loc = e.Tast.loc in
  let a, b =
    match evals f [ x; y ] with [ a; b ] -> (a, b) | _ -> assert false
  in
  match e.Tast.ty with
  | Types.Float k ->
    let op =
      match p with
      | Tast.Add -> "+" | Tast.Sub -> "-" | Tast.Mul -> "*"
      | Tast.Div -> "/" | _ -> "%"
    in
    fround k (Printf.sprintf "(%s %s %s)" a op b)
  | Types.Int k ->
    (match p with
     | Tast.Add -> norm k (Printf.sprintf "%s + %s" a b)
     | Tast.Sub -> norm k (Printf.sprintf "%s - %s" a b)
     | Tast.Mul ->
       if big k then norm k (Printf.sprintf "%s * %s" a b)
       else
         (* Math.imul is exact modulo 2^32 where a * b loses the low bits
            once the product passes 2^53. Every kind below 32 bits is exact
            in it too, since the mask that follows only keeps low bits. *)
         norm k (Printf.sprintf "Math.imul(%s, %s)" a b)
     | Tast.Div | Tast.Rem ->
       let is_rem = p = Tast.Rem in
       check_div f loc k ~is_rem a b;
       if is_rem then norm k (Printf.sprintf "%s %% %s" a b)
       else if big k then norm k (Printf.sprintf "%s / %s" a b)
       else norm k (Printf.sprintf "Math.trunc(%s / %s)" a b)
     | _ -> assert false)
  | t -> at loc "arithmetic on %s" (Types.to_string t)

(* The two tests emit.ml's [check_div] emits, with the same elisions: a
   literal divisor that cannot be zero needs no zero test, and one that cannot
   be -1 needs no overflow test. The sentences are flan_rt.c's, verbatim,
   because the survey diffs stderr. *)
and check_div f loc (k : Types.ikind) ~is_rem a b =
  if f.md.checks then begin
    let zero_lit = if big k then "0n" else "0" in
    let neg1 = if big k then "-1n" else "-1" in
    let need_zero = not (b = zero_lit) in
    let need_ovf = Types.signed k && b <> zero_lit in
    if need_zero then
      line f "if (%s === %s) $%s(%s, %s);" b zero_lit
        (if is_rem then "remzero" else "divzero")
        (locstr loc) a;
    if need_ovf then begin
      let lo =
        let bits = Types.bits k in
        if bits = 64 then "-9223372036854775808n"
        else Printf.sprintf "%d" (-(1 lsl (bits - 1)))
      in
      line f "if (%s === %s && %s === %s) $divovf(%s, %s, %s, %s);" a lo b neg1
        (locstr loc)
        (js_string (if is_rem then "%" else "/"))
        a b
    end
  end

and bitwise f (e : Tast.expr) p x y =
  let a, b =
    match evals f [ x; y ] with [ a; b ] -> (a, b) | _ -> assert false
  in
  let k =
    match x.Tast.ty with
    | Types.Int k -> k
    | t -> at e.Tast.loc "a bitwise operation on %s" (Types.to_string t)
  in
  (* The count is masked to the operand's width, mirroring emit.ml's shift
     arm. JS masks a 32-bit shift itself and has no 8- or 16-bit shift at
     all, so the mask is written rather than relied on. *)
  let b =
    match p with
    | Tast.Shl | Tast.Shr ->
      if big k then Printf.sprintf "(%s & %dn)" b (Types.bits k - 1)
      else Printf.sprintf "(%s & %d)" b (Types.bits k - 1)
    | _ -> b
  in
  match p with
  | Tast.BitAnd -> norm k (Printf.sprintf "%s & %s" a b)
  | Tast.BitOr -> norm k (Printf.sprintf "%s | %s" a b)
  | Tast.BitXor -> norm k (Printf.sprintf "%s ^ %s" a b)
  | Tast.Shl -> norm k (Printf.sprintf "%s << %s" a b)
  | Tast.Shr ->
    if big k then norm k (Printf.sprintf "%s >> %s" a b)
    else if Types.signed k then norm k (Printf.sprintf "%s >> %s" a b)
    else
      (* An unsigned value below 32 bits is already a non-negative number, so
         >> and >>> agree on it; at 32 bits only >>> does. *)
      norm k (Printf.sprintf "%s >>> %s" a b)
  | _ -> assert false

and cast f loc (t : Types.t) (x : Tast.expr) =
  refuse_ty loc t;
  let src = x.Tast.ty in
  let v = value f x in
  match (src, t) with
  | Types.Int a, Types.Int b when a = b -> v
  | (Types.Enum _ | Types.Int _), (Types.Enum _ | Types.Int _) ->
    let bk = match t with Types.Int k -> Some k | _ -> None in
    let sbig = match src with Types.Int k -> big k | _ -> false in
    let dbig = match bk with Some k -> big k | None -> false in
    if sbig && not dbig then
      (* The truncation has to happen in BigInt and not after: a 64-bit value
         through Number() is rounded to 53 bits first, so (i32 i64hi) would
         answer 0 where every other backend answers -1. *)
      let k = match bk with Some k -> k | None -> Types.I32 in
      Printf.sprintf "Number(BigInt.as%sN(%d, %s))"
        (if Types.signed k then "Int" else "Uint")
        (Types.bits k) v
    else
      let v = if dbig && not sbig then Printf.sprintf "BigInt(%s)" v else v in
      (match bk with Some k -> norm k v | None -> Printf.sprintf "(%s | 0)" v)
  | Types.Float _, Types.Float k -> fround k v
  | (Types.Int _ | Types.Enum _), Types.Float k ->
    let sbig = match src with Types.Int k -> big k | _ -> false in
    fround k (if sbig then Printf.sprintf "Number(%s)" v else v)
  | Types.Float _, Types.Int k ->
    let t0 = fresh f in
    line f "const %s = %s;" t0 v;
    if f.md.checks then begin
      let bits = Types.bits k in
      let lo, hi =
        if Types.signed k then
          ( Printf.sprintf "-%s" (two_pow (bits - 1)),
            Printf.sprintf "%s" (two_pow (bits - 1)) )
        else ("0", two_pow bits)
      in
      let ilo, ihi =
        if Types.signed k then
          (Printf.sprintf "-%s" (two_pow (bits - 1)),
           Printf.sprintf "%s" (dec_sub1 (two_pow (bits - 1))))
        else ("0", dec_sub1 (two_pow bits))
      in
      line f "if (!(%s >= %s && %s < %s)) $castrange(%s, %s, %s);" t0 lo t0 hi
        (locstr loc) ilo ihi
    end;
    if big k then norm k (Printf.sprintf "BigInt(Math.trunc(%s))" t0)
    else norm k (Printf.sprintf "Math.trunc(%s)" t0)
  | Types.Bool, Types.Int k -> norm k (Printf.sprintf "(%s ? 1 : 0)" v)
  | a, b ->
    at loc "a cast from %s to %s is not in the JS dialect"
      (Types.to_string a) (Types.to_string b)

(* 2^n as a decimal literal, exact for every n a machine integer can need. *)
and two_pow n =
  let rec go acc i = if i = 0 then acc else go (mul2 acc) (i - 1) in
  go "1" n

and mul2 s =
  let n = String.length s in
  let out = Bytes.make (n + 1) '0' in
  let carry = ref 0 in
  for i = n - 1 downto 0 do
    let d = (Char.code s.[i] - 48) * 2 + !carry in
    Bytes.set out (i + 1) (Char.chr (48 + (d mod 10)));
    carry := d / 10
  done;
  Bytes.set out 0 (Char.chr (48 + !carry));
  let s = Bytes.to_string out in
  if s.[0] = '0' then String.sub s 1 n else s

and dec_sub1 s =
  let b = Bytes.of_string s in
  let rec go i =
    if i < 0 then ()
    else if Bytes.get b i = '0' then (Bytes.set b i '9'; go (i - 1))
    else Bytes.set b i (Char.chr (Char.code (Bytes.get b i) - 1))
  in
  go (Bytes.length b - 1);
  let s = Bytes.to_string b in
  if String.length s > 1 && s.[0] = '0' then String.sub s 1 (String.length s - 1)
  else s

(* ── Statements ─────────────────────────────────────────────────────── *)

and assign f dest v =
  match dest with
  (* A form whose value is discarded and whose text is [undefined] did
     nothing; emitting it as a statement is noise in the output and nothing
     else. *)
  | None -> if not (String.equal v "undefined") then line f "%s;" v
  | Some d -> line f "%s = %s;" d v

and stmt f dest (e : Tast.expr) =
  match e.Tast.e with
  | Tast.Do body -> block f dest body
  | Tast.Let (binds, body) ->
    List.iter
      (fun (slot, v) ->
         let x = bind_value f v in
         line f "%s = %s;" f.names.(slot) x)
      binds;
    block f dest body
  | Tast.If (c, a, b) ->
    let cv = value f c in
    line f "if (%s) {" cv;
    f.ind <- f.ind + 1;
    stmt f dest a;
    f.ind <- f.ind - 1;
    line f "} else {";
    f.ind <- f.ind + 1;
    stmt f dest b;
    f.ind <- f.ind - 1;
    line f "}"
  | Tast.While (c, body, latch) ->
    let d = List.length f.loops in
    let lb = Printf.sprintf "$b%d" d and lc = Printf.sprintf "$c%d" d in
    line f "%s: for (;;) {" lb;
    f.ind <- f.ind + 1;
    let cv = value f c in
    line f "if (!(%s)) break %s;" cv lb;
    (* The body is a labelled block and the latch is after it, so a continue
       runs the latch — emit.ml's reason for the latch existing at all: a
       [dotimes] step written in the body would be skipped by a continue and
       the loop would never advance. *)
    line f "%s: {" lc;
    f.ind <- f.ind + 1;
    f.loops <- (lb, lc) :: f.loops;
    List.iter (fun x -> stmt f None x) body;
    f.loops <- List.tl f.loops;
    f.ind <- f.ind - 1;
    line f "}";
    List.iter (fun x -> stmt f None x) latch;
    f.ind <- f.ind - 1;
    line f "}";
    (match dest with Some d -> line f "%s = undefined;" d | None -> ())
  | Tast.Break n ->
    let lb, _ = List.nth f.loops n in
    line f "break %s;" lb
  | Tast.Continue n ->
    let _, lc = List.nth f.loops n in
    line f "break %s;" lc
  | Tast.Return None ->
    if Types.equal f.ret Types.Unit then line f "return;"
    else line f "return %s;" (zero f.md e.Tast.loc f.ret)
  | Tast.Return (Some v) ->
    if Types.equal f.ret Types.Unit then begin
      ignore (value f v);
      line f "return;"
    end
    else line f "return %s;" (bind_value f v)
  | Tast.Set (p, v) -> set f e.Tast.loc p v
  | Tast.Match (s, arms) -> emit_match f dest s arms
  | Tast.UnwrapSome v ->
    let ov = spill f v in
    line f "if (%s === null) return null;" ov;
    assign f dest (Printf.sprintf "%s.v" ov)
  | _ -> assign f dest (value f e)

and block f dest (body : Tast.expr list) =
  match body with
  | [] -> (match dest with Some d -> line f "%s = undefined;" d | None -> ())
  | [ last ] -> stmt f dest last
  | x :: rest ->
    stmt f None x;
    block f dest rest

and set f loc (p : Tast.place) (v : Tast.expr) =
  match p with
  | Tast.Plocal i -> line f "%s = %s;" f.names.(i) (bind_value f v)
  | Tast.Pglobal n -> line f "%s = %s;" (gvar n) (bind_value f v)
  | Tast.Pfield (x, i) ->
    let s = struct_of f.md loc x.Tast.ty in
    let fl = List.nth s.Tast.fields i in
    let t = spill f x in
    line f "%s.%s = %s;" t (prop fl.Tast.fname) (bind_value f v)
  | Tast.Pindex (x, idxs) ->
    (* Every index but the last names the container the next one indexes, so
       the walk down is [index]'s and only the final store is written here. *)
    let tv = spill f x in
    let rec walk base (bty : Types.t) = function
      | [] -> assert false
      | [ i ] ->
        let iv = value f i in
        let rhs = bind_value f v in
        if f.md.checks then
          let fn = match bty with Types.Array _ -> "$aset" | _ -> "$set" in
          line f "%s(%s, %s, %s, %s);" fn base iv rhs (locstr i.Tast.loc)
        else (
          match bty with
          | Types.Array _ -> line f "%s[%s] = %s;" base iv rhs
          | _ -> line f "%s.a[%s.o + %s] = %s;" base base iv rhs)
      | i :: rest ->
        let iv = value f i in
        let fn = match bty with Types.Array _ -> "$aat" | _ -> "$at" in
        let one =
          if f.md.checks then
            Printf.sprintf "%s(%s, %s, %s)" fn base iv (locstr i.Tast.loc)
          else
            match bty with
            | Types.Array _ -> Printf.sprintf "%s[%s]" base iv
            | _ -> Printf.sprintf "%s.a[%s.o + %s]" base base iv
        in
        let t = fresh f in
        line f "const %s = %s;" t one;
        walk t (elem_ty loc bty) rest
    in
    walk tv x.Tast.ty idxs
  | Tast.Pderef _ ->
    at loc
      "a store through a pointer is not in the JS dialect — JavaScript has no \
       addresses"

and emit_match f dest (s : Tast.expr) (arms : Tast.arm list) =
  let sv = spill f s in
  let opt = match s.Tast.ty with Types.Option _ -> true | _ -> false in
  let payload =
    match s.Tast.ty with Types.Option t -> Some t | _ -> None
  in
  let uname =
    match s.Tast.ty with
    | Types.Named n when Hashtbl.mem f.md.unions n -> Some n
    | Types.Option _ -> None
    | t -> at s.Tast.loc "match on %s" (Types.to_string t)
  in
  let first = ref true in
  let closed = ref false in
  List.iter
    (fun (a : Tast.arm) ->
       if not !closed then begin
         (match a.Tast.acase with
          | None ->
            if !first then line f "{" else line f "} else {";
            closed := true
          | Some c ->
            let test =
              if opt then
                if String.equal c "Some" then
                  Printf.sprintf "%s !== null" sv
                else Printf.sprintf "%s === null" sv
              else Printf.sprintf "%s.case === %s" sv (js_string c)
            in
            if !first then line f "if (%s) {" test
            else line f "} else if (%s) {" test);
         first := false;
         f.ind <- f.ind + 1;
         (* The binds, in field order. Each one copies, for the reason in the
            header: a bound field is a value in Flan. *)
         List.iteri
           (fun i slot ->
              let name = f.names.(slot) in
              match (opt, a.Tast.acase, uname) with
              | true, _, _ ->
                let t = Option.get payload in
                let v = Printf.sprintf "%s.v" sv in
                let v =
                  match copy_of f.md t v with Some c -> c | None -> v
                in
                line f "%s = %s;" name v
              | false, Some c, Some n ->
                let u = Hashtbl.find f.md.unions n in
                (match Tast.case_index u c with
                 | Some (_, cs) ->
                   let fl = List.nth cs.Tast.vfields i in
                   let v =
                     Printf.sprintf "%s.%s" sv (prop fl.Tast.fname)
                   in
                   let v =
                     match copy_of f.md fl.Tast.fty v with
                     | Some cc -> cc
                     | None -> v
                   in
                   line f "%s = %s;" name v
                 | None -> at s.Tast.loc "no case %s" c)
              | _ -> at s.Tast.loc "a default arm cannot bind fields")
           a.Tast.binds;
         block f dest a.Tast.abody;
         f.ind <- f.ind - 1
       end)
    arms;
  if not !first then begin
    if not !closed then
      (* The checker proved exhaustiveness, so the fall-through is
         unreachable; it is written out so that a wrong proof is a message and
         not a silently-undefined value. *)
      line f "} else { throw new Error(\"unreachable match\"); }"
    else line f "}"
  end

(* ── A function ─────────────────────────────────────────────────────── *)

(* Slot names come from [snames] where the source wrote one, which is most of
   what makes the output readable. A name used by two different slots gets its
   index appended, so the mapping stays injective. *)
let slot_names (fn : Tast.fn) =
  let n = Array.length fn.Tast.slots in
  let seen = Hashtbl.create 16 in
  Array.iteri
    (fun i s ->
       match s with
       | Some s when i < n ->
         Hashtbl.replace seen s (1 + try Hashtbl.find seen s with Not_found -> 0)
       | _ -> ())
    fn.Tast.snames;
  Array.init n (fun i ->
    match fn.Tast.snames.(i) with
    | Some s when Hashtbl.find seen s = 1 -> ident s
    | Some s -> Printf.sprintf "%s$%d" (ident s) i
    | None -> Printf.sprintf "t$%d" i)

let func m (fn : Tast.fn) =
  List.iter (refuse_ty fn.Tast.floc) fn.Tast.params;
  refuse_ty fn.Tast.floc fn.Tast.ret;
  Array.iter (refuse_ty fn.Tast.floc) fn.Tast.slots;
  (* [fdefers] is the same defer list again, for the *transfer* exit path.
     Nothing in this dialect can start a transfer — signal, handler-bind,
     restart-case and invoke-restart are all refused above, and a bounds or
     arithmetic failure here dies where the native runtime would signal — so
     that path is unreachable and the list is dropped rather than emitted. The
     defers on the ordinary path are already spliced into [body] and do run.
     This is the one place a refusal would have been wrong: it would refuse
     every program that writes a plain [defer]. *)
  let names = slot_names fn in
  let f =
    { md = m; b = Buffer.create 512; ind = 1; n = 0; names;
      slots = fn.Tast.slots; ret = fn.Tast.ret; loops = [] }
  in
  let nparams = List.length fn.Tast.params in
  (* Every slot that is not a parameter is declared once at the top, which is
     what the frame is: the checker already numbered them and they do not
     nest. *)
  let locals =
    Array.to_list (Array.sub names nparams (Array.length names - nparams))
  in
  if locals <> [] then
    line f "let %s;" (String.concat ", " locals);
  (* The body is a list of forms and the last one is the return value — the
     same rule [emit.ml] follows. Every form before it is a statement, and a
     statement it is not is the bug this used to have: a unit-typed call
     compiled to an expression nobody emitted, so [(load-xs)] silently did not
     happen. A Unit function's body may end on a form of any type; the value is
     discarded there, exactly as emit.ml discards it. *)
  let void =
    Types.equal fn.Tast.ret Types.Unit || Types.equal fn.Tast.ret Types.Never
  in
  let n = List.length fn.Tast.body in
  List.iteri
    (fun i (e : Tast.expr) ->
       if i < n - 1 || void then stmt f None e
       else
         match e.Tast.e with
         | Tast.Do _ | Tast.Let _ | Tast.If _ | Tast.While _ | Tast.Match _
         | Tast.UnwrapSome _ | Tast.Set _ | Tast.Return _ | Tast.Break _
         | Tast.Continue _ ->
           let t = fresh f in
           line f "let %s;" t;
           stmt f (Some t) e;
           (match copy_of m fn.Tast.ret t with
            | Some c -> line f "return %s;" c
            | None -> line f "return %s;" t)
         | _ -> line f "return %s;" (bind_value f e))
    fn.Tast.body;
  Buffer.add_string m.out
    (Printf.sprintf "\nfunction %s(%s) {\n%s}\n" (fname fn.Tast.name)
       (String.concat ", "
          (List.mapi (fun i _ -> names.(i)) fn.Tast.params))
       (Buffer.contents f.b))

(* ── A whole program ────────────────────────────────────────────────── *)

(* The per-struct copy, which is where the value-semantics rule is actually
   spent. Recursive, because a field may be a struct or an array of them. *)
(* A union's declaration order is its tag ([Tast.case_index]), and that order
   is a union's contract — an all-bytes-zero union is its first case. The
   printer asks for the number; the value carries the name. *)
let tag_fn m name =
  let u = Hashtbl.find m.unions name in
  let arms =
    List.mapi
      (fun i (c : Tast.variant) ->
         Printf.sprintf "v.case === %s ? %d : " (js_string c.Tast.vname) i)
      u.Tast.cases
  in
  Printf.sprintf "function %s$tag(v) { return %s-1; }\n" (ident name)
    (String.concat "" arms)

let copy_fn m name =
  let field_copy (fl : Tast.field) =
    let v = Printf.sprintf "v.%s" (prop fl.Tast.fname) in
    let v = match copy_of m fl.Tast.fty v with Some c -> c | None -> v in
    Printf.sprintf "%s: %s" (prop fl.Tast.fname) v
  in
  if Hashtbl.mem m.structs name then
    let s = Hashtbl.find m.structs name in
    Printf.sprintf "function %s$copy(v) { return { %s }; }\n" (ident name)
      (String.concat ", " (List.map field_copy s.Tast.fields))
  else
    let u = Hashtbl.find m.unions name in
    let arm (c : Tast.variant) =
      Printf.sprintf
        "  if (v.case === %s) return { case: v.case%s };\n"
        (js_string c.Tast.vname)
        (String.concat ""
           (List.map
              (fun (fl : Tast.field) -> ", " ^ field_copy fl)
              c.Tast.vfields))
    in
    Printf.sprintf "function %s$copy(v) {\n%s  return { case: v.case };\n}\n"
      (ident name)
      (String.concat "" (List.map arm u.Tast.cases))

let program ?(checks = true) (p : Tast.program) : string =
  let m =
    { out = Buffer.create 8192; structs = Hashtbl.create 16;
      unions = Hashtbl.create 8; checks; strs = []; nstr = 0; copies = [];
      tags = [] }
  in
  List.iter
    (fun (s : Tast.structure) -> Hashtbl.replace m.structs s.Tast.sname s)
    p.Tast.structs;
  List.iter
    (fun (u : Tast.union) -> Hashtbl.replace m.unions u.Tast.uname u)
    p.Tast.unions;
  if p.Tast.externs <> [] then begin
    let e = List.hd p.Tast.externs in
    unsupported
      "%s is a (declare-c ...) binding, and the JS dialect has no C boundary \
       — the FFI crosses through a generated C shim, which has nowhere to be \
       here"
      e.Tast.ename
  end;
  if p.Tast.cshim <> [] then
    unsupported
      "this program generates a C shim, and the JS dialect has no C boundary";
  (* Globals first: an initialiser is a compile-time constant in this IR, so
     there is no ordering question and no init-at-startup path. *)
  let gbuf = Buffer.create 256 in
  List.iter
    (fun (g : Tast.global) ->
       refuse_ty g.Tast.ginit.Tast.loc g.Tast.gty;
       let f =
         { md = m; b = Buffer.create 64; ind = 0; n = 0; names = [||];
           slots = [||]; ret = g.Tast.gty; loops = [] }
       in
       let v = value f g.Tast.ginit in
       if Buffer.length f.b > 0 then
         at g.Tast.ginit.Tast.loc
           "the initialiser of %s is not a constant, which this IR does not \
            produce"
           g.Tast.gname;
       Buffer.add_string gbuf
         (Printf.sprintf "%s %s = %s;\n"
            (if g.Tast.gconst then "const" else "let")
            (gvar g.Tast.gname) v))
    p.Tast.globals;
  List.iter (fun fn -> func m fn) p.Tast.fns;
  (* The copies are discovered while walking, so they are written after it and
     hoisted above by JS's own function hoisting. *)
  let copies =
    String.concat "" (List.map (copy_fn m) (List.sort compare m.copies))
    ^ String.concat "" (List.map (tag_fn m) (List.sort compare m.tags))
  in
  let strs =
    String.concat ""
      (List.map
         (fun (s, n) ->
            if printable s then
              Printf.sprintf "const %s = $str(%s);\n" n (js_string s)
            else
              Printf.sprintf "const %s = $bytes([%s]);\n" n
                (String.concat ", "
                   (List.map (fun c -> string_of_int (Char.code c))
                      (List.init (String.length s) (String.get s)))))
         (List.rev m.strs))
  in
  let has_main =
    List.exists (fun (fn : Tast.fn) -> String.equal fn.Tast.name "main")
      p.Tast.fns
  in
  let tail =
    if has_main then
      let mainfn =
        List.find (fun (fn : Tast.fn) -> String.equal fn.Tast.name "main")
          p.Tast.fns
      in
      (* [main] takes the command line or nothing, which is the whole of the
         entry point's contract. node's own argv starts at the interpreter, so
         the slice starts at the script — which is where a native argv[0] is
         the program. *)
      let arg = if mainfn.Tast.params = [] then "" else "$argv()" in
      if Types.equal mainfn.Tast.ret Types.Unit then
        Printf.sprintf "\n%s(%s);\nprocess.exit(0);\n" (fname "main") arg
      else
        Printf.sprintf "\nprocess.exit(Number(%s(%s)));\n" (fname "main") arg
    else ""
  in
  runtime ^ "\n// ── string literals ──\n" ^ strs
  ^ (if copies = "" then "" else "\n// ── value-semantics copies ──\n" ^ copies)
  ^ (if Buffer.length gbuf = 0 then ""
     else "\n// ── globals ──\n" ^ Buffer.contents gbuf)
  ^ Buffer.contents m.out ^ tail