The FFI shim is generated, and goes where its package goes
vendor/raylib has no C in it any more: shim.c is deleted and its 84 wrappers are emitted from declare-c, which names the library's function in the library's own signature. The reason the shim exists is unchanged - a small struct's calling convention is a per-target classification and clang reproduces it for free - but writing it by hand has stopped. declare-c is a second form rather than a change to declare, because the two make opposite claims about the same shape: (declare start-raw [path string] ...) says the symbol takes ptr+len, and (declare-c init-window [... title string] ...) says it takes a NUL-terminated char*. No structural rule separates them, so the author says which. The merge needed two fixes that neither lane could have found alone. Load's uses-walker matches decl_kind exhaustively and did not know DeclareC, so the reachability work and the generator did not compile together. And the generated C is now emitted in parts keyed by the wrapper's own C symbol, not as one translation unit. Reach.link drops the bindings nothing reachable calls; a single TU holding every wrapper referenced every raylib symbol, so sand-headless - which deliberately links no libraylib, and is the reason Reach exists - failed at the link with undefined references to GetTime and its neighbours. The first attempt keyed the parts by Flan name and broke the other way, dropping a wrapper that was called: the flattened declaration is named foo-c when a Flan wrapper is generated over it and foo when none is needed, so the Flan name is not one thing. The wrapper's C symbol is what the declaration binds in both branches. Worth recording how close that came to passing: the acceptance suite died with an exception rather than printing FAIL, so a grep for failures counted zero and the suite looked green. Only the count of reporting suites - ten where there had been eleven - showed it.
This commit is contained in:
commit
17ef50898d
100
NEXT.md
100
NEXT.md
@ -143,10 +143,11 @@ 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** |
|
||||
| `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** |
|
||||
@ -225,7 +226,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
|
||||
@ -233,11 +234,80 @@ 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 <file>` 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. 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
|
||||
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
|
||||
@ -254,8 +324,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
|
||||
@ -268,8 +339,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.
|
||||
|
||||
@ -285,8 +357,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
|
||||
@ -1505,7 +1577,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.
|
||||
|
||||
|
||||
17
bin/main.ml
17
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
|
||||
| [] -> Printf.printf "%s: no declare-c, so no generated C\n" path
|
||||
| parts -> List.iter (fun (_, src) -> print_string src) parts))
|
||||
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
|
||||
@ -211,7 +226,7 @@ let () =
|
||||
exit code)
|
||||
| _ ->
|
||||
prerr_endline
|
||||
"usage: flan (read|parse|check|emit) <file.flan>...\n\
|
||||
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n\
|
||||
\ flan build <file.flan> [-o out] [--no-bounds-checks] [--dev] \
|
||||
[--target=wasm32-wasi]\n\
|
||||
\ flan run <file.flan> [args...]\n\
|
||||
|
||||
@ -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
|
||||
|
||||
@ -318,6 +318,15 @@ 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
|
||||
| [] -> []
|
||||
| parts ->
|
||||
[ cc (String.concat "" (List.map snd parts)) "flan_shim.c" ])
|
||||
@ List.map (fun c -> cc (read_file c) (Filename.basename c)) csrcs
|
||||
in
|
||||
let cmd =
|
||||
|
||||
13
lib/check.ml
13
lib/check.ml
@ -1320,6 +1320,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;
|
||||
@ -1575,6 +1581,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;
|
||||
@ -1607,7 +1618,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)
|
||||
|
||||
14
lib/load.ml
14
lib/load.ml
@ -250,6 +250,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)
|
||||
@ -385,7 +394,10 @@ let decl_uses acc (d : Ast.decl) =
|
||||
| Ast.Defunion (_, vs) ->
|
||||
List.iter (fun (v : Ast.variant) -> List.iter field v.Ast.vfields) vs
|
||||
| Ast.Defn f -> fn f
|
||||
| Ast.Declare (f, _) ->
|
||||
(* Both declaration forms name types in their signature and nothing else.
|
||||
[declare-c] additionally causes a C typedef to be generated for every
|
||||
struct it mentions, which is the same dependency by a different route. *)
|
||||
| Ast.Declare (f, _) | Ast.DeclareC (f, _) ->
|
||||
List.iter field f.Ast.params;
|
||||
Option.iter (texpr_uses acc) f.Ast.ret
|
||||
| Ast.Defvar (_, t, init) ->
|
||||
|
||||
32
lib/parse.ml
32
lib/parse.ml
@ -461,22 +461,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
|
||||
|
||||
17
lib/reach.ml
17
lib/reach.ml
@ -136,6 +136,23 @@ let link ?(dev = false) (l : Load.t) (p : Tast.program) =
|
||||
(fun (e : Tast.extern) -> String.starts_with ~prefix e.Tast.ename)
|
||||
p.Tast.externs
|
||||
in
|
||||
(* The generated wrappers go the same way as the packages: a wrapper whose
|
||||
flattened declaration did not survive the prune is a C function calling
|
||||
a library symbol nothing reachable wants, and emitting it would put an
|
||||
undefined reference in a link that deliberately has no such library.
|
||||
The preamble stays; an unused typedef costs nothing. *)
|
||||
let live (name, _) =
|
||||
name = ""
|
||||
|| List.exists (fun (e : Tast.extern) -> e.Tast.esym = name)
|
||||
p.Tast.externs
|
||||
in
|
||||
let p =
|
||||
match List.filter live p.Tast.cshim with
|
||||
(* Nothing left but the preamble: no wrapper survived, so there is no
|
||||
translation unit to compile. *)
|
||||
| [ ("", _) ] | [] -> { p with Tast.cshim = [] }
|
||||
| parts -> { p with Tast.cshim = parts }
|
||||
in
|
||||
let pkgs = List.filter used l.Load.pkgs in
|
||||
(p,
|
||||
List.concat_map (fun (k : Load.pkg) -> k.Load.pcsrcs) pkgs,
|
||||
|
||||
651
lib/shim.ml
Normal file
651
lib/shim.ml
Normal file
@ -0,0 +1,651 @@
|
||||
(** [declare-c]: a foreign function written in the C library's own terms, with
|
||||
the crossing generated rather than hand-written.
|
||||
|
||||
[declare] says "this Flan signature *is* the C signature" — the symbol it
|
||||
names already trades in scalars and ptr+len, because somebody wrote it that
|
||||
way ([flan_agent_start], [sqrtf], the runtime's own shims). That form is
|
||||
unchanged and this module never touches one.
|
||||
|
||||
[declare-c] says the other thing: the signature is the *library's*, structs
|
||||
by value and all, and the compiler is to produce whatever flattening makes
|
||||
it crossable. The two cannot be one form —
|
||||
[(declare start-raw [path string] i32 "flan_agent_start")] and
|
||||
[(declare-c init-window [w i32 h i32 title string] "InitWindow")] are the
|
||||
same shape and mean opposite things about who NUL-terminates the string.
|
||||
|
||||
Why the crossing is still C, and not [emit.ml]: a small aggregate's calling
|
||||
convention is a per-target *classification*, not part of its layout.
|
||||
x86-64 hands [Vector2] over as [<2 x float>] and returns [Rectangle] as
|
||||
[{i64,i64}]; arm64 and wasm32 each do something else. Reproducing that in
|
||||
the backend is three classifiers to keep correct forever, and a mistake
|
||||
reads as a field full of garbage rather than as a link error. clang already
|
||||
does it, per target, for free. So the C shim stays; what stops is writing
|
||||
it by hand.
|
||||
|
||||
What this module does with one [declare-c]:
|
||||
|
||||
- emits a C [typedef] for every struct in the signature, from the Flan
|
||||
[defstruct], transitively and once each;
|
||||
- emits an [extern] prototype for the real function, in its true signature;
|
||||
- emits a wrapper that flattens — a struct returns through an out-pointer,
|
||||
a struct argument goes by pointer, a Flan string arrives as ptr+len and
|
||||
the wrapper NUL-terminates a copy;
|
||||
- and rewrites the declaration into the flattened [declare] the Flan side
|
||||
calls, with an ordinary Flan [defn] above it carrying the nice signature.
|
||||
|
||||
{2 What is guaranteed and what is trusted}
|
||||
|
||||
Guaranteed: the C typedef and the Flan struct come from the same
|
||||
[defstruct], so they cannot disagree — permute the [defstruct] and the
|
||||
typedef permutes with it. And clang type-checks the wrapper against the
|
||||
[extern] prototype, so the flattening cannot disagree with the prototype.
|
||||
|
||||
Padding is not a separate hazard, which is worth saying because it reads
|
||||
like one. For every field type this generator admits — the machine
|
||||
integers, the two floats, [bool], a pointer and a nested struct — LLVM's
|
||||
struct layout is C's, and [emit.ml] writes no datalayout, so clang applies
|
||||
the target's own rules to both halves and they land in the same place.
|
||||
Everything where the two could diverge — a fixed array, a slice, an
|
||||
[Option], a map, a union — is refused at the field, by name.
|
||||
|
||||
Trusted: that the [defstruct] describes the library's real struct, and that
|
||||
the [declare-c] signature is the function's real signature. No library
|
||||
header is read — deliberately, so a build needs the shared library and not
|
||||
the -devel package — so nothing here can check either. Two consequences
|
||||
worth stating plainly:
|
||||
|
||||
- the prototype is now generated *from the declaration*, so a scalar's
|
||||
width carries ABI weight it did not before. [f64] where the library says
|
||||
[float] used to be narrowed by clang at the hand-written call site; now
|
||||
it emits [double] and the library reads garbage.
|
||||
- the only thing that catches a wrong [defstruct] is a test that makes the
|
||||
library *compute* with the fields — which is why the raylib acceptance
|
||||
cases pin layouts by arithmetic and go red when a [defstruct] is
|
||||
permuted.
|
||||
|
||||
A [_Static_assert] on [sizeof] and [offsetof] was considered and left out:
|
||||
both sides of it would come from the same field list, so it would check
|
||||
this module's arithmetic against clang's and say nothing about the library.
|
||||
What 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 <stdbool.h>\n\
|
||||
#include <stddef.h>\n\
|
||||
#include <stdint.h>\n\
|
||||
#include <stdlib.h>\n\
|
||||
#include <string.h>\n\n"
|
||||
|
||||
(* A Flan string is ptr+len and never NUL-terminated, so a C API that wants a C
|
||||
string needs a copy. The hand-written wrappers sized the buffer per call
|
||||
site — 256 for a window title, PATH_MAX for a path, 512 for drawn text — and
|
||||
truncated past it. A generator has no call site to look at, so it must not
|
||||
be the thing deciding a string is too long: what does not fit the stack
|
||||
buffer is copied to the heap and freed after the call. The stack buffer is
|
||||
what keeps that allocation-free in the overwhelmingly common case, and it is
|
||||
256 because that covers a title, a path and a line of text without making
|
||||
every foreign call carry a page of stack. The only truncation left is when
|
||||
malloc itself fails, where the alternative is handing C a null pointer. *)
|
||||
let cstr_helpers =
|
||||
"static char *flan_shim_cstr(const char *p, int64_t n, char *buf, size_t cap) {\n\
|
||||
\ size_t len = n <= 0 ? 0 : (size_t)n;\n\
|
||||
\ char *d = buf;\n\
|
||||
\ if (len + 1 > cap) {\n\
|
||||
\ d = (char *)malloc(len + 1);\n\
|
||||
\ if (d == NULL) { d = buf; len = cap - 1; } /* out of memory: truncate */\n\
|
||||
\ }\n\
|
||||
\ if (len != 0) memcpy(d, p, len);\n\
|
||||
\ d[len] = '\\0';\n\
|
||||
\ return d;\n\
|
||||
}\n\n\
|
||||
static void flan_shim_cstr_free(char *d, char *buf) {\n\
|
||||
\ if (d != buf) free(d);\n\
|
||||
}\n\n"
|
||||
|
||||
let cstr_cap = 256
|
||||
|
||||
(* One [declare-c], reduced to what both halves need. *)
|
||||
type shim = {
|
||||
sflan : string; (* the Flan name as written *)
|
||||
ssym : string; (* the C symbol being bound *)
|
||||
swrap : string; (* the generated wrapper's symbol *)
|
||||
sargs : (pkind * string) list; (* kind and C type, per parameter *)
|
||||
sret : [ `Void | `Scalar of string | `Struct of string * string ];
|
||||
sloc : Loc.t;
|
||||
}
|
||||
|
||||
let arg_name i = Printf.sprintf "a%d" i
|
||||
|
||||
(* The wrapper's own parameter list: a struct by pointer, a string as ptr+len,
|
||||
anything else as itself — plus the out-pointer when C returns a struct. *)
|
||||
let wrapper_params s =
|
||||
let ps =
|
||||
List.concat
|
||||
(List.mapi
|
||||
(fun i (k, c) ->
|
||||
let a = arg_name i in
|
||||
match k with
|
||||
| Pstruct _ -> [ Printf.sprintf "const %s *%s" c a ]
|
||||
| Pstr ->
|
||||
[ Printf.sprintf "const char *%s_p" a;
|
||||
Printf.sprintf "int64_t %s_n" a ]
|
||||
| Pscalar ->
|
||||
[ (if String.length c > 0 && c.[String.length c - 1] = '*' then
|
||||
Printf.sprintf "%s%s" c a
|
||||
else Printf.sprintf "%s %s" c a) ])
|
||||
s.sargs)
|
||||
in
|
||||
match s.sret with
|
||||
| `Struct (_, c) -> ps @ [ Printf.sprintf "%s *out" c ]
|
||||
| _ -> ps
|
||||
|
||||
let c_for (s : shim) =
|
||||
let b = Buffer.create 512 in
|
||||
Printf.bprintf b "/* %s */\n" s.sflan;
|
||||
(* The prototype, in the library's own terms. *)
|
||||
let proto_args =
|
||||
List.map
|
||||
(fun (k, c) ->
|
||||
match k with Pstruct _ -> c | Pstr -> "const char *" | Pscalar -> c)
|
||||
s.sargs
|
||||
in
|
||||
let proto_ret =
|
||||
match s.sret with `Void -> "void" | `Scalar c -> c | `Struct (_, c) -> c
|
||||
in
|
||||
Printf.bprintf b "extern %s %s(%s);\n" proto_ret s.ssym
|
||||
(match proto_args with [] -> "void" | _ -> String.concat ", " proto_args);
|
||||
let wret = match s.sret with `Struct _ | `Void -> "void" | `Scalar c -> c in
|
||||
let wparams = wrapper_params s in
|
||||
Printf.bprintf b "%s %s(%s) {\n" wret s.swrap
|
||||
(match wparams with [] -> "void" | _ -> String.concat ", " wparams);
|
||||
(* The NUL-terminated copies, before the call. *)
|
||||
List.iteri
|
||||
(fun i (k, _) ->
|
||||
match k with
|
||||
| Pstr ->
|
||||
let a = arg_name i in
|
||||
Printf.bprintf b " char %s_b[%d];\n" a cstr_cap;
|
||||
Printf.bprintf b
|
||||
" char *%s = flan_shim_cstr(%s_p, %s_n, %s_b, sizeof %s_b);\n" a a a
|
||||
a a
|
||||
| _ -> ())
|
||||
s.sargs;
|
||||
let call_args =
|
||||
List.mapi
|
||||
(fun i (k, _) ->
|
||||
let a = arg_name i in
|
||||
match k with Pstruct _ -> "*" ^ a | Pstr | Pscalar -> a)
|
||||
s.sargs
|
||||
in
|
||||
let call = Printf.sprintf "%s(%s)" s.ssym (String.concat ", " call_args) in
|
||||
let has_str = List.exists (fun (k, _) -> k = Pstr) s.sargs in
|
||||
(match s.sret with
|
||||
| `Void -> Printf.bprintf b " %s;\n" call
|
||||
| `Struct _ -> Printf.bprintf b " *out = %s;\n" call
|
||||
| `Scalar c ->
|
||||
(* The result is named rather than returned straight through when there
|
||||
are copies to free: the free has to happen after the call. *)
|
||||
if has_str then Printf.bprintf b " %s r = %s;\n" c call
|
||||
else Printf.bprintf b " return %s;\n" call);
|
||||
if has_str then begin
|
||||
List.iteri
|
||||
(fun i (k, _) ->
|
||||
match k with
|
||||
| Pstr ->
|
||||
let a = arg_name i in
|
||||
Printf.bprintf b " flan_shim_cstr_free(%s, %s_b);\n" a a
|
||||
| _ -> ())
|
||||
s.sargs;
|
||||
match s.sret with
|
||||
| `Scalar _ -> Buffer.add_string b " return r;\n"
|
||||
| _ -> ()
|
||||
end;
|
||||
Buffer.add_string b "}\n\n";
|
||||
Buffer.contents b
|
||||
|
||||
(* The typedefs, forward-declared first so a struct may hold a pointer to one
|
||||
defined below it — or to itself — and then defined in dependency order, so a
|
||||
struct held *by value* is complete before it is used. *)
|
||||
let typedefs env needed =
|
||||
let b = Buffer.create 512 in
|
||||
(* The transitive closure, in first-met order. *)
|
||||
let rec close acc n =
|
||||
if List.mem n acc then acc
|
||||
else
|
||||
let acc = acc @ [ n ] in
|
||||
match Hashtbl.find_opt env.structs n with
|
||||
| None -> acc
|
||||
| Some fs ->
|
||||
List.fold_left
|
||||
(fun acc (f : Ast.field) ->
|
||||
let sink = ref [] in
|
||||
(* The type mapper is reused here purely to discover the struct
|
||||
names a field mentions; its text is not wanted. Mapping it now
|
||||
is also what refuses an unrepresentable field, at the field. *)
|
||||
ignore
|
||||
(cty env ~needed:sink ~loc:f.Ast.floc
|
||||
~what:(Printf.sprintf "field %s of %s" f.Ast.fname n)
|
||||
f.Ast.fty);
|
||||
List.fold_left close acc !sink)
|
||||
acc fs
|
||||
in
|
||||
let all = List.fold_left close [] needed in
|
||||
List.iter
|
||||
(fun n ->
|
||||
Printf.bprintf b "typedef struct %s_s %s;\n" (ctype_name n) (ctype_name n))
|
||||
all;
|
||||
if all <> [] then Buffer.add_char b '\n';
|
||||
(* Define a struct after every struct it holds by value. *)
|
||||
let defined = ref [] in
|
||||
let rec define n =
|
||||
if not (List.mem n !defined) then begin
|
||||
defined := n :: !defined;
|
||||
let fs = Hashtbl.find env.structs n in
|
||||
List.iter
|
||||
(fun (f : Ast.field) ->
|
||||
match (unalias env f.Ast.fty).Ast.t with
|
||||
| Ast.Tname m when Hashtbl.mem env.structs m -> define m
|
||||
| _ -> ())
|
||||
fs;
|
||||
Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n;
|
||||
List.iter
|
||||
(fun (f : Ast.field) ->
|
||||
let c =
|
||||
cty env ~needed:(ref []) ~loc:f.Ast.floc
|
||||
~what:(Printf.sprintf "field %s of %s" f.Ast.fname n) f.Ast.fty
|
||||
in
|
||||
let star = String.length c > 0 && c.[String.length c - 1] = '*' in
|
||||
(* A field name needs no digest: it is scoped to this struct, and
|
||||
two Flan fields that squash together are a duplicate member
|
||||
clang refuses by name. *)
|
||||
Printf.bprintf b " %s%s%s;\n" c (if star then "" else " ")
|
||||
(squash f.Ast.fname))
|
||||
fs;
|
||||
Buffer.add_string b "};\n\n"
|
||||
end
|
||||
in
|
||||
List.iter define all;
|
||||
Buffer.contents b
|
||||
|
||||
(* ── The Flan halves ────────────────────────────────────────────────── *)
|
||||
|
||||
let ty loc t = { Ast.t; tloc = loc }
|
||||
let ex loc e = { Ast.e; loc }
|
||||
|
||||
(* The flattened declaration the Flan side actually calls: a struct parameter
|
||||
becomes (Ptr T), a struct return becomes a trailing out-parameter. *)
|
||||
let flattened (fn : Ast.fn) (s : shim) name : Ast.fn =
|
||||
let loc = fn.Ast.nloc in
|
||||
let params =
|
||||
List.map2
|
||||
(fun (p : Ast.field) (k, _) ->
|
||||
match k with
|
||||
| Pstruct n ->
|
||||
{ p with
|
||||
Ast.fty =
|
||||
ty p.Ast.floc
|
||||
(Ast.Tapp ("Ptr", [ ty p.Ast.floc (Ast.Tname n) ])) }
|
||||
| _ -> p)
|
||||
fn.Ast.params s.sargs
|
||||
in
|
||||
match s.sret with
|
||||
| `Struct (n, _) ->
|
||||
{ fn with
|
||||
Ast.name;
|
||||
params =
|
||||
params
|
||||
@ [ { Ast.fname = "out"; floc = loc;
|
||||
fty = ty loc (Ast.Tapp ("Ptr", [ ty loc (Ast.Tname n) ])) } ];
|
||||
ret = None }
|
||||
| _ -> { fn with Ast.name; params }
|
||||
|
||||
(* The ordinary Flan function that carries the nice signature: it copies each
|
||||
struct argument into a local — a parameter is not an assignable place, so
|
||||
there is no address to take without one — and, when C returns a struct,
|
||||
zeroes one and hands over its address. *)
|
||||
let flan_wrapper (fn : Ast.fn) (s : shim) raw : Ast.decl_kind =
|
||||
let loc = fn.Ast.nloc in
|
||||
let binds = ref [] in
|
||||
let args =
|
||||
List.mapi
|
||||
(fun i ((p : Ast.field), (k, _)) ->
|
||||
match k with
|
||||
| Pstruct _ ->
|
||||
let t = tmp i in
|
||||
binds :=
|
||||
!binds
|
||||
@ [ { Ast.bname = t; bty = None;
|
||||
bval = ex p.Ast.floc (Ast.Var p.Ast.fname);
|
||||
bloc = p.Ast.floc } ];
|
||||
ex p.Ast.floc
|
||||
(Ast.Call
|
||||
(ex p.Ast.floc (Ast.Var "addr"), [ ex p.Ast.floc (Ast.Var t) ]))
|
||||
| _ -> ex p.Ast.floc (Ast.Var p.Ast.fname))
|
||||
(List.combine fn.Ast.params s.sargs)
|
||||
in
|
||||
let call args = ex loc (Ast.Call (ex loc (Ast.Var raw), args)) in
|
||||
let body, ret =
|
||||
match s.sret with
|
||||
| `Struct (n, _) ->
|
||||
binds :=
|
||||
!binds
|
||||
@ [ { Ast.bname = out_tmp; bty = None;
|
||||
bval = ex loc (Ast.Struct (n, [])); bloc = loc } ];
|
||||
let out = ex loc (Ast.Var out_tmp) in
|
||||
( [ call (args @ [ ex loc (Ast.Call (ex loc (Ast.Var "addr"), [ out ])) ]);
|
||||
out ],
|
||||
Some (ty loc (Ast.Tname n)) )
|
||||
| _ -> ([ call args ], fn.Ast.ret)
|
||||
in
|
||||
Ast.Defn { fn with Ast.ret; fbody = [ ex loc (Ast.Let (!binds, body)) ] }
|
||||
|
||||
(* ── Expansion ──────────────────────────────────────────────────────── *)
|
||||
|
||||
let one env ~taken (fn : Ast.fn) csym loc =
|
||||
let needed = ref [] in
|
||||
let sargs =
|
||||
List.map
|
||||
(fun (p : Ast.field) ->
|
||||
classify env ~needed ~loc:p.Ast.floc
|
||||
~what:(Printf.sprintf "parameter %s of %s" p.Ast.fname fn.Ast.name)
|
||||
p.Ast.fty)
|
||||
fn.Ast.params
|
||||
in
|
||||
let what = Printf.sprintf "the return type of %s" fn.Ast.name in
|
||||
let sret =
|
||||
match fn.Ast.ret with
|
||||
| None -> `Void
|
||||
| Some t ->
|
||||
let t' = unalias env t in
|
||||
(match t'.Ast.t with
|
||||
| Ast.Tname "Unit" -> `Void
|
||||
| Ast.Tname n when Hashtbl.mem env.structs n ->
|
||||
ignore (cty env ~needed ~loc ~what t');
|
||||
`Struct (n, ctype_name n)
|
||||
| _ -> `Scalar (cty env ~needed ~loc ~what t'))
|
||||
in
|
||||
let s =
|
||||
{ sflan = fn.Ast.name; ssym = csym; swrap = shim_symbol fn.Ast.name; sargs;
|
||||
sret; sloc = loc }
|
||||
in
|
||||
(* A declaration whose Flan face already equals its flattened face needs no
|
||||
Flan function on top of it; only the ones with a struct in the signature
|
||||
do. A string is not one of those — it crosses as ptr+len either way, and
|
||||
it is the C wrapper that terminates it. *)
|
||||
let needs_flan =
|
||||
(match sret with `Struct _ -> true | _ -> false)
|
||||
|| List.exists (fun (k, _) -> match k with Pstruct _ -> true | _ -> false)
|
||||
sargs
|
||||
in
|
||||
let decls =
|
||||
if needs_flan then
|
||||
let raw = raw_name fn.Ast.name in
|
||||
(* The flattened declaration's name is made up, so it can collide with
|
||||
one somebody wrote. Refused here, naming both, rather than arriving as
|
||||
the checker's "declared twice" about a name not in the file. *)
|
||||
if Hashtbl.mem taken raw then
|
||||
fail loc
|
||||
"the declare-c of %s needs the name %s for the declaration it \
|
||||
generates, and %s is declared already — rename one of them"
|
||||
fn.Ast.name raw raw
|
||||
else [ Ast.Declare (flattened fn s raw, s.swrap); flan_wrapper fn s raw ]
|
||||
else [ Ast.Declare (flattened fn s fn.Ast.name, s.swrap) ]
|
||||
in
|
||||
(decls, s, !needed)
|
||||
|
||||
(* Every [declare-c] in the program, rewritten, with the one C file they share.
|
||||
The file is [None] when there are none, so a program that binds nothing pays
|
||||
no C compile. *)
|
||||
(* The C comes back in parts rather than as one string: a wrapper belongs to
|
||||
the binding it serves, and [Reach.link] drops the bindings nothing reachable
|
||||
calls. One TU holding every wrapper would reference every C symbol in the
|
||||
library, so a program that imports raylib and never draws would still fail
|
||||
to link without libraylib — which is the whole thing [Reach] exists to
|
||||
avoid. The key is the flattened declaration's name; "" is the preamble. *)
|
||||
let expand (decls : Ast.decl list) : Ast.decl list * (string * string) list =
|
||||
let env = scan decls in
|
||||
(* The flattened declaration's name is made up, so it can collide with one
|
||||
somebody wrote. Refused here, naming both, rather than surfacing as the
|
||||
checker's "declared twice" about a name that is not in the file. *)
|
||||
let taken = Hashtbl.create 64 in
|
||||
List.iter
|
||||
(fun (d : Ast.decl) ->
|
||||
match Ast.declared_name d with
|
||||
| Some n -> Hashtbl.replace taken n d.Ast.dloc
|
||||
| None -> ())
|
||||
decls;
|
||||
let shims = ref [] in
|
||||
let needed = ref [] in
|
||||
let out =
|
||||
List.concat_map
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.DeclareC (fn, csym) ->
|
||||
let ds, s, n = one env ~taken fn csym d.Ast.dloc in
|
||||
shims := !shims @ [ s ];
|
||||
List.iter
|
||||
(fun x -> if not (List.mem x !needed) then needed := !needed @ [ x ])
|
||||
n;
|
||||
List.map (fun k -> { d with Ast.d = k }) ds
|
||||
| _ -> [ d ])
|
||||
decls
|
||||
in
|
||||
match !shims with
|
||||
| [] -> (out, [])
|
||||
| shims ->
|
||||
(* Two Flan names may not bind one C symbol: the prototype would be emitted
|
||||
twice, and a second Flan name for the same function is a [defn] and not
|
||||
a second declaration. *)
|
||||
let seen = Hashtbl.create 16 in
|
||||
List.iter
|
||||
(fun s ->
|
||||
match Hashtbl.find_opt seen s.ssym with
|
||||
| Some other ->
|
||||
fail s.sloc
|
||||
"%s and %s both bind the C function %s — one declare-c per C \
|
||||
function, and another Flan name for it is a defn"
|
||||
other s.sflan s.ssym
|
||||
| None -> Hashtbl.replace seen s.ssym s.sflan)
|
||||
shims;
|
||||
let b = Buffer.create 4096 in
|
||||
Buffer.add_string b header;
|
||||
if List.exists (fun s -> List.exists (fun (k, _) -> k = Pstr) s.sargs) shims
|
||||
then Buffer.add_string b cstr_helpers;
|
||||
(* Every typedef the program needs, kept whole even when wrappers are
|
||||
dropped: an unused typedef costs nothing, and working out which ones a
|
||||
surviving subset still needs is a second dependency walk for no gain. *)
|
||||
Buffer.add_string b (typedefs env !needed);
|
||||
(out,
|
||||
("", Buffer.contents b)
|
||||
(* Keyed by the wrapper's own C symbol, not by a Flan name: the flattened
|
||||
declaration is named [foo-c] when a Flan wrapper is generated over it
|
||||
and [foo] when none is needed, so the Flan name is not one thing.
|
||||
[swrap] is what the declaration binds either way. *)
|
||||
:: List.map (fun s -> (s.swrap, c_for s)) shims)
|
||||
@ -159,6 +159,15 @@ 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]. *)
|
||||
(* The generated FFI shim, in parts keyed by the declaration each serves,
|
||||
with "" for the shared preamble. Parts rather than one string so that
|
||||
[Reach.link] can drop a wrapper whose binding nothing reachable calls. *)
|
||||
cshim : (string * string) list;
|
||||
}
|
||||
|
||||
let field_index (s : structure) name =
|
||||
|
||||
@ -711,6 +711,154 @@ ERR@7 unexpected token: not the kind the caller was reading
|
||||
outputs ~opt:"-O0" "enum comparison, -O0" "programs/enum-compare.flan"
|
||||
enum_out;
|
||||
|
||||
|
||||
(* ── 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:"<shim-test>" src) in
|
||||
(* One string again for the assertions: the parts exist so [Reach] can
|
||||
drop a wrapper, and what is asserted here is the text clang is
|
||||
handed, which is the concatenation. *)
|
||||
String.concat "" (List.map snd (Check.program decls).Tast.cshim)
|
||||
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: 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";
|
||||
|
||||
if !failures = 0 then print_endline "acceptance: all tests passed"
|
||||
else begin
|
||||
Printf.printf "\n%d failure(s)\n" !failures;
|
||||
|
||||
677
vendor/raylib/raylib.flan
vendored
677
vendor/raylib/raylib.flan
vendored
@ -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")
|
||||
(declare-c draw-circle-lines-v
|
||||
[center Vector2 radius f32 color Color]
|
||||
"DrawCircleLinesV")
|
||||
|
||||
(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))))
|
||||
|
||||
;; 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 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")
|
||||
|
||||
476
vendor/raylib/shim.c
vendored
476
vendor/raylib/shim.c
vendored
@ -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 <stdbool.h>
|
||||
#include <stddef.h>
|
||||
#include <limits.h>
|
||||
#include <string.h>
|
||||
|
||||
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(); }
|
||||
Loading…
x
Reference in New Issue
Block a user