JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/test/test_acceptance.ml
Joseph Ferano 885470820e A NaN has no sign to print 
(/ 0.0 0.0) printed nan through LLVM, which folds it at compile time to
the positive quiet NaN, and -nan through x86, where divsd computes the
negative one. Put the operands in globals so nothing folds and both say
-nan, so the divergence is the folding path and not the arithmetic.

The sign bit of a NaN is not a property of the number and IEEE 754 does
not specify it, so the print site is where this is answered.
flan_f64_to_bytes renders any NaN as nan, and the two dev emitters do
the same. That is not a new rule: format-f64 in the prelude has always
answered nan for this value, so a build where (print x) said -nan and
(show x 2) said nan was contradicting itself inside one backend. An
infinity still prints signed.

format.flan prints the three non-finite values through print as well as
through show. It is in the survey corpus, so the one program pins the
printed form under dune test and the agreement between backends under
the survey.
2026-09-18 07:37:14 +07:00

3930 lines
199 KiB
OCaml
Raw Blame History

(* The milestone-2 acceptance test: a table of expression/result pairs run
through a compiled calc-me (plan.org, Build sequence).
It is a table rather than a golden file because milestone 3 runs the *same*
table on wasm32 — headless is what makes one test cover both targets. *)
open Flan
(* 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;
(* Two rendered numbers held at once, which is what one shared buffer in
the runtime made impossible: this printed "22 22" and could not have
been caught by a sanitizer, because every byte read was inside a live
object — the wrong one. -O0 too, since the buffer is now a frame slot
and mem2reg is what decides whether the address escapes. *)
let two_numbers_out = "11 22\n123\n2.5 7\n0 11 22 33 \n" in
outputs "two rendered numbers at once" "programs/two-numbers.flan"
two_numbers_out;
outputs ~opt:"-O0" "two rendered numbers at once, -O0"
"programs/two-numbers.flan" two_numbers_out;
(* The other side of that boundary: bytes the copy cannot represent. A NUL
inside the string is where ptr+len and C's "ends at the first NUL" stop
describing the same value, so the shim refuses instead of handing C a
prefix — the policy flan_path_cstr has always had for a path. The
refusal names the declare-c, which is the only name the program's author
wrote. *)
let exe = compile "programs/shim-nul.flan" in
let code, text = run exe None in
if code <> 134 || not (contains text "before")
|| not (contains text "c-puts: a string passed to C contains a NUL byte")
|| contains text "unreachable"
then begin
incr failures;
Printf.printf
"FAIL a string with a NUL in it is refused at the C boundary\n\
\ got: %S (exit %d)\n wanted: exit 134, naming the call\n"
text code
end;
(try Sys.remove exe with Sys_error _ -> ());
(* 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\n\
nan\ninf\n-inf\n\
1e+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 _ -> ());
(* The request whose *size* is the thing that does not fit. The count times
the element size wraps to a number a heap allocator answers, so the
block is real, the recorded capacity is not, and the write past it is
the failure no sanitizer can see — it is inside a block ASan was told to
expect. Guarded arithmetic makes it the same StorageExhausted an
exhausted region raises, because it is the same answer: the storage
asked for is not available. *)
let exe = compile "programs/reserve-overflow.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 a byte count that cannot be represented is StorageExhausted\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" ();
(* What the release build drops, and what it does not. Asserted on the IR
for the first half, because an index past the end has no defined
behaviour to run and assert on; the second half is asserted by running
the program, below, because it does.
The line: @flan_bounds_error is the bounds check and goes. The two slice
calls stay, because what survives behind them is not a bounds check —
check_slice's lo <= hi and slice-from-ptr's n >= 0 are the claim that a
%slice's length word holds a count. This assertion is written as
"present" and not merely as "no longer looked at", so that re-gating
either one on f.md.checks fails here rather than passing quietly. *)
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(" then begin
incr failures;
print_endline "FAIL --no-bounds-checks: a bounds check survived"
end;
if not (contains off "call void @flan_slice_error(") then begin
incr failures;
print_endline "FAIL --no-bounds-checks: the lo <= hi invariant went too"
end;
if not (contains off "call void @flan_slice_promise_error(") then begin
incr failures;
print_endline "FAIL --no-bounds-checks: the n >= 0 invariant went too"
end;
(* And the same thing as behaviour rather than as text. A slice built
backwards writes hi - lo into a length word that every reader takes for
a count, so the value it produces is not a slice with its bounds check
removed — it is not a slice. The same for a promise of -2 elements.
Both must still die, with the same sentence, in a build that asked for
no bounds checks at all.
The in-bounds selector is run too, and it is the other half of the
claim: the flag still buys something, and a program that slices
correctly does not start paying for a check it was promised was gone.
This is the one place the two halves can be told apart, and it is worth
one compile. *)
let unchecked = compile ~checks:false "programs/bounds.flan" in
let still_traps name arg reason =
let code, text = run unchecked (Some arg) in
if code <> 134 || not (contains text reason) then begin
incr failures;
Printf.printf
"FAIL %s under --no-bounds-checks\n got: %S (exit %d)\n\
\ wanted: %S (exit 134)\n"
name text code reason
end
in
still_traps "reversed slice" "2" "slice [2 1) is out of bounds for length 5";
still_traps "slice-from-ptr with a negative length" "-2"
"slice-from-ptr was promised -2 elements behind the pointer";
let code, text = run unchecked (Some "0") in
if text <> "0ello\n" || code <> 0 then begin
incr failures;
Printf.printf
"FAIL in-bounds edges under --no-bounds-checks\n got: %S (exit %d)\n"
text code
end;
(try Sys.remove unchecked with Sys_error _ -> ());
(* 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. The Flan name travels with the copy so that the refusal a NUL
in the bytes raises can name the call — see programs/shim-nul.flan. *)
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, \"open-it\")";
"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;
(* Removal, which is the operation that can break the others. A Robin Hood
probe stops at the first empty slot, so a hole left in the middle of a
run hides every entry past it — and the hidden ones are exactly what a
test that only asks after what it removed never looks at. Hence the
third row: 2000 entries, the even keys taken out, and then every odd one
asked for. A removal that punched the hole and left it answers row one
correctly and loses entries there.
-O0 as well, because the Option the removal answers with is built in the
compiler and not in the runtime, and mem2reg is what would hide a store
into the wrong half of it. *)
let map_remove_out =
"100\n1\nfalse\ngone\n1\n0\n77\n1\n1000\n1000\n0\n0\n2000\n\
709\nfalse\ntrue\n399\n1\ntrue\n1\n66\n0\n66\n150\n598\nfalse\n"
in
outputs "map removal" "programs/map-remove.flan" map_remove_out;
outputs ~opt:"-O0" "map removal, -O0" "programs/map-remove.flan"
map_remove_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. *)
(* Removal is a map's operation and says so, rather than reaching for a
[len] that a Vec would also answer. *)
refuses_src "map-remove! wants a map"
"(defn main [] i32 (let [v (vec-new i32)] (map-remove! v 1) (free v)) 0)"
"map-remove! takes a (Map K V)";
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;
(* ── The driver's own refusals ─────────────────────────────────────
Not about compiled code at all: about what the CLI does when it is
handed something it cannot do. Each of these was an escape before —
an OCaml exception printed by the default handler, or a build flag
silently forwarded to the program — and each is pinned here because
"it prints a sentence" is exactly the kind of claim that rots without
a test to hold it. *)
let cli args =
let out = Filename.concat scratch "flan-cli.out" in
let code =
Sys.command
(Printf.sprintf "../bin/main.exe %s > %s 2>&1" args (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 cli_case name args ~code:want_code ~says =
let code, text = cli args in
let bad =
code <> want_code
|| List.exists (fun n -> not (contains text n)) says
(* The point of half of these: no arm here may end in OCaml's default
handler, whatever else it does. *)
|| contains text "Fatal error"
in
if bad then begin
incr failures;
Printf.printf "FAIL %s\n got: %S (exit %d)\n wanted exit %d with %s\n"
name text code want_code (String.concat ", " says)
end
in
(* A path that is not there. This used to be
[Fatal error: exception Sys_error("...")] — the compiler reporting that
it had not expected to be asked. *)
cli_case "check on a file that is not there"
"check no-such-file.flan" ~code:1
~says:[ "no-such-file.flan"; "No such file or directory" ];
(* And every other front end takes the same route, since the arm is on the
one wrapper they all go through. *)
cli_case "build on a file that is not there"
"build no-such-file.flan -o /dev/null" ~code:1
~says:[ "no-such-file.flan" ];
(* [flan run] and its two argument lists. -O0 is the build's, so calc-me
never sees it and answers the expression that follows; before the split
it was handed "-O0" as the expression and said it could not parse it. *)
cli_case "run keeps a build flag out of the program's argv"
"run ../calc-me.flan -O0 '1+2'" ~code:0 ~says:[ "3" ];
(* -- hands the rest over whatever it looks like, which is what makes the
refusal below affordable. *)
cli_case "run passes everything after -- to the program"
"run ../calc-me.flan -O0 -- '3*4'" ~code:0 ~says:[ "12" ];
(* And an unknown dash argument is refused by name rather than guessed at
in either direction. *)
cli_case "run refuses a flag it does not offer"
"run ../calc-me.flan --lint" ~code:2
~says:[ "--lint"; "will not be guessed at"; "--" ];
(* The one pair of flags that cannot both be honoured: --debug is -O0 in
[Build] and says why, so asking for it alongside a higher level is a
request with two answers. *)
cli_case "--debug and an explicit -O are refused together"
"build ../calc-me.flan --debug -O2 -o /dev/null" ~code:2
~says:[ "--debug"; "-O2"; "Drop one of the two" ];
if !failures = 0 then print_endline "acceptance: all tests passed"
else begin
Printf.printf "\n%d failure(s)\n" !failures;
exit 1
end
| _ -> print_endline "acceptance: skipped (no clang on PATH)"
Reference in New Issue View Git Blame Copy Permalink