diff --git a/BUILT.md b/BUILT.md index 7723cd4..0200b33 100644 --- a/BUILT.md +++ b/BUILT.md @@ -132,6 +132,164 @@ No raylib headers are needed: the generated C declares the prototypes it uses, s library being linkable and not on `raylib-devel`. `vendor/raylib/link` carries `-l:libraylib.so.550` because Fedora ships the runtime library without the `.so` symlink. +### The header is read now — `headers`, `lib/cimport.ml` + +The section above ends by naming what the generator *trusts*: that the +`defstruct` matches the library's real struct, and that the `declare-c` +signature is the function's real signature. "No header is read, deliberately, +so nothing can check either." A header is read now, and both are checked. + +**The dependency, which is the crux, and which this project already answered +once.** Zig's old `@cImport` ran clang as a *library*. That is exactly the +dependency plan.org rejected in "Why LLVM IR as text": 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 +every build already runs and adds nothing that is not already being paid for. +`lib/cjson.ml` is enough JSON to read that dump and no more, so it adds no opam +package either. + +A note worth recording, because it strengthens the argument rather than +weakening it: **Zig has since abandoned clang here too.** `translate_c.zig` is +gone; `lib/compiler/translate-c/` is built on Aro, a C frontend written in Zig. +Their reason was to ship a compiler containing no clang at all — the opposite +premise to this one, where `clang` on PATH *is* the toolchain assumption. Both +projects walked away from linking libclang; only the destination differs. + +**What is imported: functions, and only functions.** Not structs, not enums, +not macros. The bound on how much is not a curated list but the package's own +`defstruct`s — a function whose signature mentions a struct the package has not +described is refused with that reason, so `vendor/raylib` describing thirteen +structs is what makes the import thirteen structs wide, and describing a +fourteenth widens it. Of raylib 5.5's 581 functions, 256 import, 153 are +refused, and 172 are left alone because the package already binds them by hand. + +Not generating `defstruct`s is what makes the check possible at all. Generate +them and the header becomes the authority on layout, and comparing the +package's layouts against the header's would be comparing the header with +itself. A `_Static_assert` on `sizeof`/`offsetof` was rejected in the section +above as circular for exactly that reason; **this is not circular, because the +two sides have different authors.** It is the cheapest real closure of the +trusted-not-guaranteed gap. + +**Refusing by demotion, which is the one thing taken wholesale from Zig.** Zig's +translator never drops a declaration it cannot handle: `failDecl` binds the name +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 a hundred and fifty refusals and a caller cares +about the one they typed. Flan already had that mechanism — `Load.refuse_hidden`, +built for `main` — so `rl/get-gamepad-name` is not a name, and a program that +writes it is told *the return type is a string, and a string only crosses as a +parameter* rather than "unknown name". + +That is also the split `shim.ml` needed and did not have. It refuses through +`Loc.fail`, which is right when a human named one function and wrong for a +wholesale import, where one returned `const char *` would kill the header. Same +judgement, different disposition; a hand-written `declare-c` still hard-fails +and `shim.ml` is untouched. + +**Two C spellings mean something in a parameter that they mean nowhere else.** +`const char *` is a string going in, and the generator already knows how to hand +one over. `char *` without the const is very often a buffer the callee *writes*, +and handing it a NUL-terminated temporary 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 an out-buffer keeps a hand-written binding +saying `(Ptr u8)`. `long`, `size_t` and the rest are refused rather than +guessed, and for a reason specific to this project: 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, so a guess would be right for the target that gets tested and +silently wrong for two that do not. + +**Naming.** `rl/InitWindow` is `rl/init-window`. Reversibility is not a property +of the rule — the C symbol is stored verbatim in the declaration, so the wrapper +reads the library's spelling rather than reconstructing it. What the rule must +be is *injective over one header*, since two C functions arriving under one Flan +name would surface as a duplicate declaration about a name nobody wrote. A +boundary goes before an uppercase letter after a lowercase one, before an +uppercase letter between an uppercase and a lowercase, and before a digit after +a lowercase; nowhere else. So `SetTargetFPS` is `set-target-fps` and not +`set-target-f-p-s`, `BeginMode2D` is `begin-mode-2d`, `UnloadUTF8` is +`unload-utf8`. raylib's 581 names are injective under it. **When two do collide, +neither takes the name** — resolving by order would mean that moving two lines +in somebody else's header silently rebinds a name a program is already calling. +Both are refused, both say why, and the author binds the one they want with a +`declare-c`. + +**Where it runs.** `headers` beside `link` in the package directory, read the +same way: a path, any clang flags it needs, `${NAME}` expanded from the +environment. What comes back is ordinary `declare-c` declarations, generated +before the package's names are qualified, so they arrive as `rl/…` exactly like +the hand-written ones and nothing downstream can tell which is which. No new +form, no new `decl_kind`, no reader or parser change. A C symbol the package +already binds by hand is left alone, so `declare-c` stays the escape hatch and +stays the thing that wins. + +A leading `?` makes a line optional, and `vendor/raylib` uses it. "No raylib +headers are needed" is a real property — a build needs libraylib linkable, not +raylib-devel installed — and requiring a header would take it from everyone in +order to give the check to whoever has one. Unset `FLAN_RAYLIB_H` and the build +is exactly what it was; set it and every signature is checked. A path that is +*set and wrong* is an error naming it, because silently behaving as though +nobody had opted in is the difference between an opt-in and a trap. + +#### What the diff found + +The evidence the whole lane exists for. Against raylib **5.5** — the version +whose `.so` `link` names — **all 16 `defstruct`s and all 172 hand-written +`declare-c` agree exactly.** The half BUILT.md called trusted is now checked, +and it was right. + +That is only worth stating because the check has teeth. Against the **5.1-dev** +header installed in `/usr/local` it reports ten differences: nine functions that +version does not have (`CheckCollisionCircleLine`, the six `Is*Valid` renames, +`DrawRectangleRoundedLinesEx`) and `DrawRectangleRoundedLines`, which gained a +parameter. Picking the wrong header is therefore loud, which matters, because +the two headers are on the same machine and only one matches the linked library. + +Both comparisons run **at build time** and stop the build, not just in the tool. +Verified by breaking them: a permuted `Texture2D` fails naming the field that +moved, and `f64` where raylib says `float` fails naming the parameter — which is +the hazard the section above calls out by name and says only a test can catch. +The message points at the line in `raylib.flan`, not at the header. + +`flan import-c
[package.flan…]` prints what it would produce, what it +refused and why, and both comparisons, without building anything. That also +makes "generate once and commit the result" available for the cost of a +printer — explicit in the source, checked against reality, no header read at +build time. + +#### What it costs, measured + +The number that decides how much to import, because `reach.ml` was the reason to +think a wholesale import could be free. + +| | today (172 by hand) | + 256 imported | +|---|---|---| +| release build, cold | 0.298s | 0.312s | +| release build, warm | 0.078s | 0.082s | +| redefinition (`flan reload`) | 31.0ms | 46.5ms | +| dev build, cold | 0.649s | 0.982s | + +**`Reach.link` already drops a generated wrapper whose declaration nothing +reachable calls, and that is what makes the release column nearly flat.** +Confirmed on the case it exists for: a wasm32-wasi build of a program that +imports raylib and calls none of it still links without libraylib, with 256 +extra declarations in play. Dev builds are not pruned, on purpose, so one +compiles all 428 wrappers — once, at session start, since `Build.shared` is +llc + `ld -shared` and compiles no C. + +Reading the header is cached, and the cache earned itself against a measurement +rather than a guess: 64ms of a 72ms check, against 8ms for the whole program +without it. What is cached is the *extracted* signatures and not clang's JSON, +because the parse is half the cost — 30ms is clang writing 1.8 MB and the rest +is reading it. Keyed the way the object cache is keyed, on everything that could +change the answer: the header's path, size and mtime, the full flag list, and a +format version, since the value is marshalled. That takes the delta to 17ms. + +**The 15.5ms on redefinition is the real cost and it is the argument against +importing at build time**, on the branch where the dev loop is the priority. It +is the strongest case for the third option — generate from the header, commit +the result, regenerate when the library moves — and that decision is open. + ### What a headless FFI test can and cannot pin Worth knowing before writing another one, because two plausible tests in a row turned out to check nothing. diff --git a/DISCUSS.md b/DISCUSS.md index 581f0f0..de129d3 100644 --- a/DISCUSS.md +++ b/DISCUSS.md @@ -196,33 +196,62 @@ happens. **One dependency:** hiccup is a macro, and the macro expander is blocked on `Form` being a Flan union, which is union values. The backend can start before that; the DSL cannot. -## 6. C interop as seamless as Zig's +## 6. C interop as seamless as Zig's — built, with two decisions left -Today: `declare-c` names one C function per line and the compiler generates the wrapper, the typedefs and the flattened -declaration — 175 lines for raylib. **No header is ever read, deliberately**, which means nothing verifies that a -declaration matches the real signature. That is written down as trusted rather than guaranteed. +**The mechanism is in** (`lib/cimport.ml`, `lib/cjson.ml`, `vendor/raylib/headers`; BUILT.md, "The header +is read now"). Settled and not worth reopening: clang's JSON AST dump over a shelled-out `clang`, never +libclang — and Zig has since abandoned linking clang too, for Aro, which strengthens the argument rather +than weakening it. The import is bounded by the package's own `defstruct`s rather than by a curated list. +Refusals are demotions in Zig's sense: the name exists, cannot be had, and says why at the use site, which +`Load.refuse_hidden` already did for `main`. Names kebab by a rule that is injective over raylib's 581, and +reversibility is by storage — the C symbol is kept verbatim — so the rule never needs an inverse. Where two +names do collide, neither takes it. -The proposal: read the header, prefix a namespace, get `rl/InitWindow` for free, possibly kebab-cased to -`rl/init-window`. +**The evidence:** against raylib 5.5, all 16 `defstruct`s and all 172 hand-written `declare-c` agree +exactly. Against the 5.1-dev header also on this machine, ten real differences. Both comparisons stop the +build, and a permuted `Texture2D` or an `f64` for a `float` is caught by name. -**The dependency is the crux, and this project already answered the same question once.** Zig's `@cImport` runs clang as -a *library*. That is exactly the dependency rejected in plan.org's "Why LLVM IR as text": a version-pinned C++ library -breaks routinely on upgrade, while a binary on `PATH` does not. Linking libclang walks back into it. +What is left is two decisions, and both are the author's. -**The middle path that keeps the property:** clang will dump a parsed header as JSON from the command line -(`-Xclang -ast-dump=json`). Still only `clang` on `PATH`, still no library linkage, and it yields *real* signatures -instead of hand-transcribed ones — which closes the "trusted, not guaranteed" gap that is the strongest argument for -doing this at all. +### 6a. Does reading the header stay a build-time step, or become a code generator? -**The design question is how much to import.** Zig imports everything a header declares. For raylib that is several -hundred functions plus every struct and macro, nearly all unused. The current 175 lines are deliberate, and the -declaration site is also the checkpoint where the compiler *refuses* a signature it cannot safely flatten — an -aggregate return, a variadic, a `string` coming back. A wholesale import removes that checkpoint, or has to reproduce -it as a filter. Generating the list from the header while keeping it explicit in the source is a third option: generate -once, commit the result, regenerate when the library moves. +The cost, measured, with the wrappers pruned by `Reach` as they already were: -**Kebab-casing is separable and small**, with one constraint: it must be reversible, because the generated C wrapper -needs the library's own spelling. +| | today | + 256 imported | +|---|---|---| +| release build, warm | 0.078s | 0.082s | +| **redefinition** | **31.0ms** | **46.5ms** | +| dev build, cold | 0.649s | 0.982s | + +Release is nearly free and that question is answered. **The 15.5ms on redefinition is not nothing on the +branch where the dev loop is the priority** — it is a 50% increase on the number that lane exists to keep +small, and it buys a check of signatures that have not changed since the last build. + +So the third option from the original discussion is now the live one: `flan import-c` already prints +`declare-c` lines, so **generate from the header, commit the result, regenerate when raylib moves** costs +nothing more to build. Explicit in the source, checked against reality, no header read at build time, and +the check becomes a thing you run rather than a thing you pay for. Against it: a committed file goes stale +silently, which is the failure the whole lane exists to prevent, and "regenerate when the library moves" +is a discipline rather than a mechanism. + +A middle reading worth considering: keep the build-time check but run it only when *not* `--dev`, on the +grounds that a release build is where a wrong signature must not get through and a dev build is where +15.5ms is felt. That is the same shape as `Reach` not pruning dev builds, for a symmetric reason. + +### 6b. Do the 172 hand-written lines get migrated? + +The diff is clean, so nothing blocks it on correctness. What blocks it is that migration needs the header +present at *every* build, which means vendoring raylib.h into the repo or requiring `raylib-devel` — and +BUILT.md records "a build needs libraylib linkable and not raylib-devel installed" as a property that was +chosen on purpose. That is why `vendor/raylib/headers` is opt-in (`?${FLAN_RAYLIB_H}`) today and the +hand-written lines are untouched. + +Worth noting what migration would actually lose, since it is small but real: the hand-written names are +better than the rule's. `IsKeyPressed` is `key-pressed?` by hand and `is-key-pressed` by rule; +`CheckCollisionRecs` is `collision-recs?`. And an enum parameter imports as `i32`, because the header says +`KeyboardKey` and nothing tells the importer the package calls that `Key` — so `(rl/key-down? :space)` +would become an integer at the call site. A migration is therefore not a deletion; it is a deletion plus a +kept list of the lines whose face is deliberately nicer than the header's. ## 7. Watching variables diff --git a/NEXT.md b/NEXT.md index 5b6370f..56c6663 100644 --- a/NEXT.md +++ b/NEXT.md @@ -40,6 +40,58 @@ read. It belongs with item 2, where the listing is being changed anyway. Read SBCL for what restarts should *mean* and ignore how it moves control: it transfers with `block`/`return-from`, which §6 rules out. +### Landed — a C header is read, so a binding is checked instead of trusted + +`lib/cimport.ml`, `lib/cjson.ml`, a `headers` file beside `link`. Full reasoning in `BUILT.md`, "The header is read +now"; DISCUSS.md item 6 is rewritten down to the two decisions left, both the author's. + +The gap closed is the one `BUILT.md` recorded as *trusted*: `declare-c` generates the wrapper, the typedefs and the +prototype from one declaration, so they agree with each other by construction and only the library could disagree — +and nothing had a second opinion to disagree with. Now clang is asked for a JSON AST dump of the header (shelled out, +never libclang — the dependency plan.org rejected; Zig has since left it too, for Aro) and both halves are compared +against it. + +**The evidence.** Against raylib 5.5, the version whose `.so` `vendor/raylib/link` names: **all 16 `defstruct`s and +all 172 hand-written `declare-c` agree exactly.** Against the 5.1-dev header also installed on this machine, ten real +differences — nine functions that version lacks and one that gained a parameter — so picking the wrong header is +loud. Both comparisons run at build time and stop the build; verified by permuting `Texture2D` and by putting `f64` +where raylib says `float`, which is the hazard `BUILT.md` names and says only a test can catch. + +**Costs, measured, because they decide the remaining question.** Release build +4ms warm — `Reach.link` already drops +a wrapper nothing reachable calls, confirmed on the wasm32 case it exists for with 256 extra declarations in play. +Redefinition 31.0ms → 46.5ms. Dev build +333ms cold, once per session, since `Build.shared` compiles no C. Reading the +header is cached (64ms → 17ms), keyed like the object cache; the cache was built against a measurement, not a guess. + +**Opt-in on purpose.** `vendor/raylib/headers` is `?${FLAN_RAYLIB_H}`. "A build needs libraylib linkable and not +raylib-devel installed" is a property chosen deliberately, and requiring a header would take it from everyone to give +the check to whoever has one. Unset means off; set-and-wrong is an error naming the path. + +Worth knowing before touching it: + +- **The import is bounded by the package's own `defstruct`s**, not by a curated list. A function mentioning a struct + the package has not described is refused with that reason. Of raylib's 581 functions, 256 import, 153 are refused, + 172 are already bound by hand and left alone. Widening the binding is a `defstruct`, not a list edit. +- **No `defstruct` is generated, and that is load-bearing.** Generate them and the header becomes the authority on + layout, and checking the package's layouts against it would be comparing the header with itself — which is exactly + why `BUILT.md` rejected a `_Static_assert` as circular. Keeping them hand-written is what makes the check a second + source. +- **A refusal is a demotion, not a drop** — Zig's `failDecl`, which `Load.refuse_hidden` already implemented for + `main`. `rl/get-gamepad-name` is a name that exists, cannot be had, and says why at the use site. +- **`declare-c` and `declare` are untouched and still win.** A C symbol the package binds by hand is not imported, so + the escape hatch is the override. +- **`test/headers/sample.h`** is the importer's table — one function per decision, committed, no raylib needed. The + raylib acceptance case skips without `FLAN_RAYLIB_H`; that one does not. + +Two things that are *not* done, and are 6a and 6b in DISCUSS.md: whether the header stays a build-time read or becomes +a committed generator (`flan import-c` already prints the lines, so it costs nothing more to switch), and whether the +172 hand-written lines migrate. Neither is blocked on correctness. The 15.5ms on redefinition is the argument for the +first; needing the header at every build — vendoring raylib.h or requiring raylib-devel — is the argument on the +second. + +One smaller thing found and worth not re-deriving: an enum parameter imports as `i32`, because the header says +`KeyboardKey` and nothing tells the importer the package calls that `Key`. The ABI is identical, the face is worse, +and it is why `(rl/key-down? :space)` keeps its hand-written line. + ### Landed 2026-09-12 — six tracks, one session Six agents in parallel worktrees. Kept short on purpose; the reasoning that outlives the change is in `BUILT.md` or in diff --git a/bin/main.ml b/bin/main.ml index 35d178f..4c8e3aa 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -148,6 +148,103 @@ let () = | [] -> Printf.printf "%s: no declare-c, so no generated C\n" path | parts -> List.iter (fun (_, src) -> print_string src) parts)) files + (* A header, read. The importer is a pure function of the header and the + package beside it, so it can be looked at without building anything — + which is what makes the diff against a hand-written binding possible, and + what makes "generate once and commit the result" a usable option rather + than a description of one. Prints the declarations it would produce, then + what it refused and why, then how the package's defstructs compare with + the header's records. *) + | _ :: "import-c" :: header :: rest -> + with_errors header (fun () -> + let pkg = List.filter (fun a -> Filename.check_suffix a ".flan") rest in + let flags = + List.filter (fun a -> not (Filename.check_suffix a ".flan")) rest + in + let ds = + List.concat_map + (fun f -> Flan.Parse.program (Flan.Reader.read_file f)) pkg + in + let structs = + List.filter_map + (fun (d : Flan.Ast.decl) -> + match d.Flan.Ast.d with + | Flan.Ast.Defstruct (n, fs) -> Some (n, fs) + | _ -> None) + ds + in + let known_enums = + List.filter_map + (fun (d : Flan.Ast.decl) -> + match d.Flan.Ast.d with + | Flan.Ast.Defenum (n, _) -> Some n + | _ -> None) + ds + in + let taken = Hashtbl.create 64 in + List.iter + (fun d -> + match Flan.Ast.declared_name d with + | Some n -> Hashtbl.replace taken n () + | None -> ()) + ds; + let bound_syms = + List.filter_map + (fun (d : Flan.Ast.decl) -> + match d.Flan.Ast.d with + | Flan.Ast.Declare (_, s) | Flan.Ast.DeclareC (_, s) -> Some s + | _ -> None) + ds + in + let imported, dump, env = + Flan.Cimport.header ~loc:(Flan.Loc.make header 0 0) ~header ~flags + ~known_structs:(List.map fst structs) ~known_enums ~taken ~bound_syms + in + List.iter + (fun d -> print_endline (Flan.Cimport.decl_source d)) + imported.Flan.Cimport.decls; + Printf.printf "\n;; %d imported, %d refused, of %d functions in %s\n" + (List.length imported.Flan.Cimport.decls) + (List.length imported.Flan.Cimport.hidden) + (List.length dump.Flan.Cimport.fns) header; + List.iter + (fun (n, why) -> Printf.printf ";; refused %s: %s\n" n why) + imported.Flan.Cimport.hidden; + (match Flan.Cimport.check_structs ~env ~structs dump with + | [] -> + if structs <> [] then + Printf.printf ";; every defstruct agrees with the header\n" + | bad -> + List.iter + (fun (n, why) -> Printf.printf ";; DISAGREES %s: %s\n" n why) + bad); + (* And the bindings the package already wrote by hand, against the + header's own signatures. Nothing else in the build can do this: a + wrong declare-c is wrong in the generated prototype too, so the two + agree with each other and only the library disagrees. *) + let bound = + List.filter_map + (fun (d : Flan.Ast.decl) -> + match d.Flan.Ast.d with + | Flan.Ast.DeclareC (fn, sym) -> Some (fn, sym) + | _ -> None) + ds + in + if bound <> [] then + match Flan.Cimport.diff_bound ~env ~bound dump with + | [] -> + Printf.printf + ";; all %d hand-written declare-c agree with the header\n" + (List.length bound) + | ds -> + Printf.printf ";; %d of %d hand-written declare-c disagree\n" + (List.length ds) (List.length bound); + List.iter + (fun (x : Flan.Cimport.sig_diff) -> + Printf.printf ";; DIFFERS %s (%s): %s\n" + x.Flan.Cimport.dflan x.Flan.Cimport.dsym x.Flan.Cimport.dwhy) + ds) + (* The IR is target-independent — [Emit] writes no triple and no datalayout, which is what lets one .ll serve both targets — so there is nothing for a target to change here. Refused rather than accepted and ignored: silently @@ -289,6 +386,7 @@ let () = | _ -> prerr_endline "usage: flan (read|parse|check|emit|shim) ...\n\ + \ flan import-c [package.flan...] [clang flags...]\n\ \ flan build [-o out] [--no-bounds-checks] [--dev] \ [--debug] [--sanitize] [--target=wasm32-wasi|web]\n\ \ flan run [args...]\n\ diff --git a/lib/cimport.ml b/lib/cimport.ml new file mode 100644 index 0000000..cb5d2f8 --- /dev/null +++ b/lib/cimport.ml @@ -0,0 +1,884 @@ +(** 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 [] 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 + let groups = Hashtbl.create 512 in + List.iter + (fun f -> + let k = kebab f.csym in + Hashtbl.replace groups k (f.csym :: Option.value ~default:[] + (Hashtbl.find_opt groups k))) + candidates; + List.iter + (fun f -> + let flan = kebab 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. Bind the one you want 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 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 diff --git a/lib/cjson.ml b/lib/cjson.ml new file mode 100644 index 0000000..e4937c5 --- /dev/null +++ b/lib/cjson.ml @@ -0,0 +1,174 @@ +(** Just enough JSON to read clang's AST dump. + + Not a general JSON library and not a dependency. The compiler's build + inputs are a [clang] on PATH and nothing else — that is plan.org's "Why + LLVM IR as text" applied a second time — so reading clang's + [-ast-dump=json] must not drag in an opam package to parse it. What the + dump actually contains is a narrow subset: objects, arrays, strings, + integers, [true]/[false]/[null]. No floats appear in a declaration dump, + but one is accepted anyway rather than being a lurking parse error. + + The reader is strict about structure and lax about what it keeps: a dump of + raylib.h is 1.8 MB and roughly fifty thousand objects, almost all of it + source ranges nobody asks for. Parsing it whole and then selecting is still + well under the cost of the [clang] process that produced it, so there is no + streaming filter here and no reason for one. *) + +type t = + | Null + | Bool of bool + | Num of float + | Str of string + | Arr of t list + | Obj of (string * t) list + +exception Bad of string + +let bad fmt = Printf.ksprintf (fun m -> raise (Bad m)) fmt + +let parse (s : string) : t = + let n = String.length s in + let i = ref 0 in + let peek () = if !i < n then s.[!i] else '\000' in + let rec skip_ws () = + if !i < n then + match s.[!i] with + | ' ' | '\t' | '\n' | '\r' -> incr i; skip_ws () + | _ -> () + in + let expect c = + if !i >= n || s.[!i] <> c then + bad "expected %c at byte %d" c !i + else incr i + in + let lit word v = + let l = String.length word in + if !i + l <= n && String.sub s !i l = word then (i := !i + l; v) + else bad "bad literal at byte %d" !i + in + (* Strings are the hot path — every node has several — so the common case of + no escape at all is copied out in one [String.sub] rather than a character + at a time through a Buffer. *) + let string_ () = + expect '"'; + let start = !i in + let rec scan plain = + if !i >= n then bad "unterminated string at byte %d" start + else + match s.[!i] with + | '"' -> plain + | '\\' -> i := !i + 2; scan false + | _ -> incr i; scan plain + in + let plain = scan true in + if plain then begin + let r = String.sub s start (!i - start) in + incr i; r + end + else begin + let b = Buffer.create (!i - start) in + let j = ref start in + while !j < !i do + (match s.[!j] with + | '\\' -> + incr j; + (match s.[!j] with + | 'n' -> Buffer.add_char b '\n' + | 't' -> Buffer.add_char b '\t' + | 'r' -> Buffer.add_char b '\r' + | 'b' -> Buffer.add_char b '\b' + | 'f' -> Buffer.add_char b '\012' + | '/' -> Buffer.add_char b '/' + | '"' -> Buffer.add_char b '"' + | '\\' -> Buffer.add_char b '\\' + | 'u' -> + (* clang escapes a non-ASCII identifier or a comment this way. + Encoded as UTF-8; a surrogate pair is not joined, which is + acceptable because nothing this reads is ever a name Flan + could use anyway. *) + let hex = String.sub s (!j + 1) 4 in + j := !j + 4; + let c = int_of_string ("0x" ^ hex) in + if c < 0x80 then Buffer.add_char b (Char.chr c) + else if c < 0x800 then begin + Buffer.add_char b (Char.chr (0xC0 lor (c lsr 6))); + Buffer.add_char b (Char.chr (0x80 lor (c land 0x3F))) + end + else begin + Buffer.add_char b (Char.chr (0xE0 lor (c lsr 12))); + Buffer.add_char b (Char.chr (0x80 lor ((c lsr 6) land 0x3F))); + Buffer.add_char b (Char.chr (0x80 lor (c land 0x3F))) + end + | c -> bad "unknown escape \\%c at byte %d" c !j) + | c -> Buffer.add_char b c); + incr j + done; + incr i; + Buffer.contents b + end + in + let number () = + let start = !i in + if peek () = '-' then incr i; + let digits () = while !i < n && s.[!i] >= '0' && s.[!i] <= '9' do incr i done in + digits (); + if peek () = '.' then (incr i; digits ()); + if peek () = 'e' || peek () = 'E' then begin + incr i; + if peek () = '+' || peek () = '-' then incr i; + digits () + end; + if !i = start then bad "expected a number at byte %d" start; + Num (float_of_string (String.sub s start (!i - start))) + in + let rec value () = + skip_ws (); + match peek () with + | '{' -> + incr i; skip_ws (); + if peek () = '}' then (incr i; Obj []) + else begin + let acc = ref [] in + let rec members () = + skip_ws (); + let k = string_ () in + skip_ws (); expect ':'; + let v = value () in + acc := (k, v) :: !acc; + skip_ws (); + if peek () = ',' then (incr i; members ()) else expect '}' + in + members (); + Obj (List.rev !acc) + end + | '[' -> + incr i; skip_ws (); + if peek () = ']' then (incr i; Arr []) + else begin + let acc = ref [] in + let rec items () = + let v = value () in + acc := v :: !acc; + skip_ws (); + if peek () = ',' then (incr i; items ()) else expect ']' + in + items (); + Arr (List.rev !acc) + end + | '"' -> Str (string_ ()) + | 't' -> lit "true" (Bool true) + | 'f' -> lit "false" (Bool false) + | 'n' -> lit "null" Null + | _ -> number () + in + let v = value () in + skip_ws (); + if !i <> n then bad "trailing bytes at %d" !i; + v + +(* ── Getters ───────────────────────────────────────────────────────── *) + +let mem k = function Obj kvs -> List.assoc_opt k kvs | _ -> None +let str k j = match mem k j with Some (Str s) -> Some s | _ -> None +let bool k j = match mem k j with Some (Bool b) -> b | _ -> false +let arr k j = match mem k j with Some (Arr l) -> l | _ -> [] diff --git a/lib/load.ml b/lib/load.ml index 5514be6..fbb044c 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -54,7 +54,14 @@ type t = { (see [Reach.link]). The aggregate fields remain what a dev build uses, where "not called yet" is not "not called". *) and pkg = { alias : string; dir : string; owns : string list; - pcsrcs : string list; plflags : string list } + pcsrcs : string list; plflags : string list; + (* Names a [headers] file could have supplied and deliberately did + not, each with the reason — already qualified, so [rl/…]. A + wholesale header import refuses a great many functions and the + caller cares about the one they wrote, so the reason is attached + to the name and raised where it is used rather than printed at + import. See [Cimport]. *) + phidden : (string * string) list } let fail loc fmt = Printf.ksprintf (fun m -> raise (Loc.Error (loc, m))) fmt @@ -466,6 +473,113 @@ let link_flags dir = close_in ch; r end +(* The [headers] file: C headers to read signatures out of, one per line, a + path followed by any clang flags that header needs. Blank lines and + comments ignored, [${NAME}] expanded from the environment, and a relative + path taken against the package's own directory. + + A sidecar rather than a new form, for the same reason [link] is one. The + thing being named is a property of the *package* and not of any one + declaration in it, the importing program should not have to know the header + exists — [(import rl "vendor:raylib")] is unchanged at every call site — and + a package whose headers move is edited in one place. It also means the + reader, the parser and the AST are untouched: what comes back is ordinary + [declare-c] declarations, which is the only thing downstream understands. *) +let expand_env ~loc ~what line = + let b = Buffer.create (String.length line) in + let n = String.length line in + let i = ref 0 in + while !i < n do + if !i + 1 < n && line.[!i] = '$' && line.[!i + 1] = '{' then + match String.index_from_opt line !i '}' with + | None -> Buffer.add_char b line.[!i]; incr i + | Some close -> + let name = String.sub line (!i + 2) (close - !i - 2) in + (match Sys.getenv_opt name with + | Some v -> Buffer.add_string b v + | None -> + fail loc + "%s names ${%s} and %s is not set in the environment" what name name); + i := close + 1 + else (Buffer.add_char b line.[!i]; incr i) + done; + Buffer.contents b + +let read_lines path = + if not (Sys.file_exists path) then [] + else begin + let ch = open_in path in + let rec go acc = + match input_line ch with + | line -> + let line = String.trim line in + go (if line = "" || line.[0] = '#' then acc else line :: acc) + | exception End_of_file -> List.rev acc + in + let r = go [] in + close_in ch; r + end + +(* Split on whitespace: the first word is the header, the rest are clang's. *) +let words line = + String.split_on_char ' ' line + |> List.concat_map (String.split_on_char '\t') + |> List.filter (fun w -> w <> "") + +(* A line may begin with [?], meaning "read this header if it is there and say + nothing if it is not". + + That marker is what lets a package offer the check without requiring it. + [vendor/raylib] builds today against a shared library alone — BUILT.md's "no + raylib headers are needed", which is a real property: a build needs + libraylib linkable and not raylib-devel installed. A required header would + take that away from everyone in order to give the check to the people who + have one. Optional, the default build is exactly what it was, and a + developer with the matching header exports one variable and gets every + signature checked against it. It is the same shape as [${FLAN_RAYLIB_WEB}] + in [link], and for the same reason. + + An unset [${NAME}] on an optional line skips it rather than failing, since + "not set" is precisely how the line is turned off. On a required line it is + still an error that names the variable. *) +let header_specs ~loc dir = + let path = Filename.concat dir "headers" in + List.filter_map + (fun line -> + let optional = String.length line > 0 && line.[0] = '?' in + let line = + if optional then String.trim (String.sub line 1 (String.length line - 1)) + else line + in + match + if optional then + match expand_env ~loc ~what:path line with + | v -> Some v + | exception Loc.Error _ -> None + else Some (expand_env ~loc ~what:path line) + with + | None -> None + | Some expanded -> + (match words expanded with + | [] -> None + | h :: flags -> + let h = + if Filename.is_relative h then Filename.concat dir h else h + in + (* An optional line that expanded to nothing at all is the + line being switched off, which is the whole point of the + marker. An optional line that expanded to a *path* is somebody + opting in, and a path that is not there is their typo — told + about by name, rather than silently behaving as though they had + not opted in at all. Those two are the difference between an + opt-in and a trap. *) + if optional && String.trim expanded = "" then None + else if not (Sys.file_exists h) then + fail loc + "%s names the header %s, and there is no such file" path h + else Some (h, flags))) + (read_lines path) + let real dir = try Unix.realpath dir with Unix.Unix_error _ -> dir (* One package, and whatever it imports. @@ -527,6 +641,130 @@ let rec import ~seen ~loc alias dir = | _ -> None) ds in + (* Every header the package names, read, and turned into the same + [declare-c] declarations a human would have written. Done here, before + anything below looks at what the package declares, so the generated ones + are owned and qualified exactly like the hand-written ones and nothing + downstream can tell which is which. + + A single file is not a package with a directory, so it carries no + headers, for the same reason it carries no [.c] and no [link]. *) + let imported = + if one_file then [] + else + List.map + (fun (h, flags) -> + 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 known_structs = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defstruct (n, _) -> Some n + | _ -> None) + ds + and known_enums = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defenum (n, _) -> Some n + | _ -> None) + ds + (* A C symbol the package already binds by hand is left alone: + the hand-written line wins, and [Shim] would refuse the + program outright if one symbol arrived under two Flan names. + That is what keeps [declare-c] the escape hatch — a signature + the importer gets wrong, or a nicer face than the header can + describe, is fixed by writing the line. *) + and bound_syms = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Declare (_, sym) | Ast.DeclareC (_, sym) -> Some sym + | _ -> None) + ds + in + let r, dump, env = + Cimport.header ~loc ~header:h ~flags ~known_structs ~known_enums + ~taken ~bound_syms + in + (* The point of reading the header, and the reason it is not + enough to generate declarations out of it. + + Everything the generator produces agrees with itself by + construction — the typedef and the Flan struct come from one + [defstruct], the prototype and the wrapper from one + declaration — so the only thing that can disagree is the + *library*, and until a header was read nothing here had a + second opinion to disagree with. Now it does, so it says so. + + Build-stopping, not a note. The package named this header, so + the header is the package's own claim about what it binds; a + [defstruct] that disagrees with it lays fields out in the + wrong order and reads as five plausible numbers rather than as + a link error, which is the failure BUILT.md says only a test + can catch. 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. + + A structure the header does not describe at all is not + checked and not complained about: a package may legitimately + describe something the header does not name. *) + let structs = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defstruct (n, fs) -> Some (n, fs, d.Ast.dloc) + | _ -> None) + ds + in + List.iter + (fun (n, why) -> + let at = + List.find_map + (fun (m, _, l) -> if String.equal m n then Some l else None) + structs + in + fail (Option.value ~default:loc at) + "the defstruct %s disagrees with %s: %s" n h why) + (Cimport.check_structs ~env + ~structs:(List.map (fun (n, fs, _) -> (n, fs)) structs) dump); + (* And the hand-written bindings, against the header's own + signatures. These are the lines the importer deliberately + leaves alone, which is exactly why they are the ones nothing + else can check: a wrong declare-c is wrong in the generated + prototype too, so the two halves agree with each other and + only the library knows better. *) + let bound = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.DeclareC (fn, sym) -> Some (fn, sym) + | _ -> None) + ds + in + List.iter + (fun (x : Cimport.sig_diff) -> + let at = + List.find_map + (fun ((fn : Ast.fn), sym) -> + if String.equal sym x.Cimport.dsym then Some fn.Ast.nloc + else None) + bound + in + fail (Option.value ~default:loc at) + "the declare-c of %s disagrees with %s: %s" + x.Cimport.dflan h x.Cimport.dwhy) + (Cimport.diff_bound ~env ~bound dump); + r) + (header_specs ~loc dir) + in + let ds = ds @ List.concat_map (fun r -> r.Cimport.decls) imported in let own = List.filter (fun (d : Ast.decl) -> match d.Ast.d with @@ -540,9 +778,18 @@ let rec import ~seen ~loc alias dir = let decls = List.map (qualify_decl owned alias) own in let lflags = if one_file then [] else link_flags dir in let csrcs = if one_file then [] else entries dir ".c" in + let phidden = + List.concat_map + (fun r -> + List.map + (fun (n, why) -> (qualify alias n, qualify alias n ^ ": " ^ why)) + r.Cimport.hidden) + imported + in let here = { decls; csrcs; lflags; - pkgs = [ { alias; dir; owns = owned; pcsrcs = csrcs; plflags = lflags } ] } + pkgs = [ { alias; dir; owns = owned; pcsrcs = csrcs; plflags = lflags; + phidden } ] } in List.fold_left (fun acc p -> @@ -555,7 +802,8 @@ let rec import ~seen ~loc alias dir = (* What an import did *not* bring: the names an importer might reasonably write and that are not there, each with the reason it is not. *) let hidden_of (t : t) = - List.filter_map + List.concat_map (fun (p : pkg) -> p.phidden) t.pkgs + @ List.filter_map (fun (p : pkg) -> let ds = List.concat_map (fun f -> Parse.program (Reader.read_file f)) diff --git a/lib/shim.ml b/lib/shim.ml index b9bfbee..6ced73d 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -66,8 +66,14 @@ 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 would convert the trusted half into a checked one is including the - real header when one is installed, and that is not built. *) + 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 diff --git a/test/dune b/test/dune index 446f9ba..89f7b30 100644 --- a/test/dune +++ b/test/dune @@ -31,6 +31,11 @@ ; examples/digits.flan, so the directory has to be here whole. (glob_files %{workspace_root}/examples/*) (glob_files programs/*.flan) + ; The synthetic C header the importer's table reads. Committed rather than + ; reached for on the machine: the raylib case needs raylib installed, at the + ; right version, with a variable set, so it skips everywhere and covers + ; nothing. This one does not move. + (glob_files headers/*.h) ; The files programs/embed.flan bakes in. An embed reads them at *compile* ; time, so they are a dependency of the checker run and not of the program. (glob_files programs/assets/*) diff --git a/test/headers/sample.h b/test/headers/sample.h new file mode 100644 index 0000000..de56002 --- /dev/null +++ b/test/headers/sample.h @@ -0,0 +1,48 @@ +/* A small C header, for testing the importer against something that does not + * move. The raylib case needs raylib installed, needs the right version of it, + * and needs an environment variable set, so it is the wrong thing to hang the + * refusal catalogue on: it would skip everywhere and cover nothing. This + * header has one function per decision Cimport makes, and the test asserts on + * the reasons rather than on the count. + * + * Deliberately includes nothing. A header that pulls in stdio would make the + * dump thirty times larger and would put libc's declarations in the way of + * reading the test's. */ + +typedef struct Pair { float x; float y; } Pair; +typedef struct Shade { unsigned char r, g, b, a; } Shade; +typedef struct Undescribed { int a; int b; } Undescribed; + +/* A second typedef name for a record the package already describes under + * another one. raylib does this: struct Texture is Texture2D and also + * TextureCubemap. Both have to resolve to the one defstruct. */ +typedef struct Pair Point; + +typedef enum Mood { MOOD_CALM = 0, MOOD_CROSS = 1 } Mood; + +typedef void (*Notify)(void *user, unsigned int n); + +/* --- accepted --- */ +void set_seed(unsigned int seed); +int add_ints(int a, int b); +Pair make_pair(float x, float y); /* aggregate out, by out-pointer */ +float pair_len(Pair p); /* aggregate in, by pointer */ +Shade tint(Shade base, Shade over); +int name_length(const char *text); /* const char * is a string in */ +int count_at(const int *values, int n); /* T * is (Ptr T) */ +Pair point_of(Point p); /* the second typedef name */ +int mood_value(Mood m); /* a C enum is an int */ +void take_nothing(void); + +/* --- refused, one per reason --- */ +const char *name_of(int which); /* returns char * */ +void fill_buffer(char *out, int cap); /* non-const char *: C writes it */ +int printf_like(const char *fmt, ...); /* variadic */ +void on_event(Notify cb); /* a callback */ +long file_time(const char *path); /* long varies across our targets */ +Undescribed make_undescribed(void); /* no defstruct for it */ + +/* Two names that kebab to one, so the collision is refused by name rather than + * arriving at the checker as a duplicate declaration nobody wrote. */ +int Spin2D(int n); +int spin2d(int n); diff --git a/test/programs/raylib-imported.flan b/test/programs/raylib-imported.flan new file mode 100644 index 0000000..0d8087c --- /dev/null +++ b/test/programs/raylib-imported.flan @@ -0,0 +1,36 @@ +;;;; Every binding called here came out of raylib's header, not out of +;;;; raylib.flan. The package binds none of these four by hand, so if this +;;;; program runs at all the importer produced working declarations — and +;;;; what it prints pins rather more than that. +;;;; +;;;; Needs FLAN_RAYLIB_H pointing at a raylib 5.5 header; the acceptance case +;;;; skips without it. + +(import rl "vendor:raylib") + +(defn main [] i32 + ;; A scalar in, a scalar out. Seeded, and a range of one, so the answer is + ;; the bound rather than anything random. + (rl/set-random-seed 12345) + (println (rl/get-random-value 10 10)) + + ;; A string parameter. A Flan string is ptr+len and never NUL-terminated, so + ;; this only answers 5 if the generated wrapper made the terminated copy. + (println (rl/text-length "hello")) + + ;; A struct by value in, a scalar out. 0x11223344 is 287454020, and it is + ;; the four fields read in r,g,b,a order — swap any two and the number + ;; changes, which a round trip could not have told us. + (println (rl/color-to-int (rl/Color {.r 17 .g 34 .b 51 .a 68}))) + + ;; A struct in and a struct out, which is the whole flattening path: the + ;; argument goes by pointer and the result comes back through an + ;; out-parameter. Tinting by white is the identity, so the four bytes come + ;; back separately and in order. + (let [t (rl/color-tint (rl/Color {.r 255 .g 255 .b 255 .a 255}) + (rl/Color {.r 17 .g 34 .b 51 .a 68}))] + (println (.r t)) + (println (.g t)) + (println (.b t)) + (println (.a t))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 8806fde..0b061ec 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -658,6 +658,39 @@ let () = else print_endline "acceptance: skipping the raylib FFI case (no libraylib)"; + (* The same boundary, from declarations nobody wrote. Every binding this + program calls came out of raylib's header through vendor/raylib/headers; + the package binds none of the four by hand, so if it runs at all the + importer produced working declarations. + + What it prints pins more than that. ColorToInt of {17,34,51,68} is + 0x11223344 — the four fields read in r,g,b,a order, so exchanging any + two changes the number — and ColorTint by white is the identity, which + hands the four bytes back separately. That is the same argument the + GetColor case makes and for the same reason: handing a struct over and + reading it back proves nothing, because storing and returning is + symmetric and a permuted layout comes back permuted the same way. + TextLength of "hello" is 5, which is only true if the generated wrapper + NUL-terminated the copy. + + Skipped without FLAN_RAYLIB_H, because the import is opt-in — a build + needs libraylib linkable and not raylib-devel installed, and that is a + property worth keeping. The importer's own table does not skip: it runs + against test/headers/sample.h, which is committed. *) + (match Sys.getenv_opt "FLAN_RAYLIB_H" with + | Some h when Sys.file_exists h + && Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 -> + let out = "10\n5\n287454020\n17\n34\n51\n68\n" in + outputs "raylib, bindings read from the header" "programs/raylib-imported.flan" out; + (* At -O0 too, for the reason the rest of the table is: every struct + here crosses as (addr v) on a local, which is the alloca mem2reg + would launder before anyone noticed it was wrong. *) + outputs ~opt:"-O0" "raylib, bindings read from the header, -O0" + "programs/raylib-imported.flan" out + | _ -> + print_endline + "acceptance: skipping the imported-bindings case (FLAN_RAYLIB_H unset)"); + (* raylib's Image family, headless, and the strongest FFI case here: an Image is pixels in RAM, so raylib *computes* with it rather than storing and returning it. diff --git a/test/test_flan.ml b/test/test_flan.ml index 9bf98b2..d07e4d7 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1120,6 +1120,231 @@ let () = "(defn f [] i32 (let [xs [1 2]] (destructure~nth xs 0 2 1)))" ~needle:"means nothing outside a quasiquote"; + (* ── Reading a C header (cimport.ml, cjson.ml) ─────────────────── *) + + (* Against test/headers/sample.h, which is one function per decision the + importer makes and is committed so that it cannot move. The raylib case + is better evidence and worse coverage: it needs raylib installed, at the + version whose .so is linked, with FLAN_RAYLIB_H set, so as the only test + of this it would skip everywhere. + + The assertions are on the *reasons*, not on the counts, for the reason the + acceptance table gives: a refusal that fires for the wrong cause still + refuses, and a count still matches. *) + let imported, dump, env, fixture_ds = + let fixture = + "(defstruct Pair [x f32 y f32])\n\ + (defstruct Shade [r u8 g u8 b u8 a u8])\n\ + (defenum Mood [calm 0 cross 1])\n" + in + let ds = program fixture in + let taken = Hashtbl.create 16 in + List.iter + (fun d -> + match Ast.declared_name d with + | Some n -> Hashtbl.replace taken n () + | None -> ()) + ds; + let known_structs = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defstruct (n, _) -> Some n | _ -> None) + ds + and known_enums = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defenum (n, _) -> Some n | _ -> None) + ds + in + let i, d, e = + Cimport.header ~loc:Loc.unknown ~header:"headers/sample.h" ~flags:[] + ~known_structs ~known_enums ~taken ~bound_syms:[] + in + (i, d, e, ds) + in + + (* What came out, as source, so a wrong type is visible as the line somebody + would otherwise have had to write by hand. *) + let produced = List.map Cimport.decl_source imported.Cimport.decls in + let emits name line = + check ("import-c emits " ^ name) (List.mem line produced) + in + emits "a scalar signature" "(declare-c set-seed [seed u32] \"set_seed\")"; + emits "two scalars and a return" + "(declare-c add-ints [a i32 b i32] i32 \"add_ints\")"; + (* An aggregate return is the flattening path: Shim turns it into an + out-pointer, and the declaration it starts from has to say the struct. *) + emits "an aggregate return" + "(declare-c make-pair [x f32 y f32] Pair \"make_pair\")"; + emits "an aggregate parameter" "(declare-c pair-len [p Pair] f32 \"pair_len\")"; + (* const char * is a string going in — the one C spelling that means + something different in a parameter than it does anywhere else. *) + emits "const char * as a string parameter" + "(declare-c name-length [text string] i32 \"name_length\")"; + emits "a pointer parameter" + "(declare-c count-at [values (Ptr i32) n i32] i32 \"count_at\")"; + (* struct Pair is both Pair and Point in the header and the package + describes it once, so both names have to land on the one defstruct — + raylib does exactly this with Texture2D and TextureCubemap. *) + emits "a second typedef name for a described record" + "(declare-c point-of [p Pair] Pair \"point_of\")"; + (* A C enum is an int, and so is a Flan defenum at the boundary; matching by + name is what keeps the nicer face. *) + emits "a C enum against a defenum of the same name" + "(declare-c mood-value [m Mood] i32 \"mood_value\")"; + emits "a function of no arguments" "(declare-c take-nothing [] \"take_nothing\")"; + + (* And the refusals, each by its reason rather than by a count. *) + let refused name needle = + check + ("import-c refuses " ^ name ^ ": " ^ needle) + (List.exists + (fun (n, why) -> n = name && contains why needle) + imported.Cimport.hidden) + in + refused "name-of" "returns char *"; + refused "fill-buffer" "C may write through"; + refused "printf-like" "is variadic"; + refused "on-event" "is a function pointer"; + refused "file-time" "width that differs"; + refused "make-undescribed" "the package does not describe"; + (* The order-dependent one. Spin2D and spin2d both kebab to spin-2d, so + neither may have it: whichever won would depend on the order the header + declares them in, and moving two lines in somebody else's header would + rebind a name a program is already calling. *) + refused "spin-2d" "would depend on the order"; + check "a colliding name is not imported after all" + (not (List.exists (fun l -> contains l "\"Spin2D\"") produced)); + check "nor is the other half of the collision" + (not (List.exists (fun l -> contains l "\"spin2d\"") produced)); + + (* A refused name is a name that exists and cannot be had — Zig's failDecl, + which Load.refuse_hidden already implements for main. Nothing may be in + both lists, or asking for a name that works would report that it does + not. *) + check "nothing is both imported and refused" + (not + (List.exists + (fun (d : Ast.decl) -> + match Ast.declared_name d with + | Some n -> List.mem_assoc n imported.Cimport.hidden + | None -> false) + imported.Cimport.decls)); + + (* The struct check, which is the point of reading a header the generator + does not otherwise need: the defstruct and the header's record have + different authors, so a disagreement is real information. A + _Static_assert was rejected in BUILT.md as circular for want of exactly + that. *) + let structs_of ds = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.Defstruct (n, fs) -> Some (n, fs) | _ -> None) + ds + in + check "a defstruct that matches the header is not reported" + (Cimport.check_structs ~env ~structs:(structs_of fixture_ds) dump = []); + (* Permuted: the failure BUILT.md says only a test can catch, because every + field still reads as a plausible number. *) + check "a permuted defstruct is reported" + (match + Cimport.check_structs ~env + ~structs:(structs_of (program "(defstruct Pair [y f32 x f32])\n")) dump + with + | [ ("Pair", why) ] -> contains why "field order" + | _ -> false); + (* Widened: the other half of the same hazard and the one BUILT.md names — + f64 where the library says float lays out eight bytes where there are + four, and every field after it moves. *) + check "a widened field is reported" + (match + Cimport.check_structs ~env + ~structs:(structs_of (program "(defstruct Pair [x f32 y f64])\n")) dump + with + | [ ("Pair", why) ] -> contains why "f64" && contains why "f32" + | _ -> false); + (* A struct the header says nothing about is not a disagreement: a package + may describe something the library does not name. *) + check "a struct the header does not describe is left alone" + (Cimport.check_structs ~env + ~structs:(structs_of (program "(defstruct Nowhere [q i32])\n")) dump + = []); + + (* diff_bound: a hand-written declare-c against the header's own signature. + This is the check with no other source — a wrong declare-c is wrong in the + generated prototype too, so the two halves agree with each other and only + the library knows better. *) + let bound_of src = + List.filter_map + (fun (d : Ast.decl) -> + match d.Ast.d with Ast.DeclareC (fn, sym) -> Some (fn, sym) | _ -> None) + (program src) + in + let differs name src needle = + check ("declare-c against the header: " ^ name) + (match Cimport.diff_bound ~env ~bound:(bound_of src) dump with + | [ d ] -> contains d.Cimport.dwhy needle + | _ -> false) + in + check "a declare-c that matches the header is not reported" + (Cimport.diff_bound ~env + ~bound:(bound_of "(declare-c add [a i32 b i32] i32 \"add_ints\")") dump + = []); + differs "a wrong parameter width" + "(declare-c add [a f64 b i32] i32 \"add_ints\")" "parameter a is f64"; + differs "a wrong arity" "(declare-c add [a i32] i32 \"add_ints\")" + "the header says 2"; + differs "a wrong return type" + "(declare-c add [a i32 b i32] f32 \"add_ints\")" "returns f32"; + (* A symbol the header does not have at all is the version-drift case, and + it is how a package pinned to the wrong release announces itself. *) + differs "a symbol the header does not declare" + "(declare-c gone [] \"no_such_function\")" "does not declare"; + (* An enum face against a plain int is the expected difference and not a + finding: that is what a defenum is at the boundary. *) + check "an enum face against the header's int is not a difference" + (Cimport.diff_bound ~env + ~bound:(bound_of "(declare-c mv [m Mood] i32 \"mood_value\")") dump + = []); + + (* The name rule. Reversibility is by storage — the C symbol is kept verbatim + in the declaration — so what the rule has to be is injective over one + header, which the collision case above asserts. These pin its shape. *) + List.iter + (fun (c, flan) -> + check + (Printf.sprintf "kebab %s -> %s" c flan) + (String.equal (Cimport.kebab c) flan)) + [ ("InitWindow", "init-window"); + (* An acronym stays one word rather than becoming separate letters. *) + ("SetTargetFPS", "set-target-fps"); + ("ColorToHSV", "color-to-hsv"); + ("UnloadUTF8", "unload-utf8"); + (* A digit run takes the uppercase after it, so 2D is one word. *) + ("BeginMode2D", "begin-mode-2d"); + ("GetScreenToWorld2D", "get-screen-to-world-2d"); + ("snake_case_already", "snake-case-already") ]; + + (* cjson.ml, on the shapes clang's dump actually contains. *) + check "json: an escaped string" + (match Cjson.parse "{\"a\":\"x\\ny\"}" with + | Cjson.Obj [ ("a", Cjson.Str "x\ny") ] -> true + | _ -> false); + check "json: nesting, numbers, booleans and null" + (match Cjson.parse "{\"i\":[1,-2,3.5e2],\"b\":true,\"n\":null}" with + | Cjson.Obj + [ ("i", Cjson.Arr [ _; _; _ ]); ("b", Cjson.Bool true); + ("n", Cjson.Null) ] -> true + | _ -> false); + check "json: empty containers" + (match Cjson.parse "{\"a\":{},\"b\":[]}" with + | Cjson.Obj [ ("a", Cjson.Obj []); ("b", Cjson.Arr []) ] -> true + | _ -> false); + check "json: trailing bytes are refused" + (match Cjson.parse "{} x" with + | _ -> false + | exception Cjson.Bad _ -> true); + (* ── The acceptance program checks end to end ──────────────────── *) accepts "calc-me.flan type checks" (In_channel.with_open_bin "../calc-me.flan" In_channel.input_all); diff --git a/vendor/raylib/headers b/vendor/raylib/headers new file mode 100644 index 0000000..4f001e7 --- /dev/null +++ b/vendor/raylib/headers @@ -0,0 +1,32 @@ +# C headers this package reads function signatures out of. One per line: a +# path, then any clang flags that header needs. A relative path is against +# this directory, ${NAME} expands from the environment, and a leading `?` +# means "if it is there" — an optional line with nothing behind it is simply +# not read. +# +# Why this exists. The declare-c lines in raylib.flan were transcribed by +# hand from raylib's documentation, and until now nothing could check that +# any of them matched the real function — BUILT.md records that as trusted +# rather than guaranteed. Point this at raylib's own header and the compiler +# reads the signatures instead: every hand-written line is compared against +# the library's, every defstruct against the header's record, and any raylib +# function the package has not bound becomes available under its own name. +# +# Why it is optional. A build needs libraylib linkable and *not* raylib-devel +# installed, which is a property worth keeping; requiring a header would take +# it from everyone to give the check to whoever has one. So the default build +# is unchanged and this is opt-in, the same shape as ${FLAN_RAYLIB_WEB} in +# `link`. +# +# The version must match the shared library `link` names — 5.5, libraylib.so.550. +# Reading one version's header while linking another's library is exactly the +# silent disagreement this exists to prevent, and `flan import-c` will say so: +# against a 5.1-dev header it reports ten differences that are all real. +# +# export FLAN_RAYLIB_H=/path/to/raylib-5.5/src/raylib.h +# +# To see what it would do without building anything: +# +# flan import-c $FLAN_RAYLIB_H vendor/raylib/raylib.flan +# +?${FLAN_RAYLIB_H}