From ff8b61e44ce8212e558e758c06418a4163e75d07 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 19:57:58 +0700 Subject: [PATCH] A self-containing or runaway generic struct and a where clause over a length are each one error among the file's others, and a literal that does not fit a variable a typed field decided names that field --- lib/check.ml | 102 +++++++++++++++++++++++++++++++++++++++++----- test/test_flan.ml | 41 +++++++++++++++++++ 2 files changed, 133 insertions(+), 10 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 25f7018e..670a5f8d 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -251,6 +251,15 @@ type env = { (* The struct copies this env made, by key, and whether each is one at variables — those are left out of the program. *) copies : (string, bool) Hashtbl.t; + (* Templates whose own check was refused while [deferred] was collecting: + a use of one is a copy with no fields, so the refusal is said once, at + the defstruct, and nothing downstream repeats it. *) + broken : (string, unit) Hashtbl.t; + (* While a whole-file check collects every error, the refusals [collect] + can go on past — a generic struct's template, a where clause over a + length — are kept here instead of ending the pass. [None] everywhere + else, where they raise as before. *) + mutable deferred : Loc.diag list option; (* A generic defn's length variables, by name: the ones of its [gsigs] variables that are lengths. *) glens : (string, string list) Hashtbl.t; @@ -329,6 +338,8 @@ let new_env () = { refused_generics = Hashtbl.create 4; gstructs = Hashtbl.create 4; copies = Hashtbl.create 8; + broken = Hashtbl.create 2; + deferred = None; glens = Hashtbl.create 8; lenvars = []; len_placeholder = false; @@ -343,6 +354,13 @@ let new_env () = { guard_next = false; } +(* A refusal [collect] can go on past: kept while a whole-file check is + collecting, in the order found, and raised otherwise. *) +let defer_or_raise env (d : Loc.diag) = + match env.deferred with + | Some l -> env.deferred <- Some (d :: l) + | None -> Loc.raise_diag d + (* Where a named type was declared, and what it has, as a note. This is the second half of the two-place messages: a refusal that says @@ -1599,9 +1617,14 @@ and struct_len_arg env name p (a : Ast.texpr) = (* The copy of generic struct [name] at [targs], made on first use and registered as an ordinary struct under its key. *) -and struct_copy env loc name targs = +and struct_copy ?(at_definition = false) env loc name targs = let key = struct_app name targs in if Hashtbl.mem env.copies key then key + else if Hashtbl.mem env.broken name then begin + Hashtbl.replace env.copies key (List.exists generic_arg targs); + Hashtbl.replace env.structs key { Tast.sname = key; fields = [] }; + key + end else begin if Hashtbl.mem env.structs key || Hashtbl.mem env.datas key || Hashtbl.mem env.unions key then @@ -1673,7 +1696,7 @@ and struct_copy env loc name targs = (* A field refused inside the template says nothing about which use asked for this copy; the note names it, one per level of copies. *) (match e with - | Loc.Error d when d.Loc.dloc <> loc -> + | Loc.Error d when d.Loc.dloc <> loc && not at_definition -> Loc.raise_diag { d with Loc.notes = @@ -6810,9 +6833,37 @@ and generic_ctor ctx ~want loc name given = them, as a generic call's literal arguments meet at the wider type — [(Pair 1 2.5)] is a [(Pair f64)]. *) let lit_only = ref [] in + (* Which field's value decided each variable, for the refusal of a + literal that does not fit what it decided. *) + let decided_by = ref [] in List.iter (fun ((f : Tast.field), (a : Ast.expr)) -> match f.Tast.fty with + (* A literal at a variable a typed field already decided: it has to + be usable at that type, and when it is not the refusal names the + field that decided it. *) + | Types.Var v + when literal a && List.mem_assoc v !subst + && not (List.mem v !lit_only) -> + let b = List.assoc v !subst in + (match a.Ast.e, b with + | Ast.Float x, Types.Int _ -> + let notes = + match List.assoc_opt v !decided_by with + | Some (fname, at) -> + [ Loc.note at + (Printf.sprintf ".%s is %s here, which decides $%s" fname + (Types.to_string b) v) ] + | None -> [] + in + Loc.failk "check/generic-struct-field" a.Ast.loc ~notes + "%s's .%s is $%s, which is %s here, and %g is a float literal. \ + Write .%s as an integer, or give .%s a float type" + name f.Tast.fname v (Types.to_string b) x f.Tast.fname + (match List.assoc_opt v !decided_by with + | Some (fname, _) -> fname + | None -> f.Tast.fname) + | _ -> ()) | Types.Var v when literal a && not (List.mem_assoc v !subst && not (List.mem v !lit_only)) -> let t = (literal_type a) in (match List.assoc_opt v !subst with @@ -6841,7 +6892,14 @@ and generic_ctor ctx ~want loc name given = nothing. *) | None -> Option.iter (fun d -> unsure := d :: !unsure) refusal | Some t -> - if not (bind_ty subst f.Tast.fty t) then + let before = !subst in + if bind_ty subst f.Tast.fty t then + List.iter + (fun (v, _) -> + if not (List.mem_assoc v before) then + decided_by := (v, (f.Tast.fname, a.Ast.loc)) :: !decided_by) + !subst + else fail a.Ast.loc "%s's .%s is %s here, and this is %s" (Types.to_string (Types.Named open_key)) f.Tast.fname (Types.to_string (subst_ty !subst f.Tast.fty)) @@ -13370,9 +13428,14 @@ let collect env (decls : Ast.decl list) = type in a field is refused at the defstruct rather than at the first use of it. *) let g = Hashtbl.find env.gstructs n in - ignore - (struct_copy env loc n - (List.map (fun (p, _) -> Types.Var p) g.gparams)) + (match + struct_copy ~at_definition:true env loc n + (List.map (fun (p, _) -> Types.Var p) g.gparams) + with + | _ -> () + | exception Loc.Error d -> + Hashtbl.replace env.broken n (); + defer_or_raise env d) | Ast.Defstruct (n, fs, parent) -> let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in if List.length (List.sort_uniq compare names) <> List.length names then @@ -13517,10 +13580,22 @@ let collect env (decls : Ast.decl list) = an open question in TODO.org, not an accident to fall out of this. *) if List.mem p.Ast.pvar lens then - Loc.failk "check/length-predicate" p.Ast.ploc - "$%s is a length, and a where clause takes type predicates \ - only — %s is about a type" p.Ast.pvar p.Ast.pname) + defer_or_raise env + (Loc.diag ~kind:"check/length-predicate" p.Ast.ploc + (Printf.sprintf + "$%s is a length, and a where clause takes type \ + predicates only — %s is about a type" + p.Ast.pvar p.Ast.pname))) fn.Ast.fwhere; + (* A predicate over a length was refused above; what is left is the + clause every copy is judged against. *) + let fn = + { fn with + Ast.fwhere = + List.filter + (fun (p : Ast.pred) -> not (List.mem p.Ast.pvar lens)) + fn.Ast.fwhere } + in env.tyvars <- vars; env.lenvars <- lens; env.tvpreds <- fn.Ast.fwhere; @@ -13623,7 +13698,10 @@ let collect env (decls : Ast.decl list) = out or a zero value is built for it — which would not fail, it would hang. *) let check_finite env = let walk _ n = finite_from env n in - Hashtbl.iter (fun n _ -> walk [] n) env.structs; + (* A generic struct's copy was asked this when it was made. *) + Hashtbl.iter + (fun n _ -> if not (Hashtbl.mem env.copies n) then walk [] n) + env.structs; Hashtbl.iter (fun n _ -> walk [] n) env.datas; Hashtbl.iter (fun n _ -> walk [] n) env.unions @@ -14978,10 +15056,14 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : time it runs every signature is sound, so a body that fails to check cannot make the next body fail — which is what makes a declaration a resync point that needs no resynchronising. *) + if keep_going then env.deferred <- Some []; let decls = collect env decls in check_finite env; check_union_members env; let s = Loc.sink ~on:keep_going in + (match env.deferred with + | Some ds -> s.Loc.found <- ds; env.deferred <- None + | None -> ()); ignore (Loc.caught s (fun () -> check_main env decls)); (* Every generic body, checked once with its variables left abstract, and the result thrown away. This is the pass plan.org's rule needs and Odin diff --git a/test/test_flan.ml b/test/test_flan.ml index ed62a56b..6aca6d1e 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6017,6 +6017,47 @@ let () = = [ "show is instantiated at $t = (CFn [] i32) here"; "outer is instantiated at $t = (CFn [] i32) here" ])); + (* A refusal made while collecting declarations — a generic struct that + holds itself, one that grows without end, a where clause over a length — + is one error among the rest of the file's, not the end of the check. *) + let all_lines src = + match Check.program_all (Parse.program_all (read src)) with + | _ -> [] + | exception Loc.Errors ds -> + List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds + in + check "a self-containing generic struct is one error of several" + (all_lines + "(defstruct Loop [next (Loop $t)])\n\ + (defn g [] i32 (let [p (the (Loop i32) (zeroed))] nope1))\n\ + (defn h [] i32 nope2)\n" + = [ 1; 2; 3 ]); + check "a generic struct that grows without end is one error of several" + (all_lines + "(defstruct Grow [next (Ptr (Grow [$t]))])\n\ + (defn g [] i32 (let [p (the (Grow i32) (zeroed))] nope1))\n\ + (defn h [] i32 nope2)\n" + = [ 1; 2; 3 ]); + check "a where clause over a length is one error of several" + (all_lines + "(defn f [a [$n i32]] i32 {:where (numeric? $n)} nope1)\n\ + (defn h [] i32 nope2)\n" + = [ 1; 1; 2 ]); + (* A literal that does not fit what a typed field decided names that field. *) + (match + checked + "(defstruct Pair [a $t b $t]) \ + (defn main [] i32 (let [p (Pair (the i32 1) 2.5)] 0))" + with + | _ -> check "a float literal where a typed field decided i32" false + | exception Loc.Error d -> + check "the refusal names the field that decided the variable" + (contains d.Loc.dmsg "Pair's .b is $t, which is i32 here" + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg ".a is i32 here, which decides $t") + d.Loc.notes)); + (* A copy that cannot be built at a closure's type: the zeroed value in the body is refused there, and the call that asked is named. *) (match