From d2bc2bd7149228dd542a78e293517d61087aab58 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 11 Sep 2026 20:26:00 +0700 Subject: [PATCH 1/4] The wrapper per binding was always mechanical, so write it here 84 hand-written C wrappers is the shape of a job the compiler should be doing. The reason the shim exists is unchanged and is not negotiable: a small aggregate's calling convention is a per-target classification, not part of its layout, and reproducing x86-64, arm64 and wasm32 inside emit.ml is three classifiers to keep correct forever, where a mistake reads as a field full of garbage rather than as a link error. clang does it, per target, for free. So the C stays; the typing of it stops. declare-c names the library's own function in the library's own signature, and Shim emits the typedefs, the extern prototype, the flattening wrapper and the flattened declaration the Flan side calls. It is a second form rather than a change to declare because no structural rule can separate them: (declare start-raw [path string] i32 "flan_agent_start") means the symbol takes ptr+len, and (declare-c init-window [w i32 h i32 title string] "InitWindow") means it takes a NUL-terminated char *. Same shape, opposite claims. declare is untouched, so sqrtf and vendor/agent keep working unedited. The generated C rides on Tast.program rather than beside it, so the CLI, the REPL and the acceptance table all carry it without being told about it. `flan shim` prints it, because a wrong binding is wrong in a wrapper that is otherwise on no disk anywhere. --- bin/main.ml | 17 +- lib/ast.ml | 9 +- lib/build.ml | 8 + lib/check.ml | 13 +- lib/load.ml | 9 + lib/parse.ml | 32 ++- lib/shim.ml | 611 +++++++++++++++++++++++++++++++++++++++++++++++++++ lib/tast.ml | 6 + 8 files changed, 693 insertions(+), 12 deletions(-) create mode 100644 lib/shim.ml diff --git a/bin/main.ml b/bin/main.ml index 07cc208..a3594e3 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -20,6 +20,9 @@ let summarise (d : Flan.Ast.decl) = | Declare (fn, csym) -> Printf.sprintf "declare %s (%d params) = %s" fn.name (List.length fn.params) csym + | DeclareC (fn, csym) -> + Printf.sprintf "declare-c %s (%d params) = %s" fn.name + (List.length fn.params) csym | Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms) | Defn fn -> Printf.sprintf "defn %s (%d params, %s return, %d body forms)" @@ -100,6 +103,18 @@ let () = (Flan.Types.to_string f.ret) (Array.length f.slots)) p.fns)) files + (* The generated C, for looking at. A wrong FFI binding is wrong in the + wrapper, and the wrapper is not on disk anywhere — [Build] hands the text + straight to clang — so without this the only way to read one is to catch + it in the object cache. *) + | _ :: "shim" :: files when files <> [] -> + List.iter + (fun path -> + with_errors path (fun () -> + match (checked path).Flan.Tast.cshim with + | Some src -> print_string src + | None -> Printf.printf "%s: no declare-c, so no generated C\n" path)) + files (* 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 @@ -205,7 +220,7 @@ let () = exit code) | _ -> prerr_endline - "usage: flan (read|parse|check|emit) ...\n\ + "usage: flan (read|parse|check|emit|shim) ...\n\ \ flan build [-o out] [--no-bounds-checks] [--dev] \ [--target=wasm32-wasi]\n\ \ flan run [args...]\n\ diff --git a/lib/ast.ml b/lib/ast.ml index 7abd55f..3edf084 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -113,6 +113,13 @@ and decl_kind = it is actually called by (plan.org, Types — [declare] is kept only where there is no body). *) | Declare of fn * string + (* The same, but written in the C library's own terms — structs by value, + strings as strings. [Shim] generates the C that flattens it and rewrites + this into a [Declare] plus an ordinary [Defn], so nothing downstream sees + one. Two forms and not one because [(declare f [p string] ...)] already + means "the symbol takes ptr+len", which is the opposite of what this + means. *) + | DeclareC of fn * string (* Inline name/value pairs, as everywhere else. The members are what a keyword at a call site resolves against. *) | Defenum of string * (string * int64) list @@ -132,5 +139,5 @@ let declared_name (d : decl) = match d.d with | Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _) -> Some n - | Declare (fn, _) | Defn fn -> Some fn.name + | Declare (fn, _) | DeclareC (fn, _) | Defn fn -> Some fn.name | Package _ | Import _ -> None diff --git a/lib/build.ml b/lib/build.ml index 7733b88..7a0b297 100644 --- a/lib/build.ml +++ b/lib/build.ml @@ -318,6 +318,14 @@ let executable ?(opts = default) ?(csrcs = []) ?(lflags = []) :: [ cc Runtime_src.dev_source "flan_dev.c" ] (* wasi-libc's entry point, which is not [main]. See [wasm_main_source]. *) @ (if wasm_target opts then [ cc wasm_main_source "flan_wasm_main.c" ] else []) + (* The generated half of the FFI: one translation unit holding a typedef + per struct that crosses and a wrapper per (declare-c ...), compiled + exactly like a package's hand-written .c. It rides on the program + rather than on a parameter so that every caller of [executable] carries + it without having been changed to. See [Shim]. *) + @ (match p.Tast.cshim with + | None -> [] + | Some src -> [ cc src "flan_shim.c" ]) @ List.map (fun c -> cc (read_file c) (Filename.basename c)) csrcs in let cmd = diff --git a/lib/check.ml b/lib/check.ml index 2be2aa2..34aed06 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -1312,6 +1312,12 @@ let collect env (decls : Ast.decl list) = | Ast.Import (alias, _) -> fail loc "internal: the import of %s was not resolved before checking" alias + (* [Shim.expand] rewrote every one of these into a [Declare] and a + [Defn] before [collect] ran, so one arriving here is a driver that + skipped that step. *) + | Ast.DeclareC (fn, _) -> + fail loc "internal: the declare-c of %s was not expanded before checking" + fn.Ast.name | Ast.Declare (fn, csym) -> if Hashtbl.mem env.fns fn.Ast.name then fail loc "%s is declared twice" fn.Ast.name; @@ -1567,6 +1573,11 @@ let check_main env = let program_with_env (decls : Ast.decl list) : Tast.program * env = let env = new_env () in let decls = Parse.program (Prelude.forms ()) @ decls in + (* Before anything is collected: every (declare-c ...) becomes an ordinary + flattened [declare] with a Flan [defn] over it, and the C that does the + flattening comes back to be compiled into the build. Nothing below this + line knows the form exists. *) + let decls, cshim = Shim.expand decls in collect env decls; check_finite env; check_main env; @@ -1599,7 +1610,7 @@ let program_with_env (decls : Ast.decl list) : Tast.program * env = in ({ Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs; unions = values (fun (u : Tast.union) -> u.Tast.uname) env.unions; - globals; externs; fns }, + globals; externs; fns; cshim }, env) let program (decls : Ast.decl list) : Tast.program = fst (program_with_env decls) diff --git a/lib/load.ml b/lib/load.ml index 3fa5869..83cbc8e 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -224,6 +224,15 @@ let qualify_decl owned alias (d : Ast.decl) : Ast.decl = params = List.map (rename_field owned alias) fn.Ast.params; ret = Option.map (rename_texpr owned alias) fn.Ast.ret }, csym) + (* The same as [Declare]: [Shim] has not run yet, so this is still the + library's own signature and the names in it are the package's. *) + | Ast.DeclareC (fn, csym) -> + Ast.DeclareC + ({ fn with + Ast.name = qualify alias fn.Ast.name; + params = List.map (rename_field owned alias) fn.Ast.params; + ret = Option.map (rename_texpr owned alias) fn.Ast.ret }, + csym) | Ast.Defenum (n, ms) -> Ast.Defenum (qualify alias n, ms) | Ast.Defalias (n, t) -> Ast.Defalias (qualify alias n, rename_texpr owned alias t) diff --git a/lib/parse.ml b/lib/parse.ml index c5db730..efe8dc1 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -435,22 +435,36 @@ let rec decl types (f : Form.t) : Ast.decl = fbody = body; nloc = n.loc }) | _ -> fail f "defn is (defn name [param Type ...] ReturnType? body ...)") - | List ({ v = Sym "declare"; _ } :: args) -> + | List ({ v = Sym ("declare" | "declare-c" as which); _ } :: args) -> (* (declare name [param Type ...] ReturnType? "c_symbol"). The C symbol is last and is always written: a foreign name is not derivable from a Flan - one, and guessing it would fail at link time rather than here. *) + one, and guessing it would fail at link time rather than here. + + [declare-c] is the same shape and a different claim about the symbol. + [declare]'s signature IS the C signature, already flattened by whoever + wrote the C; [declare-c]'s is the *library's* — structs by value — and + [Shim] generates the flattening. The two cannot be one form, because + (declare f [p string] ...) already means the symbol takes ptr+len and + (declare-c f [p string] ...) means it takes a NUL-terminated char *. *) + let mkd fn csym = + if String.equal which "declare-c" then Ast.DeclareC (fn, csym) + else Ast.Declare (fn, csym) + in + let usage = + Printf.sprintf + "%s is (%s name [param Type ...] ReturnType? \"c_symbol\")" which which + in (match List.rev args with | { v = Str csym; _ } :: rest -> (match List.rev rest with | [ n; { v = Form.Vec ps; _ } ] -> - mk (Ast.Declare ({ Ast.name = sym n; params = fields f ps; - ret = None; fbody = []; nloc = n.loc }, csym)) + mk (mkd { Ast.name = sym n; params = fields f ps; + ret = None; fbody = []; nloc = n.loc } csym) | [ n; { v = Form.Vec ps; _ }; r ] -> - mk (Ast.Declare ({ Ast.name = sym n; params = fields f ps; - ret = Some (texpr r); fbody = []; nloc = n.loc }, - csym)) - | _ -> fail f "declare is (declare name [param Type ...] ReturnType? \"c_symbol\")") - | _ -> fail f "declare is (declare name [param Type ...] ReturnType? \"c_symbol\")") + mk (mkd { Ast.name = sym n; params = fields f ps; + ret = Some (texpr r); fbody = []; nloc = n.loc } csym) + | _ -> fail f "%s" usage) + | _ -> fail f "%s" usage) | List ({ v = Sym "defenum"; _ } :: args) -> (match args with diff --git a/lib/shim.ml b/lib/shim.ml new file mode 100644 index 0000000..dfe6c99 --- /dev/null +++ b/lib/shim.ml @@ -0,0 +1,611 @@ +(** [declare-c]: a foreign function written in the C library's own terms, with + the crossing generated rather than hand-written. + + [declare] says "this Flan signature *is* the C signature" — the symbol it + names already trades in scalars and ptr+len, because somebody wrote it that + way ([flan_agent_start], [sqrtf], the runtime's own shims). That form is + unchanged and this module never touches one. + + [declare-c] says the other thing: the signature is the *library's*, structs + by value and all, and the compiler is to produce whatever flattening makes + it crossable. The two cannot be one form — + [(declare start-raw [path string] i32 "flan_agent_start")] and + [(declare-c init-window [w i32 h i32 title string] "InitWindow")] are the + same shape and mean opposite things about who NUL-terminates the string. + + Why the crossing is still C, and not [emit.ml]: a small aggregate's calling + convention is a per-target *classification*, not part of its layout. + x86-64 hands [Vector2] over as [<2 x float>] and returns [Rectangle] as + [{i64,i64}]; arm64 and wasm32 each do something else. Reproducing that in + the backend is three classifiers to keep correct forever, and a mistake + reads as a field full of garbage rather than as a link error. clang already + does it, per target, for free. So the C shim stays; what stops is writing + it by hand. + + What this module does with one [declare-c]: + + - emits a C [typedef] for every struct in the signature, from the Flan + [defstruct], transitively and once each; + - emits an [extern] prototype for the real function, in its true signature; + - emits a wrapper that flattens — a struct returns through an out-pointer, + a struct argument goes by pointer, a Flan string arrives as ptr+len and + the wrapper NUL-terminates a copy; + - and rewrites the declaration into the flattened [declare] the Flan side + calls, with an ordinary Flan [defn] above it carrying the nice signature. + + {2 What is guaranteed and what is trusted} + + Guaranteed: the C typedef and the Flan struct come from the same + [defstruct], so they cannot disagree — permute the [defstruct] and the + typedef permutes with it. And clang type-checks the wrapper against the + [extern] prototype, so the flattening cannot disagree with the prototype. + + Trusted: that the [defstruct] describes the library's real struct, and that + the [declare-c] signature is the function's real signature. No library + header is read — deliberately, so a build needs the shared library and not + the -devel package — so nothing here can check either. Two consequences + worth stating plainly: + + - the prototype is now generated *from the declaration*, so a scalar's + width carries ABI weight it did not before. [f64] where the library says + [float] used to be narrowed by clang at the hand-written call site; now + it emits [double] and the library reads garbage. + - the only thing that catches a wrong [defstruct] is a test that makes the + library *compute* with the fields — which is why the raylib acceptance + cases pin layouts by arithmetic and go red when a [defstruct] is + permuted. + + A [_Static_assert] on [sizeof] and [offsetof] was considered and left out: + both sides of it would come from the same field list, so it would check + this module's arithmetic against clang's and say nothing about the library. + What would convert the trusted half into a checked one is including the + real header when one is installed, and that is not built. *) + +let fail = Loc.fail + +(* ── Names ────────────────────────────────────────────────────────── + A Flan name may contain '/', '-', '?' and '!', none of which a C identifier + may. Squashing them all to '_' is not injective — [valid?] and [valid_] + would collide — so the readable squash carries a digest of the original, + which makes it injective without making it unreadable. *) + +let squash s = + let b = Buffer.create (String.length s) in + String.iter + (fun c -> + let ok = + (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') + || (c >= '0' && c <= '9') + in + Buffer.add_char b (if ok then c else '_')) + s; + Buffer.contents b + +let mangle s = + Printf.sprintf "%s_%s" (squash s) + (String.sub (Digest.to_hex (Digest.string s)) 0 8) + +let shim_symbol flan_name = "flan_shim_" ^ mangle flan_name +let ctype_name struct_name = "flan_ty_" ^ mangle struct_name + +(* The Flan name the generated flattened declaration gets. It is visible, as + the hand-written [-raw] names were, because there is no visibility rule + yet. *) +let raw_name flan_name = flan_name ^ "-c" + +(* Locals the generated Flan wrapper binds. A parameter is not an assignable + place (spec-memory.md), so a struct argument needs a copy to take the + address of — and the hand-written wrappers had to rename around their own + parameters to do it ([draw-triangle] bound [d] for [v3] to keep [c] for the + colour). These cannot collide with anything: the reader does not produce a + name beginning with '%'. *) +let tmp i = Printf.sprintf "%%a%d" i +let out_tmp = "%out" + +(* ── The declarations in scope ──────────────────────────────────────── *) + +type env = { + structs : (string, Ast.field list) Hashtbl.t; + enums : (string, unit) Hashtbl.t; + unions : (string, unit) Hashtbl.t; + aliases : (string, Ast.texpr) Hashtbl.t; +} + +let scan (decls : Ast.decl list) = + let env = + { structs = Hashtbl.create 32; enums = Hashtbl.create 32; + unions = Hashtbl.create 8; aliases = Hashtbl.create 16 } + in + List.iter + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defstruct (n, fs) -> Hashtbl.replace env.structs n fs + | Ast.Defenum (n, _) -> Hashtbl.replace env.enums n () + | Ast.Defunion (n, _) -> Hashtbl.replace env.unions n () + | Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t + | _ -> ()) + decls; + env + +(* An alias is a name for a type expression, so follow it before deciding what + a type is. [check.ml] rejects a cyclic alias, but this runs before it does, + so the walk is bounded rather than trusting. *) +let unalias env (t : Ast.texpr) = + let rec go fuel t = + if fuel = 0 then t + else + match t.Ast.t with + | Ast.Tname n -> + (match Hashtbl.find_opt env.aliases n with + | Some t' -> go (fuel - 1) t' + | None -> t) + | _ -> t + in + go 100 t + +(* ── Flan type → C type ───────────────────────────────────────────── + One function, used for a struct's fields and for a function's parameters + alike, so the two cannot drift: a [bool] field and a [bool] argument are the + same C [bool] and never an [int]. *) + +let prim_cty = function + | "i8" -> Some "int8_t" | "i16" -> Some "int16_t" + | "i32" -> Some "int32_t" | "i64" -> Some "int64_t" + | "u8" -> Some "uint8_t" | "u16" -> Some "uint16_t" + | "u32" -> Some "uint32_t" | "u64" -> Some "uint64_t" + | "f32" -> Some "float" | "f64" -> Some "double" + | "bool" -> Some "bool" + | _ -> None + +(* [needed] collects the structs whose typedefs this signature pulls in, in the + order they were first met. Order is the program's and never a hash fold's: + the object cache keys on the generated text, so a reordering would be a + rebuild. *) +let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = + let t = unalias env t in + match t.Ast.t with + | Ast.Tname n -> + (match prim_cty n with + | Some c -> c + | None -> + if Hashtbl.mem env.structs n then begin + if not (List.mem n !needed) then needed := !needed @ [ n ]; + ctype_name n + end + else if Hashtbl.mem env.enums n then + (* A C enum is an int, and Flan's [Enum] is an i32 — the same thing on + every target this compiles for. *) + "int32_t" + else if Hashtbl.mem env.unions n then + fail loc + "%s is %s, a union, and a Flan union has no C layout — the shim \ + cannot be generated for it" + what n + else if String.equal n "string" then + fail loc + "%s is a string, and a string only crosses as a parameter — a C \ + function that *returns* one returns something Flan has no owner for" + what + else if String.equal n "Unit" || String.equal n "Never" then + fail loc "%s is %s, which is not a value C can carry" what n + else + fail loc "%s is %s, which is not a type this shim generator knows" what n) + | Ast.Tapp ("Ptr", [ e ]) -> cty env ~needed ~loc ~what e ^ " *" + | Ast.Tapp ("Option", _) -> + fail loc + "%s is an Option, which is a Flan shape and not a C one — declare what C \ + returns and build the Option in Flan" + what + | Ast.Tslice _ -> + fail loc + "%s is a slice, which crosses as ptr+len with an i64 length, and the \ + count parameter the C function actually takes has a type this \ + declaration does not say — declare (Ptr T) with an explicit count and \ + pass (addr (at s 0)) and (len s) from Flan" + what + | Ast.Tarray _ -> + fail loc + "%s is a fixed array, which C passes as a pointer and Flan as a value — \ + declare (Ptr T) and say which" + what + | Ast.Tmap _ -> fail loc "%s is a map, which has no C representation" what + | Ast.Tfn _ -> + fail loc "%s is a function type, and a C callback is not implemented" what + | Ast.Tapp (n, _) -> + fail loc "%s is %s, which is not a type this shim generator knows" what n + +(* ── What one parameter does at the boundary ────────────────────────── *) + +type pkind = + | Pscalar (* crosses as itself: an int, a float, a Ptr *) + | Pstruct of string (* by value in C; by pointer across the boundary *) + | Pstr (* ptr+len in, a NUL-terminated copy out *) + +let classify env ~needed ~loc ~what (t : Ast.texpr) = + let t' = unalias env t in + match t'.Ast.t with + | Ast.Tname "string" -> (Pstr, "const char *") + | Ast.Tname n when Hashtbl.mem env.structs n -> + ignore (cty env ~needed ~loc ~what t'); + (Pstruct n, ctype_name n) + | _ -> (Pscalar, cty env ~needed ~loc ~what t') + +(* ── The C text ─────────────────────────────────────────────────────── *) + +let header = + "/* Generated by Flan from the (declare-c ...) forms in this program. Do not\n\ + \ * edit it: it is rebuilt from the declarations on every build, and the\n\ + \ * object cache is keyed by the text below, so an edit here is either\n\ + \ * overwritten or — worse — kept after the declarations have moved on.\n\ + \ *\n\ + \ * Every wrapper exists so that no aggregate crosses the Flan/C boundary. A\n\ + \ * small struct's calling convention is a per-target classification rather\n\ + \ * than part of its layout, so clang does it here, correctly, for whichever\n\ + \ * target this build is for, and the backend never learns x86-64 from arm64\n\ + \ * from wasm32.\n\ + \ *\n\ + \ * No library header is included, deliberately: the prototypes below are the\n\ + \ * declarations, so a build needs the shared library to be linkable and not\n\ + \ * the -devel package to be installed. The price is that a prototype here is\n\ + \ * only as right as the declare-c it came from.\n\ + \ */\n\n\ + #include \n\ + #include \n\ + #include \n\ + #include \n\ + #include \n\n" + +(* A Flan string is ptr+len and never NUL-terminated, so a C API that wants a C + string needs a copy. The hand-written wrappers sized the buffer per call + site — 256 for a window title, PATH_MAX for a path, 512 for drawn text — and + truncated past it. A generator has no call site to look at, so it must not + be the thing deciding a string is too long: what does not fit the stack + buffer is copied to the heap and freed after the call. The stack buffer is + what keeps that allocation-free in the overwhelmingly common case, and it is + 256 because that covers a title, a path and a line of text without making + every foreign call carry a page of stack. The only truncation left is when + malloc itself fails, where the alternative is handing C a null pointer. *) +let cstr_helpers = + "static char *flan_shim_cstr(const char *p, int64_t n, char *buf, size_t cap) {\n\ + \ size_t len = n <= 0 ? 0 : (size_t)n;\n\ + \ char *d = buf;\n\ + \ if (len + 1 > cap) {\n\ + \ d = (char *)malloc(len + 1);\n\ + \ if (d == NULL) { d = buf; len = cap - 1; } /* out of memory: truncate */\n\ + \ }\n\ + \ if (len != 0) memcpy(d, p, len);\n\ + \ d[len] = '\\0';\n\ + \ return d;\n\ + }\n\n\ + static void flan_shim_cstr_free(char *d, char *buf) {\n\ + \ if (d != buf) free(d);\n\ + }\n\n" + +let cstr_cap = 256 + +(* One [declare-c], reduced to what both halves need. *) +type shim = { + sflan : string; (* the Flan name as written *) + ssym : string; (* the C symbol being bound *) + swrap : string; (* the generated wrapper's symbol *) + sargs : (pkind * string) list; (* kind and C type, per parameter *) + sret : [ `Void | `Scalar of string | `Struct of string * string ]; + sloc : Loc.t; +} + +let arg_name i = Printf.sprintf "a%d" i + +(* The wrapper's own parameter list: a struct by pointer, a string as ptr+len, + anything else as itself — plus the out-pointer when C returns a struct. *) +let wrapper_params s = + let ps = + List.concat + (List.mapi + (fun i (k, c) -> + let a = arg_name i in + match k with + | Pstruct _ -> [ Printf.sprintf "const %s *%s" c a ] + | Pstr -> + [ Printf.sprintf "const char *%s_p" a; + Printf.sprintf "int64_t %s_n" a ] + | Pscalar -> + [ (if String.length c > 0 && c.[String.length c - 1] = '*' then + Printf.sprintf "%s%s" c a + else Printf.sprintf "%s %s" c a) ]) + s.sargs) + in + match s.sret with + | `Struct (_, c) -> ps @ [ Printf.sprintf "%s *out" c ] + | _ -> ps + +let c_for (s : shim) = + let b = Buffer.create 512 in + Printf.bprintf b "/* %s */\n" s.sflan; + (* The prototype, in the library's own terms. *) + let proto_args = + List.map + (fun (k, c) -> + match k with Pstruct _ -> c | Pstr -> "const char *" | Pscalar -> c) + s.sargs + in + let proto_ret = + match s.sret with `Void -> "void" | `Scalar c -> c | `Struct (_, c) -> c + in + Printf.bprintf b "extern %s %s(%s);\n" proto_ret s.ssym + (match proto_args with [] -> "void" | _ -> String.concat ", " proto_args); + let wret = match s.sret with `Struct _ | `Void -> "void" | `Scalar c -> c in + let wparams = wrapper_params s in + Printf.bprintf b "%s %s(%s) {\n" wret s.swrap + (match wparams with [] -> "void" | _ -> String.concat ", " wparams); + (* The NUL-terminated copies, before the call. *) + List.iteri + (fun i (k, _) -> + match k with + | Pstr -> + let a = arg_name i in + Printf.bprintf b " char %s_b[%d];\n" a cstr_cap; + Printf.bprintf b + " char *%s = flan_shim_cstr(%s_p, %s_n, %s_b, sizeof %s_b);\n" a a a + a a + | _ -> ()) + s.sargs; + let call_args = + List.mapi + (fun i (k, _) -> + let a = arg_name i in + match k with Pstruct _ -> "*" ^ a | Pstr | Pscalar -> a) + s.sargs + in + let call = Printf.sprintf "%s(%s)" s.ssym (String.concat ", " call_args) in + let has_str = List.exists (fun (k, _) -> k = Pstr) s.sargs in + (match s.sret with + | `Void -> Printf.bprintf b " %s;\n" call + | `Struct _ -> Printf.bprintf b " *out = %s;\n" call + | `Scalar c -> + (* The result is named rather than returned straight through when there + are copies to free: the free has to happen after the call. *) + if has_str then Printf.bprintf b " %s r = %s;\n" c call + else Printf.bprintf b " return %s;\n" call); + if has_str then begin + List.iteri + (fun i (k, _) -> + match k with + | Pstr -> + let a = arg_name i in + Printf.bprintf b " flan_shim_cstr_free(%s, %s_b);\n" a a + | _ -> ()) + s.sargs; + match s.sret with + | `Scalar _ -> Buffer.add_string b " return r;\n" + | _ -> () + end; + Buffer.add_string b "}\n\n"; + Buffer.contents b + +(* The typedefs, forward-declared first so a struct may hold a pointer to one + defined below it — or to itself — and then defined in dependency order, so a + struct held *by value* is complete before it is used. *) +let typedefs env needed = + let b = Buffer.create 512 in + (* The transitive closure, in first-met order. *) + let rec close acc n = + if List.mem n acc then acc + else + let acc = acc @ [ n ] in + match Hashtbl.find_opt env.structs n with + | None -> acc + | Some fs -> + List.fold_left + (fun acc (f : Ast.field) -> + let sink = ref [] in + (* The type mapper is reused here purely to discover the struct + names a field mentions; its text is not wanted. Mapping it now + is also what refuses an unrepresentable field, at the field. *) + ignore + (cty env ~needed:sink ~loc:f.Ast.floc + ~what:(Printf.sprintf "field %s of %s" f.Ast.fname n) + f.Ast.fty); + List.fold_left close acc !sink) + acc fs + in + let all = List.fold_left close [] needed in + List.iter + (fun n -> + Printf.bprintf b "typedef struct %s_s %s;\n" (ctype_name n) (ctype_name n)) + all; + if all <> [] then Buffer.add_char b '\n'; + (* Define a struct after every struct it holds by value. *) + let defined = ref [] in + let rec define n = + if not (List.mem n !defined) then begin + defined := n :: !defined; + let fs = Hashtbl.find env.structs n in + List.iter + (fun (f : Ast.field) -> + match (unalias env f.Ast.fty).Ast.t with + | Ast.Tname m when Hashtbl.mem env.structs m -> define m + | _ -> ()) + fs; + Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n; + List.iter + (fun (f : Ast.field) -> + let c = + cty env ~needed:(ref []) ~loc:f.Ast.floc + ~what:(Printf.sprintf "field %s of %s" f.Ast.fname n) f.Ast.fty + in + let star = String.length c > 0 && c.[String.length c - 1] = '*' in + (* A field name needs no digest: it is scoped to this struct, and + two Flan fields that squash together are a duplicate member + clang refuses by name. *) + Printf.bprintf b " %s%s%s;\n" c (if star then "" else " ") + (squash f.Ast.fname)) + fs; + Buffer.add_string b "};\n\n" + end + in + List.iter define all; + Buffer.contents b + +(* ── The Flan halves ────────────────────────────────────────────────── *) + +let ty loc t = { Ast.t; tloc = loc } +let ex loc e = { Ast.e; loc } + +(* The flattened declaration the Flan side actually calls: a struct parameter + becomes (Ptr T), a struct return becomes a trailing out-parameter. *) +let flattened (fn : Ast.fn) (s : shim) name : Ast.fn = + let loc = fn.Ast.nloc in + let params = + List.map2 + (fun (p : Ast.field) (k, _) -> + match k with + | Pstruct n -> + { p with + Ast.fty = + ty p.Ast.floc + (Ast.Tapp ("Ptr", [ ty p.Ast.floc (Ast.Tname n) ])) } + | _ -> p) + fn.Ast.params s.sargs + in + match s.sret with + | `Struct (n, _) -> + { fn with + Ast.name; + params = + params + @ [ { Ast.fname = "out"; floc = loc; + fty = ty loc (Ast.Tapp ("Ptr", [ ty loc (Ast.Tname n) ])) } ]; + ret = None } + | _ -> { fn with Ast.name; params } + +(* The ordinary Flan function that carries the nice signature: it copies each + struct argument into a local — a parameter is not an assignable place, so + there is no address to take without one — and, when C returns a struct, + zeroes one and hands over its address. *) +let flan_wrapper (fn : Ast.fn) (s : shim) raw : Ast.decl_kind = + let loc = fn.Ast.nloc in + let binds = ref [] in + let args = + List.mapi + (fun i ((p : Ast.field), (k, _)) -> + match k with + | Pstruct _ -> + let t = tmp i in + binds := + !binds + @ [ { Ast.bname = t; bty = None; + bval = ex p.Ast.floc (Ast.Var p.Ast.fname); + bloc = p.Ast.floc } ]; + ex p.Ast.floc + (Ast.Call + (ex p.Ast.floc (Ast.Var "addr"), [ ex p.Ast.floc (Ast.Var t) ])) + | _ -> ex p.Ast.floc (Ast.Var p.Ast.fname)) + (List.combine fn.Ast.params s.sargs) + in + let call args = ex loc (Ast.Call (ex loc (Ast.Var raw), args)) in + let body, ret = + match s.sret with + | `Struct (n, _) -> + binds := + !binds + @ [ { Ast.bname = out_tmp; bty = None; + bval = ex loc (Ast.Struct (n, [])); bloc = loc } ]; + let out = ex loc (Ast.Var out_tmp) in + ( [ call (args @ [ ex loc (Ast.Call (ex loc (Ast.Var "addr"), [ out ])) ]); + out ], + Some (ty loc (Ast.Tname n)) ) + | _ -> ([ call args ], fn.Ast.ret) + in + Ast.Defn { fn with Ast.ret; fbody = [ ex loc (Ast.Let (!binds, body)) ] } + +(* ── Expansion ──────────────────────────────────────────────────────── *) + +let one env (fn : Ast.fn) csym loc = + let needed = ref [] in + let sargs = + List.map + (fun (p : Ast.field) -> + classify env ~needed ~loc:p.Ast.floc + ~what:(Printf.sprintf "parameter %s of %s" p.Ast.fname fn.Ast.name) + p.Ast.fty) + fn.Ast.params + in + let what = Printf.sprintf "the return type of %s" fn.Ast.name in + let sret = + match fn.Ast.ret with + | None -> `Void + | Some t -> + let t' = unalias env t in + (match t'.Ast.t with + | Ast.Tname "Unit" -> `Void + | Ast.Tname n when Hashtbl.mem env.structs n -> + ignore (cty env ~needed ~loc ~what t'); + `Struct (n, ctype_name n) + | _ -> `Scalar (cty env ~needed ~loc ~what t')) + in + let s = + { sflan = fn.Ast.name; ssym = csym; swrap = shim_symbol fn.Ast.name; sargs; + sret; sloc = loc } + in + (* A declaration whose Flan face already equals its flattened face needs no + Flan function on top of it; only the ones with a struct in the signature + do. A string is not one of those — it crosses as ptr+len either way, and + it is the C wrapper that terminates it. *) + let needs_flan = + (match sret with `Struct _ -> true | _ -> false) + || List.exists (fun (k, _) -> match k with Pstruct _ -> true | _ -> false) + sargs + in + let decls = + if needs_flan then + let raw = raw_name fn.Ast.name in + [ Ast.Declare (flattened fn s raw, s.swrap); flan_wrapper fn s raw ] + else [ Ast.Declare (flattened fn s fn.Ast.name, s.swrap) ] + in + (decls, s, !needed) + +(* Every [declare-c] in the program, rewritten, with the one C file they share. + The file is [None] when there are none, so a program that binds nothing pays + no C compile. *) +let expand (decls : Ast.decl list) : Ast.decl list * string option = + let env = scan decls in + let shims = ref [] in + let needed = ref [] in + let out = + List.concat_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.DeclareC (fn, csym) -> + let ds, s, n = one env fn csym d.Ast.dloc in + shims := !shims @ [ s ]; + List.iter + (fun x -> if not (List.mem x !needed) then needed := !needed @ [ x ]) + n; + List.map (fun k -> { d with Ast.d = k }) ds + | _ -> [ d ]) + decls + in + match !shims with + | [] -> (out, None) + | shims -> + (* Two Flan names may not bind one C symbol: the prototype would be emitted + twice, and a second Flan name for the same function is a [defn] and not + a second declaration. *) + let seen = Hashtbl.create 16 in + List.iter + (fun s -> + match Hashtbl.find_opt seen s.ssym with + | Some other -> + fail s.sloc + "%s and %s both bind the C function %s — one declare-c per C \ + function, and another Flan name for it is a defn" + other s.sflan s.ssym + | None -> Hashtbl.replace seen s.ssym s.sflan) + shims; + let b = Buffer.create 4096 in + Buffer.add_string b header; + if List.exists (fun s -> List.exists (fun (k, _) -> k = Pstr) s.sargs) shims + then Buffer.add_string b cstr_helpers; + Buffer.add_string b (typedefs env !needed); + List.iter (fun s -> Buffer.add_string b (c_for s)) shims; + (out, Some (Buffer.contents b)) diff --git a/lib/tast.ml b/lib/tast.ml index d79c2a8..de4f33b 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -159,6 +159,12 @@ type program = { globals : global list; (* in declaration order *) externs : extern list; fns : fn list; + (* The C the program's own (declare-c ...) forms generated, if any: one + translation unit, compiled into the build like a package's hand-written + .c file. It is on the program rather than beside it so that every driver + — the CLI, the REPL, the acceptance table — carries it without knowing + it exists. See [Shim]. *) + cshim : string option; } let field_index (s : structure) name = From a3e06ce3d41e92120d9f1d351bfac5a7bde92f0b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 11 Sep 2026 20:26:00 +0700 Subject: [PATCH 2/4] raylib says what it takes, and shim.c stops existing MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit All 84 bindings migrated, so the package is raylib.flan and link and no C at all. Two keep a wrapper and both wrappers are Flan, not C: collision-point-poly? takes a slice and collision-lines answers with an Option, and neither is raylib's signature. A slice in a declare-c is refused by name — the length crosses as i64 and the type of the C count parameter beside the pointer is not recoverable from [T] — so that one declares (Ptr Vector2) with an explicit count and the Flan wrapper hands over (addr (at points 0)) and (len points), answering an empty polygon itself rather than reading out of bounds. What this buys and what it costs, stated rather than assumed. Guaranteed: the C typedef and the Flan struct are made from one defstruct, so they cannot disagree — permute the defstruct and both permute. Trusted: that the defstruct is raylib's real struct and that the declare-c is raylib's real signature. No header is read, on purpose, so the build needs libraylib linkable and not raylib-devel, and nothing here can check either half. A _Static_assert on sizeof and offsetof would have both sides coming from the same field list, so it was left out rather than mistaken for evidence. The sharper edge is the prototype: it is generated from the declaration now, so f64 where raylib says float emits double and raylib reads garbage, where before clang narrowed it at the hand-written call site. Every one of the 84 was diffed against the prototypes in the shim.c being deleted, which was the ground truth, and they agree. Strings are sized here and not per call site, because a generator has no call site to look at. 256 bytes on the stack, the heap past that, freed after the call; the only truncation left is on malloc failure. The old wrappers truncated at 256, PATH_MAX and 512 by hand. --- vendor/raylib/raylib.flan | 675 ++++++++++++-------------------------- vendor/raylib/shim.c | 476 --------------------------- 2 files changed, 210 insertions(+), 941 deletions(-) delete mode 100644 vendor/raylib/shim.c diff --git a/vendor/raylib/raylib.flan b/vendor/raylib/raylib.flan index 5b0bb55..a84dc2b 100644 --- a/vendor/raylib/raylib.flan +++ b/vendor/raylib/raylib.flan @@ -1,19 +1,35 @@ ;;;; raylib, declared for Flan. The directory is the package (plan.org, ;;;; Modules), and (import rl "vendor:raylib") qualifies all of it as rl/… ;;;; -;;;; Nothing here names a raylib symbol. Every `declare` names a wrapper in -;;;; shim.c, and that is the whole design decision: raylib passes Color by -;;;; value and returns Vector2 by value, and how a small aggregate is passed -;;;; differs between x86-64, arm64 and wasm32. Written in C, clang classifies -;;;; each one correctly per target for free; written in emit.ml it would be -;;;; three calling conventions to reimplement and then maintain forever. This -;;;; is "one narrow host ABI, implemented twice" (plan.org, Targets), and it -;;;; is why the checker rejects an aggregate in a `declare` signature at all. +;;;; Every binding here is one `declare-c` line naming raylib's own function +;;;; in raylib's own signature — Color by value, Vector2 returned by value — +;;;; and the compiler writes the C that flattens it. There is no shim.c in +;;;; this directory any more, and no hand-written wrapper at all. ;;;; -;;;; So each struct that crosses does it through a pointer, and the `-raw` -;;;; declaration is wrapped by an ordinary Flan function just below it. The -;;;; `-raw` names are visible as rl/…-raw because there is no visibility rule -;;;; yet; they are not meant to be called. +;;;; The shim itself did not go away, only the typing of it. A small +;;;; aggregate's calling convention is a per-target classification rather than +;;;; part of its layout: x86-64 hands Vector2 over as <2 x float> and returns +;;;; Rectangle as {i64,i64}, and arm64 and wasm32 each do something else. +;;;; Written in C, clang classifies every one of them correctly for whichever +;;;; target the build is for; written in emit.ml it would be three calling +;;;; conventions to reimplement and then keep correct forever, and a mistake +;;;; would read as a field full of garbage rather than as a link error. This +;;;; is "one narrow host ABI, implemented twice" (plan.org, Targets). See +;;;; lib/shim.ml. +;;;; +;;;; What that means for reading this file: the `defstruct`s below are the +;;;; only statement anywhere about raylib's layouts, and the generated C +;;;; typedefs are made from them. No raylib header is consulted — a build +;;;; needs libraylib linkable, not raylib-devel — so a wrong field order here +;;;; is wrong everywhere and nothing but a test can catch it. The acceptance +;;;; cases pin the layouts by making raylib *compute* with the fields, and +;;;; they go red when a struct below is permuted. Likewise a scalar's width: +;;;; f64 where raylib says float now emits `double` in the generated +;;;; prototype, and raylib reads garbage. +;;;; +;;;; Two bindings keep a hand-written Flan wrapper, both because their Flan +;;;; face is deliberately not raylib's: collision-point-poly? takes a slice, +;;;; and collision-lines answers with an Option. Both wrappers are Flan. ;; Layouts are C's — no object headers anywhere — so these are exactly ;; raylib's structs and nothing marshals. @@ -46,31 +62,27 @@ ;; ── Window ────────────────────────────────────────────────────────── -(declare init-window [width i32 height i32 title string] "flan_rl_init_window") -(declare close-window [] "flan_rl_close_window") -(declare window-should-close? [] bool "flan_rl_window_should_close") -(declare set-target-fps [fps i32] "flan_rl_set_target_fps") -(declare set-trace-log-level [level TraceLogLevel] "flan_rl_set_trace_log_level") +(declare-c init-window [width i32 height i32 title string] "InitWindow") +(declare-c close-window [] "CloseWindow") +(declare-c window-should-close? [] bool "WindowShouldClose") +(declare-c set-target-fps [fps i32] "SetTargetFPS") +(declare-c set-trace-log-level [level TraceLogLevel] "SetTraceLogLevel") ;; ── Input ─────────────────────────────────────────────────────────── -(declare key-pressed? [key Key] bool "flan_rl_is_key_pressed") -(declare key-down? [key Key] bool "flan_rl_is_key_down") -(declare key-released? [key Key] bool "flan_rl_is_key_released") +(declare-c key-pressed? [key Key] bool "IsKeyPressed") +(declare-c key-down? [key Key] bool "IsKeyDown") +(declare-c key-released? [key Key] bool "IsKeyReleased") -(declare mouse-button-pressed? [button MouseButton] bool - "flan_rl_is_mouse_button_pressed") -(declare mouse-button-down? [button MouseButton] bool - "flan_rl_is_mouse_button_down") -(declare mouse-button-released? [button MouseButton] bool - "flan_rl_is_mouse_button_released") +(declare-c mouse-button-pressed? + [button MouseButton] bool + "IsMouseButtonPressed") +(declare-c mouse-button-down? [button MouseButton] bool "IsMouseButtonDown") +(declare-c mouse-button-released? + [button MouseButton] bool + "IsMouseButtonReleased") -(declare get-mouse-position-raw [out (Ptr Vector2)] "flan_rl_get_mouse_position") - -(defn get-mouse-position [] Vector2 - (let [v (Vector2 {})] - (get-mouse-position-raw (addr v)) - v)) +(declare-c get-mouse-position [] Vector2 "GetMousePosition") ;; ── Colours ───────────────────────────────────────────────────────── ;; @@ -78,37 +90,22 @@ ;; reading of the packed 0xRRGGBBAA integer — that is why get-color is a real ;; call and not a reinterpretation. -(declare get-color-raw [hex u32 out (Ptr Color)] "flan_rl_get_color") - -(defn get-color [hex u32] Color - (let [c (Color {})] - (get-color-raw hex (addr c)) - c)) +(declare-c get-color [hex u32] Color "GetColor") (defconst black (Color {:r 0 :g 0 :b 0 :a 255})) (defconst white (Color {:r 255 :g 255 :b 255 :a 255})) ;; ── Drawing ───────────────────────────────────────────────────────── -(declare begin-drawing [] "flan_rl_begin_drawing") -(declare end-drawing [] "flan_rl_end_drawing") -(declare draw-fps [x i32 y i32] "flan_rl_draw_fps") +(declare-c begin-drawing [] "BeginDrawing") +(declare-c end-drawing [] "EndDrawing") +(declare-c draw-fps [x i32 y i32] "DrawFPS") -(declare clear-background-raw [color (Ptr Color)] "flan_rl_clear_background") +(declare-c clear-background [color Color] "ClearBackground") -(defn clear-background [color Color] - ;; The copy is not ceremony: a parameter is not an assignable place - ;; (spec-memory.md), so there is no address to take without one. - (let [c color] - (clear-background-raw (addr c)))) - -(declare draw-rectangle-raw - [x i32 y i32 width i32 height i32 color (Ptr Color)] - "flan_rl_draw_rectangle") - -(defn draw-rectangle [x i32 y i32 width i32 height i32 color Color] - (let [c color] - (draw-rectangle-raw x y width height (addr c)))) +(declare-c draw-rectangle + [x i32 y i32 width i32 height i32 color Color] + "DrawRectangle") ;; ── Shapes texture ────────────────────────────────────────────────── ;; @@ -122,29 +119,15 @@ ;; source's width or height is not positive, so a caller — and the test — ;; should keep clear of those values if it wants its own back. -(declare set-shapes-texture-raw - [texture (Ptr Texture2D) source (Ptr Rectangle)] - "flan_rl_set_shapes_texture") +(declare-c set-shapes-texture + [texture Texture2D source Rectangle] + "SetShapesTexture") -(defn set-shapes-texture [texture Texture2D source Rectangle] - (let [t texture - r source] - (set-shapes-texture-raw (addr t) (addr r)))) +(declare-c get-shapes-texture [] Texture2D "GetShapesTexture") -(declare get-shapes-texture-raw [out (Ptr Texture2D)] "flan_rl_get_shapes_texture") - -(defn get-shapes-texture [] Texture2D - (let [t (Texture2D {})] - (get-shapes-texture-raw (addr t)) - t)) - -(declare get-shapes-texture-rectangle-raw - [out (Ptr Rectangle)] "flan_rl_get_shapes_texture_rectangle") - -(defn get-shapes-texture-rectangle [] Rectangle - (let [r (Rectangle {})] - (get-shapes-texture-rectangle-raw (addr r)) - r)) +(declare-c get-shapes-texture-rectangle + [] Rectangle + "GetShapesTextureRectangle") ;; ── Camera2D ──────────────────────────────────────────────────────── ;; @@ -160,13 +143,9 @@ (defstruct Camera2D [offset Vector2 target Vector2 rotation f32 zoom f32]) -(declare begin-mode-2d-raw [camera (Ptr Camera2D)] "flan_rl_begin_mode_2d") +(declare-c begin-mode-2d [camera Camera2D] "BeginMode2D") -(defn begin-mode-2d [camera Camera2D] - (let [c camera] - (begin-mode-2d-raw (addr c)))) - -(declare end-mode-2d [] "flan_rl_end_mode_2d") +(declare-c end-mode-2d [] "EndMode2D") ;; The two conversions are pure arithmetic over every field of the camera, so ;; unlike the rest of the camera they run with no window and no GL context. @@ -174,27 +153,13 @@ ;; a rotated camera, which is the only call here that mixes x into y — it is ;; also the only thing that pins Vector2's two fields against each other. -(declare get-screen-to-world-2d-raw - [position (Ptr Vector2) camera (Ptr Camera2D) out (Ptr Vector2)] - "flan_rl_get_screen_to_world_2d") +(declare-c get-screen-to-world-2d + [position Vector2 camera Camera2D] Vector2 + "GetScreenToWorld2D") -(defn get-screen-to-world-2d [position Vector2 camera Camera2D] Vector2 - (let [p position - c camera - out (Vector2 {})] - (get-screen-to-world-2d-raw (addr p) (addr c) (addr out)) - out)) - -(declare get-world-to-screen-2d-raw - [position (Ptr Vector2) camera (Ptr Camera2D) out (Ptr Vector2)] - "flan_rl_get_world_to_screen_2d") - -(defn get-world-to-screen-2d [position Vector2 camera Camera2D] Vector2 - (let [p position - c camera - out (Vector2 {})] - (get-world-to-screen-2d-raw (addr p) (addr c) (addr out)) - out)) +(declare-c get-world-to-screen-2d + [position Vector2 camera Camera2D] Vector2 + "GetWorldToScreen2D") ;; ── Shapes ────────────────────────────────────────────────────────── ;; @@ -203,16 +168,9 @@ ;; also how the acceptance table pins the layout: a store-and-return check is ;; symmetric and a permuted layout survives it untouched. -(declare get-collision-rec-raw - [a (Ptr Rectangle) b (Ptr Rectangle) out (Ptr Rectangle)] - "flan_rl_get_collision_rec") - -(defn get-collision-rec [a Rectangle b Rectangle] Rectangle - (let [x a - y b - out (Rectangle {})] - (get-collision-rec-raw (addr x) (addr y) (addr out)) - out)) +(declare-c get-collision-rec + [a Rectangle b Rectangle] Rectangle + "GetCollisionRec") ;; ── Collision ─────────────────────────────────────────────────────── ;; @@ -220,103 +178,75 @@ ;; makes them the other half of what the acceptance table can assert, and the ;; only part of the 2D surface that is tested as thoroughly as it is bound. ;; -;; Each takes its aggregates through pointers for the usual reason, and each -;; wrapper copies its parameters into locals first — a parameter is not an -;; assignable place (spec-memory.md), so there is no address to take. +;; Each is declared exactly as raylib declares it. The pointers and the copies +;; the crossing needs — a parameter is not an assignable place +;; (spec-memory.md), so a struct argument has no address to take without one — +;; are in the generated halves and not here. -(declare collision-recs?-raw [a (Ptr Rectangle) b (Ptr Rectangle)] bool - "flan_rl_check_collision_recs") +(declare-c collision-recs? + [a Rectangle b Rectangle] bool + "CheckCollisionRecs") -(defn collision-recs? [a Rectangle b Rectangle] bool - (let [x a y b] - (collision-recs?-raw (addr x) (addr y)))) +(declare-c collision-circles? + [c1 Vector2 r1 f32 c2 Vector2 r2 f32] bool + "CheckCollisionCircles") -(declare collision-circles?-raw - [c1 (Ptr Vector2) r1 f32 c2 (Ptr Vector2) r2 f32] bool - "flan_rl_check_collision_circles") +(declare-c collision-circle-rec? + [center Vector2 radius f32 rec Rectangle] bool + "CheckCollisionCircleRec") -(defn collision-circles? [c1 Vector2 r1 f32 c2 Vector2 r2 f32] bool - (let [a c1 b c2] - (collision-circles?-raw (addr a) r1 (addr b) r2))) +(declare-c collision-circle-line? [center Vector2 radius f32 + p1 Vector2 p2 Vector2] bool "CheckCollisionCircleLine") -(declare collision-circle-rec?-raw - [center (Ptr Vector2) radius f32 rec (Ptr Rectangle)] bool - "flan_rl_check_collision_circle_rec") +(declare-c collision-point-rec? + [point Vector2 rec Rectangle] bool + "CheckCollisionPointRec") -(defn collision-circle-rec? [center Vector2 radius f32 rec Rectangle] bool - (let [c center r rec] - (collision-circle-rec?-raw (addr c) radius (addr r)))) +(declare-c collision-point-circle? + [point Vector2 center Vector2 radius f32] bool + "CheckCollisionPointCircle") -(declare collision-circle-line?-raw - [center (Ptr Vector2) radius f32 p1 (Ptr Vector2) p2 (Ptr Vector2)] bool - "flan_rl_check_collision_circle_line") - -(defn collision-circle-line? [center Vector2 radius f32 - p1 Vector2 p2 Vector2] bool - (let [c center a p1 b p2] - (collision-circle-line?-raw (addr c) radius (addr a) (addr b)))) - -(declare collision-point-rec?-raw [point (Ptr Vector2) rec (Ptr Rectangle)] bool - "flan_rl_check_collision_point_rec") - -(defn collision-point-rec? [point Vector2 rec Rectangle] bool - (let [p point r rec] - (collision-point-rec?-raw (addr p) (addr r)))) - -(declare collision-point-circle?-raw - [point (Ptr Vector2) center (Ptr Vector2) radius f32] bool - "flan_rl_check_collision_point_circle") - -(defn collision-point-circle? [point Vector2 center Vector2 radius f32] bool - (let [p point c center] - (collision-point-circle?-raw (addr p) (addr c) radius))) - -(declare collision-point-triangle?-raw - [point (Ptr Vector2) a (Ptr Vector2) b (Ptr Vector2) c (Ptr Vector2)] bool - "flan_rl_check_collision_point_triangle") - -(defn collision-point-triangle? [point Vector2 a Vector2 b Vector2 - c Vector2] bool - (let [p point x a y b z c] - (collision-point-triangle?-raw (addr p) (addr x) (addr y) (addr z)))) +(declare-c collision-point-triangle? [point Vector2 a Vector2 b Vector2 + c Vector2] bool "CheckCollisionPointTriangle") ;; `threshold` is in pixels, and it is not optional in practice: raylib's test ;; is a distance comparison in floats, so a point exactly on the line fails at ;; a threshold of 0. 1 is the useful smallest value. -(declare collision-point-line?-raw - [point (Ptr Vector2) p1 (Ptr Vector2) p2 (Ptr Vector2) threshold i32] bool - "flan_rl_check_collision_point_line") +(declare-c collision-point-line? [point Vector2 p1 Vector2 p2 Vector2 + threshold i32] bool "CheckCollisionPointLine") -(defn collision-point-line? [point Vector2 p1 Vector2 p2 Vector2 - threshold i32] bool - (let [p point a p1 b p2] - (collision-point-line?-raw (addr p) (addr a) (addr b) threshold))) - -;; A slice crosses as ptr+len, which is exactly what raylib wants here, so -;; this is the one collision call that needs no per-element copying. The -;; polygon is not closed explicitly — raylib joins the last point to the -;; first. -(declare collision-point-poly?-raw [point (Ptr Vector2) points [Vector2]] bool - "flan_rl_check_collision_point_poly") +;; The one binding whose Flan face is not raylib's, and one of only two in +;; this file with a hand-written wrapper on top. A Flan slice crosses as +;; ptr+len with an i64 length; raylib wants a pointer and an `int` count, and +;; the generator refuses to guess what integer type a C count parameter is — +;; so the declaration says (Ptr Vector2) and a count, and the wrapper takes +;; the slice apart. The polygon is not closed explicitly; raylib joins the +;; last point to the first. +;; +;; Empty is answered here rather than passed on: (at points 0) would be an +;; out-of-bounds read, and raylib answers false for a polygon with no points +;; anyway. +(declare-c collision-point-poly?-raw + [point Vector2 points (Ptr Vector2) count i32] bool + "CheckCollisionPointPoly") (defn collision-point-poly? [point Vector2 points [Vector2]] bool - (let [p point] - (collision-point-poly?-raw (addr p) points))) + (if (= (len points) 0) + false + (collision-point-poly?-raw point (addr (at points 0)) (len points)))) ;; The one that answers with more than yes or no: where the two segments meet. ;; None is "they do not", so the point cannot be read when there isn't one — ;; raylib's own signature leaves the out-parameter untouched in that case and ;; a caller that forgets reads whatever was there. -(declare collision-lines-raw - [a1 (Ptr Vector2) a2 (Ptr Vector2) b1 (Ptr Vector2) b2 (Ptr Vector2) - out (Ptr Vector2)] bool - "flan_rl_check_collision_lines") +(declare-c collision-lines-raw + [a1 Vector2 a2 Vector2 b1 Vector2 b2 Vector2 out (Ptr Vector2)] bool + "CheckCollisionLines") (defn collision-lines [a1 Vector2 a2 Vector2 b1 Vector2 b2 Vector2] (Option Vector2) - (let [p a1 q a2 r b1 s b2 - out (Vector2 {})] - (if (collision-lines-raw (addr p) (addr q) (addr r) (addr s) (addr out)) + (let [out (Vector2 {})] + (if (collision-lines-raw a1 a2 b1 b2 (addr out)) (Some out) None))) @@ -328,70 +258,27 @@ ;; only in the log; raylib 5.5 spells it IsTextureValid, and IsTextureReady, ;; which older code calls, does not exist in this version. -(declare load-texture-raw [path string out (Ptr Texture2D)] "flan_rl_load_texture") +(declare-c load-texture [path string] Texture2D "LoadTexture") -(defn load-texture [path string] Texture2D - (let [t (Texture2D {})] - (load-texture-raw path (addr t)) - t)) +(declare-c texture-valid? [texture Texture2D] bool "IsTextureValid") -(declare texture-valid?-raw [texture (Ptr Texture2D)] bool "flan_rl_is_texture_valid") +(declare-c unload-texture [texture Texture2D] "UnloadTexture") -(defn texture-valid? [texture Texture2D] bool - (let [t texture] - (texture-valid?-raw (addr t)))) +(declare-c draw-texture + [texture Texture2D x i32 y i32 tint Color] + "DrawTexture") -(declare unload-texture-raw [texture (Ptr Texture2D)] "flan_rl_unload_texture") +(declare-c draw-texture-v + [texture Texture2D position Vector2 tint Color] + "DrawTextureV") -(defn unload-texture [texture Texture2D] - (let [t texture] - (unload-texture-raw (addr t)))) - -(declare draw-texture-raw - [texture (Ptr Texture2D) x i32 y i32 tint (Ptr Color)] - "flan_rl_draw_texture") - -(defn draw-texture [texture Texture2D x i32 y i32 tint Color] - (let [t texture - c tint] - (draw-texture-raw (addr t) x y (addr c)))) - -(declare draw-texture-v-raw - [texture (Ptr Texture2D) position (Ptr Vector2) tint (Ptr Color)] - "flan_rl_draw_texture_v") - -(defn draw-texture-v [texture Texture2D position Vector2 tint Color] - (let [t texture - p position - c tint] - (draw-texture-v-raw (addr t) (addr p) (addr c)))) - -(declare draw-texture-ex-raw - [texture (Ptr Texture2D) position (Ptr Vector2) rotation f32 scale f32 - tint (Ptr Color)] - "flan_rl_draw_texture_ex") - -(defn draw-texture-ex [texture Texture2D position Vector2 rotation f32 - scale f32 tint Color] - (let [t texture - p position - c tint] - (draw-texture-ex-raw (addr t) (addr p) rotation scale (addr c)))) +(declare-c draw-texture-ex [texture Texture2D position Vector2 rotation f32 + scale f32 tint Color] "DrawTextureEx") ;; A negative source width or height flips the sprite, which is how a sheet is ;; drawn facing the other way without a second image. -(declare draw-texture-rec-raw - [texture (Ptr Texture2D) source (Ptr Rectangle) position (Ptr Vector2) - tint (Ptr Color)] - "flan_rl_draw_texture_rec") - -(defn draw-texture-rec [texture Texture2D source Rectangle position Vector2 - tint Color] - (let [t texture - s source - p position - c tint] - (draw-texture-rec-raw (addr t) (addr s) (addr p) (addr c)))) +(declare-c draw-texture-rec [texture Texture2D source Rectangle position Vector2 + tint Color] "DrawTextureRec") ;; ── Images ────────────────────────────────────────────────────────── ;; @@ -410,101 +297,55 @@ ;; level too, so a caller can see which ones change what they are given. (defstruct Image [data (Ptr u8) width i32 height i32 mipmaps i32 format i32]) -(declare load-image-raw [path string out (Ptr Image)] "flan_rl_load_image") - -(defn load-image [path string] Image - (let [i (Image {})] - (load-image-raw path (addr i)) - i)) +(declare-c load-image [path string] Image "LoadImage") ;; raylib 5.5 spells this IsImageValid. IsImageReady, which older code calls, ;; does not exist here — the same rename that took IsTextureReady. -(declare image-valid?-raw [image (Ptr Image)] bool "flan_rl_is_image_valid") - -(defn image-valid? [image Image] bool - (let [i image] - (image-valid?-raw (addr i)))) +(declare-c image-valid? [image Image] bool "IsImageValid") ;; By value, as raylib has it. The caller's copy is dangling afterwards — ;; `data` pointed at the buffer this just freed — so an Image is used or ;; unloaded, never both. -(declare unload-image-raw [image (Ptr Image)] "flan_rl_unload_image") - -(defn unload-image [image Image] - (let [i image] - (unload-image-raw (addr i)))) +(declare-c unload-image [image Image] "UnloadImage") ;; The format is taken from the path's extension, so ".png" writes a PNG. ;; False means it could not be written. -(declare export-image-raw [image (Ptr Image) path string] bool - "flan_rl_export_image") +(declare-c export-image [image Image path string] bool "ExportImage") -(defn export-image [image Image path string] bool - (let [i image] - (export-image-raw (addr i) path))) - -(declare gen-image-color-raw - [width i32 height i32 color (Ptr Color) out (Ptr Image)] - "flan_rl_gen_image_color") - -(defn gen-image-color [width i32 height i32 color Color] Image - (let [c color - i (Image {})] - (gen-image-color-raw width height (addr c) (addr i)) - i)) +(declare-c gen-image-color + [width i32 height i32 color Color] Image + "GenImageColor") ;; Bicubic, so the pixels that come out are interpolated and only the new ;; width and height are exactly predictable. image-resize-nn is the ;; nearest-neighbour one, and it is the one to reach for when the colours ;; have to survive. -(declare image-resize [image (Ptr Image) width i32 height i32] - "flan_rl_image_resize") -(declare image-resize-nn [image (Ptr Image) width i32 height i32] - "flan_rl_image_resize_nn") +(declare-c image-resize + [image (Ptr Image) width i32 height i32] + "ImageResize") +(declare-c image-resize-nn + [image (Ptr Image) width i32 height i32] + "ImageResizeNN") -(declare image-crop-raw [image (Ptr Image) crop (Ptr Rectangle)] - "flan_rl_image_crop") +(declare-c image-crop [image (Ptr Image) crop Rectangle] "ImageCrop") -(defn image-crop [image (Ptr Image) crop Rectangle] - (let [r crop] - (image-crop-raw image (addr r)))) +(declare-c image-flip-horizontal [image (Ptr Image)] "ImageFlipHorizontal") +(declare-c image-flip-vertical [image (Ptr Image)] "ImageFlipVertical") -(declare image-flip-horizontal [image (Ptr Image)] - "flan_rl_image_flip_horizontal") -(declare image-flip-vertical [image (Ptr Image)] - "flan_rl_image_flip_vertical") - -(declare image-draw-pixel-raw - [image (Ptr Image) x i32 y i32 color (Ptr Color)] - "flan_rl_image_draw_pixel") - -(defn image-draw-pixel [image (Ptr Image) x i32 y i32 color Color] - (let [c color] - (image-draw-pixel-raw image x y (addr c)))) +(declare-c image-draw-pixel + [image (Ptr Image) x i32 y i32 color Color] + "ImageDrawPixel") ;; Out of bounds is not an error: raylib logs a warning and hands back a ;; transparent black, so a caller that is off by one gets zeroes rather than ;; somebody else's memory. -(declare get-image-color-raw - [image (Ptr Image) x i32 y i32 out (Ptr Color)] - "flan_rl_get_image_color") - -(defn get-image-color [image Image x i32 y i32] Color - (let [i image - c (Color {})] - (get-image-color-raw (addr i) x y (addr c)) - c)) +(declare-c get-image-color [image Image x i32 y i32] Color "GetImageColor") ;; The one call in this section that does need a GL context — it uploads. An ;; image loaded and edited on the CPU becomes something draw-texture can use. -(declare load-texture-from-image-raw [image (Ptr Image) out (Ptr Texture2D)] - "flan_rl_load_texture_from_image") - -(defn load-texture-from-image [image Image] Texture2D - (let [i image - t (Texture2D {})] - (load-texture-from-image-raw (addr i) (addr t)) - t)) +(declare-c load-texture-from-image + [image Image] Texture2D + "LoadTextureFromImage") ;; ── Shapes ────────────────────────────────────────────────────────── ;; @@ -522,185 +363,92 @@ ;; and draws nonsense, so this was read off the library with nm rather than ;; remembered. -(declare draw-pixel-raw [x i32 y i32 color (Ptr Color)] "flan_rl_draw_pixel") +(declare-c draw-pixel [x i32 y i32 color Color] "DrawPixel") -(defn draw-pixel [x i32 y i32 color Color] - (let [c color] (draw-pixel-raw x y (addr c)))) +(declare-c draw-pixel-v [position Vector2 color Color] "DrawPixelV") -(declare draw-pixel-v-raw [position (Ptr Vector2) color (Ptr Color)] - "flan_rl_draw_pixel_v") +(declare-c draw-line [x1 i32 y1 i32 x2 i32 y2 i32 color Color] "DrawLine") -(defn draw-pixel-v [position Vector2 color Color] - (let [p position c color] (draw-pixel-v-raw (addr p) (addr c)))) - -(declare draw-line-raw [x1 i32 y1 i32 x2 i32 y2 i32 color (Ptr Color)] - "flan_rl_draw_line") - -(defn draw-line [x1 i32 y1 i32 x2 i32 y2 i32 color Color] - (let [c color] (draw-line-raw x1 y1 x2 y2 (addr c)))) - -(declare draw-line-v-raw - [start (Ptr Vector2) end (Ptr Vector2) color (Ptr Color)] - "flan_rl_draw_line_v") - -(defn draw-line-v [start Vector2 end Vector2 color Color] - (let [a start b end c color] (draw-line-v-raw (addr a) (addr b) (addr c)))) +(declare-c draw-line-v [start Vector2 end Vector2 color Color] "DrawLineV") ;; The thick one is built from triangles rather than GL lines, which is why it ;; is a separate call and not a parameter on the one above. -(declare draw-line-ex-raw - [start (Ptr Vector2) end (Ptr Vector2) thick f32 color (Ptr Color)] - "flan_rl_draw_line_ex") +(declare-c draw-line-ex + [start Vector2 end Vector2 thick f32 color Color] + "DrawLineEx") -(defn draw-line-ex [start Vector2 end Vector2 thick f32 color Color] - (let [a start b end c color] - (draw-line-ex-raw (addr a) (addr b) thick (addr c)))) +(declare-c draw-circle [x i32 y i32 radius f32 color Color] "DrawCircle") -(declare draw-circle-raw [x i32 y i32 radius f32 color (Ptr Color)] - "flan_rl_draw_circle") +(declare-c draw-circle-v + [center Vector2 radius f32 color Color] + "DrawCircleV") -(defn draw-circle [x i32 y i32 radius f32 color Color] - (let [c color] (draw-circle-raw x y radius (addr c)))) +(declare-c draw-circle-lines + [x i32 y i32 radius f32 color Color] + "DrawCircleLines") -(declare draw-circle-v-raw - [center (Ptr Vector2) radius f32 color (Ptr Color)] "flan_rl_draw_circle_v") - -(defn draw-circle-v [center Vector2 radius f32 color Color] - (let [p center c color] (draw-circle-v-raw (addr p) radius (addr c)))) - -(declare draw-circle-lines-raw [x i32 y i32 radius f32 color (Ptr Color)] - "flan_rl_draw_circle_lines") - -(defn draw-circle-lines [x i32 y i32 radius f32 color Color] - (let [c color] (draw-circle-lines-raw x y radius (addr c)))) - -(declare draw-circle-lines-v-raw - [center (Ptr Vector2) radius f32 color (Ptr Color)] - "flan_rl_draw_circle_lines_v") - -(defn draw-circle-lines-v [center Vector2 radius f32 color Color] - (let [p center c color] (draw-circle-lines-v-raw (addr p) radius (addr c)))) +(declare-c draw-circle-lines-v + [center Vector2 radius f32 color Color] + "DrawCircleLinesV") ;; Two radii, horizontal then vertical. Equal radii is a circle, so a wrapper ;; that exchanged them would be invisible unless they differ — which is why ;; sand.flan's ellipse is deliberately wider than it is tall. -(declare draw-ellipse-raw - [x i32 y i32 radius-h f32 radius-v f32 color (Ptr Color)] - "flan_rl_draw_ellipse") +(declare-c draw-ellipse + [x i32 y i32 radius-h f32 radius-v f32 color Color] + "DrawEllipse") -(defn draw-ellipse [x i32 y i32 radius-h f32 radius-v f32 color Color] - (let [c color] (draw-ellipse-raw x y radius-h radius-v (addr c)))) - -(declare draw-ellipse-lines-raw - [x i32 y i32 radius-h f32 radius-v f32 color (Ptr Color)] - "flan_rl_draw_ellipse_lines") - -(defn draw-ellipse-lines [x i32 y i32 radius-h f32 radius-v f32 color Color] - (let [c color] (draw-ellipse-lines-raw x y radius-h radius-v (addr c)))) +(declare-c draw-ellipse-lines + [x i32 y i32 radius-h f32 radius-v f32 color Color] + "DrawEllipseLines") ;; Angles are degrees, clockwise from the +x axis, and `segments` is how many ;; straight pieces the arc is made of — 0 lets raylib pick from the radius. -(declare draw-ring-raw - [center (Ptr Vector2) inner f32 outer f32 start f32 end f32 - segments i32 color (Ptr Color)] - "flan_rl_draw_ring") +(declare-c draw-ring [center Vector2 inner f32 outer f32 start f32 end f32 + segments i32 color Color] "DrawRing") -(defn draw-ring [center Vector2 inner f32 outer f32 start f32 end f32 - segments i32 color Color] - (let [p center c color] - (draw-ring-raw (addr p) inner outer start end segments (addr c)))) - -(declare draw-ring-lines-raw - [center (Ptr Vector2) inner f32 outer f32 start f32 end f32 - segments i32 color (Ptr Color)] - "flan_rl_draw_ring_lines") - -(defn draw-ring-lines [center Vector2 inner f32 outer f32 start f32 end f32 - segments i32 color Color] - (let [p center c color] - (draw-ring-lines-raw (addr p) inner outer start end segments (addr c)))) +(declare-c draw-ring-lines [center Vector2 inner f32 outer f32 start f32 end f32 + segments i32 color Color] "DrawRingLines") ;; Counter-clockwise, and raylib means it: the clockwise winding is culled and ;; draws nothing at all, which looks exactly like a broken binding. -(declare draw-triangle-raw - [v1 (Ptr Vector2) v2 (Ptr Vector2) v3 (Ptr Vector2) color (Ptr Color)] - "flan_rl_draw_triangle") +(declare-c draw-triangle + [v1 Vector2 v2 Vector2 v3 Vector2 color Color] + "DrawTriangle") -(defn draw-triangle [v1 Vector2 v2 Vector2 v3 Vector2 color Color] - (let [a v1 b v2 d v3 c color] - (draw-triangle-raw (addr a) (addr b) (addr d) (addr c)))) +(declare-c draw-triangle-lines + [v1 Vector2 v2 Vector2 v3 Vector2 color Color] + "DrawTriangleLines") -(declare draw-triangle-lines-raw - [v1 (Ptr Vector2) v2 (Ptr Vector2) v3 (Ptr Vector2) color (Ptr Color)] - "flan_rl_draw_triangle_lines") +(declare-c draw-rectangle-v + [position Vector2 size Vector2 color Color] + "DrawRectangleV") -(defn draw-triangle-lines [v1 Vector2 v2 Vector2 v3 Vector2 color Color] - (let [a v1 b v2 d v3 c color] - (draw-triangle-lines-raw (addr a) (addr b) (addr d) (addr c)))) +(declare-c draw-rectangle-rec [rec Rectangle color Color] "DrawRectangleRec") -(declare draw-rectangle-v-raw - [position (Ptr Vector2) size (Ptr Vector2) color (Ptr Color)] - "flan_rl_draw_rectangle_v") - -(defn draw-rectangle-v [position Vector2 size Vector2 color Color] - (let [p position s size c color] - (draw-rectangle-v-raw (addr p) (addr s) (addr c)))) - -(declare draw-rectangle-rec-raw [rec (Ptr Rectangle) color (Ptr Color)] - "flan_rl_draw_rectangle_rec") - -(defn draw-rectangle-rec [rec Rectangle color Color] - (let [r rec c color] (draw-rectangle-rec-raw (addr r) (addr c)))) - -(declare draw-rectangle-lines-raw - [x i32 y i32 width i32 height i32 color (Ptr Color)] - "flan_rl_draw_rectangle_lines") - -(defn draw-rectangle-lines [x i32 y i32 width i32 height i32 color Color] - (let [c color] (draw-rectangle-lines-raw x y width height (addr c)))) +(declare-c draw-rectangle-lines + [x i32 y i32 width i32 height i32 color Color] + "DrawRectangleLines") ;; The one-pixel outline above is drawn with GL lines and sits *on* the ;; rectangle's edge; this one is drawn with quads and sits inside it, so the ;; two do not agree at thickness 1 and that is raylib's doing, not a bug here. -(declare draw-rectangle-lines-ex-raw - [rec (Ptr Rectangle) thick f32 color (Ptr Color)] - "flan_rl_draw_rectangle_lines_ex") - -(defn draw-rectangle-lines-ex [rec Rectangle thick f32 color Color] - (let [r rec c color] (draw-rectangle-lines-ex-raw (addr r) thick (addr c)))) +(declare-c draw-rectangle-lines-ex + [rec Rectangle thick f32 color Color] + "DrawRectangleLinesEx") ;; `roundness` is 0 to 1 as a fraction of the shorter side, so 0 is a plain ;; rectangle and 1 is a stadium. -(declare draw-rectangle-rounded-raw - [rec (Ptr Rectangle) roundness f32 segments i32 color (Ptr Color)] - "flan_rl_draw_rectangle_rounded") - -(defn draw-rectangle-rounded [rec Rectangle roundness f32 segments i32 - color Color] - (let [r rec c color] - (draw-rectangle-rounded-raw (addr r) roundness segments (addr c)))) +(declare-c draw-rectangle-rounded [rec Rectangle roundness f32 segments i32 + color Color] "DrawRectangleRounded") ;; No thickness here — see the section note. The `-ex` form below is the one ;; that takes it. -(declare draw-rectangle-rounded-lines-raw - [rec (Ptr Rectangle) roundness f32 segments i32 color (Ptr Color)] - "flan_rl_draw_rectangle_rounded_lines") +(declare-c draw-rectangle-rounded-lines [rec Rectangle roundness f32 segments i32 + color Color] "DrawRectangleRoundedLines") -(defn draw-rectangle-rounded-lines [rec Rectangle roundness f32 segments i32 - color Color] - (let [r rec c color] - (draw-rectangle-rounded-lines-raw (addr r) roundness segments (addr c)))) - -(declare draw-rectangle-rounded-lines-ex-raw - [rec (Ptr Rectangle) roundness f32 segments i32 thick f32 - color (Ptr Color)] - "flan_rl_draw_rectangle_rounded_lines_ex") - -(defn draw-rectangle-rounded-lines-ex [rec Rectangle roundness f32 - segments i32 thick f32 color Color] - (let [r rec c color] - (draw-rectangle-rounded-lines-ex-raw (addr r) roundness segments thick - (addr c)))) +(declare-c draw-rectangle-rounded-lines-ex [rec Rectangle roundness f32 + segments i32 thick f32 color Color] "DrawRectangleRoundedLinesEx") ;; ── Text ──────────────────────────────────────────────────────────── ;; @@ -718,14 +466,11 @@ ;; load-font, load-font-ex, unload-font, get-font-default, draw-text-ex and ;; measure-text-ex are all absent rather than half-done. -(declare draw-text-raw - [text string x i32 y i32 font-size i32 color (Ptr Color)] - "flan_rl_draw_text") +(declare-c draw-text + [text string x i32 y i32 font-size i32 color Color] + "DrawText") -(defn draw-text [text string x i32 y i32 font-size i32 color Color] - (let [c color] (draw-text-raw text x y font-size (addr c)))) - -(declare measure-text [text string font-size i32] i32 "flan_rl_measure_text") +(declare-c measure-text [text string font-size i32] i32 "MeasureText") ;; ── Timing and window state ───────────────────────────────────────── ;; @@ -734,7 +479,7 @@ ;; delta the last frame took, in seconds, which is what a simulation should ;; scale by instead of assuming the target fps was met. -(declare get-frame-time [] f32 "flan_rl_get_frame_time") -(declare get-time [] f64 "flan_rl_get_time") -(declare get-screen-width [] i32 "flan_rl_get_screen_width") -(declare get-screen-height [] i32 "flan_rl_get_screen_height") +(declare-c get-frame-time [] f32 "GetFrameTime") +(declare-c get-time [] f64 "GetTime") +(declare-c get-screen-width [] i32 "GetScreenWidth") +(declare-c get-screen-height [] i32 "GetScreenHeight") diff --git a/vendor/raylib/shim.c b/vendor/raylib/shim.c deleted file mode 100644 index b9f9e1e..0000000 --- a/vendor/raylib/shim.c +++ /dev/null @@ -1,476 +0,0 @@ -/* The C half of the raylib binding: one wrapper per `declare` in raylib.flan. - * - * The wrappers exist so that no aggregate is ever passed or returned across - * the Flan/C boundary. raylib takes Color by value and returns Vector2 by - * value, and a small aggregate is passed differently on x86-64 (<2 x float>, - * i32), on arm64, and on wasm32. Here, clang classifies each one correctly for - * whichever target the build is for; in the Flan backend it would be three - * conventions to reimplement. Everything below therefore trades in scalars and - * pointers only — see raylib.flan. - * - * raylib's own headers are not needed and not used: these prototypes are the - * declarations, so the build has no dependency on raylib-devel being - * installed, only on the shared library being linkable. - */ - -#include -#include -#include -#include - -typedef struct { float x, y; } Vector2; -typedef struct { unsigned char r, g, b, a; } Color; -typedef struct { unsigned int id; int width, height, mipmaps, format; } Texture2D; -typedef struct { float x, y, width, height; } Rectangle; -typedef struct { Vector2 offset, target; float rotation, zoom; } Camera2D; - -extern void InitWindow(int width, int height, const char *title); -extern void CloseWindow(void); -extern bool WindowShouldClose(void); -extern void SetTargetFPS(int fps); -extern void SetTraceLogLevel(int level); -extern bool IsKeyPressed(int key); -extern bool IsKeyDown(int key); -extern bool IsKeyReleased(int key); -extern bool IsMouseButtonPressed(int button); -extern bool IsMouseButtonDown(int button); -extern bool IsMouseButtonReleased(int button); -extern Vector2 GetMousePosition(void); -extern Color GetColor(unsigned int hex); -extern void BeginDrawing(void); -extern void EndDrawing(void); -extern void DrawFPS(int x, int y); -extern void ClearBackground(Color color); -extern void DrawRectangle(int x, int y, int width, int height, Color color); -extern void SetShapesTexture(Texture2D texture, Rectangle source); -extern Texture2D GetShapesTexture(void); -extern Rectangle GetShapesTextureRectangle(void); -extern Rectangle GetCollisionRec(Rectangle a, Rectangle b); -extern Texture2D LoadTexture(const char *fileName); -extern bool IsTextureValid(Texture2D texture); -extern void UnloadTexture(Texture2D texture); -extern void DrawTexture(Texture2D texture, int posX, int posY, Color tint); -extern void DrawTextureV(Texture2D texture, Vector2 position, Color tint); -extern void DrawTextureEx(Texture2D texture, Vector2 position, float rotation, - float scale, Color tint); -extern void DrawTextureRec(Texture2D texture, Rectangle source, - Vector2 position, Color tint); -extern void BeginMode2D(Camera2D camera); -extern void EndMode2D(void); -extern Vector2 GetScreenToWorld2D(Vector2 position, Camera2D camera); -extern Vector2 GetWorldToScreen2D(Vector2 position, Camera2D camera); -extern bool CheckCollisionRecs(Rectangle rec1, Rectangle rec2); -extern bool CheckCollisionCircles(Vector2 c1, float r1, Vector2 c2, float r2); -extern bool CheckCollisionCircleRec(Vector2 center, float radius, Rectangle rec); -extern bool CheckCollisionCircleLine(Vector2 center, float radius, - Vector2 p1, Vector2 p2); -extern bool CheckCollisionPointRec(Vector2 point, Rectangle rec); -extern bool CheckCollisionPointCircle(Vector2 point, Vector2 center, float radius); -extern bool CheckCollisionPointTriangle(Vector2 point, Vector2 p1, Vector2 p2, - Vector2 p3); -extern bool CheckCollisionPointLine(Vector2 point, Vector2 p1, Vector2 p2, - int threshold); -extern bool CheckCollisionPointPoly(Vector2 point, const Vector2 *points, - int pointCount); -extern bool CheckCollisionLines(Vector2 a1, Vector2 a2, Vector2 b1, Vector2 b2, - Vector2 *collisionPoint); - -/* A Flan string arrives as ptr+len and is not NUL-terminated, so a C API that - * wants a C string needs a copy. Two callers want one: the window title and a - * texture's file path. Each passes a buffer big enough for what it is — 256 - * for a title, PATH_MAX for a path — and truncating is better than reading - * past the end. A truncated path fails to open and LoadTexture returns an id - * of 0, which is what texture-valid? is for. */ -static const char *cstr(const char *p, long long n, char *buf, size_t cap) { - size_t k = (size_t)n < cap - 1 ? (size_t)n : cap - 1; - memcpy(buf, p, k); - buf[k] = '\0'; - return buf; -} - -void flan_rl_init_window(int width, int height, const char *title, long long n) { - char buf[256]; - InitWindow(width, height, cstr(title, n, buf, sizeof buf)); -} - -void flan_rl_close_window(void) { CloseWindow(); } -bool flan_rl_window_should_close(void) { return WindowShouldClose(); } -void flan_rl_set_target_fps(int fps) { SetTargetFPS(fps); } -void flan_rl_set_trace_log_level(int l) { SetTraceLogLevel(l); } - -bool flan_rl_is_key_pressed(int key) { return IsKeyPressed(key); } -bool flan_rl_is_key_down(int key) { return IsKeyDown(key); } -bool flan_rl_is_key_released(int key) { return IsKeyReleased(key); } - -bool flan_rl_is_mouse_button_pressed(int b) { return IsMouseButtonPressed(b); } -bool flan_rl_is_mouse_button_down(int b) { return IsMouseButtonDown(b); } -bool flan_rl_is_mouse_button_released(int b) { return IsMouseButtonReleased(b); } - -void flan_rl_get_mouse_position(Vector2 *out) { *out = GetMousePosition(); } - -void flan_rl_get_color(unsigned int hex, Color *out) { *out = GetColor(hex); } - -void flan_rl_begin_drawing(void) { BeginDrawing(); } -void flan_rl_end_drawing(void) { EndDrawing(); } -void flan_rl_draw_fps(int x, int y) { DrawFPS(x, y); } - -void flan_rl_clear_background(const Color *color) { ClearBackground(*color); } - -void flan_rl_draw_rectangle(int x, int y, int width, int height, - const Color *color) { - DrawRectangle(x, y, width, height, *color); -} - -void flan_rl_set_shapes_texture(const Texture2D *texture, const Rectangle *source) { - SetShapesTexture(*texture, *source); -} - -void flan_rl_get_shapes_texture(Texture2D *out) { *out = GetShapesTexture(); } - -void flan_rl_get_shapes_texture_rectangle(Rectangle *out) { - *out = GetShapesTextureRectangle(); -} - -void flan_rl_get_collision_rec(const Rectangle *a, const Rectangle *b, - Rectangle *out) { - *out = GetCollisionRec(*a, *b); -} - -void flan_rl_load_texture(const char *path, long long n, Texture2D *out) { - char buf[PATH_MAX]; - *out = LoadTexture(cstr(path, n, buf, sizeof buf)); -} - -bool flan_rl_is_texture_valid(const Texture2D *texture) { - return IsTextureValid(*texture); -} - -void flan_rl_unload_texture(const Texture2D *texture) { UnloadTexture(*texture); } - -void flan_rl_draw_texture(const Texture2D *texture, int x, int y, - const Color *tint) { - DrawTexture(*texture, x, y, *tint); -} - -void flan_rl_draw_texture_v(const Texture2D *texture, const Vector2 *position, - const Color *tint) { - DrawTextureV(*texture, *position, *tint); -} - -void flan_rl_draw_texture_ex(const Texture2D *texture, const Vector2 *position, - float rotation, float scale, const Color *tint) { - DrawTextureEx(*texture, *position, rotation, scale, *tint); -} - -void flan_rl_draw_texture_rec(const Texture2D *texture, const Rectangle *source, - const Vector2 *position, const Color *tint) { - DrawTextureRec(*texture, *source, *position, *tint); -} - -void flan_rl_begin_mode_2d(const Camera2D *camera) { BeginMode2D(*camera); } -void flan_rl_end_mode_2d(void) { EndMode2D(); } - -void flan_rl_get_screen_to_world_2d(const Vector2 *position, - const Camera2D *camera, Vector2 *out) { - *out = GetScreenToWorld2D(*position, *camera); -} - -void flan_rl_get_world_to_screen_2d(const Vector2 *position, - const Camera2D *camera, Vector2 *out) { - *out = GetWorldToScreen2D(*position, *camera); -} - -bool flan_rl_check_collision_recs(const Rectangle *a, const Rectangle *b) { - return CheckCollisionRecs(*a, *b); -} - -bool flan_rl_check_collision_circles(const Vector2 *c1, float r1, - const Vector2 *c2, float r2) { - return CheckCollisionCircles(*c1, r1, *c2, r2); -} - -bool flan_rl_check_collision_circle_rec(const Vector2 *center, float radius, - const Rectangle *rec) { - return CheckCollisionCircleRec(*center, radius, *rec); -} - -bool flan_rl_check_collision_circle_line(const Vector2 *center, float radius, - const Vector2 *p1, const Vector2 *p2) { - return CheckCollisionCircleLine(*center, radius, *p1, *p2); -} - -bool flan_rl_check_collision_point_rec(const Vector2 *point, const Rectangle *rec) { - return CheckCollisionPointRec(*point, *rec); -} - -bool flan_rl_check_collision_point_circle(const Vector2 *point, - const Vector2 *center, float radius) { - return CheckCollisionPointCircle(*point, *center, radius); -} - -bool flan_rl_check_collision_point_triangle(const Vector2 *point, const Vector2 *a, - const Vector2 *b, const Vector2 *c) { - return CheckCollisionPointTriangle(*point, *a, *b, *c); -} - -bool flan_rl_check_collision_point_line(const Vector2 *point, const Vector2 *p1, - const Vector2 *p2, int threshold) { - return CheckCollisionPointLine(*point, *p1, *p2, threshold); -} - -/* A Flan slice arrives as ptr+len, the same shape a string does. raylib wants - * an int count, and a polygon with more than INT_MAX points is not a thing - * that happens; the clamp is there so the conversion is not silent. */ -bool flan_rl_check_collision_point_poly(const Vector2 *point, - const Vector2 *points, long long n) { - if (n > INT_MAX) n = INT_MAX; - return CheckCollisionPointPoly(*point, points, (int)n); -} - -bool flan_rl_check_collision_lines(const Vector2 *a1, const Vector2 *a2, - const Vector2 *b1, const Vector2 *b2, - Vector2 *out) { - return CheckCollisionLines(*a1, *a2, *b1, *b2, out); -} - -/* ── Images ───────────────────────────────────────────────────────── - * - * An Image is pixels in RAM, so all of this runs with no window and no GL - * context — which is why it is the part of the package that a headless test - * can actually assert rather than merely link. `data` is the pixel buffer - * raylib owns; `format` is a PixelFormat enum and GenImageColor makes 7 - * (uncompressed R8G8B8A8). - * - * raylib 5.5 spells the predicate IsImageValid. IsImageReady, which the 5.1 - * header still had, is gone — checked with nm -D, not remembered. - */ -typedef struct { void *data; int width, height, mipmaps, format; } Image; - -extern Image LoadImage(const char *fileName); -extern bool IsImageValid(Image image); -extern void UnloadImage(Image image); -extern bool ExportImage(Image image, const char *fileName); -extern Image GenImageColor(int width, int height, Color color); -extern void ImageResize(Image *image, int newWidth, int newHeight); -extern void ImageResizeNN(Image *image, int newWidth, int newHeight); -extern void ImageCrop(Image *image, Rectangle crop); -extern void ImageFlipHorizontal(Image *image); -extern void ImageFlipVertical(Image *image); -extern void ImageDrawPixel(Image *dst, int posX, int posY, Color color); -extern Color GetImageColor(Image image, int x, int y); -extern Texture2D LoadTextureFromImage(Image image); - -void flan_rl_load_image(const char *path, long long n, Image *out) { - char buf[PATH_MAX]; - *out = LoadImage(cstr(path, n, buf, sizeof buf)); -} - -bool flan_rl_is_image_valid(const Image *image) { return IsImageValid(*image); } -void flan_rl_unload_image(const Image *image) { UnloadImage(*image); } - -bool flan_rl_export_image(const Image *image, const char *path, long long n) { - char buf[PATH_MAX]; - return ExportImage(*image, cstr(path, n, buf, sizeof buf)); -} - -void flan_rl_gen_image_color(int width, int height, const Color *color, - Image *out) { - *out = GenImageColor(width, height, *color); -} - -void flan_rl_image_resize(Image *image, int w, int h) { ImageResize(image, w, h); } -void flan_rl_image_resize_nn(Image *image, int w, int h) { ImageResizeNN(image, w, h); } - -void flan_rl_image_crop(Image *image, const Rectangle *crop) { - ImageCrop(image, *crop); -} - -void flan_rl_image_flip_horizontal(Image *image) { ImageFlipHorizontal(image); } -void flan_rl_image_flip_vertical(Image *image) { ImageFlipVertical(image); } - -void flan_rl_image_draw_pixel(Image *dst, int x, int y, const Color *color) { - ImageDrawPixel(dst, x, y, *color); -} - -void flan_rl_get_image_color(const Image *image, int x, int y, Color *out) { - *out = GetImageColor(*image, x, y); -} - -void flan_rl_load_texture_from_image(const Image *image, Texture2D *out) { - *out = LoadTextureFromImage(*image); -} - -/* ── Shapes, text and timing ───────────────────────────────────────── - * - * All of the drawing below needs a GL context and therefore a window, so none - * of it can be in the acceptance table — it is exercised by running sand.flan - * and looking. The three prototypes most likely to be remembered wrong were - * checked against nm -D on libraylib.so.550 rather than against a header: - * raylib 5.5 moved the line thickness off DrawRectangleRoundedLines onto - * DrawRectangleRoundedLinesEx, so the four-argument form here is the 5.5 one - * and not the 5.1 one. - * - * MeasureText, GetFrameTime, GetTime and GetScreenWidth/Height need no GL - * context but do need InitWindow: the first reads the default font, which - * only InitWindow loads, and the others read window state. Headless they all - * answer 0 — measured, not assumed — so they are no more assertable than the - * drawing is. - */ - -extern void DrawPixel(int posX, int posY, Color color); -extern void DrawPixelV(Vector2 position, Color color); -extern void DrawLine(int startPosX, int startPosY, int endPosX, int endPosY, - Color color); -extern void DrawLineV(Vector2 startPos, Vector2 endPos, Color color); -extern void DrawLineEx(Vector2 startPos, Vector2 endPos, float thick, Color color); -extern void DrawCircle(int centerX, int centerY, float radius, Color color); -extern void DrawCircleV(Vector2 center, float radius, Color color); -extern void DrawCircleLines(int centerX, int centerY, float radius, Color color); -extern void DrawCircleLinesV(Vector2 center, float radius, Color color); -extern void DrawEllipse(int centerX, int centerY, float radiusH, float radiusV, - Color color); -extern void DrawEllipseLines(int centerX, int centerY, float radiusH, - float radiusV, Color color); -extern void DrawRing(Vector2 center, float innerRadius, float outerRadius, - float startAngle, float endAngle, int segments, Color color); -extern void DrawRingLines(Vector2 center, float innerRadius, float outerRadius, - float startAngle, float endAngle, int segments, - Color color); -extern void DrawTriangle(Vector2 v1, Vector2 v2, Vector2 v3, Color color); -extern void DrawTriangleLines(Vector2 v1, Vector2 v2, Vector2 v3, Color color); -extern void DrawRectangleV(Vector2 position, Vector2 size, Color color); -extern void DrawRectangleRec(Rectangle rec, Color color); -extern void DrawRectangleLines(int posX, int posY, int width, int height, - Color color); -extern void DrawRectangleLinesEx(Rectangle rec, float lineThick, Color color); -extern void DrawRectangleRounded(Rectangle rec, float roundness, int segments, - Color color); -extern void DrawRectangleRoundedLines(Rectangle rec, float roundness, - int segments, Color color); -extern void DrawRectangleRoundedLinesEx(Rectangle rec, float roundness, - int segments, float lineThick, - Color color); -extern void DrawText(const char *text, int posX, int posY, int fontSize, - Color color); -extern int MeasureText(const char *text, int fontSize); -extern float GetFrameTime(void); -extern double GetTime(void); -extern int GetScreenWidth(void); -extern int GetScreenHeight(void); - -void flan_rl_draw_pixel(int x, int y, const Color *c) { DrawPixel(x, y, *c); } - -void flan_rl_draw_pixel_v(const Vector2 *p, const Color *c) { - DrawPixelV(*p, *c); -} - -void flan_rl_draw_line(int x1, int y1, int x2, int y2, const Color *c) { - DrawLine(x1, y1, x2, y2, *c); -} - -void flan_rl_draw_line_v(const Vector2 *a, const Vector2 *b, const Color *c) { - DrawLineV(*a, *b, *c); -} - -void flan_rl_draw_line_ex(const Vector2 *a, const Vector2 *b, float thick, - const Color *c) { - DrawLineEx(*a, *b, thick, *c); -} - -void flan_rl_draw_circle(int x, int y, float radius, const Color *c) { - DrawCircle(x, y, radius, *c); -} - -void flan_rl_draw_circle_v(const Vector2 *center, float radius, const Color *c) { - DrawCircleV(*center, radius, *c); -} - -void flan_rl_draw_circle_lines(int x, int y, float radius, const Color *c) { - DrawCircleLines(x, y, radius, *c); -} - -void flan_rl_draw_circle_lines_v(const Vector2 *center, float radius, - const Color *c) { - DrawCircleLinesV(*center, radius, *c); -} - -void flan_rl_draw_ellipse(int x, int y, float rh, float rv, const Color *c) { - DrawEllipse(x, y, rh, rv, *c); -} - -void flan_rl_draw_ellipse_lines(int x, int y, float rh, float rv, const Color *c) { - DrawEllipseLines(x, y, rh, rv, *c); -} - -void flan_rl_draw_ring(const Vector2 *center, float inner, float outer, - float start, float end, int segments, const Color *c) { - DrawRing(*center, inner, outer, start, end, segments, *c); -} - -void flan_rl_draw_ring_lines(const Vector2 *center, float inner, float outer, - float start, float end, int segments, - const Color *c) { - DrawRingLines(*center, inner, outer, start, end, segments, *c); -} - -void flan_rl_draw_triangle(const Vector2 *a, const Vector2 *b, const Vector2 *d, - const Color *c) { - DrawTriangle(*a, *b, *d, *c); -} - -void flan_rl_draw_triangle_lines(const Vector2 *a, const Vector2 *b, - const Vector2 *d, const Color *c) { - DrawTriangleLines(*a, *b, *d, *c); -} - -void flan_rl_draw_rectangle_v(const Vector2 *position, const Vector2 *size, - const Color *c) { - DrawRectangleV(*position, *size, *c); -} - -void flan_rl_draw_rectangle_rec(const Rectangle *rec, const Color *c) { - DrawRectangleRec(*rec, *c); -} - -void flan_rl_draw_rectangle_lines(int x, int y, int w, int h, const Color *c) { - DrawRectangleLines(x, y, w, h, *c); -} - -void flan_rl_draw_rectangle_lines_ex(const Rectangle *rec, float thick, - const Color *c) { - DrawRectangleLinesEx(*rec, thick, *c); -} - -void flan_rl_draw_rectangle_rounded(const Rectangle *rec, float roundness, - int segments, const Color *c) { - DrawRectangleRounded(*rec, roundness, segments, *c); -} - -/* Four arguments, not five: 5.5's DrawRectangleRoundedLines has no thickness - * and the Ex variant below is where it went. Getting this wrong links fine. */ -void flan_rl_draw_rectangle_rounded_lines(const Rectangle *rec, float roundness, - int segments, const Color *c) { - DrawRectangleRoundedLines(*rec, roundness, segments, *c); -} - -void flan_rl_draw_rectangle_rounded_lines_ex(const Rectangle *rec, - float roundness, int segments, - float thick, const Color *c) { - DrawRectangleRoundedLinesEx(*rec, roundness, segments, thick, *c); -} - -void flan_rl_draw_text(const char *text, long long n, int x, int y, - int font_size, const Color *c) { - char buf[512]; - DrawText(cstr(text, n, buf, sizeof buf), x, y, font_size, *c); -} - -int flan_rl_measure_text(const char *text, long long n, int font_size) { - char buf[512]; - return MeasureText(cstr(text, n, buf, sizeof buf), font_size); -} - -float flan_rl_get_frame_time(void) { return GetFrameTime(); } -double flan_rl_get_time(void) { return GetTime(); } -int flan_rl_get_screen_width(void) { return GetScreenWidth(); } -int flan_rl_get_screen_height(void) { return GetScreenHeight(); } From dbf5748c560542a45d3c8b7ac4f490d48181071e Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 11 Sep 2026 20:26:11 +0700 Subject: [PATCH 3/4] Assert the reasons, and say what a permutation proves MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Every refusal is by name with the reason, so the tests assert on the reasons and weakening one to a bare "cannot" breaks them: a slice, an Option, a union, a fixed array, a map, a returned string, a callback, an unknown type, a struct field C cannot hold, and two Flan names for one C symbol. The rest is text about text, which is the honest scope: what a wrapper does is settled by clang, and what is worth checking in OCaml is the shape of what clang is handed. Two cases assert the typedef's field order against a defstruct and against the same defstruct permuted, because only the pair rules out a generator that sorts — and sorting is exactly the mutation the raylib cases cannot see, since every raylib struct is fields of one size and a rename changes no offset. What the raylib cases do see is a permuted defstruct, and that was run: Rectangle width/height, Vector2 x/y, Image width/height, Image with data moved last, Texture2D id/format, Color r/a and Camera2D offset/target all go red. Texture2D width/mipmaps stays green, which is what NEXT.md already says headless cannot pin — the one green is the control, not a gap. --- NEXT.md | 96 +++++++++++++++++++++++---- test/test_acceptance.ml | 142 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 224 insertions(+), 14 deletions(-) diff --git a/NEXT.md b/NEXT.md index da43f24..fafe3e1 100644 --- a/NEXT.md +++ b/NEXT.md @@ -143,11 +143,12 @@ reader ✅ → parse ✅ → load ✅ → check ✅ → emit ✅ → clang ✅ | `lib/build.ml` | `.ll` + the shim + the packages' C → clang → executable | | `runtime/flan_rt.c` | the host ABI: argv, stdout, exit, 4 conversions | | `runtime/flan_dev.c` | **dev only: the by-name registry a run-time-new name needs** | -| `vendor/raylib/` | **the raylib package: `raylib.flan`, `shim.c`, `link`** | +| `lib/shim.ml` | **`declare-c` -> the generated C that flattens a struct crossing** | +| `vendor/raylib/` | **the raylib package: `raylib.flan` and `link`, and no C at all** | | `vendor/agent/` | **the dev agent: a socket, a loader thread, install at a frame boundary** | | `emacs/` | **`flan-mode.el`, `flan-dev.el`, `flan-repl.el`: the editor half of the dev loop** | | `sand-sim/` | **the falling-sand simulation, with no raylib in it** | -| `bin/main.ml` | `flan read \| parse \| check \| emit \| build \| run \| reload \| dev` | +| `bin/main.ml` | `flan read \| parse \| check \| emit \| shim \| build \| run \| reload \| dev` | | `test/test_flan.ml` | reader, parser and checker | | `test/test_acceptance.ml` | expression/result pairs + whole programs + the traps | | `test/test_reload.ml` | **the reload primitive: recompile one function, load it, call it** | @@ -226,7 +227,7 @@ Putting that in `emit.ml` is three classifiers to write and then keep correct forever, and a mistake shows up as `(.y m)` returning garbage rather than as a link error. -So `vendor/raylib/shim.c` has one wrapper per binding, each one flattening the +So the boundary has one wrapper per binding, each one flattening the aggregates: a struct returns through an out-pointer, a struct argument is passed by pointer, a Flan string crosses as ptr+len and the shim NUL-terminates a copy. clang classifies all of it, per target, for free. `check.ml` enforces @@ -234,11 +235,76 @@ the rule — an aggregate in a `declare` signature is rejected with the reason so the boundary cannot quietly acquire one. This is plan.org's "one narrow host ABI, implemented twice", and `flan_rt.c` is the same pattern. -The price is a hand-written wrapper per raylib call. They are one-liners and -mechanical enough to generate if that ever becomes the bottleneck. +### The wrappers are generated now — `declare-c`, `lib/shim.ml` -`raylib.flan` declares each `-raw` entry point and wraps it in an ordinary Flan -function just below, so the surface sand.flan sees is `(rl/get-mouse-position)` +The price above was a hand-written wrapper per raylib call, and the prediction +that they were mechanical enough to generate "if that ever becomes the +bottleneck" came true at 84 of them. `vendor/raylib/shim.c` is gone; the +directory holds `raylib.flan` and `link` and no C at all. + +One binding is now one line: + +``` +(declare-c draw-texture [t Texture2D x i32 y i32 tint Color] "DrawTexture") +``` + +`declare-c` names raylib's own function in raylib's own signature, and the +compiler emits, into a C file compiled like any other: the typedefs for the +structs involved, made from the Flan `defstruct`s; the `extern` prototype in +the function's true signature; the wrapper that flattens it; and the flattened +`declare` the Flan side calls, with an ordinary Flan `defn` above it when the +signature has a struct in it. `flan shim ` prints the whole file. + +**It is a second form and not a change to `declare`, for one reason worth +remembering:** `(declare start-raw [path string] i32 "flan_agent_start")` in +`vendor/agent` means the symbol takes ptr+len, and `(declare-c init-window [w +i32 h i32 title string] "InitWindow")` means it takes a NUL-terminated `char +*`. Same shape, opposite claims, so no structural rule can separate them. +`declare` is untouched, and `sqrtf` and the agent still work unedited. + +**What the generator guarantees, and what it trusts.** Guaranteed: the C +typedef and the Flan struct come from the same `defstruct`, so they cannot +disagree — permute the `defstruct` and the typedef permutes with it, which is +exactly what makes the permutation runs below meaningful. And clang +type-checks the wrapper against the generated prototype. Trusted: 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 `_Static_assert` on `sizeof`/`offsetof` was +considered and rejected as circular: both sides would come from the same field +list. + +**One thing got sharper and should be said plainly:** the prototype is now +generated *from the declaration*, so a scalar's width carries ABI weight it did +not before. `f64` where raylib says `float` used to be narrowed by clang at the +hand-written call site; now it emits `double` and raylib reads garbage. All 84 +migrated prototypes were diffed against the deleted `shim.c`'s — which was the +ground truth for the true signatures — and agree. + +**Strings.** The hand-written wrappers sized the NUL-copy per call site: 256 +for a window title, `PATH_MAX` for a path, 512 for drawn text, truncating past +it. A generator has no call site to look at, so it must not be the thing +deciding a string is too long: 256 bytes on the stack, the heap past that, +freed after the call. The only truncation left is on malloc failure, where the +alternative is handing C a null pointer. + +**Two bindings keep a hand-written wrapper, and both wrappers are Flan, not C.** +`collision-point-poly?` takes a slice and `collision-lines` answers with an +`Option`; neither is raylib's own signature. A slice parameter in a `declare-c` +is refused by name, because a slice's length crosses as i64 and the type of the +C count parameter beside the pointer is not recoverable from `[T]` — so that +one declares `(Ptr Vector2)` with an explicit `count i32` and the Flan wrapper +passes `(addr (at points 0))` and `(len points)`. Every other refusal — an +Option, a union, a fixed array, a map, a returned string, a callback, an +unknown type, an unrepresentable struct field, two Flan names for one C symbol +— is by name with the reason, and the acceptance table asserts on the reasons. + +**Known edge, not fixed:** a REPL redefinition that introduces a *new* +`declare-c` cannot work. `Build.shared` is llc + `ld -shared` and compiles no +C, so the wrapper would not exist in the running process. Editing the body of a +function that calls an existing binding is unaffected. + +`raylib.flan` carries the nice signature and the compiler writes the rest, so +the surface sand.flan sees is `(rl/get-mouse-position)` returning a `Vector2`. Verified end to end, headless: `GetColor(0x11223344)` comes back as `17 34 51 68`, four separate bytes — a `Color` is *not* the little-endian reading of the packed integer, so an identity would have passed a @@ -255,8 +321,9 @@ The bindings are 29 calls: window (`init-window`, `close-window`, texture and rectangle intersection (`set-shapes-texture`, `get-shapes-texture`, `get-shapes-texture-rectangle`, `get-collision-rec`), plus the `Key`, `MouseButton` and `TraceLogLevel` enums and the `Vector2`, -`Color`, `Texture2D` and `Rectangle` structs. Adding one is three lines: a -`declare`, an `extern` prototype, and a one-line wrapper. +`Color`, `Texture2D` and `Rectangle` structs. Adding one was three lines — a +`declare`, an `extern` prototype and a one-line wrapper — and is now one +`declare-c`. The texture calls are the first ones with no headless test, because loading one needs a GL context. What the acceptance case does instead is pin the two @@ -269,8 +336,9 @@ comes back permuted the same way and the case passes. `width`, `height` and `mipmaps` are therefore checked only by looking at `sand.flan` running, which draws the brush sprite four ways for that reason. -No raylib headers are needed: `shim.c` declares the prototypes it uses, so the -build depends on the shared library being linkable and not on `raylib-devel`. +No raylib headers are needed: the generated C declares the prototypes it uses, +so the build depends on the shared 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. @@ -286,8 +354,8 @@ turned out to check nothing. - **Axis-aligned geometry cannot pin `Vector2`.** Exchanging `x` and `y` is a reflection, applied to the inputs on the way in and undone on the way out, so the printed answer is unchanged. Every collision predicate, and every - distance, passes with the fields swapped — verified by swapping the shim's - own typedef. Distances are worse: the reflection does not even reach them. + distance, passes with the fields swapped — verified by swapping the + `defstruct`, which is what the typedef is now made from. Distances are worse: the reflection does not even reach them. - **What does pin `Vector2` is the rotated camera**, because a 90-degree rotation is not axis-aligned and therefore does not commute with the reflection. That case is load-bearing and must not be deleted on the grounds @@ -1470,7 +1538,7 @@ object is written to a temporary name and `rename`d into place, so two concurrent builds cannot see a half-written one. Measured: calc-me 160ms → 110ms; sand ~720ms → ~700ms, since sand's time is -mostly linking libraylib and its `shim.c` was never the cost. The cache is +mostly linking libraylib and its C was never the cost. The cache is keyed by content, so it never needs invalidating by hand — `rm -rf` on the directory is only ever a disk-space decision. diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 300a7e7..cb3f018 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -542,6 +542,148 @@ let () = wasm_case "calc-me, wasm32" "../calc-me.flan" ~arg:"1 + 2 * (3 - 0.5) / 2" "3.5\n")); + + (* ── declare-c: the generated FFI shim (lib/shim.ml) ──────────────── + The raylib package is the proof that the generator is real — 84 + hand-written wrappers replaced by 84 one-line declarations, with the + two raylib cases above unchanged — and the permutation runs below are + the proof that the generated C typedefs actually follow the Flan + `defstruct`s rather than merely looking as if they do. + + Everything here is text, not a link: what a wrapper does is settled by + clang, and what is worth asserting in OCaml is the shape of what clang + is handed and the refusals, each by name and reason. *) + let shim_of src = + let decls = Parse.program (Reader.read_all ~file:"" src) in + match (Check.program decls).Tast.cshim with + | Some c -> c + | None -> "" + in + let shim_case name src needles = + match shim_of src with + | c -> + List.iter + (fun n -> + if not (contains c n) then begin + incr failures; + Printf.printf "FAIL %s\n wanted in the generated C: %S\n" + name n + end) + needles + | exception Loc.Error (_, m) -> + incr failures; + Printf.printf "FAIL %s\n refused: %s\n" name m + in + (* A refusal is by name and carries the reason; the tests assert on the + reason, so weakening one to a bare "cannot" breaks them. *) + let shim_refuses name src fragment = + match shim_of src with + | _ -> + incr failures; + Printf.printf "FAIL %s: accepted, and it should not have been\n" name + | exception Loc.Error (_, m) -> + if not (contains m fragment) then begin + incr failures; + Printf.printf "FAIL %s\n reason: %S\n wanted to contain: %S\n" + name m fragment + end + in + let v2 = "(defstruct Vector2 [x f32 y f32])\n" in + let img = + "(defstruct Image [data (Ptr u8) width i32 height i32])\n" + in + + (* A struct argument goes by pointer and a struct return through an + out-pointer, and the prototype says what C really takes. *) + shim_case "declare-c: a struct crosses by pointer, both ways" + (v2 ^ "(declare-c mid [a Vector2 b Vector2] Vector2 \"Mid\")") + [ "extern flan_ty_Vector2"; "*out = Mid(*a0, *a1);"; + "const flan_ty_Vector2"; "*out)" ]; + + (* The typedef is made from the defstruct and nothing else, so its field + order is the defstruct's — which is what makes permuting a defstruct a + real test rather than a rewording. Both orders asserted, because only + the pair rules out a generator that sorts. *) + shim_case "declare-c: the C typedef follows the defstruct's field order" + (v2 ^ "(declare-c f [v Vector2] \"F\")") + [ " float x;\n float y;\n" ]; + shim_case "declare-c: and permuting the defstruct permutes the typedef" + ("(defstruct Vector2 [y f32 x f32])\n(declare-c f [v Vector2] \"F\")") + [ " float y;\n float x;\n" ]; + + (* One type mapper for fields and parameters alike: a bool is C's bool and + never an int, and a pointer field keeps its element type. *) + shim_case "declare-c: field and parameter types come from one mapper" + (img + ^ "(defstruct S [flag bool n u64])\n\ + (declare-c g [s S i (Ptr Image) b bool] u64 \"G\")") + [ " bool flag;\n uint64_t n;\n"; " uint8_t *data;\n"; + "uint64_t G(flan_ty_S"; "bool a2" ]; + + (* A struct held by value pulls its own typedef in, and the definitions are + ordered so the inner one is complete first. *) + shim_case "declare-c: a nested struct is defined before it is used" + (v2 ^ "(defstruct Camera2D [offset Vector2 zoom f32])\n\ + (declare-c h [c Camera2D] \"H\")") + [ "struct flan_ty_Vector2"; " flan_ty_Vector2" ]; + + (* A string is ptr+len on the Flan side and a NUL-terminated copy on C's. + The buffer is sized here and not per call site, because a generator has + no call site to look at: 256 on the stack, the heap past that, and the + copy is freed after the call rather than before the return value is + computed. *) + shim_case "declare-c: a string is copied, NUL-terminated and freed" + "(declare-c open-it [path string] bool \"OpenIt\")" + [ "char a0_b[256];"; "flan_shim_cstr(a0_p, a0_n, a0_b, sizeof a0_b)"; + "bool r = OpenIt(a0);"; "flan_shim_cstr_free(a0, a0_b);"; + " return r;\n" ]; + shim_case "declare-c: two strings get two buffers" + "(declare-c both [a string b string] \"Both\")" + [ "char a0_b[256];"; "char a1_b[256];"; + "flan_shim_cstr_free(a0, a0_b);"; "flan_shim_cstr_free(a1, a1_b);" ]; + + (* [declare] is untouched by any of this: its signature still IS the C + signature, which is what vendor/agent's flan_agent_start and the + prelude's sqrtf depend on. A program with no declare-c generates no C + at all. *) + if shim_of "(declare start [path string] i32 \"flan_agent_start\")" <> "" + then begin + incr failures; + print_endline "FAIL declare (not declare-c) generated a shim" + end; + + shim_refuses "declare-c: a slice parameter, by name and reason" + (v2 ^ "(declare-c poly [pts [Vector2]] bool \"Poly\")") + "the count parameter the C function actually takes"; + shim_refuses "declare-c: an Option" + (v2 ^ "(declare-c maybe [] (Option Vector2) \"Maybe\")") + "which is a Flan shape and not a C one"; + shim_refuses "declare-c: a union" + ("(defunion Shape [(Circle [r f32]) (Square [s f32])])\n\ + (declare-c area [s Shape] f32 \"Area\")") + "a union, and a Flan union has no C layout"; + shim_refuses "declare-c: a fixed array" + "(declare-c takes [xs [4 f32]] \"Takes\")" + "which C passes as a pointer and Flan as a value"; + shim_refuses "declare-c: a map" + "(declare-c takes [m {string i32}] \"Takes\")" + "which has no C representation"; + shim_refuses "declare-c: a returned string" + "(declare-c name [] string \"Name\")" + "a string only crosses as a parameter"; + shim_refuses "declare-c: a callback" + "(declare-c each [f (Fn [i32] Unit)] \"Each\")" + "a C callback is not implemented"; + shim_refuses "declare-c: an unknown type" + "(declare-c f [x Nope] \"F\")" + "which is not a type this shim generator knows"; + shim_refuses "declare-c: a field C cannot hold" + "(defstruct S [xs [i32]])\n(declare-c f [s S] \"F\")" + "field xs of S is a slice"; + shim_refuses "declare-c: two Flan names for one C function" + "(declare-c a [] \"Same\")\n(declare-c b [] \"Same\")" + "one declare-c per C function"; + if !failures = 0 then print_endline "acceptance: all tests passed" else begin Printf.printf "\n%d failure(s)\n" !failures; From e08b3914fb1badefe095a62207e7b6a58bc9b47d Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 11 Sep 2026 20:31:55 +0700 Subject: [PATCH 4/4] Padding is a closed case, and a made-up name can still collide MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two gaps in what was claimed. The first is prose: "the typedef follows the defstruct" answers field order and field types but says nothing about padding, which reads like the remaining hazard. It is not one. Every field type the generator admits has the same layout under LLVM as under C, and emit.ml writes no datalayout, so clang applies the target's own rules to both halves; everything where they could diverge — an array, a slice, an Option, a map, a union — is already refused at the field. The second is real. The flattened declaration's name is invented by appending -c, so a hand-written foo-c beside (declare-c foo ...) came out as the checker complaining that a name not in the file was declared twice. Refused now where it happens, naming both and saying to rename one. --- NEXT.md | 6 +++++- lib/shim.ml | 32 +++++++++++++++++++++++++++++--- test/test_acceptance.ml | 5 +++++ vendor/raylib/raylib.flan | 2 +- 4 files changed, 40 insertions(+), 5 deletions(-) diff --git a/NEXT.md b/NEXT.md index fafe3e1..c6c7453 100644 --- a/NEXT.md +++ b/NEXT.md @@ -271,7 +271,11 @@ type-checks the wrapper against the generated prototype. Trusted: that the signature is the function's real signature — no header is read, deliberately, so nothing can check either. A `_Static_assert` on `sizeof`/`offsetof` was considered and rejected as circular: both sides would come from the same field -list. +list. Padding is not a separate hazard: for every field type the generator +admits — the machine integers, the two floats, `bool`, a pointer and a nested +struct — LLVM's layout is C's, and `emit.ml` writes no datalayout, so clang +applies the target's rules to both halves. Everything where they could diverge +is refused at the field. **One thing got sharper and should be said plainly:** the prototype is now generated *from the declaration*, so a scalar's width carries ABI weight it did diff --git a/lib/shim.ml b/lib/shim.ml index dfe6c99..4c8b8a0 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -40,6 +40,14 @@ typedef permutes with it. And clang type-checks the wrapper against the [extern] prototype, so the flattening cannot disagree with the prototype. + Padding is not a separate hazard, which is worth saying because it reads + like one. For every field type this generator admits — the machine + integers, the two floats, [bool], a pointer and a nested struct — LLVM's + struct layout is C's, and [emit.ml] writes no datalayout, so clang applies + the target's own rules to both halves and they land in the same place. + Everything where the two could diverge — a fixed array, a slice, an + [Option], a map, a union — is refused at the field, by name. + Trusted: that the [defstruct] describes the library's real struct, and that the [declare-c] signature is the function's real signature. No library header is read — deliberately, so a build needs the shared library and not @@ -520,7 +528,7 @@ let flan_wrapper (fn : Ast.fn) (s : shim) raw : Ast.decl_kind = (* ── Expansion ──────────────────────────────────────────────────────── *) -let one env (fn : Ast.fn) csym loc = +let one env ~taken (fn : Ast.fn) csym loc = let needed = ref [] in let sargs = List.map @@ -559,7 +567,15 @@ let one env (fn : Ast.fn) csym loc = let decls = if needs_flan then let raw = raw_name fn.Ast.name in - [ Ast.Declare (flattened fn s raw, s.swrap); flan_wrapper fn s raw ] + (* The flattened declaration's name is made up, so it can collide with + one somebody wrote. Refused here, naming both, rather than arriving as + the checker's "declared twice" about a name not in the file. *) + if Hashtbl.mem taken raw then + fail loc + "the declare-c of %s needs the name %s for the declaration it \ + generates, and %s is declared already — rename one of them" + fn.Ast.name raw raw + else [ Ast.Declare (flattened fn s raw, s.swrap); flan_wrapper fn s raw ] else [ Ast.Declare (flattened fn s fn.Ast.name, s.swrap) ] in (decls, s, !needed) @@ -569,6 +585,16 @@ let one env (fn : Ast.fn) csym loc = no C compile. *) let expand (decls : Ast.decl list) : Ast.decl list * string option = let env = scan decls in + (* The flattened declaration's name is made up, so it can collide with one + somebody wrote. Refused here, naming both, rather than surfacing as the + checker's "declared twice" about a name that is not in the file. *) + let taken = Hashtbl.create 64 in + List.iter + (fun (d : Ast.decl) -> + match Ast.declared_name d with + | Some n -> Hashtbl.replace taken n d.Ast.dloc + | None -> ()) + decls; let shims = ref [] in let needed = ref [] in let out = @@ -576,7 +602,7 @@ let expand (decls : Ast.decl list) : Ast.decl list * string option = (fun (d : Ast.decl) -> match d.Ast.d with | Ast.DeclareC (fn, csym) -> - let ds, s, n = one env fn csym d.Ast.dloc in + let ds, s, n = one env ~taken fn csym d.Ast.dloc in shims := !shims @ [ s ]; List.iter (fun x -> if not (List.mem x !needed) then needed := !needed @ [ x ]) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index cb3f018..04b5ed8 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -680,6 +680,11 @@ let () = shim_refuses "declare-c: a field C cannot hold" "(defstruct S [xs [i32]])\n(declare-c f [s S] \"F\")" "field xs of S is a slice"; + shim_refuses "declare-c: the generated name is already taken" + (v2 + ^ "(defn mid-c [a (Ptr Vector2) out (Ptr Vector2)])\n\ + (declare-c mid [a Vector2] Vector2 \"Mid\")") + "needs the name mid-c for the declaration it generates"; shim_refuses "declare-c: two Flan names for one C function" "(declare-c a [] \"Same\")\n(declare-c b [] \"Same\")" "one declare-c per C function"; diff --git a/vendor/raylib/raylib.flan b/vendor/raylib/raylib.flan index a84dc2b..a2d4d9a 100644 --- a/vendor/raylib/raylib.flan +++ b/vendor/raylib/raylib.flan @@ -391,7 +391,7 @@ [center Vector2 radius f32 color Color] "DrawCircleLinesV") -;; Two radii, horizontal then vertical. Equal radii is a circle, so a wrapper +;; Two radii, horizontal then vertical. Equal radii is a circle, so a binding ;; that exchanged them would be invisible unless they differ — which is why ;; sand.flan's ellipse is deliberately wider than it is tall. (declare-c draw-ellipse