Joseph Ferano
c5b8af23a1
Five more: file-exists?, file-size, delete-file, rename-file and make-directory. The interesting thing is not the list, it is the line drawn through it. file-exists? and file-size answer a value -- a bool and an (Option i64) -- and are prelude functions over one declare that the compiler knows nothing about. Absence is the reply to those two questions and not a fault, so a condition would make the ordinary case pay for a handler search, and there is no restart a handler could take that would turn "it is not there" into a different answer. delete-file, rename-file and make-directory answer () and signal FileError, and they are check.ml builtins for the one thing a declare cannot do: they go through file_guard, so each failure arrives under retry and use-value. Those are restarts a handler really can take -- make the parent directory and retry, or supply another path -- which is exactly the case a bool return throws away. op continues the prelude's numbering as 2, 3 and 4. One C function behind the two questions rather than two, because they are one question: stat answers whether the path resolves and how big it is in the same breath. It is stat and not flan_file_size's fopen-plus-ftell, which is shaped by slurp being about to read the file and is wrong as a general size -- fopen on a directory succeeds on Linux and ftell then answers a number that is not a file size. The two coexist and answer different questions. rename holds the source in the guard's path slot, so a use-value renames a different file to the same destination. Both readings are plausible until somebody says which, so check.ml says which. The errno mapping is not extended. Its three buckets are what a handler can act on; EEXIST and ENOTEMPTY land in io with everything else, and that is honest until conditions have a hierarchy to hang a fourth reason off. All three carry barf's decision 2 unchanged: they change the filesystem, so on the web they signal rather than succeeding quietly into a filesystem the page throws away. Not here, and not half-parsed either: a directory listing, which needs an allocating builtin and a Vec of owned strings, and streaming IO. Neither has a name to trip over. programs/files.flan makes and removes its own tree and takes both restarts on operations that write. The runtime additions continue the block at the end of flan_rt.c.
3736 lines
189 KiB
OCaml
3736 lines
189 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
|
|
|
|
(* The watchdog first: a hang is the one failure mode that reports
|
|
nothing at all. See watchdog.ml. *)
|
|
let () = Watchdog.arm ~seconds:1200 "test_acceptance"
|
|
|
|
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 (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";
|
|
(* A global of move-only type, which this compiler used to refuse outright.
|
|
What the numbers assert is the half of the rule no checker test can: the
|
|
global is loaded once and *stays* loaded across a second entry, which is
|
|
what a re-entered main needs, and the mutations land on the global
|
|
itself rather than on a copy of its header — the second run's length is
|
|
the first run's plus one, and the count after cloning and freeing the
|
|
clone is still the global's. *)
|
|
outputs "a global Vec" "programs/vec-global.flan"
|
|
"6\n131\n131\n7\n232\n232\n7\n7\n7\n";
|
|
(* (array COUNT TYPE). Every line of it is a [let] binding, which is the
|
|
one position with no type slot and the whole reason the form exists. *)
|
|
outputs "array constructor" "programs/array-ctor.flan" "4\n0\n7\n9\n4\n";
|
|
(* break and continue. The dotimes/continue case is the one that fails by
|
|
hanging rather than by printing the wrong thing — the step is the loop's
|
|
latch, and folded onto the body a continue would jump past it — so the
|
|
watchdog above is what turns that failure back into a report. *)
|
|
outputs "break and continue" "programs/loops.flan"
|
|
"4\n9\n8\n3\n0\n1\n0\n0\n0\n3\n6\nhit\nhit\n2\n";
|
|
(* loop and recur. The ten-million line is the one that matters: a recur is
|
|
a jump to the top of a [While] and not a call, so the program returns
|
|
rather than running out of stack. The swap line is the other — recur
|
|
rebinds every name at once, and interleaved writes would print 1. *)
|
|
outputs "loop and recur" "programs/recur.flan"
|
|
"10\n2\n21\n8\n10000000\n64\n012\n0\n4\n012\n6\n";
|
|
(* into. The count of pulls is the assertion a unit test cannot make: one
|
|
pass, one call per element per stage it reaches, and no intermediate
|
|
collection anywhere. The two show lines either side of it are the same
|
|
source transformed in two orders, which have to differ. *)
|
|
outputs "into" "programs/into.flan"
|
|
"7 8 9 \n2 4 6 8 10 12 \n4 8 12 \n21\n6 2 4 \n3 1 2 \n3 4 \n2 4 \n1\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
|
|
(* (slice-from-ptr p n) — NEXT.md, "a pointer from C needs a length before
|
|
it can be indexed". The pointers that motivated it come from C, but the
|
|
form does not care where one came from, so this case makes its own and
|
|
needs no library: what it pins is that the result is an ordinary [T] —
|
|
it has the promised length, it indexes, it slices, it passes to a
|
|
function that takes a slice — and that it is a *view*, so the last two
|
|
lines write through it and read the array back. The refusals are in
|
|
test_flan.ml and the negative-length trap is in programs/bounds.flan. *)
|
|
let sfp_out = "5\n10\n50\n150\n50\n2\n50\n0\n7\n127\n" in
|
|
outputs "slice-from-ptr" "programs/slice-from-ptr.flan" sfp_out;
|
|
outputs ~opt:"-O0" "slice-from-ptr, -O0" "programs/slice-from-ptr.flan"
|
|
sfp_out;
|
|
outputs "slice algorithms" "programs/slices.flan" slices_out;
|
|
outputs ~opt:"-O0" "slice algorithms, -O0" "programs/slices.flan" slices_out;
|
|
(* println, one row per arm of render.ml's walk. The walk is shared with
|
|
the REPL, but its only coverage was the REPL tests -- a dev build,
|
|
emitting to flan_dev_emit. This is the same walk with the other emitter
|
|
in an ordinary build, which is a path nothing else takes.
|
|
|
|
Three of these rows are load-bearing beyond "it prints something". The
|
|
u64 reads 18446744073709551615 and not -1, which is what a second shim
|
|
exists for. The Blob's name is quoted and escaped while the two strings
|
|
at the top are raw, which is the top-level/nested split and the thing
|
|
most likely to be "tidied up" into being wrong. And the Option rows are
|
|
an arm that never ran until now: a field of an Option had no gep in
|
|
emit.ml, so the REPL would have failed on one too.
|
|
|
|
At -O0 as well -- the slice arm allocates slots in the enclosing
|
|
function's frame and emits a loop, and mem2reg is the pass that would
|
|
hide a mistake in either. *)
|
|
let println_out =
|
|
"plain string\nplain bytes\n42\n-7\n5\n18446744073709551615\n3.5\n\
|
|
-0.25\ntrue\nfalse\n()\n:green\n:red\n<ptr>\n(some 0)\nnone\n\
|
|
(Blob {.id 7 .name \"sandy \\\"quoted\\\"\" .pos (V {.x 1.5 .y -2}) .tags [ 0 42 0]})\n\
|
|
[ 0 0 9 0]\n[ 0 0 0 0 0 0 0 0 ...]\n[ 0 9 0]\n\
|
|
(D1 {.d (D2 {.d (D3 {.d (D4 {.d (D5 {.n ...})})})})})\n[ 0 0]\n\
|
|
[ 0 0]\n[ 9 0]\n"
|
|
(* The escape buffer is 1024 and the input is 1100 x's, so this is the
|
|
truncation: the ellipsis goes *inside* the quotes, and the count is
|
|
spelled out rather than pasted so that a change to the buffer or to
|
|
the reserve shows up here as a number and not as a wall of x. *)
|
|
^ "(Long {.s \"" ^ String.make 1014 'x' ^ "...\"})\n"
|
|
^ "abc\n"
|
|
in
|
|
outputs "println, every arm" "programs/println.flan" println_out;
|
|
outputs ~opt:"-O0" "println, every arm, -O0" "programs/println.flan"
|
|
println_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;
|
|
(* atan2, pow and clamp. Every float here is exact in binary — quadrant
|
|
boundaries, powers of two, a perfect square — because atan2f and powf
|
|
are no more correctly rounded than sinf is, and a case pinning one
|
|
libm's last bit would pass native and fail wasi. The -O0 run is the one
|
|
that proves the two symbols resolve: at -O2 LLVM constant-folds a powf
|
|
of two literals and nothing is left to link, which is the same trap the
|
|
sqrt note describes. clamp is a macro, so the interesting lines are the
|
|
four types it is called at (a function would be four copies) and the
|
|
call counter, which is 3 and would be 4 or 5 for a macro that named an
|
|
argument twice. *)
|
|
let math2_out =
|
|
"0.785398 2.35619 -2.35619 -0.785398 0 1.5708 -1.5708 \n\
|
|
1024 3 0.25 1 5 \n\
|
|
1 3 2 1 3\n\
|
|
255 200 1 \n\
|
|
1\n\
|
|
3 3\n"
|
|
in
|
|
outputs "atan2, pow and clamp" "programs/math2.flan" math2_out;
|
|
outputs ~opt:"-O0" "atan2, pow and clamp, -O0" "programs/math2.flan"
|
|
math2_out;
|
|
(* The rest of libm, at both widths. Same rule as math2 above and for the
|
|
same reason — every value is exact in binary — and the -O0 pass is
|
|
doing the same job: at -O2 LLVM folds a libm call over two literals and
|
|
leaves no symbol to resolve, so that run is the one proving all thirty
|
|
new declares actually link. *)
|
|
let math3_out =
|
|
"0 0 0 0 0 3 3 1 \n\
|
|
3 -1 5 3 -2 2.5 \n\
|
|
4 0 1 0 0 0 0 0 \n\
|
|
0 10 2 1 1024 3 5 2 1.5 \n\
|
|
-3 -2 -3 3 \n\
|
|
7 7 7 true true\n\
|
|
true\n"
|
|
in
|
|
outputs "the rest of libm, both widths" "programs/math3.flan" math3_out;
|
|
outputs ~opt:"-O0" "the rest of libm, both widths, -O0"
|
|
"programs/math3.flan" math3_out;
|
|
(* The clock and the environment. Every line of that program's output is
|
|
an invariant — a monotonicity, a date range, a sleep that did not
|
|
return early — and not a reading, because the same file is in the
|
|
corpus @x86 builds twice and diffs, so a timestamp would fail a correct
|
|
compiler on its second run. *)
|
|
let time_out = "true\ntrue\ntrue\ntrue\ntrue\nslept\nunset\ntrue\n" in
|
|
outputs "the clock and getenv" "programs/time.flan" time_out;
|
|
outputs ~opt:"-O0" "the clock and getenv, -O0" "programs/time.flan"
|
|
time_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;
|
|
(* (string b). The conversion emits nothing — String and Slice _ are the
|
|
same %slice — so the rows are about length and ownership rather than
|
|
arithmetic: a number round-tripped, an empty slice, sub-views whose
|
|
length is not the underlying storage's, and the result crossing a
|
|
declare-c boundary where the shim NUL-terminates a copy. That last one
|
|
is the load-bearing case: "hello world" cut to five bytes has a space
|
|
where C wants a NUL, so a shim that trusted the bytes would print all
|
|
eleven. Both levels, because a reinterpretation that had accidentally
|
|
been undefined would fail one way at -O0 and the other at -O2. *)
|
|
let string_of_bytes_out =
|
|
"[42] 2\n[-7] 2\n[0] 1\n[] 0\n\
|
|
[hello] 5\n[world] 5\n[] 0\n\
|
|
7\n\
|
|
hello\nok\n12345\nok\n\nok\n"
|
|
in
|
|
outputs "string of bytes" "programs/string-of-bytes.flan" string_of_bytes_out;
|
|
outputs ~opt:"-O0" "string of bytes, -O0" "programs/string-of-bytes.flan"
|
|
string_of_bytes_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.
|
|
|
|
Then §3's parameters: one, two of them in an order a sum would not pin,
|
|
a string beside an integer, a clause taking none in the same form as
|
|
clauses taking some, and an argument that is a call to a function
|
|
reached from nowhere else. The last one is the reachability claim — an
|
|
invoke-restart whose arguments were not walked would drop [half] and
|
|
fail to link, which is why the arguments are evaluated into slots before
|
|
the node rather than hanging off it. *)
|
|
let restarts_out =
|
|
"101\n1\n-1\n2\n7\n1010\n101\n105\n-2\n42\n34\n7\nsupplied\n5\n42\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;
|
|
(* §3's run-time check, which is the price of a restart being found by name
|
|
on a dynamic stack: neither end of an invoke can see the other, so what
|
|
a clause takes against what was given is settled where the transfer
|
|
starts. Each of these stops the program, so each is asserted on its
|
|
reason rather than on the exit status alone — too few arguments, the
|
|
right count of the wrong type, and arguments handed to a clause that
|
|
takes none. *)
|
|
let restart_mismatch ?opt () =
|
|
let exe = compile ?opt "programs/restarts.flan" in
|
|
let refuses name arg reason =
|
|
let code, text = run exe (Some arg) in
|
|
if code <> 134
|
|
|| not (contains text "programs/restarts.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
|
|
refuses "a restart invoked with too few arguments" "1"
|
|
"restart use-value takes (i32), given ()";
|
|
refuses "a restart invoked with the wrong type" "2"
|
|
"restart use-value takes (i32), given (string)";
|
|
refuses "arguments given to a restart that takes none" "3"
|
|
"restart retry takes (), given (i32)";
|
|
(* §4 meets §3. The name finds the innermost frame offering it and the
|
|
signature is checked against *that*; nothing searches outward for a
|
|
frame the arguments would have fitted, and an outer clause that would
|
|
have taken them is not consulted. *)
|
|
refuses "a shadowing clause of the same name and a different signature" "4"
|
|
"restart use-value takes (string), given (i32)";
|
|
(try Sys.remove exe with Sys_error _ -> ())
|
|
in
|
|
restart_mismatch ();
|
|
restart_mismatch ~opt:"-O0" ();
|
|
(* The other way a transfer starts is the break loop, which chooses a
|
|
restart by position and has nothing to fill parameters in with. It
|
|
reaches the clause through the same channel an invoke-restart writes, so
|
|
nothing downstream could tell the two apart — except that the clause's
|
|
buffer is still the zero the frame was pushed with. Asserted on the IR,
|
|
because driving it needs a stopped program and a socket, and what is
|
|
being claimed is that the guard exists at all. *)
|
|
let p =
|
|
Reader.read_file "programs/restarts.flan" |> Parse.program |> Check.program
|
|
in
|
|
if not (contains (Emit.program p) "call void @flan_restart_unarmed(") then begin
|
|
incr failures;
|
|
print_endline
|
|
"FAIL a clause with parameters has no guard against being taken \
|
|
without any"
|
|
end;
|
|
(* What is refused before anything runs, and why. Not everything about a
|
|
restart's arguments waits for run time: the shape of the form and
|
|
whether an argument is a value at all are here, and each is asserted on
|
|
its reason. *)
|
|
let refuses_src name src needle =
|
|
match Check.program (Parse.program (Reader.read_all ~file:"<restarts>" src)) with
|
|
| _ ->
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n it was accepted\n" name
|
|
| exception Loc.Error { Loc.dmsg = 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
|
|
(* The other half of [refuses_src], for a declaration that used to be
|
|
refused and is not any more: "it compiles" is the whole claim, and a
|
|
row that only ever asserted the refusal would have been deleted rather
|
|
than inverted, which loses the record of what changed. *)
|
|
let accepts_src name src =
|
|
match Check.program (Parse.program (Reader.read_all ~file:"<accepts>" src)) with
|
|
| _ -> ()
|
|
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n it was refused: %S\n" name m
|
|
in
|
|
(* The name is still a quoted symbol, and now it is the *first* of several
|
|
things, so an unquoted one has to say what the form is rather than read
|
|
as a call with a spare argument. *)
|
|
refuses_src "invoke-restart without a quoted name"
|
|
"(defn main [] i32 (invoke-restart use-value 1) 0)"
|
|
"a quoted restart name and then its arguments";
|
|
(* A clause parameter is a binding, so it needs something to hold. *)
|
|
refuses_src "a restart parameter that is not a value"
|
|
"(defn main [] i32 (restart-case 0 (use-value [v ()] 1)))"
|
|
"which is not a value";
|
|
(* And so does an argument: a [println] is Unit, and there would be nothing
|
|
to store into the clause's buffer. *)
|
|
refuses_src "a restart argument that is not a value"
|
|
"(defn main [] i32 (restart-case 0 (use-value [v i32] v))\n\
|
|
\ (invoke-restart 'use-value (println \"\")) 0)"
|
|
"a restart argument must be a value";
|
|
(* An embed reads the bytes before any value exists, so the path has to be
|
|
a literal - Odin's rule and for Odin's reason (check_load_directive
|
|
refuses anything that is not Addressing_Constant). This is the refusal
|
|
that keeps the result genuinely free at run time. *)
|
|
refuses_src "an embedded path that is computed"
|
|
"(defn main [] i32 (let [p \"x\"] (len (embed p))))"
|
|
"must be a literal string";
|
|
(* A file that is not there is a compile error naming it, not an empty
|
|
embed: an asset silently missing is the class of quiet wrongness this
|
|
whole feature exists to remove. *)
|
|
refuses_src "an embedded file that does not exist"
|
|
"(defn main [] i32 (len (embed \"no-such-asset.bin\")))"
|
|
"cannot embed";
|
|
(* A directory where a file was meant. On Linux open_in_bin on a directory
|
|
succeeds and the *read* is where EISDIR arrives, so this was an uncaught
|
|
exception out of the checker until the whole read was guarded - the one
|
|
way a user could make the compiler crash rather than refuse. *)
|
|
refuses_src "embed given a directory"
|
|
"(defn main [] i32 (len (embed \"programs/assets\")))"
|
|
"it is a directory";
|
|
|
|
(* One extra argument, and `string` is the only thing it can be. Two
|
|
spellings, not one form that changes type with its context. *)
|
|
refuses_src "embed asked for a type it cannot read a file as"
|
|
"(defn main [] i32 (len (embed \"no-such-asset.bin\" i32)))"
|
|
"`string` is the only one";
|
|
|
|
(* Allocators, spec-memory.md. The tier on its own, with no container
|
|
above it, so that a failure here is not read as a Vec bug. What is
|
|
asserted is the capability set differing per allocator, the context
|
|
rebinding for a dynamic extent and restoring — out of a call and out of
|
|
a *transfer* — and free-all moving the epoch while keeping the pages.
|
|
At -O0 as well, because with-allocator's restore on the transfer path is
|
|
control flow an optimiser would otherwise launder, and as a dev build,
|
|
because the call inside the body then goes through a cell. *)
|
|
let allocators_out =
|
|
"true\nfalse\nfalse\ntrue\ntrue\nfalse\nfalse\ntrue\n41\n0\n1\n2\n2\ntrue\ntrue\n"
|
|
in
|
|
outputs "allocators" "programs/allocators.flan" allocators_out;
|
|
outputs ~opt:"-O0" "allocators, -O0" "programs/allocators.flan" allocators_out;
|
|
outputs ~dev:true "allocators, dev" "programs/allocators.flan" allocators_out;
|
|
|
|
(* The recursive dynamic value in an arena, spec-memory.md's arena rule and
|
|
the thing it exists to make possible: a data type naming itself through a
|
|
(Vec Value) and a (Map string Value), built several levels deep, read
|
|
back, and released by one free-all with no per-element teardown
|
|
anywhere. The five refusals that used to stand between here and a type
|
|
like this were all about *teardown*, and a region has none.
|
|
|
|
The numbers are the assertion that a run which did nothing cannot pass:
|
|
five top-level values, 23 summed across every leaf in the graph. Printed
|
|
twice because the second build happens in the region the first one was
|
|
released from — free-all is retain-capacity, so the same bytes hold the
|
|
second document, and a stale header surviving the reset would show up
|
|
as a different total rather than as nothing at all. *)
|
|
let arena_value_out = "5\n23\n5\n23\n" in
|
|
outputs "a dynamic value in an arena" "programs/arena-value.flan"
|
|
arena_value_out;
|
|
outputs ~opt:"-O0" "a dynamic value in an arena, -O0"
|
|
"programs/arena-value.flan" arena_value_out;
|
|
outputs ~dev:true "a dynamic value in an arena, dev"
|
|
"programs/arena-value.flan" arena_value_out;
|
|
|
|
(* And the same thing over a real document, which is what the arena route
|
|
was taken for: the EDN tokenizer is a non-allocating cursor over a
|
|
[u8], and the reader above it builds a (Vec Value) and a
|
|
(Map string Value) against whichever allocator the *caller* bound. It
|
|
takes no allocator parameter and names none — spec-memory.md puts the
|
|
allocator in the calling convention, so (with-allocator a (read-doc s))
|
|
is the whole of "read-edn taking an allocator", and there is no new
|
|
machinery to add for it.
|
|
|
|
The numbers are structural: "map" is the document's shape, 12 is every
|
|
leaf in it, 6 is [1 2 3] summed, and "string" is :name's value read back
|
|
through the map. A reader that flattened a level or dropped a nested
|
|
map would miss on the leaf count. *)
|
|
let arena_edn_out = "map\n12\n6\nstring\n" in
|
|
outputs "an EDN document in an arena" "programs/arena-edn.flan"
|
|
arena_edn_out;
|
|
outputs ~opt:"-O0" "an EDN document in an arena, -O0"
|
|
"programs/arena-edn.flan" arena_edn_out;
|
|
|
|
(* And the branch that makes it safe, which needs a program that dies to
|
|
say anything — the shape bounds.flan uses, and for the same reason.
|
|
Run 0 is the control and must not trap: a (Vec (Vec i32)) in the region
|
|
is exactly the nested-container case the frame tier exists for, and the
|
|
rule asks about the allocator rather than about what the element owns,
|
|
so it has to be built without complaint. *)
|
|
let region ?opt () =
|
|
let exe = compile ?opt "programs/arena-region.flan" in
|
|
let code, text = run exe (Some "0") in
|
|
if text <> "1\n2\n1\n1\n" || code <> 0 then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL nested containers in a region\n got: %S (exit %d)\n"
|
|
text code
|
|
end;
|
|
let traps name arg reason =
|
|
let code, text = run exe (Some arg) in
|
|
if code <> 134
|
|
|| not (contains text "programs/arena-region.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
|
|
(* At the construction, and not at the free it would have gone wrong in:
|
|
one branch per container, where the allocator is still a value the
|
|
site is holding. *)
|
|
traps "a container of owning elements against the heap" "1"
|
|
"this allocator can free one block";
|
|
(* A different mechanism, pinned separately: the epoch, and specifically
|
|
an inner header copied *out* of its container before the release. It
|
|
traps because an Allocator is a pointer — a copied-by-value one would
|
|
carry its own epoch and the copy would never notice the bump. *)
|
|
traps "an inner header used after free-all" "2"
|
|
"this container's allocator was released";
|
|
(* And the hole a guard only at the construction would have left: ZII
|
|
means a container can exist without ever reaching (vec-new), and the
|
|
first push is what adopts the context. Pinned from both sides — run 0
|
|
above grows the same zeroed field in a region and must not trap. *)
|
|
traps "a zeroed field of owning elements grown against the heap" "3"
|
|
"this allocator can free one block";
|
|
(try Sys.remove exe with Sys_error _ -> ())
|
|
in
|
|
region ();
|
|
region ~opt:"-O0" ();
|
|
(* The allocation registry, NEXT.md. Two expectations rather than one, and
|
|
the difference between them *is* the assertion: a dev build answers for
|
|
an address at each of the three tiers and a release build answers 0 to
|
|
every question, because a release build records nothing. Written as one
|
|
program read twice rather than two programs, so that nobody can change
|
|
what a dev build does without the release row noticing.
|
|
|
|
The arena row is the one worth naming. test_valgrind.ml measures a hole:
|
|
free-all is retain-capacity, so memcheck is never told the storage died
|
|
and a later read of stale bytes goes unnoticed. This does not close that
|
|
— memcheck still says nothing — it makes the same read *answerable*, by
|
|
a different tool. The two must not be blurred. *)
|
|
outputs "registry, dev" ~dev:true "programs/registry.flan"
|
|
"1\n1\n0\n1\n0\n1\n0\n";
|
|
outputs "registry, release" "programs/registry.flan"
|
|
"0\n0\n0\n0\n0\n0\n0\n";
|
|
outputs "registry, release -O0" ~opt:"-O0" "programs/registry.flan"
|
|
"0\n0\n0\n0\n0\n0\n0\n";
|
|
(* free-all on an allocator that does not offer it traps rather than doing
|
|
nothing, because "I released the region" and "I leaked the region" must
|
|
not be the same program text. Its own case for the same reason the
|
|
bounds traps are: a trap has no result, only an exit and a message. *)
|
|
let exe = compile "programs/free-all-refused.flan" in
|
|
let code, text = run exe None in
|
|
if code <> 134
|
|
|| not (contains text "programs/free-all-refused.flan:")
|
|
|| not (contains text "does not offer free-all")
|
|
then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL free-all on an allocator without it\n\
|
|
\ got: %S (exit %d)\n wanted: exit 134, naming the site\n"
|
|
text code
|
|
end;
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
|
|
(* (Vec T), spec-memory.md. Two element types over one type-erased
|
|
runtime, which is the whole claim: size_of and align_of are produced at
|
|
the concrete call site and nothing below it knows the element type. The
|
|
moves are here too — into a call and out of one — because a Vec that
|
|
cannot be handed to a function is not a container anyone can use. *)
|
|
let vec_out =
|
|
"0\n3\n10\n30\n99\n139\n2\n99\n-1\n10\n3\n4\n\
|
|
<vec>\n<allocator>\n2\n4\n7\nfalse\n11\n5\n"
|
|
in
|
|
outputs "vec" "programs/vec.flan" vec_out;
|
|
outputs ~opt:"-O0" "vec, -O0" "programs/vec.flan" vec_out;
|
|
outputs ~dev:true "vec, dev" "programs/vec.flan" vec_out;
|
|
(* The prelude's second tier: the functions that return new storage, every
|
|
one of which the prelude used to refuse by name for want of an
|
|
allocator. The cases are the ones that separate a correct version from a
|
|
lucky one — join over zero and one parts, where the separator count is
|
|
-1 and 0; "aaa" with "aa" -> "b", which is "ba" only if the match is
|
|
non-overlapping; an empty `from` to replace, which is an infinite loop
|
|
under the other reading; and split's trailing and leading empty fields,
|
|
which is where Odin's iterator and Odin's own allocating split disagree.
|
|
The builder line holds two rendered integers and a float at once, which
|
|
is precisely what the runtime's shared static scratch makes impossible
|
|
for i64->bytes on its own.
|
|
|
|
The dev run earns its place here more than most: it is the one that
|
|
checks a container's recorded allocator epoch, so it is what would catch
|
|
one of these Vecs being used after the arena under it was released. *)
|
|
let strings_out =
|
|
"x=42 y=-7 r=1.5\nonetwo\n0\na, b, c\na\n0\nabc\nababab\n0\n\
|
|
hello, world 42!\nHELLO, WORLD 42!\n\
|
|
ba\na -- b -- c\nabc\nabc\nabc\n\
|
|
3\na\nc\n3\n0\n2\n0\n1\nabc\n1\n0\na/b/c\nin-arena\n"
|
|
in
|
|
outputs "string building" "programs/strings.flan" strings_out;
|
|
outputs ~opt:"-O0" "string building, -O0" "programs/strings.flan"
|
|
strings_out;
|
|
outputs ~dev:true "string building, dev" "programs/strings.flan"
|
|
strings_out;
|
|
(* format-f64, the first number formatter a caller can steer. The three
|
|
lines that would ship wrong are pinned deliberately: 0.999995 at five
|
|
places, where the rounded fraction equals the scale and is the next
|
|
integer rather than a fraction; 1.005 at three, where dropping the zero
|
|
padding prints "1.5"; and -0.5, where the sign belongs to the number and
|
|
the integer part it would otherwise ride on is 0, which i64->bytes
|
|
renders unsigned.
|
|
|
|
0.125 at two places answers 0.13 and printf's "%.2f" answers 0.12. That
|
|
is not a defect: this rounds the decimal expansion half away from zero,
|
|
which is round-f32's rule and the rest of this file's, where printf
|
|
rounds the binary value to nearest-even. Pinning 0.12 here would be
|
|
pinning a libc.
|
|
|
|
The last line is the one the whole shape is for — two numbers in one
|
|
built string, which the runtime's single shared scratch buffer makes
|
|
impossible for a formatter that answers a slice. *)
|
|
let format_out =
|
|
"3.14\n0.02\n1234.5\n2\n2.000\n\
|
|
0.13\n-0.13\n3\n-3\n\
|
|
1.00000\n10.0\n-10.0\n1\n\
|
|
1.005\n1.0001\n7.000000\n\
|
|
-0.50\n-0.00\n0.00\n0.00\n\
|
|
2\n1.500000000\n\
|
|
nan\ninf\n-inf\n1e+20\n1234567890123.00\n\
|
|
fps 59.9 / frame 0.0167\n"
|
|
in
|
|
outputs "a number with a precision" "programs/format.flan" format_out;
|
|
outputs ~opt:"-O0" "a number with a precision, -O0" "programs/format.flan"
|
|
format_out;
|
|
(* The slice family at its second and third element types. sort-i32! was
|
|
the only sort in the language; these are copies rather than an
|
|
abstraction, because map/filter/reduce and a comparator sort all need a
|
|
function value and check.ml refuses one outright.
|
|
|
|
Two lines carry the claims that are not about sorting. The subslice sort
|
|
leaves its neighbours alone, which is the in-place ptr+len contract and
|
|
the one thing a version that copied would fail. And the 2 is the width of
|
|
sum-f32's accumulator made visible: 2^24 is where an f32 stops having a
|
|
bit for 1, so an f32 running total absorbs both addends and prints 0. *)
|
|
let algorithms_out =
|
|
"-2.25 -1 0 0.5 3.5 3.5 10 \n\
|
|
9 1 2 3 4 9 \n\
|
|
1 2 3 \n1 2 3 \n7 \n\n\
|
|
4 3 2 1 \n\
|
|
-1 10 12.5\nnone 0\n2\n\
|
|
true false false true false true true\ntrue false\n\
|
|
Fig apple apple banana pear \n\
|
|
alpha < bravo < charlie < delta\n"
|
|
in
|
|
outputs "sorting f32 and byte slices" "programs/algorithms.flan"
|
|
algorithms_out;
|
|
outputs ~opt:"-O0" "sorting f32 and byte slices, -O0"
|
|
"programs/algorithms.flan" algorithms_out;
|
|
(* A debug build, because [dty] is a separate path from everything above:
|
|
[outputs ~dev:true] goes through the cells, not through DWARF, and a
|
|
type with no arm there dies at emit rather than being merely undebugged.
|
|
That is NEXT.md's landed item 2 exactly — [field_addr] took only
|
|
[Types.Named], so the printer's Option arm had never run. Asserted on
|
|
the metadata as well as on the program still working: a composite whose
|
|
element count disagreed with [lay] would print plausible values for the
|
|
wrong fields, which is the failure debug info has. *)
|
|
let dbg = Emit.program ~debug:true (Check.program
|
|
(Parse.program (Reader.read_file "programs/vec.flan"))) in
|
|
if not (contains dbg "name: \"Allocator\"")
|
|
|| not (contains dbg "name: \"(Vec i32)\", size: 384")
|
|
then begin
|
|
incr failures;
|
|
print_endline "FAIL debug info for Allocator and (Vec T)"
|
|
end;
|
|
|
|
(* StorageExhausted and retry. The allocator is genuinely exhausted — a
|
|
ceiling on live bytes, hit repeatedly — and the handler raises it and
|
|
invokes retry, so the same request is re-attempted and no push is lost.
|
|
Every allocating operation is covered, not only push: reserve asks for
|
|
the whole block at once and clone asks for the source's length.
|
|
At -O0 because the retry loop and the guard after the error are control
|
|
flow an optimiser would otherwise launder. *)
|
|
let exhausted_out = "64\n0\n126\ntrue\ntrue\n4\ntrue\n0\n8\n7\ntrue\n" in
|
|
outputs "storage exhausted, retried" "programs/exhausted.flan" exhausted_out;
|
|
outputs ~opt:"-O0" "storage exhausted, retried, -O0" "programs/exhausted.flan"
|
|
exhausted_out;
|
|
outputs ~dev:true "storage exhausted, retried, dev" "programs/exhausted.flan"
|
|
exhausted_out;
|
|
|
|
(* The same exhaustion with nothing handling it. [error] is the diverging
|
|
variant: the program stops on the frame that erred rather than carrying
|
|
on with a push that appended nothing, which is the Odin outcome the rule
|
|
exists to make impossible. *)
|
|
let exe = compile "programs/exhausted-unhandled.flan" in
|
|
let code, text = run exe None in
|
|
if code <> 134 || not (contains text "before")
|
|
|| not (contains text "unhandled StorageExhausted")
|
|
|| contains text "unreachable"
|
|
then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL an unhandled StorageExhausted stops the program\n\
|
|
\ got: %S (exit %d)\n wanted: exit 134, naming the condition\n"
|
|
text code
|
|
end;
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
|
|
(* -- Files, NEXT.md decisions 1, 2 and 5 --------------------------
|
|
Embedding first, because it is the one that costs nothing at run time
|
|
and needs no host ABI at all: a compiler feature, so no linker
|
|
arguments, no per-target packaging, and identical on desktop and web.
|
|
At -O0 and as a dev build too - a dev build emits a defconst as a
|
|
mutable global, so the (embed-dir) constant travels a different path
|
|
there and is worth seeing twice. *)
|
|
let embed_out =
|
|
"13\nhello from a\nBBB\n4\n0\n255\n254\n3\na.txt\nb.bin\nraw.bin\nBBB\n\
|
|
no nope.txt\n"
|
|
in
|
|
outputs "embed, a file and a directory" "programs/embed.flan" embed_out;
|
|
outputs ~opt:"-O0" "embed, -O0" "programs/embed.flan" embed_out;
|
|
outputs ~dev:true "embed, dev" "programs/embed.flan" embed_out;
|
|
|
|
(* slurp and barf, with all three restart paths taken: use-value on a read,
|
|
use-value on a write, and retry after the handler made the file. The
|
|
typed restart is the thing being exercised as much as the file I/O -
|
|
this is the first restart clause the *compiler* emits with a parameter,
|
|
and its parameter is the path slot the attempt reads. *)
|
|
let slurp_out =
|
|
"13\nhello from a\n4\n0\n255\n3\nBBB\n1\ntrue\ntrue\n\
|
|
programs/assets/does-not-exist\n11\nround trip\n1\ntrue\nsecond\n\
|
|
made by the handler\n1\ntrue\n"
|
|
in
|
|
let clean () =
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
|
[ "slurp-out.txt"; "slurp-made.txt" ]
|
|
in
|
|
clean ();
|
|
outputs "slurp and barf, with restarts" "programs/slurp.flan" slurp_out;
|
|
clean ();
|
|
outputs ~opt:"-O0" "slurp and barf, -O0" "programs/slurp.flan" slurp_out;
|
|
clean ();
|
|
outputs ~dev:true "slurp and barf, dev" "programs/slurp.flan" slurp_out;
|
|
clean ();
|
|
|
|
(* slurp's use-value is the first restart clause the *compiler* emits with
|
|
a parameter - alloc_guard's retry takes none - so the guard against the
|
|
break loop taking it with nothing to fill the parameter in with is worth
|
|
asserting here too. It is the same emit.ml path a hand-written typed
|
|
clause goes through (the restarts.flan case above), and this says the
|
|
compiler-emitted one is on it rather than beside it. *)
|
|
let p =
|
|
Reader.read_file "programs/slurp.flan" |> Parse.program |> Check.program
|
|
in
|
|
if not (contains (Emit.program p) "call void @flan_restart_unarmed(") then begin
|
|
incr failures;
|
|
print_endline
|
|
"FAIL the compiler-emitted use-value has no guard against being taken \
|
|
without an argument"
|
|
end;
|
|
|
|
(* The desktop half of the one program whose behaviour differs by target.
|
|
test_web.ml builds this same text for the browser and asserts the other
|
|
outcome: there `barf` signals and the program says which file it could
|
|
not write, here it writes it. No conditional compilation is involved in
|
|
either - nothing in parse.ml or check.ml reads the target, and the whole
|
|
of the difference is one #ifdef in flan_rt.c. Seeing both halves is what
|
|
makes the claim a test rather than an assertion. *)
|
|
(try Sys.remove "web-files-out.txt" with Sys_error _ -> ());
|
|
outputs "files, the desktop half of the web case" "programs/web-files.flan"
|
|
"hello from a\nwrote it\n";
|
|
(try Sys.remove "web-files-out.txt" with Sys_error _ -> ());
|
|
|
|
(* A missing file with nothing handling it. The same rule StorageExhausted
|
|
follows: [error] is the diverging variant, so the program stops on the
|
|
frame that erred rather than carrying on with a Vec that was never
|
|
filled. Neither restart is taken and both were still offered. *)
|
|
let exe = compile "programs/slurp-unhandled.flan" in
|
|
let code, text = run exe None in
|
|
if code <> 134 || not (contains text "before")
|
|
|| not (contains text "unhandled FileError")
|
|
|| contains text "unreachable"
|
|
then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL an unhandled FileError stops the program\n\
|
|
\ got: %S (exit %d)\n wanted: exit 134, naming the condition\n"
|
|
text code
|
|
end;
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
|
|
(* The rest of the file surface. What is being checked as much as the
|
|
calls is the line drawn through them: file-exists? and file-size answer
|
|
a value because absence is a reply and not a fault, and the three that
|
|
change the filesystem signal FileError with the same two restarts slurp
|
|
and barf establish. Both restarts are taken here on operations that
|
|
write - retry after the handler made the parent directory, and
|
|
use-value on a delete - which is what the pair is for and what a bool
|
|
return could not have offered.
|
|
|
|
The program makes and removes its own tree, so the cleanup below is for
|
|
a run that failed part way through and not for a passing one. *)
|
|
let clean_dir () =
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
|
[ "files-tmp/sub/deep.txt"; "files-tmp/one.txt"; "files-tmp/two.txt" ];
|
|
List.iter (fun d -> try Unix.rmdir d with Unix.Unix_error _ -> ())
|
|
[ "files-tmp/sub"; "files-tmp" ]
|
|
in
|
|
let files_out =
|
|
"true\nfalse\ntrue\n13\nnone\ntrue\n10\nfalse\ntrue\nfalse\n\
|
|
1\ntrue\ntrue\ntrue\n1\ntrue\nfalse\n1\ntrue\nfalse\n"
|
|
in
|
|
clean_dir ();
|
|
outputs "the rest of the file surface" "programs/files.flan" files_out;
|
|
clean_dir ();
|
|
outputs ~opt:"-O0" "the rest of the file surface, -O0" "programs/files.flan"
|
|
files_out;
|
|
clean_dir ();
|
|
outputs ~dev:true "the rest of the file surface, dev" "programs/files.flan"
|
|
files_out;
|
|
clean_dir ();
|
|
|
|
(* The epoch trap: a container whose allocator has been released. This is
|
|
spec-memory.md's shipping answer to "Open: catching a use-after-release
|
|
statically" — detection, loud and immediate, rather than a static rule
|
|
that with-allocator and context/allocator deny the knowledge for. What
|
|
is asserted is the reason and the site, not the line. *)
|
|
let exe = compile "programs/stale-region.flan" in
|
|
let code, text = run exe None in
|
|
if code <> 134 || not (contains text "programs/stale-region.flan:")
|
|
|| not (contains text "allocator was released")
|
|
then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL a container used after its region was released\n\
|
|
\ got: %S (exit %d)\n wanted: exit 134, naming the site\n"
|
|
text code
|
|
end;
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
|
|
(* (Handle T) and (Pool T), spec-memory.md. The thesis is one line of this
|
|
output and the rest is scaffolding for it: the same slot prints as
|
|
<handle 1:1> before a death and <handle 1:3> after the reuse, and the
|
|
projectile still holding the first is told -1 rather than the
|
|
newcomer's 99. At -O0 as well, because the null test resolve is built
|
|
out of is exactly the kind of control flow an optimiser launders, and
|
|
as a dev build, because a pool then lives in a frame the reload path
|
|
has to agree with on 64 bytes. *)
|
|
let handles_out =
|
|
"3\n3\n60\n21\ntrue\nfalse\n2\n<handle 1:1>\n<handle 1:3>\nfalse\ntrue\n-1\n99\n3\n3\n<handle 0:0>\n-1\n10\n30\n"
|
|
in
|
|
outputs "handles" "programs/handles.flan" handles_out;
|
|
outputs ~opt:"-O0" "handles, -O0" "programs/handles.flan" handles_out;
|
|
outputs ~dev:true "handles, dev" "programs/handles.flan" handles_out;
|
|
|
|
(* The epoch trap on the pool's side, and it is deliberately the *other*
|
|
failure from a stale handle. A stale handle is an answer and resolve
|
|
returns None; a released region is not an answer at all, because the
|
|
slot array went with the storage, so it traps. The two must not be
|
|
conflated, which is the same rule that keeps a Vec's generation word
|
|
and its epoch word apart. *)
|
|
let exe = compile "programs/pool-stale-region.flan" in
|
|
let code, text = run exe None in
|
|
if code <> 134 || not (contains text "programs/pool-stale-region.flan:")
|
|
|| not (contains text "allocator was released")
|
|
|| not (contains text "7")
|
|
then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL a pool used after its region was released\n\
|
|
\ got: %S (exit %d)\n wanted: exit 134, naming the site\n"
|
|
text code
|
|
end;
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
|
|
(* The same trap on the Map's side, and it is not the same code path: a
|
|
Vec's operations check on the way in and stop there, while a map's get
|
|
goes on to call a hash and an equality function through pointers into
|
|
the block. A missing check here is not a wrong number, it is a probe
|
|
loop walking released memory. *)
|
|
let exe = compile "programs/map-stale-region.flan" in
|
|
let code, text = run exe None in
|
|
if code <> 134 || not (contains text "programs/map-stale-region.flan:")
|
|
|| not (contains text "allocator was released")
|
|
|| not (contains text "20")
|
|
then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL a map used after its region was released\n\
|
|
\ got: %S (exit %d)\n wanted: exit 134, naming the site\n"
|
|
text code
|
|
end;
|
|
(try Sys.remove exe with Sys_error _ -> ());
|
|
|
|
(* §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\
|
|
axes 0 0 0 0 -1 -1 past-end 0\n\
|
|
window ready no\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)";
|
|
|
|
(* The same boundary, from declarations nobody wrote. Every binding this
|
|
program calls came out of raylib's header through vendor/raylib/headers;
|
|
the package binds none of the four by hand, so if it runs at all the
|
|
importer produced working declarations.
|
|
|
|
What it prints pins more than that. ColorToInt of {17,34,51,68} is
|
|
0x11223344 — the four fields read in r,g,b,a order, so exchanging any
|
|
two changes the number — and ColorTint by white is the identity, which
|
|
hands the four bytes back separately. That is the same argument the
|
|
GetColor case makes and for the same reason: handing a struct over and
|
|
reading it back proves nothing, because storing and returning is
|
|
symmetric and a permuted layout comes back permuted the same way.
|
|
TextLength of "hello" is 5, which is only true if the generated wrapper
|
|
NUL-terminated the copy.
|
|
|
|
This used to be skipped without FLAN_RAYLIB_H, because the generated
|
|
bindings only existed when a header was read. They are committed now —
|
|
vendor/raylib/generated.flan — so it runs on the same terms as every
|
|
other raylib case here: libraylib linkable, and no raylib-devel. That is
|
|
the change stated as a test rather than as a claim. If generated.flan
|
|
were ever regenerated empty or stale, this is what would say so, and it
|
|
would say so on an ordinary machine rather than only on one with a
|
|
header exported. *)
|
|
let out = "10\n5\n287454020\n17\n34\n51\n68\n" in
|
|
outputs "raylib, bindings generated from the header" "programs/raylib-imported.flan" out;
|
|
(* At -O0 too, 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, bindings generated from the header, -O0"
|
|
"programs/raylib-imported.flan" out;
|
|
|
|
(* The raylib package's begin/end macros — vendor/raylib/modes.flan.
|
|
Nothing here draws: every one of the five brackets calls that want a
|
|
window and a GL context, so what can be asserted headless is that the
|
|
expansion compiles, which is the whole of what a macro over a pair can
|
|
get wrong. The program keeps the frame function unreachable from main
|
|
on purpose, so reach.ml links no libraylib and this runs unconditionally
|
|
alongside the cases that need one. See the file's header. *)
|
|
outputs "raylib begin/end macros expand" "programs/rl-with.flan"
|
|
"expanded\n";
|
|
|
|
(* 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\
|
|
piece-top 2 1 1 7\n\
|
|
piece-top at 1,0 200 0 0 255\n\
|
|
piece-top at 0,0 10 20 30 255\n\
|
|
piece-bottom 2 1 1 7\n\
|
|
piece-bottom at 0,0 0 200 0 255\n\
|
|
piece-bottom at 1,0 10 20 30 255\n\
|
|
sheet after 6 3 1 7\n\
|
|
sheet at 5,0 200 0 0 255\n\
|
|
sheet at 4,2 0 200 0 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)";
|
|
|
|
(* The nine filters of examples/textures-image-processing.flan, headless.
|
|
The example is imported, so these are the pixels that program shows —
|
|
and the filters are the half of the raylib Image surface
|
|
programs/raylib-image.flan does not reach, because every one of them
|
|
takes a (Ptr Image) and rewrites the buffer in place. Two of the rows
|
|
here are load-bearing beyond the arithmetic: grayscale's format goes
|
|
from 7 to 1, which is ImageColorGrayscale reallocating into a
|
|
one-byte-per-pixel buffer and is exactly the kind of change a
|
|
by-value declaration would hide, and the two flip rows read the OTHER
|
|
probe's colour, which is what says the reflection happened in the axis
|
|
it claimed. The blur is asserted structurally and not to the byte —
|
|
the file says why. *)
|
|
let raylib_proc_out =
|
|
"source 200 150 7\n\
|
|
source a 230 41 55 255\n\
|
|
source b 0 158 47 255\n\
|
|
source c 37 122 202 255\n\
|
|
none 200 150 7\n\
|
|
none a 230 41 55 255\n\
|
|
none b 0 158 47 255\n\
|
|
none c 37 122 202 255\n\
|
|
grayscale 200 150 1\n\
|
|
grayscale a 99 99 99 255\n\
|
|
grayscale b 98 98 98 255\n\
|
|
grayscale c 105 105 105 255\n\
|
|
tint 200 150 7\n\
|
|
tint a 0 36 10 255\n\
|
|
tint b 0 141 8 255\n\
|
|
tint c 0 109 38 255\n\
|
|
invert 200 150 7\n\
|
|
invert a 25 214 200 255\n\
|
|
invert b 255 97 208 255\n\
|
|
invert c 218 133 53 255\n\
|
|
contrast 200 150 7\n\
|
|
contrast a 164 96 101 255\n\
|
|
contrast b 81 138 98 255\n\
|
|
contrast c 94 125 154 255\n\
|
|
brightness 200 150 7\n\
|
|
brightness a 150 1 1 255\n\
|
|
brightness b 1 78 1 255\n\
|
|
brightness c 1 42 122 255\n\
|
|
flip-v 200 150 7\n\
|
|
flip-v a 0 158 47 255\n\
|
|
flip-v b 230 41 55 255\n\
|
|
flip-v c 17 100 186 255\n\
|
|
flip-h 200 150 7\n\
|
|
flip-h a 49 135 212 255\n\
|
|
flip-h b 255 203 0 255\n\
|
|
flip-h c 230 41 55 255\n\
|
|
blur 200 150 7\n\
|
|
blur edge-reddened yes\n\
|
|
blur inside-still-red yes\n"
|
|
in
|
|
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
|
|
outputs "raylib image processing, headless"
|
|
"programs/raylib-image-processing.flan" raylib_proc_out;
|
|
outputs ~opt:"-O0" "raylib image processing, headless, -O0"
|
|
"programs/raylib-image-processing.flan" raylib_proc_out
|
|
end
|
|
else
|
|
print_endline
|
|
"acceptance: skipping the raylib image-processing case (no libraylib)";
|
|
|
|
(* The scan and the codepoint walk of examples/text-codepoints-loading.flan,
|
|
headless. The example is imported, so the literal counted here is the
|
|
literal that program draws — which is the point: a non-ASCII string
|
|
literal is carried by the reader, the object file and the FFI without
|
|
any of the three claiming to understand it, and 49 distinct codepoints
|
|
out of 54 is a fact about the Iroha that a lost byte anywhere in that
|
|
chain would change. The two walk rows are what stands in for
|
|
GetCodepointPrevious, which cannot be called from Flan at all — see
|
|
docs/PORTING.md, and the file's own header for what each row fails on. *)
|
|
let raylib_codepoints_out =
|
|
"codepoints 54\n\
|
|
unique 49\n\
|
|
unique 0 12356\n\
|
|
unique 1 12429\n\
|
|
unique 2 12399\n\
|
|
unique 3 12395\n\
|
|
unique 4 12411\n\
|
|
forward 54\n\
|
|
backward 54\n\
|
|
walks mirror yes\n\
|
|
back at start 0\n\
|
|
walk matches raylib yes\n"
|
|
in
|
|
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
|
|
outputs "raylib codepoints, headless"
|
|
"programs/raylib-codepoints.flan" raylib_codepoints_out;
|
|
outputs ~opt:"-O0" "raylib codepoints, headless, -O0"
|
|
"programs/raylib-codepoints.flan" raylib_codepoints_out
|
|
end
|
|
else
|
|
print_endline
|
|
"acceptance: skipping the raylib codepoints 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 = "15595743031174623232\n" in
|
|
outputs "sand, headless" "programs/sand-headless.flan" sand_out;
|
|
outputs ~opt:"-O0" "sand, headless, -O0" "programs/sand-headless.flan" sand_out;
|
|
|
|
(* The ported raylib example that has a headless half. The other nine of
|
|
the ten in examples/ are input read straight into drawing calls, and a
|
|
test of those would be asserting that raylib answers 0 for every input
|
|
with no window open — which is also what a binding with its arguments
|
|
crossed would answer. This one is different: which virtual D-pad button
|
|
sits under a pointer, and what a held button does to the player, is
|
|
arithmetic. The driver sweeps a pointer over the pad in a fixed grid,
|
|
so every branch of the search is taken, and hashes where the player
|
|
ended up. A crossed x and y anywhere in it changes the number. Like
|
|
sand-headless it imports the example and reaches no raylib call, so it
|
|
links neither a shim nor libraylib. *)
|
|
let vc_out = "-2146089238186896844\n" in
|
|
outputs "virtual controls, headless"
|
|
"programs/virtual-controls-headless.flan" vc_out;
|
|
outputs ~opt:"-O0" "virtual controls, headless, -O0"
|
|
"programs/virtual-controls-headless.flan" vc_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";
|
|
(* (slice-from-ptr p n) with a length that cannot be true. There is no
|
|
length to compare n against — the caller's number *is* the length — so
|
|
the only check possible is that it is not negative, and it is a signed
|
|
one: the two above are unsigned, and a negative i32 sign-extended to
|
|
i64 passes both of them.
|
|
|
|
Its own sentence, from its own runtime function. It used to borrow
|
|
@flan_slice_error and say "slice [0 -2) is out of bounds for length
|
|
0", which named a range and a length the caller never wrote. This is
|
|
the one form whose real condition the compiler cannot check, so the
|
|
refusal is where the caller's promise gets stated. The asserted
|
|
substring stays inside one output line; the second line is the part
|
|
about what is *not* checked. *)
|
|
traps "slice-from-ptr with a negative length" "-2"
|
|
"slice-from-ptr was promised -2 elements behind the pointer";
|
|
(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_error(") 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_error("
|
|
|| contains off "call void @flan_slice_error("
|
|
|| contains off "call void @flan_slice_promise_error(" then begin
|
|
incr failures;
|
|
print_endline "FAIL --no-bounds-checks: a check survived"
|
|
end;
|
|
|
|
(* The other half of the same change: a bad index that something *answers*.
|
|
bounds.flan above is still the unhandled case and still exits 134 with
|
|
the same text; this one establishes a frame loop's `continue` and a
|
|
handler that takes it, and the program runs to the end.
|
|
|
|
Three claims, and the second is the one that had to be decided rather
|
|
than inherited. (1) Five frames finish and seven are abandoned, out of
|
|
five routes to a bad index — fixed-array read, fixed-array write (a
|
|
different lowering), slice, Vec element and Vec as-slice, the last two
|
|
checked inside the runtime rather than in emitted IR. (2) `cleaned` is
|
|
5, which is every defer on every one of those paths: an answered bounds
|
|
failure leaves through the same unwind path a `return` uses and runs
|
|
them, where a trap ran none. (3) The condition's numbers are the real
|
|
ones — 7 and -1 for the two bad `at`s, [2 9) and [3 1) for the two bad
|
|
slices, with `low` and `high` equal for an index and the two ends for a
|
|
range, which is why there is one condition type and not two.
|
|
|
|
Also at -O0 and as a dev build. The dev build is here for the reason
|
|
the rest of the dev rows are — every call goes through a cell and a
|
|
shadow-stack frame is pushed per call — so this pins that the
|
|
indirection does not change where a transfer lands. It says nothing
|
|
about the break loop: this program does not import the agent, so
|
|
flan_break_hook is NULL in all three rows and the handler is what
|
|
answers. The break loop over a bad index is its own case, in
|
|
test_dev.ml, over programs/dev-break-bounds.flan, with nothing
|
|
handling it at all. *)
|
|
let bounds_cond_out =
|
|
"read 12\nlow 7\nlength 4\nlow -1\nwrote 99\nlow 4\n\
|
|
slice 3\nlow 2\nhigh 9\nlength 5\nlow 3\nhigh 1\n\
|
|
vec 200\nlow 5\nlength 2\nvec-slice 2\nhigh 9\n\
|
|
frames 5\nskipped 7\ncleaned 5\n10 99 12 13\n"
|
|
in
|
|
outputs "a bad index is a condition" "programs/bounds-condition.flan"
|
|
bounds_cond_out;
|
|
outputs ~opt:"-O0" "a bad index is a condition, -O0"
|
|
"programs/bounds-condition.flan" bounds_cond_out;
|
|
outputs ~dev:true "a bad index is a condition, dev"
|
|
"programs/bounds-condition.flan" bounds_cond_out;
|
|
|
|
(* ── Arithmetic with no answer ─────────────────────────────────────
|
|
The same pair of programs and the same pair of shapes, for the three
|
|
situations that had no defined behaviour at all until now: a divide or
|
|
remainder by zero, which was a raw SIGFPE — no message, no location,
|
|
nothing to handle — the one division that overflows, and a float to
|
|
integer cast whose value does not fit, which LLVM called undefined and
|
|
would fold to anything.
|
|
|
|
arith.flan is the unhandled half. It is asserted the way bounds.flan is,
|
|
on the reason rather than on a result: the location, and which operation
|
|
against which operands. The first case is the one that must *not* die,
|
|
and it is four shapes rather than one — an ordinary dynamic divisor, a
|
|
literal one the guard is allowed to drop, unsigned division, which has
|
|
no overflow case because it has no most-negative value, and a float
|
|
division by zero, which is an infinity and is a defined answer this
|
|
language has no business refusing. *)
|
|
let arith ?opt () =
|
|
let exe = compile ?opt "programs/arith.flan" in
|
|
let traps name arg reason =
|
|
let code, text = run exe (Some arg) in
|
|
if code <> 134
|
|
|| not (contains text "programs/arith.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
|
|
let code, text = run exe (Some "0") in
|
|
if text <> "3 5 14 inf\n" || code <> 0 then begin
|
|
incr failures;
|
|
Printf.printf "FAIL arithmetic that is fine\n got: %S (exit %d)\n"
|
|
text code
|
|
end;
|
|
traps "divide by zero" "1" "divide by zero: (/ 10 0)";
|
|
traps "remainder by zero" "2" "remainder by zero: (% 10 0)";
|
|
(* The only pair of operands in the whole type for which a division
|
|
overflows, and the reason this cannot be left to the hardware: `idiv`
|
|
raises SIGFPE here and LLVM calls it undefined, so the two backends
|
|
disagreed about a case that is one comparison away from being
|
|
answerable. *)
|
|
traps "the division that overflows" "3"
|
|
"(/ -9223372036854775808 -1) overflows";
|
|
(* `srem` overflows on exactly the operands `sdiv` does: the quotient is
|
|
what does not fit, and a remainder computes one on the way. *)
|
|
traps "the remainder that overflows" "4"
|
|
"(% -9223372036854775808 -1) overflows";
|
|
(* The range is the destination's, and it is in the message because it is
|
|
the only thing that explains the failure — the value is a float and
|
|
the number that matters about it is which end it fell off. *)
|
|
traps "a float too large for an i64" "5"
|
|
"which holds [-9223372036854775808 9223372036854775807]";
|
|
traps "a float too large for an i8" "6" "which holds [-128 127]";
|
|
(* NaN fails both halves of the range test rather than passing both,
|
|
which is what the comparisons being *ordered* buys. An unordered pair
|
|
would have waved it through into an fptosi that is as undefined for a
|
|
NaN as it is for 1e300. *)
|
|
traps "NaN cast to an integer" "7"
|
|
"does not fit the integer type it is cast to";
|
|
(* One width down, and this is the case the two backends disagreed about
|
|
*silently* rather than both dying: x86 loaded the operands
|
|
sign-extended into 64-bit registers, divided there and truncated on
|
|
the store, answering -2147483648, where LLVM emitted poison. It is
|
|
also the only thing that exercises the widening on the way into the
|
|
condition — if that is wrong, the number in this sentence is
|
|
garbage. *)
|
|
traps "the i32 division that overflows" "8"
|
|
"(/ -2147483648 -1) overflows";
|
|
(* An f32 source, whose range test the two backends reach by deliberately
|
|
different routes: emit.ml widens the value to a double and compares
|
|
against double bounds, x86.ml compares in f32 against an f32 constant.
|
|
They agree because every bound is a power of two and is exact in both,
|
|
and this is the row that says so rather than the comment. *)
|
|
traps "an f32 too large for an i32" "9"
|
|
"which holds [-2147483648 2147483647]";
|
|
(try Sys.remove exe with Sys_error _ -> ())
|
|
in
|
|
arith ();
|
|
arith ~opt:"-O0" ();
|
|
|
|
(* The release build drops the guards. Asserted on the IR and not by
|
|
running an unchecked program, for the reason the bounds case gives: an
|
|
unchecked divide by zero has no defined behaviour to assert on — it is
|
|
the SIGFPE this whole change exists to replace. *)
|
|
let ap =
|
|
Reader.read_file "programs/arith.flan" |> Parse.program |> Check.program
|
|
in
|
|
if not (contains (Emit.program ap) "call void @flan_arith_error(") then begin
|
|
incr failures;
|
|
print_endline "FAIL checks on: no arithmetic guard emitted"
|
|
end;
|
|
if contains (Emit.program ~checks:false ap) "call void @flan_arith_error("
|
|
then begin
|
|
incr failures;
|
|
print_endline "FAIL --no-bounds-checks: an arithmetic guard survived"
|
|
end;
|
|
|
|
(* And the answered half. Five codes, five routes, one condition type, and
|
|
the same three claims bounds-condition.flan makes. (1) The frame is
|
|
abandoned and the program carries on: four frames finish and eight are
|
|
abandoned. (2) `cleaned` is 12, every defer on every one of those paths
|
|
— an answered arithmetic failure leaves through the unwind path a
|
|
`return` uses, where a SIGFPE ran nothing and could not have. (3) The
|
|
condition carries the numbers: `op` is which of the five, and
|
|
`lhs`/`rhs` are the operands for a division and the destination's range
|
|
for a cast, which is two meanings over two fields rather than five
|
|
condition types and is BoundsError's precedent exactly.
|
|
|
|
The last two rows are the elisions, which are here because a dropped
|
|
guard is indistinguishable from a broken one unless the result is
|
|
asserted: a literal divisor, and unsigned division, which gets the zero
|
|
test and no overflow test at all. *)
|
|
let arith_cond_out =
|
|
"div 3\nop 0\nlhs 10\nrhs 0\nop 1\n\
|
|
op 2\nlhs -9223372036854775808\nrhs -1\nop 3\n\
|
|
cast 3\ncast -3\n\
|
|
op 4\nlhs -9223372036854775808\nrhs 9223372036854775807\nop 4\n\
|
|
cast8 12\nlhs -128\nrhs 127\nop 4\n\
|
|
lit 4611686018427387903\nu 14\n\
|
|
frames 4\nskipped 8\ncleaned 12\n"
|
|
in
|
|
outputs "arithmetic with no answer is a condition"
|
|
"programs/arith-condition.flan" arith_cond_out;
|
|
outputs ~opt:"-O0" "arithmetic with no answer is a condition, -O0"
|
|
"programs/arith-condition.flan" arith_cond_out;
|
|
outputs ~dev:true "arithmetic with no answer is a condition, dev"
|
|
"programs/arith-condition.flan" arith_cond_out;
|
|
|
|
(* And the half that finishes that thought. bounds-condition.flan's last
|
|
line is `10 99 12 13` — an abandoned frame's leftovers — and a restart
|
|
undoes none of it, because a restart is not a transaction
|
|
(spec-conditions.md §5). So rollback is written rather than provided,
|
|
and frame-rollback.flan is the worked example: snapshot at the top of
|
|
the frame, restore in the `continue` clause, over one fixed array and
|
|
one struct, which is engine.clj's grids plus engine.lisp's shallow copy
|
|
of the state object and is two `set`s here because both are values.
|
|
|
|
The rows to read are the three drifts. Frame 1 is in bounds and leaves
|
|
drift 4 against a zeroed snapshot — work that must survive. Frame 2 is
|
|
the negative control: the same bad index, the same snapshot taken, and
|
|
a `continue` that only counts, leaving drift 3. Without it "state equals
|
|
snapshot" would pass on a program that wrote nothing. Frame 3 restores
|
|
and leaves drift 0.
|
|
|
|
`tails 3` and `tick 2` are the ordering, and they are the pair no other
|
|
ordering produces. An answered bounds failure runs the abandoned
|
|
function's defers — innermost-first, before the clause body — so
|
|
update-frame's defer ran on all three frames (tails 3) and wrote into
|
|
the snapshotted cell 7, and cell 7 still reads its pre-frame 2 because
|
|
restore is the last write on that path. Restore in a defer instead
|
|
would read tick 3 here, and would also roll back frame 1, which nothing
|
|
reports as an error.
|
|
|
|
Three rows for the reason the bounds rows above have three: -O0 pins
|
|
that the transfer does not depend on optimisation, and the dev build
|
|
pins that a call through a cell and a shadow-stack frame per call does
|
|
not change where it lands. *)
|
|
let rollback_out =
|
|
"1 5 1 1\ndrift 4\n2 5 2 2\ndrift 3\n2 5 2 2\ndrift 0\n\
|
|
tails 3\ntick 2\nframes 1\nskipped 2\nwrites 3\nlow 9\nlength 8\n"
|
|
in
|
|
outputs "an abandoned frame rolls back" "programs/frame-rollback.flan"
|
|
rollback_out;
|
|
outputs ~opt:"-O0" "an abandoned frame rolls back, -O0"
|
|
"programs/frame-rollback.flan" rollback_out;
|
|
outputs ~dev:true "an abandoned frame rolls back, dev"
|
|
"programs/frame-rollback.flan" rollback_out;
|
|
|
|
(* ── 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";
|
|
(* And the diamond with a type crossing it, which is the case the dedupe
|
|
exists for rather than a restatement of the one above. pkg-diamond
|
|
imports area and draw; both import shape; a shape/Box is built inside
|
|
area and handed to a function declared inside draw. Read shape twice
|
|
and there are two structs both called shape/Box, which do not unify —
|
|
so the numbers are the test and compiling is not. 3 is draw/describe
|
|
picking .w of a 3x2 box it never constructed, 6 is area/of on the same
|
|
value, 20 is shape's own constructor reached through the chain.
|
|
|
|
It is also where the inner-alias rule is visible: shape is imported by
|
|
area and by draw and never by the program, and the name is still
|
|
shape/Box and not area/shape/Box. *)
|
|
outputs "a diamond, with a type crossing it" "programs/pkg-diamond.flan"
|
|
"3\n6\n20\n";
|
|
(* A local shadows an imported name. Qualification rewrites a package's own
|
|
names wherever they are used, and a binding is where it has to stop —
|
|
in an expression and in a place, which are two separate lines of the
|
|
renamer. Nothing refuses a renamer that qualifies through a binding:
|
|
the program builds and runs and reads the top-level name instead, so
|
|
what says it is wrong is the number. 7 is the let's and not the
|
|
constant's 5; 20 comes back out of [assigned] while the package's own
|
|
[sink] is still 0, which is the place half. *)
|
|
outputs "a local shadows an imported name" "programs/pkg-shadow.flan"
|
|
"7\n20\n0\n5\n";
|
|
|
|
(* Generics end to end: one written body per family, several emitted, and
|
|
the collapsed prelude running underneath it. Every line of the expected
|
|
output is an answer a per-type copy used to give. *)
|
|
let generics_out =
|
|
"3\n4.5\ntrue\n7\n5\n-1\n5\n42\n3\n1\n10\n1\n8\n\
|
|
3\n4.5\ntext\n1\n2.5\n9\n36\n2\n2.5\n0\n3\n3\n0\n21\n7\n3\n4.5\n"
|
|
in
|
|
outputs "generics" "programs/generics.flan" generics_out;
|
|
outputs ~opt:"-O0" "generics, -O0" "programs/generics.flan" generics_out;
|
|
|
|
(* Reach's walk, edge by edge. Pruning is what makes the link follow the
|
|
program, and the cost of getting it wrong is not a wrong answer: a
|
|
function the walk fails to reach is not emitted, and the build dies in
|
|
the linker naming a symbol nobody wrote. reach-walk.flan calls three
|
|
functions from three places that are each the only route to them — the
|
|
index expression of a place, a place under [addr], and a restart-case
|
|
clause body — so a walk that forgets any one of the three fails to build
|
|
here. Caught rather than raised, because a build that dies takes the
|
|
rest of the table with it. *)
|
|
(match compile "programs/reach-walk.flan" with
|
|
| exception Failure m ->
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL Reach's walk: it did not build, which is what a pruned function looks like\n%s\n"
|
|
m
|
|
| exe ->
|
|
let code, text = run exe None in
|
|
let want = "10\n20\n42\n" in
|
|
if text <> want || code <> 0 then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL Reach's walk\n got: %S (exit %d)\n wanted: %S\n"
|
|
text code want
|
|
end;
|
|
(try Sys.remove exe with Sys_error _ -> ()));
|
|
|
|
(* 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 (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 { Loc.dmsg = 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
|
|
(* A package macro's arity check. A macro cannot signal while it expands,
|
|
so the prelude's idiom — clamp's, unless's, into's — is to answer a
|
|
symbol that is not a name and reads as the sentence the caller needs.
|
|
What makes that usable rather than baffling is the expander's note
|
|
beneath it, naming rl/with-mode-2d at the call site rather than
|
|
pointing into the package — that half is rendering and is not asserted
|
|
here. *)
|
|
refuses "with-mode-2d written without a camera"
|
|
"programs/rl-with-reject.flan"
|
|
"with-mode-2d-takes-a-camera-and-a-body";
|
|
|
|
(* Visibility: main is not a name a package offers, and saying so is the
|
|
point — "unknown name sand/main" would be true and useless. *)
|
|
(* Generics, at the definition rather than at a call site. Both of these
|
|
are refusals the abstract pass exists for: the body is checked once
|
|
with its type variables left abstract, so an operator the variable was
|
|
not declared to support, and an instantiation that grows without end,
|
|
are both answered where they are written. The second one used to *hang*
|
|
rather than fail, which through Session.eval is C-c C-c hanging with
|
|
the dev daemon behind it — so what is asserted is that it names the
|
|
chain of instantiations and not a depth it gave up at. *)
|
|
refuses "an unconstrained operator in a generic body"
|
|
"programs/generic-reject.flan"
|
|
"only what it is declared to support";
|
|
refuses "an unconstrained operator names the way out"
|
|
"programs/generic-reject.flan" "{:where (numeric? $t)}";
|
|
refuses "a runaway instantiation" "programs/generic-runaway.flan"
|
|
"instantiates itself without end";
|
|
refuses "a runaway instantiation names the chain"
|
|
"programs/generic-runaway.flan" "grow at ([2 i32])";
|
|
|
|
(* The other half of the map deferral. The operations over a key that is a
|
|
type variable are deferred to the instantiation — there is no hash and
|
|
no equality to emit until the key type is concrete — and what makes
|
|
that safe is that {:where (hashable? $t)} is in the signature, so the
|
|
refusal lands at the call that asked for the type, against a
|
|
requirement the author wrote down. What is asserted is that it names
|
|
the type passed and the predicate it failed, and not the body. *)
|
|
refuses "a generic over maps, instantiated at a key that cannot be hashed"
|
|
"programs/generic-map-reject.flan" "does not answer hashable?";
|
|
refuses "and it names the type the call site asked for"
|
|
"programs/generic-map-reject.flan" "at $t = f64";
|
|
|
|
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";
|
|
(* A ring is refused and the ring is named. The needle is the chain, not
|
|
the word "cycle": what a person needs is which three imports, and the
|
|
refusal that says only "there is a cycle" leaves them to find it. The
|
|
ring is a -> b -> c -> a, and the message closes it by repeating the
|
|
package it came back to. *)
|
|
(* And the same rule through a chain, which is the case that only exists
|
|
once a package may import a package: area imports shape as [shape] and
|
|
the program imports the same directory as [sh]. Which of the two lines
|
|
the message names is whichever one arrived second, so it depends on the
|
|
order the entry file writes its imports in; both are correct refusals
|
|
and the needle deliberately does not pin it down. What is being tested
|
|
is that the clash is caught at all when the two halves are a page and a
|
|
directory apart, rather than side by side as in the case above. *)
|
|
refuses "one directory under two aliases, through a package"
|
|
"programs/pkg-alias-clash.flan" "one directory is one set of names";
|
|
(* A ring is refused and the ring is named. The needle is the chain, not
|
|
the word "cycle": what a person needs is which three imports, and the
|
|
refusal that says only "there is a cycle" leaves them to find it. The
|
|
ring is a -> b -> c -> a, and the message closes it by repeating the
|
|
package it came back to. *)
|
|
(* A package may declare a macro, and its name is the package's: importing
|
|
one makes nothing globally visible, macros included. This used to be the
|
|
refusal "macros are not imported yet"; the working half is
|
|
[outputs "a macro in an imported package"] below, and this is the half
|
|
the rule needs — that the bare name is still nothing. *)
|
|
refuses "a package's macro is not visible unqualified"
|
|
"programs/pkg-macro-bare.flan" "unknown function twice";
|
|
(* And both non-termination refusals, with the macros coming from a
|
|
package. They are different failures — a ring has no compile order, a
|
|
macro that quasiquotes itself has one and just never stops — and an
|
|
import must not quietly turn either into the other. *)
|
|
refuses "a ring of macros in a package" "programs/pkg-macro-ring.flan"
|
|
"none can be compiled first";
|
|
refuses "a package macro that does not settle"
|
|
"programs/pkg-macro-spin.flan" "expanding s/spin did not settle";
|
|
refuses "an import ring" "programs/pkg-cycle.flan"
|
|
"round a ring: a -> b -> c -> a";
|
|
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";
|
|
(* Still the one thing in the allocator tier that does not work, and the
|
|
reason changed when function values landed: it *has* a defn's name in
|
|
value position now. What it does not have is a way to be called — the
|
|
runtime calls proc(a, mode, p, old, size, align), six C arguments with
|
|
no transfer channel, and every Flan function value's signature ends with
|
|
one — or anywhere to put the flan_allocator, Allocator being opaque and
|
|
pointer-width. Two reasons, both named, neither a function value. *)
|
|
refuses "a user-written allocator" "programs/user-allocator.flan"
|
|
"is no longer what is missing";
|
|
(* Move-only, spec-memory.md. Each of these would otherwise be a double
|
|
free or a use-after-free at run time, and each is refused at the second
|
|
use with the first one's location in the message. *)
|
|
refuses "a Vec used after it was passed" "programs/vec-moved.flan"
|
|
"was moved at";
|
|
refuses "a Vec freed twice" "programs/vec-double-free.flan"
|
|
"double free unrepresentable";
|
|
(* The one case the dead set cannot answer on its own: merged once at the
|
|
end of the body it counts one move, not two. *)
|
|
refuses "a Vec moved inside a loop" "programs/vec-moved-in-loop.flan"
|
|
"the next iteration would use what this one gave away";
|
|
(* let has no type annotation, so with no element type and no expectation
|
|
there is nothing to infer from — and guessing is the alternative. *)
|
|
refuses "vec-new with nothing saying what of" "programs/vec-untyped.flan"
|
|
"write the element type";
|
|
(* The shape ownership is still not transitive through. A global used to be
|
|
one of these and a Vec of a Vec used to be another; neither is now. The
|
|
global's rule is [Check.global_borrow] — see "a global Vec" above — and
|
|
the Vec of a Vec is a run-time question about the allocator instead, so
|
|
its program runs rather than being refused (programs/arena-region.flan).
|
|
|
|
This one stays, and the narrowing is exactly why: a [(Vec u8)] field
|
|
holds elements that own nothing, so nothing forces it into a region,
|
|
and two copies of the struct would be two headers over one heap buffer.
|
|
A container whose *elements* own storage is the case that is admitted,
|
|
because that one can only have been built against a region. *)
|
|
refuses "a struct field that owns a Vec" "programs/vec-in-struct.flan"
|
|
"a struct that owns one is move-only too";
|
|
(* And it does not cross to C: the shim would flatten a header that owns
|
|
storage. Refused by the shim generator, where the message can say what
|
|
to pass instead. *)
|
|
refuses "a Vec crossing to C" "programs/vec-to-c.flan"
|
|
"handing its header to C hands out an owner";
|
|
|
|
(* ── 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 (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;
|
|
|
|
(* Converting an enum, explicitly, in both directions: (i32 k) and (K n).
|
|
An enum is an i32 at run time, so neither direction is an instruction
|
|
and the interesting thing is what the checker will let through — which
|
|
is why this is here and at -O0 rather than only in test_flan. The rows
|
|
are the three members out, a round trip back, a value that is no
|
|
declared member and the comparisons it exists for, a narrowing and a
|
|
widening of a negative member, and an enum parameter driven by a loop
|
|
variable, which is the whole point.
|
|
|
|
The two bare prints in the middle are the ones that hold the design up
|
|
rather than merely exercising it: 7 prints as 7 and 1 prints as :hi.
|
|
Allowing a non-member to be *built* is only coherent because the
|
|
printer already shows one as its number, and this is where that is
|
|
asserted rather than asserted about. *)
|
|
let enum_conv_out =
|
|
"-1\n0\n1\n1\n-1\n7\n7\n:hi\nnot a member\nabove 3\n-1\n255\n1\n\
|
|
lo\nmid\nhi\nother\n"
|
|
in
|
|
outputs "enum conversion" "programs/enum-convert.flan" enum_conv_out;
|
|
outputs ~opt:"-O0" "enum conversion, -O0" "programs/enum-convert.flan"
|
|
enum_conv_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 { Loc.dmsg = 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 { Loc.dmsg = 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 data type"
|
|
("(defdata Shape [(Circle [r f32]) (Square [s f32])])\n\
|
|
(declare-c area [s Shape] f32 \"Area\")")
|
|
"a data type, and a Flan data type 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 (Map 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] ())] \"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;
|
|
|
|
(* defer-let.flan: a [let] at the top level of a function body has exactly
|
|
the function's extent, so a defer written in it always registers and is
|
|
as safe as one written at the top level. Six claims, and the numbers
|
|
differ per failure.
|
|
|
|
The one a plausible wrong version gets wrong is [two]: a permission
|
|
granted once around a block rather than once before each form lets the
|
|
first defer through and refuses the second, and every other case here
|
|
still passes. *)
|
|
let defer_let_out = "9\n91\n921\n921\n9321\n7\n21\n" in
|
|
outputs "defer in a let" "programs/defer-let.flan" defer_let_out;
|
|
outputs ~opt:"-O0" "defer in a let, -O0" "programs/defer-let.flan"
|
|
defer_let_out;
|
|
(* The two refusals that stay, each named by what blocks it. A loop body
|
|
would fire once at function exit rather than once per iteration, and a
|
|
branch would have to express "maybe registered", which a construct
|
|
copied into every exit path cannot. A [let] inside either one inherits
|
|
the refusal, not the permission: its extent is the loop's or the arm's. *)
|
|
refuses_src "defer in a loop body"
|
|
"(defn g [] () 0)\n(defn f [] () (while true (defer (g))))"
|
|
"not allowed inside a loop body";
|
|
refuses_src "defer in a dotimes body"
|
|
"(defn g [] () 0)\n(defn f [] () (dotimes [i 3] (defer (g))))"
|
|
"not allowed inside a loop body";
|
|
refuses_src "defer in a branch"
|
|
"(defn g [] () 0)\n(defn f [] () (if true (defer (g)) 0))"
|
|
"not allowed inside a branch";
|
|
refuses_src "defer in a let inside a loop"
|
|
"(defn g [] () 0)\n(defn f [] () (while true (let [x 1] (defer (g)))))"
|
|
"not allowed inside a loop body";
|
|
refuses_src "defer in a let inside a branch"
|
|
"(defn g [] () 0)\n(defn f [] () (if true (let [x 1] (defer (g))) 0))"
|
|
"not allowed inside a branch";
|
|
|
|
(* ── (Map K V), spec-memory.md step 4 ──────────────────────────
|
|
|
|
Odin's map: open-addressed Robin Hood hashing at a 75% load factor with
|
|
cache-line cell packing. maps.flan is seven claims, each one a plausible
|
|
wrong version gets wrong, and the numbers differ per failure.
|
|
|
|
The two worth naming, because nothing else in the suite would catch
|
|
them. A struct key is hashed *field by field*, never bytewise, because a
|
|
struct's padding bytes are indeterminate — hashing them makes two equal
|
|
keys hash differently and the entry unfindable, which shows up here as a
|
|
wrong count rather than a crash. And a grow rehashes against a fresh
|
|
seed, because the seed is derived from the block address; carrying the
|
|
old hashes across a grow puts every entry in a slot nothing will probe.
|
|
2000 entries is eight grows and then every one of them read back. *)
|
|
let maps_out =
|
|
"2000\n0\n1600\n709\ntrue\nfalse\n3\n20\nfalse\n2\n3\nfalse\n\
|
|
100\n999\n2\n1\n3\n500\n998\n2\n2\n"
|
|
in
|
|
outputs "maps" "programs/maps.flan" maps_out;
|
|
outputs ~opt:"-O0" "maps, -O0" "programs/maps.flan" maps_out;
|
|
(* A dev build, because the hash and equality pair emitted for a struct key
|
|
is a function nobody wrote and the only other inhabitant of that list —
|
|
a lifted handler clause — carries a parent this one cannot: the pair is
|
|
shared by every function that maps that key type. A dev build puts every
|
|
body behind an indirection cell, so it is the build that would notice. *)
|
|
outputs ~dev:true "maps, dev" "programs/maps.flan" maps_out;
|
|
|
|
(* Iteration, which no map could do at all until flan_map_next. Every case
|
|
here is order-free on purpose — block order is the hash's order, not the
|
|
insertion's — so the numbers are sums, counts and lengths and never a
|
|
first entry. The string-keyed, struct-valued map is the one that would
|
|
catch the key and value runs being indexed with a single geometry, since
|
|
their element sizes and cell packing differ; and the 500-entry map is
|
|
several grows past the minimum, so it walks a block whose layout has
|
|
nothing to do with the order the entries went in. *)
|
|
let map_iter_out =
|
|
"4 10 100\nnever allocated: 0\nallocated and empty: 0\nspent: 2\n\
|
|
6 9 12\n500 500 500\n"
|
|
in
|
|
outputs "map iteration" "programs/map-iter.flan" map_iter_out;
|
|
outputs ~opt:"-O0" "map iteration, -O0" "programs/map-iter.flan" map_iter_out;
|
|
|
|
(* The allocation-failure rule is one rule over every allocating operation,
|
|
so it has to hold for map-new, put, reserve and clone as it does for the
|
|
Vec's four. A map is the harder case: its growth allocates a new block,
|
|
rehashes into it and only then releases the old one, so a failure
|
|
partway must leave the map exactly as it was or the retry re-attempts
|
|
against a half-moved map. *)
|
|
let map_exhausted_out = "300\n0\ntrue\ntrue\ntrue\n0\n2\n2\ntrue\n" in
|
|
outputs "map StorageExhausted and retry" "programs/map-exhausted.flan"
|
|
map_exhausted_out;
|
|
|
|
(* The refusals, each by name. A float key is not a milestone question —
|
|
NaN is not equal to itself and 0.0 and -0.0 are equal while differing
|
|
bytewise, so there is no equality for a map to hash. A move-only value
|
|
is the refusal (Vec (Vec T)) already carries, for the identical reason.
|
|
Unit as a value is refused rather than dividing a cache line by zero,
|
|
and it is named because it is the natural spelling of a set. *)
|
|
refuses_src "a float is not a map key"
|
|
"(defn f [m (Map f32 i32)] () 0)" "is not a map key";
|
|
refuses_src "a Ptr is not a map key"
|
|
"(defn f [m (Map (Ptr i32) i32)] () 0)" "hash an address";
|
|
(* A map value that owns storage is no longer refused at the type: that
|
|
refusal was about teardown, and which tier the map will meet is not
|
|
knowable where its type is written. What it became is a branch on the
|
|
allocator at (map-new) — programs/arena-region.flan. The key half is
|
|
untouched and is the two rows above. *)
|
|
accepts_src "a map value may own storage"
|
|
"(defn f [m (Map i32 (Vec i32))] () 0)";
|
|
refuses_src "a map value may not be ()"
|
|
"(defn f [m (Map i32 ())] () 0)" "cannot be ()";
|
|
refuses_src "map-new with nothing to say what it maps"
|
|
"(defn main [] i32 (let [m (map-new)] (free m)) 0)"
|
|
"nothing here says what (map-new) maps";
|
|
(* A map is move-only like a Vec, and the refusal names the type that was
|
|
moved rather than saying "a Vec" whatever it was. *)
|
|
refuses_src "a map used after it was moved"
|
|
"(defn main [] i32 (let [m (map-new i32 i32)] (free m) (put m 1 2)) 0)"
|
|
"cannot be used again";
|
|
(* ── Data type values ───────────────────────────────────────────
|
|
defdata parsed and its shape was checked; naming the type and
|
|
constructing a value were refused as milestone 6. The program covers a
|
|
case with no fields, a case wider than another, a case holding a
|
|
string, a data type in a struct, a data type through a call in both directions,
|
|
ZII, reassignment and printing.
|
|
|
|
-O0 as well, for the reason every aggregate here gets it: a data type value
|
|
is built in an alloca and mem2reg is exactly what would hide a store to
|
|
the wrong half of it. And a dev build, because every body goes behind an
|
|
indirection cell there and a data type crosses one as a parameter and as a
|
|
return value. *)
|
|
let datas_out =
|
|
"empty\ndot on the diagonal\ndot\nsquare\ntagged\nsquare\n\
|
|
32\n0\n-1\nin a cell\nempty\n30\nreassigned\n15\n\
|
|
Shape.Empty\n(Shape.Dot {.x 1.5 .y -2.5})\n\
|
|
(Shape.Tag {.name \"printed\" .n 9})\n\
|
|
(Cell {.id 7 .s (Shape.Rect {.w 1 .h 2})})\n\
|
|
6\nempty\nin a map\n"
|
|
in
|
|
(* ── Macros ─────────────────────────────────────────────────────
|
|
Running these means the expander compiled a shared object, dlopened it
|
|
into this process and called into it, before the program's first line
|
|
was parsed. They are acceptance cases and not unit tests for exactly
|
|
that reason: there is a clang driver and a loader in the path.
|
|
|
|
The three opt levels matter here the way they matter nowhere else in
|
|
this file: the expansion happens before anything the optimiser sees, so
|
|
all three had better produce the same program. *)
|
|
let macros_out =
|
|
"ab\ncd\n42\n10 5\n-> announced\na macro that called a macro\n\
|
|
true\ntrue\nfalse\n"
|
|
in
|
|
outputs "macros" "programs/macros.flan" macros_out;
|
|
outputs ~opt:"-O0" "macros, -O0" "programs/macros.flan" macros_out;
|
|
outputs ~dev:true "macros, dev" "programs/macros.flan" macros_out;
|
|
|
|
(* A macro declared in an imported *package*, which is the half the
|
|
refusal at [a package's macro is not visible unqualified] above leaves
|
|
out. The program calls six of them qualified and one of its own
|
|
unqualified, so what is asserted is that the two sets coexist in one
|
|
file: a package macro, a package macro that quasiquotes another one and
|
|
a function of its package, a macro that really calls another at expand
|
|
time, a macro whose output shadows a top-level name, a package function
|
|
calling its own macro unqualified, and the program's own macro wrapped
|
|
around a package's.
|
|
|
|
Three opt levels for the reason the case above has them -- the
|
|
expansion is finished before the optimiser exists -- and a dev build
|
|
because the dev path is this project's priority and reads the same
|
|
collected set. *)
|
|
let pkg_macro_out = "8\n12\n10\n12\n10\n8\n70\n60\n" in
|
|
outputs "a macro in an imported package" "programs/pkg-macro.flan"
|
|
pkg_macro_out;
|
|
outputs ~opt:"-O0" "a macro in an imported package, -O0"
|
|
"programs/pkg-macro.flan" pkg_macro_out;
|
|
outputs ~dev:true "a macro in an imported package, dev"
|
|
"programs/pkg-macro.flan" pkg_macro_out;
|
|
|
|
(* Function values, the non-escaping kind. Three opt levels because the
|
|
indirect call is the one shape LLVM is most likely to devirtualise: at
|
|
-O2 a name passed straight down becomes a direct call and the pointer
|
|
vanishes, so -O0 is what proves there is a real load and a real
|
|
[call ptr] behind it, and a dev build is what proves the value is read
|
|
out of the indirection cell rather than frozen as a symbol.
|
|
|
|
The two lines worth naming. A *returned* function value, called through
|
|
a computed head, is the case that would fail if the value were anything
|
|
other than a link-time constant. And the handler-bind around a fold
|
|
whose element function signals is the case that would fail if an
|
|
indirect call skipped the transfer guard — a callee reached by pointer
|
|
has to answer a signal exactly as one reached by name. *)
|
|
let fn_values_out =
|
|
"2 8\n-20\n24\n81\n1 9\n9 1\n1\nfalse\n512\n32\nseen 500\n"
|
|
in
|
|
outputs "function values" "programs/fn-values.flan" fn_values_out;
|
|
outputs ~opt:"-O0" "function values, -O0" "programs/fn-values.flan"
|
|
fn_values_out;
|
|
outputs ~dev:true "function values, dev" "programs/fn-values.flan"
|
|
fn_values_out;
|
|
|
|
(* The prelude's four, which is the point of the whole lane: map!, filter,
|
|
reduce and a comparator sort were blocked on function values and not on
|
|
generics, so they arrived without generics — and are still one copy per
|
|
element type, which is the generics half. The f32 rows are that copy.
|
|
-O0 as well, because filter allocates and the -O2 run can fold a
|
|
predicate over four literals into nothing. *)
|
|
let higher_order_out =
|
|
"3 12\n30\n1944\n2 3\n12 3\n3 12\n2 4\n7.5\n2\n4 0.5\n"
|
|
in
|
|
outputs "the prelude's map, filter, reduce and sort-by"
|
|
"programs/higher-order.flan" higher_order_out;
|
|
outputs ~opt:"-O0" "the prelude's map, filter, reduce and sort-by, -O0"
|
|
"programs/higher-order.flan" higher_order_out;
|
|
|
|
(* What function values do *not* include, each refused by name. Capture is
|
|
the headline: an fn is lifted into a function of its own and handed
|
|
nothing but its parameters, so spec-memory.md's capture cases and
|
|
escaping closures with them stay deferred. *)
|
|
refuses "an fn cannot capture" "programs/fn-capture.flan"
|
|
"cannot see n";
|
|
refuses "an fn with no type to take" "programs/fn-no-type.flan"
|
|
"nothing here says what this fn";
|
|
refuses "a function value would be zeroed" "programs/fn-in-struct.flan"
|
|
"it would be zeroed";
|
|
refuses "a foreign function's address" "programs/fn-extern.flan"
|
|
"is not a Flan function value";
|
|
|
|
(* The exit criterion plan.org set for milestone 5: a special form moved
|
|
out of the compiler and into the prelude, with the corpus that was
|
|
written against the special form unchanged. *)
|
|
let unless_out =
|
|
"the test was false\nabc\n7 is not less than 3\neven\nodd\n4\n"
|
|
in
|
|
outputs "unless, now a prelude macro" "programs/macro-unless.flan" unless_out;
|
|
outputs ~opt:"-O0" "unless, now a prelude macro, -O0"
|
|
"programs/macro-unless.flan" unless_out;
|
|
|
|
(* An error on code a macro produced says which macro, and it has to be
|
|
asserted through a real expansion: the tag is put on by [Macro] and
|
|
defaulted into the diagnostic by [Loc], and a unit test on either half
|
|
alone would pass with the other one broken.
|
|
|
|
[clamp] with the wrong number of arguments expands into a call to a name
|
|
that does not exist, on purpose -- that is how a prelude macro reports a
|
|
misuse. So the checker refuses a name the author never wrote, which is
|
|
exactly the case the field exists for. *)
|
|
(let src = "(defn f [] i32 (clamp 1 2))\n(defn main [] i32 0)\n" in
|
|
match
|
|
Check.program (Parse.program (Reader.read_all ~file:"<expansion>" src))
|
|
with
|
|
| _ ->
|
|
incr failures;
|
|
print_endline "FAIL an error in an expansion is refused"
|
|
| exception Loc.Error d ->
|
|
(match d.Loc.expansion with
|
|
| Some (name, _) when name = "clamp" -> ()
|
|
| Some (name, _) ->
|
|
incr failures;
|
|
Printf.printf "FAIL an error in an expansion names the wrong macro: %s\n"
|
|
name
|
|
| None ->
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL an error in an expansion names no macro\n error: %s\n"
|
|
d.Loc.dmsg);
|
|
(* And it reaches the printed report, which is the only part a reader
|
|
ever sees. *)
|
|
if not (contains (Loc.report d) "expanded from the macro clamp") then begin
|
|
incr failures;
|
|
print_endline "FAIL the report does not say which macro"
|
|
end);
|
|
|
|
(* The two ways expansion does not terminate, and they are different
|
|
failures. A ring is a compile-order problem -- each body calls the other
|
|
while the other is being compiled -- and there is no order, so it is
|
|
refused. A macro that quasiquotes a call to itself is not a ring: that
|
|
call is part of what it answers, and the answer is expanded again, so it
|
|
is an ordinary loop and it is bounded. *)
|
|
refuses "a ring of macros" "programs/macro-cycle.flan"
|
|
"none can be compiled first";
|
|
refuses "a macro that does not settle" "programs/macro-spin.flan"
|
|
"did not settle after";
|
|
|
|
outputs "data types" "programs/datas.flan" datas_out;
|
|
outputs ~opt:"-O0" "data types, -O0" "programs/datas.flan" datas_out;
|
|
outputs ~dev:true "data types, dev" "programs/datas.flan" datas_out;
|
|
(* ── The untagged union ─────────────────────────────────────────
|
|
Reading a member that was not written is defined here rather than
|
|
refused, which means nothing at run time would notice a member at the
|
|
wrong offset or a type sized to the wrong member: the numbers would
|
|
just be different numbers. So the numbers are written down. The layout
|
|
itself is checked against the backend that computes it, through the
|
|
DWARF/LLVM oracle further down; this is what the bytes *do*.
|
|
|
|
-O0 for the reason the data type above gets it, and more so: a union
|
|
value is a zeroed alloca and a store, and mem2reg is exactly what would
|
|
turn a store to the wrong half of one into a register nobody reads.
|
|
The x86-64 backend runs the same file under the @x86 alias, which
|
|
compares both backends on every program in this directory. *)
|
|
let unions_out =
|
|
"1\n1065353216\n0\n63\n1073741824\n0.5\n4611686018427387904\n0\n\
|
|
11\n22\n0\n0\n7\n1\n1.5\n2\n9\n<Bits union>\n"
|
|
in
|
|
outputs "unions" "programs/unions.flan" unions_out;
|
|
outputs ~opt:"-O0" "unions, -O0" "programs/unions.flan" unions_out;
|
|
outputs ~dev:true "unions, dev" "programs/unions.flan" unions_out;
|
|
|
|
(* The refusals, each by name. The first is the diagnostics bug NEXT.md
|
|
listed and this lane fixed: a case name written as if it were a struct
|
|
reported "unknown struct A", because nothing in the environment could
|
|
tell a case from a misspelling. It can now. *)
|
|
refuses_src "a data type case written as a struct"
|
|
"(defdata U [(A [x i32])])\n(defn main [] i32 (let [v (A {.x 1})] 0))"
|
|
"A is a case of the data type U";
|
|
refuses_src "a data type type used as a constructor"
|
|
"(defdata U [(A [x i32])])\n(defn main [] i32 (let [v (U {.x 1})] 0))"
|
|
"a data type value names the case as well as the type";
|
|
refuses_src "a case with fields written bare"
|
|
"(defdata U [(A [x i32])])\n(defn main [] i32 (let [v U.A] 0))"
|
|
"has fields, so it needs them";
|
|
(* Exhaustiveness is refused rather than defaulted: a match that fell
|
|
through would have to produce a value of the match's type out of
|
|
nothing, and the case a data type grows tomorrow is the one a reader wants
|
|
to be told about today. *)
|
|
refuses_src "a match that misses a case"
|
|
"(defdata U [A B C])\n\
|
|
(defn main [] i32 (match U.A A 0 B 1))"
|
|
"this match is not exhaustive";
|
|
refuses_src "a match arm naming a case the data type does not have"
|
|
"(defdata U [A B])\n(defn main [] i32 (match U.A A 0 B 1 Q 2))"
|
|
"Q is not a case of U";
|
|
(* All of a case's fields or none: a pattern binding some of them would be
|
|
reading the wrong field the moment one is inserted above it. *)
|
|
refuses_src "a case pattern binding the wrong number of names"
|
|
"(defdata U [(A [x i32 y i32])])\n\
|
|
(defn f [u U] i32 (match u (A x) x))"
|
|
"binds every field, in declaration order";
|
|
refuses_src "two arms for one case"
|
|
"(defdata U [A B])\n(defn main [] i32 (match U.A A 0 A 1 B 2))"
|
|
"two A arms";
|
|
(* The declaration's own refusals. A data type with no cases has no value, and
|
|
a case owning a Vec is the refusal a struct field already carries, in
|
|
the same words and for the same reason. *)
|
|
(* A data type that contains itself by value has no finite size, and the
|
|
emitter would recurse forever laying one out rather than failing. It is
|
|
refused where every other infinitely-sized type is, by the same walk,
|
|
which already traversed a data type's cases. Both shapes: direct, and two
|
|
data types through each other. (Ptr T) breaks the cycle and is exercised in
|
|
the program above -- it is the shape a Form has. *)
|
|
refuses_src "a data type that contains itself by value"
|
|
"(defdata T [Leaf (Node [l T r T])])\n(defn f [t T] () 0)"
|
|
"T contains itself by value";
|
|
refuses_src "two data types that contain each other by value"
|
|
"(defdata A [(X [b B])])\n(defdata B [(Y [a A])])\n(defn f [a A] () 0)"
|
|
"contains itself by value";
|
|
refuses_src "a data type with no cases"
|
|
"(defdata U [])\n(defn f [u U] () 0)"
|
|
"declares no cases";
|
|
refuses_src "a data type case that owns a Vec"
|
|
"(defdata U [(A [v (Vec i32)])])\n(defn f [u U] () 0)"
|
|
"which is move-only";
|
|
(* At the operation, not at the type: a struct key is decided by walking
|
|
its fields and the struct table is not necessarily complete while a
|
|
type is resolving, so both are answered where the hash and equality
|
|
pair is emitted. A data type reaches the same place. *)
|
|
refuses_src "a data type is not a map key"
|
|
"(defdata U [A B])\n\
|
|
(defn f [m (Map U i32) k U] () (put m k 1))"
|
|
"the payload past the case in hand is indeterminate";
|
|
(* A global cannot hold a case, because writing one at link time means
|
|
serialising the fields into the payload blob and a string field is a
|
|
relocation a byte array has nowhere to put. Zeroed is fine and is the
|
|
first declared case. Refused in the emitter, where the rest of the
|
|
same rule about a global's initialiser already lives, so the assertion
|
|
has to get that far rather than stopping at the checker. *)
|
|
(let name = "a global initialised with a data type case" in
|
|
let src =
|
|
"(defdata U [A (B [x i32])])\n(defvar g U (U.B {.x 1}))\n\
|
|
(defn main [] i32 0)"
|
|
in
|
|
match
|
|
Emit.program
|
|
(Check.program (Parse.program (Reader.read_all ~file:"<defdata>" src)))
|
|
with
|
|
| _ ->
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n it was accepted\n" name
|
|
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
|
if not (contains m "needs a byte-level encoder that does not exist")
|
|
then begin
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n said: %S\n" name m
|
|
end);
|
|
(* uninit is an opt-out from ZII everywhere else and the bytes are just
|
|
bytes. On a data type they steer control flow: a tag no case names falls
|
|
past every comparison in a match into the block LLVM is entitled to
|
|
assume cannot be reached. *)
|
|
refuses_src "uninit on a data type global"
|
|
"(defdata U [A B])\n(defvar g U uninit)\n(defn main [] i32 0)"
|
|
"its tag steers every match";
|
|
(* A data type's fields belong to a case, so .field is not a read anyone can
|
|
do without having read the tag first. match is how one is opened. *)
|
|
refuses_src "reading a field of a data type directly"
|
|
"(defdata U [(A [x i32])])\n(defn f [u U] i32 (.x u))"
|
|
"reached by (match ...)";
|
|
(* And a zeroed one is fine, which is the other half of the same rule: it
|
|
is the first declared case, all bytes zero, and needs no encoder. *)
|
|
(let name = "a zeroed data type global" in
|
|
match
|
|
Emit.program
|
|
(Check.program
|
|
(Parse.program
|
|
(Reader.read_all ~file:"<defdata>"
|
|
"(defdata U [A (B [x i32])])\n(defvar g U)\n\
|
|
(defn main [] i32 (match g A 0 (B x) x))")))
|
|
with
|
|
| _ -> ()
|
|
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n refused: %S\n" name m);
|
|
|
|
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 ?(tag = "DW_TAG_structure_type") 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 (Printf.sprintf "!DICompositeType(tag: %s" tag) >= 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. *)
|
|
(* The type definitions lifted straight out of an emitted module, so the
|
|
oracle never carries a second spelling of a layout. *)
|
|
let tydefs_of ir =
|
|
lines_of ir
|
|
|> List.filter (fun l ->
|
|
String.length l > 0 && l.[0] = '%' && index_of l " = type " >= 0)
|
|
|> List.map (fun l -> l ^ "\n")
|
|
|> String.concat ""
|
|
in
|
|
(* Hand LLVM a module of constant-folded ptrtoint expressions and read the
|
|
.quad it writes for each. Every layout question below is asked this way:
|
|
the answer comes from the backend that lays the type out, not from a
|
|
table written beside the code that would have to be wrong in the same
|
|
way to agree. *)
|
|
let run_oracle src =
|
|
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 src);
|
|
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
|
|
(* Every member's byte offset and the whole type's size, LLVM's answer. *)
|
|
let llvm_members ir sname nfields =
|
|
let sty = Printf.sprintf "%%\"%s\"" sname in
|
|
let b = Buffer.create 512 in
|
|
Buffer.add_string b (tydefs_of ir);
|
|
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);
|
|
run_oracle (Buffer.contents b)
|
|
in
|
|
(* Alignment, which no getelementptr states directly. Put the type after a
|
|
single byte and ask where it lands: a struct member sits at the first
|
|
offset its own alignment allows, so the offset of field 1 in
|
|
{ i8, T } *is* alignof(T). Reading [2 x i64] out of the emitted type and
|
|
concluding 8 would be asserting the layout against itself, which is the
|
|
circularity docs/BUILT.md already rejected for _Static_assert. *)
|
|
let llvm_align ir sname =
|
|
let sty = Printf.sprintf "%%\"%s\"" sname in
|
|
let b = Buffer.create 512 in
|
|
Buffer.add_string b (tydefs_of ir);
|
|
Buffer.add_string b (Printf.sprintf "%%alignprobe = type { i8, %s }\n" sty);
|
|
Buffer.add_string b
|
|
"@al = constant i64 ptrtoint (ptr getelementptr (%alignprobe, ptr null, i32 0, i32 1) to i64)\n";
|
|
match run_oracle (Buffer.contents b) with
|
|
| None -> None
|
|
| Some qs -> List.assoc_opt "al" qs
|
|
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" ];
|
|
(* A data type, through the same oracle, because its layout is the one thing
|
|
about it that has to be exactly right: the macro expander's Form has to
|
|
be the same bytes in the compiler and in the dlopened macro, and there
|
|
is nothing at run time that would notice a disagreement.
|
|
|
|
Two members, a tag and a blob, which is what DWARF 5's variant_part
|
|
would describe more precisely and lldb's C support would not read. The
|
|
size is the oracle's: room for the widest case at the alignment the
|
|
widest member of any case needs. Here that is (f64, f64) for the size
|
|
and f64 for the alignment, so a tag of 4 padded to 8 and 16 bytes of
|
|
payload -- 24. A blob sized to the *first* case, or one aligned to the
|
|
tag, comes out at a different number and this says so. *)
|
|
layout_case "DWARF offsets agree with LLVM: a data type"
|
|
("(defdata U [Nil (Pair [a f64 b f64]) (One [n i32])])\n\
|
|
(defn main [] i32 (let [u U.Nil] (match u Nil 0 _ 1)))\n")
|
|
"U" [ "tag"; "payload" ];
|
|
(* And the same data type with a narrower widest case, so the payload is not a
|
|
constant this could have hard-coded: three i32 cases want 4-byte
|
|
alignment and 4 bytes of payload, which is 8 in total. *)
|
|
layout_case "DWARF offsets agree with LLVM: a narrow data type"
|
|
("(defdata N [(A [x i32]) (B [y i32]) (C [z i32])])\n\
|
|
(defn main [] i32 (let [n (N.A {.x 3})] (match n (A x) x _ 1)))\n")
|
|
"N" [ "tag"; "payload" ];
|
|
|
|
(* An untagged union, which the case above cannot serve: its DWARF tag is
|
|
DW_TAG_union_type and its members are not a struct's, so there is no
|
|
[getelementptr] per member to compare against. What there is to check
|
|
is exactly C's three rules, and each is asked of the backend rather
|
|
than of a table beside the code:
|
|
|
|
- every member is at offset zero, which is the DWARF's claim;
|
|
- the size is the widest member, rounded up to the alignment, which is
|
|
[ptrtoint (getelementptr (%U, ptr null, i32 1))];
|
|
- the alignment is the strictest member's, which is where the type
|
|
lands after a single byte.
|
|
|
|
The type here is chosen so that no two of those numbers agree by
|
|
accident: [f64] is the widest and strictest at 8, [i32] is narrower,
|
|
and [[5 u8]] is five bytes at alignment one — so the size is 8 only if
|
|
it is the max *rounded up*, and a union sized to its first member, or
|
|
to the last, or aligned to the array, comes out at a different number
|
|
and this says so. *)
|
|
let union_layout_case name src uname members =
|
|
let ir = debug_ir src in
|
|
match dwarf_members ~tag:"DW_TAG_union_type" ir uname with
|
|
| None ->
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n no DWARF union type for %s\n" name uname
|
|
| Some (got, size) ->
|
|
if List.map fst got <> members then begin
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n DWARF members: %s\n wanted: %s\n"
|
|
name (String.concat " " (List.map fst got))
|
|
(String.concat " " members)
|
|
end;
|
|
List.iter
|
|
(fun (mname, off) ->
|
|
if off <> 0 then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL %s\n %s.%s is at byte %d, and a union member is \
|
|
at zero\n" name uname mname off
|
|
end)
|
|
got;
|
|
(match llvm_members ir uname 0 with
|
|
| None ->
|
|
Printf.printf "acceptance: %s — llc unavailable, size unchecked\n" name
|
|
| Some oracle ->
|
|
(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 uname size want
|
|
| _ -> ()));
|
|
(match llvm_align ir uname with
|
|
| None -> ()
|
|
| Some al ->
|
|
(* The DWARF states the alignment too, and it has to be the one
|
|
LLVM lays the type out at -- a debugger reading 8 where the
|
|
storage is aligned to 4 would step through an array of them
|
|
wrongly. *)
|
|
let dwarf_align =
|
|
List.find_map
|
|
(fun l ->
|
|
if index_of l "!DICompositeType(tag: DW_TAG_union_type" >= 0
|
|
&& attr l "name" = Some (Printf.sprintf "\"%s\"" uname)
|
|
then
|
|
Option.map (fun a -> int_of_string (String.trim a) / 8)
|
|
(attr l "align")
|
|
else None)
|
|
(lines_of ir)
|
|
in
|
|
(match dwarf_align with
|
|
| Some d when d <> al ->
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL %s\n %s is aligned to %d in the DWARF, %d in LLVM\n"
|
|
name uname d al
|
|
| _ -> ()))
|
|
in
|
|
union_layout_case "DWARF and LLVM agree on a union's layout"
|
|
("(defunion U [n i32 d f64 bs [5 u8]])\n\
|
|
(defn main [] i32 (let [u (U {.n 3})] (.n u)))\n")
|
|
"U" [ "n"; "d"; "bs" ];
|
|
(* And one whose widest member is not its strictest, so the round-up is
|
|
doing something: [11 u8] is eleven bytes at alignment one and [i32]
|
|
wants four, which is 12 and not 11. A union sized to the widest member
|
|
alone is 11, and an array of them would misalign every element after
|
|
the first. *)
|
|
union_layout_case "DWARF and LLVM agree on a union that rounds up"
|
|
("(defunion R [bs [11 u8] n i32])\n\
|
|
(defn main [] i32 (let [r (R {.n 3})] (.n r)))\n")
|
|
"R" [ "bs"; "n" ];
|
|
|
|
(* -- Form: the one layout two programs have to agree on --------
|
|
Every layout above is checked because a debugger reads it. This one is
|
|
checked because the *compiler* reads it. A macro is compiled into a .so
|
|
and dlopened into the compiler, and the compiler then writes a Form into
|
|
raw memory a field at a time and reads one back the same way; nothing at
|
|
run time would notice if the two sides disagreed by a byte. The image
|
|
format is three numbers -- 24 bytes, align 8, payload at offset 8 -- and
|
|
the marshaller in lib/expand.ml is written to them, so here is where they
|
|
stop being an assumption.
|
|
|
|
They are not arbitrary. Form's widest cases are (Str [s string]) and
|
|
(List [xs [Form]]); a string and a slice are both ptr+len, 16 bytes at
|
|
align 8. So the tag is 4 padded to 8, the payload is 16, and the total
|
|
is 24. Adding a case with a wider member -- two f64s and a pointer, say
|
|
-- moves every one of these numbers, and this is what says so before the
|
|
first macro hands back a Form the compiler misreads. *)
|
|
let form_src =
|
|
"(defn shape [f Form] i32\n\
|
|
\ (match f (Int _n) 1 (Str _s) 2 (List xs) (i32 (len xs)) _ 0))\n\
|
|
(defn main [] i32 (shape (Form.Int {.i 1})))\n"
|
|
in
|
|
layout_case "DWARF offsets agree with LLVM: Form" form_src
|
|
"Form" [ "tag"; "payload" ];
|
|
(* The three numbers by name, so a failure says which one moved rather than
|
|
leaving it to be read out of an offset table. *)
|
|
(let ir = debug_ir form_src in
|
|
let want =
|
|
[ ("o0", 0, "the tag is at byte"); ("o1", 8, "the payload is at byte");
|
|
("sz", 24, "a Form is this many bytes wide:") ]
|
|
in
|
|
match llvm_members ir "Form" 2 with
|
|
| None -> Printf.printf "acceptance: Form's image format - llc unavailable, unchecked\n"
|
|
| Some oracle ->
|
|
List.iter
|
|
(fun (k, expect, what) ->
|
|
match List.assoc_opt k oracle with
|
|
| Some got when got <> expect ->
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL Form's image format\n %s %d, the marshaller says %d\n"
|
|
what got expect
|
|
| Some _ -> ()
|
|
| None ->
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL Form's image format\n the oracle gave no %s\n" k)
|
|
want;
|
|
(match llvm_align ir "Form" with
|
|
| Some 8 -> ()
|
|
| Some got ->
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL Form's image format\n align %d, the marshaller says 8\n" got
|
|
| None ->
|
|
incr failures;
|
|
print_endline
|
|
"FAIL Form's image format\n the oracle gave no alignment"));
|
|
|
|
(* -- The macro boundary, executed ------------------------------
|
|
Everything above about Form is a claim about layout. This is the claim
|
|
that the two halves actually meet: a Flan function compiled into a .so,
|
|
dlopened into this process, handed Forms built by the OCaml side and
|
|
asked to hand one back.
|
|
|
|
It is here rather than in the unit tests because it shells out to clang
|
|
and to llc, which is what the acceptance suite is for. Without a
|
|
compiler on the path there is nothing to run, and that says so rather
|
|
than passing.
|
|
|
|
`keep` is the whole point of the three macros: `id` proves an argument
|
|
arrives and comes back, `snd` proves the *slice* arrives and not just
|
|
its first element, and `wrap` proves a Form the macro allocated itself
|
|
-- through the prelude's form-cons, inside the loaded module, on the
|
|
module's own heap -- is readable from here after the call returns. *)
|
|
let macro_src =
|
|
"(defn id [args [Form]] Form (at args 0))\n\
|
|
(defn snd [args [Form]] Form (at args 1))\n\
|
|
(defn wrap [args [Form]] Form\n\
|
|
\ (Form.List {.xs (form-cons (Form.Sym {.s \"do\"}) args)}))\n"
|
|
in
|
|
let macro_roundtrip () =
|
|
let decls = Parse.program (Reader.read_all ~file:"<macro-boundary>" macro_src) in
|
|
let p = Check.program decls in
|
|
let so = Filename.concat scratch "flan-macro-boundary.so" in
|
|
let so = Build.macro_module ~macros:[ "id"; "snd"; "wrap" ] p ~out:so in
|
|
let h = Dynload.dl_open so in
|
|
let fn n = Dynload.dl_sym h ("flan.macro." ^ n) in
|
|
let loc = Loc.unknown in
|
|
let f v = Form.make v loc in
|
|
(* One of every case, so a tag this file and the prelude disagree about
|
|
is a failure and not a gap. *)
|
|
let every =
|
|
[ f (Form.Sym "a-symbol"); f (Form.Kw "kw"); f (Form.Int 42L);
|
|
f (Form.Float 1.5); f (Form.Str "with \"quotes\" and \n");
|
|
f (Form.Byte 200); f (Form.Str "");
|
|
f (Form.List [ f (Form.Int 1L); f (Form.Vec [ f (Form.Sym "x") ]) ]);
|
|
f (Form.Vec []); f (Form.Map [ f (Form.Sym ".k"); f (Form.Int 9L) ]) ]
|
|
in
|
|
List.iter
|
|
(fun x ->
|
|
let got = Expand.call ~loc (fn "id") [ x ] in
|
|
if Form.to_string got <> Form.to_string x then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL a Form through the macro boundary\n sent %s, got back %s\n"
|
|
(Form.to_string x) (Form.to_string got)
|
|
end)
|
|
every;
|
|
(* The second argument, which only arrives if the slice's length crossed
|
|
as well as its base. A macro reading past its arguments is the bug
|
|
this catches. *)
|
|
let two = [ f (Form.Sym "first"); f (Form.Int 7L) ] in
|
|
let got = Expand.call ~loc (fn "snd") two in
|
|
if Form.to_string got <> "7" then begin
|
|
incr failures;
|
|
Printf.printf "FAIL a macro's second argument\n got %s, wanted 7\n"
|
|
(Form.to_string got)
|
|
end;
|
|
(* A Form the macro built. Nothing about this one was laid out on this
|
|
side, so it is the direction the layout agreement has never been
|
|
tested in. *)
|
|
let got = Expand.call ~loc (fn "wrap") two in
|
|
if Form.to_string got <> "(do first 7)" then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL a Form a macro built\n got %s, wanted (do first 7)\n"
|
|
(Form.to_string got)
|
|
end;
|
|
Dynload.dl_close h;
|
|
Dynload.release ();
|
|
(try Sys.remove so with Sys_error _ -> ())
|
|
in
|
|
(try macro_roundtrip () with
|
|
| Failure m ->
|
|
incr failures;
|
|
Printf.printf "FAIL the macro boundary\n %s\n" m);
|
|
|
|
(* 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 carries the name the source gave it. [Tast.fn]
|
|
records one per slot and [Check] fills it in at the binding, so
|
|
[(let [c ...)] is [c] in the debug info and not [s0] -- which is
|
|
what it used to be, and was the one honest gap in this picture. *)
|
|
("!DILocalVariable(name: \"c\"", "a let-bound local, named by its source name");
|
|
("!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;
|
|
|
|
(* The two rules about a name that is not simply the source's own.
|
|
|
|
A slot the compiler invented has no source name and keeps [s<index>]:
|
|
[dotimes] evaluates its bound once into a hidden slot, and calling that
|
|
something plausible would put a variable in the debugger that is not in
|
|
the file. [i] is the programmer's and is named; the bound is not.
|
|
|
|
And a shadowed name is disambiguated. Every [!DILocalVariable] is scoped
|
|
to the subprogram — the typed IR has no block structure to build a
|
|
[!DILexicalBlock] from — so two slots both called [v] leave lldb
|
|
answering [p v] with whichever it finds first. Measured: it answers with
|
|
the outer one, and does not list the inner at all, so the debugger is
|
|
confident and wrong. [~] cannot occur in a source symbol, so [v~2] is
|
|
unambiguous and visibly the compiler's. The prelude shadows in
|
|
[split-next], so this rule is load-bearing for the library too. *)
|
|
let ir =
|
|
debug_ir "(defn spin [n i32] i32\n\
|
|
\ (let [v 11]\n\
|
|
\ (let [v 22]\n\
|
|
\ (dotimes [i n] (set v (+ v i)))\n\
|
|
\ v)))\n\
|
|
(defn main [] i32 (spin 3))\n"
|
|
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)
|
|
[ ("!DILocalVariable(name: \"v\"", "the outer of two shadowed bindings");
|
|
("!DILocalVariable(name: \"v~2\"", "the inner one, disambiguated");
|
|
("!DILocalVariable(name: \"i\"", "a dotimes counter, which is the source's");
|
|
("!DILocalVariable(name: \"s4\"", "dotimes' hidden bound, which is not") ];
|
|
|
|
(* 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-value [v i32 s string] (do (print s) v))\n\
|
|
\ (use-placeholder [] -1)))\n\
|
|
(defn run [] i32\n\
|
|
\ (defer (set seen (+ seen 1)))\n\
|
|
\ (handler-bind [(Missing [m] (invoke-restart 'use-value 4 \"\"))]\n\
|
|
\ (fetch 3)))\n\
|
|
(defn main [] i32\n\
|
|
\ (set (at arr 2) 9)\n\
|
|
\ (let [s (slice arr 0 4)]\n\
|
|
\ (print (pick s 2)) (println \"\")\n\
|
|
\ (print (run)) (println \"\")\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) ?(x86 = false) path =
|
|
let exe =
|
|
Filename.concat scratch
|
|
("flan-dbg-" ^ Filename.remove_extension (Filename.basename path)
|
|
^ (if dev then "-dev" else "")
|
|
^ if x86 then "-x86" else "")
|
|
in
|
|
let l = Load.program ~file:path (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; x86 }
|
|
~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 = []; datas = []; 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 let-bound local under its own name rather than [s0], which
|
|
is the gap this closes. Only the name is claimed here: a name
|
|
breakpoint stops on the function's first line, which is before the
|
|
[let] has stored anything, so the value at this point is whatever
|
|
the frame happened to hold. The value is pinned just below. *)
|
|
"(int) bump" ];
|
|
(* 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" ];
|
|
(* The value, which the case above deliberately does not claim. Every
|
|
[!DILocalVariable] is scoped to the whole subprogram and carries the
|
|
function's own line, so a let-bound local is nominally in scope from
|
|
entry and reads as garbage until its binding runs. Breaking *after*
|
|
the binding is what makes the value load-bearing: [bump] is n+1 and n
|
|
is 41, so 42 is the only right answer, and a [!DILocalVariable]
|
|
attached to the wrong alloca prints something else. That is the check
|
|
that a name which is present is also not a lie. *)
|
|
let exe = debug_compile "programs/debug.flan" in
|
|
let _, text =
|
|
lldb_run exe
|
|
[ "breakpoint set --file debug.flan --line 20"; "run";
|
|
"frame variable bump" ]
|
|
in
|
|
if not (contains text "(int) bump = 42") then begin
|
|
incr failures;
|
|
print_endline "FAIL lldb: a let-bound local's value after its binding";
|
|
print_endline text
|
|
end;
|
|
|
|
(* 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:" ];
|
|
|
|
(* And the same program through the hand-written x86-64 backend, which
|
|
emits its own DWARF rather than handing LLVM metadata.
|
|
|
|
The claim is narrower than the one above and deliberately so: a
|
|
breakpoint resolved on a Flan name, and a backtrace whose frames name
|
|
a .flan file and a line. No [frame variable], because [x86.ml] emits
|
|
no [DW_TAG_variable] -- a slot there is a bump-allocated frame
|
|
temporary whose lifetime the backend does not model, and a name
|
|
attached to an offset something else reuses would be a lie. That is
|
|
the gap between the two backends and this is where it is recorded.
|
|
|
|
Worth pinning rather than leaving to a handoff's transcript, because
|
|
everything this exercises is bytes [x86.ml] wrote by hand -- a line
|
|
program, a compile unit and an abbreviation table -- and a wrong byte
|
|
in any of them is silent. The program still printing the same four
|
|
lines is checked too, since debug information that breaks the build
|
|
it describes has helped nobody. *)
|
|
let exe = debug_compile ~x86:true "programs/debug.flan" in
|
|
let code, text = run exe None in
|
|
if text <> expected || code <> 0 then begin
|
|
incr failures;
|
|
Printf.printf
|
|
"FAIL an --x86 --debug build of debug.flan runs the same\n\
|
|
\ got: %S (exit %d)\n wanted: %S\n"
|
|
text code expected
|
|
end;
|
|
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: --x86 --debug names Flan files and lines\n\
|
|
\ wanted %S\n" n;
|
|
print_endline text
|
|
end)
|
|
[ "flan.tick"; "at debug.flan:"; "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)"
|