diff --git a/test/programs/dev-break-nullcall.flan b/test/programs/dev-break-nullcall.flan new file mode 100644 index 00000000..47de55f7 --- /dev/null +++ b/test/programs/dev-break-nullcall.flan @@ -0,0 +1,26 @@ +;;;; A program that stops on a call through a null CFn, for driving the break +;;;; loop over one. Nothing handles NullCall here, so the signal reaches the +;;;; break hook and the program parks, as a bad index does in +;;;; dev-break-bounds.flan; the program's own continue is the way on. +(import agent "vendor:agent") + +(defonce table [2 (CFn [i32] i32)]) +(defonce skipped i64) +(defonce ticks i64) + +(defn call-slot [i i32] i32 ((at table i) 5)) + +(defn frame [i i32] () + (restart-case + (do (println (call-slot i)) (println "frame done")) + (continue [] (set skipped (+ skipped 1))))) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-break-nullcall-fallback.sock") + ;; Slot 1 was never set, so it is null. + (frame 1) + (print skipped) (println "") + (dotimes [i 4000] + (agent/wait 5) + (set ticks (+ ticks 1))) + 0) diff --git a/test/test_dev.ml b/test/test_dev.ml index 7cf14617..4a81e008 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -2162,6 +2162,88 @@ let () = pointer: the bytes-view write that first crashed no longer compiles. *) trap_park ~refault:true "segfault" "dev-segv.flan" "SegFault" []; + (* ── A break over a call through a null CFn ───────────────────────── + + NullCall is a condition, signalled as a bad index is: nothing handles + it in dev-break-nullcall.flan, so the program parks with NullCall + named, the program's own continue on offer and takeable, and taking it + resumes — the transcript's 1 is continue's clause having run. On both + backends, since the null test before the call is emitted by each. *) + let null_park backend = + let nsock = tmp ("nullcall" ^ backend ^ ".sock") + and nout = tmp ("nullcall" ^ backend ^ ".out") in + (try Sys.remove nsock with Sys_error _ -> ()); + let nfd = + Unix.openfile nout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let npid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-break-nullcall.flan"; "-s"; nsock; backend |] + Unix.stdin nfd Unix.stderr + in + Unix.close nfd; + if not (listening ~pid:npid nsock) then begin + fail "the null-call daemon (%s) %s" backend !listen_why; + (try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let out = Buffer.create 64 in + let c = connect nsock in + let ask sexp = + let r = Wire.parse (Wire.send c sexp; Wire.recv c) in + (match Wire.string_field r "output" with + | Some t -> Buffer.add_string out t + | None -> ()); + r + in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let last = ref (Wire.parse "()") in + if not (await (fun () -> last := ask "(:op \"describe\")"; stopped !last)) + then fail "a null CFn call never stopped the program (%s)" backend + else begin + (match Wire.string_field !last "condition" with + | Some "NullCall" -> () + | c -> + fail "a null CFn call is reported as %S (%s)" + (Option.value ~default:"" c) backend); + let r = ask "(:op \"break\")" in + (match Wire.field r "restarts" with + | Some { Form.v = Form.List l; _ } + when List.exists + (fun (n : Form.t) -> n.Form.v = Form.Str "continue") l -> () + | _ -> fail "a null CFn call offers no continue (%s)" backend); + let r = ask "(:op \"restart\" :name \"continue\")" in + if status r <> "ok" then + fail "continuing past a null CFn call (%s): %s" backend + (Option.value ~default:"" (Wire.string_field r "message")); + if not + (await (fun () -> + ignore (ask "(:op \"describe\")"); + List.mem "1" + (String.split_on_char '\n' (Buffer.contents out)))) + then fail "the program never resumed past a null CFn call (%s)" backend + end; + ignore (ask "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] npid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ()) + end + end + in + null_park "--llvm"; + null_park "--x86"; + (* ── The locals of a stopped frame ─────────────────────────────── *) (* A third daemon, over a program that stops with something worth looking