JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A function that cannot return without calling itself gets a warning, and a dev eval shows warnings for the forms it sent in Emacs.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 19:28:28 +07:00
commit fd63b56a96
8 changed files with 483 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
emacs/flan.el
View File

@ -1847,6 +1847,62 @@ Returns non-nil when it put an overlay somewhere."
(goto-char beg))
t)))))))
;;; Warnings
;; A warning is drawn the way an error is — a mark at the site, the message
;; beside it, gone at the next command — and logged the same way, in the
;; compiler's own `file:line:col: warning: text' shape, which is what gives it
;; `compilation-minor-mode''s warning face in the log. The marks carry
;; `flan-error' as well, so every path that takes an error mark down takes
;; these with it.
(defface flan-warning-face
'((t :inherit warning :underline (:style wave)))
"Face for the text a compiler warning is about."
:group 'flan)
(defface flan-warning-message-face
'((t :inherit warning :height 0.9))
"Face for a warning's message, shown beside the form it is about."
:group 'flan)
(defun flan--warning-overlays (&optional buffer)
"The Flan warning overlays in BUFFER, or in the current buffer."
(with-current-buffer (or buffer (current-buffer))
(seq-filter (lambda (o) (overlay-get o 'flan-warning))
(overlays-in (point-min) (point-max)))))
(defun flan--show-warning (file line col msg)
"Mark MSG at LINE and COL of FILE, if some buffer is visiting it."
(let ((buf (flan--buffer-visiting file)))
(when buf
(with-current-buffer buf
(let* ((beg (flan--position line col))
(end (save-excursion (goto-char beg) (line-end-position)))
(ov (make-overlay beg end buf t nil)))
(overlay-put ov 'flan-error t)
(overlay-put ov 'flan-warning t)
(overlay-put ov 'face 'flan-warning-face)
(overlay-put ov 'help-echo msg)
(overlay-put ov 'priority 90)
(overlay-put ov 'after-string
(propertize (concat " " msg)
'face 'flan-warning-message-face))
(add-hook 'pre-command-hook #'flan--clear-errors-on-command nil t)
t)))))
(defun flan--report-warnings (warnings)
"Log and mark each of WARNINGS, a reply's `:warnings' list."
(dolist (w warnings)
(let ((file (plist-get w :file))
(line (plist-get w :line))
(col (plist-get w :col))
(msg (plist-get w :message)))
(ignore-errors
(flan--record-diagnostic (format "%s:%d:%d" file line col)
(concat "warning: " msg)))
(ignore-errors (flan--show-warning file line col msg)))))
;;; Inline results
;; The value of an expression, drawn after the form it came from, the way eros
@ -2599,7 +2655,8 @@ has nothing to sit beside."
(names (plist-get reply :names))
(note (plist-get reply :note))
(value (plist-get reply :value))
(stale (plist-get reply :stale)))
(stale (plist-get reply :stale))
(warnings (plist-get reply :warnings)))
;; Accepted, so whatever the last rejection marked is no longer true.
;; Redundant now that any command clears it — the command that ran this
;; evaluation already did — and kept because it is the claim being
@ -2623,6 +2680,7 @@ has nothing to sit beside."
;; written first is wiped by whatever the drawing does to the buffer.
(when value (ignore-errors (flan--show-result value at)))
(when stale (ignore-errors (flan--report-stale stale)))
(when warnings (ignore-errors (flan--report-warnings warnings)))
(when flan-echo-result
(cond
;; An expression's value, rendered inside the running program —
@ -2646,9 +2704,13 @@ has nothing to sit beside."
;; is then empty by construction rather than a repeat of it. Now
;; that `C-x C-e' reaches this path too, that sentence is also how
;; you tell an installed declaration from an expression's `=>'.
(message "flan: %s installed in %.0f ms%s%s"
(message "flan: %s installed in %.0f ms%s%s%s"
(flan--names-phrase (or fns names) what)
(or (plist-get reply :ms) 0)
(if warnings
(format ", %d warning%s" (length warnings)
(if (= (length warnings) 1) "" "s"))
"")
(let ((vars (and fns (seq-difference names fns))))
(if vars (format " (also %s)"
(flan--names-phrase vars ""))

24
emacs/test-flan.el
View File

@ -899,6 +899,30 @@ already rely on it — so nothing here is a stand-in for the real thing."
(goto-char (point-max))
(delete-region beg (point-max)))
;; A form the compiler warns about installs, and the warning is shown as an
;; error is — marked at its site — and counted in the echo line.
(goto-char (point-max))
(let ((beg (point)))
(insert "\n(defn spin-forever [n i64] i64\n (println n)\n (spin-forever n))")
(search-backward "(println")
(let ((said (test-flan--said (flan-eval-defun))))
(test-flan--check "a warned-about form says so in the echo line"
(and said
(string-match-p "installed in [0-9]+ ms, 1 warning\\'"
said))))
(test-flan--check "and the warning is marked at the call it is about"
(let ((ovs (flan--warning-overlays)))
(and (= 1 (length ovs))
(string-match-p
"cannot return without first calling itself"
(or (overlay-get (car ovs) 'help-echo) ""))
(save-excursion
(goto-char (overlay-start (car ovs)))
(looking-at-p "(spin-forever n)")))))
(flan-clear-errors)
(goto-char (point-max))
(delete-region beg (point-max)))
;; A declaration can be written where it is prose and not a declaration, and
;; the depth at its open delimiter says nothing about that: a form at column
;; 1 inside a comment or a string is at depth 0 like any other, so the head

189
lib/check.ml
View File

@ -20806,6 +20806,35 @@ let prelude_alias = "prelude~"
the dev program re-creating the session its launcher built and warned for. *)
let print_warnings = ref true
(* Where a dev eval's own forms are, so its warnings are said for those and
not again, on every later eval, for everything the session holds. [None]
is a build or a check, which says everything. *)
let warn_within : Loc.t list option ref = ref None
(* The warnings [say_warnings] kept since [build_program] began, in order:
what a dev eval hands the editor in its reply as well as printing. *)
let said_warnings : Loc.diag list ref = ref []
let say_warnings (ds : Loc.diag list) =
let within (at : Loc.t) =
match !warn_within with
| None -> true
| Some spans ->
List.exists
(fun (s : Loc.t) ->
String.equal s.Loc.file at.Loc.file
&& s.Loc.line <= at.Loc.line && at.Loc.line <= max s.Loc.line s.Loc.eline)
spans
in
let ds = List.filter (fun (d : Loc.diag) -> within d.Loc.dloc) ds in
said_warnings := !said_warnings @ ds;
if !print_warnings then
List.iter
(fun (d : Loc.diag) ->
prerr_endline
(Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg))
ds
(* A name the renaming above made, which nobody wrote: left out of every
listing a person reads, and shown as whose it is where a frame has to be. *)
let internal_name n = String.starts_with ~prefix:(prelude_alias ^ "/") n
@ -20862,9 +20891,146 @@ let shadow_prelude (prelude : Ast.decl list) (decls : Ast.decl list) =
in
(prelude @ decls, warnings)
(* ── A function that calls itself on every path (decision 142) ─────────
Rust's [unconditional_recursion], and like it only the obvious case, with
no false positives: from entry, every path reaches a direct call of the
same name at the same arity before anything can leave. So a branch (an
[if], [match], [if-let], [?.], [??]; [when] and [and]/[or] are [If] by
now), a loop body, a handler, a restart and a closure each end the search
rather than being looked into, and anything that may leave — [return],
[some]/[try], a signal, a restart, [break]/[continue] out of the fn, or a
call to a function whose type is [Never] — ends it before the call. A name
the body binds itself (a parameter, a [let]) is not the function, so a
body binding it is not looked at at all. Read over the AST after [collect],
where the parameters are paired, a fn's arities are renamed apart and
[infer_returns] has settled every callee's return type. *)
let recursion_warnings : Loc.diag list ref = ref []
let unconditional_recursion env (decls : Ast.decl list) : Loc.diag list =
let children (e : Ast.expr) =
let acc = ref [] in
ignore (Ast.map_children (fun c -> acc := c :: !acc; c) e);
!acc
in
let rec binds n (e : Ast.expr) =
let pat (a : Ast.arm) =
match a.Ast.pat with Ast.Pctor (_, ns) -> List.mem n ns | _ -> false
in
(match e.Ast.e with
| Ast.Let (bs, _) -> List.exists (fun (b : Ast.binding) -> b.Ast.bname = n) bs
| Ast.Loop (bs, _) -> List.mem_assoc n bs
| Ast.Fn (ps, _) -> List.mem n ps
| Ast.Dotimes (_, v, _, _) | Ast.Chain (v, _, _) -> v = n
| Ast.Match (_, arms) -> List.exists pat arms
| Ast.IfLet (_, a, _) -> pat a
| Ast.HandlerBind (cs, _) | Ast.HandlerCase (_, cs) ->
List.exists (fun (c : Ast.hclause) -> c.Ast.hname = n) cs
| Ast.RestartCase (_, cs) ->
List.exists
(fun (c : Ast.rclause) ->
List.exists (fun (p : Ast.field) -> p.Ast.fname = n) c.Ast.rparams)
cs
| _ -> false)
|| List.exists (binds n) (children e)
in
let never n nargs =
let ret n =
match Hashtbl.find_opt env.fns n with
| Some (_, r) -> Some r
| None ->
Option.map (fun (_, _, r) -> r) (Hashtbl.find_opt env.gsigs n)
in
let r =
match Hashtbl.find_opt env.versions n with
| Some vs -> Option.bind (List.assoc_opt nargs vs) ret
| None -> ret n
in
r = Some Types.Never
|| ((n = "exit" || n = builtin_prefix ^ "exit") && r = None)
in
(* Whether [e] may leave the function, or reach a [break]/[continue] of a
loop outside it. [loops] counts the loops of [e] itself around the node. *)
let rec leaves loops (e : Ast.expr) =
match e.Ast.e with
| Ast.Fn _ | Ast.Defer _ -> false
| Ast.Return _ | Ast.Unwrap _ | Ast.Signal _ | Ast.InvokeRestart _
| Ast.Recur _ -> true
| Ast.Break l | Ast.Continue l -> loops = 0 || l <> None
| Ast.Call ({ Ast.e = Ast.Var n; _ }, args) when never n (List.length args) ->
true
| Ast.While _ | Ast.Loop _ | Ast.Dotimes _ ->
List.exists (leaves (loops + 1)) (children e)
| _ -> List.exists (leaves loops) (children e)
in
let check_fn (d : Ast.decl) (fn : Ast.fn) =
let name, arity =
match version_of fn.Ast.name with
| Some (b, k) when Hashtbl.mem env.versions b -> (b, k)
| _ -> (fn.Ast.name, List.length fn.Ast.params)
in
(* The self-call every path reaches first, if there is one. *)
let rec reaches (e : Ast.expr) =
match e.Ast.e with
| Ast.Call ({ Ast.e = Ast.Var n; _ }, args)
when n = name && List.length args = arity ->
(match seq args with
| Some _ as c -> c
| None -> if List.exists (leaves 0) args then None else Some e.Ast.loc)
(* [??] evaluates its fallbacks only when what comes before is empty,
so only its first operand is certain to run. Every other builtin
evaluates all of its arguments. *)
| Ast.Call ({ Ast.e = Ast.Var "??"; _ }, a :: _) -> seq [ a ]
| Ast.Call (f, args) -> seq (f :: args)
| Ast.Return (Some x) -> seq [ x ]
| Ast.Do es -> seq es
| Ast.Let (bs, es) -> seq (List.map (fun (b : Ast.binding) -> b.Ast.bval) bs @ es)
| Ast.If (c, _, _) | Ast.Match (c, _) | Ast.IfLet (c, _, _)
| Ast.Chain (_, c, _) -> seq [ c ]
| Ast.Field (x, _) | Ast.The (_, x) | Ast.Unwrap (_, x) | Ast.Signal (_, x)
| Ast.Narrow (_, x) | Ast.Alias (_, x) -> seq [ x ]
| Ast.Set (Ast.Pvar _, v) -> seq [ v ]
| Ast.Struct (_, fs) | Ast.Bare fs -> seq (List.map snd fs)
| Ast.Arr es -> seq es
| _ -> None
and seq = function
| [] -> None
(* A loop that may never end: what follows it may never run. *)
| { Ast.e = Ast.While (_, { Ast.e = Ast.Var "true"; _ }, _) | Ast.Loop _; _ } :: _ ->
None
| e :: rest ->
(match reaches e with
| Some _ as c -> c
| None -> if leaves 0 e then None else seq rest)
in
if String.equal d.Ast.dloc.Loc.file Prelude.file
|| List.exists (fun (p : Ast.field) -> p.Ast.fname = name) fn.Ast.params
|| List.exists (binds name) fn.Ast.fbody
then None
else
Option.map
(fun (at : Loc.t) ->
let fln = fln_source at in
Loc.diag ~kind:"check/unconditional-recursion" at
(Printf.sprintf
"%s cannot return without first calling itself on line %d, \
so it never returns. If that call was meant to come after %s, it is %s \
by mistake; otherwise %s needs a base case, a path that \
returns without calling itself"
name at.Loc.line
(if fln then "the function" else "the defn")
(if fln then "indented into the body" else "inside the defn's body")
name))
(seq fn.Ast.fbody)
in
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defn fn -> check_fn d fn | _ -> None)
decls
let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) :
Tast.program * env * string list =
let env = new_env () in
said_warnings := [];
Hashtbl.reset arm_failed;
(* ── A declaration left as it was compiled ───────────────────────────
A dev session installs a function whose signature changed, and a
@ -20924,12 +21090,7 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) :
reload, which is where a defn is most likely to be written. Printed in
the shape [Loc] gives an error, so a checker in an editor parses it the
same way. *)
if !print_warnings then
List.iter
(fun (d : Loc.diag) ->
prerr_endline
(Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg))
(shadowed_builtins decls @ prelude_warnings);
say_warnings (shadowed_builtins decls @ prelude_warnings);
(* Pass one, and it stops at the first thing it refuses. That is not
laziness: every name, type and signature in the file comes from here, so a
declaration this pass could not make sense of leaves a hole that pass two
@ -20943,15 +21104,12 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) :
if keep_going then env.deferred <- Some [];
grow_warnings := [];
let decls = collect env decls in
if !print_warnings then
List.iter
(fun (d : Loc.diag) ->
prerr_endline
(Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg))
(List.rev !pairing_warnings);
say_warnings (List.rev !pairing_warnings);
check_finite env;
check_union_members env;
infer_returns ~keep_going ?tolerate ?previous env decls;
recursion_warnings := unconditional_recursion env decls;
say_warnings !recursion_warnings;
(let late = !consts_after_infer in
consts_after_infer := [];
settle_consts env late);
@ -21012,12 +21170,7 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) :
| _ -> None)
decls
in
if !print_warnings then
List.iter
(fun (d : Loc.diag) ->
prerr_endline
(Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg))
(List.rev !grow_warnings);
say_warnings (List.rev !grow_warnings);
Loc.finish s;
(* The placeholder a [_] body is read against is never a type anything
downstream may see; a signature carrying it would be emitted as a

28
lib/dev.ml
View File

@ -1073,6 +1073,21 @@ let errors_field (ds : Loc.diag list) =
(Wire.quote d.Loc.dmsg))
ds) ]
(* The compiler's warnings about the forms an eval sent, which it also
printed: the editor marks each where it is, as it marks an error. *)
let warnings_field (ds : Loc.diag list) =
match ds with
| [] -> []
| ds ->
[ ":warnings "
^ Wire.list
(List.map
(fun (d : Loc.diag) ->
Printf.sprintf "(:file %s :line %d :col %d :kind %s :message %s)"
(Wire.quote d.Loc.dloc.Loc.file) d.Loc.dloc.Loc.line
d.Loc.dloc.Loc.col (Wire.quote d.Loc.kind) (Wire.quote d.Loc.dmsg))
ds) ]
(* A refusal with several diagnostics: the first where every refusal puts its
message, all of them under [:errors]. *)
let errors_reply (ds : Loc.diag list) =
@ -1118,7 +1133,7 @@ let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause =
^ Wire.quote
"loaded; the program has ended, so this is in it when M-x \
flan-rerun starts it again" ]
@ extra)
@ warnings_field c.Session.warnings @ extra)
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
Session.restore t.session before;
error ~loc:(Loc.to_string l) msg
@ -1136,7 +1151,7 @@ let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause =
ok
([ ":names " ^ Wire.strings c.Session.names; ":fns ()";
":note " ^ Wire.quote "nothing to install" ]
@ extra)
@ warnings_field c.Session.warnings @ extra)
| c ->
(* Everything from here to the delivery is inside the restore, and by
exception type as well as by arm. The three named below are the ones
@ -1184,6 +1199,7 @@ let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause =
Printf.sprintf ":ms %.1f"
(timing.Build.llc_ms +. timing.Build.link_ms) ]
@ stale_field c.Session.stale
@ warnings_field c.Session.warnings
@ (match pause with
| Some (l, c) ->
[ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ]
@ -1227,10 +1243,16 @@ let load_file t ~code ~origin =
is. *)
let base = if Sys.file_exists origin then Some origin else None in
let running = liveness t <> Parked in
(* A trial, which [Session.pruned] may run several times over the same
forms: only the [eval] of what survives says the warnings. *)
let check forms =
let before = Session.held t.session in
let was = !Check.print_warnings in
Check.print_warnings := false;
Fun.protect
~finally:(fun () -> Session.restore t.session before)
~finally:(fun () ->
Check.print_warnings := was;
Session.restore t.session before)
(fun () ->
ignore (Session.eval ~origin ?base ~forms ~running t.session code))
in

22
lib/session.ml
View File

@ -688,6 +688,8 @@ type change = {
change leaves behind, and the ones earlier changes left that this one
did not recompile. Empty for anything that builds no module. *)
stale : stale list;
(* The compiler's warnings about the forms sent, as it printed them. *)
warnings : Loc.diag list;
}
(* The bodies a change installed, as whoever reads the reply wrote them: a
@ -1095,6 +1097,7 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
(* Every error in the form sent, not the first: [keep_going] checks past a
refused subexpression (see [Check.check]). One error is still raised as
[Loc.Error], which is what every caller of one form expects. *)
let said = ref [] in
let program, env, tolerated =
(* A tolerated body whose return type is read off it keeps the
signature the process has for it. *)
@ -1105,11 +1108,17 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
else None)
t.program.Tast.fns
in
(* The whole session is checked again, and only the forms sent are warned
about: a warning said at the eval that wrote it is not said again at
every eval after. *)
let was = !Check.warn_within in
Check.warn_within := Some (List.map (fun (f : Form.t) -> f.Form.loc) forms);
match
Fun.protect ~finally:(fun () -> Check.warn_within := was) (fun () ->
Check.program_tolerant ~keep_going:true ~tolerate:stale_owner ~previous
decls
decls)
with
| r -> r
| r -> said := !Check.said_warnings; r
| exception Loc.Errors [ d ] -> raise (Loc.Error d)
in
let program =
@ -1562,7 +1571,8 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
fns <> [] || allocates || consts <> [] || run_thunk <> None;
stale =
stale_sites ~live ~running ~inferred:(Check.inferred_cause env) built
program }
program;
warnings = !said }
(* ── Evaluating an expression ──────────────────────────────────────── *)
@ -2272,7 +2282,7 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
Ok
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = []; warnings = [] },
where, Types.to_string shown.Tast.ty))))
(* ── A typed restart, taken from the break loop ──────────────────────── *)
@ -2401,7 +2411,7 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
Ok
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = []; warnings = [] },
List.map Types.to_string params)
(* [pause] is [C-u C-x C-e] — §9's "last expression" target. It is a flag and
@ -2620,7 +2630,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
{ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }
{ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = []; warnings = [] }
(* ── What a macro call expands to ──────────────────────────────────── *)

35
test/test_dev.ml
View File

@ -9581,6 +9581,41 @@ let () =
if not (contains_sub (value "(good)") "refused") then
fail "a form that called one left out was installed"
end;
(* A load checks its forms more than once to find the ones that do not
compile, and says each warning once: for a file that compiles whole
and for one with a form left out. The reply carries it too. *)
let times () =
let s = In_channel.with_open_bin mout In_channel.input_all in
let needle = "cannot return without first calling itself" in
let k = String.length needle and n = ref 0 in
for i = 0 to String.length s - k do
if String.sub s i k = needle then incr n
done;
!n
in
let warned what code =
let before = times () in
let r =
request mc
(Printf.sprintf "(:op \"load-file\" :file %S :code %s)"
("programs/dev-load-" ^ what ^ ".flan") (Wire.quote code))
in
let sent =
match Wire.field r "warnings" with
| Some { Form.v = Form.List l; _ } -> List.length l
| _ -> 0
in
if status r <> "ok" then fail "a load of %s: %s" what (said r)
else begin
if sent <> 1 then fail "a load of %s replied with %d warnings" what sent;
let after = times () in
if after - before <> 1 then
fail "a load of %s printed its warning %d times" what (after - before)
end
in
warned "spin" "(defn spin [n i64] i64 (println n) (spin n))";
warned "spin-bad"
"(defn spin2 [n i64] i64 (println n) (spin2 n))\n(defn bad2 [] i64 \"x\")";
(* Nothing compiles: a refusal, with the error where every refusal
puts it and the list beside it. *)
let r =

92
test/test_flan.ml
View File

@ -6647,6 +6647,98 @@ let () =
(grown "(defn f [v (Ptr (Vec i32))] ()\n\
\ (push (deref v) 1) (let [w (vec-new i32)] (push w 1) (free w)))"
= Some []);
(* A fn that calls itself on every path never returns, and is warned at
the call (decision 142). Only the obvious case: a branch, a loop body,
a closure or a handler between entry and the call, or anything that
may leave first, and there is no warning. *)
let recursion ?(fln = false) src =
let run () =
if fln then begin
let path = Test_support.tmp "recursion-" (string_of_int (Hashtbl.hash src) ^ ".fln") in
Out_channel.with_open_bin path (fun oc -> output_string oc src);
Fun.protect ~finally:(fun () -> Sys.remove path)
(fun () -> ignore (Front.checked path))
end
else ignore (checked src)
in
match run () with
| () ->
Some
(List.map
(fun (d : Loc.diag) -> (d.Loc.dloc.Loc.line, d.Loc.dmsg))
!Check.recursion_warnings)
| exception Loc.Error d -> Printf.printf " (%s)\n" d.Loc.dmsg; None
in
let warns name ?fln src line =
match recursion ?fln src with
| Some [ (l, _) ] when l = line -> ()
| Some ds ->
check (Printf.sprintf "%s (%d warnings)" name (List.length ds)) false
| None -> check (name ^ ": the program checks") false
in
let quiet name ?fln src =
match recursion ?fln src with
| Some [] -> ()
| Some ds ->
check (Printf.sprintf "%s (%d warnings)" name (List.length ds)) false
| None -> check (name ^ ": the program checks") false
in
(match
recursion ~fln:true
"fn count-handshakes(people)\n for p in range(people)\n println(p)\n \
count-handshakes(5)\n"
with
| Some [ (4, m) ] ->
check "a self-call after a loop, outside any branch, is warned at"
(m = "count-handshakes cannot return without first calling itself \
on line 4, so it never returns. If that call was meant to come after the \
function, it is indented into the body by mistake; otherwise \
count-handshakes needs a base case, a path that returns without \
calling itself")
| _ -> check "a self-call after a loop warns once, at line 4" false);
warns "a self-call in .flan is warned at"
"(defn f [n i64] i64\n (println n)\n (f n))" 3;
warns "a self-call inside an operand is warned at" ~fln:true
"fn fact(n: i64) -> i64\n n * fact(n - 1)\n" 2;
warns "a returned self-call is warned at" ~fln:true
"fn r(n: i64) -> i64\n return r(n)\n" 2;
warns "a self-call in a let's value is warned at" ~fln:true
"fn r(n: i64) -> i64\n let m = r(n)\n m\n" 2;
warns "a generic's self-call is warned at"
"(defn pick [x $t] $t\n (pick x))" 2;
warns "only the arity that calls itself is warned at" ~fln:true
"fn h\n (a: i64) -> i64\n h(a, 1)\n (a: i64, b: i64) -> i64\n \
h(a, b)\n" 5;
quiet "a self-call under if is not warned at" ~fln:true
"fn f(n: i64) -> i64\n if n > 0\n f(n - 1)\n else\n 0\n";
quiet "a self-call under when is not warned at" ~fln:true
"fn f(n: i64)\n when n > 0\n f(n - 1)\n";
quiet "a self-call in a loop body is not warned at" ~fln:true
"fn f(n: i32) -> ()\n for i in range(n)\n f(i)\n";
quiet "a self-call in a lambda is not warned at" ~fln:true
"fn f(n: i64)\n let k: Fn() -> () = fn() => f(n)\n k()\n";
quiet "a call to another arity is not warned at" ~fln:true
"fn h\n (a: i64) -> i64\n h(a, 1)\n (a: i64, b: i64) -> i64\n a + b\n";
quiet "mutual recursion is not warned at" ~fln:true
"fn ping(n: i64) -> i64\n pong(n)\n\nfn pong(n: i64) -> i64\n ping(n)\n";
quiet "tail recursion with a base case is not warned at" ~fln:true
"fn fact(n: i64, acc: i64) -> i64\n if n == 0\n return acc\n \
fact(n - 1, acc * n)\n";
quiet "a self-call after an early return under when is not warned at" ~fln:true
"fn g(n: i64) -> i64\n when n > 3\n return 1\n g(n + 1)\n";
quiet "a self-call behind ?? is not warned at" ~fln:true
"fn c(a: i64?, n: i64) -> i64\n a ?? c(a, n)\n";
(* A call that never comes back but is not typed Never leaves the
self-call dead, and the function still never returns, which is all the
warning claims. *)
warns "a self-call after a call that exits is warned at" ~fln:true
"fn boom() -> ()\n exit(1)\n\nfn f(n: i64) -> ()\n boom()\n f(n)\n" 6;
quiet "a self-call after exit is not warned at" ~fln:true
"fn q(n: i64)\n exit(1)\n q(n)\n";
quiet "a self-call after an endless loop is not warned at" ~fln:true
"fn s(n: i64)\n while true\n println(n)\n s(n)\n";
quiet "a parameter of the fn's name is not the fn"
"(defn same [same (Fn [i64] i64)] i64 (same 1))";
check "a program that shadows nothing is warned at not at all"
(Check.shadowed_builtins (program "(defn f [] i32 1)") = []);
(* A prelude function's name is taken over the same way, for the calls in

55
test/test_session.ml
View File

@ -2235,4 +2235,59 @@ let () =
if not (Array.exists (fun x -> x = Some "g") f.Tast.snames) then
fail "if o? as g has no slot named g");
(* A fn sent to the session that calls itself on every path is warned at
(decision 142) on the daemon's stderr, which is the daemon's buffer in
the editor — once, at the eval that sent it. Every eval checks the whole
session again, and a warning about a form sent earlier is not said
again; nor is a builtin-shadow warning. *)
(let t, _ = Session.create ~file:"programs/reload.flan" () in
let stderr_of f =
let path = Test_support.tmp "recursion-" "stderr.txt" in
let fd = Unix.openfile path [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let saved = Unix.dup Unix.stderr in
flush stderr;
Unix.dup2 fd Unix.stderr;
let r =
Fun.protect
~finally:(fun () ->
flush stderr; Unix.dup2 saved Unix.stderr; Unix.close saved; Unix.close fd)
(fun () -> Source.with_code ~syntax:Source.Indented ~at:None f)
in
let said = In_channel.with_open_bin path In_channel.input_all in
Sys.remove path;
(r, said)
in
let warnings said =
List.length
(List.filter (fun l -> has l ": warning: ") (String.split_on_char '\n' said))
in
let r, said =
stderr_of (fun () ->
Session.eval ~origin:"handshakes.fln" t
"fn count-handshakes(people)\n for p in range(people)\n \
println(p)\n count-handshakes(5)\n\nfn get(p: i64) -> i64\n p\n")
in
if not (List.mem "count-handshakes" r.Session.fns) then
fail "a fn that calls itself on every path was not installed";
(match !Check.recursion_warnings with
| [ d ] when d.Loc.kind = "check/unconditional-recursion" && d.Loc.dloc.Loc.line = 4 -> ()
| ds -> fail "a dev eval of count-handshakes found %d recursions" (List.length ds));
if not (has said "warning: count-handshakes cannot return without first calling itself on line 4")
then fail "a dev eval printed no recursion warning: %S" said;
(match r.Session.warnings with
| [ a; b ] when a.Loc.kind = "check/shadows-builtin"
&& b.Loc.kind = "check/unconditional-recursion" -> ()
| ds -> fail "the eval's change carries %d warnings, not the 2 it printed"
(List.length ds));
if warnings said <> 2 then
fail "the eval that sent them printed %d warnings, not 2: %S" (warnings said) said;
let r2, again =
stderr_of (fun () ->
Session.eval ~origin:"other.fln" t "fn other-thing(x: i64) -> i64\n x + 1\n")
in
if r2.Session.warnings <> [] then
fail "an unrelated eval's change carries an earlier form's warnings";
if warnings again <> 0 then
fail "an unrelated eval said an earlier form's warnings again: %S" again);
Test_support.report ~label:"session" ()