Joseph Ferano
87aeb7b0da
F3: the unknown-struct-vs-function message overgeneralized a one-case
parser quirk into a language rule that does not exist. (g {:a 1}) compiles
fine -- only the empty map is stolen by is_struct_map's Map [] -> true.
The message now names {} specifically and says why: it is read as the
zero-field struct literal, not "a map literal cannot be passed as an
argument".
F2: the ordering refusal named machine numbers only, when Types.is_comparable
also admits enums and enum-compare.flan orders one with (< k :mid). Both
messages -- equality and ordering -- now name every type each actually
covers.
F1 and F5, together, since both live in the same parse.ml arm: the
rest = [] carve-out that let a single-form dyn map body through
reintroduced the exact bug the earlier fix was for. (defn mx [a $t b $t]
$t {:where (ordered? $t)}) -- a :where clause with nothing after it, what
a moved closing paren produces -- no longer matched, fell through to expr,
and printed "unknown function ordered?" from inside what was meant as a
predicate. A :where map is peeled unconditionally again, whether or not
anything follows it; every other keyword, plus the empty map and any
non-keyword key, is still peeled only when the body has more after it, so
a real single-form dyn map body is still left alone. The comment
justifying the discarded-map refusal claimed a map literal has no side
effects; it does -- {:a (println "hi")} prints, confirmed by running it --
so the reasoning now names the actual problem, a value going unused, not
a false claim about purity.
Closing that F1 hole this way opened two more, both traced by rebuilding
the pre-fix parse.ml and diffing real compiler output rather than
reasoning about it: {.x 1} at a defn body's head used to get its own
message, "a bare map is not an expression", and briefly started getting
"a constraint map is keyword/value pairs" instead, because the broadened
guard no longer required a keyword and started catching the struct-field
shape too. Excluded explicitly, with a comment saying why, so expr's
dedicated diagnostic fires again. And (defn main [] i32 {} 0) and
(defn main [] i32 {"a" 1} 0) -- the empty map and the non-keyword-keyed
map, the two siblings a keyword-only guard could never have caught --
now get their own refusals alongside the keyword case, each pinned with
a rejects_check row, along with the where-with-no-body case and the two
legitimate single-form bodies that must keep compiling.
F6: the acceptance runner's tail already caught every failure on every
path through the binary -- there is no skip branch that bypasses it, and
the no-clang branch runs zero rows -- so last round's at_exit guard and
the FIX.org note both overstated what was broken. Both now say what was
actually true: the exit status was already trustworthy, the guard is
insurance against a future case leaving past the tail instead of through
it, and the other nine test binaries were already sound the same way.
The guard also had a real bug of its own: forcing exit 1 whenever
failures was nonzero would stomp the watchdog's own exit 2 if a hang
followed a few already-failed rows, since Stdlib.exit runs at_exit
handlers LIFO. watchdog.ml now flags when it is the one unwinding, and
test_acceptance.ml's guard defers to it -- shared state for a single
caller, justified by there being no other way for one at_exit handler to
know a sibling handler is already mid-exit with a code of its own to
protect.
Verified every case in this commit by compiling and, where it mattered,
running the actual program -- not by inspecting the arm and assuming.
dune test --force: exit 0, clean grep for FAIL and Fatal error.
76 lines
3.2 KiB
OCaml
76 lines
3.2 KiB
OCaml
(* A clock on every test binary, because a green run is not the only outcome
|
|
to plan for.
|
|
|
|
The mutation pass that produced NEXT.md's blind-spot list turned up one
|
|
defect that did not make the suite fail — it made it *hang*. A reader loop
|
|
that forgets to advance reads the same character for ever, and every binary
|
|
that reads a .flan file stops there. Nothing prints, nothing exits, and
|
|
[dune test] waits as long as it is left to. In CI that is a job killed by
|
|
the runner's own timeout, with no failing case named and no output to read.
|
|
|
|
So: an alarm, at two scales.
|
|
|
|
[arm] is the per-binary backstop. It is deliberately generous — test_dev
|
|
launches a daemon and test_acceptance builds for wasm32 — because an alarm
|
|
that fires on a slow machine is a flake, and a flake is how a watchdog gets
|
|
deleted. It is here to turn "for ever" into "fails in ten minutes", not to
|
|
measure anything.
|
|
|
|
[within] is the tight one, for a call whose budget really is small: reading
|
|
a few characters of source. It raises [Timeout] rather than exiting, so the
|
|
caller can report one failing row and carry on through the rest of its
|
|
table — a binary that dies on the first hang tells you much less than one
|
|
that finishes and names every case that hung.
|
|
|
|
SIGALRM is delivered at OCaml's safepoints, which are inserted at loop
|
|
back-edges and function entries, so a tight loop that allocates nothing is
|
|
still interruptible. *)
|
|
|
|
exception Timeout
|
|
|
|
let label = ref "test"
|
|
let budget = ref 0
|
|
let deadline = ref 0.0
|
|
|
|
(* Set the instant [dying] starts unwinding, and read by any [at_exit]
|
|
handler a binary registers of its own (test_acceptance.ml's failure-count
|
|
guard is the one that exists) so it knows not to relabel this exit as an
|
|
ordinary failing run: the watchdog's 2 is a distinct code from a FAIL's 1,
|
|
and an [at_exit] handler that forced 1 whenever [failures > 0] would
|
|
overwrite it out from under a hang that happened to come after a few rows
|
|
had already failed. *)
|
|
let dying_flag = ref false
|
|
let is_dying () = !dying_flag
|
|
|
|
let dying _ =
|
|
dying_flag := true;
|
|
Printf.eprintf
|
|
"\nFAIL %s: no result after %ds — stopped by the test watchdog.\n\
|
|
\ A test that hangs reports nothing at all; this is that outcome\n\
|
|
\ turned into a failing run.\n"
|
|
!label !budget;
|
|
flush stderr;
|
|
(* [exit] rather than [_exit]: the rows that did pass are in stdout's buffer
|
|
and a watchdog that threw them away would be worse than the hang. *)
|
|
exit 2
|
|
|
|
(* Re-arm the backstop for whatever is left of its budget. One second is the
|
|
floor, because [alarm 0] cancels rather than fires. *)
|
|
let backstop () =
|
|
Sys.set_signal Sys.sigalrm (Sys.Signal_handle dying);
|
|
let left = !deadline -. Unix.gettimeofday () in
|
|
ignore (Unix.alarm (max 1 (int_of_float left)))
|
|
|
|
let arm ?(seconds = 600) name =
|
|
label := name;
|
|
budget := seconds;
|
|
deadline := Unix.gettimeofday () +. float_of_int seconds;
|
|
backstop ()
|
|
|
|
(* [f] under a tighter alarm, with the backstop restored afterwards however
|
|
[f] left. *)
|
|
let within seconds f =
|
|
Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout));
|
|
ignore (Unix.alarm seconds);
|
|
Fun.protect ~finally:backstop f
|