Joseph Ferano
4f0b1012e8
Found by a read-only audit of emit.ml's failwith sites, each of which is a claim
that the checker guarantees something. Three of those claims were false, and
every one failed in the shape NEXT.md calls the worst available: type checks,
then dies with no source location.
An enum comparison is lowered now rather than refused. Types.is_comparable
already admits an enum, so the checker was stating an intent the backend never
honoured - (= k :a) is the first thing anyone writes with an enum, and it raised
Failure("comparison on K"). An enum is an i32 at run time, so all six
operators are an icmp. Signed, because (defenum K [a -1]) is accepted and an
unsigned compare would call -1 the largest member.
A union in a type position is refused instead. Constructing a union value and
reading a field of one were already refused, so nothing could ever be done with
such a value - only the declaration got through, and it reached clang as a
reference to an undefined %"U", which is a link error naming an emitted symbol
with the source location long gone.
A function type annotation is refused too. The function *value* was refused
where it is written; the annotation was refused nowhere, so (defn f [g (Fn []
i32)]) died with "no layout for". It now sits beside the Map line directly
above it, which is the same shape of not-yet.
The audit also found the sentence that covered the last two: NEXT.md and
check.ml's header both claim unions and function values are rejected by name.
That is true of values and false of types, which is exactly the gap the two
findings lived in.
720 lines
34 KiB
OCaml
720 lines
34 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)";
|
|
|
|
(* Again at -O0. Everything above runs through mem2reg, which launders a
|
|
sloppy alloca; -O0 tests the IR actually emitted, so a disagreement
|
|
between the two points at undefined behaviour rather than a typo. *)
|
|
(* sand.flan's simulation, headless. This is the milestone-4 acceptance
|
|
case: N frames from a seeded PRNG, one hash. It imports the sim package
|
|
and not raylib, deliberately — a program that imports raylib links
|
|
libraylib on every target, and this one is the version meant to run on
|
|
wasm32 too. The hash is reproducible only because rand-f32 is ours. *)
|
|
let sand_out = "2256461126764447066\n" in
|
|
outputs "sand, headless" "programs/sand-headless.flan" sand_out;
|
|
outputs ~opt:"-O0" "sand, headless, -O0" "programs/sand-headless.flan" sand_out;
|
|
|
|
outputs ~opt:"-O0" "value semantics, -O0" "programs/values.flan" values_out;
|
|
outputs ~opt:"-O0" "machine surface, -O0" "programs/machine.flan" machine_out;
|
|
|
|
(* And once more as a dev build. Every call in one goes through a cell, so
|
|
this is the same table asserting the indirection changes nothing before
|
|
anything has been redefined — the sand hash especially, since it is the
|
|
one result that would notice a call reaching the wrong function. *)
|
|
outputs ~dev:true "sand, headless, dev" "programs/sand-headless.flan" sand_out;
|
|
outputs ~dev:true "value semantics, dev" "programs/values.flan" values_out;
|
|
outputs ~dev:true "machine surface, dev" "programs/machine.flan" machine_out;
|
|
|
|
(* Bounds checks, NEXT.md item 2. A trap has no result — it has a nonzero
|
|
exit and a message on stderr — so it needs a case shape the table above
|
|
does not have. What is asserted is the *reason*: the location, and which
|
|
index against which length. The line and column are not pinned, because
|
|
editing the program should not break the test that reads it. *)
|
|
let bounds ?opt () =
|
|
let exe = compile ?opt "programs/bounds.flan" in
|
|
let traps name arg reason =
|
|
let code, text = run exe (Some arg) in
|
|
if code <> 134
|
|
|| not (contains text "programs/bounds.flan:")
|
|
|| not (contains text reason)
|
|
then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 134)\n"
|
|
name text code reason
|
|
end
|
|
in
|
|
(* Both edges are in bounds and must not trap: the last index of a fixed
|
|
array, a slice ending exactly at len, and an empty slice at len. *)
|
|
let code, text = run exe (Some "0") in
|
|
if text <> "0ello\n" || code <> 0 then begin
|
|
incr failures;
|
|
Printf.printf "FAIL in-bounds edges\n got: %S (exit %d)\n" text code
|
|
end;
|
|
traps "at past a fixed array" "3"
|
|
"index 3 is out of bounds for length 3";
|
|
(* Negative indices sext to a huge unsigned, so the one unsigned
|
|
comparison catches them; the message still reports the signed value. *)
|
|
traps "at with a negative index" "-1"
|
|
"index -1 is out of bounds for length 3";
|
|
traps "at past a slice" "9"
|
|
"index 9 is out of bounds for length 5";
|
|
(* A different lowering — place/Pindex, not At — so it is its own case. *)
|
|
traps "set past a fixed array" "7"
|
|
"index 7 is out of bounds for length 3";
|
|
traps "slice with hi past len" "4"
|
|
"slice [4 9) is out of bounds for length 5";
|
|
(* Without the lo <= hi test this one would not trap: it would build a
|
|
slice of length hi - lo as a huge unsigned, which is worse. *)
|
|
traps "slice with a reversed range" "2"
|
|
"slice [2 1) is out of bounds for length 5";
|
|
(try Sys.remove exe with Sys_error _ -> ())
|
|
in
|
|
bounds ();
|
|
bounds ~opt:"-O0" ();
|
|
|
|
(* The release build drops them — the calls, that is; the two declarations
|
|
stay in the header and LLVM discards the unused ones. Asserted on the IR
|
|
rather than by running an unchecked out-of-bounds program, which has no
|
|
defined behaviour to assert on. *)
|
|
let p =
|
|
Reader.read_file "programs/bounds.flan" |> Parse.program |> Check.program
|
|
in
|
|
if not (contains (Emit.program p) "call void @flan_bounds_fail(") then begin
|
|
incr failures;
|
|
print_endline "FAIL checks on: no bounds call emitted"
|
|
end;
|
|
let off = Emit.program ~checks:false p in
|
|
if contains off "call void @flan_bounds_fail(" || contains off "call void @flan_slice_fail(" then begin
|
|
incr failures;
|
|
print_endline "FAIL --no-bounds-checks: a check survived"
|
|
end;
|
|
|
|
(* ── 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;
|
|
|
|
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)"
|