JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/test/test_acceptance.ml
Joseph Ferano cb47b98100 Merge branch 'string-of-bytes' into dev-loop 
A [u8] and a string are the same 16 bytes at run time, so (string b)
is a reinterpretation with no instructions. What it buys is that a
number can reach draw-text at all, which five of the ten examples
wanted and none could have.
2026-09-12 05:21:58 +07:00

1729 lines
83 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
let failures = ref 0
let scratch = Filename.get_temp_dir_name ()
let run exe arg =
let out = Filename.concat scratch "flan-acceptance.out" in
let cmd =
Printf.sprintf "%s %s > %s 2>&1"
(Filename.quote exe)
(match arg with None -> "" | Some a -> Filename.quote a)
(Filename.quote out)
in
let code = Sys.command cmd in
let text = In_channel.with_open_bin out In_channel.input_all in
Sys.remove out;
(code, text)
let compile ?(opt = "-O2") ?(checks = true) ?(dev = false) path =
let exe =
Filename.concat scratch
("flan-t-" ^ Filename.remove_extension (Filename.basename path))
in
(* Through [Load], so a program with an (import ...) is buildable here: it
brings back the package's C shim and linker arguments as well. *)
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
(* [Reach.link] decides the link from the program: a package nothing
reachable calls into hands over no C and no linker argument, and its
functions are not emitted. *)
let p, csrcs, lflags = Reach.link ~dev l p in
ignore (Build.executable ~opts:{ Build.default with opt; checks; dev }
~csrcs ~lflags p ~out:exe);
exe
(* No Str, and the reader is hand-written for the same reason. *)
let contains hay needle =
let n = String.length needle and h = String.length hay in
let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
go 0
let () =
match Sys.command "command -v clang > /dev/null 2>&1" with
| 0 ->
let exe = compile "../calc-me.flan" in
let case name arg expected_out expected_code =
let code, text = run exe arg in
if text <> expected_out || code <> expected_code then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit %d)\n"
name text code expected_out expected_code
end
in
let evaluates src expected = case src (Some src) (expected ^ "\n") 0 in
let rejects src = case src (Some src) "calc-me: cannot parse\n" 1 in
(* Arithmetic and precedence *)
evaluates "1 + 2 * (3 - 0.5) / 2" "3.5";
evaluates "1+2*3" "7";
evaluates "2*3+4" "10";
evaluates "(1+2)*3" "9";
evaluates "10/4" "2.5";
evaluates "7" "7";
evaluates " 7 " "7";
evaluates "1.5+2.25" "3.75";
(* Left-associative: 1-2-3 is (1-2)-3, not 1-(2-3) *)
evaluates "1-2-3" "-4";
evaluates "8/4/2" "1";
(* Unary minus, including nested *)
evaluates "-5" "-5";
evaluates "-(1+2)" "-3";
evaluates "3 * -2" "-6";
(* Whole input or nothing: trailing junk is an error, not ignored *)
rejects "1 +";
rejects "(1+2";
rejects "1 2";
rejects "";
rejects "+";
rejects "1+2)";
case "no argument" None "usage: calc-me \"1 + 2 * 3\"\n" 1;
(try Sys.remove exe with Sys_error _ -> ());
(* Programs whose whole output is fixed. These cover the milestone-2
surface calc-me does not reach — globals, 2-D arrays, places through a
pointer, casts, match with either arm taken, and the value semantics of
spec-memory.md. *)
let outputs ?opt ?dev name path expected =
let exe = compile ?opt ?dev path in
let code, text = run exe None in
if text <> expected || code <> 0 then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 0)\n"
name text code expected
end;
(try Sys.remove exe with Sys_error _ -> ())
in
let values_out = "1\n5\nel\n" in
let machine_out = "12\n30\n2\n2\n3\n3.5\n42\n99\n12\n123\n" in
outputs "value semantics" "programs/values.flan" values_out;
outputs "machine surface" "programs/machine.flan" machine_out;
outputs "unit main exits 0" "programs/unit-main.flan" "ok\n";
(* The prelude's slice algorithms. Every assertion here is over an input a
wrong implementation fails: unsorted with duplicates, negatives and an
odd length; a reverse-sorted slice; and a sort of a subslice whose
neighbours must be untouched, which is the in-place, ptr+len claim
itself. At -O0 as well — a slice parameter is an alloca of a two-word
struct, and mem2reg is exactly what would hide it being copied. *)
let slices_out =
"5 -3 5 0 12 -3 7\n23\n-3\n12\n0\n-1\n99\n\
7 -3 12 0 5 -3 5\n-3 7 12 0 5 -3 5\n\
-3 -3 0 5 5 7 12\n1 2 3 4 5\n\
100 -1 0 4 9 9 200 300\n100 -1 0 4 9 9 200 300\n"
in
outputs "slice algorithms" "programs/slices.flan" slices_out;
outputs ~opt:"-O0" "slice algorithms, -O0" "programs/slices.flan" slices_out;
(* 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;
(* 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. *)
let restarts_out = "101\n1\n-1\n2\n7\n1010\n101\n105\n-2\n" in
outputs "restarts" "programs/restarts.flan" restarts_out;
outputs ~opt:"-O0" "restarts, -O0" "programs/restarts.flan" restarts_out;
outputs ~dev:true "restarts, dev" "programs/restarts.flan" restarts_out;
(* §2's other half, which cannot be an [outputs] case because it does not
exit 0: a handler runs, returns normally, and has still not answered the
error, so the program stops and names the condition. *)
let exe = compile "programs/error.flan" in
let code, text = run exe None in
if code <> 134 || not (contains text "handler ran")
|| not (contains text "unhandled AssetMissing")
then begin
incr failures;
Printf.printf
"FAIL an unhandled error stops the program\n\
\ got: %S (exit %d)\n wanted: exit 134, naming the condition\n"
text code
end;
(* The raylib FFI, headless. GetColor, rectangle intersection and the
shapes texture need no window, so the whole boundary is exercised
without a display: a struct out of C through an out-pointer, a struct
into C through a pointer, a keyword resolved against an enum, and a
Flan string crossing as ptr+len.
Every case is asymmetric, which is the point. 0x11223344 comes back as
four separate bytes, so a Color is not the little-endian reading of the
packed integer. The intersection of (0,0,10,4) and (6,1,10,10) is
(6,1,4,3), four numbers from four different pairs of fields, so no
permutation of Rectangle survives it. And the shapes texture is stored
or replaced by 1 1 1 1 7 depending on which field is zero, which pins
Texture2D's id and format. Handing raylib a struct and reading it back
would have passed with any of those permuted — storing and returning is
symmetric. What the last case cannot pin, because nothing raylib
computes without a GL context reads them, is width, height and mipmaps
against each other.
The camera conversions are the strongest headless material here: both
are pure arithmetic over every field of a Camera2D and two Vector2s,
and both directions are asserted as absolute answers. A round trip
would not be — the inverse cancels a permuted layout exactly, the same
way store-and-return does. The rotated pair is the only thing in the
package that pins Vector2's own two fields, because every
component-wise formula is merely mirrored by exchanging x and y and so
compares equal; a rotation mixes them. It reports ok/bad rather than a
number because sinf and cosf make the answer 27.9999981, and this
table compares stdout byte for byte. *)
let raylib_out =
"17\n34\n51\n68\n\
6\n1\n4\n3\n\
7\n13\n17\n2\n4\n3.5\n7.25\n11.5\n13.75\n\
1\n1\n1\n1\n7\n\
7\n0\n17\n2\n4\n\
28\n24\n140\n90\n\
rotated screen-to-world ok\n\
rotated world-to-screen ok\n\
point in rect yes\npoint below rect no\n\
rects overlap yes\nrects apart no\n\
circles touch yes\ncircles clear no\n\
3\n7\n\
circle meets rect yes\ncircle clears rect no\n\
circle meets line yes\ncircle clears line no\n\
point in circle yes\npoint outside circle no\n\
point in triangle yes\npoint outside triangle no\n\
point on line yes\npoint off line no\n\
point in poly yes\npoint outside poly no\n\
in square, four corners yes\nout of triangle, three no\n\
no crossing\n"
in
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
outputs "raylib ffi, headless" "programs/raylib-ffi.flan" raylib_out;
(* And at -O0, for the reason the rest of the table is: every struct
here crosses as (addr v) on a local, which is the alloca mem2reg
would launder before anyone noticed it was wrong. *)
outputs ~opt:"-O0" "raylib ffi, headless, -O0" "programs/raylib-ffi.flan"
raylib_out
end
else
print_endline "acceptance: skipping the raylib FFI case (no libraylib)";
(* raylib's Image family, headless, and the strongest FFI case here: an
Image is pixels in RAM, so raylib *computes* with it rather than
storing and returning it.
Two separate things are pinned. gen-image-color is handed two scalars
and answers with a struct reading 4, 2, 1, 7 — four distinct values in
four adjacent i32 slots, so exchanging any two of width, height,
mipmaps and format is visible, and dropping `data` makes width the low
half of raylib's pointer. Scalars in and fields out is what makes that
work: a permuted layout has nothing to cancel against, unlike the
shapes texture, where nothing without a GPU read width, height or
mipmaps at all.
The other is the axis, which the collision cases could not get. raylib
indexes a pixel as y*width + x, and the image is 4 wide by 2 tall, so
(3,0) exists and its transpose does not — exchange x and y in the shim
and the read is out of bounds and answers transparent black. The
horizontal and vertical flips are the same argument twice more: on two
rows, one of them moves a mark that the other leaves alone.
The PNG round trip is not the symmetric trap either: stb's encoder and
decoder are external ground truth and agree with each other rather than
with whatever field order Flan believes in. It also crosses a path as
ptr+len. /tmp is written to, and both optimisation levels write the
same bytes, so the shared name is harmless.
Trace logging stays at :warning and no read here is out of bounds, so
a warning appearing in this output is a real failure — [run] folds
stderr in. *)
let raylib_image_out =
"generated 4 2 1 7\n\
at 3,0 200 0 0 255\n\
at 0,1 0 200 0 255\n\
at 0,0 10 20 30 255\n\
at 3,1 10 20 30 255\n\
flipped-h at 0,0 200 0 0 255\n\
flipped-h at 3,1 0 200 0 255\n\
flipped-h at 3,0 10 20 30 255\n\
flipped-v at 0,1 200 0 0 255\n\
flipped-v at 3,0 0 200 0 255\n\
flipped-v at 0,0 10 20 30 255\n\
exported yes\n\
loaded valid yes\n\
loaded 4 2 1 7\n\
loaded at 0,1 200 0 0 255\n\
loaded at 3,0 0 200 0 255\n\
loaded at 0,0 10 20 30 255\n\
resized-nn 8 2 1 7\n\
nn at 0,1 200 0 0 255\n\
nn at 1,1 200 0 0 255\n\
nn at 6,0 0 200 0 255\n\
nn at 7,0 0 200 0 255\n\
nn at 2,1 10 20 30 255\n\
resized 2 6 1 7\n\
cropped 2 1 1 7\n\
cropped at 1,0 200 0 0 255\n\
cropped at 0,0 10 20 30 255\n"
in
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
outputs "raylib images, headless" "programs/raylib-image.flan"
raylib_image_out;
outputs ~opt:"-O0" "raylib images, headless, -O0" "programs/raylib-image.flan"
raylib_image_out
end
else
print_endline "acceptance: skipping the raylib Image case (no libraylib)";
(* raylib's Wave family, headless — and the first claim to make about it
is that it exists. The received wisdom in this repository was that
audio needs a device and so cannot be in this table at all. That is
true of Sound, Music and AudioStream, every one of which is a handle
the miniaudio mixer owns, and false of Wave: samples in RAM and four
integers describing them, with copy, crop, reformat, export, load and
decode all running on the CPU. So it gets the Image family's treatment.
Three shapes, and they pin different things.
wave-format is the scalars-in/fields-out case gen-image-color is: three
plain integers go in and all four u32 fields come out, with
frame-count *computed* from the ratio of the sample rates — 16, from
eight frames at twice the rate, and no argument named it. Eight bits
rather than sixteen in that call so sample-size cannot be confused
with the frame count it would otherwise equal.
export-wave then load-wave is external ground truth, the PNG argument
transposed: dr_wav writes the header from three fields and reads them
back, agreeing with itself rather than with Flan's field order. Be
precise about its reach, because it is narrower than it looks — it
catches sample-size against channels (the "loaded" line reads
"8 8000 16 16" when those two are exchanged) and NOT frame-count
against sample-rate, which leaves every line of the round trip green.
The crop and the reformat are what catch that pair.
And the decoded samples are the axis discriminator this section needed.
load-wave-samples answers a (Ptr f32), which Flan cannot index — [at]
takes an array, a slice or a string — so the program crops to a single
frame first and dereferences sample 0. That detour is what makes the
case strong rather than weak: raylib's crop offset is init-frame times
channels times sample-size over 8, so asking for frame 3 and getting
+3000 pins sample-size against channels. Exchange those two and the
crop lands two bytes off and the sample is a different number, not the
same one mirrored, which is the failure mode axis-aligned geometry
could never produce.
Verified red by permuting the Wave defstruct three ways: frame-count
with sample-rate (cropped reads "8 4 16 1" and reformatted
"16000 16000000 8 2", while the file round trip stays green — see
above), sample-size with channels (every frame read turns to "no" and
the loaded line reads "8 8000 16 16"), and data moved to the front
(the run dies after two lines). *)
let raylib_audio_out =
"valid yes\n\
source 8 8000 16 1\n\
cropped 4 8000 16 1\n\
reformatted 16 16000 8 2\n\
frame 1 is +1000 yes\n\
frame 3 is +3000 yes\n\
frame 4 is -3000 yes\n\
frame 0 is zero yes\n\
exported yes\n\
loaded valid yes\n\
loaded 8 8000 16 1\n\
loaded frame 1 is +1000 yes\n\
loaded frame 4 is -3000 yes\n"
in
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
outputs "raylib audio, headless" "programs/raylib-audio.flan"
raylib_audio_out;
outputs ~opt:"-O0" "raylib audio, headless, -O0" "programs/raylib-audio.flan"
raylib_audio_out
end
else
print_endline "acceptance: skipping the raylib Wave case (no libraylib)";
(* raylib's Font family, headless, which the package refused to bind at
all until now. The stated reason was that a Font drags in two more
aggregates and two owned arrays "for something with no headless test at
the end of it". The generator takes all of it unchanged — a struct held
by value is emitted after what it contains, one held by pointer is
forward-declared — and the test turned out to exist.
What makes it exist is that the program does not ASK raylib for a font.
Every call that makes one needs a window or a TTF and a GL context.
So it builds one out of Flan arrays, field by field, and hands it over
to be computed with: three glyphs, three atlas rectangles, a base size
of 10 and a texture that is a lie in every field but [id]. Text
measuring is pure arithmetic over exactly those fields, so this is
scalars in and numbers out with no raylib-produced struct anywhere for
a permutation to cancel against.
The one raylib trap worth recording: MeasureTextEx returns (0,0)
immediately when font.texture.id is 0. The hand-built font claims an id
of 1, and that guard is what pins where the Texture2D sits inside the
Font — land it elsewhere and every measurement collapses to zero.
Glyph C carries an advance of 0 deliberately, which sends raylib down
its other branch: the atlas rectangle's width plus the glyph's offset,
9 + 3 = 12, which is why "ABC" is 36 and "AB" is 24. And "A" at a
spacing of 3 measures 11 and not 14, because spacing is added per gap
and not per glyph — without that line, a wrapper that added it per
glyph would pass everything else.
Verified red by six permutations. In Font: base-size with glyph-count
(the measurements become 80, 120, 163 and 36.6667), the recs and glyphs
pointers (floats in the 1e9 range and a garbage atlas rectangle), and
[texture] moved to the end (the run dies after the first line). In
GlyphInfo: offset-x with advance-x (3, 6, 9, 1), and [image] moved to
the FRONT, which shifts the four ints by 24 bytes — the glyph search
collapses, every index reads 0 and glyph C answers with A's fields.
In Rectangle: x with width, which moves "measure ABC" to 39 and leaves
"measure AB" at 24, since only the advance-0 fallback reads a width out
of the recs array. Two of the six were a crash rather than a wrong
number, which still counts.
What this case does NOT pin, said here for the same reason the
Texture2D notes above say it: glyph-padding is read by nothing raylib
computes on the CPU, offset-y only moves a glyph when it is drawn, and
of each atlas rectangle only `width` is ever looked at. Those four
fields rest on the header agreeing with raylib's and on sand.flan
looking right, and on nothing else. *)
let raylib_font_out =
"valid yes\n\
index A 0\nindex B 1\nindex C 2\nindex Z 0\n\
atlas B 5 0 7 10\n\
glyph C value 67\nglyph C offset 3\nglyph C advance 0\n\
measure AB 24 10\n\
measure ABC 36 10\n\
measure AB big 51 20\n\
measure A spaced 11 10\n"
in
if Sys.command "ldconfig -p 2>/dev/null | grep -q libraylib" = 0 then begin
outputs "raylib fonts, headless" "programs/raylib-font.flan"
raylib_font_out;
outputs ~opt:"-O0" "raylib fonts, headless, -O0" "programs/raylib-font.flan"
raylib_font_out
end
else
print_endline "acceptance: skipping the raylib Font case (no libraylib)";
(* Again at -O0. Everything above runs through mem2reg, which launders a
sloppy alloca; -O0 tests the IR actually emitted, so a disagreement
between the two points at undefined behaviour rather than a typo. *)
(* sand.flan's simulation, headless. This is the milestone-4 acceptance
case: N frames from a seeded PRNG, one hash. It imports the sim package
and not raylib, deliberately — a program that imports raylib links
libraylib on every target, and this one is the version meant to run on
wasm32 too. The hash is reproducible only because rand-f32 is ours. *)
let sand_out = "-2851001042534928384\n" in
outputs "sand, headless" "programs/sand-headless.flan" sand_out;
outputs ~opt:"-O0" "sand, headless, -O0" "programs/sand-headless.flan" sand_out;
(* 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";
(* The refusals. Each is a thing that would otherwise fail later and
elsewhere — as a name the checker says is unknown, or as a collision
nobody wrote — so what is asserted is the *reason*, at the form that
caused it. None of these is built; being refused is the whole test. *)
let refuses name path needle =
let attempt () =
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
ignore (Check.program l.Load.decls)
in
match attempt () with
| () ->
incr failures;
Printf.printf "FAIL %s\n it was accepted\n" name
| exception Loc.Error (_, m) ->
if not (contains m needle) then begin
incr failures;
Printf.printf "FAIL %s\n said: %S\n wanted: %S in it\n"
name m needle
end
in
(* Visibility: main is not a name a package offers, and saying so is the
point — "unknown name sand/main" would be true and useless. *)
refuses "a package's main is not visible" "programs/pkg-hidden-main.flan"
"sand/main is not a name";
refuses "one directory under two aliases" "programs/pkg-two-aliases.flan"
"one directory is one set of names";
refuses "two mains in one program" "programs/pkg-two-mains.flan"
"main is defined twice";
(* nth is gone, not renamed: it has to fail as a name nobody defined. If it
were ever re-added as an alias of [at] it would have to be a place too,
and this row is what says so. *)
refuses "nth is not a name" "programs/nth-gone.flan"
"unknown function nth";
(* ── wasm32 (NEXT.md, deferred item 6) ──────────────────────────────
The second target, and the reason sand-headless imports no raylib. What
is asserted is not that a wasm module exists — it is that it prints the
*same hash* as the native build, byte for byte. That is only possible
because rand-f32 is written in Flan rather than bound to libc, so the
case is the regression test for that decision as much as for the port.
Four independent things can be absent — clang's wasm target, the
wasi-libc sysroot, a builtins archive, and a runtime that speaks WASI —
so the skip is a *probe*: build the smallest program and run it. A
[which] would go red on the machine where Node is too old, with a
reason nobody could read. *)
let wasm_runner =
if Sys.command "command -v wasmtime > /dev/null 2>&1" = 0 then
Some "wasmtime"
else if Sys.command "command -v wasmer > /dev/null 2>&1" = 0 then
Some "wasmer run"
else if Sys.command "command -v node > /dev/null 2>&1" = 0 then
(* --no-warnings because node:wasi prints an ExperimentalWarning to
stderr on every run, and this harness compares combined output. *)
Some "node --no-warnings wasm-run.mjs"
else None
in
let wasm_build ?(opt = "-O2") path out =
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
let p, csrcs, lflags = Reach.link l p in
ignore
(Build.executable
~opts:{ Build.default with opt; target = Some "wasm32-wasi" }
~csrcs ~lflags p ~out)
in
let wasm_run ?arg runner wasm =
let out = Filename.concat scratch "flan-acceptance-wasm.out" in
let code =
Sys.command
(Printf.sprintf "%s %s %s > %s 2>&1" runner (Filename.quote wasm)
(match arg with None -> "" | Some a -> Filename.quote a)
(Filename.quote out))
in
let text = In_channel.with_open_bin out In_channel.input_all in
(try Sys.remove out with Sys_error _ -> ());
(code, text)
in
(match wasm_runner with
| None ->
print_endline
"acceptance: skipping the wasm32 case (no wasmtime, wasmer or node)"
| Some runner ->
let probe = Filename.concat scratch "flan-wasm-probe.wasm" in
let outcome =
match wasm_build "programs/unit-main.flan" probe with
| () ->
let code, text = wasm_run runner probe in
if code = 0 && text = "ok\n" then Ok ()
else
Error
(Printf.sprintf "%s could not run it: %S (exit %d)" runner text
code)
| exception Failure m -> Error m
in
(try Sys.remove probe with Sys_error _ -> ());
(match outcome with
| Error why ->
Printf.printf "acceptance: skipping the wasm32 case (%s)\n" why
| Ok () ->
let wasm_case name ?opt ?arg path expected =
let wasm =
Filename.concat scratch
("flan-w-" ^ Filename.remove_extension (Filename.basename path)
^ ".wasm")
in
wasm_build ?opt path wasm;
let code, text = wasm_run ?arg runner wasm in
if text <> expected || code <> 0 then begin
incr failures;
Printf.printf
"FAIL %s\n got: %S (exit %d)\n wanted: %S (exit 0)\n"
name text code expected
end;
(try Sys.remove wasm with Sys_error _ -> ())
in
(* The hash, which must equal the native one above. At both levels:
agreement at -O2 alone could be a coincidence of how LLVM folded
the float arithmetic, and -O0 is the cheap way to say it is not. *)
wasm_case "sand, headless, wasm32" "programs/sand-headless.flan"
sand_out;
wasm_case "sand, headless, wasm32, -O0" ~opt:"-O0"
"programs/sand-headless.flan" sand_out;
(* And the two fixed-output programs, which between them cover the
milestone-2 surface: globals, 2-D arrays, places through a
pointer, casts and match. A 32-bit pointer is the thing most
likely to go wrong and these are where it would show. *)
wasm_case "value semantics, wasm32" "programs/values.flan" values_out;
wasm_case "machine surface, wasm32" "programs/machine.flan"
machine_out;
(* calc-me, for the one host-ABI path the three above do not touch:
[flan_argv] builds an array of flan_slice in C and Flan indexes it
as [string], so what is pinned here is the element *stride* of a
ptr+len pair, which is 16 bytes native and 12 on wasm32 — not a
field offset, and nothing else in the table reaches it. This is
also the file header's own claim, that the table runs on wasm32
too, honoured for the first time. *)
wasm_case "calc-me, wasm32" "../calc-me.flan"
~arg:"1 + 2 * (3 - 0.5) / 2" "3.5\n";
(* And the case the whole of Reach.link exists for: a program that
imports raylib, calls none of it, and builds for a target where
libraylib cannot be linked at all. Before, this was not a failing
test — it was a file nobody could write. *)
wasm_case "an imported package nothing calls, wasm32"
"programs/pkg-unused.flan" "ok\n";
wasm_case "an imported package nothing calls, wasm32, -O0"
~opt:"-O0" "programs/pkg-unused.flan" "ok\n"));
(* The EDN tokenizer, and the struct reader written by hand against it
(vendor/edn, test/programs/edn.flan). The expected output is a raw
literal because the token dump is full of brackets and quotes, and
escaping them here would put a second reader between the test and what
the program actually printed.
Every line is one a plausible wrong version fails. The dump prints both
the kind letter and the text in <>, so a tokenizer with the right kinds
and the wrong slices - off by the opening quote, off by the keyword's
colon - fails even though it agreed about every kind. The cases that
are not obvious: a number followed straight by a delimiter ("[1]",
"1;c") separates a scan-to-delimiter from a scan-to-whitespace; foo/bar
must stay a namespaced symbol where a "contains a slash" ratio rule
makes it an error; a string holding a bracket and a semicolon must not
open a vector or start a comment; "1 ; no newline at the end" is the
comment a scan-to-newline loop runs off the end of; and an empty map is
what a reader assuming at least one key-value pair gets wrong.
The refusals are asserted on their *reason* and not on the fact of
failing, with the byte offset first - a tokenizer answering one generic
error for all of them would pass a test that only checked that it
stopped. Both string cases are here because they fail differently: an
escaped quote is the one where a wrong version returns a backslash as
part of the text and leaves the rest of the literal behind as garbage.
At -O0 as well. A Token is a two-word slice inside a struct returned by
value, and a Cursor is passed by pointer with a fixed array in it;
mem2reg is exactly what launders a struct being copied where it should
be shared. *)
let edn_out =
{edn|i<1>
i<-1>i<+2>i<0>
f<1.5>f<-2.5e3>f<.5>
b<true>b<false>n<nil>
y<foo>y<Enemy/Goblin>y<->
k<a>k<foo/bar>
[<>i<1>]<>
[<>i<1>i<2>]<>[<>i<3>]<>
{<>k<a>i<1>}<>
i<1>
k<a>
{<>}<>
[<>]<>
(<>)<>
[<>[<>i<1>]<>[<>i<2>[<>i<3>]<>]<>]<>
{<>k<a>{<>k<b>[<>]<>}<>}<>
k<a>
i<1>
s<x>
i<1>
i<1>i<2>
i<1>
[<>i<1>i<2>i<3>]<>
s<hi>
s<a[b;c>i<1>
s<>i<1>
s<a b>
2 escaped strings are refused: unescaping needs a copy of the bytes, and there is no allocator to put one in
2 escaped strings are refused: unescaping needs a copy of the bytes, and there is no allocator to put one in
0 unterminated string: end of input before the closing quote
0 sets #{} are refused: there is no hash set, and no allocator to build one in
0 tagged literals #tag are refused: the tag would pick the type at run time, which is what a type-directed reader exists to avoid
0 #inst is refused: it is a tagged literal, and there is no timestamp type to read it into
0 #uuid is refused: it is a tagged literal, and there is no uuid type to read it into
0 metadata ^ is refused: it attaches to the value after it, and a flat token stream has nowhere to attach it
0 ratios are refused: there is no rational type, and rounding one to a float would change the value
0 character literals are refused: a character is not a byte once it is not ASCII, and there is no code point type
0 not a number: the token starts like one but does not parse as an integer or a float
3 empty keyword: a colon with no name after it
0 unexpected byte: not the start of any EDN value
0 unexpected byte: not the start of any EDN value
4 unbalanced: this closing delimiter does not match the one that is open
0 unbalanced: this closing delimiter does not match the one that is open
4 unbalanced: this closing delimiter does not match the one that is open
32 nesting is too deep: the balance stack is a fixed array and it is full
[goblin] hp=12 speed=1.5 boss=no
[dragon] hp=40 speed=0 boss=yes
[imp] hp=1 speed=2 boss=no
[] hp=0 speed=0 boss=no
ERR@7 unexpected token: not the kind the caller was reading
[orc] hp=9 speed=0 boss=no
|edn}
in
outputs "edn tokenizer" "programs/edn.flan" edn_out;
outputs ~opt:"-O0" "edn tokenizer, -O0" "programs/edn.flan" edn_out;
(* Comparing enums, found by auditing emit.ml's failwith sites. It type
checked and then died in the backend with no source location, which is
the project's worst failure shape. All six operators, a negative member
so that an unsigned compare would answer the other way, and a compare
through a struct field, which reaches the same lowering by another
path. *)
let enum_out =
"eq yes\neq no\nlo below mid\nhi not below mid\nfield eq yes\n"
in
outputs "enum comparison" "programs/enum-compare.flan" enum_out;
outputs ~opt:"-O0" "enum comparison, -O0" "programs/enum-compare.flan"
enum_out;
(* ── declare-c: the generated FFI shim (lib/shim.ml) ────────────────
The raylib package is the proof that the generator is real — 84
hand-written wrappers replaced by 84 one-line declarations, with the
two raylib cases above unchanged — and the permutation runs below are
the proof that the generated C typedefs actually follow the Flan
`defstruct`s rather than merely looking as if they do.
Everything here is text, not a link: what a wrapper does is settled by
clang, and what is worth asserting in OCaml is the shape of what clang
is handed and the refusals, each by name and reason. *)
let shim_of src =
let decls = Parse.program (Reader.read_all ~file:"<shim-test>" src) in
(* One string again for the assertions: the parts exist so [Reach] can
drop a wrapper, and what is asserted here is the text clang is
handed, which is the concatenation. *)
String.concat "" (List.map snd (Check.program decls).Tast.cshim)
in
let shim_case name src needles =
match shim_of src with
| c ->
List.iter
(fun n ->
if not (contains c n) then begin
incr failures;
Printf.printf "FAIL %s\n wanted in the generated C: %S\n"
name n
end)
needles
| exception Loc.Error (_, m) ->
incr failures;
Printf.printf "FAIL %s\n refused: %s\n" name m
in
(* A refusal is by name and carries the reason; the tests assert on the
reason, so weakening one to a bare "cannot" breaks them. *)
let shim_refuses name src fragment =
match shim_of src with
| _ ->
incr failures;
Printf.printf "FAIL %s: accepted, and it should not have been\n" name
| exception Loc.Error (_, m) ->
if not (contains m fragment) then begin
incr failures;
Printf.printf "FAIL %s\n reason: %S\n wanted to contain: %S\n"
name m fragment
end
in
let v2 = "(defstruct Vector2 [x f32 y f32])\n" in
let img =
"(defstruct Image [data (Ptr u8) width i32 height i32])\n"
in
(* A struct argument goes by pointer and a struct return through an
out-pointer, and the prototype says what C really takes. *)
shim_case "declare-c: a struct crosses by pointer, both ways"
(v2 ^ "(declare-c mid [a Vector2 b Vector2] Vector2 \"Mid\")")
[ "extern flan_ty_Vector2"; "*out = Mid(*a0, *a1);";
"const flan_ty_Vector2"; "*out)" ];
(* The typedef is made from the defstruct and nothing else, so its field
order is the defstruct's — which is what makes permuting a defstruct a
real test rather than a rewording. Both orders asserted, because only
the pair rules out a generator that sorts. *)
shim_case "declare-c: the C typedef follows the defstruct's field order"
(v2 ^ "(declare-c f [v Vector2] \"F\")")
[ " float x;\n float y;\n" ];
shim_case "declare-c: and permuting the defstruct permutes the typedef"
("(defstruct Vector2 [y f32 x f32])\n(declare-c f [v Vector2] \"F\")")
[ " float y;\n float x;\n" ];
(* One type mapper for fields and parameters alike: a bool is C's bool and
never an int, and a pointer field keeps its element type. *)
shim_case "declare-c: field and parameter types come from one mapper"
(img
^ "(defstruct S [flag bool n u64])\n\
(declare-c g [s S i (Ptr Image) b bool] u64 \"G\")")
[ " bool flag;\n uint64_t n;\n"; " uint8_t *data;\n";
"uint64_t G(flan_ty_S"; "bool a2" ];
(* A struct held by value pulls its own typedef in, and the definitions are
ordered so the inner one is complete first. *)
shim_case "declare-c: a nested struct is defined before it is used"
(v2 ^ "(defstruct Camera2D [offset Vector2 zoom f32])\n\
(declare-c h [c Camera2D] \"H\")")
[ "struct flan_ty_Vector2"; " flan_ty_Vector2" ];
(* A string is ptr+len on the Flan side and a NUL-terminated copy on C's.
The buffer is sized here and not per call site, because a generator has
no call site to look at: 256 on the stack, the heap past that, and the
copy is freed after the call rather than before the return value is
computed. *)
shim_case "declare-c: a string is copied, NUL-terminated and freed"
"(declare-c open-it [path string] bool \"OpenIt\")"
[ "char a0_b[256];"; "flan_shim_cstr(a0_p, a0_n, a0_b, sizeof a0_b)";
"bool r = OpenIt(a0);"; "flan_shim_cstr_free(a0, a0_b);";
" return r;\n" ];
shim_case "declare-c: two strings get two buffers"
"(declare-c both [a string b string] \"Both\")"
[ "char a0_b[256];"; "char a1_b[256];";
"flan_shim_cstr_free(a0, a0_b);"; "flan_shim_cstr_free(a1, a1_b);" ];
(* [declare] is untouched by any of this: its signature still IS the C
signature, which is what vendor/agent's flan_agent_start and the
prelude's sqrtf depend on. A program with no declare-c generates no C
at all. *)
if shim_of "(declare start [path string] i32 \"flan_agent_start\")" <> ""
then begin
incr failures;
print_endline "FAIL declare (not declare-c) generated a shim"
end;
shim_refuses "declare-c: a slice parameter, by name and reason"
(v2 ^ "(declare-c poly [pts [Vector2]] bool \"Poly\")")
"the count parameter the C function actually takes";
shim_refuses "declare-c: an Option"
(v2 ^ "(declare-c maybe [] (Option Vector2) \"Maybe\")")
"which is a Flan shape and not a C one";
shim_refuses "declare-c: a union"
("(defunion Shape [(Circle [r f32]) (Square [s f32])])\n\
(declare-c area [s Shape] f32 \"Area\")")
"a union, and a Flan union has no C layout";
shim_refuses "declare-c: a fixed array"
"(declare-c takes [xs [4 f32]] \"Takes\")"
"which C passes as a pointer and Flan as a value";
shim_refuses "declare-c: a map"
"(declare-c takes [m {string i32}] \"Takes\")"
"which has no C representation";
shim_refuses "declare-c: a returned string"
"(declare-c name [] string \"Name\")"
"a string only crosses as a parameter";
shim_refuses "declare-c: a callback"
"(declare-c each [f (Fn [i32] Unit)] \"Each\")"
"a C callback is not implemented";
shim_refuses "declare-c: an unknown type"
"(declare-c f [x Nope] \"F\")"
"which is not a type this shim generator knows";
shim_refuses "declare-c: a field C cannot hold"
"(defstruct S [xs [i32]])\n(declare-c f [s S] \"F\")"
"field xs of S is a slice";
shim_refuses "declare-c: the generated name is already taken"
(v2
^ "(defn mid-c [a (Ptr Vector2) out (Ptr Vector2)])\n\
(declare-c mid [a Vector2] Vector2 \"Mid\")")
"needs the name mid-c for the declaration it generates";
shim_refuses "declare-c: two Flan names for one C function"
"(declare-c a [] \"Same\")\n(declare-c b [] \"Same\")"
"one declare-c per C function";
(* Two programs written against a mutation-testing report, each covering a
claim the whole suite could be broken on while staying green.
cleanup.flan: a return running the defers above it, and running them
innermost-first; a defer that calls something, so a guard is emitted
inside it on the transfer path; a transfer out of a handler-bind popping
its frames; a two-clause handler-bind popping both; and a signal that
stops at the inner handler once that one has answered it by
transferring. Six claims, and the numbers differ per failure so a wrong
answer names its own cause.
signedness.flan: the ashr/lshr and slt/ult choices, which emit.ml makes
from the operand's type. Either could have been hardcoded to one arm,
because nothing in the corpus shifted a negative right or compared an
unsigned value above 2^31. *)
let cleanup_out = "7\n21\n42\n0\n5\n0\n0\n" in
outputs "cleanup paths" "programs/cleanup.flan" cleanup_out;
outputs ~opt:"-O0" "cleanup paths, -O0" "programs/cleanup.flan" cleanup_out;
let signed_out = "-4\n-1\nbig is not small\nbig is large\n1\n" in
outputs "signedness" "programs/signedness.flan" signed_out;
outputs ~opt:"-O0" "signedness, -O0" "programs/signedness.flan" signed_out;
(* ── Destructuring ─────────────────────────────────────────── *)
(* A destructuring let is desugared in [Parse] into the Let, field access,
[at] and [slice] that already existed, so there is nothing in the typed
IR to inspect and this program *is* the test. The last line is the one
that catches the mistake worth catching: four names come out of two
calls, so a desugaring that dropped the temporary and re-evaluated the
initialiser per name would print 4 instead of 2. Every other line here
would stay green through that. -O0 as well, for the usual reason — the
tail slice is an address into a local array, and mem2reg launders a
sloppy one. *)
let destructure_out =
"keys 1 2\npairs 10 20\nnested 7 8\nshadow 5 6\nsequential 100 200\n\
array 11 22 33\nrest 1 4 2 5\nempty-tail 17 0\nnested-in-array 1 4\n\
struct-tail 1 2 4 5\ncalls 2 14\n"
in
outputs "destructuring" "programs/destructure.flan" destructure_out;
outputs ~opt:"-O0" "destructuring, -O0" "programs/destructure.flan"
destructure_out;
(* A package-qualified struct as a declared return type, which the parser
used to read as the first body form. Reported by the raylib lane, which
hit it on rl/Vector2 and worked around it rather than reaching into a
file it did not own. *)
let pkgret_out = "9\n5\n" in
outputs "a package struct in return position" "programs/pkg-return.flan"
pkgret_out;
outputs ~opt:"-O0" "a package struct in return position, -O0"
"programs/pkg-return.flan" pkgret_out;
(* -- Source-level debugging: DWARF, and whether it is true ---------
The whole of this section is about one risk. A Flan struct is its C
struct and lldb needs to learn nothing about the data model, which is
what makes DWARF cheap here; but !DIDerivedType takes its member offset
as an integer literal, so those offsets are the one layout number the
backend works out for itself instead of handing to LLVM. A wrong one
does not crash: it prints a plausible value for the wrong field, which
is the failure this project has met over and over at the FFI boundary.
So the offsets are not checked against a table written by the same hand
as the code. They are checked against LLVM's own answer for the same
struct type — ptrtoint of a getelementptr through a null pointer, which
is exactly the idiom Emit already uses for the size it passes to
flan_dev_global — constant-folded by llc into a .quad and read back.
And the whole thing is run twice over the same struct with its fields
permuted, because a check that cannot come out differently is not
checking anything. *)
(* Small text tools, since there is no Str and the reader is hand-written
for the same reason. *)
let lines_of s = String.split_on_char '\n' s in
let index_of hay needle =
let n = String.length needle and h = String.length hay in
let rec go i =
if i + n > h then -1 else if String.sub hay i n = needle then i else go (i + 1)
in
go 0
in
(* The value of [key: ] in a metadata node, up to the next , or ). *)
let attr line key =
let k = key ^ ": " in
match index_of line k with
| -1 -> None
| i ->
let i = i + String.length k in
let j = ref i in
let n = String.length line in
while !j < n && line.[!j] <> ',' && line.[!j] <> ')' do incr j done;
Some (String.sub line i (!j - i))
in
(* [elements: !{!12, !13}] — the value has commas in it, so it needs its
own reader rather than [attr]'s stop-at-the-next-comma. *)
let attr_ids line key =
let k = key ^ ": !{" in
match index_of line k with
| -1 -> []
| i ->
let i = i + String.length k in
let j = ref i and n = String.length line in
while !j < n && line.[!j] <> '}' do incr j done;
String.sub line i (!j - i)
|> String.split_on_char ','
|> List.filter_map (fun t ->
let t = String.trim t in
if String.length t > 1 && t.[0] = '!' then
int_of_string_opt (String.sub t 1 (String.length t - 1))
else None)
in
let unquote s =
let n = String.length s in
if n >= 2 && s.[0] = '"' && s.[n - 1] = '"' then String.sub s 1 (n - 2) else s
in
(* The parameter names come down from the driver, exactly as [bin/main.ml]
sends them: the typed IR does not carry them. *)
let pnames_of decls =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defn fn ->
Some (fn.Ast.name,
List.map (fun (f : Ast.field) -> f.Ast.fname) fn.Ast.params)
| _ -> None)
decls
in
let debug_ir src =
let decls = Parse.program (Reader.read_all ~file:"<dwarf-test>" src) in
Emit.program ~debug:true ~pnames:(pnames_of decls) (Check.program decls)
in
(* Every (member name, byte offset) of a named struct, in declaration
order, as the emitted DWARF states it. *)
let dwarf_members ir sname =
let ls = lines_of ir in
let node id =
List.find_opt
(fun l -> String.starts_with ~prefix:(Printf.sprintf "!%d = " id) l) ls
in
let composite =
List.find_opt
(fun l ->
index_of l "!DICompositeType(tag: DW_TAG_structure_type" >= 0
&& attr l "name" = Some (Printf.sprintf "\"%s\"" sname))
ls
in
match composite with
| None -> None
| Some c ->
let ids = attr_ids c "elements" in
Some
((List.filter_map
(fun id ->
match node id with
| None -> None
| Some l ->
(match attr l "name", attr l "offset" with
| Some n, Some o ->
Some (unquote n, int_of_string (String.trim o) / 8)
| _ -> None))
ids),
(match attr c "size" with
| Some sz -> int_of_string (String.trim sz) / 8
| None -> -1))
in
(* LLVM's own answer, for the same struct type text the DWARF describes.
The type definitions are lifted straight out of the emitted module, so
there is no second spelling of the layout to get wrong. *)
let llvm_members ir sname nfields =
let tydefs =
lines_of ir
|> List.filter (fun l ->
String.length l > 0 && l.[0] = '%' && index_of l " = type " >= 0)
in
let sty = Printf.sprintf "%%\"%s\"" sname in
let b = Buffer.create 512 in
List.iter (fun l -> Buffer.add_string b (l ^ "\n")) tydefs;
for i = 0 to nfields - 1 do
Buffer.add_string b
(Printf.sprintf
"@o%d = constant i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 0, i32 %d) to i64)\n"
i sty i)
done;
Buffer.add_string b
(Printf.sprintf
"@sz = constant i64 ptrtoint (ptr getelementptr (%s, ptr null, i32 1) to i64)\n"
sty);
let ll = Filename.concat scratch "flan-dwarf-oracle.ll" in
let asm = Filename.concat scratch "flan-dwarf-oracle.s" in
Out_channel.with_open_bin ll (fun ch -> Out_channel.output_string ch (Buffer.contents b));
let llc = try Sys.getenv "FLAN_LLC" with Not_found -> "llc" in
let code =
Sys.command
(Printf.sprintf "%s -filetype=asm %s -o %s > /dev/null 2>&1"
(Filename.quote llc) (Filename.quote ll) (Filename.quote asm))
in
if code <> 0 then None
else begin
let text = In_channel.with_open_bin asm In_channel.input_all in
(try Sys.remove ll with Sys_error _ -> ());
(try Sys.remove asm with Sys_error _ -> ());
(* llc writes the folded constant as ".quad 0+24" — a sum, because the
null base is still a symbolic zero to the assembler. *)
let pending = ref "" and acc = ref [] in
List.iter
(fun l ->
let t = String.trim l in
if String.length t > 1 && t.[String.length t - 1] = ':' then
pending := String.sub t 0 (String.length t - 1)
else if index_of t ".quad" >= 0 && !pending <> "" then begin
let v = String.trim (String.sub t 5 (String.length t - 5)) in
let v = match index_of v "#" with -1 -> v | i -> String.sub v 0 i in
let n =
String.split_on_char '+' v
|> List.fold_left
(fun a part ->
match int_of_string_opt (String.trim part) with
| Some x -> a + x
| None -> a)
0
in
acc := (!pending, n) :: !acc;
pending := ""
end)
(lines_of text);
Some (List.rev !acc)
end
in
(* The case itself: the DWARF a source text produces must agree with LLVM
on every member's offset, and on the struct's size. *)
let layout_case name src sname fields =
let ir = debug_ir src in
match dwarf_members ir sname with
| None ->
incr failures;
Printf.printf "FAIL %s\n no DWARF type for %s\n" name sname
| Some (members, size) ->
let got = List.map fst members in
if got <> fields then begin
incr failures;
Printf.printf "FAIL %s\n DWARF members: %s\n wanted: %s\n"
name (String.concat " " got) (String.concat " " fields)
end;
(match llvm_members ir sname (List.length fields) with
| None ->
(* No llc is a reason to skip the oracle, not to pass silently. *)
Printf.printf "acceptance: %s — llc unavailable, offsets unchecked\n" name
| Some oracle ->
List.iteri
(fun i (fname, off) ->
match List.assoc_opt (Printf.sprintf "o%d" i) oracle with
| None -> ()
| Some want ->
if off <> want then begin
incr failures;
Printf.printf
"FAIL %s\n %s.%s at byte %d in the DWARF, %d in LLVM\n"
name sname fname off want
end)
members;
(match List.assoc_opt "sz" oracle with
| Some want when want <> size ->
incr failures;
Printf.printf
"FAIL %s\n %s is %d bytes in the DWARF, %d in LLVM\n"
name sname size want
| _ -> ()));
()
in
let cell = "(defstruct Cell [alive bool heat f64 id i32 name string])\n" in
let cell' = "(defstruct Cell [name string id i32 alive bool heat f64])\n" in
let body = "(defn main [] i32 (let [c (Cell {:id 1})] (i32 (.id c))))\n" in
layout_case "DWARF offsets agree with LLVM: a mixed struct" (cell ^ body)
"Cell" [ "alive"; "heat"; "id"; "name" ];
(* The same struct, permuted. If the offsets came from anywhere but the
declaration order they would survive this, and they do not. *)
layout_case "DWARF offsets agree with LLVM: the same fields permuted"
(cell' ^ body) "Cell" [ "name"; "id"; "alive"; "heat" ];
layout_case "DWARF offsets agree with LLVM: nesting and fixed arrays"
("(defstruct P [x i32 y i32])\n\
(defstruct Board [tag u8 cells [4 P] here P edge (Ptr P) seen (Option i64)])\n\
(defn main [] i32 (let [b (Board {:tag 1})] (i32 (.tag b))))\n")
"Board" [ "tag"; "cells"; "here"; "edge"; "seen" ];
(* Permuting the fields must actually move them. Asserting that the two
orderings disagree is what makes the two cases above a test: an offset
table that ignored declaration order would satisfy both. *)
(match dwarf_members (debug_ir (cell ^ body)) "Cell",
dwarf_members (debug_ir (cell' ^ body)) "Cell" with
| Some (a, _), Some (b, _) ->
let off l n = List.assoc_opt n l in
if List.for_all (fun n -> off a n = off b n) [ "alive"; "heat"; "id"; "name" ]
then begin
incr failures;
print_endline
"FAIL permuting a defstruct left every DWARF offset unchanged"
end
| _ ->
incr failures;
print_endline "FAIL permuting a defstruct: no DWARF type for Cell");
(* A slot's *type* has to be right too, not only where it sits. These are
the shapes lldb has to render, and the layout table says what each one
weighs; a wrong size there is a truncated or over-read value. *)
let ir = debug_ir (cell ^ body) in
List.iter
(fun (needle, what) ->
if not (contains ir needle) then begin
incr failures;
Printf.printf "FAIL DWARF for %s\n wanted: %S\n" what needle
end)
[ ("!DIBasicType(name: \"i32\", size: 32, encoding: DW_ATE_signed)", "i32");
("!DIBasicType(name: \"u8\", size: 8, encoding: DW_ATE_unsigned)", "u8");
("!DIBasicType(name: \"f64\", size: 64, encoding: DW_ATE_float)", "f64");
(* A byte in memory, not a bit: an i1 alloca is one byte wide. *)
("!DIBasicType(name: \"bool\", size: 8, encoding: DW_ATE_boolean)", "bool");
(* ptr+len, and shown as ptr+len — there is no owner and no capacity
to hide, so two members are the whole truth about a string. *)
("name: \"string\", size: 128", "string");
(* A let-bound local 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-placeholder [] -1)))\n\
(defn run [] i32\n\
\ (defer (set seen (+ seen 1)))\n\
\ (handler-bind [(Missing [m] (invoke-restart 'use-placeholder))]\n\
\ (fetch 3)))\n\
(defn main [] i32\n\
\ (set (at arr 2) 9)\n\
\ (let [s (slice arr 0 4)]\n\
\ (print-i64 (i64 (pick s 2))) (newline)\n\
\ (print-i64 (i64 (run))) (newline)\n\
\ 0))\n"
in
let decls = Parse.program (Reader.read_all ~file:"<verify>" src) in
let p = Check.program decls in
verifies "the whole program, with debug info"
(Emit.program ~debug:true ~pnames:(pnames_of decls) p);
(* And a redefinition module against a host that has every name — the
shape C-c C-c produces. *)
verifies "a redefinition module, with debug info"
(Emit.redefinition ~dev:true ~debug:true ~known:(fun _ -> true) p
~fns:[ "fetch"; "run" ]);
(* And one against a host that has none of them, which is the other
path: every call goes through flan_dev_cell and every global through
flan_dev_global, so the module is almost entirely different code. *)
verifies "a redefinition of names the host does not have"
(Emit.redefinition ~dev:true ~debug:true ~known:(fun _ -> false) p
~fns:[ "fetch"; "run" ])
end
else print_endline "acceptance: the DWARF verifier cases skipped (no opt)";
(* A debug build and a release build must still be the same program. *)
let debug_compile ?(dev = false) path =
let exe =
Filename.concat scratch
("flan-dbg-" ^ Filename.remove_extension (Filename.basename path)
^ if dev then "-dev" else "")
in
let l = Load.program ~file:path (Parse.program (Reader.read_file path)) in
let p = Check.program l.Load.decls in
let pnames =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with
| Ast.Defn fn ->
Some (fn.Ast.name,
List.map (fun (f : Ast.field) -> f.Ast.fname) fn.Ast.params)
| _ -> None)
l.Load.decls
in
let p, csrcs, lflags = Reach.link ~dev l p in
ignore
(Build.executable ~opts:{ Build.default with debug = true; dev }
~csrcs ~lflags ~pnames p ~out:exe);
exe
in
let expected = "42\n4.75\n42\ngrain\n" in
List.iter
(fun path ->
let exe = debug_compile path in
let code, text = run exe None in
if text <> expected || code <> 0 then begin
incr failures;
Printf.printf
"FAIL a --debug build of %s runs the same\n got: %S (exit %d)\n wanted: %S\n"
path text code expected
end)
[ "programs/debug.flan"; "programs/debug-permuted.flan" ];
(* wasm32 is refused by name. The offsets above are the host's, and
wasm32's 32-bit pointer moves every slice member; emitting them anyway
would give a debugger a confident wrong answer. *)
(match
Build.executable
~opts:{ Build.default with debug = true; target = Some "wasm32-wasi" }
{ Tast.structs = []; unions = []; globals = []; externs = []; fns = [];
cshim = [] }
~out:(Filename.concat scratch "flan-dbg-wasm")
with
| _ ->
incr failures;
print_endline "FAIL --debug --target=wasm32-wasi was accepted"
| exception Failure m ->
if not (contains m "--debug is native only") then begin
incr failures;
Printf.printf "FAIL --debug on wasm32\n said: %S\n" m
end);
(* -- lldb, for real ------------------------------------------------
Everything above is about the metadata being self-consistent. This is
the only part that says a person can debug a Flan program: a breakpoint
set on a Flan function *by name*, a backtrace with .flan files and line
numbers, and locals printed with their own types and values. It is
skipped rather than failed where there is no lldb. *)
if Sys.command "command -v lldb > /dev/null 2>&1" = 0 then begin
let lldb_run exe cmds =
let out = Filename.concat scratch "flan-lldb.out" in
let code =
Sys.command
(Printf.sprintf "lldb -b %s %s > %s 2>&1"
(String.concat " "
(List.map (fun c -> "-o " ^ Filename.quote c) cmds))
(Filename.quote exe) (Filename.quote out))
in
let text = In_channel.with_open_bin out In_channel.input_all in
(try Sys.remove out with Sys_error _ -> ());
(code, text)
in
let lldb_case name path needles =
let exe = debug_compile path in
let _, text =
lldb_run exe
[ "breakpoint set --name flan.tick"; "run"; "bt"; "frame variable";
"p *c" ]
in
List.iter
(fun n ->
if not (contains text n) then begin
incr failures;
Printf.printf "FAIL %s\n wanted %S in lldb's output\n"
name n;
print_endline text
end)
needles
in
(* The four claims, one needle each: the breakpoint resolved on a Flan
name; the frame names a .flan file and a line inside tick; the caller
is the Flan main and not a C frame; a parameter prints by its source
name; and the struct through the pointer prints every field with the
value the program put there. *)
lldb_case "lldb: breakpoint, frames and locals" "programs/debug.flan"
[ "flan.tick"; "at debug.flan:"; "flan.main at debug.flan:";
"(int) n = 41"; "alive = true"; "heat = 3.25"; "id = 7"; "len = 5";
(* And the 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