JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/test/test_acceptance.ml
Joseph Ferano dbf5748c56 Assert the reasons, and say what a permutation proves 
Every refusal is by name with the reason, so the tests assert on the
reasons and weakening one to a bare "cannot" breaks them: a slice, an
Option, a union, a fixed array, a map, a returned string, a callback, an
unknown type, a struct field C cannot hold, and two Flan names for one C
symbol.

The rest is text about text, which is the honest scope: what a wrapper
does is settled by clang, and what is worth checking in OCaml is the
shape of what clang is handed. Two cases assert the typedef's field
order against a defstruct and against the same defstruct permuted,
because only the pair rules out a generator that sorts — and sorting is
exactly the mutation the raylib cases cannot see, since every raylib
struct is fields of one size and a rename changes no offset.

What the raylib cases do see is a permuted defstruct, and that was run:
Rectangle width/height, Vector2 x/y, Image width/height, Image with data
moved last, Texture2D id/format, Color r/a and Camera2D offset/target
all go red. Texture2D width/mipmaps stays green, which is what NEXT.md
already says headless cannot pin — the one green is the control, not a
gap.
2026-09-11 20:26:11 +07:00

693 lines
33 KiB
OCaml
Raw Blame History

(* The milestone-2 acceptance test: a table of expression/result pairs run
through a compiled calc-me (plan.org, Build sequence).
It is a table rather than a golden file because milestone 3 runs the *same*
table on wasm32 — headless is what makes one test cover both targets. *)
open Flan
let failures = ref 0
let scratch = Filename.get_temp_dir_name ()
let run exe arg =
let out = Filename.concat scratch "flan-acceptance.out" in
let cmd =
Printf.sprintf "%s %s > %s 2>&1"
(Filename.quote exe)
(match arg with None -> "" | Some a -> Filename.quote a)
(Filename.quote out)
in
let code = Sys.command cmd in
let text = In_channel.with_open_bin out In_channel.input_all in
Sys.remove out;
(code, text)
let compile ?(opt = "-O2") ?(checks = true) ?(dev = false) path =
let exe =
Filename.concat scratch
("flan-t-" ^ Filename.remove_extension (Filename.basename path))
in
(* Through [Load], so a program with an (import ...) is buildable here: it
brings back the package's C shim and linker arguments as well. *)
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
ignore (Build.executable ~opts:{ Build.default with opt; checks; dev }
~csrcs:l.Load.csrcs ~lflags:l.Load.lflags p ~out:exe);
exe
(* No Str, and the reader is hand-written for the same reason. *)
let contains hay needle =
let n = String.length needle and h = String.length hay in
let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
go 0
let () =
match Sys.command "command -v clang > /dev/null 2>&1" with
| 0 ->
let exe = compile "../calc-me.flan" in
let case name arg expected_out expected_code =
let code, text = run exe arg in
if text <> expected_out || code <> expected_code then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit %d)\n"
name text code expected_out expected_code
end
in
let evaluates src expected = case src (Some src) (expected ^ "\n") 0 in
let rejects src = case src (Some src) "calc-me: cannot parse\n" 1 in
(* Arithmetic and precedence *)
evaluates "1 + 2 * (3 - 0.5) / 2" "3.5";
evaluates "1+2*3" "7";
evaluates "2*3+4" "10";
evaluates "(1+2)*3" "9";
evaluates "10/4" "2.5";
evaluates "7" "7";
evaluates " 7 " "7";
evaluates "1.5+2.25" "3.75";
(* Left-associative: 1-2-3 is (1-2)-3, not 1-(2-3) *)
evaluates "1-2-3" "-4";
evaluates "8/4/2" "1";
(* Unary minus, including nested *)
evaluates "-5" "-5";
evaluates "-(1+2)" "-3";
evaluates "3 * -2" "-6";
(* Whole input or nothing: trailing junk is an error, not ignored *)
rejects "1 +";
rejects "(1+2";
rejects "1 2";
rejects "";
rejects "+";
rejects "1+2)";
case "no argument" None "usage: calc-me \"1 + 2 * 3\"\n" 1;
(try Sys.remove exe with Sys_error _ -> ());
(* Programs whose whole output is fixed. These cover the milestone-2
surface calc-me does not reach — globals, 2-D arrays, places through a
pointer, casts, match with either arm taken, and the value semantics of
spec-memory.md. *)
let outputs ?opt ?dev name path expected =
let exe = compile ?opt ?dev path in
let code, text = run exe None in
if text <> expected || code <> 0 then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 0)\n"
name text code expected
end;
(try Sys.remove exe with Sys_error _ -> ())
in
let values_out = "1\n5\nel\n" in
let machine_out = "12\n30\n2\n2\n3\n3.5\n42\n99\n12\n123\n" in
outputs "value semantics" "programs/values.flan" values_out;
outputs "machine surface" "programs/machine.flan" machine_out;
outputs "unit main exits 0" "programs/unit-main.flan" "ok\n";
(* The prelude's slice algorithms. Every assertion here is over an input a
wrong implementation fails: unsorted with duplicates, negatives and an
odd length; a reverse-sorted slice; and a sort of a subslice whose
neighbours must be untouched, which is the in-place, ptr+len claim
itself. At -O0 as well — a slice parameter is an alloca of a two-word
struct, and mem2reg is exactly what would hide it being copied. *)
let slices_out =
"5 -3 5 0 12 -3 7\n23\n-3\n12\n0\n-1\n99\n\
7 -3 12 0 5 -3 5\n-3 7 12 0 5 -3 5\n\
-3 -3 0 5 5 7 12\n1 2 3 4 5\n\
100 -1 0 4 9 9 200 300\n100 -1 0 4 9 9 200 300\n"
in
outputs "slice algorithms" "programs/slices.flan" slices_out;
outputs ~opt:"-O0" "slice algorithms, -O0" "programs/slices.flan" slices_out;
(* The byte predicates, parse-i64, and the two number helpers. The refused
parse-i64 cases are every shape strtoll answers 0 for — "", "abc",
"12x", "-", " 1" — so a None there is the whole reason the function is
Flan and not the bytes->i64 primitive. The RNG lines pin the actual
sequence off a fixed seed rather than just a range, which is the only
way a later change to the derivation gets caught; rand-u32 itself is
pinned by the sand hash. *)
let text_out =
"tfft\ntfftt\ntfftt\n\
1 -1 -1\n\
0 42 -42 7 9007199254740993\n\
-999 -999 -999 -999 -999\n\
1 -1 0\n\
0 2.5 10 0\n\
11 14 12 14 15\n5 5\n\
0.793725 0.324519 0.0835023\n"
in
outputs "bytes, parsing and numbers" "programs/text.flan" text_out;
outputs ~opt:"-O0" "bytes, parsing and numbers, -O0" "programs/text.flan"
text_out;
(* Rounding and sqrt. Every case here is a *negative* or a half, because
those are the two places a plausible wrong version differs: a floor
written as the bare cast truncates toward zero and answers -2 for -2.5,
and a round written as (floor-f32 (+ x 0.5)) is half-up rather than
half-away and answers -2 as well. 16777216.0 is past 2^24, where the
guard rather than the cast has to produce the answer — and where the
cast it guards would be out of i32's range. sqrt is a `declare` on
libm's sqrtf; the -O0 run is the one that matters for it, because at
-O2 LLVM folds most calls into the hardware instruction and a symbol
that never has to resolve proves nothing about the link. *)
let math_out =
"2 2 2 -3 -2 -3 0 -1 \n\
3 2 3 -2 -2 -2 1 0 \n\
0 0 -0 \n\
2 3 3 -2 -3 -3 1 -1 \n\
1.67772e+07 1.67772e+07 1.67772e+07 -1.67772e+07 \n\
0 1 2 1.41421 0.5 1000 \n\
5 \n"
in
outputs "rounding and sqrt" "programs/math.flan" math_out;
outputs ~opt:"-O0" "rounding and sqrt, -O0" "programs/math.flan" math_out;
(* index-of-bytes, trim, the byte classes and parse-f64. The search cases
are the ones that separate a correct loop from a lucky one: a match
only at the end, "aab" in "aaab" (where the first byte matches twice
before the needle does), a needle longer than the haystack, which must
answer None without building a window off the end, and the empty needle
at Some 0. trim prints inside brackets so the all-whitespace answer is
visible as [] — that input is also the one that would build a reversed
slice and trap. And parse-f64's refusals are every shape strtod hands
back a plausible number for: "", "abc", "1x", ".", "1e", " 1", "1 ",
"0x10", "nan". *)
let bytes2_out =
"6 0 4 2 1 \n\
-1 -1 -1 0 0 0 \n\
[hi][hi][hi][][][a b][x][x]\n\
ttfff\n\
ttttff\n\
0 3.5 -3.5 0.25 1000 0.015 12\n\
-999 -999 -999 -999 -999 -999 -999 -999 -999 -999 -999\n\
1 0.5\n\
2.25\n"
in
outputs "substring, trim and parse-f64" "programs/bytes2.flan" bytes2_out;
outputs ~opt:"-O0" "substring, trim and parse-f64, -O0" "programs/bytes2.flan"
bytes2_out;
(* handler-bind and signal, spec-conditions.md §1 and §2: signal returns
Unit and carries on, an unhandled one is a no-op, a nested frame does
not displace the one outside it, and the stack is restored after. *)
let conditions_out = "0\n3\n23\n3\n1103\n1103\n" in
outputs "conditions" "programs/conditions.flan" conditions_out;
outputs ~opt:"-O0" "conditions, -O0" "programs/conditions.flan" conditions_out;
outputs ~dev:true "conditions, dev" "programs/conditions.flan" conditions_out;
(* restart-case and invoke-restart, §3 to §6: the transfer itself. A
fall-through with nothing handling it, a clause reached from two frames
down, the defer in between running on the way out, an inner frame
shadowing an outer one of the same name, and a handler that returns
normally still transferring nothing. At -O0 as well, because the guard
after every call is control flow the optimiser would otherwise launder;
and as a dev build, where every one of those calls goes through a cell. *)
let restarts_out = "101\n1\n-1\n2\n7\n1010\n101\n105\n-2\n" in
outputs "restarts" "programs/restarts.flan" restarts_out;
outputs ~opt:"-O0" "restarts, -O0" "programs/restarts.flan" restarts_out;
outputs ~dev:true "restarts, dev" "programs/restarts.flan" restarts_out;
(* §2's other half, which cannot be an [outputs] case because it does not
exit 0: a handler runs, returns normally, and has still not answered the
error, so the program stops and names the condition. *)
let exe = compile "programs/error.flan" in
let code, text = run exe None in
if code <> 134 || not (contains text "handler ran")
|| not (contains text "unhandled AssetMissing")
then begin
incr failures;
Printf.printf
"FAIL an unhandled error stops the program\n\
\ got: %S (exit %d)\n wanted: exit 134, naming the condition\n"
text code
end;
(* The raylib FFI, headless. GetColor, rectangle intersection and the
shapes texture need no window, so the whole boundary is exercised
without a display: a struct out of C through an out-pointer, a struct
into C through a pointer, a keyword resolved against an enum, and a
Flan string crossing as ptr+len.
Every case is asymmetric, which is the point. 0x11223344 comes back as
four separate bytes, so a Color is not the little-endian reading of the
packed integer. The intersection of (0,0,10,4) and (6,1,10,10) is
(6,1,4,3), four numbers from four different pairs of fields, so no
permutation of Rectangle survives it. And the shapes texture is stored
or replaced by 1 1 1 1 7 depending on which field is zero, which pins
Texture2D's id and format. Handing raylib a struct and reading it back
would have passed with any of those permuted — storing and returning is
symmetric. What the last case cannot pin, because nothing raylib
computes without a GL context reads them, is width, height and mipmaps
against each other.
The camera conversions are the strongest headless material here: both
are pure arithmetic over every field of a Camera2D and two Vector2s,
and both directions are asserted as absolute answers. A round trip
would not be — the inverse cancels a permuted layout exactly, the same
way store-and-return does. The rotated pair is the only thing in the
package that pins Vector2's own two fields, because every
component-wise formula is merely mirrored by exchanging x and y and so
compares equal; a rotation mixes them. It reports ok/bad rather than a
number because sinf and cosf make the answer 27.9999981, and this
table compares stdout byte for byte. *)
let raylib_out =
"17\n34\n51\n68\n\
6\n1\n4\n3\n\
7\n13\n17\n2\n4\n3.5\n7.25\n11.5\n13.75\n\
1\n1\n1\n1\n7\n\
7\n0\n17\n2\n4\n\
28\n24\n140\n90\n\
rotated screen-to-world ok\n\
rotated world-to-screen ok\n\
point in rect yes\npoint below rect no\n\
rects overlap yes\nrects apart no\n\
circles touch yes\ncircles clear no\n\
3\n7\n\
circle meets rect yes\ncircle clears rect no\n\
circle meets line yes\ncircle clears line no\n\
point in circle yes\npoint outside circle no\n\
point in triangle yes\npoint outside triangle no\n\
point on line yes\npoint off line no\n\
point in poly yes\npoint outside poly no\n\
in square, four corners yes\nout of triangle, three no\n\
no crossing\n"
in
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
outputs "raylib ffi, headless" "programs/raylib-ffi.flan" raylib_out;
(* And at -O0, for the reason the rest of the table is: every struct
here crosses as (addr v) on a local, which is the alloca mem2reg
would launder before anyone noticed it was wrong. *)
outputs ~opt:"-O0" "raylib ffi, headless, -O0" "programs/raylib-ffi.flan"
raylib_out
end
else
print_endline "acceptance: skipping the raylib FFI case (no libraylib)";
(* raylib's Image family, headless, and the strongest FFI case here: an
Image is pixels in RAM, so raylib *computes* with it rather than
storing and returning it.
Two separate things are pinned. gen-image-color is handed two scalars
and answers with a struct reading 4, 2, 1, 7 — four distinct values in
four adjacent i32 slots, so exchanging any two of width, height,
mipmaps and format is visible, and dropping `data` makes width the low
half of raylib's pointer. Scalars in and fields out is what makes that
work: a permuted layout has nothing to cancel against, unlike the
shapes texture, where nothing without a GPU read width, height or
mipmaps at all.
The other is the axis, which the collision cases could not get. raylib
indexes a pixel as y*width + x, and the image is 4 wide by 2 tall, so
(3,0) exists and its transpose does not — exchange x and y in the shim
and the read is out of bounds and answers transparent black. The
horizontal and vertical flips are the same argument twice more: on two
rows, one of them moves a mark that the other leaves alone.
The PNG round trip is not the symmetric trap either: stb's encoder and
decoder are external ground truth and agree with each other rather than
with whatever field order Flan believes in. It also crosses a path as
ptr+len. /tmp is written to, and both optimisation levels write the
same bytes, so the shared name is harmless.
Trace logging stays at :warning and no read here is out of bounds, so
a warning appearing in this output is a real failure — [run] folds
stderr in. *)
let raylib_image_out =
"generated 4 2 1 7\n\
at 3,0 200 0 0 255\n\
at 0,1 0 200 0 255\n\
at 0,0 10 20 30 255\n\
at 3,1 10 20 30 255\n\
flipped-h at 0,0 200 0 0 255\n\
flipped-h at 3,1 0 200 0 255\n\
flipped-h at 3,0 10 20 30 255\n\
flipped-v at 0,1 200 0 0 255\n\
flipped-v at 3,0 0 200 0 255\n\
flipped-v at 0,0 10 20 30 255\n\
exported yes\n\
loaded valid yes\n\
loaded 4 2 1 7\n\
loaded at 0,1 200 0 0 255\n\
loaded at 3,0 0 200 0 255\n\
loaded at 0,0 10 20 30 255\n\
resized-nn 8 2 1 7\n\
nn at 0,1 200 0 0 255\n\
nn at 1,1 200 0 0 255\n\
nn at 6,0 0 200 0 255\n\
nn at 7,0 0 200 0 255\n\
nn at 2,1 10 20 30 255\n\
resized 2 6 1 7\n\
cropped 2 1 1 7\n\
cropped at 1,0 200 0 0 255\n\
cropped at 0,0 10 20 30 255\n"
in
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
outputs "raylib images, headless" "programs/raylib-image.flan"
raylib_image_out;
outputs ~opt:"-O0" "raylib images, headless, -O0" "programs/raylib-image.flan"
raylib_image_out
end
else
print_endline "acceptance: skipping the raylib Image case (no libraylib)";
(* Again at -O0. Everything above runs through mem2reg, which launders a
sloppy alloca; -O0 tests the IR actually emitted, so a disagreement
between the two points at undefined behaviour rather than a typo. *)
(* sand.flan's simulation, headless. This is the milestone-4 acceptance
case: N frames from a seeded PRNG, one hash. It imports the sim package
and not raylib, deliberately — a program that imports raylib links
libraylib on every target, and this one is the version meant to run on
wasm32 too. The hash is reproducible only because rand-f32 is ours. *)
let sand_out = "2256461126764447066\n" in
outputs "sand, headless" "programs/sand-headless.flan" sand_out;
outputs ~opt:"-O0" "sand, headless, -O0" "programs/sand-headless.flan" sand_out;
outputs ~opt:"-O0" "value semantics, -O0" "programs/values.flan" values_out;
outputs ~opt:"-O0" "machine surface, -O0" "programs/machine.flan" machine_out;
(* And once more as a dev build. Every call in one goes through a cell, so
this is the same table asserting the indirection changes nothing before
anything has been redefined — the sand hash especially, since it is the
one result that would notice a call reaching the wrong function. *)
outputs ~dev:true "sand, headless, dev" "programs/sand-headless.flan" sand_out;
outputs ~dev:true "value semantics, dev" "programs/values.flan" values_out;
outputs ~dev:true "machine surface, dev" "programs/machine.flan" machine_out;
(* Bounds checks, NEXT.md item 2. A trap has no result — it has a nonzero
exit and a message on stderr — so it needs a case shape the table above
does not have. What is asserted is the *reason*: the location, and which
index against which length. The line and column are not pinned, because
editing the program should not break the test that reads it. *)
let bounds ?opt () =
let exe = compile ?opt "programs/bounds.flan" in
let traps name arg reason =
let code, text = run exe (Some arg) in
if code <> 134
|| not (contains text "programs/bounds.flan:")
|| not (contains text reason)
then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 134)\n"
name text code reason
end
in
(* Both edges are in bounds and must not trap: the last index of a fixed
array, a slice ending exactly at len, and an empty slice at len. *)
let code, text = run exe (Some "0") in
if text <> "0ello\n" || code <> 0 then begin
incr failures;
Printf.printf "FAIL in-bounds edges\n got: %S (exit %d)\n" text code
end;
traps "at past a fixed array" "3"
"index 3 is out of bounds for length 3";
(* Negative indices sext to a huge unsigned, so the one unsigned
comparison catches them; the message still reports the signed value. *)
traps "at with a negative index" "-1"
"index -1 is out of bounds for length 3";
traps "at past a slice" "9"
"index 9 is out of bounds for length 5";
(* A different lowering — place/Pindex, not At — so it is its own case. *)
traps "set past a fixed array" "7"
"index 7 is out of bounds for length 3";
traps "slice with hi past len" "4"
"slice [4 9) is out of bounds for length 5";
(* Without the lo <= hi test this one would not trap: it would build a
slice of length hi - lo as a huge unsigned, which is worse. *)
traps "slice with a reversed range" "2"
"slice [2 1) is out of bounds for length 5";
(try Sys.remove exe with Sys_error _ -> ())
in
bounds ();
bounds ~opt:"-O0" ();
(* The release build drops them — the calls, that is; the two declarations
stay in the header and LLVM discards the unused ones. Asserted on the IR
rather than by running an unchecked out-of-bounds program, which has no
defined behaviour to assert on. *)
let p =
Reader.read_file "programs/bounds.flan" |> Parse.program |> Check.program
in
if not (contains (Emit.program p) "call void @flan_bounds_fail(") then begin
incr failures;
print_endline "FAIL checks on: no bounds call emitted"
end;
let off = Emit.program ~checks:false p in
if contains off "call void @flan_bounds_fail(" || contains off "call void @flan_slice_fail(" then begin
incr failures;
print_endline "FAIL --no-bounds-checks: a check survived"
end;
(* ── wasm32 (NEXT.md, deferred item 6) ──────────────────────────────
The second target, and the reason sand-headless imports no raylib. What
is asserted is not that a wasm module exists — it is that it prints the
*same hash* as the native build, byte for byte. That is only possible
because rand-f32 is written in Flan rather than bound to libc, so the
case is the regression test for that decision as much as for the port.
Four independent things can be absent — clang's wasm target, the
wasi-libc sysroot, a builtins archive, and a runtime that speaks WASI —
so the skip is a *probe*: build the smallest program and run it. A
[which] would go red on the machine where Node is too old, with a
reason nobody could read. *)
let wasm_runner =
if Sys.command "command -v wasmtime > /dev/null 2>&1" = 0 then
Some "wasmtime"
else if Sys.command "command -v wasmer > /dev/null 2>&1" = 0 then
Some "wasmer run"
else if Sys.command "command -v node > /dev/null 2>&1" = 0 then
(* --no-warnings because node:wasi prints an ExperimentalWarning to
stderr on every run, and this harness compares combined output. *)
Some "node --no-warnings wasm-run.mjs"
else None
in
let wasm_build ?(opt = "-O2") path out =
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
ignore
(Build.executable
~opts:{ Build.default with opt; target = Some "wasm32-wasi" }
~csrcs:l.Load.csrcs ~lflags:l.Load.lflags p ~out)
in
let wasm_run ?arg runner wasm =
let out = Filename.concat scratch "flan-acceptance-wasm.out" in
let code =
Sys.command
(Printf.sprintf "%s %s %s > %s 2>&1" runner (Filename.quote wasm)
(match arg with None -> "" | Some a -> Filename.quote a)
(Filename.quote out))
in
let text = In_channel.with_open_bin out In_channel.input_all in
(try Sys.remove out with Sys_error _ -> ());
(code, text)
in
(match wasm_runner with
| None ->
print_endline
"acceptance: skipping the wasm32 case (no wasmtime, wasmer or node)"
| Some runner ->
let probe = Filename.concat scratch "flan-wasm-probe.wasm" in
let outcome =
match wasm_build "programs/unit-main.flan" probe with
| () ->
let code, text = wasm_run runner probe in
if code = 0 && text = "ok\n" then Ok ()
else
Error
(Printf.sprintf "%s could not run it: %S (exit %d)" runner text
code)
| exception Failure m -> Error m
in
(try Sys.remove probe with Sys_error _ -> ());
(match outcome with
| Error why ->
Printf.printf "acceptance: skipping the wasm32 case (%s)\n" why
| Ok () ->
let wasm_case name ?opt ?arg path expected =
let wasm =
Filename.concat scratch
("flan-w-" ^ Filename.remove_extension (Filename.basename path)
^ ".wasm")
in
wasm_build ?opt path wasm;
let code, text = wasm_run ?arg runner wasm in
if text <> expected || code <> 0 then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 0)\n"
name text code expected
end;
(try Sys.remove wasm with Sys_error _ -> ())
in
(* The hash, which must equal the native one above. At both levels:
agreement at -O2 alone could be a coincidence of how LLVM folded
the float arithmetic, and -O0 is the cheap way to say it is not. *)
wasm_case "sand, headless, wasm32" "programs/sand-headless.flan"
sand_out;
wasm_case "sand, headless, wasm32, -O0" ~opt:"-O0"
"programs/sand-headless.flan" sand_out;
(* And the two fixed-output programs, which between them cover the
milestone-2 surface: globals, 2-D arrays, places through a
pointer, casts and match. A 32-bit pointer is the thing most
likely to go wrong and these are where it would show. *)
wasm_case "value semantics, wasm32" "programs/values.flan" values_out;
wasm_case "machine surface, wasm32" "programs/machine.flan"
machine_out;
(* calc-me, for the one host-ABI path the three above do not touch:
[flan_argv] builds an array of flan_slice in C and Flan indexes it
as [string], so what is pinned here is the element *stride* of a
ptr+len pair, which is 16 bytes native and 12 on wasm32 — not a
field offset, and nothing else in the table reaches it. This is
also the file header's own claim, that the table runs on wasm32
too, honoured for the first time. *)
wasm_case "calc-me, wasm32" "../calc-me.flan"
~arg:"1 + 2 * (3 - 0.5) / 2" "3.5\n"));
(* ── declare-c: the generated FFI shim (lib/shim.ml) ────────────────
The raylib package is the proof that the generator is real — 84
hand-written wrappers replaced by 84 one-line declarations, with the
two raylib cases above unchanged — and the permutation runs below are
the proof that the generated C typedefs actually follow the Flan
`defstruct`s rather than merely looking as if they do.
Everything here is text, not a link: what a wrapper does is settled by
clang, and what is worth asserting in OCaml is the shape of what clang
is handed and the refusals, each by name and reason. *)
let shim_of src =
let decls = Parse.program (Reader.read_all ~file:"<shim-test>" src) in
match (Check.program decls).Tast.cshim with
| Some c -> c
| None -> ""
in
let shim_case name src needles =
match shim_of src with
| c ->
List.iter
(fun n ->
if not (contains c n) then begin
incr failures;
Printf.printf "FAIL %s\n wanted in the generated C: %S\n"
name n
end)
needles
| exception Loc.Error (_, m) ->
incr failures;
Printf.printf "FAIL %s\n refused: %s\n" name m
in
(* A refusal is by name and carries the reason; the tests assert on the
reason, so weakening one to a bare "cannot" breaks them. *)
let shim_refuses name src fragment =
match shim_of src with
| _ ->
incr failures;
Printf.printf "FAIL %s: accepted, and it should not have been\n" name
| exception Loc.Error (_, m) ->
if not (contains m fragment) then begin
incr failures;
Printf.printf "FAIL %s\n reason: %S\n wanted to contain: %S\n"
name m fragment
end
in
let v2 = "(defstruct Vector2 [x f32 y f32])\n" in
let img =
"(defstruct Image [data (Ptr u8) width i32 height i32])\n"
in
(* A struct argument goes by pointer and a struct return through an
out-pointer, and the prototype says what C really takes. *)
shim_case "declare-c: a struct crosses by pointer, both ways"
(v2 ^ "(declare-c mid [a Vector2 b Vector2] Vector2 \"Mid\")")
[ "extern flan_ty_Vector2"; "*out = Mid(*a0, *a1);";
"const flan_ty_Vector2"; "*out)" ];
(* The typedef is made from the defstruct and nothing else, so its field
order is the defstruct's — which is what makes permuting a defstruct a
real test rather than a rewording. Both orders asserted, because only
the pair rules out a generator that sorts. *)
shim_case "declare-c: the C typedef follows the defstruct's field order"
(v2 ^ "(declare-c f [v Vector2] \"F\")")
[ " float x;\n float y;\n" ];
shim_case "declare-c: and permuting the defstruct permutes the typedef"
("(defstruct Vector2 [y f32 x f32])\n(declare-c f [v Vector2] \"F\")")
[ " float y;\n float x;\n" ];
(* One type mapper for fields and parameters alike: a bool is C's bool and
never an int, and a pointer field keeps its element type. *)
shim_case "declare-c: field and parameter types come from one mapper"
(img
^ "(defstruct S [flag bool n u64])\n\
(declare-c g [s S i (Ptr Image) b bool] u64 \"G\")")
[ " bool flag;\n uint64_t n;\n"; " uint8_t *data;\n";
"uint64_t G(flan_ty_S"; "bool a2" ];
(* A struct held by value pulls its own typedef in, and the definitions are
ordered so the inner one is complete first. *)
shim_case "declare-c: a nested struct is defined before it is used"
(v2 ^ "(defstruct Camera2D [offset Vector2 zoom f32])\n\
(declare-c h [c Camera2D] \"H\")")
[ "struct flan_ty_Vector2"; " flan_ty_Vector2" ];
(* A string is ptr+len on the Flan side and a NUL-terminated copy on C's.
The buffer is sized here and not per call site, because a generator has
no call site to look at: 256 on the stack, the heap past that, and the
copy is freed after the call rather than before the return value is
computed. *)
shim_case "declare-c: a string is copied, NUL-terminated and freed"
"(declare-c open-it [path string] bool \"OpenIt\")"
[ "char a0_b[256];"; "flan_shim_cstr(a0_p, a0_n, a0_b, sizeof a0_b)";
"bool r = OpenIt(a0);"; "flan_shim_cstr_free(a0, a0_b);";
" return r;\n" ];
shim_case "declare-c: two strings get two buffers"
"(declare-c both [a string b string] \"Both\")"
[ "char a0_b[256];"; "char a1_b[256];";
"flan_shim_cstr_free(a0, a0_b);"; "flan_shim_cstr_free(a1, a1_b);" ];
(* [declare] is untouched by any of this: its signature still IS the C
signature, which is what vendor/agent's flan_agent_start and the
prelude's sqrtf depend on. A program with no declare-c generates no C
at all. *)
if shim_of "(declare start [path string] i32 \"flan_agent_start\")" <> ""
then begin
incr failures;
print_endline "FAIL declare (not declare-c) generated a shim"
end;
shim_refuses "declare-c: a slice parameter, by name and reason"
(v2 ^ "(declare-c poly [pts [Vector2]] bool \"Poly\")")
"the count parameter the C function actually takes";
shim_refuses "declare-c: an Option"
(v2 ^ "(declare-c maybe [] (Option Vector2) \"Maybe\")")
"which is a Flan shape and not a C one";
shim_refuses "declare-c: a union"
("(defunion Shape [(Circle [r f32]) (Square [s f32])])\n\
(declare-c area [s Shape] f32 \"Area\")")
"a union, and a Flan union has no C layout";
shim_refuses "declare-c: a fixed array"
"(declare-c takes [xs [4 f32]] \"Takes\")"
"which C passes as a pointer and Flan as a value";
shim_refuses "declare-c: a map"
"(declare-c takes [m {string i32}] \"Takes\")"
"which has no C representation";
shim_refuses "declare-c: a returned string"
"(declare-c name [] string \"Name\")"
"a string only crosses as a parameter";
shim_refuses "declare-c: a callback"
"(declare-c each [f (Fn [i32] Unit)] \"Each\")"
"a C callback is not implemented";
shim_refuses "declare-c: an unknown type"
"(declare-c f [x Nope] \"F\")"
"which is not a type this shim generator knows";
shim_refuses "declare-c: a field C cannot hold"
"(defstruct S [xs [i32]])\n(declare-c f [s S] \"F\")"
"field xs of S is a slice";
shim_refuses "declare-c: two Flan names for one C function"
"(declare-c a [] \"Same\")\n(declare-c b [] \"Same\")"
"one declare-c per C function";
if !failures = 0 then print_endline "acceptance: all tests passed"
else begin
Printf.printf "\n%d failure(s)\n" !failures;
exit 1
end
| _ -> print_endline "acceptance: skipped (no clang on PATH)"
Reference in New Issue View Git Blame Copy Permalink