Joseph Ferano
90d3d6694e
The parser decides "return type or first body form?" from the set of type
names the file declares, and an import is resolved after parsing - so a
package's structs cannot be in that set by construction. (defn mk [] rl/Vector2
...) therefore read the return type as the body and failed with "unknown name
rl/Vector2", which names the symptom and not the cause.
The signal is the alias plus the capital, and both halves are needed. An alias
is syntactically obvious and the same pre-pass collects it. A bare capitalised
symbol is never a value in this language - a struct or union constructor is
(Name {...}), a List, and an enum member is a keyword - so the hazard the
surrounding comment warns about, a body form eaten as a return type, has no
form of this shape to eat. A lowercase qualified name stays an expression,
which is what rl/get-color has to be.
Found by the raylib lane, which hit it on rl/Vector2 and reported it rather
than reaching into a file it did not own.
1052 lines
51 KiB
OCaml
1052 lines
51 KiB
OCaml
(* 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
|
|
(* [Reach.link] decides the link from the program: a package nothing
|
|
reachable calls into hands over no C and no linker argument, and its
|
|
functions are not emitted. *)
|
|
let p, csrcs, lflags = Reach.link ~dev l p in
|
|
ignore (Build.executable ~opts:{ Build.default with opt; checks; dev }
|
|
~csrcs ~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)";
|
|
|
|
(* raylib's Wave family, headless — and the first claim to make about it
|
|
is that it exists. The received wisdom in this repository was that
|
|
audio needs a device and so cannot be in this table at all. That is
|
|
true of Sound, Music and AudioStream, every one of which is a handle
|
|
the miniaudio mixer owns, and false of Wave: samples in RAM and four
|
|
integers describing them, with copy, crop, reformat, export, load and
|
|
decode all running on the CPU. So it gets the Image family's treatment.
|
|
|
|
Three shapes, and they pin different things.
|
|
|
|
wave-format is the scalars-in/fields-out case gen-image-color is: three
|
|
plain integers go in and all four u32 fields come out, with
|
|
frame-count *computed* from the ratio of the sample rates — 16, from
|
|
eight frames at twice the rate, and no argument named it. Eight bits
|
|
rather than sixteen in that call so sample-size cannot be confused
|
|
with the frame count it would otherwise equal.
|
|
|
|
export-wave then load-wave is external ground truth, the PNG argument
|
|
transposed: dr_wav writes the header from three fields and reads them
|
|
back, agreeing with itself rather than with Flan's field order. Be
|
|
precise about its reach, because it is narrower than it looks — it
|
|
catches sample-size against channels (the "loaded" line reads
|
|
"8 8000 16 16" when those two are exchanged) and NOT frame-count
|
|
against sample-rate, which leaves every line of the round trip green.
|
|
The crop and the reformat are what catch that pair.
|
|
|
|
And the decoded samples are the axis discriminator this section needed.
|
|
load-wave-samples answers a (Ptr f32), which Flan cannot index — [at]
|
|
takes an array, a slice or a string — so the program crops to a single
|
|
frame first and dereferences sample 0. That detour is what makes the
|
|
case strong rather than weak: raylib's crop offset is init-frame times
|
|
channels times sample-size over 8, so asking for frame 3 and getting
|
|
+3000 pins sample-size against channels. Exchange those two and the
|
|
crop lands two bytes off and the sample is a different number, not the
|
|
same one mirrored, which is the failure mode axis-aligned geometry
|
|
could never produce.
|
|
|
|
Verified red by permuting the Wave defstruct three ways: frame-count
|
|
with sample-rate (cropped reads "8 4 16 1" and reformatted
|
|
"16000 16000000 8 2", while the file round trip stays green — see
|
|
above), sample-size with channels (every frame read turns to "no" and
|
|
the loaded line reads "8 8000 16 16"), and data moved to the front
|
|
(the run dies after two lines). *)
|
|
let raylib_audio_out =
|
|
"valid yes\n\
|
|
source 8 8000 16 1\n\
|
|
cropped 4 8000 16 1\n\
|
|
reformatted 16 16000 8 2\n\
|
|
frame 1 is +1000 yes\n\
|
|
frame 3 is +3000 yes\n\
|
|
frame 4 is -3000 yes\n\
|
|
frame 0 is zero yes\n\
|
|
exported yes\n\
|
|
loaded valid yes\n\
|
|
loaded 8 8000 16 1\n\
|
|
loaded frame 1 is +1000 yes\n\
|
|
loaded frame 4 is -3000 yes\n"
|
|
in
|
|
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
|
|
outputs "raylib audio, headless" "programs/raylib-audio.flan"
|
|
raylib_audio_out;
|
|
outputs ~opt:"-O0" "raylib audio, headless, -O0" "programs/raylib-audio.flan"
|
|
raylib_audio_out
|
|
end
|
|
else
|
|
print_endline "acceptance: skipping the raylib Wave case (no libraylib)";
|
|
|
|
(* raylib's Font family, headless, which the package refused to bind at
|
|
all until now. The stated reason was that a Font drags in two more
|
|
aggregates and two owned arrays "for something with no headless test at
|
|
the end of it". The generator takes all of it unchanged — a struct held
|
|
by value is emitted after what it contains, one held by pointer is
|
|
forward-declared — and the test turned out to exist.
|
|
|
|
What makes it exist is that the program does not ASK raylib for a font.
|
|
Every call that makes one needs a window or a TTF and a GL context.
|
|
So it builds one out of Flan arrays, field by field, and hands it over
|
|
to be computed with: three glyphs, three atlas rectangles, a base size
|
|
of 10 and a texture that is a lie in every field but [id]. Text
|
|
measuring is pure arithmetic over exactly those fields, so this is
|
|
scalars in and numbers out with no raylib-produced struct anywhere for
|
|
a permutation to cancel against.
|
|
|
|
The one raylib trap worth recording: MeasureTextEx returns (0,0)
|
|
immediately when font.texture.id is 0. The hand-built font claims an id
|
|
of 1, and that guard is what pins where the Texture2D sits inside the
|
|
Font — land it elsewhere and every measurement collapses to zero.
|
|
|
|
Glyph C carries an advance of 0 deliberately, which sends raylib down
|
|
its other branch: the atlas rectangle's width plus the glyph's offset,
|
|
9 + 3 = 12, which is why "ABC" is 36 and "AB" is 24. And "A" at a
|
|
spacing of 3 measures 11 and not 14, because spacing is added per gap
|
|
and not per glyph — without that line, a wrapper that added it per
|
|
glyph would pass everything else.
|
|
|
|
Verified red by six permutations. In Font: base-size with glyph-count
|
|
(the measurements become 80, 120, 163 and 36.6667), the recs and glyphs
|
|
pointers (floats in the 1e9 range and a garbage atlas rectangle), and
|
|
[texture] moved to the end (the run dies after the first line). In
|
|
GlyphInfo: offset-x with advance-x (3, 6, 9, 1), and [image] moved to
|
|
the FRONT, which shifts the four ints by 24 bytes — the glyph search
|
|
collapses, every index reads 0 and glyph C answers with A's fields.
|
|
In Rectangle: x with width, which moves "measure ABC" to 39 and leaves
|
|
"measure AB" at 24, since only the advance-0 fallback reads a width out
|
|
of the recs array. Two of the six were a crash rather than a wrong
|
|
number, which still counts.
|
|
|
|
What this case does NOT pin, said here for the same reason the
|
|
Texture2D notes above say it: glyph-padding is read by nothing raylib
|
|
computes on the CPU, offset-y only moves a glyph when it is drawn, and
|
|
of each atlas rectangle only `width` is ever looked at. Those four
|
|
fields rest on the header agreeing with raylib's and on sand.flan
|
|
looking right, and on nothing else. *)
|
|
let raylib_font_out =
|
|
"valid yes\n\
|
|
index A 0\nindex B 1\nindex C 2\nindex Z 0\n\
|
|
atlas B 5 0 7 10\n\
|
|
glyph C value 67\nglyph C offset 3\nglyph C advance 0\n\
|
|
measure AB 24 10\n\
|
|
measure ABC 36 10\n\
|
|
measure AB big 51 20\n\
|
|
measure A spaced 11 10\n"
|
|
in
|
|
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
|
|
outputs "raylib fonts, headless" "programs/raylib-font.flan"
|
|
raylib_font_out;
|
|
outputs ~opt:"-O0" "raylib fonts, headless, -O0" "programs/raylib-font.flan"
|
|
raylib_font_out
|
|
end
|
|
else
|
|
print_endline "acceptance: skipping the raylib Font 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 = "-2851001042534928384\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;
|
|
|
|
(* ── Packages: the link follows the program ────────────────────────
|
|
A package's C and linker arguments used to come with the import,
|
|
whatever [main] did — which is what made sand's two halves two files
|
|
rather than one file with two entry points (NEXT.md, sand.flan is two
|
|
programs). [Reach.link] decides it from the checked program instead:
|
|
nothing reachable calls into raylib here, so no shim is compiled, no
|
|
-lraylib is passed, and no body that would reference a raylib symbol is
|
|
emitted. Natively that is invisible; the wasm32 case below is where it
|
|
is the difference between building and not. *)
|
|
outputs "an imported package nothing calls" "programs/pkg-unused.flan"
|
|
"ok\n";
|
|
outputs "an imported package nothing calls, -O0" ~opt:"-O0"
|
|
"programs/pkg-unused.flan" "ok\n";
|
|
(* A package may import a package, and one reached along two routes is read
|
|
once: pkg-shared imports sand.flan, which imports raylib, and imports
|
|
raylib itself. Loading it twice would declare every binding twice. *)
|
|
outputs "a package reached along two routes" "programs/pkg-shared.flan"
|
|
"ok\n";
|
|
|
|
(* The refusals. Each is a thing that would otherwise fail later and
|
|
elsewhere — as a name the checker says is unknown, or as a collision
|
|
nobody wrote — so what is asserted is the *reason*, at the form that
|
|
caused it. None of these is built; being refused is the whole test. *)
|
|
let refuses name path needle =
|
|
let attempt () =
|
|
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
|
|
ignore (Check.program l.Load.decls)
|
|
in
|
|
match attempt () with
|
|
| () ->
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n it was accepted\n" name
|
|
| exception Loc.Error (_, m) ->
|
|
if not (contains m needle) then begin
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n said: %S\n wanted: %S in it\n"
|
|
name m needle
|
|
end
|
|
in
|
|
(* Visibility: main is not a name a package offers, and saying so is the
|
|
point — "unknown name sand/main" would be true and useless. *)
|
|
refuses "a package's main is not visible" "programs/pkg-hidden-main.flan"
|
|
"sand/main is not a name";
|
|
refuses "one directory under two aliases" "programs/pkg-two-aliases.flan"
|
|
"one directory is one set of names";
|
|
refuses "two mains in one program" "programs/pkg-two-mains.flan"
|
|
"main is defined twice";
|
|
|
|
(* ── 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
|
|
let p, csrcs, lflags = Reach.link l p in
|
|
ignore
|
|
(Build.executable
|
|
~opts:{ Build.default with opt; target = Some "wasm32-wasi" }
|
|
~csrcs ~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";
|
|
(* And the case the whole of Reach.link exists for: a program that
|
|
imports raylib, calls none of it, and builds for a target where
|
|
libraylib cannot be linked at all. Before, this was not a failing
|
|
test — it was a file nobody could write. *)
|
|
wasm_case "an imported package nothing calls, wasm32"
|
|
"programs/pkg-unused.flan" "ok\n";
|
|
wasm_case "an imported package nothing calls, wasm32, -O0"
|
|
~opt:"-O0" "programs/pkg-unused.flan" "ok\n"));
|
|
|
|
(* The EDN tokenizer, and the struct reader written by hand against it
|
|
(vendor/edn, test/programs/edn.flan). The expected output is a raw
|
|
literal because the token dump is full of brackets and quotes, and
|
|
escaping them here would put a second reader between the test and what
|
|
the program actually printed.
|
|
|
|
Every line is one a plausible wrong version fails. The dump prints both
|
|
the kind letter and the text in <>, so a tokenizer with the right kinds
|
|
and the wrong slices - off by the opening quote, off by the keyword's
|
|
colon - fails even though it agreed about every kind. The cases that
|
|
are not obvious: a number followed straight by a delimiter ("[1]",
|
|
"1;c") separates a scan-to-delimiter from a scan-to-whitespace; foo/bar
|
|
must stay a namespaced symbol where a "contains a slash" ratio rule
|
|
makes it an error; a string holding a bracket and a semicolon must not
|
|
open a vector or start a comment; "1 ; no newline at the end" is the
|
|
comment a scan-to-newline loop runs off the end of; and an empty map is
|
|
what a reader assuming at least one key-value pair gets wrong.
|
|
|
|
The refusals are asserted on their *reason* and not on the fact of
|
|
failing, with the byte offset first - a tokenizer answering one generic
|
|
error for all of them would pass a test that only checked that it
|
|
stopped. Both string cases are here because they fail differently: an
|
|
escaped quote is the one where a wrong version returns a backslash as
|
|
part of the text and leaves the rest of the literal behind as garbage.
|
|
|
|
At -O0 as well. A Token is a two-word slice inside a struct returned by
|
|
value, and a Cursor is passed by pointer with a fixed array in it;
|
|
mem2reg is exactly what launders a struct being copied where it should
|
|
be shared. *)
|
|
let edn_out =
|
|
{edn|i<1>
|
|
i<-1>i<+2>i<0>
|
|
f<1.5>f<-2.5e3>f<.5>
|
|
b<true>b<false>n<nil>
|
|
y<foo>y<Enemy/Goblin>y<->
|
|
k<a>k<foo/bar>
|
|
|
|
[<>i<1>]<>
|
|
[<>i<1>i<2>]<>[<>i<3>]<>
|
|
{<>k<a>i<1>}<>
|
|
i<1>
|
|
k<a>
|
|
|
|
{<>}<>
|
|
[<>]<>
|
|
(<>)<>
|
|
[<>[<>i<1>]<>[<>i<2>[<>i<3>]<>]<>]<>
|
|
{<>k<a>{<>k<b>[<>]<>}<>}<>
|
|
|
|
k<a>
|
|
i<1>
|
|
s<x>
|
|
|
|
i<1>
|
|
i<1>i<2>
|
|
i<1>
|
|
|
|
|
|
[<>i<1>i<2>i<3>]<>
|
|
|
|
s<hi>
|
|
s<a[b;c>i<1>
|
|
s<>i<1>
|
|
s<a b>
|
|
|
|
2 escaped strings are refused: unescaping needs a copy of the bytes, and there is no allocator to put one in
|
|
2 escaped strings are refused: unescaping needs a copy of the bytes, and there is no allocator to put one in
|
|
0 unterminated string: end of input before the closing quote
|
|
0 sets #{} are refused: there is no hash set, and no allocator to build one in
|
|
0 tagged literals #tag are refused: the tag would pick the type at run time, which is what a type-directed reader exists to avoid
|
|
0 #inst is refused: it is a tagged literal, and there is no timestamp type to read it into
|
|
0 #uuid is refused: it is a tagged literal, and there is no uuid type to read it into
|
|
0 metadata ^ is refused: it attaches to the value after it, and a flat token stream has nowhere to attach it
|
|
0 ratios are refused: there is no rational type, and rounding one to a float would change the value
|
|
0 character literals are refused: a character is not a byte once it is not ASCII, and there is no code point type
|
|
0 not a number: the token starts like one but does not parse as an integer or a float
|
|
3 empty keyword: a colon with no name after it
|
|
0 unexpected byte: not the start of any EDN value
|
|
0 unexpected byte: not the start of any EDN value
|
|
4 unbalanced: this closing delimiter does not match the one that is open
|
|
0 unbalanced: this closing delimiter does not match the one that is open
|
|
4 unbalanced: this closing delimiter does not match the one that is open
|
|
32 nesting is too deep: the balance stack is a fixed array and it is full
|
|
|
|
[goblin] hp=12 speed=1.5 boss=no
|
|
[dragon] hp=40 speed=0 boss=yes
|
|
[imp] hp=1 speed=2 boss=no
|
|
[] hp=0 speed=0 boss=no
|
|
ERR@7 unexpected token: not the kind the caller was reading
|
|
[orc] hp=9 speed=0 boss=no
|
|
|edn}
|
|
in
|
|
outputs "edn tokenizer" "programs/edn.flan" edn_out;
|
|
outputs ~opt:"-O0" "edn tokenizer, -O0" "programs/edn.flan" edn_out;
|
|
|
|
(* Comparing enums, found by auditing emit.ml's failwith sites. It type
|
|
checked and then died in the backend with no source location, which is
|
|
the project's worst failure shape. All six operators, a negative member
|
|
so that an unsigned compare would answer the other way, and a compare
|
|
through a struct field, which reaches the same lowering by another
|
|
path. *)
|
|
let enum_out =
|
|
"eq yes\neq no\nlo below mid\nhi not below mid\nfield eq yes\n"
|
|
in
|
|
outputs "enum comparison" "programs/enum-compare.flan" enum_out;
|
|
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";
|
|
|
|
(* Two programs written against a mutation-testing report, each covering a
|
|
claim the whole suite could be broken on while staying green.
|
|
|
|
cleanup.flan: a return running the defers above it, and running them
|
|
innermost-first; a defer that calls something, so a guard is emitted
|
|
inside it on the transfer path; a transfer out of a handler-bind popping
|
|
its frames; a two-clause handler-bind popping both; and a signal that
|
|
stops at the inner handler once that one has answered it by
|
|
transferring. Six claims, and the numbers differ per failure so a wrong
|
|
answer names its own cause.
|
|
|
|
signedness.flan: the ashr/lshr and slt/ult choices, which emit.ml makes
|
|
from the operand's type. Either could have been hardcoded to one arm,
|
|
because nothing in the corpus shifted a negative right or compared an
|
|
unsigned value above 2^31. *)
|
|
let cleanup_out = "7\n21\n42\n0\n5\n0\n0\n" in
|
|
outputs "cleanup paths" "programs/cleanup.flan" cleanup_out;
|
|
outputs ~opt:"-O0" "cleanup paths, -O0" "programs/cleanup.flan" cleanup_out;
|
|
let signed_out = "-4\n-1\nbig is not small\nbig is large\n1\n" in
|
|
outputs "signedness" "programs/signedness.flan" signed_out;
|
|
outputs ~opt:"-O0" "signedness, -O0" "programs/signedness.flan" signed_out;
|
|
|
|
(* ── Destructuring ─────────────────────────────────────────── *)
|
|
|
|
(* A destructuring let is desugared in [Parse] into the Let, field access,
|
|
[at] and [slice] that already existed, so there is nothing in the typed
|
|
IR to inspect and this program *is* the test. The last line is the one
|
|
that catches the mistake worth catching: four names come out of two
|
|
calls, so a desugaring that dropped the temporary and re-evaluated the
|
|
initialiser per name would print 4 instead of 2. Every other line here
|
|
would stay green through that. -O0 as well, for the usual reason — the
|
|
tail slice is an address into a local array, and mem2reg launders a
|
|
sloppy one. *)
|
|
let destructure_out =
|
|
"keys 1 2\npairs 10 20\nnested 7 8\nshadow 5 6\nsequential 100 200\n\
|
|
array 11 22 33\nrest 1 4 2 5\nempty-tail 17 0\nnested-in-array 1 4\n\
|
|
struct-tail 1 2 4 5\ncalls 2 14\n"
|
|
in
|
|
outputs "destructuring" "programs/destructure.flan" destructure_out;
|
|
outputs ~opt:"-O0" "destructuring, -O0" "programs/destructure.flan"
|
|
destructure_out;
|
|
|
|
(* A package-qualified struct as a declared return type, which the parser
|
|
used to read as the first body form. Reported by the raylib lane, which
|
|
hit it on rl/Vector2 and worked around it rather than reaching into a
|
|
file it did not own. *)
|
|
let pkgret_out = "9\n5\n" in
|
|
outputs "a package struct in return position" "programs/pkg-return.flan"
|
|
pkgret_out;
|
|
outputs ~opt:"-O0" "a package struct in return position, -O0"
|
|
"programs/pkg-return.flan" pkgret_out;
|
|
|
|
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)"
|