Joseph Ferano
1fb208a991
Reading the header produced declarations and nothing else, so the gap the whole thing exists to close — that nothing verifies a declaration against the library — was closed by a command somebody could run rather than by a property the build had. Now `import` runs both comparisons whenever a header resolves. Build-stopping, not a note. The package named the header, so the header is the package's own claim about what it binds; a defstruct that disagrees lays fields out in the wrong order and reads as five plausible numbers rather than as a link error. Continuing past a known-wrong layout to produce a program that will read garbage is the shape the house rule against swallowing things exists to prevent. Both messages point at the line in raylib.flan, not at the header. Verified by breaking it on purpose: a permuted Texture2D stops the build naming the field that moved, and `f64` where raylib says `float` stops it naming the parameter — which is the hazard BUILT.md calls out by name and says only a test can catch. A set-but-wrong FLAN_RAYLIB_H used to be indistinguishable from not opting in: the line was skipped and nothing was said. Unset still means off and silent; a path that is not there is now an error naming it. That is the difference between an opt-in and a trap. test/headers/sample.h is one function per decision the importer makes. The raylib case needs raylib installed, at the right version, with a variable set, so it would skip everywhere and cover nothing; this one does not move. It also found a bug, fixed next. Reach still prunes with 256 extra declarations in play: a wasm32-wasi build of a program that imports raylib and calls none of it links without libraylib, which is the case Reach.link exists for.
852 lines
38 KiB
OCaml
852 lines
38 KiB
OCaml
(** Reading a C header, so a binding is checked against the library instead of
|
|
transcribed from it.
|
|
|
|
[declare-c] closed half the gap: the wrapper, the typedefs and the
|
|
prototype are generated, so they cannot disagree with each other. The half
|
|
it left open is the one BUILT.md records as *trusted* — that the signature
|
|
somebody typed is the function's real signature. Nothing checked it,
|
|
because no header was ever read. This reads one.
|
|
|
|
{2 Why clang, and why not linked to it}
|
|
|
|
Zig's old [@cImport] ran clang as a *library*. That is precisely the
|
|
dependency plan.org rejected when it chose text IR over libLLVM bindings: a
|
|
version-pinned C++ library breaks routinely on upgrade, a binary on PATH
|
|
does not. So this shells out for [clang -Xclang -ast-dump=json
|
|
-fsyntax-only], which is the same binary the build already runs for every
|
|
other purpose and adds no dependency that is not already being paid for.
|
|
|
|
(Zig has since replaced clang here altogether with Aro, a C frontend
|
|
written in Zig. Their reason was to ship a compiler containing no clang at
|
|
all, self-contained and cross-compiling anywhere. This project has the
|
|
opposite premise — [clang] on PATH is the whole toolchain assumption — so
|
|
that move is explained by a constraint that does not apply here.)
|
|
|
|
{2 What is imported, and what bounds it}
|
|
|
|
Functions, and only functions. Not structs, not enums, not macros.
|
|
|
|
The bound on how much gets imported is not a curated list — it is the
|
|
package's own [defstruct]s. A C function is imported when every type in its
|
|
signature maps to something the package already declares or to a machine
|
|
scalar; a function mentioning a struct the package has not described is
|
|
refused, by name, with that reason. So [vendor/raylib] describing thirteen
|
|
structs is what makes the import thirteen structs wide, and describing a
|
|
fourteenth is what widens it. The layouts stay hand-written and stay the
|
|
single statement about what raylib's structs are, which is the thing the
|
|
acceptance tests pin; only the *signatures* come from the header.
|
|
|
|
This is also why no [defstruct] is generated. Generating one would make the
|
|
header the authority on layout, and then the check below — comparing the
|
|
package's [defstruct]s against the header's records — would be comparing
|
|
the header with itself. Keeping the layouts hand-written is what makes
|
|
[check_structs] an independent second source, and that check is the
|
|
cheapest real closure of BUILT.md's trusted-not-guaranteed gap: a
|
|
[_Static_assert] was rejected there as circular for exactly this reason,
|
|
and this is not circular, because the two sides have different authors.
|
|
|
|
{2 Refusing by demotion}
|
|
|
|
Taken from Zig, and the one decision here most worth keeping. Zig's
|
|
translator never drops a declaration it cannot handle: [failDecl] emits the
|
|
name bound to a [@compileError] carrying the reason, so the name still
|
|
exists, the program still compiles, and asking for that one name fails —
|
|
at the use site, with the reason. A wholesale import has hundreds of
|
|
refusals and a caller cares about the one they typed.
|
|
|
|
Flan has that mechanism already: [Load.refuse_hidden] is the same idea,
|
|
built for [main]. So a refused import becomes a hidden name.
|
|
[rl/get-gamepad-name] is not a name, and a program that writes it is told
|
|
*why* — "returns const char *, and a string only crosses as a parameter" —
|
|
rather than "unknown name".
|
|
|
|
This is also the split the existing generator needs and does not have.
|
|
[Shim] refuses through [Loc.fail], which is right when a human named one
|
|
function and wrong for a wholesale import: one returned [const char *]
|
|
would otherwise kill the whole header. Same judgement, different
|
|
disposition — a hand-written [declare-c] still hard-fails, and [Shim] is
|
|
untouched. *)
|
|
|
|
let fail = Loc.fail
|
|
|
|
(* ── Names ─────────────────────────────────────────────────────────
|
|
|
|
The C symbol is kept verbatim in [Ast.DeclareC], so the kebab rule never
|
|
needs an inverse: the generated wrapper reads the spelling out of the
|
|
declaration rather than reconstructing it. What the rule does have to be is
|
|
*injective over one header*, since two C functions arriving under one Flan
|
|
name is a collision the checker would report as a duplicate declaration
|
|
about a name nobody wrote. That is asserted below, by name.
|
|
|
|
The rule, in full. A boundary goes before a character that is
|
|
|
|
- an uppercase letter after a lowercase one — [InitWindow] → init-window
|
|
- an uppercase letter between an uppercase and
|
|
a lowercase one — [ColorToHSV] → color-to-hsv
|
|
- a digit after a lowercase letter — [BeginMode2D] → begin-mode-2d
|
|
|
|
and nowhere else; an underscore is a boundary and disappears. The third
|
|
clause is what keeps [2D] together as one word, and the second is what keeps
|
|
an acronym together: [SetTargetFPS] is set-target-fps and not
|
|
set-target-f-p-s, [UnloadUTF8] is unload-utf8. *)
|
|
|
|
let kebab (s : string) : string =
|
|
let n = String.length s in
|
|
let b = Buffer.create (n + 8) in
|
|
String.iteri
|
|
(fun i c ->
|
|
let prev = if i > 0 then s.[i - 1] else '\000' in
|
|
let next = if i + 1 < n then s.[i + 1] else '\000' in
|
|
let upper c = c >= 'A' && c <= 'Z' in
|
|
let lower c = c >= 'a' && c <= 'z' in
|
|
let digit c = c >= '0' && c <= '9' in
|
|
if
|
|
i > 0 && prev <> '_'
|
|
&& ((upper c && lower prev)
|
|
|| (upper c && upper prev && lower next)
|
|
|| (digit c && lower prev))
|
|
then Buffer.add_char b '-';
|
|
if c = '_' then (if Buffer.length b > 0 then Buffer.add_char b '-')
|
|
else Buffer.add_char b (Char.lowercase_ascii c))
|
|
s;
|
|
Buffer.contents b
|
|
|
|
(* ── What clang was asked, and what it said ────────────────────────── *)
|
|
|
|
(* One C function, as the dump describes it and before anything is decided
|
|
about whether Flan can hold it. *)
|
|
type cfn = {
|
|
csym : string;
|
|
cret : string; (* the return type, as clang spells it *)
|
|
cparams : (string * string) list; (* name (possibly ""), type *)
|
|
cvariadic : bool;
|
|
cloc : Loc.t; (* the line of the header it is on *)
|
|
}
|
|
|
|
(* One C struct, for checking a [defstruct] against. *)
|
|
type crecord = { rname : string; rfields : (string * string) list }
|
|
|
|
type dump = {
|
|
fns : cfn list;
|
|
records : crecord list;
|
|
(* A typedef's underlying spelling: [Texture2D] → [struct Texture], and
|
|
[Camera] → [Camera3D]. Followed when the spelled name is not one the
|
|
package declares, which is what lets a Flan [defstruct Texture2D] serve a
|
|
C parameter typed [Texture]. *)
|
|
typedefs : (string * string) list;
|
|
(* The typedef names that are enums rather than records. A C enum is an int
|
|
on every target this compiles for, which is also what [Shim] lowers a Flan
|
|
[defenum] to, so the two agree by construction. *)
|
|
enums : string list;
|
|
}
|
|
|
|
let clang_argv ~header ~flags =
|
|
[ "clang"; "-Xclang"; "-ast-dump=json"; "-fsyntax-only" ] @ flags @ [ header ]
|
|
|
|
(* clang's stdout, or its stderr if it failed. Run through [Unix.create_process]
|
|
rather than a shell so a path with a space in it needs no quoting and no
|
|
[Filename.quote] round trip. *)
|
|
let run_clang ~loc ~header ~flags =
|
|
if not (Sys.file_exists header) then
|
|
fail loc "no such header: %s" header;
|
|
let argv = clang_argv ~header ~flags in
|
|
let out_r, out_w = Unix.pipe ~cloexec:false () in
|
|
let err_r, err_w = Unix.pipe ~cloexec:false () in
|
|
let pid =
|
|
try
|
|
Unix.create_process "clang" (Array.of_list argv) Unix.stdin out_w err_w
|
|
with Unix.Unix_error _ ->
|
|
List.iter Unix.close [ out_r; out_w; err_r; err_w ];
|
|
fail loc
|
|
"clang is not on PATH, and reading a C header is done by running it \
|
|
(%s)"
|
|
(String.concat " " argv)
|
|
in
|
|
Unix.close out_w;
|
|
Unix.close err_w;
|
|
(* Both pipes have to be drained as they fill: the dump is megabytes and a
|
|
process blocked writing stdout while this waits on its exit is a deadlock
|
|
that only shows up on a big header. *)
|
|
let read_all fd =
|
|
let b = Buffer.create 65536 in
|
|
let chunk = Bytes.create 65536 in
|
|
let rec go () =
|
|
match Unix.read fd chunk 0 65536 with
|
|
| 0 -> ()
|
|
| k -> Buffer.add_subbytes b chunk 0 k; go ()
|
|
| exception Unix.Unix_error (Unix.EINTR, _, _) -> go ()
|
|
in
|
|
go (); Buffer.contents b
|
|
in
|
|
let out_buf = Buffer.create (1 lsl 21) in
|
|
let err_buf = Buffer.create 4096 in
|
|
(* Read stdout first but keep stderr drained too. clang writes very little to
|
|
stderr for a header that parses, and a header that does not parse writes
|
|
little enough to fit a pipe, so alternating is not needed — but stdout is
|
|
the one that is megabytes, so it is the one read in the loop. *)
|
|
Buffer.add_string out_buf (read_all out_r);
|
|
Buffer.add_string err_buf (read_all err_r);
|
|
Unix.close out_r;
|
|
Unix.close err_r;
|
|
let status = snd (Unix.waitpid [] pid) in
|
|
(match status with
|
|
| Unix.WEXITED 0 -> ()
|
|
| _ ->
|
|
fail loc "clang could not parse %s:\n%s" header
|
|
(String.trim (Buffer.contents err_buf)));
|
|
Buffer.contents out_buf
|
|
|
|
(* ── Reading the dump ──────────────────────────────────────────────── *)
|
|
|
|
(* clang omits [loc.file] when it is the same as the previous node's, so file
|
|
attribution is a fold over the children in order and not a lookup. Getting
|
|
this wrong is not loud: it silently imports everything the header includes,
|
|
or nothing at all. *)
|
|
let qual j = match Cjson.mem "type" j with Some t -> Cjson.str "qualType" t | None -> None
|
|
|
|
let read_dump ~header (root : Cjson.t) : dump =
|
|
let want = try Unix.realpath header with Unix.Unix_error _ -> header in
|
|
let same f = try Unix.realpath f = want with Unix.Unix_error _ -> f = want in
|
|
let cur = ref "" in
|
|
let fns = ref [] and records = ref [] and typedefs = ref [] and enums = ref [] in
|
|
List.iter
|
|
(fun d ->
|
|
(match Cjson.mem "loc" d with
|
|
| Some l -> (match Cjson.str "file" l with Some f -> cur := f | None -> ())
|
|
| None -> ());
|
|
let mine = same !cur in
|
|
let name = Cjson.str "name" d in
|
|
match (Cjson.str "kind" d, name) with
|
|
| Some "FunctionDecl", Some nm when mine ->
|
|
(* A [static] or [inline] definition in a header has no symbol to
|
|
link against from outside the translation unit that has the body.
|
|
Left out rather than imported and met at the linker. *)
|
|
let sc = Cjson.str "storageClass" d in
|
|
if sc <> Some "static" then begin
|
|
let q = match qual d with Some q -> q | None -> "" in
|
|
let cret =
|
|
match String.index_opt q '(' with
|
|
| Some k -> String.trim (String.sub q 0 k)
|
|
| None -> q
|
|
in
|
|
let cparams =
|
|
List.filter_map
|
|
(fun p ->
|
|
if Cjson.str "kind" p = Some "ParmVarDecl" then
|
|
Some (Option.value ~default:"" (Cjson.str "name" p),
|
|
Option.value ~default:"" (qual p))
|
|
else None)
|
|
(Cjson.arr "inner" d)
|
|
in
|
|
let line =
|
|
match Cjson.mem "loc" d with
|
|
| Some l ->
|
|
(match Cjson.mem "line" l with
|
|
| Some (Cjson.Num f) -> int_of_float f
|
|
| _ -> 0)
|
|
| None -> 0
|
|
in
|
|
fns := { csym = nm; cret; cparams; cvariadic = Cjson.bool "variadic" d;
|
|
cloc = Loc.make !cur line 1 }
|
|
:: !fns
|
|
end
|
|
| Some "RecordDecl", Some nm when mine && Cjson.bool "completeDefinition" d ->
|
|
let rfields =
|
|
List.filter_map
|
|
(fun f ->
|
|
if Cjson.str "kind" f = Some "FieldDecl" then
|
|
Some (Option.value ~default:"" (Cjson.str "name" f),
|
|
Option.value ~default:"" (qual f))
|
|
else None)
|
|
(Cjson.arr "inner" d)
|
|
in
|
|
(* A bitfield has no address and no Flan spelling; a record holding
|
|
one is not one this can check, so it is not recorded and the
|
|
[defstruct] beside it is left unchecked rather than checked
|
|
wrongly. Same for an unnamed field, which is an anonymous union or
|
|
struct. *)
|
|
let ok =
|
|
List.for_all
|
|
(fun f ->
|
|
Cjson.str "kind" f <> Some "FieldDecl"
|
|
|| (not (Cjson.bool "isBitfield" f)
|
|
&& Cjson.str "name" f <> None))
|
|
(Cjson.arr "inner" d)
|
|
in
|
|
if ok then records := { rname = nm; rfields } :: !records
|
|
| Some "TypedefDecl", Some nm when mine ->
|
|
(match qual d with
|
|
| Some u ->
|
|
typedefs := (nm, u) :: !typedefs;
|
|
if String.length u > 5 && String.sub u 0 5 = "enum " then
|
|
enums := nm :: !enums
|
|
| None -> ())
|
|
| _ -> ())
|
|
(Cjson.arr "inner" root);
|
|
{ fns = List.rev !fns; records = List.rev !records;
|
|
typedefs = List.rev !typedefs; enums = List.rev !enums }
|
|
|
|
(* ── C types into Flan types ───────────────────────────────────────── *)
|
|
|
|
(* What the package already says exists. The importer adds no type of its own:
|
|
it either finds a Flan name for a C type here or refuses the function. *)
|
|
type env = {
|
|
known_structs : string list; (* the package's defstruct names *)
|
|
known_enums : string list; (* its defenum names *)
|
|
d : dump;
|
|
}
|
|
|
|
exception Refused of string
|
|
|
|
let refuse fmt = Printf.ksprintf (fun m -> raise (Refused m)) fmt
|
|
|
|
let strip_prefix p s =
|
|
let lp = String.length p in
|
|
if String.length s >= lp && String.sub s 0 lp = p then
|
|
Some (String.trim (String.sub s lp (String.length s - lp)))
|
|
else None
|
|
|
|
(* [const struct Foo] → [Foo]. Qualifiers carry no Flan meaning — Flan has no
|
|
const — but they have to come off before the name is recognised, and
|
|
const-ness is read *before* this, where it still means something (see
|
|
[param_ty]). *)
|
|
let rec bare s =
|
|
let s = String.trim s in
|
|
match
|
|
List.find_map (fun p -> strip_prefix p s)
|
|
[ "const "; "volatile "; "restrict "; "struct "; "union "; "enum " ]
|
|
with
|
|
| Some s' -> bare s'
|
|
| None -> s
|
|
|
|
(* A generated type expression carries no location of its own: the thing a
|
|
message about it wants to point at is the declaration's line in the header,
|
|
which is what the field and the declaration below carry. *)
|
|
let ty t = { Ast.t; tloc = Loc.unknown }
|
|
|
|
let rec ty_source (t : Ast.texpr) =
|
|
match t.Ast.t with
|
|
| Ast.Tname n -> n
|
|
| Ast.Tapp (n, args) ->
|
|
Printf.sprintf "(%s %s)" n (String.concat " " (List.map ty_source args))
|
|
| Ast.Tslice e -> Printf.sprintf "[%s]" (ty_source e)
|
|
| Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (ty_source e)
|
|
| Ast.Tarray (Ast.Lname n, e) -> Printf.sprintf "[%s %s]" n (ty_source e)
|
|
| Ast.Tmap (k, v) -> Printf.sprintf "{%s %s}" (ty_source k) (ty_source v)
|
|
| Ast.Tfn (ps, r) ->
|
|
Printf.sprintf "(Fn [%s] %s)"
|
|
(String.concat " " (List.map ty_source ps)) (ty_source r)
|
|
|
|
let tname n = ty (Ast.Tname n)
|
|
|
|
(* The machine scalars, and the ones deliberately left out.
|
|
|
|
[long], [size_t] and the rest are refused rather than guessed, and the
|
|
reason is specific to this project rather than general fussiness: it builds
|
|
for x86-64, for wasm32-wasi and for the browser, and [long] is 64 bits on
|
|
the first and 32 on the others. A guess would be right for the target that
|
|
gets tested and silently wrong for the two that do not. A header that wants
|
|
one says so in [declare-c], where a human takes responsibility for it. *)
|
|
let scalar = function
|
|
| "void" -> Some "Unit"
|
|
| "_Bool" | "bool" -> Some "bool"
|
|
| "char" | "signed char" | "int8_t" -> Some "i8"
|
|
| "unsigned char" | "uint8_t" -> Some "u8"
|
|
| "short" | "short int" | "int16_t" -> Some "i16"
|
|
| "unsigned short" | "unsigned short int" | "uint16_t" -> Some "u16"
|
|
| "int" | "signed int" | "int32_t" -> Some "i32"
|
|
| "unsigned" | "unsigned int" | "uint32_t" -> Some "u32"
|
|
| "int64_t" | "long long" | "long long int" -> Some "i64"
|
|
| "uint64_t" | "unsigned long long" | "unsigned long long int" -> Some "u64"
|
|
| "float" -> Some "f32"
|
|
| "double" -> Some "f64"
|
|
| _ -> None
|
|
|
|
let width_varies =
|
|
[ "long"; "long int"; "unsigned long"; "unsigned long int"; "size_t";
|
|
"ssize_t"; "ptrdiff_t"; "intptr_t"; "uintptr_t"; "time_t"; "wchar_t" ]
|
|
|
|
(* A named type, after qualifiers and pointers are gone: a struct the package
|
|
describes, an enum, or nothing this can hold. *)
|
|
let rec named env (n : string) : Ast.texpr =
|
|
if List.mem n env.known_structs then tname n
|
|
else if List.mem n env.known_enums then tname n
|
|
else if List.mem n env.d.enums then
|
|
(* A C enum is an int, which is what [Shim] lowers a Flan [defenum] to, so
|
|
this is the same ABI and not a widening. What it loses is the nice face:
|
|
a parameter typed [Key] takes [:space] at the call site and an [i32]
|
|
does not. That is a reason to keep a hand-written [declare-c] for the
|
|
few calls where it matters, not a reason to refuse the other five
|
|
hundred. *)
|
|
tname "i32"
|
|
else if List.exists (fun r -> r.rname = n) env.d.records then
|
|
(* Checked before the typedef table, because C's usual idiom
|
|
[typedef struct Vector3 { ... } Vector3;] puts the same name in both and
|
|
following it would arrive straight back here.
|
|
|
|
One step first, in the other direction: the package may already describe
|
|
this record under one of its *other* typedef names. raylib's record is
|
|
[struct Texture] and [Texture2D], [TextureCubemap] and the package's own
|
|
[defstruct Texture2D] are all names for it, so [LoadTextureCubemap]
|
|
returns the same struct the package has described and refusing it would
|
|
be wrong. Any known struct whose typedef bottoms out at this record
|
|
will do; they denote the same layout by construction. *)
|
|
match
|
|
List.find_opt
|
|
(fun k ->
|
|
match List.assoc_opt k env.d.typedefs with
|
|
| Some u -> String.equal (bare u) n
|
|
| None -> false)
|
|
env.known_structs
|
|
with
|
|
| Some k -> tname k
|
|
| None ->
|
|
refuse
|
|
"%s is a struct the package does not describe — add a defstruct for \
|
|
it, or keep a hand-written declare-c"
|
|
n
|
|
else if List.mem_assoc n env.d.typedefs then begin
|
|
let u = List.assoc n env.d.typedefs in
|
|
if bare u = n then
|
|
refuse "%s is a typedef of itself, which is not a type" n
|
|
else
|
|
(* Back through [value_ty] and not straight to [named]: a typedef may
|
|
name a pointer or a function pointer — raylib's [AudioCallback] is
|
|
one — and only [value_ty] knows what to say about either. Going
|
|
straight to [named] reported a callback as an unknown type rather
|
|
than as the callback it is. *)
|
|
value_ty env u
|
|
end
|
|
else if List.mem n width_varies then
|
|
refuse
|
|
"%s has a width that differs between this project's own targets (64 \
|
|
bits on x86-64, 32 on wasm32), so no single Flan type is right for it"
|
|
n
|
|
else refuse "%s is not a type the header importer knows" n
|
|
|
|
(* A type in any position but an outermost parameter. Pointers are where C says
|
|
least and Flan has to say something: a [T *] is one T, or an array of them,
|
|
or null, and the header does not distinguish. Flan's [(Ptr T)] claims only
|
|
"the address of a T", which is the weakest of those and therefore the only
|
|
honest one — the same judgement Zig makes when it translates [T *] to
|
|
[[*c]T] rather than to a single-item pointer. *)
|
|
and value_ty env (s : string) : Ast.texpr =
|
|
let s = String.trim s in
|
|
if String.length s > 0 && s.[String.length s - 1] = '*' then begin
|
|
let inner = String.trim (String.sub s 0 (String.length s - 1)) in
|
|
let b = bare inner in
|
|
(* [void *] is an address of unknown element type; [(Ptr u8)] is what the
|
|
package already spells that as ([Image.data]). *)
|
|
if b = "void" then ty (Ast.Tapp ("Ptr", [ tname "u8" ]))
|
|
else ty (Ast.Tapp ("Ptr", [ value_ty env inner ]))
|
|
end
|
|
else if String.contains s '[' then
|
|
refuse "%s is an array, which C passes as a pointer and Flan as a value" s
|
|
else if String.contains s '(' then
|
|
refuse "%s is a function pointer, and a C callback is not implemented" s
|
|
else
|
|
let b = bare s in
|
|
match scalar b with
|
|
| Some "Unit" -> refuse "void is not a value"
|
|
| Some p -> tname p
|
|
| None -> named env b
|
|
|
|
(* A parameter, where two C spellings mean things no other position does.
|
|
|
|
[const char *] is a string going in, and [Shim] already knows how to hand
|
|
one over: Flan's ptr+len, NUL-terminated into a copy for the duration of the
|
|
call. [char *] without the const is not that. It is very often a buffer the
|
|
callee *writes*, and handing it a temporary copy would lose the writes with
|
|
no diagnostic anywhere. const is the only thing in the header that separates
|
|
the two, so it is what decides, and a genuine out-buffer keeps a
|
|
hand-written binding that says [(Ptr u8)] and means it. *)
|
|
let param_ty env (s : string) : Ast.texpr =
|
|
let s = String.trim s in
|
|
if String.length s > 0 && s.[String.length s - 1] = '*' then begin
|
|
let inner = String.trim (String.sub s 0 (String.length s - 1)) in
|
|
let is_const = strip_prefix "const " inner <> None in
|
|
match bare inner with
|
|
| "char" when is_const -> tname "string"
|
|
| "char" ->
|
|
refuse
|
|
"char * is a parameter C may write through, and a Flan string crosses \
|
|
as a NUL-terminated copy — the writes would be lost. const char * is \
|
|
a string; this one needs a declare-c saying (Ptr u8)"
|
|
| _ -> value_ty env s
|
|
end
|
|
else value_ty env s
|
|
|
|
(* The return type. Every refusal here is one [Shim] would also make; it is
|
|
made earlier so that the reason names the C spelling rather than the Flan
|
|
one it was about to become. *)
|
|
let ret_ty env (s : string) : Ast.texpr option =
|
|
let s = String.trim s in
|
|
if bare s = "void" && not (String.contains s '*') then None
|
|
else if String.length s > 0 && s.[String.length s - 1] = '*' then begin
|
|
let inner = String.trim (String.sub s 0 (String.length s - 1)) in
|
|
match bare inner with
|
|
| "char" ->
|
|
refuse
|
|
"returns char *, and a string only crosses as a parameter — a C \
|
|
function that returns one returns something Flan has no owner for"
|
|
| _ -> Some (value_ty env s)
|
|
end
|
|
else Some (value_ty env s)
|
|
|
|
(* ── One header, imported ──────────────────────────────────────────── *)
|
|
|
|
type imported = {
|
|
decls : Ast.decl list;
|
|
(* Name and reason, for [Load.refuse_hidden]: the name exists as a thing
|
|
that cannot be had, and asking for it says why. Zig's [failDecl]. *)
|
|
hidden : (string * string) list;
|
|
}
|
|
|
|
(* [taken] is every name the package already declares, which is what makes the
|
|
sidecar additive: a hand-written [(declare-c get-gamepad-name ...)] wins
|
|
over the header, and a C symbol already bound by hand is not bound twice —
|
|
which [Shim] would refuse for the whole build.
|
|
|
|
[-c] as well as the name itself, because [Shim] generates [foo-c] beside a
|
|
[foo] whose signature has a struct in it, and a collision there is refused
|
|
for the whole program rather than for the one binding. *)
|
|
let of_dump ~env ~taken ~bound_syms (d : dump) : imported =
|
|
let decls = ref [] and hidden = ref [] and by_name = Hashtbl.create 512 in
|
|
List.iter
|
|
(fun f ->
|
|
let flan = kebab f.csym in
|
|
let skip why = hidden := (flan, why) :: !hidden in
|
|
if List.mem f.csym bound_syms then
|
|
(* Not hidden: the name the package wrote for it is there and works.
|
|
This is the escape hatch doing its job. *)
|
|
()
|
|
else if Hashtbl.mem taken flan || Hashtbl.mem taken (flan ^ "-c") then
|
|
skip
|
|
(Printf.sprintf
|
|
"%s would be the imported name of %s, and the package declares \
|
|
%s already" flan f.csym flan)
|
|
else if Hashtbl.mem by_name flan then
|
|
skip
|
|
(Printf.sprintf
|
|
"%s and %s both kebab to %s, so the header cannot be imported \
|
|
whole — one of them needs a hand-written declare-c"
|
|
(Hashtbl.find by_name flan) f.csym flan)
|
|
else if f.cvariadic then
|
|
skip
|
|
(Printf.sprintf
|
|
"%s is variadic, and a wrapper cannot forward an argument list \
|
|
it does not know the shape of" f.csym)
|
|
else
|
|
match
|
|
(try
|
|
let ps =
|
|
List.mapi
|
|
(fun i (n, t) ->
|
|
let n = if n = "" then Printf.sprintf "a%d" i else kebab n in
|
|
{ Ast.fname = n; fty = param_ty env t; floc = f.cloc })
|
|
f.cparams
|
|
in
|
|
(* [void] spelled as the only parameter is C for "none". clang
|
|
reports it as no ParmVarDecl at all, so this is belt and
|
|
braces. *)
|
|
let ps = List.filter (fun (p : Ast.field) -> p.Ast.fname <> "void") ps in
|
|
Ok (ps, ret_ty env f.cret)
|
|
with Refused why -> Error why)
|
|
with
|
|
| Error why -> skip (Printf.sprintf "%s %s" f.csym why)
|
|
| Ok (params, ret) ->
|
|
Hashtbl.replace by_name flan f.csym;
|
|
decls :=
|
|
{ Ast.d =
|
|
Ast.DeclareC
|
|
({ Ast.name = flan; params; ret; fbody = []; nloc = f.cloc },
|
|
f.csym);
|
|
dloc = f.cloc }
|
|
:: !decls)
|
|
d.fns;
|
|
{ decls = List.rev !decls; hidden = List.rev !hidden }
|
|
|
|
(* ── Checking the package's layouts against the header's ───────────── *)
|
|
|
|
(* The point of reading a header that the generator does not otherwise need.
|
|
|
|
BUILT.md rejected a [_Static_assert] on [sizeof]/[offsetof] as circular:
|
|
both sides would have come from the same field list. This is not circular.
|
|
The [defstruct] was written by hand and the record comes from the library's
|
|
own header, so a disagreement is real information — and it is the failure
|
|
mode the whole FFI is most exposed to, since a permuted [Texture2D] reads as
|
|
five plausible numbers and no link error.
|
|
|
|
Reported and not raised. A package may legitimately describe a prefix of a
|
|
struct it only ever holds by pointer, and a header that is a different
|
|
version of the library is a normal state of affairs to be told about rather
|
|
than stopped by. *)
|
|
let check_structs ~env ~(structs : (string * Ast.field list) list) (d : dump) =
|
|
let record n =
|
|
match List.find_opt (fun r -> r.rname = n) d.records with
|
|
| Some r -> Some r
|
|
| None ->
|
|
(* [defstruct Texture2D] against a header whose record is [Texture] and
|
|
whose typedef says so. *)
|
|
(match List.assoc_opt n d.typedefs with
|
|
| Some u -> List.find_opt (fun r -> r.rname = bare u) d.records
|
|
| None -> None)
|
|
in
|
|
(* Names and widths both. Order is what a permuted [defstruct] gets wrong and
|
|
what BUILT.md says only a test can catch; width is the other half of the
|
|
same hazard and the one it calls out by name — [f64] where the library
|
|
says [float] lays out eight bytes where there are four, and every field
|
|
after it moves. Comparing the rendered Flan type rather than the C
|
|
spelling keeps the two sides commensurable: [u8] and [unsigned char] have
|
|
to come out equal, and [f32] and [double] have to not. *)
|
|
let field_mismatch (fs : Ast.field list) (r : crecord) =
|
|
if List.length fs <> List.length r.rfields then
|
|
Some
|
|
(Printf.sprintf "defstruct has %d fields [%s] and %s has %d [%s]"
|
|
(List.length fs)
|
|
(String.concat " " (List.map (fun (f : Ast.field) -> f.Ast.fname) fs))
|
|
r.rname (List.length r.rfields)
|
|
(String.concat " " (List.map (fun (n, _) -> kebab n) r.rfields)))
|
|
else
|
|
List.find_map
|
|
(fun ((f : Ast.field), (cn, ct)) ->
|
|
if kebab cn <> f.Ast.fname then
|
|
Some
|
|
(Printf.sprintf
|
|
"the defstruct has %s where %s has %s, so the field order disagrees"
|
|
f.Ast.fname r.rname (kebab cn))
|
|
else
|
|
match (try Some (value_ty env ct) with Refused _ -> None) with
|
|
| None -> None (* a field type this cannot render says nothing *)
|
|
| Some want ->
|
|
let a = ty_source want and b = ty_source f.Ast.fty in
|
|
if String.equal a b then None
|
|
else
|
|
Some
|
|
(Printf.sprintf "field %s is %s in the defstruct and %s (%s) in %s"
|
|
f.Ast.fname b a ct r.rname))
|
|
(List.combine fs r.rfields)
|
|
in
|
|
List.filter_map
|
|
(fun (n, (fs : Ast.field list)) ->
|
|
match record n with
|
|
| None -> None
|
|
| Some r -> Option.map (fun m -> (n, m)) (field_mismatch fs r))
|
|
structs
|
|
|
|
(* ── The entry point ───────────────────────────────────────────────── *)
|
|
|
|
let dump_of_clang ~loc ~header ~flags =
|
|
let text = run_clang ~loc ~header ~flags in
|
|
let json =
|
|
try Cjson.parse text
|
|
with Cjson.Bad m ->
|
|
fail loc "clang's AST dump of %s did not parse: %s" header m
|
|
in
|
|
read_dump ~header json
|
|
|
|
(* ── The cache ─────────────────────────────────────────────────────── *)
|
|
|
|
(* Measured, not assumed: reading raylib.h costs 64ms — 30ms for clang to write
|
|
1.8 MB of JSON and the rest to parse it and map it — against an 8ms check
|
|
for the whole program without it. The dev loop rebuilds constantly and the
|
|
header does not change between two of those rebuilds, so paying it every
|
|
time is eight times the cost of everything else put together.
|
|
|
|
What is cached is the *extracted* dump and not clang's JSON: it is the
|
|
parse that is half the cost, and what comes out is a few hundred signatures
|
|
rather than megabytes of source ranges.
|
|
|
|
Keyed the way the object cache is keyed, and for the same reason — on
|
|
everything that could change the answer. The header's path, its size and
|
|
mtime, and the full flag list, because a flag changes what clang sees; plus
|
|
a format version, because the cached value is a marshalled OCaml value and a
|
|
compiler whose [dump] type has changed must not read one written by the old
|
|
one. [Marshal] does not check that for you and a mismatch is a segfault
|
|
rather than an exception, so the discipline is: **change the [dump] type,
|
|
bump [cache_format] in the same commit.** Nothing enforces it. *)
|
|
|
|
let cache_format = 1
|
|
|
|
let cachedir () =
|
|
let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-cimport" in
|
|
(try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
|
|
d
|
|
|
|
let dump_of ~loc ~header ~flags =
|
|
let st = try Some (Unix.stat header) with Unix.Unix_error _ -> None in
|
|
match st with
|
|
| None -> dump_of_clang ~loc ~header ~flags
|
|
| Some st ->
|
|
let key =
|
|
Digest.to_hex
|
|
(Digest.string
|
|
(String.concat "\000"
|
|
[ string_of_int cache_format;
|
|
(try Unix.realpath header with Unix.Unix_error _ -> header);
|
|
string_of_int st.Unix.st_size;
|
|
Printf.sprintf "%.6f" st.Unix.st_mtime;
|
|
String.concat " " flags ]))
|
|
in
|
|
let path = Filename.concat (cachedir ()) (key ^ ".dump") in
|
|
let cached =
|
|
if not (Sys.file_exists path) then None
|
|
else
|
|
try
|
|
let ch = open_in_bin path in
|
|
Fun.protect
|
|
~finally:(fun () -> close_in_noerr ch)
|
|
(fun () -> Some (Marshal.from_channel ch : dump))
|
|
with _ ->
|
|
(* A truncated or stale file is not worth a build failure: the header
|
|
is right there and can be read again. *)
|
|
(try Sys.remove path with Sys_error _ -> ());
|
|
None
|
|
in
|
|
(match cached with
|
|
| Some d -> d
|
|
| None ->
|
|
let d = dump_of_clang ~loc ~header ~flags in
|
|
(* Written to a distinct name and renamed, so two builds running at
|
|
once cannot see a half-written file — the object cache does the
|
|
same. *)
|
|
(try
|
|
let tmp = Printf.sprintf "%s.%d.tmp" path (Unix.getpid ()) in
|
|
let ch = open_out_bin tmp in
|
|
Fun.protect
|
|
~finally:(fun () -> close_out_noerr ch)
|
|
(fun () -> Marshal.to_channel ch d []);
|
|
Sys.rename tmp path
|
|
with Sys_error _ -> ());
|
|
d)
|
|
|
|
let env_of ~known_structs ~known_enums d = { known_structs; known_enums; d }
|
|
|
|
let header ~loc ~header:h ~flags ~known_structs ~known_enums ~taken ~bound_syms =
|
|
let d = dump_of ~loc ~header:h ~flags in
|
|
let env = env_of ~known_structs ~known_enums d in
|
|
(of_dump ~env ~taken ~bound_syms d, d, env)
|
|
|
|
(* ── Printing a declaration back as source ─────────────────────────── *)
|
|
|
|
(* Which makes the third option in DISCUSS.md item 6 available at no extra
|
|
cost: generate the declarations from the header, *commit the result*, and
|
|
regenerate when the library moves. That trade — explicit in the source,
|
|
checked against reality, no header read at build time — is a real one, and
|
|
it needs a printer and nothing else. [flan import-c] is it. *)
|
|
|
|
|
|
let decl_source (d : Ast.decl) =
|
|
match d.Ast.d with
|
|
| Ast.DeclareC (fn, csym) ->
|
|
Printf.sprintf "(declare-c %s [%s]%s %S)" fn.Ast.name
|
|
(String.concat " "
|
|
(List.map
|
|
(fun (p : Ast.field) ->
|
|
Printf.sprintf "%s %s" p.Ast.fname (ty_source p.Ast.fty))
|
|
fn.Ast.params))
|
|
(match fn.Ast.ret with None -> "" | Some t -> " " ^ ty_source t)
|
|
csym
|
|
| _ -> ""
|
|
|
|
(* ── A hand-written binding, against the header's own signature ────── *)
|
|
|
|
(* The other half of closing the trusted gap, and the one that pays off
|
|
immediately: [vendor/raylib] carries 176 [declare-c] lines that were
|
|
transcribed by hand from raylib's documentation, and until now nothing could
|
|
say whether any of them was right. This says so, one at a time.
|
|
|
|
Compared as *rendered Flan types*, not as C spellings, because the two sides
|
|
are not written in the same language and only the Flan rendering is
|
|
commensurable. Three differences are expected and are not reported:
|
|
|
|
- the Flan name. [IsKeyPressed] is [key-pressed?] by hand and
|
|
[is-key-pressed] by rule, and the hand-written one is better. The C symbol
|
|
is what identifies the function here, not the name.
|
|
- an enum parameter. The header says [KeyboardKey] and the importer has no
|
|
way to know the package calls that [Key], so it says [i32]; the
|
|
hand-written [Key] is the same int with a better face.
|
|
- a [(Ptr T)] where the header says [T *] and the hand-written line chose
|
|
something more specific for a reason it recorded.
|
|
|
|
What is left after those is a real disagreement about a width, an arity or a
|
|
direction — which is exactly the class of bug BUILT.md warns about, where
|
|
[f64] against the library's [float] reads as garbage rather than as a link
|
|
error. *)
|
|
|
|
type sig_diff = { dsym : string; dflan : string; dwhy : string }
|
|
|
|
let diff_bound ~env ~(bound : (Ast.fn * string) list) (d : dump) =
|
|
let by_sym = Hashtbl.create 512 in
|
|
List.iter (fun f -> Hashtbl.replace by_sym f.csym f) d.fns;
|
|
List.filter_map
|
|
(fun ((fn : Ast.fn), csym) ->
|
|
match Hashtbl.find_opt by_sym csym with
|
|
| None ->
|
|
Some
|
|
{ dsym = csym; dflan = fn.Ast.name;
|
|
dwhy = "the header does not declare this function at all" }
|
|
| Some c ->
|
|
let say why = Some { dsym = csym; dflan = fn.Ast.name; dwhy = why } in
|
|
(* An enum on the Flan side against a plain int from the header is
|
|
the expected difference and not a finding — that is what a Flan
|
|
[defenum] *is* at the boundary, and giving it a name is the whole
|
|
point of declaring one. Signedness goes with it: raylib spells
|
|
[IsGestureDetected]'s parameter [unsigned int] and the package
|
|
calls it [Gesture], and since both are four bytes in a register
|
|
there is no ABI difference to report. What is still reported is an
|
|
enum against something that is *not* a 32-bit integer, which would
|
|
be a real one. *)
|
|
let enum_like (t : Ast.texpr) =
|
|
match t.Ast.t with
|
|
| Ast.Tname n -> List.mem n env.known_enums
|
|
| _ -> false
|
|
in
|
|
let int32_like s = String.equal s "i32" || String.equal s "u32" in
|
|
let norm (t : Ast.texpr) = ty_source t in
|
|
let same a b =
|
|
String.equal (norm a) (norm b)
|
|
|| (enum_like a && int32_like (norm b))
|
|
|| (enum_like b && int32_like (norm a))
|
|
in
|
|
if c.cvariadic then None
|
|
else if List.length fn.Ast.params <> List.length c.cparams then
|
|
say
|
|
(Printf.sprintf "declared with %d parameters and the header says %d (%s)"
|
|
(List.length fn.Ast.params) (List.length c.cparams)
|
|
(String.concat ", " (List.map snd c.cparams)))
|
|
else
|
|
let param_diff =
|
|
List.find_map
|
|
(fun ((p : Ast.field), (_, ct)) ->
|
|
match (try Some (param_ty env ct) with Refused _ -> None) with
|
|
| None -> None
|
|
| Some want ->
|
|
if same want p.Ast.fty then None
|
|
else
|
|
Some
|
|
(Printf.sprintf "parameter %s is %s and the header says %s (%s)"
|
|
p.Ast.fname (ty_source p.Ast.fty) (norm want) ct))
|
|
(List.combine fn.Ast.params c.cparams)
|
|
in
|
|
match param_diff with
|
|
| Some why -> say why
|
|
| None ->
|
|
(match (try Ok (ret_ty env c.cret) with Refused w -> Error w) with
|
|
| Error _ -> None
|
|
| Ok want ->
|
|
let agrees =
|
|
match (want, fn.Ast.ret) with
|
|
| None, None -> true
|
|
| Some a, Some b -> same a b
|
|
| _ -> false
|
|
in
|
|
if agrees then None
|
|
else
|
|
say
|
|
(Printf.sprintf "returns %s and the header says %s (%s)"
|
|
(match fn.Ast.ret with None -> "nothing" | Some t -> ty_source t)
|
|
(match want with None -> "nothing" | Some t -> ty_source t)
|
|
c.cret)))
|
|
bound
|