Joseph Ferano
7332bed14a
The imported-bindings program was skipped without FLAN_RAYLIB_H, which was right when the bindings only existed if a header was read and is now the one gate hiding the change. It runs on the same terms as every other raylib case: libraylib linkable, no raylib-devel. A generated.flan regenerated empty or stale is now caught on an ordinary machine rather than only on one with a header exported. Reach.link already answers the shim worry BUILT.md's cold-build attribution would otherwise raise: sand.flan links 110 wrappers, not 425, because the bindings nothing reachable calls are dropped. What is left is 65ms of frontend on a cold build, against a header read that was 60-90ms of a fresh session and 15.5ms of every redefinition. Both numbers are in BUILT.md now. Also a swallowed line continuation in the exclusion message.
1191 lines
54 KiB
OCaml
1191 lines
54 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;
|
|
}
|
|
|
|
(* ── The config beside the header ──────────────────────────────────── *)
|
|
|
|
(* Why a config file exists at all, when the importer decides everything else
|
|
from the header.
|
|
|
|
Because the generated declarations are *committed*. A generated file that is
|
|
read at build time can be hand-corrected and the correction survives, since
|
|
nothing rewrites it. A generated file that is checked in is rewritten by the
|
|
next regeneration, so a hand-edit to it is destroyed without anybody being
|
|
told — which is the worst shape an edit can have. The edits therefore have
|
|
to live somewhere regeneration *reads* rather than somewhere it writes, and
|
|
this is that place.
|
|
|
|
Two directives, which are the two things the header cannot decide:
|
|
|
|
- [exclude], a C symbol or a pattern of them, for what should not be
|
|
generated at all.
|
|
- [name], a C symbol and the Flan name it is to take, for where the kebab
|
|
rule gives something ugly.
|
|
|
|
A postprocessing transform pass over the generated file was the alternative
|
|
and was rejected: a second program to understand, run over text the
|
|
generator had already committed to. Both directives here are applied
|
|
*while* the declarations are made, so the file on disk is already what the
|
|
config says and nothing reads it twice. *)
|
|
|
|
type config = {
|
|
excludes : string list;
|
|
(* C symbol to Flan name. Keyed on the symbol and not on the kebab result,
|
|
because the symbol is the only spelling that is stable — the whole point
|
|
of an override is that the kebab result is not what is wanted. *)
|
|
renames : (string * string) list;
|
|
}
|
|
|
|
let no_config = { excludes = []; renames = [] }
|
|
|
|
(* [*] stands for any run of characters and nothing else does anything. Enough
|
|
for [rl*] or [*Callback], and small enough to read at a glance; a package
|
|
that needs more than this wants a hand-written declare-c, which it has. *)
|
|
let matches (pat : string) (s : string) =
|
|
let np = String.length pat and ns = String.length s in
|
|
let rec go i j =
|
|
if i = np then j = ns
|
|
else if pat.[i] = '*' then
|
|
let rec from k = (k <= ns && go (i + 1) k) || (k < ns && from (k + 1)) in
|
|
from j
|
|
else j < ns && Char.equal pat.[i] s.[j] && go (i + 1) (j + 1)
|
|
in
|
|
go 0 0
|
|
|
|
let excluded cfg sym = List.exists (fun p -> matches p sym) cfg.excludes
|
|
|
|
(* The one place the kebab rule is consulted, so an override is not a special
|
|
case anywhere below: collisions are computed on the name a function will
|
|
actually take, which means renaming one of two colliding symbols resolves
|
|
the collision rather than leaving both refused. *)
|
|
let flan_name cfg sym =
|
|
match List.assoc_opt sym cfg.renames with Some n -> n | None -> kebab sym
|
|
|
|
(* The file, in the shape of [headers] and [link] beside it: one directive per
|
|
line, [#] comments, blank lines ignored. A line that is neither directive is
|
|
an error rather than a line quietly skipped — the house rule against
|
|
swallowing things applies to a config as much as to a flag, and a typo in a
|
|
name override would otherwise show up as a binding under the wrong name. *)
|
|
let read_config path : config =
|
|
if not (Sys.file_exists path) then no_config
|
|
else begin
|
|
let ch = open_in path in
|
|
let excludes = ref [] and renames = ref [] in
|
|
let rec go n =
|
|
match input_line ch with
|
|
| line ->
|
|
let t = String.trim line in
|
|
if t <> "" && t.[0] <> '#' then begin
|
|
let ws =
|
|
String.split_on_char ' ' t
|
|
|> List.concat_map (String.split_on_char '\t')
|
|
|> List.filter (fun w -> w <> "")
|
|
in
|
|
match ws with
|
|
| [ "exclude"; p ] -> excludes := p :: !excludes
|
|
| [ "name"; sym; flan ] -> renames := (sym, flan) :: !renames
|
|
| _ ->
|
|
close_in ch;
|
|
fail (Loc.make path n 0)
|
|
"a line here is `exclude <C symbol or pattern>` or `name <C \
|
|
symbol> <flan-name>`, and this is neither: %s" t
|
|
end;
|
|
go (n + 1)
|
|
| exception End_of_file -> ()
|
|
in
|
|
go 1;
|
|
close_in ch;
|
|
{ excludes = List.rev !excludes; renames = List.rev !renames }
|
|
end
|
|
|
|
(* [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 ~config (d : dump) : imported =
|
|
let decls = ref [] and hidden = ref [] in
|
|
(* Collisions are found before anything is emitted, and they take *every*
|
|
name in the colliding group down with them.
|
|
|
|
Resolving one by taking the first and refusing the rest is the tempting
|
|
shape and the wrong one: which C function ends up owning the Flan name
|
|
would then depend on the order the header happens to declare them in, so
|
|
moving two lines in somebody else's header silently rebinds a name a Flan
|
|
program is already calling. There is no reading of [spin-2d] that is
|
|
obviously right when the header offers both [Spin2D] and [spin2d], so
|
|
neither gets it, and both say why. The author disambiguates with a
|
|
hand-written declare-c, which is what that form is for.
|
|
|
|
[bound_syms] is excluded first: a C function the package already binds by
|
|
hand is not competing for an imported name at all, so it cannot collide
|
|
with one. *)
|
|
let candidates =
|
|
List.filter (fun f -> not (List.mem f.csym bound_syms)) d.fns
|
|
in
|
|
(* Excluded before anything else looks at them, so an excluded symbol is not
|
|
in a collision group either — which is one of the things exclusion is for.
|
|
It still says why, under the name it would have taken: "there is no such
|
|
binding" and "the package decided against this binding" are different
|
|
answers and a reader deserves the second one. *)
|
|
let dropped, candidates =
|
|
List.partition (fun f -> excluded config f.csym) candidates
|
|
in
|
|
List.iter
|
|
(fun f ->
|
|
hidden :=
|
|
(flan_name config f.csym,
|
|
Printf.sprintf
|
|
"%s is excluded by the package's binding config, so no \
|
|
declaration is generated for it" f.csym)
|
|
:: !hidden)
|
|
dropped;
|
|
let groups = Hashtbl.create 512 in
|
|
List.iter
|
|
(fun f ->
|
|
let k = flan_name config f.csym in
|
|
Hashtbl.replace groups k (f.csym :: Option.value ~default:[]
|
|
(Hashtbl.find_opt groups k)))
|
|
candidates;
|
|
List.iter
|
|
(fun f ->
|
|
let flan = flan_name config f.csym in
|
|
let skip why = hidden := (flan, why) :: !hidden in
|
|
match List.rev (Hashtbl.find groups flan) with
|
|
| _ :: _ :: _ as all ->
|
|
skip
|
|
(Printf.sprintf
|
|
"%s all kebab to %s, and which one got the name would depend on \
|
|
the order the header declares them in — so none of them takes \
|
|
it. Give the one you want a `name` in the binding config, or \
|
|
bind it with a hand-written declare-c"
|
|
(String.concat ", " all) flan)
|
|
| _ ->
|
|
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 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) ->
|
|
decls :=
|
|
{ Ast.d =
|
|
Ast.DeclareC
|
|
({ Ast.name = flan; params; ret; fbody = []; nloc = f.cloc },
|
|
f.csym);
|
|
dloc = f.cloc }
|
|
:: !decls)
|
|
candidates;
|
|
(* One entry per name. A collision refuses every member of its group and each
|
|
of them writes the same reason under the same name, which [refuse_hidden]
|
|
would look up identically but a report would print twice. *)
|
|
let seen = Hashtbl.create 64 in
|
|
let hidden =
|
|
List.filter
|
|
(fun (n, _) ->
|
|
if Hashtbl.mem seen n then false else (Hashtbl.add seen n (); true))
|
|
(List.rev !hidden)
|
|
in
|
|
{ decls = List.rev !decls; 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 caches, two of them ───────────────────────────────────────── *)
|
|
|
|
(* 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.
|
|
|
|
It lives under the object cache directory, beside the [.o] files, because it
|
|
is the same kind of thing: derived from an input the compiler did not write,
|
|
stable across builds, and safe to delete. One directory to clear rather than
|
|
two. *)
|
|
|
|
let cache_format = 1
|
|
|
|
(* The same directory [Build.cachedir] makes, spelled here rather than called:
|
|
[Load] is upstream of this file and downstream of [Reach], so reaching
|
|
[Build] from here closes a cycle. Two lines that have to agree, and the
|
|
consequence of their disagreeing is a second cache directory rather than a
|
|
wrong answer. *)
|
|
let cachedir () =
|
|
let d = Filename.concat (Filename.get_temp_dir_name ()) "flan-objcache" in
|
|
(try Unix.mkdir d 0o700 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
|
|
d
|
|
|
|
let dump_of_disk ~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)
|
|
|
|
(* And in front of that file, the session's own copy — which is the level that
|
|
matters for the dev loop, because the daemon is a process that lives for as
|
|
long as the editor does and re-reads the file once per evaluation that
|
|
imports the package again. Reading the cached dump is 0.33ms and extracting
|
|
the declarations from it is another 3.3ms, so this is small; it is here
|
|
because *nothing* is the right amount for a long-lived process to pay twice
|
|
for an answer it already has.
|
|
|
|
**Keyed on the header's path and the flags, and deliberately not on its
|
|
mtime.** That is the whole of the mid-session question: a header edited
|
|
while a session is running is not re-read, and the session keeps the
|
|
signatures it started with until it is restarted. It is the same rule a
|
|
changed [.c] file follows — the daemon compiled the package's C once, at
|
|
startup, and a redefinition does not recompile it — and the same rule the
|
|
running program itself follows, since its layouts are the ones it was built
|
|
with. The alternative is worse in both directions: keying on mtime would put
|
|
a [stat] on a path that is supposed to cost nothing, and it would let a
|
|
header change take effect on the next [C-c C-c] in a *program that is still
|
|
running with the old layouts*, which is precisely the silent disagreement
|
|
the header check exists to prevent. A new session reads the new header, and
|
|
the disk cache above keys on mtime so it does not serve it the old one.
|
|
|
|
Two tables rather than one, because the two answers have different inputs.
|
|
The *dump* is the header's alone, so a second package importing the same
|
|
header shares it. The *declarations* are the dump read against one package —
|
|
which names it already has taken, which structs and enums it knows, which C
|
|
symbols it binds by hand — so they are keyed on those too, and a package
|
|
whose decls an evaluation has added to gets its declarations worked out
|
|
again rather than served an answer about the decls it used to have. *)
|
|
|
|
let dumps : (string, dump) Hashtbl.t = Hashtbl.create 4
|
|
let imports : (string, imported * dump * env) Hashtbl.t = Hashtbl.create 4
|
|
|
|
let header_key ~header ~flags =
|
|
String.concat "\000"
|
|
((try Unix.realpath header with Unix.Unix_error _ -> header) :: flags)
|
|
|
|
let dump_of ~loc ~header ~flags =
|
|
let k = header_key ~header ~flags in
|
|
match Hashtbl.find_opt dumps k with
|
|
| Some d -> d
|
|
| None ->
|
|
let d = dump_of_disk ~loc ~header ~flags in
|
|
Hashtbl.replace dumps k d;
|
|
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
|
|
~config =
|
|
let k =
|
|
(* Sorted, because neither the taken table nor the declaration order is a
|
|
fact about the package — two loads of the same file that enumerate them
|
|
differently are the same question and must not miss each other. *)
|
|
let sorted xs = List.sort compare xs in
|
|
String.concat "\000"
|
|
(header_key ~header:h ~flags
|
|
:: "\001" :: sorted known_structs
|
|
@ ("\001" :: sorted known_enums)
|
|
@ ("\001" :: sorted (Hashtbl.fold (fun n () acc -> n :: acc) taken []))
|
|
@ ("\001" :: sorted bound_syms)
|
|
(* The config is part of the question: two loads that disagree about
|
|
what is excluded or renamed are different questions, and serving one
|
|
the other's answer is the bug this key exists to prevent. *)
|
|
@ ("\001" :: sorted config.excludes)
|
|
@ ("\001" :: sorted (List.map (fun (a, b) -> a ^ "=" ^ b) config.renames)))
|
|
in
|
|
match Hashtbl.find_opt imports k with
|
|
| Some r -> r
|
|
| None ->
|
|
let d = dump_of ~loc ~header:h ~flags in
|
|
let env = env_of ~known_structs ~known_enums d in
|
|
let r = (of_dump ~env ~taken ~bound_syms ~config d, d, env) in
|
|
Hashtbl.replace imports k r;
|
|
r
|
|
|
|
(* ── 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
|
|
|
|
|
|
(* ── Regenerating the committed declarations ───────────────────────── *)
|
|
|
|
(* Generate once, commit the result, regenerate when the library moves.
|
|
|
|
What that buys is in DISCUSS.md item 6 and it is not caching — the dump is
|
|
already cached on disk and in memory, so a build that reads the header pays
|
|
for it once either way. It is that no header is needed by *anybody*: the
|
|
declarations are in the repository, so they are greppable, they diff when
|
|
raylib moves, and a build needs libraylib linkable and nothing else. The
|
|
opt-in that used to decide whether a package had 172 bindings or 428 stops
|
|
deciding anything.
|
|
|
|
What it costs is the check. A header read at build time compared every
|
|
hand-written declaration against the library on every build; a committed
|
|
file compares nothing, because a file on disk has no second opinion. That
|
|
check is not decoration — it verified all 172 hand-written declarations and
|
|
all 16 struct layouts against raylib 5.5 and found them exactly right, and
|
|
against a 5.1-dev header on the same machine it found ten real differences.
|
|
|
|
So regeneration runs it, and the check *gates the write*. There is no way to
|
|
ask for new declarations without comparing the package against the header
|
|
they come from, because the one function that writes the file is this one
|
|
and it refuses when the two disagree. A regeneration that quietly rewrote
|
|
the bindings against a header the library does not match would produce
|
|
exactly the failure BUILT.md warns about — a permuted struct read as five
|
|
plausible numbers rather than as a link error — and it would produce it in a
|
|
committed file that looks reviewed.
|
|
|
|
The hand-written declarations are what make the signature half of that check
|
|
mean anything, which is why they stay. Everything the generator emits agrees
|
|
with the header by construction, so diffing generated output against the
|
|
header it came from is a tautology; the hand-written lines were transcribed
|
|
from raylib's documentation by a person, so they are an independent second
|
|
opinion and the only thing here that the header can actually contradict. *)
|
|
|
|
type regen = {
|
|
gwrote : bool;
|
|
gdecls : int;
|
|
gfns : int;
|
|
ghidden : (string * string) list;
|
|
gstructs : (string * string) list;
|
|
gsigs : sig_diff list;
|
|
}
|
|
|
|
let banner h =
|
|
Printf.sprintf
|
|
";;;; Generated from %s by `flan generate-c`. Do not edit this file.\n\
|
|
;;;;\n\
|
|
;;;; Every line here was read out of the C header named by `headers`, and\n\
|
|
;;;; the next regeneration overwrites the file — so a correction made here\n\
|
|
;;;; is destroyed without anybody being told. Corrections go in `bindings`\n\
|
|
;;;; beside it, which is read *while* these lines are made: `exclude` drops\n\
|
|
;;;; a function, `name` gives one a Flan name the kebab rule would not.\n\
|
|
;;;; Anything neither directive can express is a hand-written declare-c in\n\
|
|
;;;; the package's own .flan, which wins over this file and is left alone.\n\
|
|
;;;;\n\
|
|
;;;; Regenerating compares the package against the header first and\n\
|
|
;;;; refuses to write when they disagree, so this file and the\n\
|
|
;;;; hand-written declarations beside it agreed with %s when it was made.\n\n"
|
|
(Filename.basename h) (Filename.basename h)
|
|
|
|
(* [ds] is the package's *hand-written* declarations: every .flan in the
|
|
directory except the one being written. Reading the output back in would
|
|
make regeneration idempotent in the worst way — every symbol would already
|
|
be bound, so the second run would generate nothing and cheerfully write an
|
|
empty file. *)
|
|
let regenerate ~loc ~header:h ~flags ~(ds : Ast.decl list) ~config ~out =
|
|
let taken = Hashtbl.create 64 in
|
|
List.iter
|
|
(fun d ->
|
|
match Ast.declared_name d with
|
|
| Some n -> Hashtbl.replace taken n ()
|
|
| None -> ())
|
|
ds;
|
|
let pick f = List.filter_map f ds in
|
|
let structs =
|
|
pick (fun (d : Ast.decl) ->
|
|
match d.Ast.d with Ast.Defstruct (n, fs) -> Some (n, fs) | _ -> None)
|
|
and known_enums =
|
|
pick (fun (d : Ast.decl) ->
|
|
match d.Ast.d with Ast.Defenum (n, _) -> Some n | _ -> None)
|
|
and bound_syms =
|
|
pick (fun (d : Ast.decl) ->
|
|
match d.Ast.d with
|
|
| Ast.Declare (_, s) | Ast.DeclareC (_, s) -> Some s
|
|
| _ -> None)
|
|
and bound =
|
|
pick (fun (d : Ast.decl) ->
|
|
match d.Ast.d with Ast.DeclareC (fn, s) -> Some (fn, s) | _ -> None)
|
|
in
|
|
let imported, dump, env =
|
|
header ~loc ~header:h ~flags ~known_structs:(List.map fst structs)
|
|
~known_enums ~taken ~bound_syms ~config
|
|
in
|
|
let gstructs = check_structs ~env ~structs dump in
|
|
let gsigs = diff_bound ~env ~bound dump in
|
|
let gwrote = gstructs = [] && gsigs = [] in
|
|
if gwrote then begin
|
|
let b = Buffer.create 65536 in
|
|
Buffer.add_string b (banner h);
|
|
List.iter
|
|
(fun d ->
|
|
Buffer.add_string b (decl_source d);
|
|
Buffer.add_char b '\n')
|
|
imported.decls;
|
|
let ch = open_out out in
|
|
output_string ch (Buffer.contents b);
|
|
close_out ch
|
|
end;
|
|
{ gwrote; gdecls = List.length imported.decls;
|
|
gfns = List.length dump.fns; ghidden = imported.hidden; gstructs; gsigs }
|