Joseph Ferano
5ea0bcae84
nth and at were documented as the same operation, and as reads they were: check.ml matched "at" | "nth" in one arm. But a place is recovered in two other spots -- parse.ml for (set ...) and place_of_expr for (addr ...) -- and both match only Sym "at". So (set (nth a i) x) and (addr (nth a i)) were refused while the at forms worked. Two names said to be identical that disagree about writing is worse than one name, and the asymmetry is not worth fixing in three places to keep a synonym. at is the indexing operation; nth is gone. The six call sites were all reads, so they rewrite directly. get/put stay the Map pair: get returns (Option V) and is deliberately not a place. nth-gone.flan pins the removal -- it has to fail as a name nobody defined, not quietly resolve to at again. destructure~nth is compiler-generated and unrelated.
1601 lines
76 KiB
OCaml
1601 lines
76 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";
|
|
(* nth is gone, not renamed: it has to fail as a name nobody defined. If it
|
|
were ever re-added as an alias of [at] it would have to be a place too,
|
|
and this row is what says so. *)
|
|
refuses "nth is not a name" "programs/nth-gone.flan"
|
|
"unknown function nth";
|
|
|
|
(* ── 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;
|
|
|
|
(* -- Source-level debugging: DWARF, and whether it is true ---------
|
|
The whole of this section is about one risk. A Flan struct is its C
|
|
struct and lldb needs to learn nothing about the data model, which is
|
|
what makes DWARF cheap here; but !DIDerivedType takes its member offset
|
|
as an integer literal, so those offsets are the one layout number the
|
|
backend works out for itself instead of handing to LLVM. A wrong one
|
|
does not crash: it prints a plausible value for the wrong field, which
|
|
is the failure this project has met over and over at the FFI boundary.
|
|
|
|
So the offsets are not checked against a table written by the same hand
|
|
as the code. They are checked against LLVM's own answer for the same
|
|
struct type — ptrtoint of a getelementptr through a null pointer, which
|
|
is exactly the idiom Emit already uses for the size it passes to
|
|
flan_dev_global — constant-folded by llc into a .quad and read back.
|
|
And the whole thing is run twice over the same struct with its fields
|
|
permuted, because a check that cannot come out differently is not
|
|
checking anything. *)
|
|
|
|
(* Small text tools, since there is no Str and the reader is hand-written
|
|
for the same reason. *)
|
|
let lines_of s = String.split_on_char '\n' s in
|
|
let index_of hay needle =
|
|
let n = String.length needle and h = String.length hay in
|
|
let rec go i =
|
|
if i + n > h then -1 else if String.sub hay i n = needle then i else go (i + 1)
|
|
in
|
|
go 0
|
|
in
|
|
(* The value of [key: ] in a metadata node, up to the next , or ). *)
|
|
let attr line key =
|
|
let k = key ^ ": " in
|
|
match index_of line k with
|
|
| -1 -> None
|
|
| i ->
|
|
let i = i + String.length k in
|
|
let j = ref i in
|
|
let n = String.length line in
|
|
while !j < n && line.[!j] <> ',' && line.[!j] <> ')' do incr j done;
|
|
Some (String.sub line i (!j - i))
|
|
in
|
|
(* [elements: !{!12, !13}] — the value has commas in it, so it needs its
|
|
own reader rather than [attr]'s stop-at-the-next-comma. *)
|
|
let attr_ids line key =
|
|
let k = key ^ ": !{" in
|
|
match index_of line k with
|
|
| -1 -> []
|
|
| i ->
|
|
let i = i + String.length k in
|
|
let j = ref i and n = String.length line in
|
|
while !j < n && line.[!j] <> '}' do incr j done;
|
|
String.sub line i (!j - i)
|
|
|> String.split_on_char ','
|
|
|> List.filter_map (fun t ->
|
|
let t = String.trim t in
|
|
if String.length t > 1 && t.[0] = '!' then
|
|
int_of_string_opt (String.sub t 1 (String.length t - 1))
|
|
else None)
|
|
in
|
|
let unquote s =
|
|
let n = String.length s in
|
|
if n >= 2 && s.[0] = '"' && s.[n - 1] = '"' then String.sub s 1 (n - 2) else s
|
|
in
|
|
(* The parameter names come down from the driver, exactly as [bin/main.ml]
|
|
sends them: the typed IR does not carry them. *)
|
|
let pnames_of decls =
|
|
List.filter_map
|
|
(fun (d : Ast.decl) ->
|
|
match d.Ast.d with
|
|
| Ast.Defn fn ->
|
|
Some (fn.Ast.name,
|
|
List.map (fun (f : Ast.field) -> f.Ast.fname) fn.Ast.params)
|
|
| _ -> None)
|
|
decls
|
|
in
|
|
let debug_ir src =
|
|
let decls = Parse.program (Reader.read_all ~file:"<dwarf-test>" src) in
|
|
Emit.program ~debug:true ~pnames:(pnames_of decls) (Check.program decls)
|
|
in
|
|
(* Every (member name, byte offset) of a named struct, in declaration
|
|
order, as the emitted DWARF states it. *)
|
|
let dwarf_members ir sname =
|
|
let ls = lines_of ir in
|
|
let node id =
|
|
List.find_opt
|
|
(fun l -> String.starts_with ~prefix:(Printf.sprintf "!%d = " id) l) ls
|
|
in
|
|
let composite =
|
|
List.find_opt
|
|
(fun l ->
|
|
index_of l "!DICompositeType(tag: DW_TAG_structure_type" >= 0
|
|
&& attr l "name" = Some (Printf.sprintf "\"%s\"" sname))
|
|
ls
|
|
in
|
|
match composite with
|
|
| None -> None
|
|
| Some c ->
|
|
let ids = attr_ids c "elements" in
|
|
Some
|
|
((List.filter_map
|
|
(fun id ->
|
|
match node id with
|
|
| None -> None
|
|
| Some l ->
|
|
(match attr l "name", attr l "offset" with
|
|
| Some n, Some o ->
|
|
Some (unquote n, int_of_string (String.trim o) / 8)
|
|
| _ -> None))
|
|
ids),
|
|
(match attr c "size" with
|
|
| Some sz -> int_of_string (String.trim sz) / 8
|
|
| None -> -1))
|
|
in
|
|
(* LLVM's own answer, for the same struct type text the DWARF describes.
|
|
The type definitions are lifted straight out of the emitted module, so
|
|
there is no second spelling of the layout to get wrong. *)
|
|
let llvm_members ir sname nfields =
|
|
let tydefs =
|
|
lines_of ir
|
|
|> List.filter (fun l ->
|
|
String.length l > 0 && l.[0] = '%' && index_of l " = type " >= 0)
|
|
in
|
|
let sty = Printf.sprintf "%%\"%s\"" sname in
|
|
let b = Buffer.create 512 in
|
|
List.iter (fun l -> Buffer.add_string b (l ^ "\n")) tydefs;
|
|
for i = 0 to nfields - 1 do
|
|
Buffer.add_string b
|
|
(Printf.sprintf
|
|
"@o%d = constant i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 0, i32 %d) to i64)\n"
|
|
i sty i)
|
|
done;
|
|
Buffer.add_string b
|
|
(Printf.sprintf
|
|
"@sz = constant i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64)\n"
|
|
sty);
|
|
let ll = Filename.concat scratch "flan-dwarf-oracle.ll" in
|
|
let asm = Filename.concat scratch "flan-dwarf-oracle.s" in
|
|
Out_channel.with_open_bin ll (fun ch -> Out_channel.output_string ch (Buffer.contents b));
|
|
let llc = try Sys.getenv "FLAN_LLC" with Not_found -> "llc" in
|
|
let code =
|
|
Sys.command
|
|
(Printf.sprintf "%s -filetype=asm %s -o %s > /dev/null 2>&1"
|
|
(Filename.quote llc) (Filename.quote ll) (Filename.quote asm))
|
|
in
|
|
if code <> 0 then None
|
|
else begin
|
|
let text = In_channel.with_open_bin asm In_channel.input_all in
|
|
(try Sys.remove ll with Sys_error _ -> ());
|
|
(try Sys.remove asm with Sys_error _ -> ());
|
|
(* llc writes the folded constant as ".quad 0+24" — a sum, because the
|
|
null base is still a symbolic zero to the assembler. *)
|
|
let pending = ref "" and acc = ref [] in
|
|
List.iter
|
|
(fun l ->
|
|
let t = String.trim l in
|
|
if String.length t > 1 && t.[String.length t - 1] = ':' then
|
|
pending := String.sub t 0 (String.length t - 1)
|
|
else if index_of t ".quad" >= 0 && !pending <> "" then begin
|
|
let v = String.trim (String.sub t 5 (String.length t - 5)) in
|
|
let v = match index_of v "#" with -1 -> v | i -> String.sub v 0 i in
|
|
let n =
|
|
String.split_on_char '+' v
|
|
|> List.fold_left
|
|
(fun a part ->
|
|
match int_of_string_opt (String.trim part) with
|
|
| Some x -> a + x
|
|
| None -> a)
|
|
0
|
|
in
|
|
acc := (!pending, n) :: !acc;
|
|
pending := ""
|
|
end)
|
|
(lines_of text);
|
|
Some (List.rev !acc)
|
|
end
|
|
in
|
|
(* The case itself: the DWARF a source text produces must agree with LLVM
|
|
on every member's offset, and on the struct's size. *)
|
|
let layout_case name src sname fields =
|
|
let ir = debug_ir src in
|
|
match dwarf_members ir sname with
|
|
| None ->
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n no DWARF type for %s\n" name sname
|
|
| Some (members, size) ->
|
|
let got = List.map fst members in
|
|
if got <> fields then begin
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n DWARF members: %s\n wanted: %s\n"
|
|
name (String.concat " " got) (String.concat " " fields)
|
|
end;
|
|
(match llvm_members ir sname (List.length fields) with
|
|
| None ->
|
|
(* No llc is a reason to skip the oracle, not to pass silently. *)
|
|
Printf.printf "acceptance: %s — llc unavailable, offsets unchecked\n" name
|
|
| Some oracle ->
|
|
List.iteri
|
|
(fun i (fname, off) ->
|
|
match List.assoc_opt (Printf.sprintf "o%d" i) oracle with
|
|
| None -> ()
|
|
| Some want ->
|
|
if off <> want then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL %s\n %s.%s at byte %d in the DWARF, %d in LLVM\n"
|
|
name sname fname off want
|
|
end)
|
|
members;
|
|
(match List.assoc_opt "sz" oracle with
|
|
| Some want when want <> size ->
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL %s\n %s is %d bytes in the DWARF, %d in LLVM\n"
|
|
name sname size want
|
|
| _ -> ()));
|
|
()
|
|
in
|
|
let cell = "(defstruct Cell [alive bool heat f64 id i32 name string])\n" in
|
|
let cell' = "(defstruct Cell [name string id i32 alive bool heat f64])\n" in
|
|
let body = "(defn main [] i32 (let [c (Cell {:id 1})] (i32 (.id c))))\n" in
|
|
layout_case "DWARF offsets agree with LLVM: a mixed struct" (cell ^ body)
|
|
"Cell" [ "alive"; "heat"; "id"; "name" ];
|
|
(* The same struct, permuted. If the offsets came from anywhere but the
|
|
declaration order they would survive this, and they do not. *)
|
|
layout_case "DWARF offsets agree with LLVM: the same fields permuted"
|
|
(cell' ^ body) "Cell" [ "name"; "id"; "alive"; "heat" ];
|
|
layout_case "DWARF offsets agree with LLVM: nesting and fixed arrays"
|
|
("(defstruct P [x i32 y i32])\n\
|
|
(defstruct Board [tag u8 cells [4 P] here P edge (Ptr P) seen (Option i64)])\n\
|
|
(defn main [] i32 (let [b (Board {:tag 1})] (i32 (.tag b))))\n")
|
|
"Board" [ "tag"; "cells"; "here"; "edge"; "seen" ];
|
|
|
|
(* Permuting the fields must actually move them. Asserting that the two
|
|
orderings disagree is what makes the two cases above a test: an offset
|
|
table that ignored declaration order would satisfy both. *)
|
|
(match dwarf_members (debug_ir (cell ^ body)) "Cell",
|
|
dwarf_members (debug_ir (cell' ^ body)) "Cell" with
|
|
| Some (a, _), Some (b, _) ->
|
|
let off l n = List.assoc_opt n l in
|
|
if List.for_all (fun n -> off a n = off b n) [ "alive"; "heat"; "id"; "name" ]
|
|
then begin
|
|
incr failures;
|
|
print_endline
|
|
"FAIL permuting a defstruct left every DWARF offset unchanged"
|
|
end
|
|
| _ ->
|
|
incr failures;
|
|
print_endline "FAIL permuting a defstruct: no DWARF type for Cell");
|
|
|
|
(* A slot's *type* has to be right too, not only where it sits. These are
|
|
the shapes lldb has to render, and the layout table says what each one
|
|
weighs; a wrong size there is a truncated or over-read value. *)
|
|
let ir = debug_ir (cell ^ body) in
|
|
List.iter
|
|
(fun (needle, what) ->
|
|
if not (contains ir needle) then begin
|
|
incr failures;
|
|
Printf.printf "FAIL DWARF for %s\n wanted: %S\n" what needle
|
|
end)
|
|
[ ("!DIBasicType(name: \"i32\", size: 32, encoding: DW_ATE_signed)", "i32");
|
|
("!DIBasicType(name: \"u8\", size: 8, encoding: DW_ATE_unsigned)", "u8");
|
|
("!DIBasicType(name: \"f64\", size: 64, encoding: DW_ATE_float)", "f64");
|
|
(* A byte in memory, not a bit: an i1 alloca is one byte wide. *)
|
|
("!DIBasicType(name: \"bool\", size: 8, encoding: DW_ATE_boolean)", "bool");
|
|
(* ptr+len, and shown as ptr+len — there is no owner and no capacity
|
|
to hide, so two members are the whole truth about a string. *)
|
|
("name: \"string\", size: 128", "string");
|
|
(* A let-bound local has no name to keep: the typed IR refers to
|
|
slots by index and [Check] drops what they were called, so it is
|
|
emitted as the slot it is. Asserted rather than left implicit,
|
|
because this is the one honest gap in the picture. *)
|
|
("!DILocalVariable(name: \"s0\"", "a let-bound local, named by its slot");
|
|
("!llvm.dbg.cu = ", "the compile unit is registered");
|
|
(* Without this LLVM discards every node above, silently. *)
|
|
("!{i32 2, !\"Debug Info Version\", i32 3}", "the module flag") ];
|
|
|
|
(* Parameters carry the name the source gave them. The typed IR does not
|
|
record it — [Check] has it and drops it — so this is the driver handing
|
|
the names down, and it is worth a test because the path is easy to
|
|
forget when either end changes. *)
|
|
let ir =
|
|
debug_ir "(defn dist [ax f64 ay f64] f64 (+ ax ay))\n\
|
|
(defn main [] i32 (i32 (i64 (dist 1.0 2.0))))\n"
|
|
in
|
|
List.iter
|
|
(fun needle ->
|
|
if not (contains ir needle) then begin
|
|
incr failures;
|
|
Printf.printf "FAIL parameter names in DWARF\n wanted: %S\n" needle
|
|
end)
|
|
[ "!DILocalVariable(name: \"ax\", arg: 1"; "!DILocalVariable(name: \"ay\", arg: 2" ];
|
|
(* The transfer channel is a parameter of every Flan function and is not a
|
|
Flan name, so it gets no variable at all — and must not, or it would
|
|
take arg: 1 and shift every real parameter's storage by one. *)
|
|
if contains ir "name: \"xfer\"" then begin
|
|
incr failures;
|
|
print_endline "FAIL the transfer channel appeared as a local variable"
|
|
end;
|
|
|
|
(* LLVM's own verifier, over both entry points. String needles cannot see
|
|
a DISubprogram the compile unit does not reach, or a call without a
|
|
!dbg inside a function that has debug info — and that second one is a
|
|
hard rejection, not a warning, so it would turn every debug build into
|
|
a clang error rather than into anything visible here.
|
|
|
|
[redefinition] is the half that needs this most. It is only ever run at
|
|
the default debug:false today, and it differs from [program] in exactly
|
|
the places metadata goes wrong: hidden bodies, the by-name cell and
|
|
global loads, and flan_reload_install and flan_reload_call, which are
|
|
raw defines with no subprogram that nonetheless contain calls. *)
|
|
if Sys.command "command -v opt > /dev/null 2>&1" = 0 then begin
|
|
let verifies name ir =
|
|
let f = Filename.concat scratch "flan-dwarf-verify.ll" in
|
|
Out_channel.with_open_bin f (fun ch -> Out_channel.output_string ch ir);
|
|
let log = Filename.concat scratch "flan-dwarf-verify.log" in
|
|
let code =
|
|
Sys.command
|
|
(Printf.sprintf "opt -passes=verify -disable-output %s > %s 2>&1"
|
|
(Filename.quote f) (Filename.quote log))
|
|
in
|
|
if code <> 0 then begin
|
|
incr failures;
|
|
Printf.printf "FAIL %s: LLVM's verifier rejected the module\n%s\n" name
|
|
(In_channel.with_open_bin log In_channel.input_all)
|
|
end;
|
|
(try Sys.remove f with Sys_error _ -> ());
|
|
(try Sys.remove log with Sys_error _ -> ())
|
|
in
|
|
(* A program with a bit of everything that emits a call the backend
|
|
invents rather than one a Tast node asked for: a bounds check, a
|
|
condition signalled and handled, a restart transferred to, a defer on
|
|
the way out. Each would be a verifier rejection without a location. *)
|
|
let src =
|
|
"(defstruct Missing [id i32])\n\
|
|
(defvar seen i64)\n\
|
|
(defvar arr [4 i32])\n\
|
|
(defn pick [xs [i32] i i32] i32 (at xs i))\n\
|
|
(defn fetch [n i32] i32\n\
|
|
\ (restart-case\n\
|
|
\ (do (error (Missing {:id n})) 0)\n\
|
|
\ (use-placeholder [] -1)))\n\
|
|
(defn run [] i32\n\
|
|
\ (defer (set seen (+ seen 1)))\n\
|
|
\ (handler-bind [(Missing [m] (invoke-restart 'use-placeholder))]\n\
|
|
\ (fetch 3)))\n\
|
|
(defn main [] i32\n\
|
|
\ (set (at arr 2) 9)\n\
|
|
\ (let [s (slice arr 0 4)]\n\
|
|
\ (print-i64 (i64 (pick s 2))) (newline)\n\
|
|
\ (print-i64 (i64 (run))) (newline)\n\
|
|
\ 0))\n"
|
|
in
|
|
let decls = Parse.program (Reader.read_all ~file:"<verify>" src) in
|
|
let p = Check.program decls in
|
|
verifies "the whole program, with debug info"
|
|
(Emit.program ~debug:true ~pnames:(pnames_of decls) p);
|
|
(* And a redefinition module against a host that has every name — the
|
|
shape C-c C-c produces. *)
|
|
verifies "a redefinition module, with debug info"
|
|
(Emit.redefinition ~dev:true ~debug:true ~known:(fun _ -> true) p
|
|
~fns:[ "fetch"; "run" ]);
|
|
(* And one against a host that has none of them, which is the other
|
|
path: every call goes through flan_dev_cell and every global through
|
|
flan_dev_global, so the module is almost entirely different code. *)
|
|
verifies "a redefinition of names the host does not have"
|
|
(Emit.redefinition ~dev:true ~debug:true ~known:(fun _ -> false) p
|
|
~fns:[ "fetch"; "run" ])
|
|
end
|
|
else print_endline "acceptance: the DWARF verifier cases skipped (no opt)";
|
|
|
|
(* A debug build and a release build must still be the same program. *)
|
|
let debug_compile ?(dev = false) path =
|
|
let exe =
|
|
Filename.concat scratch
|
|
("flan-dbg-" ^ Filename.remove_extension (Filename.basename path)
|
|
^ if dev then "-dev" else "")
|
|
in
|
|
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
|
|
let p = Check.program l.Load.decls in
|
|
let pnames =
|
|
List.filter_map
|
|
(fun (d : Ast.decl) ->
|
|
match d.Ast.d with
|
|
| Ast.Defn fn ->
|
|
Some (fn.Ast.name,
|
|
List.map (fun (f : Ast.field) -> f.Ast.fname) fn.Ast.params)
|
|
| _ -> None)
|
|
l.Load.decls
|
|
in
|
|
let p, csrcs, lflags = Reach.link ~dev l p in
|
|
ignore
|
|
(Build.executable ~opts:{ Build.default with debug = true; dev }
|
|
~csrcs ~lflags ~pnames p ~out:exe);
|
|
exe
|
|
in
|
|
let expected = "42\n4.75\n42\ngrain\n" in
|
|
List.iter
|
|
(fun path ->
|
|
let exe = debug_compile path in
|
|
let code, text = run exe None in
|
|
if text <> expected || code <> 0 then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL a --debug build of %s runs the same\n got: %S (exit %d)\n wanted: %S\n"
|
|
path text code expected
|
|
end)
|
|
[ "programs/debug.flan"; "programs/debug-permuted.flan" ];
|
|
|
|
(* wasm32 is refused by name. The offsets above are the host's, and
|
|
wasm32's 32-bit pointer moves every slice member; emitting them anyway
|
|
would give a debugger a confident wrong answer. *)
|
|
(match
|
|
Build.executable
|
|
~opts:{ Build.default with debug = true; target = Some "wasm32-wasi" }
|
|
{ Tast.structs = []; unions = []; globals = []; externs = []; fns = [];
|
|
cshim = [] }
|
|
~out:(Filename.concat scratch "flan-dbg-wasm")
|
|
with
|
|
| _ ->
|
|
incr failures;
|
|
print_endline "FAIL --debug --target=wasm32-wasi was accepted"
|
|
| exception Failure m ->
|
|
if not (contains m "--debug is native only") then begin
|
|
incr failures;
|
|
Printf.printf "FAIL --debug on wasm32\n said: %S\n" m
|
|
end);
|
|
|
|
(* -- lldb, for real ------------------------------------------------
|
|
Everything above is about the metadata being self-consistent. This is
|
|
the only part that says a person can debug a Flan program: a breakpoint
|
|
set on a Flan function *by name*, a backtrace with .flan files and line
|
|
numbers, and locals printed with their own types and values. It is
|
|
skipped rather than failed where there is no lldb. *)
|
|
if Sys.command "command -v lldb > /dev/null 2>&1" = 0 then begin
|
|
let lldb_run exe cmds =
|
|
let out = Filename.concat scratch "flan-lldb.out" in
|
|
let code =
|
|
Sys.command
|
|
(Printf.sprintf "lldb -b %s %s > %s 2>&1"
|
|
(String.concat " "
|
|
(List.map (fun c -> "-o " ^ Filename.quote c) cmds))
|
|
(Filename.quote exe) (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
|
|
let lldb_case name path needles =
|
|
let exe = debug_compile path in
|
|
let _, text =
|
|
lldb_run exe
|
|
[ "breakpoint set --name flan.tick"; "run"; "bt"; "frame variable";
|
|
"p *c" ]
|
|
in
|
|
List.iter
|
|
(fun n ->
|
|
if not (contains text n) then begin
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n wanted %S in lldb's output\n"
|
|
name n;
|
|
print_endline text
|
|
end)
|
|
needles
|
|
in
|
|
(* The four claims, one needle each: the breakpoint resolved on a Flan
|
|
name; the frame names a .flan file and a line inside tick; the caller
|
|
is the Flan main and not a C frame; a parameter prints by its source
|
|
name; and the struct through the pointer prints every field with the
|
|
value the program put there. *)
|
|
lldb_case "lldb: breakpoint, frames and locals" "programs/debug.flan"
|
|
[ "flan.tick"; "at debug.flan:"; "flan.main at debug.flan:";
|
|
"(int) n = 41"; "alive = true"; "heat = 3.25"; "id = 7"; "len = 5" ];
|
|
(* And the same, with the fields permuted. If the offsets were not
|
|
following the declaration, the values would land on the wrong names
|
|
here and nowhere else. *)
|
|
lldb_case "lldb: the same struct with its fields permuted"
|
|
"programs/debug-permuted.flan"
|
|
[ "at debug-permuted.flan:"; "flan.main at debug-permuted.flan:";
|
|
"(int) n = 41"; "alive = true"; "heat = 3.25"; "id = 7"; "len = 5" ];
|
|
(* A dev build routes every call through a cell, so the call site is an
|
|
indirect call through a mutable global. The frame above it is still
|
|
the Flan caller with its own line: the indirection is in how the
|
|
callee is found, not in how the frame is laid out, so nothing about
|
|
unwinding changes. Worth pinning, because "the stack goes missing
|
|
under --dev" would be the sort of thing found late. *)
|
|
let exe = debug_compile ~dev:true "programs/debug.flan" in
|
|
let _, text =
|
|
lldb_run exe [ "breakpoint set --name flan.tick"; "run"; "bt" ]
|
|
in
|
|
List.iter
|
|
(fun n ->
|
|
if not (contains text n) then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL lldb: --dev --debug keeps the Flan stack\n wanted %S\n"
|
|
n;
|
|
print_endline text
|
|
end)
|
|
[ "flan.tick"; "flan.main at debug.flan:" ]
|
|
end
|
|
else print_endline "acceptance: lldb cases skipped (no lldb on PATH)";
|
|
|
|
(* ── Strings: UTF-8, the split cursor, and ASCII case ──────────────
|
|
|
|
The prelude's port of Odin's core/unicode/utf8, which is the only part
|
|
of a string library that needs no allocator. The valid decodes prove
|
|
almost nothing on their own — a decoder that just masks and shifts gets
|
|
every one of them right — so the test is the malformed group: an
|
|
overlong two- and three-byte "/", a UTF-16 surrogate, a code point past
|
|
U+10FFFF, a lead byte that leads nothing, a lone continuation byte, and
|
|
a valid character truncated by the end of its slice. Each isolates one
|
|
row of the accept_sizes table, and each answers width 1 so that a scan
|
|
makes progress rather than hanging.
|
|
|
|
Encoding is checked by round trip rather than against expected bytes,
|
|
because an encoder and a decoder that are wrong in the same direction
|
|
agree with each other and disagree with nothing else.
|
|
|
|
At -O0 as well, for the reason the slice algorithms run there: a slice
|
|
is a two-word struct through an alloca, decode-rune returns a struct by
|
|
value, and the split cursor is mutated through a (Ptr Split) — mem2reg
|
|
is exactly what would hide any of those being copied when it should be
|
|
shared. *)
|
|
let utf8_out =
|
|
"0/0/f 65/1/t 233/2/t 26085/3/t 128512/4/t \n\
|
|
0/1/f 0/1/f 0/1/f 0/1/f 0/1/f 0/1/f 0/1/f \n\
|
|
0/1/f 0/1/f 0/1/f 0/1/f \n\
|
|
tft\n\
|
|
0 3 8 13 3\n\
|
|
ttffft\n\
|
|
26085 26412 -1 -1 -1 \n\
|
|
-1 1 1 2 2 3 3 -1 -1 3 3 4 4 -1 \n\
|
|
0 65 127 128 2047 2048 65535 65536 1114111 \n\
|
|
-1 -1 -1 -1 -1 1 \n\
|
|
65 -1 65 -1 65 \n\
|
|
[a][b][c] [a][][b] [abc] [] [][] [][a] [a][] \n\
|
|
60\n\
|
|
97 122 97 64 91 65 90 65 96 123 53 \n\
|
|
195 195 \n\
|
|
tftfft\n"
|
|
in
|
|
outputs "utf-8, splitting and ascii case" "programs/utf8.flan" utf8_out;
|
|
outputs ~opt:"-O0" "utf-8, splitting and ascii case, -O0"
|
|
"programs/utf8.flan" utf8_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)"
|