From 9549d386a1d37dd571f4631d639d0b0cf06d57a6 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 10:35:33 +0700 Subject: [PATCH 1/8] A sign and an unknown escape are both the reader's business Two mutations the reader survived: dropping '+' from the number dispatch, so +5 reads as a symbol nobody defined, and accepting an unknown string escape as the character after the backslash, so a typo silently reads a different string. Both now have a row, and the known escapes are asserted on the decoded bytes rather than through Form.to_string, which escapes them again and would compare the source with itself. --- test/test_flan.ml | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/test/test_flan.ml b/test/test_flan.ml index ff84835..9768a6e 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -47,6 +47,15 @@ let () = (* ── Atoms ─────────────────────────────────────────────────────── *) reads "integer" "42" "42"; reads "negative" "-1" "-1"; + (* A sign is part of the number, both ways. [+5] is the one that reads as a + symbol the moment the '+' case is dropped from the dispatch, and a symbol + named "+5" is an unknown name much later and somewhere else. *) + reads "leading plus" "+5" "5"; + reads "plus float" "+0.5" "0.5"; + reads "plus in a call" "(f +5 -5)" "(f 5 -5)"; + (* And the operator is still itself: [+] alone is the addition symbol, and + [(+ 1 2)] must not read its head as a number. *) + reads "bare plus" "+" "+"; reads "float" "0.05" "0.05"; reads "hex" "0xE6B800FF" "3870818559"; reads "string" "\"SAND\"" "\"SAND\""; @@ -141,6 +150,18 @@ let () = rejects "unterminated str" "\"abc"; rejects "empty keyword" ":"; rejects "unknown char" "\\bogus"; + (* An escape the reader does not know is a typo, not a character: accepting + \q as 'q' silently reads a different string than the one that was + written, and nothing downstream can tell. *) + rejects "unknown string escape" "\"a\\qb\"" ~needle:"unknown string escape"; + (* The escapes it does know still decode, which is what says the rejection + above rejects the unknown one and not escaping itself. Asserted on the + string's bytes rather than through [Form.to_string], which escapes them + again and would compare the source with itself. *) + (match Reader.read_all ~file:"" "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with + | [ { Form.v = Form.Str s; _ } ] -> + check "known escapes" (s = "a\nb\tc\\d\"e\000f") + | _ -> check "known escapes: one string" false); rejects "metadata" "^:async"; rejects "dangling quote" "'"; (* Each of these asserts the reason, not merely that something failed. *) From 86d0c14a45a0ef5836f908ad731aa05f08fbc9d2 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 10:38:40 +0700 Subject: [PATCH 2/8] Three edges of Reach's walk that nothing called An index expression inside a place, a place under addr, and a restart-case clause body are each the only route to a function in reach-walk.flan. Drop any one of the three from the walk and the function is not emitted, so the program stops linking rather than answering wrong; each mutation was planted and watched fail here. The addr case goes through a deref place on purpose, so the index case cannot stand in for it. --- test/programs/reach-walk.flan | 53 +++++++++++++++++++++++++++++++++++ test/test_acceptance.ml | 26 +++++++++++++++++ 2 files changed, 79 insertions(+) create mode 100644 test/programs/reach-walk.flan diff --git a/test/programs/reach-walk.flan b/test/programs/reach-walk.flan new file mode 100644 index 0000000..a82c111 --- /dev/null +++ b/test/programs/reach-walk.flan @@ -0,0 +1,53 @@ +;;;; Three edges of Reach's walk, each the only route to one function. +;;;; +;;;; A release build is pruned: a function nothing reachable from main or from +;;;; a global initialiser calls is not emitted at all. So an edge the walk +;;;; forgets does not produce a wrong answer — it produces a program that does +;;;; not link, with a message about a symbol nobody wrote. Each of the three +;;;; functions below is called from exactly one place, and that place is an +;;;; edge no other program in the corpus exercises: +;;;; +;;;; index-of the index expression of a place, (set (at a (f)) v) +;;;; through a place under (addr ...), here a (deref ...) so that it is +;;;; the addr edge and not the index one again +;;;; placeholder a restart-case clause body, which is reached by a transfer +;;;; and never by a call the walk can see from the body +;;;; +;;;; Nothing here is about the values; the values are how the test notices that +;;;; the program was built and ran at all. + +(defvar cells [4 i32]) +(defvar slot i32) + +(defstruct Nope [id i32]) + +(defn index-of [] i32 2) + +(defn through [] (Ptr i32) (addr slot)) + +(defn placeholder [] i32 42) + +;;; Signals with nothing to return, so the clause body is the only way past. +(defn missing [] i32 + (error (Nope {:id 1}))) + +(defn pick [] i32 + (restart-case (missing) + (use-placeholder [] (placeholder)))) + +(defn main [] i32 + ;; The index of a place is an expression, and it can call. + (set (at cells (index-of)) 10) + (print (at cells 2)) (println "") + + ;; (addr (deref p)) is p, so this is the addr edge over a place whose own + ;; walk is Pderef rather than Pindex — the index case above cannot stand in + ;; for it. + (let [q (addr (deref (through)))] + (set (deref q) 20)) + (print slot) (println "") + + ;; The clause body, reached only because the handler transfers into it. + (handler-bind [(Nope [c] (invoke-restart 'use-placeholder))] + (print (pick)) (println "")) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 05b46a2..af19c20 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -661,6 +661,32 @@ let () = outputs "a package reached along two routes" "programs/pkg-shared.flan" "ok\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 From 79a8142b7887cfe25ea694792679a4afcdd2943f Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 10:40:47 +0700 Subject: [PATCH 3/8] A local shadowing an imported name, in an expression and in a place MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Qualification rewrites a package's own names wherever they are used and has to stop at a binding. Nothing refuses a renamer that does not: the program builds, runs, and reads the top-level name instead. The package in shadow-pkg.flan binds locals called limit and sink over its own constant and var, and the four numbers separate the two halves — dropping the shadowing check in the expression renamer gives 5, dropping it in the place renamer moves the 20 onto the package's sink. --- test/programs/pkg-shadow.flan | 17 +++++++++++++++++ test/programs/shadow-pkg.flan | 21 +++++++++++++++++++++ test/test_acceptance.ml | 10 ++++++++++ 3 files changed, 48 insertions(+) create mode 100644 test/programs/pkg-shadow.flan create mode 100644 test/programs/shadow-pkg.flan diff --git a/test/programs/pkg-shadow.flan b/test/programs/pkg-shadow.flan new file mode 100644 index 0000000..bbec4e5 --- /dev/null +++ b/test/programs/pkg-shadow.flan @@ -0,0 +1,17 @@ +;;;; A local shadowing an imported name (test/programs/shadow-pkg.flan). +;;;; +;;;; Nothing about this program is unusual; the package it imports is where the +;;;; shadowing is. What is asserted is that qualification stopped at the local: +;;;; 7 rather than the constant's 5, and 20 out of [assigned] with the +;;;; package's own [sink] still zero. A renamer that qualifies through a +;;;; binding produces no error anywhere — it silently reads and writes the +;;;; top-level name instead. + +(import shd "shadow-pkg.flan") + +(defn main [] i32 + (print (shd/shadowed)) (println "") + (print (shd/assigned)) (println "") + (print shd/sink) (println "") + (print shd/limit) (println "") + 0) diff --git a/test/programs/shadow-pkg.flan b/test/programs/shadow-pkg.flan new file mode 100644 index 0000000..7d49b58 --- /dev/null +++ b/test/programs/shadow-pkg.flan @@ -0,0 +1,21 @@ +;;;; A package whose own bodies bind locals named after its own top-level +;;;; names. Imported, every name this file owns is rewritten to shd/name +;;;; wherever it is *used* — and a local binding shadows, so inside these two +;;;; functions the bare name is the local and must be left alone. Get that +;;;; wrong and the code still compiles and still runs; it just reads a +;;;; different variable, which is why this needs a fixture and not a refusal. + +(defconst limit 5) +(defvar sink i32) + +;;; The expression case: the body's [limit] is the let's, not the constant. +(defn shadowed [] i32 + (let [limit 7] + limit)) + +;;; The place case, which is a separate line in the renamer: [set] takes a +;;; place, and a place that is a bare name has its own shadowing check. +(defn assigned [] i32 + (let [sink 0] + (set sink 20) + sink)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index af19c20..4d044b6 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -660,6 +660,16 @@ let () = raylib itself. Loading it twice would declare every binding twice. *) outputs "a package reached along two routes" "programs/pkg-shared.flan" "ok\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 From 3ace7c262fdda0d8046ac843d6eead241880f779 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 10:49:07 +0700 Subject: [PATCH 4/8] A hang is a failure the suite never reported MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The mutation pass turned up one defect that did not make the suite go red: a reader branch that forgets to advance reads the same character for ever, and dune test waits as long as it is left to. In CI that is a job killed by the runner with nothing named and no output to read. watchdog.ml puts an alarm on every test binary — generous, because an alarm that fires on a slow machine is a flake — and a five-second one around each read in test_flan, where the budget really is small. The first read that does not return wedges the rest, so a looping reader costs five seconds and names the row instead of costing eight minutes or never finishing. Both were watched: the string-escape loop now fails in five seconds with the case named, and the per-binary backstop was armed short and observed to fire. --- test/dune | 6 ++-- test/test_acceptance.ml | 4 +++ test/test_agent.ml | 4 +++ test/test_cider.ml | 3 ++ test/test_dev.ml | 4 +++ test/test_emacs.ml | 3 ++ test/test_flan.ml | 69 ++++++++++++++++++++++++++++++++++------- test/test_reload.ml | 4 +++ test/test_repl.ml | 4 +++ test/test_sanitize.ml | 4 +++ test/test_session.ml | 4 +++ test/watchdog.ml | 62 ++++++++++++++++++++++++++++++++++++ 12 files changed, 158 insertions(+), 13 deletions(-) create mode 100644 test/watchdog.ml diff --git a/test/dune b/test/dune index 4efb846..ac37170 100644 --- a/test/dune +++ b/test/dune @@ -2,8 +2,10 @@ (names test_flan test_acceptance test_reload test_agent test_session test_dev test_emacs test_repl test_cider) ; Explicit because test_sanitize lives in this directory and is not one of ; these: two stanzas in one directory have to say which modules are whose. + ; watchdog is every binary's clock: a hanging test reports nothing, so each + ; of these arms an alarm that turns "for ever" into a failing run. (modules test_flan test_acceptance test_reload test_agent test_session - test_dev test_emacs test_repl test_cider) + test_dev test_emacs test_repl test_cider watchdog) (libraries flan unix) ; The acceptance programs are part of the test corpus: if the reader, the ; parser or the checker regresses on them we want to know here, not at the CLI. @@ -44,7 +46,7 @@ ; is the whole point here. (executable (name test_sanitize) - (modules test_sanitize) + (modules test_sanitize watchdog) (libraries flan unix)) (rule diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 4d044b6..6228b62 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -6,6 +6,10 @@ 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 () diff --git a/test/test_agent.ml b/test/test_agent.ml index 557c33b..e2dbb61 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -14,6 +14,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_agent" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_cider.ml b/test/test_cider.ml index 7fc6ad5..d573061 100644 --- a/test/test_cider.ml +++ b/test/test_cider.ml @@ -12,6 +12,9 @@ Skipped, not failed, where there is no emacs: the compiler does not depend on one. *) +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_cider" let () = if Sys.command "command -v emacs > /dev/null 2>&1" <> 0 then print_endline "cider: skipped (no emacs on PATH)" diff --git a/test/test_dev.ml b/test/test_dev.ml index 50ce32f..4140ae3 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -8,6 +8,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:900 "test_dev" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_emacs.ml b/test/test_emacs.ml index 4bafa59..b2ffdc0 100644 --- a/test/test_emacs.ml +++ b/test/test_emacs.ml @@ -9,6 +9,9 @@ Skipped, not failed, where there is no emacs — the compiler does not depend on one. *) +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_emacs" let scratch = Filename.get_temp_dir_name () let tmp n = Filename.concat scratch ("flan-emacs-" ^ n) diff --git a/test/test_flan.ml b/test/test_flan.ml index 9768a6e..dbb57fe 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -3,6 +3,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_flan" + let failures = ref 0 let check name cond = @@ -16,8 +20,34 @@ let contains hay needle = let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in n = 0 || go 0 +(* Every read in this table runs under a five-second alarm. The reader is the + one part of the compiler whose mistakes loop rather than raise — a branch + that forgets to advance reads the same character for ever — and a hanging + case reports nothing at all. Five seconds is thousands of times what any + row here needs; what it buys is that a loop becomes a named failing row and + the rest of the table still runs. *) +(* Once one read has not returned, the reader is looping and every row after + it would spend the same five seconds proving the same thing — a hundred + rows is eight minutes of that. So the first timeout wedges the rest: they + fail immediately and the binary still reports, which is the whole point of + the alarm. *) +let wedged = ref false + +let guarded seconds f = + if !wedged then raise Watchdog.Timeout + else + match Watchdog.within seconds f with + | x -> x + | exception Watchdog.Timeout -> wedged := true; raise Watchdog.Timeout + +let read ?(file = "") src = + guarded 5 (fun () -> Reader.read_all ~file src) + +(* The corpus files, which are larger and are read from disk. *) +let read_file path = guarded 30 (fun () -> Reader.read_file path) + let reads name src expected = - match Reader.read_all ~file:"" src with + match read src with | forms -> let got = String.concat " " (List.map Form.to_string forms) in if got <> expected then begin @@ -29,13 +59,20 @@ let reads name src expected = incr failures; Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n" name src (Loc.to_string loc) msg + | exception Watchdog.Timeout -> + incr failures; + Printf.printf "FAIL %s\n src: %s\n the reader did not return\n" + name src (* [needle] is the point: a read error that fires for the wrong reason is not the test passing. Without it "backtick at end of input" would be green even if the backtick were still an ordinary symbol character. *) let rejects ?needle name src = - match Reader.read_all ~file:"" src with + match read src with | _ -> incr failures; Printf.printf "FAIL %s: expected a read error\n" name + | exception Watchdog.Timeout -> + incr failures; + Printf.printf "FAIL %s: the reader did not return\n" name | exception Loc.Error (_, msg) -> (match needle with | Some n when not (contains msg n) -> @@ -140,7 +177,7 @@ let () = `(i ~j ~@k) `(l `(m ~n)) [`o ~p] {:q `r} (f a~b x`y)" in check "no sigils leak into names" - (bad_names (Form.make (Form.List (Reader.read_all ~file:"" corpus)) + (bad_names (Form.make (Form.List (read corpus)) Loc.unknown) = []); (* ── Errors ────────────────────────────────────────────────────── *) @@ -158,7 +195,7 @@ let () = above rejects the unknown one and not escaping itself. Asserted on the string's bytes rather than through [Form.to_string], which escapes them again and would compare the source with itself. *) - (match Reader.read_all ~file:"" "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with + (match read "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with | [ { Form.v = Form.Str s; _ } ] -> check "known escapes" (s = "a\nb\tc\\d\"e\000f") | _ -> check "known escapes: one string" false); @@ -171,14 +208,14 @@ let () = rejects "quasiquote unclosed" "`(a b" ~needle:"unclosed"; (* ── Locations ─────────────────────────────────────────────────── *) - (match Reader.read_all ~file:"f.flan" "(a)\n (b)" with + (match read ~file:"f.flan" "(a)\n (b)" with | [ a; b ] -> check "loc line 1" (a.loc.line = 1 && a.loc.col = 1); check "loc line 2" (b.loc.line = 2 && b.loc.col = 3); check "loc file" (a.loc.file = "f.flan") | _ -> check "loc: two forms" false); - (match Reader.read_all ~file:"f.flan" "(f\n bad" with + (match read ~file:"f.flan" "(f\n bad" with | _ -> check "unclosed reports opening loc" false | exception Loc.Error (loc, _) -> check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1)); @@ -192,12 +229,12 @@ let () = (* ═══ Parse: forms → AST ═══════════════════════════════════════════ *) let parse1 src = - match Reader.read_all ~file:"" src with + match read src with | [ f ] -> Parse.expr f | _ -> failwith "test source must be exactly one form" let parse_decl src = - match Reader.read_all ~file:"" src with + match read src with | [ f ] -> Parse.decl f | _ -> failwith "test source must be exactly one form" @@ -205,7 +242,7 @@ let parse_decl src = name with the reason, so a test that only proves *something* failed does not observe the rule it is there for. *) let parse_rejects ?needle name src = - match Reader.read_all ~file:"" src |> Parse.program with + match read src |> Parse.program with | _ -> incr failures; Printf.printf "FAIL %s: expected a parse error\n" name | exception Loc.Error (_, msg) -> (match needle with @@ -360,7 +397,7 @@ let () = (* ── The corpus parses ─────────────────────────────────────────── *) List.iter (fun path -> - match Reader.read_file path |> Parse.program with + match read_file path |> Parse.program with | _ -> () | exception Loc.Error (loc, msg) -> incr failures; @@ -382,7 +419,9 @@ let () = capitalisation — otherwise a body starting with a constructor call gets silently eaten as a return type. *) -let program src = Reader.read_all ~file:"" src |> Parse.program +(* Through [read], so the parser and checker tables are under the reader's + alarm too: their sources go through the same reader. *) +let program src = read src |> Parse.program let () = let open Ast in @@ -440,6 +479,10 @@ let infers name src expected = incr failures; Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n" name src (Loc.to_string loc) msg + | exception Watchdog.Timeout -> + incr failures; + Printf.printf "FAIL %s\n src: %s\n the reader did not return\n" + name src let accepts name src = match checked src with @@ -448,6 +491,10 @@ let accepts name src = incr failures; Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n" name src (Loc.to_string loc) msg + | exception Watchdog.Timeout -> + incr failures; + Printf.printf "FAIL %s\n src: %s\n the reader did not return\n" + name src (* [needle] pins the *reason* down: a rejection for the wrong reason is not a passing test, and the unimplemented-feature errors are the whole point. *) diff --git a/test/test_reload.ml b/test/test_reload.ml index 804aa5f..b94eccd 100644 --- a/test/test_reload.ml +++ b/test/test_reload.ml @@ -21,6 +21,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_reload" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_repl.ml b/test/test_repl.ml index 64aa096..b8c889f 100644 --- a/test/test_repl.ml +++ b/test/test_repl.ml @@ -16,6 +16,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_repl" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_sanitize.ml b/test/test_sanitize.ml index cf384ab..dc3e52b 100644 --- a/test/test_sanitize.ml +++ b/test/test_sanitize.ml @@ -31,6 +31,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:3600 "test_sanitize" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/test_session.ml b/test/test_session.ml index 3c14ede..8221b20 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -9,6 +9,10 @@ open Flan +(* The watchdog first: a hang is the one failure mode that reports + nothing at all. See watchdog.ml. *) +let () = Watchdog.arm ~seconds:600 "test_session" + let failures = ref 0 let fail fmt = Printf.ksprintf (fun s -> incr failures; print_endline ("FAIL " ^ s)) fmt diff --git a/test/watchdog.ml b/test/watchdog.ml new file mode 100644 index 0000000..99c9040 --- /dev/null +++ b/test/watchdog.ml @@ -0,0 +1,62 @@ +(* 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 + +let dying _ = + 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 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 From aa0b799bb603898b1b8b787c48c438e1193d3d73 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 10:51:14 +0700 Subject: [PATCH 5/8] Retyping a global across a reload, which nothing had ever done MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit flan_dev_global hands back the allocation it made the first time a name was asked for, and compares the size it recorded against the size it is asked for. Nothing exercised the comparison: v5 is v4 with extra as an i32, loaded on top of v3, and what it does is abort the process — so it gets a host run of its own. The message is asserted alongside the exit status, because a process that died for some other reason is not this guard firing and the status alone cannot tell them apart. --- test/programs/reload-v5.flan | 29 +++++++++++++++++++++++++++++ test/test_reload.ml | 32 +++++++++++++++++++++++++++++++- 2 files changed, 60 insertions(+), 1 deletion(-) create mode 100644 test/programs/reload-v5.flan diff --git a/test/programs/reload-v5.flan b/test/programs/reload-v5.flan new file mode 100644 index 0000000..b114017 --- /dev/null +++ b/test/programs/reload-v5.flan @@ -0,0 +1,29 @@ +;;;; v5 is v4 with one difference: [extra] is an i32 rather than an i64. +;;;; +;;;; [extra] does not exist in the host — v3 introduced it at run time, so its +;;;; storage was allocated by runtime/flan_dev.c the first time a module asked +;;;; for it, and every later module that mentions the name is handed back that +;;;; same allocation. Handing it back for a differently shaped type is layout +;;;; drift: the new body would read and write at offsets the old allocation was +;;;; never laid out for, and nothing downstream could ever say so. The registry +;;;; compares the size it recorded against the size it is asked for and aborts +;;;; instead — retyping a var needs a restart, and this is the file that says +;;;; the guard is real. +;;;; +;;;; Loaded on top of v3, and never alongside v4: the process it aborts is the +;;;; whole of the test. +(defvar counter i64) +(defvar extra i32) + +(defn helper [x i64] i64 (* x 2)) + +(defn added [] i32 + (set extra (+ extra 100)) + extra) + +(defn bump [] i64 + (println "v5") + (set counter (+ counter (i64 (added)))) + (helper counter)) + +(defn outer [] i64 (bump)) diff --git a/test/test_reload.ml b/test/test_reload.ml index b94eccd..d4d66e5 100644 --- a/test/test_reload.ml +++ b/test/test_reload.ml @@ -82,6 +82,10 @@ let () = not exist. This is the C-c C-k unit. *) let so3, ir3, _, _ = module_of p3 [ "bump"; "added" ] "v3.so" in let so4, ir4, _, _ = module_of p4 [ "added" ] "v4.so" in + (* v5 retypes [extra], which v3 introduced at run time. It is built here + and loaded in a process of its own below: what it does is abort. *) + let p5 = checked "programs/reload-v5.flan" in + let so5, _, _, _ = module_of p5 [ "added" ] "v5.so" in (* A redefinition module must not define what the host already owns: defining [counter] would give the loaded object a private copy and the @@ -196,6 +200,32 @@ let () = if code <> 0 || text <> want then fail "reload\n got: %S (exit %d)\n wanted: %S" text code want; + (* The layout-drift guard, which needs a process of its own because what it + does is abort one. [extra] does not exist in the host: v3 introduced it + at run time, so flan_dev.c allocated its storage and recorded its size, + and every later module asking for that name is handed the same + allocation back. v5 asks for it as an i32. Handing back eight bytes for + a four-byte type is not an error anything downstream can detect — the + new body simply reads fields at offsets the allocation was never laid + out for — so the registry compares sizes and dies at the first chance + it has. + + Asserted on the message as well as on the exit status: a process that + died for some other reason is not this guard firing, and the exit code + alone cannot tell the two apart. *) + let out5 = tmp "out5" and err5 = tmp "err5" in + let code5 = + Sys.command + (Printf.sprintf "%s %s %s %s > %s 2> %s" (Filename.quote host) + (Filename.quote so1) (Filename.quote so3) (Filename.quote so5) + (Filename.quote out5) (Filename.quote err5)) + in + let said = In_channel.with_open_bin err5 In_channel.input_all in + if code5 = 0 then + fail "a global retyped across a reload was accepted (exit 0)"; + if not (has said "size changed") then + fail "a retyped global did not stop on the size guard: %S" said; + Printf.printf "reload: emit %.1fms llc %.1fms ld %.1fms (v2: emit %.1fms llc %.1fms ld %.1fms) host run %.1fms\n" emit_ms t1.Build.llc_ms t1.Build.link_ms emit2_ms t2.Build.llc_ms @@ -203,7 +233,7 @@ let () = print_string timings; List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) - [ host; so1; so2; so3; so4; out; tmp "err" ]; + [ host; so1; so2; so3; so4; so5; out; out5; err5; tmp "err" ]; if !failures = 0 then print_endline "reload: all tests passed" else begin Printf.printf "\n%d failure(s)\n" !failures; From 9b80fc20843c83054b4787c12f94eed004c82a3f Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 10:54:11 +0700 Subject: [PATCH 6/8] The 4K result cap and the registry's 4096 names, run for the first time MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Neither limit had any coverage: a renderer that emits more than 4K and a program that introduces more than 4096 run-time names are both past anything the corpus does, so the truncation and the abort were code that had never executed. dev_limits.c drives them directly — they are C entry points with no Flan spelling, and flan_dev.c is compiled into every build — one process per mode, because the name table never shrinks and the overflow case aborts. The cap case pins the length, the ellipsis, a byte from before the cut, the generation moving exactly once, and the flag being cleared so a short value after a truncated one does not inherit its ellipsis. The registry case pins that 4096 fit and the next one stops the process with its reason. Dropping result_full and moving the slot check by one were both planted and watched fail. --- test/dev_limits.c | 107 ++++++++++++++++++++++++++++++++++++++++++++ test/dune | 3 ++ test/test_reload.ml | 48 +++++++++++++++++++- 3 files changed, 157 insertions(+), 1 deletion(-) create mode 100644 test/dev_limits.c diff --git a/test/dev_limits.c b/test/dev_limits.c new file mode 100644 index 0000000..d4e444d --- /dev/null +++ b/test/dev_limits.c @@ -0,0 +1,107 @@ +/* dev_limits.c — the two fixed-size limits in runtime/flan_dev.c, driven + * directly. + * + * Neither is reachable from a Flan program that behaves. The result buffer + * only truncates when a renderer emits more than 4K, which no fixture does, + * and the name table only fills after 4096 distinct run-time-introduced names, + * which is more forms than the whole corpus has. So both were code nothing had + * ever run: the first thing either would do in anger is either lose the end of + * a value or scribble past the end of a static array, and the ellipsis and the + * abort are the two behaviours that say which. + * + * A C main, for the same reason reload_host.c is one: these are C entry points + * with no Flan spelling, and flan_dev.c is compiled into every build (see + * build.ml), so linking any Flan program brings them along. The .flan this is + * linked against therefore has no [main] of its own. + * + * One mode per run, chosen by argv, because both of them are one-way: the + * name table never shrinks and the overflow case aborts the process. + */ + +#include +#include +#include +#include + +void **flan_dev_cell(const char *name); +void flan_dev_result_begin(void); +void flan_dev_emit(const uint8_t *bytes, int64_t len); +void flan_dev_result_end(void); +const char *flan_dev_result_get(uint64_t *gen, uint64_t *len); +void flan_rt_init(int32_t argc, char **argv); + +#define CAP 4096 + +/* Emit more than fits, twice the buffer's worth, and report what came back. + * What is printed is everything a wrong cap gets wrong: the length, the three + * characters that say it was truncated, a byte from the middle to show the + * content up to the cut is the content that was emitted, and the generation + * counter, which is what a reader waits on and must move exactly once. */ +static int cap(void) { + static uint8_t a[3000], b[3000]; + uint64_t gen0, gen1, len; + const char *r; + + memset(a, 'a', sizeof a); + memset(b, 'b', sizeof b); + + r = flan_dev_result_get(&gen0, &len); + + flan_dev_result_begin(); + flan_dev_emit(a, (int64_t)sizeof a); + /* A negative length is not a huge one: the cast to size_t would make it + * about 2^64 and the clamp would then be the only thing between it and a + * memcpy of everything. */ + flan_dev_emit(b, -1); + flan_dev_emit(b, (int64_t)sizeof b); + flan_dev_result_end(); + + r = flan_dev_result_get(&gen1, &len); + printf("len %llu\n", (unsigned long long)len); + printf("tail %.3s\n", len >= 3 ? r + len - 3 : ""); + printf("mid %c\n", len > 3500 ? r[3500] : '?'); + printf("head %c\n", len > 0 ? r[0] : '?'); + printf("gen %llu\n", (unsigned long long)(gen1 - gen0)); + + /* And a short value after a truncated one: the flag has to be cleared by + * [begin] or every later render ends in an ellipsis it did not earn. */ + flan_dev_result_begin(); + flan_dev_emit((const uint8_t *)"12", 2); + flan_dev_result_end(); + r = flan_dev_result_get(&gen1, &len); + printf("again %.*s\n", (int)len, r); + return 0; +} + +/* Fill the name table and then ask for one more. The table is fixed and never + * moves — a module holds the address of a cell for as long as it is loaded — + * so the only honest answer past the end is to stop. */ +static int names(void) { + char buf[32]; + for (int i = 0; i < CAP; i++) { + snprintf(buf, sizeof buf, "n%d", i); + if (flan_dev_cell(buf) == NULL) { + printf("null cell at %d\n", i); + return 1; + } + } + /* Distinct names, all of them: a table that deduplicated wrongly would not + * be full here and the line below would not abort. */ + printf("interned %d\n", CAP); + fflush(stdout); + (void)flan_dev_cell("one-too-many"); + printf("survived\n"); + return 0; +} + +int main(int argc, char **argv) { + flan_rt_init(argc, argv); + if (argc < 2) { + fprintf(stderr, "usage: %s cap|names\n", argv[0]); + return 2; + } + if (strcmp(argv[1], "cap") == 0) return cap(); + if (strcmp(argv[1], "names") == 0) return names(); + fprintf(stderr, "unknown mode %s\n", argv[1]); + return 2; +} diff --git a/test/dune b/test/dune index ac37170..ba76fc1 100644 --- a/test/dune +++ b/test/dune @@ -27,6 +27,9 @@ (glob_files programs/*.flan) ; The reload primitive's host: a C main that dlopens what Build.shared made. (file reload_host.c) + ; The other C main: flan_dev.c's two fixed limits, which no Flan program + ; reaches, driven directly. + (file dev_limits.c) ; test_dev runs the compiler itself: flan dev launches and owns a program. (file %{workspace_root}/bin/main.exe) ; The Emacs client, which test_emacs drives against a real daemon. diff --git a/test/test_reload.ml b/test/test_reload.ml index d4d66e5..e686a18 100644 --- a/test/test_reload.ml +++ b/test/test_reload.ml @@ -226,6 +226,52 @@ let () = if not (has said "size changed") then fail "a retyped global did not stop on the size guard: %S" said; + (* The two fixed-size limits in flan_dev.c, which nothing had ever + reached: the 4K result buffer a renderer emits into, and the 4096-name + registry. Both are driven from dev_limits.c rather than from Flan, + because neither has a Flan spelling and a program that reached either + one by accident would be a program nobody wants in the corpus. + + One process per mode. The name table never shrinks, so the two cases + would contaminate each other, and the overflow case ends in abort. *) + let limits = tmp "limits" in + ignore + (Build.executable ~opts:dev ~csrcs:[ "dev_limits.c" ] p1 ~out:limits); + let mode m = + let o = tmp ("limits-" ^ m ^ ".out") and e = tmp ("limits-" ^ m ^ ".err") in + let code = + Sys.command + (Printf.sprintf "%s %s > %s 2> %s" (Filename.quote limits) m + (Filename.quote o) (Filename.quote e)) + in + let out = In_channel.with_open_bin o In_channel.input_all in + let err = In_channel.with_open_bin e In_channel.input_all in + List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) [ o; e ]; + (code, out, err) + in + (* 6000 bytes emitted into 4096. The length is the cap itself, the three + dots are what says the value was cut rather than being that short, the + middle byte says the content before the cut is the content that was + emitted, and the generation moved exactly once — a reader waits on that + counter and a value published twice would be read half-formed. The last + line is the flag being cleared: a short value after a truncated one must + not inherit its ellipsis. *) + let code, out, _ = mode "cap" in + let want_cap = "len 4096\ntail ...\nmid b\nhead a\ngen 1\nagain 12\n" in + if code <> 0 || out <> want_cap then + fail "the 4K result cap\n got: %S (exit %d)\n wanted: %S" + out code want_cap; + (* 4096 distinct names fit; the next one stops the process. The table is + fixed and never moves, because a loaded module holds the address of a + cell in it, so growing is not available and overrunning is the only + other thing it could do. *) + let code, out, err = mode "names" in + if code = 0 then fail "the registry accepted a 4097th name (exit 0)"; + if out <> "interned 4096\n" then + fail "the registry did not take 4096 names first: %S" out; + if not (has err "out of dev name slots") then + fail "the registry overflowed without saying so: %S" err; + Printf.printf "reload: emit %.1fms llc %.1fms ld %.1fms (v2: emit %.1fms llc %.1fms ld %.1fms) host run %.1fms\n" emit_ms t1.Build.llc_ms t1.Build.link_ms emit2_ms t2.Build.llc_ms @@ -233,7 +279,7 @@ let () = print_string timings; List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) - [ host; so1; so2; so3; so4; so5; out; out5; err5; tmp "err" ]; + [ host; limits; so1; so2; so3; so4; so5; out; out5; err5; tmp "err" ]; if !failures = 0 then print_endline "reload: all tests passed" else begin Printf.printf "\n%d failure(s)\n" !failures; From 6f67b7114f6f4061ac7e640709e748c691ef7c54 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 10:54:53 +0700 Subject: [PATCH 7/8] The blind spots the mutation pass named are covered Says what closed each one and how, and that two of the four named buffers now have evidence rather than a reading. The count of nineteen stands as the old one: the mutation pass has not been re-run. --- NEXT.md | 51 ++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 36 insertions(+), 15 deletions(-) diff --git a/NEXT.md b/NEXT.md index 4f2b851..5726d50 100644 --- a/NEXT.md +++ b/NEXT.md @@ -82,11 +82,13 @@ it *would* have written. which is a compiler feature of the same shape the bounds checks already have, or they belong to the checker. Not decided. `test_sanitize` pins the current answer with a control that must *not* report, so a future clang changing this is a test failure rather than a discovery. -2. **Four named buffers got no evidence at all.** The 4K result cap, the dev registry overflow guard, - `SNAP_MAX`/`SNAP_NAMES` and `condition_name[128]` are on the daemon and agent paths, which need a socket and are not - in the corpus. Their guards were read and are correct; that is reading, not testing. `escaped[ESCAPE_MAX]` is the one - that *is* covered, because `println.flan` drives a 1100-character string through it on purpose — 1019 bytes out - against a worst case of 1021 into 1024. `scratch[SCRATCH]` never sees more than 20 characters of 64. +2. **Two of four named buffers still have no evidence.** `SNAP_MAX`/`SNAP_NAMES` and `condition_name[128]` are on the + daemon and agent paths, which need a socket and are not in the corpus; their guards were read and are correct, and + that is reading, not testing. The other two — the 4K result cap and the dev registry overflow guard — are now run + for real by `test/dev_limits.c`, a C main beside `reload_host.c`, one process per limit because the name table + never shrinks and the overflow case aborts. `escaped[ESCAPE_MAX]` was already covered, because `println.flan` + drives a 1100-character string through it on purpose — 1019 bytes out against a worst case of 1021 into 1024. + `scratch[SCRATCH]` never sees more than 20 characters of 64. 3. **Valgrind over the headless corpus, not done.** ASan does not see uninitialised reads, which is where `zeroed` and struct padding live. MSan is out: it needs every dependency instrumented and raylib settles that. @@ -407,17 +409,36 @@ plan.org's single line on it (831) names a `for` the language does not have and ### Test blind spots, from a mutation pass -Sixty mutations, nineteen left the whole suite green. The severe cluster is closed (`cleanup.flan`, -`signedness.flan`); these are not: +Sixty mutations, nineteen left the whole suite green. The severe cluster was closed first (`cleanup.flan`, +`signedness.flan`); the rest are closed now. Every one below was re-planted, watched leave the suite green, and then +watched fail against the new test before the mutation was reverted — a test nobody saw fail is not evidence. -- `Reach`'s walk of index expressions, `addr` places and `restart-case` clause bodies — each confirmed to prune a - function a valid program calls, so the build fails to link. -- `flan_dev_global`'s size-change guard — the layout-drift check, with no test that retypes a global across a reload. -- A local shadowing an imported name is qualified anyway. -- The 4K result cap and the registry overflow guard have **no coverage at all**, rather than a missing assertion. -- The reader accepts an unknown string escape; `+5` stops being a number. -- And a warning: a reader mutation makes the suite **hang** rather than fail. A green run is not the only outcome to - plan for in CI. +- **`Reach`'s walk of index expressions, `addr` places and `restart-case` clause bodies.** `programs/reach-walk.flan` + calls three functions from three places that are each the only route to them. The failure is not a wrong answer: + the function is not emitted and the program stops linking, so the case catches the build exception rather than + comparing output. The `addr` case goes through a `deref` place deliberately, so the index case cannot stand in for + it. +- **`flan_dev_global`'s size-change guard.** `programs/reload-v5.flan` is v4 with `extra` as an `i32`, loaded on top + of v3 in a host run of its own, because what it does is abort. The message is asserted next to the exit status: a + process that died for another reason is not this guard firing. +- **A local shadowing an imported name.** `programs/shadow-pkg.flan` binds locals over its own constant and var; + `pkg-shadow.flan` prints four numbers that separate the expression renamer from the place renamer. Nothing refuses + a renamer that qualifies through a binding — it reads the top-level name instead and runs — so only the number says + so. +- **The 4K result cap and the registry overflow guard.** `test/dev_limits.c`, a second C main beside `reload_host.c`, + drives them directly: neither has a Flan spelling and no corpus program reaches either. One process per mode — the + name table never shrinks and the overflow case aborts. +- **The reader's unknown string escape, and `+5`.** Rows in the reader table, with the escapes it *does* know + asserted on their decoded bytes rather than through `Form.to_string`, which escapes them again and would compare + the source with itself. +- **The hang.** A reader branch that forgets to advance loops for ever, and `dune test` waits as long as it is left + to; in CI that is a job the runner kills with nothing named. `test/watchdog.ml` arms an alarm on every test binary + — generous, because an alarm that fires on a slow machine is a flake and a flake is how a watchdog gets deleted — + and a five-second one around every read in `test_flan`. The first read that does not return wedges the rest, so a + looping reader costs five seconds and names the row instead of never finishing. + +What is still open here: the mutation pass has not been re-run since, so the count of nineteen is the old one. The +sanitized sweep (`@sanitize`) is under the same watchdog but has never been observed to fire it. ### Asked for by the editor lanes From 199ab02a2b67762c5e5866426b32338b2abdd43d Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 12 Sep 2026 10:57:50 +0700 Subject: [PATCH 8/8] Say why the watchdog exits the ordinary way MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It calls exit and not _exit, and the reason is the opposite of what the comment said: the rows that did pass are still in stdout's buffer, and a watchdog that threw them away would tell you less than the hang did. Also observed firing from test_dev, which is blocked on a daemon rather than spinning — the case the reader hang does not cover. --- test/watchdog.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/watchdog.ml b/test/watchdog.ml index 99c9040..dbc10b8 100644 --- a/test/watchdog.ml +++ b/test/watchdog.ml @@ -39,6 +39,8 @@ let dying _ = \ 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