JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/test/test_acceptance.ml
Joseph Ferano 887aae45ea The next-error claim was inferred, and it is weaker than it read 
compile.el puts note in the same capture group as info — group 7, level 0 —
while warning is group 6, level 1, and compilation-skip-threshold defaults to
1. So next-error walks the errors with no configuration, which is the claim
M-x compile rests on and it holds; it steps over the notes until the
threshold is 0. They are still parsed, coloured and clickable.

Labelling notes warning: would make them navigable at the default and is
refused. A note is not a warning, and a compile whose only complaint is an
error would start reporting warnings that are not warnings.

The macro expansion field gets the test it was missing, through a real
expansion rather than a unit test on either half: the tag is put on by Macro
and defaulted into the diagnostic by Loc, and either half alone would pass
with the other broken. clamp misused expands into a call to a name that does
not exist, so the checker refuses something the author never wrote, which is
the case the field is for.
2026-09-13 08:12:49 +07:00

2911 lines
146 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 (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
(* [Reach.link] decides the link from the program: a package nothing
reachable calls into hands over no C and no linker argument, and its
functions are not emitted. *)
let p, csrcs, lflags = Reach.link ~dev l p in
ignore (Build.executable ~opts:{ Build.default with opt; checks; dev }
~csrcs ~lflags p ~out:exe);
exe
(* No Str, and the reader is hand-written for the same reason. *)
let contains hay needle =
let n = String.length needle and h = String.length hay in
let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
go 0
let () =
match Sys.command "command -v clang > /dev/null 2>&1" with
| 0 ->
let exe = compile "../calc-me.flan" in
let case name arg expected_out expected_code =
let code, text = run exe arg in
if text <> expected_out || code <> expected_code then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit %d)\n"
name text code expected_out expected_code
end
in
let evaluates src expected = case src (Some src) (expected ^ "\n") 0 in
let rejects src = case src (Some src) "calc-me: cannot parse\n" 1 in
(* Arithmetic and precedence *)
evaluates "1 + 2 * (3 - 0.5) / 2" "3.5";
evaluates "1+2*3" "7";
evaluates "2*3+4" "10";
evaluates "(1+2)*3" "9";
evaluates "10/4" "2.5";
evaluates "7" "7";
evaluates " 7 " "7";
evaluates "1.5+2.25" "3.75";
(* Left-associative: 1-2-3 is (1-2)-3, not 1-(2-3) *)
evaluates "1-2-3" "-4";
evaluates "8/4/2" "1";
(* Unary minus, including nested *)
evaluates "-5" "-5";
evaluates "-(1+2)" "-3";
evaluates "3 * -2" "-6";
(* Whole input or nothing: trailing junk is an error, not ignored *)
rejects "1 +";
rejects "(1+2";
rejects "1 2";
rejects "";
rejects "+";
rejects "1+2)";
case "no argument" None "usage: calc-me \"1 + 2 * 3\"\n" 1;
(try Sys.remove exe with Sys_error _ -> ());
(* Programs whose whole output is fixed. These cover the milestone-2
surface calc-me does not reach — globals, 2-D arrays, places through a
pointer, casts, match with either arm taken, and the value semantics of
spec-memory.md. *)
let outputs ?opt ?dev name path expected =
let exe = compile ?opt ?dev path in
let code, text = run exe None in
if text <> expected || code <> 0 then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 0)\n"
name text code expected
end;
(try Sys.remove exe with Sys_error _ -> ())
in
let values_out = "1\n5\nel\n" in
let machine_out = "12\n30\n2\n2\n3\n3.5\n42\n99\n12\n123\n" in
outputs "value semantics" "programs/values.flan" values_out;
outputs "machine surface" "programs/machine.flan" machine_out;
outputs "unit main exits 0" "programs/unit-main.flan" "ok\n";
(* (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";
(* The prelude's slice algorithms. Every assertion here is over an input a
wrong implementation fails: unsorted with duplicates, negatives and an
odd length; a reverse-sorted slice; and a sort of a subslice whose
neighbours must be untouched, which is the in-place, ptr+len claim
itself. At -O0 as well — a slice parameter is an alloca of a two-word
struct, and mem2reg is exactly what would hide it being copied. *)
let slices_out =
"5 -3 5 0 12 -3 7\n23\n-3\n12\n0\n-1\n99\n\
7 -3 12 0 5 -3 5\n-3 7 12 0 5 -3 5\n\
-3 -3 0 5 5 7 12\n1 2 3 4 5\n\
100 -1 0 4 9 9 200 300\n100 -1 0 4 9 9 200 300\n"
in
outputs "slice algorithms" "programs/slices.flan" slices_out;
outputs ~opt:"-O0" "slice algorithms, -O0" "programs/slices.flan" slices_out;
(* 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;
(* index-of-bytes, trim, the byte classes and parse-f64. The search cases
are the ones that separate a correct loop from a lucky one: a match
only at the end, "aab" in "aaab" (where the first byte matches twice
before the needle does), a needle longer than the haystack, which must
answer None without building a window off the end, and the empty needle
at Some 0. trim prints inside brackets so the all-whitespace answer is
visible as [] — that input is also the one that would build a reversed
slice and trap. And parse-f64's refusals are every shape strtod hands
back a plausible number for: "", "abc", "1x", ".", "1e", " 1", "1 ",
"0x10", "nan". *)
let bytes2_out =
"6 0 4 2 1 \n\
-1 -1 -1 0 0 0 \n\
[hi][hi][hi][][][a b][x][x]\n\
ttfff\n\
ttttff\n\
0 3.5 -3.5 0.25 1000 0.015 12\n\
-999 -999 -999 -999 -999 -999 -999 -999 -999 -999 -999\n\
1 0.5\n\
2.25\n"
in
outputs "substring, trim and parse-f64" "programs/bytes2.flan" bytes2_out;
outputs ~opt:"-O0" "substring, trim and parse-f64, -O0" "programs/bytes2.flan"
bytes2_out;
(* (string b). The conversion emits nothing — String and Slice _ are the
same %slice — so the rows are about length and ownership rather than
arithmetic: a number round-tripped, an empty slice, sub-views whose
length is not the underlying storage's, and the result crossing a
declare-c boundary where the shim NUL-terminates a copy. That last one
is the load-bearing case: "hello world" cut to five bytes has a space
where C wants a NUL, so a shim that trusted the bytes would print all
eleven. Both levels, because a reinterpretation that had accidentally
been undefined would fail one way at -O0 and the other at -O2. *)
let string_of_bytes_out =
"[42] 2\n[-7] 2\n[0] 1\n[] 0\n\
[hello] 5\n[world] 5\n[] 0\n\
7\n\
hello\nok\n12345\nok\n\nok\n"
in
outputs "string of bytes" "programs/string-of-bytes.flan" string_of_bytes_out;
outputs ~opt:"-O0" "string of bytes, -O0" "programs/string-of-bytes.flan"
string_of_bytes_out;
(* handler-bind and signal, spec-conditions.md §1 and §2: signal returns
Unit and carries on, an unhandled one is a no-op, a nested frame does
not displace the one outside it, and the stack is restored after. *)
let conditions_out = "0\n3\n23\n3\n1103\n1103\n" in
outputs "conditions" "programs/conditions.flan" conditions_out;
outputs ~opt:"-O0" "conditions, -O0" "programs/conditions.flan" conditions_out;
outputs ~dev:true "conditions, dev" "programs/conditions.flan" conditions_out;
(* restart-case and invoke-restart, §3 to §6: the transfer itself. A
fall-through with nothing handling it, a clause reached from two frames
down, the defer in between running on the way out, an inner frame
shadowing an outer one of the same name, and a handler that returns
normally still transferring nothing. At -O0 as well, because the guard
after every call is control flow the optimiser would otherwise launder;
and as a dev build, where every one of those calls goes through a cell.
Then §3's parameters: one, two of them in an order a sum would not pin,
a string beside an integer, a clause taking none in the same form as
clauses taking some, and an argument that is a call to a function
reached from nowhere else. The last one is the reachability claim — an
invoke-restart whose arguments were not walked would drop [half] and
fail to link, which is why the arguments are evaluated into slots before
the node rather than hanging off it. *)
let restarts_out =
"101\n1\n-1\n2\n7\n1010\n101\n105\n-2\n42\n34\n7\nsupplied\n5\n42\n"
in
outputs "restarts" "programs/restarts.flan" restarts_out;
outputs ~opt:"-O0" "restarts, -O0" "programs/restarts.flan" restarts_out;
outputs ~dev:true "restarts, dev" "programs/restarts.flan" restarts_out;
(* §3's run-time check, which is the price of a restart being found by name
on a dynamic stack: neither end of an invoke can see the other, so what
a clause takes against what was given is settled where the transfer
starts. Each of these stops the program, so each is asserted on its
reason rather than on the exit status alone — too few arguments, the
right count of the wrong type, and arguments handed to a clause that
takes none. *)
let restart_mismatch ?opt () =
let exe = compile ?opt "programs/restarts.flan" in
let refuses name arg reason =
let code, text = run exe (Some arg) in
if code <> 134
|| not (contains text "programs/restarts.flan:")
|| not (contains text reason)
then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 134)\n"
name text code reason
end
in
refuses "a restart invoked with too few arguments" "1"
"restart use-value takes (i32), given ()";
refuses "a restart invoked with the wrong type" "2"
"restart use-value takes (i32), given (string)";
refuses "arguments given to a restart that takes none" "3"
"restart retry takes (), given (i32)";
(* §4 meets §3. The name finds the innermost frame offering it and the
signature is checked against *that*; nothing searches outward for a
frame the arguments would have fitted, and an outer clause that would
have taken them is not consulted. *)
refuses "a shadowing clause of the same name and a different signature" "4"
"restart use-value takes (string), given (i32)";
(try Sys.remove exe with Sys_error _ -> ())
in
restart_mismatch ();
restart_mismatch ~opt:"-O0" ();
(* The other way a transfer starts is the break loop, which chooses a
restart by position and has nothing to fill parameters in with. It
reaches the clause through the same channel an invoke-restart writes, so
nothing downstream could tell the two apart — except that the clause's
buffer is still the zero the frame was pushed with. Asserted on the IR,
because driving it needs a stopped program and a socket, and what is
being claimed is that the guard exists at all. *)
let p =
Reader.read_file "programs/restarts.flan" |> Parse.program |> Check.program
in
if not (contains (Emit.program p) "call void @flan_restart_unarmed(") then begin
incr failures;
print_endline
"FAIL a clause with parameters has no guard against being taken \
without any"
end;
(* What is refused before anything runs, and why. Not everything about a
restart's arguments waits for run time: the shape of the form and
whether an argument is a value at all are here, and each is asserted on
its reason. *)
let refuses_src name src needle =
match Check.program (Parse.program (Reader.read_all ~file:"<restarts>" src)) with
| _ ->
incr failures;
Printf.printf "FAIL %s\n it was accepted\n" name
| exception Loc.Error { Loc.dmsg = m; _ } ->
if not (contains m needle) then begin
incr failures;
Printf.printf "FAIL %s\n said: %S\n wanted: %S in it\n"
name m needle
end
in
(* The 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;
(* free-all on an allocator that does not offer it traps rather than doing
nothing, because "I released the region" and "I leaked the region" must
not be the same program text. Its own case for the same reason the
bounds traps are: a trap has no result, only an exit and a message. *)
let exe = compile "programs/free-all-refused.flan" in
let code, text = run exe None in
if code <> 134
|| not (contains text "programs/free-all-refused.flan:")
|| not (contains text "does not offer free-all")
then begin
incr failures;
Printf.printf
"FAIL free-all on an allocator without it\n\
\ got: %S (exit %d)\n wanted: exit 134, naming the site\n"
text code
end;
(try Sys.remove exe with Sys_error _ -> ());
(* (Vec T), spec-memory.md. Two element types over one type-erased
runtime, which is the whole claim: size_of and align_of are produced at
the concrete call site and nothing below it knows the element type. The
moves are here too — into a call and out of one — because a Vec that
cannot be handed to a function is not a container anyone can use. *)
let vec_out =
"0\n3\n10\n30\n99\n139\n2\n99\n-1\n10\n3\n4\n\
<vec>\n<allocator>\n2\n4\n7\nfalse\n11\n5\n"
in
outputs "vec" "programs/vec.flan" vec_out;
outputs ~opt:"-O0" "vec, -O0" "programs/vec.flan" vec_out;
outputs ~dev:true "vec, dev" "programs/vec.flan" vec_out;
(* The prelude's second tier: the functions that return new storage, every
one of which the prelude used to refuse by name for want of an
allocator. The cases are the ones that separate a correct version from a
lucky one — join over zero and one parts, where the separator count is
-1 and 0; "aaa" with "aa" -> "b", which is "ba" only if the match is
non-overlapping; an empty `from` to replace, which is an infinite loop
under the other reading; and split's trailing and leading empty fields,
which is where Odin's iterator and Odin's own allocating split disagree.
The builder line holds two rendered integers and a float at once, which
is precisely what the runtime's shared static scratch makes impossible
for i64->bytes on its own.
The dev run earns its place here more than most: it is the one that
checks a container's recorded allocator epoch, so it is what would catch
one of these Vecs being used after the arena under it was released. *)
let strings_out =
"x=42 y=-7 r=1.5\nonetwo\n0\na, b, c\na\n0\nabc\nababab\n0\n\
hello, world 42!\nHELLO, WORLD 42!\n\
ba\na -- b -- c\nabc\nabc\nabc\n\
3\na\nc\n3\n0\n2\n0\n1\nabc\n1\n0\na/b/c\nin-arena\n"
in
outputs "string building" "programs/strings.flan" strings_out;
outputs ~opt:"-O0" "string building, -O0" "programs/strings.flan"
strings_out;
outputs ~dev:true "string building, dev" "programs/strings.flan"
strings_out;
(* format-f64, the first number formatter a caller can steer. The three
lines that would ship wrong are pinned deliberately: 0.999995 at five
places, where the rounded fraction equals the scale and is the next
integer rather than a fraction; 1.005 at three, where dropping the zero
padding prints "1.5"; and -0.5, where the sign belongs to the number and
the integer part it would otherwise ride on is 0, which i64->bytes
renders unsigned.
0.125 at two places answers 0.13 and printf's "%.2f" answers 0.12. That
is not a defect: this rounds the decimal expansion half away from zero,
which is round-f32's rule and the rest of this file's, where printf
rounds the binary value to nearest-even. Pinning 0.12 here would be
pinning a libc.
The last line is the one the whole shape is for — two numbers in one
built string, which the runtime's single shared scratch buffer makes
impossible for a formatter that answers a slice. *)
let format_out =
"3.14\n0.02\n1234.5\n2\n2.000\n\
0.13\n-0.13\n3\n-3\n\
1.00000\n10.0\n-10.0\n1\n\
1.005\n1.0001\n7.000000\n\
-0.50\n-0.00\n0.00\n0.00\n\
2\n1.500000000\n\
nan\ninf\n-inf\n1e+20\n1234567890123.00\n\
fps 59.9 / frame 0.0167\n"
in
outputs "a number with a precision" "programs/format.flan" format_out;
outputs ~opt:"-O0" "a number with a precision, -O0" "programs/format.flan"
format_out;
(* The slice family at its second and third element types. sort-i32! was
the only sort in the language; these are copies rather than an
abstraction, because map/filter/reduce and a comparator sort all need a
function value and check.ml refuses one outright.
Two lines carry the claims that are not about sorting. The subslice sort
leaves its neighbours alone, which is the in-place ptr+len contract and
the one thing a version that copied would fail. And the 2 is the width of
sum-f32's accumulator made visible: 2^24 is where an f32 stops having a
bit for 1, so an f32 running total absorbs both addends and prints 0. *)
let algorithms_out =
"-2.25 -1 0 0.5 3.5 3.5 10 \n\
9 1 2 3 4 9 \n\
1 2 3 \n1 2 3 \n7 \n\n\
4 3 2 1 \n\
-1 10 12.5\nnone 0\n2\n\
true false false true false true true\ntrue false\n\
Fig apple apple banana pear \n\
alpha < bravo < charlie < delta\n"
in
outputs "sorting f32 and byte slices" "programs/algorithms.flan"
algorithms_out;
outputs ~opt:"-O0" "sorting f32 and byte slices, -O0"
"programs/algorithms.flan" algorithms_out;
(* A debug build, because [dty] is a separate path from everything above:
[outputs ~dev:true] goes through the cells, not through DWARF, and a
type with no arm there dies at emit rather than being merely undebugged.
That is NEXT.md's landed item 2 exactly — [field_addr] took only
[Types.Named], so the printer's Option arm had never run. Asserted on
the metadata as well as on the program still working: a composite whose
element count disagreed with [lay] would print plausible values for the
wrong fields, which is the failure debug info has. *)
let dbg = Emit.program ~debug:true (Check.program
(Parse.program (Reader.read_file "programs/vec.flan"))) in
if not (contains dbg "name: \"Allocator\"")
|| not (contains dbg "name: \"(Vec i32)\", size: 384")
then begin
incr failures;
print_endline "FAIL debug info for Allocator and (Vec T)"
end;
(* StorageExhausted and retry. The allocator is genuinely exhausted — a
ceiling on live bytes, hit repeatedly — and the handler raises it and
invokes retry, so the same request is re-attempted and no push is lost.
Every allocating operation is covered, not only push: reserve asks for
the whole block at once and clone asks for the source's length.
At -O0 because the retry loop and the guard after the error are control
flow an optimiser would otherwise launder. *)
let exhausted_out = "64\n0\n126\ntrue\ntrue\n4\ntrue\n0\n8\n7\ntrue\n" in
outputs "storage exhausted, retried" "programs/exhausted.flan" exhausted_out;
outputs ~opt:"-O0" "storage exhausted, retried, -O0" "programs/exhausted.flan"
exhausted_out;
outputs ~dev:true "storage exhausted, retried, dev" "programs/exhausted.flan"
exhausted_out;
(* The same exhaustion with nothing handling it. [error] is the diverging
variant: the program stops on the frame that erred rather than carrying
on with a push that appended nothing, which is the Odin outcome the rule
exists to make impossible. *)
let exe = compile "programs/exhausted-unhandled.flan" in
let code, text = run exe None in
if code <> 134 || not (contains text "before")
|| not (contains text "unhandled StorageExhausted")
|| contains text "unreachable"
then begin
incr failures;
Printf.printf
"FAIL an unhandled StorageExhausted stops the program\n\
\ got: %S (exit %d)\n wanted: exit 134, naming the condition\n"
text code
end;
(try Sys.remove exe with Sys_error _ -> ());
(* -- Files, NEXT.md decisions 1, 2 and 5 --------------------------
Embedding first, because it is the one that costs nothing at run time
and needs no host ABI at all: a compiler feature, so no linker
arguments, no per-target packaging, and identical on desktop and web.
At -O0 and as a dev build too - a dev build emits a defconst as a
mutable global, so the (embed-dir) constant travels a different path
there and is worth seeing twice. *)
let embed_out =
"13\nhello from a\nBBB\n4\n0\n255\n254\n3\na.txt\nb.bin\nraw.bin\nBBB\n\
no nope.txt\n"
in
outputs "embed, a file and a directory" "programs/embed.flan" embed_out;
outputs ~opt:"-O0" "embed, -O0" "programs/embed.flan" embed_out;
outputs ~dev:true "embed, dev" "programs/embed.flan" embed_out;
(* slurp and barf, with all three restart paths taken: use-value on a read,
use-value on a write, and retry after the handler made the file. The
typed restart is the thing being exercised as much as the file I/O -
this is the first restart clause the *compiler* emits with a parameter,
and its parameter is the path slot the attempt reads. *)
let slurp_out =
"13\nhello from a\n4\n0\n255\n3\nBBB\n1\ntrue\ntrue\n\
programs/assets/does-not-exist\n11\nround trip\n1\ntrue\nsecond\n\
made by the handler\n1\ntrue\n"
in
let clean () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ "slurp-out.txt"; "slurp-made.txt" ]
in
clean ();
outputs "slurp and barf, with restarts" "programs/slurp.flan" slurp_out;
clean ();
outputs ~opt:"-O0" "slurp and barf, -O0" "programs/slurp.flan" slurp_out;
clean ();
outputs ~dev:true "slurp and barf, dev" "programs/slurp.flan" slurp_out;
clean ();
(* slurp's use-value is the first restart clause the *compiler* emits with
a parameter - alloc_guard's retry takes none - so the guard against the
break loop taking it with nothing to fill the parameter in with is worth
asserting here too. It is the same emit.ml path a hand-written typed
clause goes through (the restarts.flan case above), and this says the
compiler-emitted one is on it rather than beside it. *)
let p =
Reader.read_file "programs/slurp.flan" |> Parse.program |> Check.program
in
if not (contains (Emit.program p) "call void @flan_restart_unarmed(") then begin
incr failures;
print_endline
"FAIL the compiler-emitted use-value has no guard against being taken \
without an argument"
end;
(* The desktop half of the one program whose behaviour differs by target.
test_web.ml builds this same text for the browser and asserts the other
outcome: there `barf` signals and the program says which file it could
not write, here it writes it. No conditional compilation is involved in
either - nothing in parse.ml or check.ml reads the target, and the whole
of the difference is one #ifdef in flan_rt.c. Seeing both halves is what
makes the claim a test rather than an assertion. *)
(try Sys.remove "web-files-out.txt" with Sys_error _ -> ());
outputs "files, the desktop half of the web case" "programs/web-files.flan"
"hello from a\nwrote it\n";
(try Sys.remove "web-files-out.txt" with Sys_error _ -> ());
(* A missing file with nothing handling it. The same rule StorageExhausted
follows: [error] is the diverging variant, so the program stops on the
frame that erred rather than carrying on with a Vec that was never
filled. Neither restart is taken and both were still offered. *)
let exe = compile "programs/slurp-unhandled.flan" in
let code, text = run exe None in
if code <> 134 || not (contains text "before")
|| not (contains text "unhandled FileError")
|| contains text "unreachable"
then begin
incr failures;
Printf.printf
"FAIL an unhandled FileError stops the program\n\
\ got: %S (exit %d)\n wanted: exit 134, naming the condition\n"
text code
end;
(try Sys.remove exe with Sys_error _ -> ());
(* The 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 _ -> ());
(* 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"
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.
Skipped without FLAN_RAYLIB_H, because the import is opt-in — a build
needs libraylib linkable and not raylib-devel installed, and that is a
property worth keeping. The importer's own table does not skip: it runs
against test/headers/sample.h, which is committed. *)
(match Sys.getenv_opt "FLAN_RAYLIB_H" with
| Some h when Sys.file_exists h
&& Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 ->
let out = "10\n5\n287454020\n17\n34\n51\n68\n" in
outputs "raylib, bindings read 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 read from the header, -O0"
"programs/raylib-imported.flan" out
| _ ->
print_endline
"acceptance: skipping the imported-bindings case (FLAN_RAYLIB_H unset)");
(* raylib's Image family, headless, and the strongest FFI case here: an
Image is pixels in RAM, so raylib *computes* with it rather than
storing and returning it.
Two separate things are pinned. gen-image-color is handed two scalars
and answers with a struct reading 4, 2, 1, 7 — four distinct values in
four adjacent i32 slots, so exchanging any two of width, height,
mipmaps and format is visible, and dropping `data` makes width the low
half of raylib's pointer. Scalars in and fields out is what makes that
work: a permuted layout has nothing to cancel against, unlike the
shapes texture, where nothing without a GPU read width, height or
mipmaps at all.
The other is the axis, which the collision cases could not get. raylib
indexes a pixel as y*width + x, and the image is 4 wide by 2 tall, so
(3,0) exists and its transpose does not — exchange x and y in the shim
and the read is out of bounds and answers transparent black. The
horizontal and vertical flips are the same argument twice more: on two
rows, one of them moves a mark that the other leaves alone.
The PNG round trip is not the symmetric trap either: stb's encoder and
decoder are external ground truth and agree with each other rather than
with whatever field order Flan believes in. It also crosses a path as
ptr+len. /tmp is written to, and both optimisation levels write the
same bytes, so the shared name is harmless.
Trace logging stays at :warning and no read here is out of bounds, so
a warning appearing in this output is a real failure — [run] folds
stderr in. *)
let raylib_image_out =
"generated 4 2 1 7\n\
at 3,0 200 0 0 255\n\
at 0,1 0 200 0 255\n\
at 0,0 10 20 30 255\n\
at 3,1 10 20 30 255\n\
flipped-h at 0,0 200 0 0 255\n\
flipped-h at 3,1 0 200 0 255\n\
flipped-h at 3,0 10 20 30 255\n\
flipped-v at 0,1 200 0 0 255\n\
flipped-v at 3,0 0 200 0 255\n\
flipped-v at 0,0 10 20 30 255\n\
exported yes\n\
loaded valid yes\n\
loaded 4 2 1 7\n\
loaded at 0,1 200 0 0 255\n\
loaded at 3,0 0 200 0 255\n\
loaded at 0,0 10 20 30 255\n\
resized-nn 8 2 1 7\n\
nn at 0,1 200 0 0 255\n\
nn at 1,1 200 0 0 255\n\
nn at 6,0 0 200 0 255\n\
nn at 7,0 0 200 0 255\n\
nn at 2,1 10 20 30 255\n\
resized 2 6 1 7\n\
cropped 2 1 1 7\n\
cropped at 1,0 200 0 0 255\n\
cropped at 0,0 10 20 30 255\n"
in
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
outputs "raylib images, headless" "programs/raylib-image.flan"
raylib_image_out;
outputs ~opt:"-O0" "raylib images, headless, -O0" "programs/raylib-image.flan"
raylib_image_out
end
else
print_endline "acceptance: skipping the raylib Image case (no libraylib)";
(* raylib's Wave family, headless — and the first claim to make about it
is that it exists. The received wisdom in this repository was that
audio needs a device and so cannot be in this table at all. That is
true of Sound, Music and AudioStream, every one of which is a handle
the miniaudio mixer owns, and false of Wave: samples in RAM and four
integers describing them, with copy, crop, reformat, export, load and
decode all running on the CPU. So it gets the Image family's treatment.
Three shapes, and they pin different things.
wave-format is the scalars-in/fields-out case gen-image-color is: three
plain integers go in and all four u32 fields come out, with
frame-count *computed* from the ratio of the sample rates — 16, from
eight frames at twice the rate, and no argument named it. Eight bits
rather than sixteen in that call so sample-size cannot be confused
with the frame count it would otherwise equal.
export-wave then load-wave is external ground truth, the PNG argument
transposed: dr_wav writes the header from three fields and reads them
back, agreeing with itself rather than with Flan's field order. Be
precise about its reach, because it is narrower than it looks — it
catches sample-size against channels (the "loaded" line reads
"8 8000 16 16" when those two are exchanged) and NOT frame-count
against sample-rate, which leaves every line of the round trip green.
The crop and the reformat are what catch that pair.
And the decoded samples are the axis discriminator this section needed.
load-wave-samples answers a (Ptr f32), which Flan cannot index — [at]
takes an array, a slice or a string — so the program crops to a single
frame first and dereferences sample 0. That detour is what makes the
case strong rather than weak: raylib's crop offset is init-frame times
channels times sample-size over 8, so asking for frame 3 and getting
+3000 pins sample-size against channels. Exchange those two and the
crop lands two bytes off and the sample is a different number, not the
same one mirrored, which is the failure mode axis-aligned geometry
could never produce.
Verified red by permuting the Wave defstruct three ways: frame-count
with sample-rate (cropped reads "8 4 16 1" and reformatted
"16000 16000000 8 2", while the file round trip stays green — see
above), sample-size with channels (every frame read turns to "no" and
the loaded line reads "8 8000 16 16"), and data moved to the front
(the run dies after two lines). *)
let raylib_audio_out =
"valid yes\n\
source 8 8000 16 1\n\
cropped 4 8000 16 1\n\
reformatted 16 16000 8 2\n\
frame 1 is +1000 yes\n\
frame 3 is +3000 yes\n\
frame 4 is -3000 yes\n\
frame 0 is zero yes\n\
exported yes\n\
loaded valid yes\n\
loaded 8 8000 16 1\n\
loaded frame 1 is +1000 yes\n\
loaded frame 4 is -3000 yes\n"
in
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
outputs "raylib audio, headless" "programs/raylib-audio.flan"
raylib_audio_out;
outputs ~opt:"-O0" "raylib audio, headless, -O0" "programs/raylib-audio.flan"
raylib_audio_out
end
else
print_endline "acceptance: skipping the raylib Wave case (no libraylib)";
(* raylib's Font family, headless, which the package refused to bind at
all until now. The stated reason was that a Font drags in two more
aggregates and two owned arrays "for something with no headless test at
the end of it". The generator takes all of it unchanged — a struct held
by value is emitted after what it contains, one held by pointer is
forward-declared — and the test turned out to exist.
What makes it exist is that the program does not ASK raylib for a font.
Every call that makes one needs a window or a TTF and a GL context.
So it builds one out of Flan arrays, field by field, and hands it over
to be computed with: three glyphs, three atlas rectangles, a base size
of 10 and a texture that is a lie in every field but [id]. Text
measuring is pure arithmetic over exactly those fields, so this is
scalars in and numbers out with no raylib-produced struct anywhere for
a permutation to cancel against.
The one raylib trap worth recording: MeasureTextEx returns (0,0)
immediately when font.texture.id is 0. The hand-built font claims an id
of 1, and that guard is what pins where the Texture2D sits inside the
Font — land it elsewhere and every measurement collapses to zero.
Glyph C carries an advance of 0 deliberately, which sends raylib down
its other branch: the atlas rectangle's width plus the glyph's offset,
9 + 3 = 12, which is why "ABC" is 36 and "AB" is 24. And "A" at a
spacing of 3 measures 11 and not 14, because spacing is added per gap
and not per glyph — without that line, a wrapper that added it per
glyph would pass everything else.
Verified red by six permutations. In Font: base-size with glyph-count
(the measurements become 80, 120, 163 and 36.6667), the recs and glyphs
pointers (floats in the 1e9 range and a garbage atlas rectangle), and
[texture] moved to the end (the run dies after the first line). In
GlyphInfo: offset-x with advance-x (3, 6, 9, 1), and [image] moved to
the FRONT, which shifts the four ints by 24 bytes — the glyph search
collapses, every index reads 0 and glyph C answers with A's fields.
In Rectangle: x with width, which moves "measure ABC" to 39 and leaves
"measure AB" at 24, since only the advance-0 fallback reads a width out
of the recs array. Two of the six were a crash rather than a wrong
number, which still counts.
What this case does NOT pin, said here for the same reason the
Texture2D notes above say it: glyph-padding is read by nothing raylib
computes on the CPU, offset-y only moves a glyph when it is drawn, and
of each atlas rectangle only `width` is ever looked at. Those four
fields rest on the header agreeing with raylib's and on sand.flan
looking right, and on nothing else. *)
let raylib_font_out =
"valid yes\n\
index A 0\nindex B 1\nindex C 2\nindex Z 0\n\
atlas B 5 0 7 10\n\
glyph C value 67\nglyph C offset 3\nglyph C advance 0\n\
measure AB 24 10\n\
measure ABC 36 10\n\
measure AB big 51 20\n\
measure A spaced 11 10\n"
in
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
outputs "raylib fonts, headless" "programs/raylib-font.flan"
raylib_font_out;
outputs ~opt:"-O0" "raylib fonts, headless, -O0" "programs/raylib-font.flan"
raylib_font_out
end
else
print_endline "acceptance: skipping the raylib Font case (no libraylib)";
(* Again at -O0. Everything above runs through mem2reg, which launders a
sloppy alloca; -O0 tests the IR actually emitted, so a disagreement
between the two points at undefined behaviour rather than a typo. *)
(* sand.flan's simulation, headless. This is the milestone-4 acceptance
case: N frames from a seeded PRNG, one hash. It imports the sim package
and not raylib, deliberately — a program that imports raylib links
libraylib on every target, and this one is the version meant to run on
wasm32 too. The hash is reproducible only because rand-f32 is ours. *)
let sand_out = "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";
(try Sys.remove exe with Sys_error _ -> ())
in
bounds ();
bounds ~opt:"-O0" ();
(* The release build drops them — the calls, that is; the two declarations
stay in the header and LLVM discards the unused ones. Asserted on the IR
rather than by running an unchecked out-of-bounds program, which has no
defined behaviour to assert on. *)
let p =
Reader.read_file "programs/bounds.flan" |> Parse.program |> Check.program
in
if not (contains (Emit.program p) "call void @flan_bounds_fail(") then begin
incr failures;
print_endline "FAIL checks on: no bounds call emitted"
end;
let off = Emit.program ~checks:false p in
if contains off "call void @flan_bounds_fail(" || contains off "call void @flan_slice_fail(" then begin
incr failures;
print_endline "FAIL --no-bounds-checks: a check survived"
end;
(* ── Packages: the link follows the program ────────────────────────
A package's C and linker arguments used to come with the import,
whatever [main] did — which is what made sand's two halves two files
rather than one file with two entry points (NEXT.md, sand.flan is two
programs). [Reach.link] decides it from the checked program instead:
nothing reachable calls into raylib here, so no shim is compiled, no
-lraylib is passed, and no body that would reference a raylib symbol is
emitted. Natively that is invisible; the wasm32 case below is where it
is the difference between building and not. *)
outputs "an imported package nothing calls" "programs/pkg-unused.flan"
"ok\n";
outputs "an imported package nothing calls, -O0" ~opt:"-O0"
"programs/pkg-unused.flan" "ok\n";
(* A package may import a package, and one reached along two routes is read
once: pkg-shared imports sand.flan, which imports raylib, and imports
raylib itself. Loading it twice would declare every binding twice. *)
outputs "a package reached along two routes" "programs/pkg-shared.flan"
"ok\n";
(* 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";
(* 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 (Parse.program (Reader.read_file path)) in
ignore (Check.program l.Load.decls)
in
match attempt () with
| () ->
incr failures;
Printf.printf "FAIL %s\n it was accepted\n" name
| exception Loc.Error { 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
(* Visibility: main is not a name a package offers, and saying so is the
point — "unknown name sand/main" would be true and useless. *)
refuses "a package's main is not visible" "programs/pkg-hidden-main.flan"
"sand/main is not a name";
refuses "one directory under two aliases" "programs/pkg-two-aliases.flan"
"one directory is one set of names";
(* 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 not declare a macro yet, and the reason is the ordering:
collecting one would mean resolving that package's own imports over
Forms, before Load runs. Refused where the defmacro is written rather
than where it is called, because that is where the fix goes. *)
refuses "a macro in an imported package" "programs/pkg-macro.flan"
"macros are not imported yet";
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 three shapes ownership is not transitive through yet. Each is
refused where it is declared, naming drop as what it waits on, rather
than accepted into a path that would copy a header and hand out a
second owner. *)
refuses "a struct field that owns a Vec" "programs/vec-in-struct.flan"
"a struct that owns one is move-only too";
refuses "a global Vec" "programs/vec-global.flan"
"the dead set is per function";
refuses "a Vec of a Vec" "programs/vec-of-vec.flan"
"copies and releases elements bytewise";
(* 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 (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
let p, csrcs, lflags = Reach.link l p in
ignore
(Build.executable
~opts:{ Build.default with opt; target = Some "wasm32-wasi" }
~csrcs ~lflags p ~out)
in
let wasm_run ?arg runner wasm =
let out = Filename.concat scratch "flan-acceptance-wasm.out" in
let code =
Sys.command
(Printf.sprintf "%s %s %s > %s 2>&1" runner (Filename.quote wasm)
(match arg with None -> "" | Some a -> Filename.quote a)
(Filename.quote out))
in
let text = In_channel.with_open_bin out In_channel.input_all in
(try Sys.remove out with Sys_error _ -> ());
(code, text)
in
(match wasm_runner with
| None ->
print_endline
"acceptance: skipping the wasm32 case (no wasmtime, wasmer or node)"
| Some runner ->
let probe = Filename.concat scratch "flan-wasm-probe.wasm" in
let outcome =
match wasm_build "programs/unit-main.flan" probe with
| () ->
let code, text = wasm_run runner probe in
if code = 0 && text = "ok\n" then Ok ()
else
Error
(Printf.sprintf "%s could not run it: %S (exit %d)" runner text
code)
| exception Failure m -> Error m
in
(try Sys.remove probe with Sys_error _ -> ());
(match outcome with
| Error why ->
Printf.printf "acceptance: skipping the wasm32 case (%s)\n" why
| Ok () ->
let wasm_case name ?opt ?arg path expected =
let wasm =
Filename.concat scratch
("flan-w-" ^ Filename.remove_extension (Filename.basename path)
^ ".wasm")
in
wasm_build ?opt path wasm;
let code, text = wasm_run ?arg runner wasm in
if text <> expected || code <> 0 then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 0)\n"
name text code expected
end;
(try Sys.remove wasm with Sys_error _ -> ())
in
(* The hash, which must equal the native one above. At both levels:
agreement at -O2 alone could be a coincidence of how LLVM folded
the float arithmetic, and -O0 is the cheap way to say it is not. *)
wasm_case "sand, headless, wasm32" "programs/sand-headless.flan"
sand_out;
wasm_case "sand, headless, wasm32, -O0" ~opt:"-O0"
"programs/sand-headless.flan" sand_out;
(* And the two fixed-output programs, which between them cover the
milestone-2 surface: globals, 2-D arrays, places through a
pointer, casts and match. A 32-bit pointer is the thing most
likely to go wrong and these are where it would show. *)
wasm_case "value semantics, wasm32" "programs/values.flan" values_out;
wasm_case "machine surface, wasm32" "programs/machine.flan"
machine_out;
(* calc-me, for the one host-ABI path the three above do not touch:
[flan_argv] builds an array of flan_slice in C and Flan indexes it
as [string], so what is pinned here is the element *stride* of a
ptr+len pair, which is 16 bytes native and 12 on wasm32 — not a
field offset, and nothing else in the table reaches it. This is
also the file header's own claim, that the table runs on wasm32
too, honoured for the first time. *)
wasm_case "calc-me, wasm32" "../calc-me.flan"
~arg:"1 + 2 * (3 - 0.5) / 2" "3.5\n";
(* And the case the whole of Reach.link exists for: a program that
imports raylib, calls none of it, and builds for a target where
libraylib cannot be linked at all. Before, this was not a failing
test — it was a file nobody could write. *)
wasm_case "an imported package nothing calls, wasm32"
"programs/pkg-unused.flan" "ok\n";
wasm_case "an imported package nothing calls, wasm32, -O0"
~opt:"-O0" "programs/pkg-unused.flan" "ok\n"));
(* The EDN tokenizer, and the struct reader written by hand against it
(vendor/edn, test/programs/edn.flan). The expected output is a raw
literal because the token dump is full of brackets and quotes, and
escaping them here would put a second reader between the test and what
the program actually printed.
Every line is one a plausible wrong version fails. The dump prints both
the kind letter and the text in <>, so a tokenizer with the right kinds
and the wrong slices - off by the opening quote, off by the keyword's
colon - fails even though it agreed about every kind. The cases that
are not obvious: a number followed straight by a delimiter ("[1]",
"1;c") separates a scan-to-delimiter from a scan-to-whitespace; foo/bar
must stay a namespaced symbol where a "contains a slash" ratio rule
makes it an error; a string holding a bracket and a semicolon must not
open a vector or start a comment; "1 ; no newline at the end" is the
comment a scan-to-newline loop runs off the end of; and an empty map is
what a reader assuming at least one key-value pair gets wrong.
The refusals are asserted on their *reason* and not on the fact of
failing, with the byte offset first - a tokenizer answering one generic
error for all of them would pass a test that only checked that it
stopped. Both string cases are here because they fail differently: an
escaped quote is the one where a wrong version returns a backslash as
part of the text and leaves the rest of the literal behind as garbage.
At -O0 as well. A Token is a two-word slice inside a struct returned by
value, and a Cursor is passed by pointer with a fixed array in it;
mem2reg is exactly what launders a struct being copied where it should
be shared. *)
let edn_out =
{edn|i<1>
i<-1>i<+2>i<0>
f<1.5>f<-2.5e3>f<.5>
b<true>b<false>n<nil>
y<foo>y<Enemy/Goblin>y<->
k<a>k<foo/bar>
[<>i<1>]<>
[<>i<1>i<2>]<>[<>i<3>]<>
{<>k<a>i<1>}<>
i<1>
k<a>
{<>}<>
[<>]<>
(<>)<>
[<>[<>i<1>]<>[<>i<2>[<>i<3>]<>]<>]<>
{<>k<a>{<>k<b>[<>]<>}<>}<>
k<a>
i<1>
s<x>
i<1>
i<1>i<2>
i<1>
[<>i<1>i<2>i<3>]<>
s<hi>
s<a[b;c>i<1>
s<>i<1>
s<a b>
2 escaped strings are refused: unescaping needs a copy of the bytes, and there is no allocator to put one in
2 escaped strings are refused: unescaping needs a copy of the bytes, and there is no allocator to put one in
0 unterminated string: end of input before the closing quote
0 sets #{} are refused: there is no hash set, and no allocator to build one in
0 tagged literals #tag are refused: the tag would pick the type at run time, which is what a type-directed reader exists to avoid
0 #inst is refused: it is a tagged literal, and there is no timestamp type to read it into
0 #uuid is refused: it is a tagged literal, and there is no uuid type to read it into
0 metadata ^ is refused: it attaches to the value after it, and a flat token stream has nowhere to attach it
0 ratios are refused: there is no rational type, and rounding one to a float would change the value
0 character literals are refused: a character is not a byte once it is not ASCII, and there is no code point type
0 not a number: the token starts like one but does not parse as an integer or a float
3 empty keyword: a colon with no name after it
0 unexpected byte: not the start of any EDN value
0 unexpected byte: not the start of any EDN value
4 unbalanced: this closing delimiter does not match the one that is open
0 unbalanced: this closing delimiter does not match the one that is open
4 unbalanced: this closing delimiter does not match the one that is open
32 nesting is too deep: the balance stack is a fixed array and it is full
[goblin] hp=12 speed=1.5 boss=no
[dragon] hp=40 speed=0 boss=yes
[imp] hp=1 speed=2 boss=no
[] hp=0 speed=0 boss=no
ERR@7 unexpected token: not the kind the caller was reading
[orc] hp=9 speed=0 boss=no
|edn}
in
outputs "edn tokenizer" "programs/edn.flan" edn_out;
outputs ~opt:"-O0" "edn tokenizer, -O0" "programs/edn.flan" edn_out;
(* Comparing enums, found by auditing emit.ml's failwith sites. It type
checked and then died in the backend with no source location, which is
the project's worst failure shape. All six operators, a negative member
so that an unsigned compare would answer the other way, and a compare
through a struct field, which reaches the same lowering by another
path. *)
let enum_out =
"eq yes\neq no\nlo below mid\nhi not below mid\nfield eq yes\n"
in
outputs "enum comparison" "programs/enum-compare.flan" enum_out;
outputs ~opt:"-O0" "enum comparison, -O0" "programs/enum-compare.flan"
enum_out;
(* Converting an enum, explicitly, in both directions: (i32 k) and (K n).
An enum is an i32 at run time, so neither direction is an instruction
and the interesting thing is what the checker will let through — which
is why this is here and at -O0 rather than only in test_flan. The rows
are the three members out, a round trip back, a value that is no
declared member and the comparisons it exists for, a narrowing and a
widening of a negative member, and an enum parameter driven by a loop
variable, which is the whole point.
The two bare prints in the middle are the ones that hold the design up
rather than merely exercising it: 7 prints as 7 and 1 prints as :hi.
Allowing a non-member to be *built* is only coherent because the
printer already shows one as its number, and this is where that is
asserted rather than asserted about. *)
let enum_conv_out =
"-1\n0\n1\n1\n-1\n7\n7\n:hi\nnot a member\nabove 3\n-1\n255\n1\n\
lo\nmid\nhi\nother\n"
in
outputs "enum conversion" "programs/enum-convert.flan" enum_conv_out;
outputs ~opt:"-O0" "enum conversion, -O0" "programs/enum-convert.flan"
enum_conv_out;
(* ── declare-c: the generated FFI shim (lib/shim.ml) ────────────────
The raylib package is the proof that the generator is real — 84
hand-written wrappers replaced by 84 one-line declarations, with the
two raylib cases above unchanged — and the permutation runs below are
the proof that the generated C typedefs actually follow the Flan
`defstruct`s rather than merely looking as if they do.
Everything here is text, not a link: what a wrapper does is settled by
clang, and what is worth asserting in OCaml is the shape of what clang
is handed and the refusals, each by name and reason. *)
let shim_of src =
let decls = Parse.program (Reader.read_all ~file:"<shim-test>" src) in
(* One string again for the assertions: the parts exist so [Reach] can
drop a wrapper, and what is asserted here is the text clang is
handed, which is the concatenation. *)
String.concat "" (List.map snd (Check.program decls).Tast.cshim)
in
let shim_case name src needles =
match shim_of src with
| c ->
List.iter
(fun n ->
if not (contains c n) then begin
incr failures;
Printf.printf "FAIL %s\n wanted in the generated C: %S\n"
name n
end)
needles
| exception Loc.Error { Loc.dmsg = m; _ } ->
incr failures;
Printf.printf "FAIL %s\n refused: %s\n" name m
in
(* A refusal is by name and carries the reason; the tests assert on the
reason, so weakening one to a bare "cannot" breaks them. *)
let shim_refuses name src fragment =
match shim_of src with
| _ ->
incr failures;
Printf.printf "FAIL %s: accepted, and it should not have been\n" name
| exception Loc.Error { Loc.dmsg = m; _ } ->
if not (contains m fragment) then begin
incr failures;
Printf.printf "FAIL %s\n reason: %S\n wanted to contain: %S\n"
name m fragment
end
in
let v2 = "(defstruct Vector2 [x f32 y f32])\n" in
let img =
"(defstruct Image [data (Ptr u8) width i32 height i32])\n"
in
(* A struct argument goes by pointer and a struct return through an
out-pointer, and the prototype says what C really takes. *)
shim_case "declare-c: a struct crosses by pointer, both ways"
(v2 ^ "(declare-c mid [a Vector2 b Vector2] Vector2 \"Mid\")")
[ "extern flan_ty_Vector2"; "*out = Mid(*a0, *a1);";
"const flan_ty_Vector2"; "*out)" ];
(* The typedef is made from the defstruct and nothing else, so its field
order is the defstruct's — which is what makes permuting a defstruct a
real test rather than a rewording. Both orders asserted, because only
the pair rules out a generator that sorts. *)
shim_case "declare-c: the C typedef follows the defstruct's field order"
(v2 ^ "(declare-c f [v Vector2] \"F\")")
[ " float x;\n float y;\n" ];
shim_case "declare-c: and permuting the defstruct permutes the typedef"
("(defstruct Vector2 [y f32 x f32])\n(declare-c f [v Vector2] \"F\")")
[ " float y;\n float x;\n" ];
(* One type mapper for fields and parameters alike: a bool is C's bool and
never an int, and a pointer field keeps its element type. *)
shim_case "declare-c: field and parameter types come from one mapper"
(img
^ "(defstruct S [flag bool n u64])\n\
(declare-c g [s S i (Ptr Image) b bool] u64 \"G\")")
[ " bool flag;\n uint64_t n;\n"; " uint8_t *data;\n";
"uint64_t G(flan_ty_S"; "bool a2" ];
(* A struct held by value pulls its own typedef in, and the definitions are
ordered so the inner one is complete first. *)
shim_case "declare-c: a nested struct is defined before it is used"
(v2 ^ "(defstruct Camera2D [offset Vector2 zoom f32])\n\
(declare-c h [c Camera2D] \"H\")")
[ "struct flan_ty_Vector2"; " flan_ty_Vector2" ];
(* A string is ptr+len on the Flan side and a NUL-terminated copy on C's.
The buffer is sized here and not per call site, because a generator has
no call site to look at: 256 on the stack, the heap past that, and the
copy is freed after the call rather than before the return value is
computed. *)
shim_case "declare-c: a string is copied, NUL-terminated and freed"
"(declare-c open-it [path string] bool \"OpenIt\")"
[ "char a0_b[256];"; "flan_shim_cstr(a0_p, a0_n, a0_b, sizeof a0_b)";
"bool r = OpenIt(a0);"; "flan_shim_cstr_free(a0, a0_b);";
" return r;\n" ];
shim_case "declare-c: two strings get two buffers"
"(declare-c both [a string b string] \"Both\")"
[ "char a0_b[256];"; "char a1_b[256];";
"flan_shim_cstr_free(a0, a0_b);"; "flan_shim_cstr_free(a1, a1_b);" ];
(* [declare] is untouched by any of this: its signature still IS the C
signature, which is what vendor/agent's flan_agent_start and the
prelude's sqrtf depend on. A program with no declare-c generates no C
at all. *)
if shim_of "(declare start [path string] i32 \"flan_agent_start\")" <> ""
then begin
incr failures;
print_endline "FAIL declare (not declare-c) generated a shim"
end;
shim_refuses "declare-c: a slice parameter, by name and reason"
(v2 ^ "(declare-c poly [pts [Vector2]] bool \"Poly\")")
"the count parameter the C function actually takes";
shim_refuses "declare-c: an Option"
(v2 ^ "(declare-c maybe [] (Option Vector2) \"Maybe\")")
"which is a Flan shape and not a C one";
shim_refuses "declare-c: a union"
("(defunion Shape [(Circle [r f32]) (Square [s f32])])\n\
(declare-c area [s Shape] f32 \"Area\")")
"a union, and a Flan union has no C layout";
shim_refuses "declare-c: a fixed array"
"(declare-c takes [xs [4 f32]] \"Takes\")"
"which C passes as a pointer and Flan as a value";
shim_refuses "declare-c: a map"
"(declare-c takes [m {string i32}] \"Takes\")"
"which has no C representation";
shim_refuses "declare-c: a returned string"
"(declare-c name [] string \"Name\")"
"a string only crosses as a parameter";
shim_refuses "declare-c: a callback"
"(declare-c each [f (Fn [i32] ())] \"Each\")"
"a C callback is not implemented";
shim_refuses "declare-c: an unknown type"
"(declare-c f [x Nope] \"F\")"
"which is not a type this shim generator knows";
shim_refuses "declare-c: a field C cannot hold"
"(defstruct S [xs [i32]])\n(declare-c f [s S] \"F\")"
"field xs of S is a slice";
shim_refuses "declare-c: the generated name is already taken"
(v2
^ "(defn mid-c [a (Ptr Vector2) out (Ptr Vector2)] ())\n\
(declare-c mid [a Vector2] Vector2 \"Mid\")")
"needs the name mid-c for the declaration it generates";
shim_refuses "declare-c: two Flan names for one C function"
"(declare-c a [] \"Same\")\n(declare-c b [] \"Same\")"
"one declare-c per C function";
(* Two programs written against a mutation-testing report, each covering a
claim the whole suite could be broken on while staying green.
cleanup.flan: a return running the defers above it, and running them
innermost-first; a defer that calls something, so a guard is emitted
inside it on the transfer path; a transfer out of a handler-bind popping
its frames; a two-clause handler-bind popping both; and a signal that
stops at the inner handler once that one has answered it by
transferring. Six claims, and the numbers differ per failure so a wrong
answer names its own cause.
signedness.flan: the ashr/lshr and slt/ult choices, which emit.ml makes
from the operand's type. Either could have been hardcoded to one arm,
because nothing in the corpus shifted a negative right or compared an
unsigned value above 2^31. *)
let cleanup_out = "7\n21\n42\n0\n5\n0\n0\n" in
outputs "cleanup paths" "programs/cleanup.flan" cleanup_out;
outputs ~opt:"-O0" "cleanup paths, -O0" "programs/cleanup.flan" cleanup_out;
(* defer-let.flan: a [let] at the top level of a function body has exactly
the function's extent, so a defer written in it always registers and is
as safe as one written at the top level. Six claims, and the numbers
differ per failure.
The one a plausible wrong version gets wrong is [two]: a permission
granted once around a block rather than once before each form lets the
first defer through and refuses the second, and every other case here
still passes. *)
let defer_let_out = "9\n91\n921\n921\n9321\n7\n21\n" in
outputs "defer in a let" "programs/defer-let.flan" defer_let_out;
outputs ~opt:"-O0" "defer in a let, -O0" "programs/defer-let.flan"
defer_let_out;
(* The two refusals that stay, each named by what blocks it. A loop body
would fire once at function exit rather than once per iteration, and a
branch would have to express "maybe registered", which a construct
copied into every exit path cannot. A [let] inside either one inherits
the refusal, not the permission: its extent is the loop's or the arm's. *)
refuses_src "defer in a loop body"
"(defn g [] () 0)\n(defn f [] () (while true (defer (g))))"
"not allowed inside a loop body";
refuses_src "defer in a dotimes body"
"(defn g [] () 0)\n(defn f [] () (dotimes [i 3] (defer (g))))"
"not allowed inside a loop body";
refuses_src "defer in a branch"
"(defn g [] () 0)\n(defn f [] () (if true (defer (g)) 0))"
"not allowed inside a branch";
refuses_src "defer in a let inside a loop"
"(defn g [] () 0)\n(defn f [] () (while true (let [x 1] (defer (g)))))"
"not allowed inside a loop body";
refuses_src "defer in a let inside a branch"
"(defn g [] () 0)\n(defn f [] () (if true (let [x 1] (defer (g))) 0))"
"not allowed inside a branch";
(* ── (Map K V), spec-memory.md step 4 ──────────────────────────
Odin's map: open-addressed Robin Hood hashing at a 75% load factor with
cache-line cell packing. maps.flan is seven claims, each one a plausible
wrong version gets wrong, and the numbers differ per failure.
The two worth naming, because nothing else in the suite would catch
them. A struct key is hashed *field by field*, never bytewise, because a
struct's padding bytes are indeterminate — hashing them makes two equal
keys hash differently and the entry unfindable, which shows up here as a
wrong count rather than a crash. And a grow rehashes against a fresh
seed, because the seed is derived from the block address; carrying the
old hashes across a grow puts every entry in a slot nothing will probe.
2000 entries is eight grows and then every one of them read back. *)
let maps_out =
"2000\n0\n1600\n709\ntrue\nfalse\n3\n20\nfalse\n2\n3\nfalse\n\
100\n999\n2\n1\n3\n500\n998\n2\n2\n"
in
outputs "maps" "programs/maps.flan" maps_out;
outputs ~opt:"-O0" "maps, -O0" "programs/maps.flan" maps_out;
(* A dev build, because the hash and equality pair emitted for a struct key
is a function nobody wrote and the only other inhabitant of that list —
a lifted handler clause — carries a parent this one cannot: the pair is
shared by every function that maps that key type. A dev build puts every
body behind an indirection cell, so it is the build that would notice. *)
outputs ~dev:true "maps, dev" "programs/maps.flan" maps_out;
(* Iteration, which no map could do at all until flan_map_next. Every case
here is order-free on purpose — block order is the hash's order, not the
insertion's — so the numbers are sums, counts and lengths and never a
first entry. The string-keyed, struct-valued map is the one that would
catch the key and value runs being indexed with a single geometry, since
their element sizes and cell packing differ; and the 500-entry map is
several grows past the minimum, so it walks a block whose layout has
nothing to do with the order the entries went in. *)
let map_iter_out =
"4 10 100\nnever allocated: 0\nallocated and empty: 0\nspent: 2\n\
6 9 12\n500 500 500\n"
in
outputs "map iteration" "programs/map-iter.flan" map_iter_out;
outputs ~opt:"-O0" "map iteration, -O0" "programs/map-iter.flan" map_iter_out;
(* The allocation-failure rule is one rule over every allocating operation,
so it has to hold for map-new, put, reserve and clone as it does for the
Vec's four. A map is the harder case: its growth allocates a new block,
rehashes into it and only then releases the old one, so a failure
partway must leave the map exactly as it was or the retry re-attempts
against a half-moved map. *)
let map_exhausted_out = "300\n0\ntrue\ntrue\ntrue\n0\n2\n2\ntrue\n" in
outputs "map StorageExhausted and retry" "programs/map-exhausted.flan"
map_exhausted_out;
(* The refusals, each by name. A float key is not a milestone question —
NaN is not equal to itself and 0.0 and -0.0 are equal while differing
bytewise, so there is no equality for a map to hash. A move-only value
is the refusal (Vec (Vec T)) already carries, for the identical reason.
Unit as a value is refused rather than dividing a cache line by zero,
and it is named because it is the natural spelling of a set. *)
refuses_src "a float is not a map key"
"(defn f [m (Map f32 i32)] () 0)" "is not a map key";
refuses_src "a Ptr is not a map key"
"(defn f [m (Map (Ptr i32) i32)] () 0)" "hash an address";
refuses_src "a map value may not own storage"
"(defn f [m (Map i32 (Vec i32))] () 0)" "holds a move-only value";
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";
(* ── Union values ───────────────────────────────────────────
defunion 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 union in a struct, a union through a call in both directions,
ZII, reassignment and printing.
-O0 as well, for the reason every aggregate here gets it: a union 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 union crosses one as a parameter and as a
return value. *)
let unions_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;
(* 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 "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 union case written as a struct"
"(defunion U [(A [x i32])])\n(defn main [] i32 (let [v (A {.x 1})] 0))"
"A is a case of the union U";
refuses_src "a union type used as a constructor"
"(defunion U [(A [x i32])])\n(defn main [] i32 (let [v (U {.x 1})] 0))"
"a union value names the case as well as the type";
refuses_src "a case with fields written bare"
"(defunion 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 union grows tomorrow is the one a reader wants
to be told about today. *)
refuses_src "a match that misses a case"
"(defunion 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 union does not have"
"(defunion 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"
"(defunion 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"
"(defunion 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 union 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 union 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 union's cases. Both shapes: direct, and two
unions 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 union that contains itself by value"
"(defunion T [Leaf (Node [l T r T])])\n(defn f [t T] () 0)"
"T contains itself by value";
refuses_src "two unions that contain each other by value"
"(defunion A [(X [b B])])\n(defunion B [(Y [a A])])\n(defn f [a A] () 0)"
"contains itself by value";
refuses_src "a union with no cases"
"(defunion U [])\n(defn f [u U] () 0)"
"declares no cases";
refuses_src "a union case that owns a Vec"
"(defunion 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 union reaches the same place. *)
refuses_src "a union is not a map key"
"(defunion 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 union case" in
let src =
"(defunion 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:"<unions>" 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 union 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 union global"
"(defunion U [A B])\n(defvar g U uninit)\n(defn main [] i32 0)"
"its tag steers every match";
(* A union'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 union directly"
"(defunion 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 union global" in
match
Emit.program
(Check.program
(Parse.program
(Reader.read_all ~file:"<unions>"
"(defunion 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 ir sname =
let ls = lines_of ir in
let node id =
List.find_opt
(fun l -> String.starts_with ~prefix:(Printf.sprintf "!%d = " id) l) ls
in
let composite =
List.find_opt
(fun l ->
index_of l "!DICompositeType(tag: DW_TAG_structure_type" >= 0
&& attr l "name" = Some (Printf.sprintf "\"%s\"" sname))
ls
in
match composite with
| None -> None
| Some c ->
let ids = attr_ids c "elements" in
Some
((List.filter_map
(fun id ->
match node id with
| None -> None
| Some l ->
(match attr l "name", attr l "offset" with
| Some n, Some o ->
Some (unquote n, int_of_string (String.trim o) / 8)
| _ -> None))
ids),
(match attr c "size" with
| Some sz -> int_of_string (String.trim sz) / 8
| None -> -1))
in
(* LLVM's own answer, for the same struct type text the DWARF describes.
The type definitions are lifted straight out of the emitted module, so
there is no second spelling of the layout to get wrong. *)
(* 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 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 union, 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 union"
("(defunion 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 union 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 union"
("(defunion 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" ];
(* -- 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) path =
let exe =
Filename.concat scratch
("flan-dbg-" ^ Filename.remove_extension (Filename.basename path)
^ if dev then "-dev" else "")
in
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
let pnames =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defn fn ->
Some (fn.Ast.name,
List.map (fun (f : Ast.field) -> f.Ast.fname) fn.Ast.params)
| _ -> None)
l.Load.decls
in
let p, csrcs, lflags = Reach.link ~dev l p in
ignore
(Build.executable ~opts:{ Build.default with debug = true; dev }
~csrcs ~lflags ~pnames p ~out:exe);
exe
in
let expected = "42\n4.75\n42\ngrain\n" in
List.iter
(fun path ->
let exe = debug_compile path in
let code, text = run exe None in
if text <> expected || code <> 0 then begin
incr failures;
Printf.printf
"FAIL a --debug build of %s runs the same\n got: %S (exit %d)\n wanted: %S\n"
path text code expected
end)
[ "programs/debug.flan"; "programs/debug-permuted.flan" ];
(* wasm32 is refused by name. The offsets above are the host's, and
wasm32's 32-bit pointer moves every slice member; emitting them anyway
would give a debugger a confident wrong answer. *)
(match
Build.executable
~opts:{ Build.default with debug = true; target = Some "wasm32-wasi" }
{ Tast.structs = []; unions = []; globals = []; externs = []; fns = [];
cshim = [] }
~out:(Filename.concat scratch "flan-dbg-wasm")
with
| _ ->
incr failures;
print_endline "FAIL --debug --target=wasm32-wasi was accepted"
| exception Failure m ->
if not (contains m "--debug is native only") then begin
incr failures;
Printf.printf "FAIL --debug on wasm32\n said: %S\n" m
end);
(* -- lldb, for real ------------------------------------------------
Everything above is about the metadata being self-consistent. This is
the only part that says a person can debug a Flan program: a breakpoint
set on a Flan function *by name*, a backtrace with .flan files and line
numbers, and locals printed with their own types and values. It is
skipped rather than failed where there is no lldb. *)
if Sys.command "command -v lldb > /dev/null 2>&1" = 0 then begin
let lldb_run exe cmds =
let out = Filename.concat scratch "flan-lldb.out" in
let code =
Sys.command
(Printf.sprintf "lldb -b %s %s > %s 2>&1"
(String.concat " "
(List.map (fun c -> "-o " ^ Filename.quote c) cmds))
(Filename.quote exe) (Filename.quote out))
in
let text = In_channel.with_open_bin out In_channel.input_all in
(try Sys.remove out with Sys_error _ -> ());
(code, text)
in
let lldb_case name path needles =
let exe = debug_compile path in
let _, text =
lldb_run exe
[ "breakpoint set --name flan.tick"; "run"; "bt"; "frame variable";
"p *c" ]
in
List.iter
(fun n ->
if not (contains text n) then begin
incr failures;
Printf.printf "FAIL %s\n wanted %S in lldb's output\n"
name n;
print_endline text
end)
needles
in
(* The four claims, one needle each: the breakpoint resolved on a Flan
name; the frame names a .flan file and a line inside tick; the caller
is the Flan main and not a C frame; a parameter prints by its source
name; and the struct through the pointer prints every field with the
value the program put there. *)
lldb_case "lldb: breakpoint, frames and locals" "programs/debug.flan"
[ "flan.tick"; "at debug.flan:"; "flan.main at debug.flan:";
"(int) n = 41"; "alive = true"; "heat = 3.25"; "id = 7"; "len = 5";
(* And the 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:" ]
end
else print_endline "acceptance: lldb cases skipped (no lldb on PATH)";
(* ── Strings: UTF-8, the split cursor, and ASCII case ──────────────
The prelude's port of Odin's core/unicode/utf8, which is the only part
of a string library that needs no allocator. The valid decodes prove
almost nothing on their own — a decoder that just masks and shifts gets
every one of them right — so the test is the malformed group: an
overlong two- and three-byte "/", a UTF-16 surrogate, a code point past
U+10FFFF, a lead byte that leads nothing, a lone continuation byte, and
a valid character truncated by the end of its slice. Each isolates one
row of the accept_sizes table, and each answers width 1 so that a scan
makes progress rather than hanging.
Encoding is checked by round trip rather than against expected bytes,
because an encoder and a decoder that are wrong in the same direction
agree with each other and disagree with nothing else.
At -O0 as well, for the reason the slice algorithms run there: a slice
is a two-word struct through an alloca, decode-rune returns a struct by
value, and the split cursor is mutated through a (Ptr Split) — mem2reg
is exactly what would hide any of those being copied when it should be
shared. *)
let utf8_out =
"0/0/f 65/1/t 233/2/t 26085/3/t 128512/4/t \n\
0/1/f 0/1/f 0/1/f 0/1/f 0/1/f 0/1/f 0/1/f \n\
0/1/f 0/1/f 0/1/f 0/1/f \n\
tft\n\
0 3 8 13 3\n\
ttffft\n\
26085 26412 -1 -1 -1 \n\
-1 1 1 2 2 3 3 -1 -1 3 3 4 4 -1 \n\
0 65 127 128 2047 2048 65535 65536 1114111 \n\
-1 -1 -1 -1 -1 1 \n\
65 -1 65 -1 65 \n\
[a][b][c] [a][][b] [abc] [] [][] [][a] [a][] \n\
60\n\
97 122 97 64 91 65 90 65 96 123 53 \n\
195 195 \n\
tftfft\n"
in
outputs "utf-8, splitting and ascii case" "programs/utf8.flan" utf8_out;
outputs ~opt:"-O0" "utf-8, splitting and ascii case, -O0"
"programs/utf8.flan" utf8_out;
if !failures = 0 then print_endline "acceptance: all tests passed"
else begin
Printf.printf "\n%d failure(s)\n" !failures;
exit 1
end
| _ -> print_endline "acceptance: skipped (no clang on PATH)"
Reference in New Issue View Git Blame Copy Permalink