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

emacs/flan.el

@@ -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 ""))

emacs/test-flan.el

@@ -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

lib/check.ml

@@ -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
+  say_warnings (shadowed_builtins decls @ prelude_warnings);
-  List.iter
-    (fun (d : Loc.diag) ->
-       prerr_endline
-         (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg))
-    (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
+  say_warnings (List.rev !pairing_warnings);
-    List.iter
-      (fun (d : Loc.diag) ->
-         prerr_endline
-           (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg))
-      (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
+  say_warnings (List.rev !grow_warnings);
-    List.iter
-      (fun (d : Loc.diag) ->
-         prerr_endline
-           (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg))
-      (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

lib/dev.ml

@@ -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

lib/session.ml

@@ -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
-      Check.program_tolerant ~keep_going:true ~tolerate:stale_owner ~previous
+      Fun.protect ~finally:(fun () -> Check.warn_within := was) (fun () ->
-        decls
+        Check.program_tolerant ~keep_going:true ~tolerate:stale_owner ~previous
+          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 ──────────────────────────────────── *)
 

test/test_dev.ml

@@ -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 =

test/test_flan.ml

@@ -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

test/test_session.ml

@@ -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" ()