flan/lib/shim.ml

(** [declare-c]: a foreign function written in the C library's own terms, with
    the crossing generated rather than hand-written.

    [declare] says "this Flan signature *is* the C signature" — the symbol it
    names already trades in scalars and ptr+len, because somebody wrote it that
    way ([flan_agent_start], [sqrtf], the runtime's own shims). That form is
    unchanged and this module never touches one.

    [declare-c] says the other thing: the signature is the *library's*, structs
    by value and all, and the compiler is to produce whatever flattening makes
    it crossable. The two cannot be one form —
    [(declare start-raw [path string] i32 "flan_agent_start")] and
    [(declare-c init-window [w i32 h i32 title string] "InitWindow")] are the
    same shape and mean opposite things about who NUL-terminates the string.

    Why the crossing is still C, and not [emit.ml]: a small aggregate's calling
    convention is a per-target *classification*, not part of its layout.
    x86-64 hands [Vector2] over as [<2 x float>] and returns [Rectangle] as
    [{i64,i64}]; arm64 and wasm32 each do something else. Reproducing that in
    the backend is three classifiers to keep correct forever, and a mistake
    reads as a field full of garbage rather than as a link error. clang already
    does it, per target, for free. So the C shim stays; what stops is writing
    it by hand.

    What this module does with one [declare-c]:

    - emits a C [typedef] for every struct in the signature, from the Flan
      [defstruct], transitively and once each;
    - emits an [extern] prototype for the real function, in its true signature;
    - emits a wrapper that flattens — a struct returns through an out-pointer,
      a struct argument goes by pointer, a Flan string arrives as ptr+len and
      the wrapper NUL-terminates a copy;
    - and rewrites the declaration into the flattened [declare] the Flan side
      calls, with an ordinary Flan [defn] above it carrying the nice signature.

    {2 What is guaranteed and what is trusted}

    Guaranteed: the C typedef and the Flan struct come from the same
    [defstruct], so they cannot disagree — permute the [defstruct] and the
    typedef permutes with it. And clang type-checks the wrapper against the
    [extern] prototype, so the flattening cannot disagree with the prototype.

    Padding is not a separate hazard, which is worth saying because it reads
    like one. For every field type this generator admits — the machine
    integers, the two floats, [bool], a pointer and a nested struct — LLVM's
    struct layout is C's, and [emit.ml] writes no datalayout, so clang applies
    the target's own rules to both halves and they land in the same place.
    Everything where the two could diverge — a fixed array, a slice, an
    [Option], a map, a union — is refused at the field, by name.

    Trusted: that the [defstruct] describes the library's real struct, and that
    the [declare-c] signature is the function's real signature. No library
    header is read — deliberately, so a build needs the shared library and not
    the -devel package — so nothing here can check either. Two consequences
    worth stating plainly:

    - the prototype is now generated *from the declaration*, so a scalar's
      width carries ABI weight it did not before. [f64] where the library says
      [float] used to be narrowed by clang at the hand-written call site; now
      it emits [double] and the library reads garbage.
    - the only thing that catches a wrong [defstruct] is a test that makes the
      library *compute* with the fields — which is why the raylib acceptance
      cases pin layouts by arithmetic and go red when a [defstruct] is
      permuted.

    A [_Static_assert] on [sizeof] and [offsetof] was considered and left out:
    both sides of it would come from the same field list, so it would check
    this module's arithmetic against clang's and say nothing about the library.
    What converts the trusted half into a checked one is reading the real
    header, and that is built: [Cimport] asks clang for a JSON dump of one
    and compares both halves against it — every [defstruct] against the
    header's record, and every [declare-c] against the header's signature.
    Nothing in this module changed for it. The refusals below still raise,
    which is right for a signature a human named; the importer makes the
    same judgements and merely skips instead, since one returned
    [const char *] must not kill a header of five hundred functions. *)

let fail = Loc.fail

(* ── Names ──────────────────────────────────────────────────────────
   A Flan name may contain '/', '-', '?' and '!', none of which a C identifier
   may. Squashing them all to '_' is not injective — [valid?] and [valid_]
   would collide — so the readable squash carries a digest of the original,
   which makes it injective without making it unreadable. *)

let squash s =
  let b = Buffer.create (String.length s) in
  String.iter
    (fun c ->
       let ok =
         (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
         || (c >= '0' && c <= '9')
       in
       Buffer.add_char b (if ok then c else '_'))
    s;
  Buffer.contents b

let mangle s =
  Printf.sprintf "%s_%s" (squash s)
    (String.sub (Digest.to_hex (Digest.string s)) 0 8)

let shim_symbol flan_name = "flan_shim_" ^ mangle flan_name
let ctype_name struct_name = "flan_ty_" ^ mangle struct_name

(* The Flan name the generated flattened declaration gets. It is visible, as
   the hand-written [-raw] names were, because there is no visibility rule
   yet. *)
let raw_name flan_name = flan_name ^ "-c"

(* Locals the generated Flan wrapper binds. A parameter is not an assignable
   place (spec-memory.md), so a struct argument needs a copy to take the
   address of — and the hand-written wrappers had to rename around their own
   parameters to do it ([draw-triangle] bound [d] for [v3] to keep [c] for the
   colour). These cannot collide with anything: the reader does not produce a
   name beginning with '%'. *)
let tmp i = Printf.sprintf "%%a%d" i
let out_tmp = "%out"

(* ── The declarations in scope ──────────────────────────────────────── *)

type env = {
  structs : (string, Ast.field list) Hashtbl.t;
  enums   : (string, unit) Hashtbl.t;
  unions  : (string, unit) Hashtbl.t;
  aliases : (string, Ast.texpr) Hashtbl.t;
}

let scan (decls : Ast.decl list) =
  let env =
    { structs = Hashtbl.create 32; enums = Hashtbl.create 32;
      unions = Hashtbl.create 8; aliases = Hashtbl.create 16 }
  in
  List.iter
    (fun (d : Ast.decl) ->
       match d.Ast.d with
       | Ast.Defstruct (n, fs) -> Hashtbl.replace env.structs n fs
       | Ast.Defenum (n, _) -> Hashtbl.replace env.enums n ()
       | Ast.Defunion (n, _) -> Hashtbl.replace env.unions n ()
       | Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t
       | _ -> ())
    decls;
  env

(* An alias is a name for a type expression, so follow it before deciding what
   a type is. [check.ml] rejects a cyclic alias, but this runs before it does,
   so the walk is bounded rather than trusting. *)
let unalias env (t : Ast.texpr) =
  let rec go fuel t =
    if fuel = 0 then t
    else
      match t.Ast.t with
      | Ast.Tname n ->
        (match Hashtbl.find_opt env.aliases n with
         | Some t' -> go (fuel - 1) t'
         | None -> t)
      | _ -> t
  in
  go 100 t

(* ── Flan type → C type ─────────────────────────────────────────────
   One function, used for a struct's fields and for a function's parameters
   alike, so the two cannot drift: a [bool] field and a [bool] argument are the
   same C [bool] and never an [int]. *)

let prim_cty = function
  | "i8" -> Some "int8_t"    | "i16" -> Some "int16_t"
  | "i32" -> Some "int32_t"  | "i64" -> Some "int64_t"
  | "u8" -> Some "uint8_t"   | "u16" -> Some "uint16_t"
  | "u32" -> Some "uint32_t" | "u64" -> Some "uint64_t"
  | "f32" -> Some "float"    | "f64" -> Some "double"
  | "bool" -> Some "bool"
  | _ -> None

(* [needed] collects the structs whose typedefs this signature pulls in, in the
   order they were first met. Order is the program's and never a hash fold's:
   the object cache keys on the generated text, so a reordering would be a
   rebuild. *)
let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
  let t = unalias env t in
  match t.Ast.t with
  | Ast.Tname n ->
    (match prim_cty n with
     | Some c -> c
     | None ->
       if Hashtbl.mem env.structs n then begin
         if not (List.mem n !needed) then needed := !needed @ [ n ];
         ctype_name n
       end
       else if Hashtbl.mem env.enums n then
         (* A C enum is an int, and Flan's [Enum] is an i32 — the same thing on
            every target this compiles for. *)
         "int32_t"
       else if Hashtbl.mem env.unions n then
         fail loc
           "%s is %s, a union, and a Flan union has no C layout — the shim \
            cannot be generated for it"
           what n
       else if String.equal n "string" then
         fail loc
           "%s is a string, and a string only crosses as a parameter — a C \
            function that *returns* one returns something Flan has no owner for"
           what
       else if String.equal n "Unit" || String.equal n "Never" then
         fail loc "%s is %s, which is not a value C can carry" what n
       else
         fail loc "%s is %s, which is not a type this shim generator knows" what n)
  | Ast.Tapp ("Ptr", [ e ]) -> cty env ~needed ~loc ~what e ^ " *"
  | Ast.Tapp ("Option", _) ->
    fail loc
      "%s is an Option, which is a Flan shape and not a C one — declare what C \
       returns and build the Option in Flan"
      what
  | Ast.Tslice _ ->
    fail loc
      "%s is a slice, which crosses as ptr+len with an i64 length, and the \
       count parameter the C function actually takes has a type this \
       declaration does not say — declare (Ptr T) with an explicit count and \
       pass (addr (at s 0)) and (len s) from Flan"
      what
  | Ast.Tarray _ ->
    fail loc
      "%s is a fixed array, which C passes as a pointer and Flan as a value — \
       declare (Ptr T) and say which"
      what
  (* Two spellings reach the same type: [Ast.Tmap], which only [Cimport]
     builds now, and [(Map K V)], which is what source writes since the brace
     spelling was withdrawn from type position. Both are refused here. *)
  | Ast.Tmap _ | Ast.Tapp ("Map", _) ->
    fail loc "%s is a map, which has no C representation" what
  (* A Vec owns its storage, so handing its header to C hands out an owner and
     there is no rule for what C would then be allowed to do with it. The
     elements cross the way any other run of elements does. *)
  | Ast.Tapp ("Vec", _) ->
    fail loc
      "%s is a Vec, which owns its storage — handing its header to C hands out \
       an owner. Pass (as-slice v) as (Ptr T) and (len v), the same shape a \
       slice crosses in"
      what
  | Ast.Tfn _ ->
    fail loc "%s is a function type, and a C callback is not implemented" what
  | Ast.Tapp (n, _) ->
    fail loc "%s is %s, which is not a type this shim generator knows" what n

(* ── What one parameter does at the boundary ────────────────────────── *)

type pkind =
  | Pscalar                    (* crosses as itself: an int, a float, a Ptr *)
  | Pstruct of string          (* by value in C; by pointer across the boundary *)
  | Pstr                       (* ptr+len in, a NUL-terminated copy out *)

let classify env ~needed ~loc ~what (t : Ast.texpr) =
  let t' = unalias env t in
  match t'.Ast.t with
  | Ast.Tname "string" -> (Pstr, "const char *")
  | Ast.Tname n when Hashtbl.mem env.structs n ->
    ignore (cty env ~needed ~loc ~what t');
    (Pstruct n, ctype_name n)
  | _ -> (Pscalar, cty env ~needed ~loc ~what t')

(* ── The C text ─────────────────────────────────────────────────────── *)

let header =
  "/* Generated by Flan from the (declare-c ...) forms in this program. Do not\n\
  \ * edit it: it is rebuilt from the declarations on every build, and the\n\
  \ * object cache is keyed by the text below, so an edit here is either\n\
  \ * overwritten or — worse — kept after the declarations have moved on.\n\
  \ *\n\
  \ * Every wrapper exists so that no aggregate crosses the Flan/C boundary. A\n\
  \ * small struct's calling convention is a per-target classification rather\n\
  \ * than part of its layout, so clang does it here, correctly, for whichever\n\
  \ * target this build is for, and the backend never learns x86-64 from arm64\n\
  \ * from wasm32.\n\
  \ *\n\
  \ * No library header is included, deliberately: the prototypes below are the\n\
  \ * declarations, so a build needs the shared library to be linkable and not\n\
  \ * the -devel package to be installed. The price is that a prototype here is\n\
  \ * only as right as the declare-c it came from.\n\
  \ */\n\n\
   #include <stdbool.h>\n\
   #include <stddef.h>\n\
   #include <stdint.h>\n\
   #include <stdlib.h>\n\
   #include <string.h>\n\n"

(* A Flan string is ptr+len and never NUL-terminated, so a C API that wants a C
   string needs a copy. The hand-written wrappers sized the buffer per call
   site — 256 for a window title, PATH_MAX for a path, 512 for drawn text — and
   truncated past it. A generator has no call site to look at, so it must not
   be the thing deciding a string is too long: what does not fit the stack
   buffer is copied to the heap and freed after the call. The stack buffer is
   what keeps that allocation-free in the overwhelmingly common case, and it is
   256 because that covers a title, a path and a line of text without making
   every foreign call carry a page of stack. The only truncation left is when
   malloc itself fails, where the alternative is handing C a null pointer. *)
let cstr_helpers =
  "static char *flan_shim_cstr(const char *p, int64_t n, char *buf, size_t cap) {\n\
  \  size_t len = n <= 0 ? 0 : (size_t)n;\n\
  \  char *d = buf;\n\
  \  if (len + 1 > cap) {\n\
  \    d = (char *)malloc(len + 1);\n\
  \    if (d == NULL) { d = buf; len = cap - 1; }  /* out of memory: truncate */\n\
  \  }\n\
  \  if (len != 0) memcpy(d, p, len);\n\
  \  d[len] = '\\0';\n\
  \  return d;\n\
   }\n\n\
   static void flan_shim_cstr_free(char *d, char *buf) {\n\
  \  if (d != buf) free(d);\n\
   }\n\n"

let cstr_cap = 256

(* One [declare-c], reduced to what both halves need. *)
type shim = {
  sflan : string;                   (* the Flan name as written *)
  ssym  : string;                   (* the C symbol being bound *)
  swrap : string;                   (* the generated wrapper's symbol *)
  sargs : (pkind * string) list;    (* kind and C type, per parameter *)
  sret  : [ `Void | `Scalar of string | `Struct of string * string ];
  sloc  : Loc.t;
}

let arg_name i = Printf.sprintf "a%d" i

(* The wrapper's own parameter list: a struct by pointer, a string as ptr+len,
   anything else as itself — plus the out-pointer when C returns a struct. *)
let wrapper_params s =
  let ps =
    List.concat
      (List.mapi
         (fun i (k, c) ->
            let a = arg_name i in
            match k with
            | Pstruct _ -> [ Printf.sprintf "const %s *%s" c a ]
            | Pstr ->
              [ Printf.sprintf "const char *%s_p" a;
                Printf.sprintf "int64_t %s_n" a ]
            | Pscalar ->
              [ (if String.length c > 0 && c.[String.length c - 1] = '*' then
                   Printf.sprintf "%s%s" c a
                 else Printf.sprintf "%s %s" c a) ])
         s.sargs)
  in
  match s.sret with
  | `Struct (_, c) -> ps @ [ Printf.sprintf "%s *out" c ]
  | _ -> ps

let c_for (s : shim) =
  let b = Buffer.create 512 in
  Printf.bprintf b "/* %s */\n" s.sflan;
  (* The prototype, in the library's own terms. *)
  let proto_args =
    List.map
      (fun (k, c) ->
         match k with Pstruct _ -> c | Pstr -> "const char *" | Pscalar -> c)
      s.sargs
  in
  let proto_ret =
    match s.sret with `Void -> "void" | `Scalar c -> c | `Struct (_, c) -> c
  in
  Printf.bprintf b "extern %s %s(%s);\n" proto_ret s.ssym
    (match proto_args with [] -> "void" | _ -> String.concat ", " proto_args);
  let wret = match s.sret with `Struct _ | `Void -> "void" | `Scalar c -> c in
  let wparams = wrapper_params s in
  Printf.bprintf b "%s %s(%s) {\n" wret s.swrap
    (match wparams with [] -> "void" | _ -> String.concat ", " wparams);
  (* The NUL-terminated copies, before the call. *)
  List.iteri
    (fun i (k, _) ->
       match k with
       | Pstr ->
         let a = arg_name i in
         Printf.bprintf b "  char %s_b[%d];\n" a cstr_cap;
         Printf.bprintf b
           "  char *%s = flan_shim_cstr(%s_p, %s_n, %s_b, sizeof %s_b);\n" a a a
           a a
       | _ -> ())
    s.sargs;
  let call_args =
    List.mapi
      (fun i (k, _) ->
         let a = arg_name i in
         match k with Pstruct _ -> "*" ^ a | Pstr | Pscalar -> a)
      s.sargs
  in
  let call = Printf.sprintf "%s(%s)" s.ssym (String.concat ", " call_args) in
  let has_str = List.exists (fun (k, _) -> k = Pstr) s.sargs in
  (match s.sret with
   | `Void -> Printf.bprintf b "  %s;\n" call
   | `Struct _ -> Printf.bprintf b "  *out = %s;\n" call
   | `Scalar c ->
     (* The result is named rather than returned straight through when there
        are copies to free: the free has to happen after the call. *)
     if has_str then Printf.bprintf b "  %s r = %s;\n" c call
     else Printf.bprintf b "  return %s;\n" call);
  if has_str then begin
    List.iteri
      (fun i (k, _) ->
         match k with
         | Pstr ->
           let a = arg_name i in
           Printf.bprintf b "  flan_shim_cstr_free(%s, %s_b);\n" a a
         | _ -> ())
      s.sargs;
    match s.sret with
    | `Scalar _ -> Buffer.add_string b "  return r;\n"
    | _ -> ()
  end;
  Buffer.add_string b "}\n\n";
  Buffer.contents b

(* The typedefs, forward-declared first so a struct may hold a pointer to one
   defined below it — or to itself — and then defined in dependency order, so a
   struct held *by value* is complete before it is used. *)
let typedefs env needed =
  let b = Buffer.create 512 in
  (* The transitive closure, in first-met order. *)
  let rec close acc n =
    if List.mem n acc then acc
    else
      let acc = acc @ [ n ] in
      match Hashtbl.find_opt env.structs n with
      | None -> acc
      | Some fs ->
        List.fold_left
          (fun acc (f : Ast.field) ->
             let sink = ref [] in
             (* The type mapper is reused here purely to discover the struct
                names a field mentions; its text is not wanted. Mapping it now
                is also what refuses an unrepresentable field, at the field. *)
             ignore
               (cty env ~needed:sink ~loc:f.Ast.floc
                  ~what:(Printf.sprintf "field %s of %s" f.Ast.fname n)
                  f.Ast.fty);
             List.fold_left close acc !sink)
          acc fs
  in
  let all = List.fold_left close [] needed in
  List.iter
    (fun n ->
       Printf.bprintf b "typedef struct %s_s %s;\n" (ctype_name n) (ctype_name n))
    all;
  if all <> [] then Buffer.add_char b '\n';
  (* Define a struct after every struct it holds by value. *)
  let defined = ref [] in
  let rec define n =
    if not (List.mem n !defined) then begin
      defined := n :: !defined;
      let fs = Hashtbl.find env.structs n in
      List.iter
        (fun (f : Ast.field) ->
           match (unalias env f.Ast.fty).Ast.t with
           | Ast.Tname m when Hashtbl.mem env.structs m -> define m
           | _ -> ())
        fs;
      Printf.bprintf b "struct %s_s {  /* %s */\n" (ctype_name n) n;
      List.iter
        (fun (f : Ast.field) ->
           let c =
             cty env ~needed:(ref []) ~loc:f.Ast.floc
               ~what:(Printf.sprintf "field %s of %s" f.Ast.fname n) f.Ast.fty
           in
           let star = String.length c > 0 && c.[String.length c - 1] = '*' in
           (* A field name needs no digest: it is scoped to this struct, and
              two Flan fields that squash together are a duplicate member
              clang refuses by name. *)
           Printf.bprintf b "  %s%s%s;\n" c (if star then "" else " ")
             (squash f.Ast.fname))
        fs;
      Buffer.add_string b "};\n\n"
    end
  in
  List.iter define all;
  Buffer.contents b

(* ── The Flan halves ────────────────────────────────────────────────── *)

let ty loc t = { Ast.t; tloc = loc }
let ex loc e = { Ast.e; loc }

(* The flattened declaration the Flan side actually calls: a struct parameter
   becomes (Ptr T), a struct return becomes a trailing out-parameter. *)
let flattened (fn : Ast.fn) (s : shim) name : Ast.fn =
  let loc = fn.Ast.nloc in
  let params =
    List.map2
      (fun (p : Ast.field) (k, _) ->
         match k with
         | Pstruct n ->
           { p with
             Ast.fty =
               ty p.Ast.floc
                 (Ast.Tapp ("Ptr", [ ty p.Ast.floc (Ast.Tname n) ])) }
         | _ -> p)
      fn.Ast.params s.sargs
  in
  match s.sret with
  | `Struct (n, _) ->
    { fn with
      Ast.name;
      params =
        params
        @ [ { Ast.fname = "out"; floc = loc;
              fty = ty loc (Ast.Tapp ("Ptr", [ ty loc (Ast.Tname n) ])) } ];
      ret = None }
  | _ -> { fn with Ast.name; params }

(* The ordinary Flan function that carries the nice signature: it copies each
   struct argument into a local — a parameter is not an assignable place, so
   there is no address to take without one — and, when C returns a struct,
   zeroes one and hands over its address. *)
let flan_wrapper (fn : Ast.fn) (s : shim) raw : Ast.decl_kind =
  let loc = fn.Ast.nloc in
  let binds = ref [] in
  let args =
    List.mapi
      (fun i ((p : Ast.field), (k, _)) ->
         match k with
         | Pstruct _ ->
           let t = tmp i in
           binds :=
             !binds
             @ [ { Ast.bname = t; bty = None;
                   bval = ex p.Ast.floc (Ast.Var p.Ast.fname);
                   bloc = p.Ast.floc } ];
           ex p.Ast.floc
             (Ast.Call
                (ex p.Ast.floc (Ast.Var "addr"), [ ex p.Ast.floc (Ast.Var t) ]))
         | _ -> ex p.Ast.floc (Ast.Var p.Ast.fname))
      (List.combine fn.Ast.params s.sargs)
  in
  let call args = ex loc (Ast.Call (ex loc (Ast.Var raw), args)) in
  let body, ret =
    match s.sret with
    | `Struct (n, _) ->
      binds :=
        !binds
        @ [ { Ast.bname = out_tmp; bty = None;
              bval = ex loc (Ast.Struct (n, [])); bloc = loc } ];
      let out = ex loc (Ast.Var out_tmp) in
      ( [ call (args @ [ ex loc (Ast.Call (ex loc (Ast.Var "addr"), [ out ])) ]);
          out ],
        Some (ty loc (Ast.Tname n)) )
    | _ -> ([ call args ], fn.Ast.ret)
  in
  Ast.Defn { fn with Ast.ret; fbody = [ ex loc (Ast.Let (!binds, body)) ] }

(* ── Expansion ──────────────────────────────────────────────────────── *)

let one env ~taken (fn : Ast.fn) csym loc =
  let needed = ref [] in
  let sargs =
    List.map
      (fun (p : Ast.field) ->
         classify env ~needed ~loc:p.Ast.floc
           ~what:(Printf.sprintf "parameter %s of %s" p.Ast.fname fn.Ast.name)
           p.Ast.fty)
      fn.Ast.params
  in
  let what = Printf.sprintf "the return type of %s" fn.Ast.name in
  let sret =
    match fn.Ast.ret with
    | None -> `Void
    | Some t ->
      let t' = unalias env t in
      (match t'.Ast.t with
       | Ast.Tname "Unit" -> `Void
       | Ast.Tname n when Hashtbl.mem env.structs n ->
         ignore (cty env ~needed ~loc ~what t');
         `Struct (n, ctype_name n)
       | _ -> `Scalar (cty env ~needed ~loc ~what t'))
  in
  let s =
    { sflan = fn.Ast.name; ssym = csym; swrap = shim_symbol fn.Ast.name; sargs;
      sret; sloc = loc }
  in
  (* A declaration whose Flan face already equals its flattened face needs no
     Flan function on top of it; only the ones with a struct in the signature
     do. A string is not one of those — it crosses as ptr+len either way, and
     it is the C wrapper that terminates it. *)
  let needs_flan =
    (match sret with `Struct _ -> true | _ -> false)
    || List.exists (fun (k, _) -> match k with Pstruct _ -> true | _ -> false)
         sargs
  in
  let decls =
    if needs_flan then
      let raw = raw_name fn.Ast.name in
      (* The flattened declaration's name is made up, so it can collide with
         one somebody wrote. Refused here, naming both, rather than arriving as
         the checker's "declared twice" about a name not in the file. *)
      if Hashtbl.mem taken raw then
        fail loc
          "the declare-c of %s needs the name %s for the declaration it \
           generates, and %s is declared already — rename one of them"
          fn.Ast.name raw raw
      else [ Ast.Declare (flattened fn s raw, s.swrap); flan_wrapper fn s raw ]
    else [ Ast.Declare (flattened fn s fn.Ast.name, s.swrap) ]
  in
  (decls, s, !needed)

(* Every [declare-c] in the program, rewritten, with the one C file they share.
   The file is [None] when there are none, so a program that binds nothing pays
   no C compile. *)
(* The C comes back in parts rather than as one string: a wrapper belongs to
   the binding it serves, and [Reach.link] drops the bindings nothing reachable
   calls. One TU holding every wrapper would reference every C symbol in the
   library, so a program that imports raylib and never draws would still fail
   to link without libraylib — which is the whole thing [Reach] exists to
   avoid. The key is the flattened declaration's name; "" is the preamble. *)
let expand (decls : Ast.decl list) : Ast.decl list * (string * string) list =
  let env = scan decls in
  (* The flattened declaration's name is made up, so it can collide with one
     somebody wrote. Refused here, naming both, rather than surfacing as the
     checker's "declared twice" about a name that is not in the file. *)
  let taken = Hashtbl.create 64 in
  List.iter
    (fun (d : Ast.decl) ->
       match Ast.declared_name d with
       | Some n -> Hashtbl.replace taken n d.Ast.dloc
       | None -> ())
    decls;
  let shims = ref [] in
  let needed = ref [] in
  let out =
    List.concat_map
      (fun (d : Ast.decl) ->
         match d.Ast.d with
         | Ast.DeclareC (fn, csym) ->
           let ds, s, n = one env ~taken fn csym d.Ast.dloc in
           shims := !shims @ [ s ];
           List.iter
             (fun x -> if not (List.mem x !needed) then needed := !needed @ [ x ])
             n;
           List.map (fun k -> { d with Ast.d = k }) ds
         | _ -> [ d ])
      decls
  in
  match !shims with
  | [] -> (out, [])
  | shims ->
    (* Two Flan names may not bind one C symbol: the prototype would be emitted
       twice, and a second Flan name for the same function is a [defn] and not
       a second declaration. *)
    let seen = Hashtbl.create 16 in
    List.iter
      (fun s ->
         match Hashtbl.find_opt seen s.ssym with
         | Some other ->
           fail s.sloc
             "%s and %s both bind the C function %s — one declare-c per C \
              function, and another Flan name for it is a defn"
             other s.sflan s.ssym
         | None -> Hashtbl.replace seen s.ssym s.sflan)
      shims;
    let b = Buffer.create 4096 in
    Buffer.add_string b header;
    if List.exists (fun s -> List.exists (fun (k, _) -> k = Pstr) s.sargs) shims
    then Buffer.add_string b cstr_helpers;
    (* Every typedef the program needs, kept whole even when wrappers are
       dropped: an unused typedef costs nothing, and working out which ones a
       surviving subset still needs is a second dependency walk for no gain. *)
    Buffer.add_string b (typedefs env !needed);
    (out,
     ("", Buffer.contents b)
     (* Keyed by the wrapper's own C symbol, not by a Flan name: the flattened
        declaration is named [foo-c] when a Flan wrapper is generated over it
        and [foo] when none is needed, so the Flan name is not one thing.
        [swrap] is what the declaration binds either way. *)
     :: List.map (fun s -> (s.swrap, c_for s)) shims)