From 9d0d42e4676536119c4eb754fc0e1ba8de564421 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:59:11 +0700 Subject: [PATCH] A generic struct's copy prints as (Pair i32 {...}), crosses to C behind a pointer, names each use that made it when refused, settles literal fields at the wider type, and is laid out by stores and restarts that first name it --- lib/check.ml | 93 ++++++++++++++++++++--- lib/dev.ml | 12 ++- lib/parse.ml | 50 ++++++++++--- lib/render.ml | 2 +- lib/session.ml | 29 +++++--- lib/shim.ml | 118 ++++++++++++++++++++++++++++++ lib/types.ml | 9 +++ test/programs/generic-struct.flan | 3 +- test/test_acceptance.ml | 33 ++++++++- test/test_dev.ml | 22 ++++++ test/test_flan.ml | 41 ++++++++++- test/test_session.ml | 50 +++++++++++++ 12 files changed, 422 insertions(+), 40 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index c9c6a0df..8efdae6b 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -79,6 +79,16 @@ let rec slot_text = function | Sclass c -> c | Sopt s -> "(Option " ^ slot_text s ^ ")" +(* Where [sep] first occurs in [m]. *) +let find_sub m sep = + let n = String.length m and k = String.length sep in + let rec go i = + if i + k > n then None + else if String.sub m i k = sep then Some i + else go (i + 1) + in + go 0 + (* ── Generic structs ───────────────────────────────────────────────── [(defstruct Small [items [$n $t] count i32])] is a template, not a type. Its parameters are the sigil names its fields introduce, in the order @@ -1642,7 +1652,17 @@ and struct_copy env loc name targs = restore (); Hashtbl.remove env.copies key; Hashtbl.remove env.structs key; - raise e + (* 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.raise_diag + { d with + Loc.notes = + d.Loc.notes + @ [ Loc.note loc + (Types.to_string (Types.Named key) ^ " is made here") ] } + | e -> raise e) end (* Does a struct argument still mention a variable? *) @@ -1728,12 +1748,12 @@ and resolve_name env ~seen loc n = | [ v ] -> Loc.failk "check/unbound-type-variable" loc "nothing binds the type variable %s — this signature introduces %s, \ - so write %s here, or a concrete type" n v v + so write %s here, or a concrete type" n ("$" ^ v) ("$" ^ v) | vars -> Loc.failk "check/unbound-type-variable" loc "nothing binds the type variable %s — this signature introduces %s, \ so write one of those here, or a concrete type" - n (String.concat " and " vars)) + n (String.concat " and " (List.map (fun v -> "$" ^ v) vars))) else match Types.ikind_of_name n with | Some k -> Types.Int k @@ -1769,7 +1789,15 @@ and resolve_name env ~seen loc n = ~notes:[ Loc.note g.gloc (n ^ " is declared here") ] "%s is generic, and a type only once it is given its arguments: \ write (%s %s)" n n - (String.concat " " (List.map (fun (p, _) -> "$" ^ p) g.gparams)) + (* Variables are only an answer where a signature binds them; in + ordinary code the example is concrete. *) + (String.concat " " + (List.map + (fun (p, is_len) -> + if env.tyvars <> [] then "$" ^ p + else if is_len then "8" + else "i32") + g.gparams)) | _ when Hashtbl.mem env.structs n -> Types.Named n (* A data type is [Named] exactly as a struct is: one case in [Types.t] covers both, and which table the name is in is what tells them apart. @@ -4056,7 +4084,7 @@ let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = to that is still a refusal rather than a guessed pair. *) | Types.Var v -> Loc.failk "check/generic-map-key" loc - "a map keyed by the type variable %s has no hash and no equality here. \ + "a map keyed by the type variable $%s has no hash and no equality here. \ Write {:where (hashable? $%s)} at the head of the body, or write the \ operation in a function over the concrete key type and call that" v v | Types.String -> Tast.Rtfn "flan_hash_str", Tast.Rtfn "flan_eq_str" @@ -6611,12 +6639,37 @@ and generic_ctor ctx ~want loc name given = | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true | _ -> false in + (* A literal's own type, the one it has with nothing expected of it. *) + let literal_type (a : Ast.expr) = + match a.Ast.e with + | Ast.Float _ -> Types.Float Types.F64 + | Ast.UInt _ -> Types.Int Types.U64 + | Ast.Byte _ -> Types.Int Types.U8 + | _ -> Types.Int Types.I32 + in let pairs = List.filter (fun (_, a) -> not (literal a)) pairs @ List.filter (fun (_, a) -> literal a) pairs in + (* Variables only literals have bound so far: a later literal may widen + 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 List.iter (fun ((f : Tast.field), (a : Ast.expr)) -> + match f.Tast.fty with + | 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 + | None -> subst := (v, t) :: !subst; lit_only := v :: !lit_only + | Some b -> + (match Types.join b t with + | Some j -> subst := (v, j) :: List.remove_assoc v !subst + | None -> + 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 b) (Types.to_string t))) + | _ -> if open_ty f.Tast.fty && not (literal a && subst_ty !subst f.Tast.fty |> open_ty |> not) then begin @@ -6657,7 +6710,13 @@ and generic_ctor ctx ~want loc name given = "%s's $%s is not decided by the fields given here. Name the \ type where the value goes, as in (the (%s %s) ...)" name p name - (String.concat " " (List.map (fun (q, _) -> "$" ^ q) g.gparams))) + (String.concat " " + (List.map + (fun (q, is_len) -> + if env.tyvars <> [] then "$" ^ q + else if is_len then "8" + else "i32") + g.gparams))) g.gparams in struct_copy env loc name targs) @@ -11946,7 +12005,7 @@ and generic_call ctx ~want loc name vars pats pret args = | Some (Types.Var v) when not (declares ctx.env.tvpreds v p.Ast.pname) -> Loc.failk "check/predicate-not-carried" loc "%s is written {:where (%s $%s)}, and this call passes the \ - type variable %s, which nothing here declares %s. Add \ + type variable $%s, which nothing here declares %s. Add \ {:where (%s $%s)} to this function's own clause" name p.Ast.pname p.Ast.pvar v p.Ast.pname p.Ast.pname v | Some t when not (open_ty t) && not (pred_holds p.Ast.pname t) -> @@ -12064,17 +12123,29 @@ and instantiate env loc gname vars subst cparams cret = asked for the copy, and the prelude's line comes along as a note. *) | Loc.Error d when in_prelude d.Loc.dloc && not (in_prelude loc) -> + (* Only the reason comes along. The rest of the body's message is + a fix to the body, which the caller cannot make. *) + let reason = + let cut sep m = + match find_sub m sep with + | Some i -> String.sub m 0 i + | None -> m + in + cut ". " (cut " — " d.Loc.dmsg) + in Loc.Error (Loc.sort_notes { d with Loc.dloc = loc; dmsg = - Printf.sprintf "%s cannot be made at %s. In its body: %s" - gname (at ()) d.Loc.dmsg; + Printf.sprintf + "%s cannot be made at %s: its body in the prelude does \ + not compile at that type. Pass a value of a type it \ + takes, or write the operation here" + gname (at ()); notes = d.Loc.notes - @ [ Loc.note d.Loc.dloc - "the refusal is here, in the prelude" ]; + @ [ Loc.note d.Loc.dloc ("in the prelude, " ^ reason) ]; expansion = None }) | Loc.Error d when d.Loc.dloc <> loc -> Loc.Error diff --git a/lib/dev.ml b/lib/dev.ml index f4982178..c5649835 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1920,13 +1920,19 @@ let defs t = text about the type and never touches the program. *) let layout t ~ty = let structs = t.session.Session.program.Tast.structs in + (* A generic struct's copy answers to the spelling a printed value's head + gives it, [Pair i32], and to its type's, [(Pair i32)], as well as to its + key. *) + let names (s : Tast.structure) = + [ s.Tast.sname; Types.struct_head s.Tast.sname; + Types.to_string (Types.Named s.Tast.sname) ] + in match - List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname ty) - structs + List.find_opt (fun (s : Tast.structure) -> List.mem ty (names s)) structs with | Some s -> ok - [ ":type " ^ Wire.quote s.Tast.sname; + [ ":type " ^ Wire.quote (Types.to_string (Types.Named s.Tast.sname)); ":fields " ^ Wire.list (List.map diff --git a/lib/parse.ml b/lib/parse.ml index 6263645a..e8e84523 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -73,6 +73,16 @@ let no_pattern (f : Form.t) = (* ── Type expressions ──────────────────────────────────────────────── *) +(* A type constructor's spelling: its last segment starts with a capital. *) +let capitalised_name name = + let base = + match String.rindex_opt name '/' with + | Some i -> String.sub name (i + 1) (String.length name - i - 1) + | None -> name + in + base <> "" && Char.uppercase_ascii base.[0] = base.[0] + && Char.lowercase_ascii base.[0] <> base.[0] + let rec texpr (f : Form.t) : Ast.texpr = let mk t = { Ast.t; tloc = f.loc } in match f.v with @@ -135,23 +145,41 @@ let rec texpr (f : Form.t) : Ast.texpr = | [ { v = Vec params; _ }; ret ] -> mk (Ast.Tfn (env, List.map texpr params, texpr ret)) | _ -> fail f "a function type is (%s [T ...] R)" which) - | List ({ v = Sym name; _ } :: args) when args <> [] -> + | List ({ v = Sym name; _ } :: args) + when args <> [] || capitalised_name name -> (* An integer argument is a generic struct's length, and a type constructor is capitalised. A lowercase head is a body form in the return slot — (+ x 1) — and its integer is the type parser's reason to give up, which is the refusal that slot is built on. *) - let capitalised = - let base = - match String.rindex_opt name '/' with - | Some i -> String.sub name (i + 1) (String.length name - i - 1) - | None -> name - in - base <> "" && Char.uppercase_ascii base.[0] = base.[0] - && Char.lowercase_ascii base.[0] <> base.[0] + let capitalised = capitalised_name name in + (* Integer arithmetic over literals is a length too — [(Small (+ 4 4) + i32)] — folded here, since nothing later reads it as a value. *) + let rec fold (a : Form.t) = + match a.v with + | Int n -> Some n + | List ({ v = Sym (("+" | "-" | "*") as op); _ } :: (_ :: _ as xs)) -> + let vs = List.map fold xs in + if List.for_all Option.is_some vs then + let vs = List.map Option.get vs in + match op, vs with + | "-", [ x ] -> Some (Int64.neg x) + | "+", v :: rest -> Some (List.fold_left Int64.add v rest) + | "-", v :: rest -> Some (List.fold_left Int64.sub v rest) + | "*", v :: rest -> Some (List.fold_left Int64.mul v rest) + | _ -> None + else None + | _ -> None in let arg (a : Form.t) = - match a.v with - | Int n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc } + match a.v, fold a with + | _, Some n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc } + | List _, None when capitalised -> + (try texpr a with + | Loc.Error _ -> + fail a + "%s is not a type or a length. An argument here is a type, or a \ + length: an integer, a constant's name or a length variable" + (Form.to_string a)) | _ -> texpr a in mk (Ast.Tapp (name, List.map arg args)) diff --git a/lib/render.ml b/lib/render.ml index c5cf9f6d..1f16802c 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -333,7 +333,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis @ render c (depth + 1) v) shown) in - [ do_ ((lit ("(" ^ n ^ " {") :: parts) + [ do_ ((lit ("(" ^ Types.struct_head n ^ " {") :: parts) @ (if List.length fields > max_span then [ lit " ..." ] else []) @ [ lit "})" ]) ]) (* A fixed array's length is in its type, so it unrolls — capped, because diff --git a/lib/session.ml b/lib/session.ml index ac732970..fff0f656 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1543,7 +1543,7 @@ let render_locals ?(origin = "") t ~frame ~(fn : Tast.fn) ~bound let loc = fn.Tast.floc in let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -1655,7 +1655,7 @@ let render_condition t ~(st : Tast.structure) : change * (string * string) list let loc = Loc.unknown in let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -1916,7 +1916,7 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path | Some name -> let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2233,7 +2233,7 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path in let extra = ref [] and nslots = ref (Array.length base) in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = @@ -2270,11 +2270,15 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path Array.append bnames (Array.make (List.length !extra) None) } in + (* A struct copy the values named first, laid out in this + module and kept, as [eval_expr] keeps one. *) + let copies = Check.fresh_copies t.env t.program.Tast.structs in let program = { t.program with Tast.fns = t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ]; + structs = t.program.Tast.structs @ copies; externs = t.program.Tast.externs @ externs } in let ir = @@ -2287,7 +2291,9 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path [eval_expr] says why, and the caller takes the same [held] around this that it takes around one. *) t.program <- - { t.program with Tast.fns = t.program.Tast.fns @ fresh }; + { t.program with + Tast.fns = t.program.Tast.fns @ fresh; + structs = t.program.Tast.structs @ copies }; Ok ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, where, Types.to_string shown.Tast.ty)))) @@ -2359,7 +2365,7 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) in let extra = ref [] and nslots = ref (Array.length base) in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2400,17 +2406,22 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) slots = Array.append base (Array.of_list (List.rev !extra)); snames = Array.append bnames (Array.make (List.length !extra) None) } in + let copies = Check.fresh_copies t.env t.program.Tast.structs in let program = { t.program with Tast.fns = t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ]; + structs = t.program.Tast.structs @ copies; externs = t.program.Tast.externs @ externs } in let ir = redefinition t ~call:tname program ~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ]) in - t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh }; + t.program <- + { t.program with + Tast.fns = t.program.Tast.fns @ fresh; + structs = t.program.Tast.structs @ copies }; Ok ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.map Types.to_string params) @@ -2443,7 +2454,7 @@ let render_globals ?(origin = "") t ~(globals : Tast.global list) let loc = Loc.unknown in let extra = ref [] and nslots = ref 0 in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; @@ -2564,7 +2575,7 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = appended past [base] and collected here to size the frame below. *) let extra = ref [] and nslots = ref (Array.length base) in let c = - { Render.structs = t.program.Tast.structs; + { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs; datas = t.program.Tast.datas; unions = t.program.Tast.unions; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; diff --git a/lib/shim.ml b/lib/shim.ml index bbcdd7be..10475b19 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -177,6 +177,106 @@ let prim_cty = function | "bool" -> Some "bool" | _ -> None +(* ── Generic structs ────────────────────────────────────────────────── + A defstruct whose fields introduce [$t] is a template, and C only ever sees + one of its copies: the fields with the arguments written in, laid out the + way [Check] lays the same copy out. The copy is registered here under its + written spelling, [(G u8)], which [ctype_name] turns into a C name. *) + +let sigil n = n <> "" && n.[0] = '$' +let bare n = if sigil n then String.sub n 1 (String.length n - 1) else n + +(* A template's parameters, in the order its fields first introduce them, and + whether each is a length — [Check]'s reading, repeated over the AST + because this runs before [Check] does. *) +let rec template_params ?(fuel = 16) env n = + match Hashtbl.find_opt env.structs n with + | None -> [] + | Some fs -> + let acc = ref [] in + let add m is_len = + if sigil m && not (List.mem_assoc (bare m) !acc) then + acc := (bare m, is_len) :: !acc + in + let rec walk (t : Ast.texpr) = + match t.Ast.t with + | Ast.Tname m -> add m false + | Ast.Tslice (_, e) -> walk e + | Ast.Tarray (Ast.Lname m, e) -> add m true; walk e + | Ast.Tarray (_, e) -> walk e + | Ast.Tmap (k, v) -> walk k; walk v + | Ast.Tapp (h, args) -> + let kinds = + if fuel = 0 || String.equal h n then [] + else List.map snd (template_params ~fuel:(fuel - 1) env h) + in + if List.length kinds = List.length args then + List.iter2 + (fun is_len (a : Ast.texpr) -> + match a.Ast.t with + | Ast.Tname m when is_len -> add m true + | _ -> walk a) + kinds args + else List.iter walk args + | Ast.Tfn (_, ps, r) -> List.iter walk ps; walk r + | Ast.Tlen _ -> () + in + List.iter (fun (f : Ast.field) -> walk f.Ast.fty) fs; + List.rev !acc + +let rec source (t : Ast.texpr) = + match t.Ast.t with + | Ast.Tname n -> n + | Ast.Tlen n -> Int64.to_string n + | Ast.Tapp (n, args) -> + Printf.sprintf "(%s %s)" n (String.concat " " (List.map source args)) + | Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (source e) + | Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (source e) + | Ast.Tarray (Ast.Lname n, e) -> Printf.sprintf "[%s %s]" n (source e) + | Ast.Tmap (k, v) -> Printf.sprintf "(Map %s %s)" (source k) (source v) + | Ast.Tfn (env, ps, r) -> + Printf.sprintf "(%s [%s] %s)" (if env then "Fn" else "CFn") + (String.concat " " (List.map source ps)) (source r) + +(* The copy of template [n] at [args], registered and named. *) +let copy env ~loc n (args : Ast.texpr list) = + let ps = template_params env n in + if List.length ps <> List.length args then + fail loc "%s takes %d argument%s, and this gives %d" n (List.length ps) + (if List.length ps = 1 then "" else "s") (List.length args); + let key = source { Ast.t = Ast.Tapp (n, args); tloc = loc } in + if not (Hashtbl.mem env.structs key) then begin + let sub = List.combine (List.map fst ps) args in + let rec go (t : Ast.texpr) = + let k = + match t.Ast.t with + | Ast.Tname m when List.mem_assoc (bare m) sub -> + (List.assoc (bare m) sub).Ast.t + | Ast.Tname _ | Ast.Tlen _ -> t.Ast.t + | Ast.Tslice (c, e) -> Ast.Tslice (c, go e) + | Ast.Tarray (Ast.Lname m, e) when List.mem_assoc (bare m) sub -> + let l = + match (List.assoc (bare m) sub).Ast.t with + | Ast.Tlen k -> Ast.Lint k + | Ast.Tname c -> Ast.Lname c + | _ -> fail loc "%s's $%s is a length" n (bare m) + in + Ast.Tarray (l, go e) + | Ast.Tarray (l, e) -> Ast.Tarray (l, go e) + | Ast.Tmap (k, v) -> Ast.Tmap (go k, go v) + | Ast.Tapp (h, a) -> Ast.Tapp (h, List.map go a) + | Ast.Tfn (b, ps, r) -> Ast.Tfn (b, List.map go ps, go r) + in + { t with Ast.t = k } + in + Hashtbl.replace env.structs key + (List.map (fun (f : Ast.field) -> { f with Ast.fty = go f.Ast.fty }) + (Hashtbl.find env.structs n)) + end; + key + +let is_template env n = template_params env n <> [] + (* [needed] collects the structs whose typedefs this signature pulls in, in the order they were first met. Order is the program's and never a hash fold's: the object cache keys on the generated text, so a reordering would be a @@ -184,6 +284,14 @@ let prim_cty = function let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = let t = unalias env t in match t.Ast.t with + | Ast.Tname n when Hashtbl.mem env.structs n && is_template env n -> + fail loc "%s is %s, a generic struct, which is a type only at its \ + arguments — write them, as in (%s %s)" what n n + (String.concat " " + (List.map (fun (_, l) -> if l then "8" else "i32") + (template_params env n))) + | Ast.Tapp (n, args) when Hashtbl.mem env.structs n && is_template env n -> + cty env ~needed ~loc ~what { t with Ast.t = Ast.Tname (copy env ~loc n args) } | Ast.Tname n -> (match prim_cty n with | Some c -> c @@ -269,6 +377,14 @@ let classify env ~needed ~loc ~what (t : Ast.texpr) = let t' = unalias env t in match t'.Ast.t with | Ast.Tname "string" -> (Pstr, "const char *") + (* A copy crosses behind a pointer only: by value, the Flan half this + generator writes would have to spell the copy's type, and it builds its + wrapper from struct names. *) + | Ast.Tapp (n, _) when Hashtbl.mem env.structs n && is_template env n -> + fail loc + "%s is %s, a generic struct's copy, which crosses to C behind a pointer \ + only — declare (Ptr %s) and let the C side read it" + what (source t') (source t') | Ast.Tname n when Hashtbl.mem env.structs n -> ignore (cty env ~needed ~loc ~what t'); (Pstruct n, ctype_name n) @@ -546,6 +662,8 @@ let typedefs env needed = (fun (f : Ast.field) -> match (unalias env f.Ast.fty).Ast.t with | Ast.Tname m when Hashtbl.mem env.structs m -> define m + | Ast.Tapp (m, args) when Hashtbl.mem env.structs m && is_template env m -> + define (copy env ~loc:f.Ast.floc m args) | _ -> ()) fs; Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n; diff --git a/lib/types.ml b/lib/types.ml index 328909f9..a6f25857 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -229,6 +229,15 @@ let rec equal a b = and then only in how a message spells it. *) let display : (string, string) Hashtbl.t = Hashtbl.create 16 +(* A struct's name as a printed value's head: its own name, or for a generic + struct's copy the template and its arguments, [Pair i32] — so a value + prints as [(Pair i32 {.a 1 .b 2})], the way its type is written. *) +let struct_head n = + match Hashtbl.find_opt display n with + | Some d when String.length d >= 2 && d.[0] = '(' -> + String.sub d 1 (String.length d - 2) + | _ -> n + let rec to_string = function | Int k -> ikind_name k | Float k -> fkind_name k diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan index f080c4e4..f295fbd8 100644 --- a/test/programs/generic-struct.flan +++ b/test/programs/generic-struct.flan @@ -83,7 +83,8 @@ (let [p (Pair 1 2) q (swapped p) r (swapped (Pair {.a 1.5 .b 2.5}))] - (println (.a q) (.b q) (.a r) (.b r))) + (println (.a q) (.b q) (.a r) (.b r)) + (println q (Pair 1 2.5))) (let [c (the (Node i64) {.v 3}) b (Node 2 (Some (addr c))) a (Node 1 (Some (addr b)))] diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 04ef62d0..005df81a 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3471,7 +3471,8 @@ let () = evaluated once: the walk reads an option's tag and then its payload, and each read used to make the call again. *) let generic_struct_out = - "60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n6\n\ + "60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n\ + (Pair i32 {.a 2 .b 1}) (Pair f64 {.a 1 .b 2.5})\n6\n\ 0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n" in outputs "generic structs" "programs/generic-struct.flan" generic_struct_out; @@ -4229,6 +4230,36 @@ level "1" end in let v2 = "(defstruct Vector2 [x f32 y f32])\n" in + + (* A generic struct's copy crosses behind a pointer, as a typedef of its + own with the arguments written in, and one held by value inside a + struct is defined before that struct. clang reads the text, so the + typedef is C and not only a spelling. *) + let gsrc = + "(defstruct G [x $t count i32])\n\ + (defstruct O [v i32 inner (G u8)])\n\ + (declare-c c-g [s (Ptr (G u8))] i32 \"c_g\")\n\ + (declare-c c-o [o (Ptr O)] i32 \"c_o\")\n" + in + shim_case "declare-c: a generic struct's copy crosses behind a pointer" gsrc + [ "/* (G u8) */\n uint8_t x;\n int32_t count;\n"; "inner;\n" ]; + (match shim_of gsrc with + | c -> + let file = Filename.temp_file "flan-shim-generic" ".c" in + let oc = open_out file in + output_string oc c; + close_out oc; + if Sys.command (Printf.sprintf "clang -fsyntax-only %s" (Filename.quote file)) <> 0 + then begin + incr failures; + print_endline "FAIL declare-c: a generic struct's copy is C clang accepts" + end; + Sys.remove file + | exception Loc.Error _ -> ()); + shim_refuses "declare-c: a generic struct's copy by value" + "(defstruct G [x $t])\n(declare-c c-v [s (G u8)] i32 \"c_v\")" + "crosses to C behind a pointer only"; + let img = "(defstruct Image [data (Ptr u8) width i32 height i32])\n" in diff --git a/test/test_dev.ml b/test/test_dev.ml index fa86db9c..926c1971 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -628,6 +628,28 @@ let () = | Some { Form.v = Form.Sym "t"; _ } -> () | _ -> fail "an expression against the park reported the program live"); + (* A generic struct's copy prints the way its type is written, with the + arguments after the template's name, and [layout] answers to that + spelling. *) + let r = + request c + "(:op \"eval\" :code \"(defstruct GPair [a $t b $t])\" :file \"/tmp/buf.flan\")" + in + if status r <> "ok" then + fail "a generic struct at the daemon: %s" + (Option.value ~default:(status r) (Wire.string_field r "message")); + let r = + request c + "(:op \"eval-expr\" :code \"(GPair 1 2)\" :file \"/tmp/buf.flan\")" + in + if Wire.string_field r "value" <> Some "(GPair i32 {.a 1 .b 2})" then + fail "a generic struct's copy printed as %s" + (Option.value ~default:(status r) (Wire.string_field r "value")); + let r = request c "(:op \"layout\" :type \"GPair i32\")" in + if Wire.string_field r "type" <> Some "(GPair i32)" then + fail "layout of a copy by its printed head: %s" + (Option.value ~default:(status r) (Wire.string_field r "message")); + (* And the half that needs the process rather than only the compiler. [extra] is a global this session introduced and the first run left at 105 — the third reload's [step] does not touch it — so this is the diff --git a/test/test_flan.ml b/test/test_flan.ml index 1ab6d401..ed62a56b 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -6044,6 +6044,7 @@ let () = check "a prelude copy's refusal is at the user's call" (d.Loc.dloc.Loc.file <> Prelude.file && contains d.Loc.dmsg "filter cannot be made at $t = (Vec u8)" + && not (contains d.Loc.dmsg "clone") && List.exists (fun (n : Loc.note) -> n.Loc.nloc.Loc.file = Prelude.file) d.Loc.notes)); @@ -6720,13 +6721,13 @@ let () = bound, because inside a signature that introduces one the mistake is nearly always the second spelling of the first. *) rejects_check "vec-new over a sigil that names no variable in scope" - ~needle:"this signature introduces t, so write t here" + ~needle:"this signature introduces $t, so write $t here" "(defn f [x $t] i32 (do x (let [v (vec-new $u)] (free v) 0)))"; rejects_check "and a cast over one tells the same story" - ~needle:"this signature introduces t, so write t here" + ~needle:"this signature introduces $t, so write $t here" "(defn f [x i32 d $t] $t {:where (numeric? $t)} (do d ($u x)))"; rejects_check "two variables in scope are both named" - ~needle:"introduces t and u, so write one of those" + ~needle:"introduces $t and $u, so write one of those" "(defn f [a $t b $u] i32 (do a b (let [v (vec-new $w)] (free v) 0)))"; (* Where no variable is in scope there is none to name, and the answer is the rule: a sigil binds, and only a defn signature is a binding site. *) @@ -6795,6 +6796,40 @@ let () = (defn main [] i32 (f (Pair 1 2)))"; accepts "a copy wanted where it is built takes its type from there" "(defstruct Pair [a $t b $t]) (defn f [] (Pair i64) (Pair 1 2))"; + (* A copy whose field is refused names each use that asked for it. *) + (match + checked + "(defstruct Box [f $t]) (defstruct Outer [b (Box $w)]) \ + (defn go [g (Fn [i32] i32)] i32 \ + (.x (the (Outer (Fn [i32] i32)) (zeroed))) 0)" + with + | _ -> check "a copy with a zeroed function field is refused" false + | exception Loc.Error d -> + let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in + check "a refused copy names each use that made it" + (List.mem "(Box (Fn [i32] i32)) is made here" notes + && List.mem "(Outer (Fn [i32] i32)) is made here" notes)); + rejects_check "a bare generic struct in ordinary code suggests real arguments" + ~needle:"write (Pair i32)" + "(defstruct Pair [a $t b $t]) (defn main [] i32 (let [p (the Pair (zeroed))] 0))"; + rejects_check "a generic struct applied to nothing" + ~needle:"Pair takes 1 argument, (Pair $t), and this gives 0" + "(defstruct Pair [a $t b $t]) \ + (defn main [] i32 (let [p (the (Pair) (zeroed))] 0))"; + rejects_check "a length argument that is not one" + ~needle:"(+ n 1) is not a type or a length" + "(defstruct Small [items [$n $t] count i32]) \ + (defn main [] i32 (let [n 3 p (the (Small (+ n 1) i32) (zeroed))] 0))"; + accepts "a length argument of literal arithmetic is folded" + "(defstruct Small [items [$n $t] count i32]) \ + (defn main [] i32 (let [p (the (Small (+ 1 2) i32) (zeroed))] \ + (length (.items p))))"; + accepts "two literal fields meet at the wider type" + "(defstruct Pair [a $t b $t]) \ + (defn f [] f64 (let [p (Pair 1 2.5)] (+ (.a p) (.b p))))"; + rejects_check "a callee's predicate names the caller's variable with its $" + ~needle:"passes the type variable $t, which nothing here declares ordered?" + "(defn f [s [$t]] () (sort s))"; accepts "a defonce of a generic struct's copy" "(defstruct Pair [a $t b $t]) (defonce g (Pair i32)) \ (defn main [] i32 (.a g))"; diff --git a/test/test_session.ml b/test/test_session.ml index 73ff7f35..9f206aa6 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -374,6 +374,56 @@ let () = | exception Loc.Error { Loc.dmsg = m; _ } -> fail "an expression building a generic struct was refused: %s" m); + (* And the same for the other two modules the break loop builds out of + typed-in values: a store into a frame slot, and a restart's arguments. + A copy first named in one of them is laid out there and kept. *) + (let keeps t what = + List.exists + (fun (s : Tast.structure) -> String.equal s.Tast.sname what) + t.Session.program.Tast.structs + in + let lays_out (c : Session.change) what = + has c.Session.ir ("%\"" ^ what ^ "\" = type") + in + let st, _ = Session.create ~file:"programs/reload.flan" () in + (match Session.eval st "(defstruct Pair [a $t b $t])" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "Pair: %s" m); + (match Session.eval st "(defn holder [] i64 (let [x (the i64 0)] x))" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "holder: %s" m); + let fn = + List.find (fun (f : Tast.fn) -> f.Tast.name = "holder") + st.Session.program.Tast.fns + in + let slot = + let r = ref (-1) in + Array.iteri (fun i n -> if n = Some "x" then r := i) fn.Tast.snames; + !r + in + (match + Session.write_slot st ~frame:0 ~fn ~slot ~path:[] + ~edits:[ ([], "(.a (Pair (the i64 5) 6))") ] + with + | Ok (c, _, _) -> + if not (lays_out c "Pair-i64") then + fail "a store's module did not carry the struct copy its value made"; + if not (keeps st "Pair-i64") then + fail "the session did not keep the struct copy a store made" + | Error why -> fail "a store building a generic struct was refused: %s" why + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a store building a generic struct was refused: %s" m); + match + Session.arm_restart st ~index:0 ~params:[ Types.Int Types.U16 ] + ~codes:[ "(.b (Pair (the u16 5) 6))" ] + with + | Ok (c, _) -> + if not (lays_out c "Pair-u16") then + fail "a restart's module did not carry the struct copy its argument made" + | Error why -> fail "a restart building a generic struct was refused: %s" why + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a restart building a generic struct was refused: %s" m); + (* The other half of "a refusal costs nothing", and the half that used to be missing: a form can check and *then* fail, in the build or at the agent, and the session that already accepted it has no way to hear about it