From 4054c4921ba9724ff543f197a46c5dea1bd4f2f0 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:08:14 +0700 Subject: [PATCH] A defstruct whose fields introduce $t or an array length $n is a generic struct, each application of it an ordinary struct copy that generic functions bind against, and a printed call is evaluated once --- TODO.org | 13 +- lib/ast.ml | 3 + lib/check.ml | 984 +++++++++++++++++++++++++----- lib/cimport.ml | 1 + lib/dev.ml | 21 +- lib/emit.ml | 7 +- lib/js.ml | 2 + lib/load.ml | 8 +- lib/parse.ml | 20 +- lib/session.ml | 11 +- lib/shim.ml | 1 + lib/types.ml | 26 +- lib/x86.ml | 1 + test/programs/generic-struct.flan | 89 +++ test/test_acceptance.ml | 12 + test/test_flan.ml | 83 ++- test/test_session.ml | 20 + 17 files changed, 1111 insertions(+), 191 deletions(-) create mode 100644 test/programs/generic-struct.flan diff --git a/TODO.org b/TODO.org index 0a5e280d..98476f68 100644 --- a/TODO.org +++ b/TODO.org @@ -750,15 +750,10 @@ depth it gave up at. The bare depth number is a backstop that also prints the chain. Before any of it, the compiler hung rather than failed, which wedges =C-c C-c= with nothing to show. -** NEXT Generic types -Decided 2026-09-25: the freeze is lifted for this; build both type and length parameters. -=(defstruct Pair [a $t b $t])= cannot be spelled, and neither can a length -parameter. =Types.Named= is a bare string with no room for parameters; giving it -some changes the type, the layout calculator, both backends, the renderer and the -DWARF path. Same price for one as for both. Decided and unblocked, deliberately -not started — it is a language feature under a freeze, and it was stopped once -already for that reason. The motivating case is Odin's =Small_Array=: a -fixed-capacity array with a count and no allocation. +** DONE Generic types +CLOSED: [2026-09-25] +A struct's parameters are its fields' $-names in first-written order, a length by position; there is no +explicit parameter vector. Each application is an ordinary struct under a key, so no backend sees a parameter. ** WAIT A value predicate over a length parameter Decided 2026-09-25: waits until a program wants one. diff --git a/lib/ast.ml b/lib/ast.ml index bc5f0d67..b87d4abb 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -24,6 +24,9 @@ and texpr_kind = them identically — the difference is a fact about the value, and it is [Check.resolve] that turns it into one. *) | Tfn of bool * texpr list * texpr + (* An integer written as a generic struct's argument, the 8 in + (Small 8 i32). Parsed only there; it is not a type anywhere else. *) + | Tlen of int64 (* An array length is an integer or a compile-time constant's name. *) and len = diff --git a/lib/check.ml b/lib/check.ml index 0c03ca82..59e1ba1b 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -79,6 +79,44 @@ let rec slot_text = function | Sclass c -> c | Sopt s -> "(Option " ^ slot_text s ^ ")" +(* ── 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 + first written — [$n] then [$t] here, so the type is spelled + [(Small 8 i32)] — and each is a length or a type by where it stands: in an + array's length slot, or in a generic struct's length argument, it is a + length; anywhere else a type. + + Each application at concrete arguments is a copy: an ordinary struct under + a symbol-safe key, [Small-8-i32], so layout, both backends, the renderer + and DWARF see a struct and nothing else — the same arrangement a generic + function's copy has. [struct_apps] is how the checker still knows what a + copy was applied to, which is what binding [(defn push [s (Ptr (Small $n + $t))] ...)] against an argument needs. An application at variables is a + copy too, under a key with the variables in it, whose array lengths are + [abstract_len]; it exists for the abstract pass over a generic body and is + left out of the program. *) +type gstruct = { + gparams : (string * bool) list; (* name, and whether it is a length *) + gfields : Ast.field list; + gloc : Loc.t; +} + +(* Key -> the generic struct and the arguments it was applied to; a length + argument is [Types.Len], a variable one [Types.Var]. Global for the reason + [Types.display] is: [bind_ty] and [subst_ty] are called from places with no + env in hand. The key is made from exactly these, so an entry can only + mislead where a later program in the same process declares a struct under + a copy's key by hand, and [struct_copy] refuses that name the moment the + program asks for the copy itself. *) +let struct_apps : (string, string * Types.t list) Hashtbl.t = Hashtbl.create 16 + +(* The length every length variable has inside a generic body's abstract + pass. Large so that no constant index into such an array is refused as out + of bounds there, and within i32 so that [(length a)] is an ordinary index. + Every length is answered again, exactly, per copy. *) +let abstract_len = 2147483647L + type env = { structs : (string, Tast.structure) Hashtbl.t; datas : (string, Tast.data) Hashtbl.t; @@ -198,13 +236,32 @@ type env = { pass made would come back from the copy, at the same line, once per type it was called at. *) refused_generics : (string, unit) Hashtbl.t; + (* The generic structs, by name; see [gstruct]. *) + gstructs : (string, gstruct) Hashtbl.t; + (* 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; + (* A generic defn's length variables, by name: the ones of its [gsigs] + variables that are lengths. *) + glens : (string, string list) Hashtbl.t; + (* Which of [tyvars] are lengths. A length variable is also a value inside + the body — [n] reads as the integer it was bound to. *) + mutable lenvars : string list; + (* Set while a generic body is checked abstractly, and while a struct copy + at variables is laid out: a length variable's array is then + [abstract_len] long rather than the [Types.LArray] a signature pattern + needs. *) + mutable len_placeholder : bool; + (* The struct copies being laid out, innermost last, so a template that + asks for a copy of itself at a bigger type is refused rather than + followed forever. *) + mutable schain : (string * Types.t list) list; (* Set while a struct, data-case or union field's type is being resolved, and only then. It exists for one message: an unknown lowercase name in a type slot is told to introduce a type variable with [$name] in the - parameter vector, and a field has no parameter vector — only a defn - signature binds, and a field is built at one type for every value. The - flag is what lets [resolve_name] say the honest thing in each place - instead of a suggestion that cannot be followed. *) + parameter vector, and a field has no parameter vector — a defstruct's + field introduces one where it stands. The flag is what lets + [resolve_name] say the honest thing in each place. *) mutable in_field : bool; (* Every [defclass], by name: its slots in constructor order, each with the type a value stored in it must have — [Types.Dyn] for a slot written @@ -247,6 +304,12 @@ let new_env () = { tvpreds = []; chain = []; refused_generics = Hashtbl.create 4; + gstructs = Hashtbl.create 4; + copies = Hashtbl.create 8; + glens = Hashtbl.create 8; + lenvars = []; + len_placeholder = false; + schain = []; in_field = false; classes = Hashtbl.create 8; tracks = Hashtbl.create 16; @@ -262,6 +325,13 @@ let new_env () = { the name is not one this environment placed, so it degrades to the message alone rather than to a wrong pointer. *) let declared_note env name = + (* A generic struct's copy is declared where its template is, and is + spoken of by the template's name there. *) + let shown = + match Hashtbl.find_opt struct_apps name with + | Some (g, _) when Hashtbl.mem env.copies name -> g + | _ -> name + in match Hashtbl.find_opt env.locs name with | None -> [] | Some at -> @@ -277,8 +347,8 @@ let declared_note env name = | None -> []) in let what = - if names = [] then name ^ " is declared here" - else name ^ " is declared here, with " ^ String.concat ", " names + if names = [] then shown ^ " is declared here" + else shown ^ " is declared here, with " ^ String.concat ", " names in [ Loc.note at what ] @@ -1202,6 +1272,119 @@ let rec unfillable env seen (t : Types.t) : Types.t option = | None -> Some t) | _ -> Some t +(* How a concrete type is spelled inside an instantiation's name. The prelude + already writes this by hand — [filter-i32], [sum-f32], [append-i64] — so a + generated name reads like the handwritten one it replaces, which is what a + backtrace, a [Reach] edge and a dev-build cell all end up showing. + [Types.to_string] cannot serve: [[i32]] and [(Vec i32)] are not symbols. *) +let rec mangle_ty (t : Types.t) = + match t with + | Types.Unit -> "unit" + | Types.Slice (Types.Mut, e) -> "slice-" ^ mangle_ty e + | Types.Slice (Types.Const, e) -> "cslice-" ^ mangle_ty e + | Types.Array (n, e) -> Printf.sprintf "arr%Ld-%s" n (mangle_ty e) + | Types.Map (k, v) -> Printf.sprintf "map-%s-%s" (mangle_ty k) (mangle_ty v) + | Types.Ptr (Types.Mut, e) -> "ptr-" ^ mangle_ty e + | Types.Ptr (Types.Const, e) -> "cptr-" ^ mangle_ty e + | Types.Vec e -> "vec-" ^ mangle_ty e + | Types.Option e -> "opt-" ^ mangle_ty e + | Types.Fn (ps, r) -> + Printf.sprintf "fn-%s-to-%s" + (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) + | Types.CFn (ps, r) -> + Printf.sprintf "cfn-%s-to-%s" + (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) + (* Bare, because [Types.to_string] spells a variable with its [$] for the + reader and a symbol has no room for one. *) + | Types.Var n -> n + (* The key, not [Types.to_string]'s [(Small 8 i32)], which is a reader's + spelling and not a symbol. *) + | Types.Named n -> n + | t -> Types.to_string t + +let rec occurs_in ~needle (t : Types.t) = + Types.equal needle t + || + match t with + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e -> occurs_in ~needle e + | Types.Map (k, v) -> occurs_in ~needle k || occurs_in ~needle v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> + List.exists (occurs_in ~needle) ps || occurs_in ~needle r + | Types.LArray (_, e) -> occurs_in ~needle e + (* Through a struct copy's arguments, or [(Node (Node $t))] would not be + seen to contain [(Node $t)]. *) + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, args) -> List.exists (occurs_in ~needle) args + | None -> false) + | _ -> false + +(* [b] is [a] with something built around it: same shape, strictly bigger. *) +let grows ~from_:a ~to_:b = + List.length a = List.length b + && List.for_all2 (fun x y -> occurs_in ~needle:x y) a b + && not (List.for_all2 Types.equal a b) + +(* A generic struct's copy at [args], by key: [Small-8-i32], or + [Small-$n-$t] at variables. Recorded in [struct_apps] and [Types.display] + as the key is made; the copy's fields are [struct_copy]'s business. *) +let struct_app g args = + let key = + g ^ "-" + ^ String.concat "-" + (List.map + (function + | Types.Var v -> "$" ^ v + | Types.Len n -> Int64.to_string n + | t -> mangle_ty t) + args) + in + if not (Hashtbl.mem struct_apps key) then begin + Hashtbl.replace struct_apps key (g, args); + Hashtbl.replace Types.display key + (Printf.sprintf "(%s %s)" g + (String.concat " " (List.map Types.to_string args))) + end; + key + +(* Does [name] contain itself by value? [check_finite] asks it of every + declared type once they are all collected, and a generic struct's copy asks + it of itself when it is made, which is after that. *) +let finite_from env name0 = + let rec walk seen name = + if List.mem name seen then + (let shown = Types.to_string (Types.Named name) in + fail (Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown) + "%s contains itself by value, so it has no size — go through (Ptr %s)" + shown shown); + let seen = name :: seen in + match Hashtbl.find_opt env.structs name with + | Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields + | None -> + match Hashtbl.find_opt env.datas name with + | Some u -> + List.iter + (fun (c : Tast.variant) -> + List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) c.Tast.vfields) + u.Tast.cases + | None -> + (* A union whose member is itself is the same infinite type a struct's + is — the size is the largest member and the largest member is the + whole thing. Nothing about overlaying storage makes the recursion + finite, so it is on the same walk rather than left to hang the + layout calculator. *) + match Hashtbl.find_opt env.unions name with + | None -> () + | Some u -> + List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) u.Tast.fields + and ty seen = function + | Types.Named n -> walk seen n + | Types.Array (_, e) | Types.Option e -> ty seen e + | _ -> () + in + walk [] name0 + (* The name under the sigil. [$t] is how a defn signature introduces a type variable and [t] is how the body spells the same one, so the tables that record which variables are in scope — [env.tyvars] and [env.subst] — are @@ -1234,7 +1417,17 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = | Ast.Tarray (l, e) -> let e = resolve env ~seen e in no_zeroed_fn loc "a fixed array's element" e; - Types.Array (array_len env loc l, e) + (match l with + | Ast.Lname n + when (not env.len_placeholder) + && List.mem (tyvar_bare n) env.lenvars + && not (List.mem_assoc (tyvar_bare n) env.subst) -> + Types.LArray (tyvar_bare n, e) + | _ -> Types.Array (array_len env loc l, e)) + | Ast.Tlen n -> + fail loc + "%Ld is not a type. An integer stands only where a generic struct takes \ + a length, as in (Small 8 i32)" n (* {K V} is the type spelling. There is no map *literal*: a bare map form in expression position is a struct literal's field list, and giving the same braces two meanings is what the colon-to-dot change was for. A map is @@ -1298,15 +1491,10 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = (resolve env ~seen v) | "Map", _ -> fail loc "(Map K V) takes exactly two types" | "Result", _ -> unimplemented loc "(Result T E)" 6 + | _ when Hashtbl.mem env.gstructs name -> apply_struct env ~seen loc name args | _ -> - (* Not generics, which are here: a *function* is generic over [$t] and - instantiated per call site. This is a parameterised named type — - [(Pair i32 f64)] — and that is a different thing and is not built. - [Types.Named] is a bare string with no parameters, so there is - nowhere to put the arguments, and giving it some is a change to - [Types.t] and therefore to the layout calculator, both backends, - [Render] and the DWARF path. docs/SPIKE-GENERICS.md, question 4, - prices it and leaves it out. *) + (* No type of this name takes arguments: a generic struct is caught + by the arm above, and [Ptr], [Option], [Vec] and [Map] further up. *) (* A head that is not a type at all but one edit from one is the typo [(Vect i32)], and the generics sentence would answer a question nobody asked. *) @@ -1323,9 +1511,154 @@ let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = "unknown type %s — did you mean %s?" name m | _ -> ()); fail loc - "%s takes no type arguments. A generic function is written with $t \ - in its parameter vector; a generic type is not there yet" - name) + "%s takes no type arguments. A generic struct is one whose fields \ + introduce $t, as in (defstruct %s [x $t]), and a generic function \ + one whose parameter vector does" + name name) + +(* [(Small 8 i32)]: each argument read as the parameter it stands for — a + length or a type — and the copy made, or found. *) +and apply_struct env ~seen loc name args = + let g = Hashtbl.find env.gstructs name in + let spelled = + Printf.sprintf "(%s %s)" name + (String.concat " " (List.map (fun (p, _) -> "$" ^ p) g.gparams)) + in + let n = List.length g.gparams in + if List.length args <> n then + Loc.failk "check/generic-struct-arity" loc + ~notes:[ Loc.note g.gloc (name ^ " is declared here") ] + "%s takes %d argument%s, %s, and this gives %d" + name n (if n = 1 then "" else "s") spelled (List.length args); + let targs = + List.map2 + (fun (p, is_len) (a : Ast.texpr) -> + if is_len then struct_len_arg env name p a + else + match a.Ast.t with + | Ast.Tlen k -> + fail a.Ast.tloc + "%s's $%s is a type, and %Ld is a length — %s" name p k spelled + | _ -> resolve env ~seen a) + g.gparams args + in + Types.Named (struct_copy env loc name targs) + +and struct_len_arg env name p (a : Ast.texpr) = + let not_one what = + fail a.Ast.tloc + "%s's $%s is a length: an integer, a constant's name or a length \ + variable, and %s is %s" name p (Cimport.ty_source a) what + in + match a.Ast.t with + | Ast.Tlen k when Int64.compare k 0L < 0 -> + fail a.Ast.tloc "%s's $%s is a length, and %Ld is negative" name p k + | Ast.Tlen k -> Types.Len k + | Ast.Tname n -> + let bare = tyvar_bare n in + (match List.assoc_opt bare env.subst with + | Some (Types.Len _ as l) -> l + | Some (Types.Var v) -> Types.Var v + | Some t -> not_one ("the type " ^ Types.to_string t) + | None -> + if List.mem bare env.lenvars then Types.Var bare + else if List.mem bare env.tyvars then not_one "a type variable" + else + match Hashtbl.find_opt env.consts n with + | Some k -> Types.Len k + | None -> not_one "none of them") + | _ -> not_one "a type" + +(* 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 = + let key = struct_app name targs in + if Hashtbl.mem env.copies key then key + else begin + if Hashtbl.mem env.structs key || Hashtbl.mem env.datas key + || Hashtbl.mem env.unions key then + fail loc + "%s at these arguments is called %s, and %s is already defined — \ + rename one" name key key; + let g = Hashtbl.find env.gstructs name in + (* A copy that asks for a copy of its own template at a type built around + its own arguments — [(defstruct Grow [next (Ptr (Grow [$t]))])] — asks + forever, and pointers do not stop it: each copy is made the moment it + is named. *) + let chain_text () = + String.concat "\n " + (List.map + (fun (h, a) -> + Printf.sprintf "(%s %s)" h + (String.concat " " (List.map Types.to_string a))) + (env.schain @ [ (name, targs) ])) + in + if List.exists + (fun (h, a) -> String.equal h name && grows ~from_:a ~to_:targs) + env.schain + || List.length env.schain >= 64 then + Loc.failk "check/runaway-instantiation" loc + ~notes:[ Loc.note g.gloc (name ^ " is declared here") ] + "%s names a copy of itself at a type built around its own \ + arguments, and that copy names another, without end:\n %s\n\ + Name the same arguments, or smaller ones" name (chain_text ()); + let generic = List.exists generic_arg targs in + (* In before its fields, so a field that names the same copy through a + pointer — [(defstruct Node [next (Ptr (Node $t))])] — finds it. *) + Hashtbl.replace env.copies key generic; + Hashtbl.replace env.structs key { Tast.sname = key; fields = [] }; + Hashtbl.replace env.locs key g.gloc; + let saved = + (env.subst, env.tyvars, env.lenvars, env.tvpreds, env.len_placeholder, + env.in_field, env.schain) + in + let restore () = + let s, t, l, p, lp, f, c = saved in + env.subst <- s; env.tyvars <- t; env.lenvars <- l; env.tvpreds <- p; + env.len_placeholder <- lp; env.in_field <- f; env.schain <- c + in + env.subst <- List.map2 (fun (p, _) a -> (p, a)) g.gparams targs; + env.tyvars <- []; + env.lenvars <- []; + env.tvpreds <- []; + env.len_placeholder <- generic; + env.in_field <- true; + env.schain <- env.schain @ [ (name, targs) ]; + match + List.map + (fun (f : Ast.field) -> + let fty = resolve env f.Ast.fty in + no_zeroed_fn f.Ast.fty.Ast.tloc + (Printf.sprintf "the field %s" f.Ast.fname) fty; + { Tast.fname = f.Ast.fname; fty }) + g.gfields + with + | fields -> + restore (); + Hashtbl.replace env.structs key { Tast.sname = key; fields }; + finite_from env key; + key + | exception e -> + restore (); + Hashtbl.remove env.copies key; + Hashtbl.remove env.structs key; + raise e + end + +(* Does a struct argument still mention a variable? *) +and generic_arg (t : Types.t) = + match t with + | Types.Var _ | Types.LArray _ -> true + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e -> generic_arg e + | Types.Map (k, v) -> generic_arg k || generic_arg v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> + List.exists generic_arg ps || generic_arg r + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, a) -> List.exists generic_arg a + | None -> false) + | _ -> false (* One edit away from a type that exists — a substitution, an insertion, a deletion or a transposition of neighbours. Bounded at one, because two edits @@ -1359,12 +1692,19 @@ and resolve_name env ~seen loc n = one, a mistyped type name silently became a type parameter and made the function more permissive than it was written to be. *) let bare = tyvar_bare n in + let a_length () = + fail loc + "%s is a length, not a type — it stands where an array's length does, \ + as in [%s T], or as a generic struct's length argument" n n + in match List.assoc_opt bare env.subst with + | Some (Types.Len _) -> a_length () (* Inside an instantiation: the variable is this concrete type, and every node checked under it is as concrete as if it had been written out. *) | Some t -> t | None -> - if List.mem bare env.tyvars then Types.Var bare + if List.mem bare env.lenvars then a_length () + else if List.mem bare env.tyvars then Types.Var bare else if n <> bare then (* A sigil on a name nothing binds. Two different mistakes wear the same spelling, and which one it is turns on whether any variable is in scope @@ -1383,8 +1723,8 @@ and resolve_name env ~seen loc n = (match (match env.tyvars with [] -> List.map fst env.subst | vs -> vs) with | [] -> Loc.failk "check/unbound-type-variable" loc - "%s introduces a type variable, and only a defn signature can — write \ - the concrete type here" n + "%s introduces a type variable, and only a defn signature or a \ + defstruct's fields can — write the concrete type here" n | [ v ] -> Loc.failk "check/unbound-type-variable" loc "nothing binds the type variable %s — this signature introduces %s, \ @@ -1423,6 +1763,13 @@ and resolve_name env ~seen loc n = if List.mem n seen then fail loc "the type alias %s is defined in terms of itself" n else resolve env ~seen:(n :: seen) (Hashtbl.find env.aliases n) + | _ when Hashtbl.mem env.gstructs n -> + let g = Hashtbl.find env.gstructs n in + Loc.failk "check/generic-struct-arity" loc + ~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)) | _ 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. @@ -1460,18 +1807,16 @@ and resolve_name env ~seen loc n = permissive than it was written to be. *) | _ when n <> "" && n.[0] = Char.lowercase_ascii n.[0] -> (* The parameter-vector suggestion is only followable where a - parameter vector exists. A field has none and never will — only a - defn signature binds a variable, and a field is built at one type - for every value — so at a field the message offers the two things - that can actually be written there. *) + parameter vector exists. A field has none: a defstruct's field + introduces the variable where it stands, so at a field the message + says that instead. *) if env.in_field then Loc.failk "check/unknown-type" loc - "unknown type %s. A lowercase name is a type variable, and a \ - field cannot hold one: only a defn signature introduces type \ - variables, and a field is built at one type for every value — \ - generic types are not there. Write a concrete type here, or dyn \ - to hold any value" - n + "unknown type %s. A lowercase name is a type variable only where \ + it is introduced with $%s, and in a defstruct's fields that makes \ + the struct generic over it. Write $%s, a concrete type, or dyn to \ + hold any value" + n n n else Loc.failk "check/unknown-type" loc "unknown type %s. A lowercase name is a type variable only where a \ @@ -1483,7 +1828,19 @@ and resolve_name env ~seen loc n = and array_len env loc = function | Ast.Lint n -> n | Ast.Lname n -> - (match Hashtbl.find_opt env.consts n with + let bare = tyvar_bare n in + (match List.assoc_opt bare env.subst with + | Some (Types.Len k) -> k + | Some (Types.Var _) -> abstract_len + | Some t -> + fail loc "%s is the type %s here, and an array length is an integer, a \ + constant or a length variable" n (Types.to_string t) + | None when List.mem bare env.lenvars -> abstract_len + | None when List.mem bare env.tyvars -> + fail loc "%s is a type variable, and an array length is an integer, a \ + constant or a length variable" n + | None -> + match Hashtbl.find_opt env.consts n with | Some v -> v | None -> fail loc "%s is not a compile-time integer constant, so it cannot be \ @@ -1514,6 +1871,7 @@ let is_type_name env n = || List.mem n [ "bool"; "string"; "dyn"; "Unit"; "Never"; "Allocator" ] || Hashtbl.mem env.aliases n || Hashtbl.mem env.structs n + || Hashtbl.mem env.gstructs n || Hashtbl.mem env.datas n || Hashtbl.mem env.unions n || Hashtbl.mem env.enums n @@ -1828,6 +2186,7 @@ let defvar_reads_as_type env (t : Ast.texpr) = | Ast.Tname n -> is_type_name env n | Ast.Tapp (head, _) -> List.mem head [ "Ptr"; "Option"; "Vec"; "Map"; "Result" ] + || Hashtbl.mem env.gstructs head (* A slice, a fixed array, a map type or an (Fn ...): [Parse] only carries one of these over when it read as a type and had no value reading, so there is nothing here to decide. *) @@ -2004,9 +2363,9 @@ let settle_defvars env (decls : Ast.decl list) : Ast.decl list = (* The variables a signature introduces: every [$t] written in it, in the order written, once each. Only a [defn] signature is scanned, which is what makes the binding site a *place* and not merely a spelling. *) -let signature_tyvars (fn : Ast.fn) = +let sigil_vars ~kinds_of (ts : Ast.texpr list) = let acc = ref [] in - let name loc n = + let add loc n is_len = if n <> "" && n.[0] = '$' then begin let bare = String.sub n 1 (String.length n - 1) in if bare = "" then fail loc "$ on its own does not name a type variable"; @@ -2016,24 +2375,59 @@ let signature_tyvars (fn : Ast.fn) = || Types.ikind_of_name bare <> None || Types.fkind_of_name bare <> None then fail loc "%s is a type, so $%s cannot be a type variable" bare bare; - if not (List.mem bare !acc) then acc := bare :: !acc + match List.assoc_opt bare !acc with + | None -> acc := (bare, is_len) :: !acc + | Some k when k = is_len -> () + | Some _ -> + fail loc + "$%s stands for a length in one place here and a type in another — \ + a length goes in an array's length slot, [$%s T], and a type \ + everywhere else. Give the two different names" bare bare end in let rec ty (t : Ast.texpr) = match t.Ast.t with - | Ast.Tname n -> name t.Ast.tloc n + | Ast.Tname n -> add t.Ast.tloc n false | Ast.Tslice (_, e) -> ty e + | Ast.Tarray (Ast.Lname n, e) -> add t.Ast.tloc n true; ty e | Ast.Tarray (_, e) -> ty e | Ast.Tmap (k, v) -> ty k; ty v - (* The head of an application is a constructor — [Ptr], [Option], [Vec] — - and a variable cannot stand there: this spike is generic over types, - not over type constructors. A [$t] inside the arguments is ordinary. *) - | Ast.Tapp (_, args) -> List.iter ty args + (* The head of an application is a constructor — [Ptr], [Option], [Vec], + a generic struct — and a variable cannot stand there: this is generic + over types, not over type constructors. A [$t] inside the arguments is + ordinary, and a generic struct's length argument is a length. *) + | Ast.Tapp (h, args) -> + (match kinds_of h with + | Some ks when List.length ks = List.length args -> + List.iter2 + (fun is_len (a : Ast.texpr) -> + match a.Ast.t with + | Ast.Tname n when is_len -> add a.Ast.tloc n true + | _ -> ty a) + ks args + | _ -> List.iter ty args) | Ast.Tfn (_, ps, r) -> List.iter ty ps; ty r + | Ast.Tlen _ -> () in - List.iter (fun (p : Ast.field) -> ty p.Ast.fty) fn.Ast.params; - (match fn.Ast.ret with Some r -> ty r | None -> ()); - List.rev !acc + List.iter ty ts; + let vs = List.rev !acc in + (List.map fst vs, List.filter_map (fun (v, l) -> if l then Some v else None) vs, + vs) + +let struct_kinds env h = + Option.map (fun g -> List.map snd g.gparams) (Hashtbl.find_opt env.gstructs h) + +(* The variables a signature introduces: every [$t] written in it, in the + order written, once each, and which of them are lengths. Only a [defn] + signature and a [defstruct]'s fields are scanned, which is what makes the + binding site a *place* and not merely a spelling. *) +let signature_tyvars env (fn : Ast.fn) = + let vars, lens, _ = + sigil_vars ~kinds_of:(struct_kinds env) + (List.map (fun (p : Ast.field) -> p.Ast.fty) fn.Ast.params + @ Option.to_list fn.Ast.ret) + in + vars, lens (* Bind the variables in a parameter's written type from the type an argument turned out to have. Odin's [is_polymorphic_type_assignable], structurally @@ -2102,6 +2496,17 @@ let rec bind_ty ?(widen = false) ?(ro = true) subst (pat : Types.t) | Types.Fn (ps, r), Types.CFn (ps', r') when widen -> List.length ps = List.length ps' && List.for_all2 inner ps ps' && inner r r' + (* A length variable's array against a concrete one: the length is bound + the way a type variable is, to a [Types.Len]. *) + | Types.LArray (v, p), Types.Array (n, a) -> + bind_ty ~ro:false subst (Types.Var v) (Types.Len n) && inner p a + (* A struct copy at variables against a copy of the same template: each + argument against its own. *) + | Types.Named p, Types.Named a when not (String.equal p a) -> + (match Hashtbl.find_opt struct_apps p, Hashtbl.find_opt struct_apps a with + | Some (g, ps), Some (h, as_) when String.equal g h -> + List.length ps = List.length as_ && List.for_all2 inner ps as_ + | _ -> false) (* Nothing generic left on the pattern side: this is ordinary type equality, and [Never] fits anywhere exactly as it does elsewhere. *) | p, a -> Types.fits ~expected:p ~actual:a @@ -2118,12 +2523,29 @@ let rec subst_ty subst (t : Types.t) = | Types.Fn (ps, r) -> Types.Fn (List.map (subst_ty subst) ps, subst_ty subst r) | Types.CFn (ps, r) -> Types.CFn (List.map (subst_ty subst) ps, subst_ty subst r) + | Types.LArray (v, e) -> + (match List.assoc_opt v subst with + | Some (Types.Len n) -> Types.Array (n, subst_ty subst e) + | Some (Types.Var w) -> Types.LArray (w, subst_ty subst e) + | _ -> Types.LArray (v, subst_ty subst e)) + (* A struct copy at variables becomes the copy at what they are bound to. + Only its key is made here — there is no env to lay it out in — and + [realise] makes the copy itself before anything reads its fields. *) + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (g, args) when List.exists open_ty args -> + let args = List.map (subst_ty subst) args in + Types.Named (struct_app g args) + | _ -> t) | t -> t -(* Does this resolved type still mention a variable? *) -let rec generic_ty (t : Types.t) = +(* Does this resolved type still mention a variable? Not through a struct + copy's arguments: an operator over a [(Pair $t)] is refused as one over a + struct, not as one over a type variable. [open_ty] is the question that + does look through, for binding and substituting. *) +and generic_ty (t : Types.t) = match t with - | Types.Var _ -> true + | Types.Var _ | Types.LArray _ -> true | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e | Types.Option e -> generic_ty e | Types.Map (k, v) -> generic_ty k || generic_ty v @@ -2131,6 +2553,37 @@ let rec generic_ty (t : Types.t) = List.exists generic_ty ps || generic_ty r | _ -> false +and open_ty (t : Types.t) = + match t with + | Types.Var _ | Types.LArray _ -> true + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e -> open_ty e + | Types.Map (k, v) -> open_ty k || open_ty v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> List.exists open_ty ps || open_ty r + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, args) -> List.exists open_ty args + | None -> false) + | _ -> false + +(* Make every struct copy [t] names that [subst_ty] only named. A copy has + to exist in [env.structs] before a field of it is read, and [subst_ty] has + no env to make one in. *) +let rec realise env loc (t : Types.t) = + match t with + | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e + | Types.Option e | Types.LArray (_, e) -> realise env loc e + | Types.Map (k, v) -> realise env loc k; realise env loc v + | Types.Fn (ps, r) | Types.CFn (ps, r) -> + List.iter (realise env loc) ps; realise env loc r + | Types.Named k when not (Hashtbl.mem env.structs k) -> + (match Hashtbl.find_opt struct_apps k with + | Some (g, args) when Hashtbl.mem env.gstructs g -> + List.iter (realise env loc) args; + ignore (struct_copy env loc g args) + | _ -> ()) + | _ -> () + (* Does a type a call site bound a variable to reach a [dyn] anywhere? See the refusal in [generic_call]: [dyn] is a concrete type and substitutes like any other, so nothing stopped a copy being made at it, and the copies walked @@ -2170,33 +2623,6 @@ let unconstrained env loc op ~needs (t : Types.t) = (Types.to_string t) (Types.to_string t) (Types.to_string t) -(* How a concrete type is spelled inside an instantiation's name. The prelude - already writes this by hand — [filter-i32], [sum-f32], [append-i64] — so a - generated name reads like the handwritten one it replaces, which is what a - backtrace, a [Reach] edge and a dev-build cell all end up showing. - [Types.to_string] cannot serve: [[i32]] and [(Vec i32)] are not symbols. *) -let rec mangle_ty (t : Types.t) = - match t with - | Types.Unit -> "unit" - | Types.Slice (Types.Mut, e) -> "slice-" ^ mangle_ty e - | Types.Slice (Types.Const, e) -> "cslice-" ^ mangle_ty e - | Types.Array (n, e) -> Printf.sprintf "arr%Ld-%s" n (mangle_ty e) - | Types.Map (k, v) -> Printf.sprintf "map-%s-%s" (mangle_ty k) (mangle_ty v) - | Types.Ptr (Types.Mut, e) -> "ptr-" ^ mangle_ty e - | Types.Ptr (Types.Const, e) -> "cptr-" ^ mangle_ty e - | Types.Vec e -> "vec-" ^ mangle_ty e - | Types.Option e -> "opt-" ^ mangle_ty e - | Types.Fn (ps, r) -> - Printf.sprintf "fn-%s-to-%s" - (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) - | Types.CFn (ps, r) -> - Printf.sprintf "cfn-%s-to-%s" - (String.concat "-" (List.map mangle_ty ps)) (mangle_ty r) - (* Bare, because [Types.to_string] spells a variable with its [$] for the - reader and a symbol has no room for one. *) - | Types.Var n -> n - | t -> Types.to_string t - (* ── The runaway instantiation, refused by name rather than by depth ──── [(defn grow [x $t] () (grow [x x]))] asks for a copy at [[t]], which asks for one at [[[t]]], forever. Before this the checker did not fail, it @@ -2223,23 +2649,6 @@ let rec mangle_ty (t : Types.t) = is the whole design. The depth backstop below stays as a backstop only: it catches a growth this test does not recognise, and it is never the thing the message is about. *) -let rec occurs_in ~needle (t : Types.t) = - Types.equal needle t - || - match t with - | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e - | Types.Option e -> occurs_in ~needle e - | Types.Map (k, v) -> occurs_in ~needle k || occurs_in ~needle v - | Types.Fn (ps, r) | Types.CFn (ps, r) -> - List.exists (occurs_in ~needle) ps || occurs_in ~needle r - | _ -> false - -(* [b] is [a] with something built around it: same shape, strictly bigger. *) -let grows ~from_:a ~to_:b = - List.length a = List.length b - && List.for_all2 (fun x y -> occurs_in ~needle:x y) a b - && not (List.for_all2 Types.equal a b) - let runaway env loc gname cparams = let chain_text () = String.concat "\n " @@ -3042,7 +3451,8 @@ let box loc (e : Tast.expr) : Tast.expr = caller that starts doing that gets a sentence instead of a silent mis-lowering. *) | Types.Named _ | Types.Enum _ | Types.Option _ | Types.Ptr _ - | Types.Alloc | Types.Fn _ | Types.CFn _ | Types.Var _ -> + | Types.Alloc | Types.Fn _ | Types.CFn _ | Types.Var _ | Types.Len _ + | Types.LArray _ -> no_dyn_yet loc ~into:true e.Tast.ty "" let unbox loc (want : Types.t) (e : Tast.expr) : Tast.expr = @@ -4260,6 +4670,23 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = (mk loc Types.Dyn (Tast.Let ([ (m, empty) ], sets @ [ mval ]))) | Ast.Quote _ -> unimplemented loc "a quoted symbol (restart names)" 6 + (* A length variable read as a value is the integer it was bound to, as a + literal — so it takes its width from where it stands, the way a written + 8 would. In the abstract pass it is a 1: a literal that fits every + integer type, since the real one is answered again per copy. A local of + the same name shadows it. *) + | Ast.Var name + when (not (List.mem_assoc name ctx.scope)) + && (List.mem name ctx.env.lenvars + || (match List.assoc_opt name ctx.env.subst with + | Some (Types.Len _) -> true + | _ -> false)) -> + let n = + match List.assoc_opt name ctx.env.subst with + | Some (Types.Len n) -> n + | _ -> 1L + in + check ctx ?want { e with Ast.e = Ast.Int n } | Ast.Var name -> var ctx loc ~want name | Ast.Do body -> ctx.tail <- tail; block ctx ?want loc body (* [defer_ok] rides through: a [let] at the top level of a function body has @@ -4400,7 +4827,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) - "%s has no field %s" sname name + "%s has no field %s" (Types.to_string (Types.Named sname)) name | Some i -> let fty = (List.nth s.Tast.fields i).Tast.fty in expect ctx loc ~want (mk loc fty (Tast.Field (target, i)))) @@ -6022,6 +6449,101 @@ and callable ctx name = | Some b -> (match b.bty with Types.Fn _ -> true | _ -> false) | None -> false) +(* [(Pair 1 2)] and [(Pair {.a 1 .b 2})]: which copy of a generic struct a + value builds. The position says, when a copy of this struct is wanted + there; otherwise the fields do, each given one's type binding the + template's variables the way a generic call's arguments bind its own. The + fields are only probed here — each check is abandoned — and the ordinary + constructor checks them again against the copy it is handed. *) +and generic_ctor ctx ~want loc name given = + let env = ctx.env in + let g = Hashtbl.find env.gstructs name in + match want with + | Some (Types.Named k) + when (match Hashtbl.find_opt struct_apps k with + | Some (h, _) -> String.equal h name + | None -> false) -> + realise env loc (Types.Named k); k + | _ -> + let open_key = + struct_copy env loc name (List.map (fun (p, _) -> Types.Var p) g.gparams) + in + let fields = (Hashtbl.find env.structs open_key).Tast.fields in + let pairs = + match given with + | `Positional args when List.length args = List.length fields -> + List.combine fields args + (* The wrong number of fields: the copy at variables is handed on, and + the constructor says what is wrong with the count in its own words. *) + | `Positional _ -> [] + | `Named kvs -> + List.filter_map + (fun (f, v) -> + List.find_opt + (fun (fl : Tast.field) -> String.equal fl.Tast.fname f) fields + |> Option.map (fun fl -> (fl, v))) + kvs + in + let subst = ref [] and unsure = ref [] in + (* An untyped literal has no type of its own to bring, so the fields that + do have one bind first: [(Node 2 (addr c))] over a [(Node i64)] [c] is + a [(Node i64)], and the 2 takes its width from that. *) + let literal (a : Ast.expr) = + match a.Ast.e with + | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true + | _ -> false + in + let pairs = + List.filter (fun (_, a) -> not (literal a)) pairs + @ List.filter (fun (_, a) -> literal a) pairs + in + List.iter + (fun ((f : Tast.field), (a : Ast.expr)) -> + if open_ty f.Tast.fty + && not (literal a && subst_ty !subst f.Tast.fty |> open_ty |> not) + then begin + let seen = ref None in + let probe () = + seen := Some (check ctx a).Tast.ty; + Loc.fail a.Ast.loc "probe" + in + let refusal = match trial ctx probe with Error d -> Some d | Ok _ -> None in + match !seen with + (* No type of its own — [None], a bare {.field v} — is no + evidence; the constructor checks it against the copy the other + fields decide, and its refusal is the one given if they decide + nothing. *) + | None -> Option.iter (fun d -> unsure := d :: !unsure) refusal + | Some t -> + if not (bind_ty subst f.Tast.fty t) then + 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)) + (Types.to_string t) + end) + pairs; + (match given with + | `Positional args when List.length args <> List.length fields -> open_key + | _ -> + let targs = + List.map + (fun (p, _) -> + match List.assoc_opt p !subst with + | Some t -> t + | None -> + (match List.rev !unsure with + | d :: _ -> Loc.raise_diag d + | [] -> ()); + Loc.failk "check/generic-struct-undetermined" loc + ~notes:[ Loc.note g.gloc (name ^ " is declared here") ] + "%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))) + g.gparams + in + struct_copy env loc name targs) + (* [(Cell 1 2)] — a struct built from its fields in declaration order. The parser cannot make this one either, and for a sharper reason than the @@ -6051,6 +6573,14 @@ and positional_struct ctx ~want loc name args = let n = List.length fields in let given = List.length args in let note = declared_note ctx.env name in + (* The constructor is written with the template's name for a generic + struct's copy, and the copy is spoken of as [(Pair i32)]. *) + let ctor = + match Hashtbl.find_opt struct_apps name with + | Some (g, _) when Hashtbl.mem ctx.env.copies name -> g + | _ -> name + in + let shown = Types.to_string (Types.Named name) in if given < n then begin let missing = List.nth fields given in Loc.failk "check/positional-too-few" loc ~notes:note @@ -6058,15 +6588,15 @@ and positional_struct ctx ~want loc name args = Positional construction gives every field, in declaration order; to \ give some of them and zero the rest, a struct value is written (%s \ {.field value ...})" - name n (if n = 1 then "" else "s") given - (if given = 1 then "was" else "were") missing.Tast.fname name + shown n (if n = 1 then "" else "s") given + (if given = 1 then "was" else "were") missing.Tast.fname ctor end; if given > n then begin let extra = List.nth args n in Loc.failk "check/positional-too-many" extra.Ast.loc ~notes:note "%s has %d field%s, and this is argument %d — a struct value is written \ (%s {.field value ...}) or (%s %s)" - name n (if n = 1 then "" else "s") (n + 1) name name + shown n (if n = 1 then "" else "s") (n + 1) ctor ctor (String.concat " " (List.map (fun (f : Tast.field) -> f.Tast.fname) fields)) end; (* Left to right, each against its own field's type, exactly as the argument @@ -6089,7 +6619,7 @@ and positional_struct ctx ~want loc name args = Loc.notes = d.Loc.notes @ [ Loc.note a.Ast.loc - (Printf.sprintf "this is %s's field .%s" name + (Printf.sprintf "this is %s's field .%s" shown f.Tast.fname) ] @ note }) fields args @@ -6149,6 +6679,9 @@ and check_bare ctx ~want loc kvs = what lets the decision be made against the tables, exactly. *) and check_struct ctx ~want loc name kvs = match Hashtbl.find_opt ctx.env.structs name with + | None when Hashtbl.mem ctx.env.gstructs name -> + check_struct ctx ~want loc + (generic_ctor ctx ~want loc name (`Named kvs)) kvs | None when Hashtbl.mem ctx.env.unions name -> check_union ctx ~want loc name kvs | None -> @@ -6224,7 +6757,7 @@ and check_struct ctx ~want loc name kvs = if Tast.field_index s k = None then Loc.failk "check/unknown-field" v.Ast.loc ~notes:(declared_note ctx.env name) - "%s has no field %s" name k) + "%s has no field %s" (Types.to_string (Types.Named name)) k) in let fields = zii_fill ctx loc seen s.Tast.fields in expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) @@ -7399,7 +7932,7 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = (match Tast.field_index s name with | None -> Loc.failk "check/unknown-field" loc ~notes:(declared_note ctx.env sname) - "%s has no field %s" sname name + "%s has no field %s" (Types.to_string (Types.Named sname)) name | Some i -> if store then Option.iter (refuse_const_place ctx.env loc) (const_reached target); Tast.Pfield (target, i), (List.nth s.Tast.fields i).Tast.fty) @@ -7993,7 +8526,7 @@ and file_guard ctx loc ~path_slot ~op mk_steps = (* An argument written as a type: a type expression, or a bare name that is a type and not a local or a global of the same spelling. *) and type_arg ctx (a : Ast.expr) = - type_of_expr a <> None + type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None || (match a.Ast.e with | Ast.Var n -> lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) @@ -8027,8 +8560,11 @@ and type_named ctx n = and vec_new_elem ctx ~want loc args = let named = match args with - | a :: rest when type_of_expr a <> None -> - Some (resolve ctx.env (Option.get (type_of_expr a)), rest) + | a :: rest when type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None -> + Some + (resolve ctx.env + (Option.get (type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a)), + rest) | { Ast.e = Ast.Var n; _ } :: rest when lookup ctx n = None && (not (Hashtbl.mem ctx.env.globals n)) @@ -8051,12 +8587,12 @@ and vec_new_elem ctx ~want loc args = brackets — an allocator is never an array — or a parenthesised Ptr, Option, Vec, Map, Fn or CFn. A bare name is not one of them, because there it may be an allocator's name; the callers ask about that themselves. *) -and type_of_expr (e : Ast.expr) : Ast.texpr option = +and type_of_expr ?(generic = fun _ -> false) (e : Ast.expr) : Ast.texpr option = let mk t = { Ast.t; tloc = e.Ast.loc } in let inner (e : Ast.expr) = match e.Ast.e with | Ast.Var s -> Some { Ast.t = Ast.Tname s; tloc = e.Ast.loc } - | _ -> type_of_expr e + | _ -> type_of_expr ~generic e in let all es = let ts = List.filter_map inner es in @@ -8080,6 +8616,18 @@ and type_of_expr (e : Ast.expr) : Ast.texpr option = | Ast.Call ({ Ast.e = Ast.Var (("Ptr" | "Option" | "Vec" | "Map") as c); _ }, (_ :: _ as args)) -> Option.map (fun ts -> mk (Ast.Tapp (c, ts))) (all args) + (* A generic struct applied to its arguments, [(vec-new (Small 8 i32))]: + the caller says which heads are ones, since only the env knows. An + integer argument is a length. *) + | Ast.Call ({ Ast.e = Ast.Var c; _ }, (_ :: _ as args)) when generic c -> + let arg (a : Ast.expr) = + match a.Ast.e with + | Ast.Int n -> Some { Ast.t = Ast.Tlen n; tloc = a.Ast.loc } + | _ -> inner a + in + let ts = List.filter_map arg args in + if List.length ts = List.length args then Some (mk (Ast.Tapp (c, ts))) + else None | _ -> None (* The key and value types, or the reason this is not a Map. *) @@ -8102,7 +8650,7 @@ and map_new_types ctx ~want loc args = (* A type position holds a bare name or a type expression Parse has read as one, as [vec-new]'s does. *) let as_type (a : Ast.expr) = - match a.Ast.e, type_of_expr a with + match a.Ast.e, type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a with | _, Some t -> Some (resolve ctx.env t) | Ast.Var n, None when is_type n -> Some (resolve_name ctx.env ~seen:[] loc n) | _ -> None @@ -8110,7 +8658,7 @@ and map_new_types ctx ~want loc args = match args with | k :: v :: rest when as_type k <> None && as_type v <> None -> Option.get (as_type k), Option.get (as_type v), rest - | a :: _ when type_of_expr a <> None -> + | a :: _ when type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None -> fail loc "(map-new) names a key and no value — write both, as (map-new string \ i32)" @@ -8596,7 +9144,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = fail (List.hd args).Ast.loc "%s takes a type, as in (%s i32)" name name; let a = List.hd args in let ty = - match type_of_expr a, a.Ast.e with + match type_of_expr ~generic:(Hashtbl.mem ctx.env.gstructs) a, a.Ast.e with | Some t, _ -> resolve ctx.env t | _, Ast.Var n -> resolve_name ctx.env ~seen:[] a.Ast.loc n | _ -> fail a.Ast.loc "internal: %s's type argument is not a type" name @@ -10266,7 +10814,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = checked with [t] concrete. One generic argument defers the whole call: the printers for its neighbours would be re-selected at instantiation anyway, so building them here would be work thrown away twice. *) - if List.exists (fun a -> generic_ty a.Tast.ty) checked then + if List.exists (fun a -> open_ty a.Tast.ty) checked then mk loc Types.Unit Tast.Unit else let bslice = Types.Slice (Types.Mut, (Types.Int Types.U8)) in @@ -10295,7 +10843,20 @@ and named_call ?(qualified = false) ctx ~want loc name args = match a.Tast.ty with | Types.String | Types.Slice (_, (Types.Int Types.U8)) -> [ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ a ]))) ] - | _ -> Render.render rc 0 a + (* The walk names the value once per piece it reads — an option's tag + and then its payload, each field of a struct — so anything but a + plain variable is bound to a slot first, or [(println (pop! s))] + pops once per piece. *) + | _ -> + (match a.Tast.e with + | Tast.Local _ | Tast.Global _ -> Render.render rc 0 a + | _ -> + let s = fresh_slot ctx a.Tast.ty in + [ mk loc Types.Unit + (Tast.Let + ([ (s, a) ], + Render.render rc 0 (mk a.Tast.loc a.Tast.ty (Tast.Local s)))) + ]) in (* Built fresh per use rather than shared: nothing else in this file puts one node in two places of a tree, and a pass that hangs state off a @@ -10338,7 +10899,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = arity ctx loc name 2 args; let label = check ctx ~want:Types.String (List.hd args) in let v = check ctx (List.nth args 1) in - if generic_ty v.Tast.ty then mk loc Types.Unit Tast.Unit + if open_ty v.Tast.ty then mk loc Types.Unit Tast.Unit else begin let unit_rt sym args = mk loc Types.Unit (Tast.Prim (Tast.Rt sym, args)) in let bslice = Types.Slice (Types.Mut, (Types.Int Types.U8)) in @@ -10634,6 +11195,10 @@ and ordinary_call ctx ~want loc name args = name dname dname c.Tast.vname dname c.Tast.vname else if Hashtbl.mem ctx.env.structs name then positional_struct ctx ~want loc name args + else if Hashtbl.mem ctx.env.gstructs name then + positional_struct ctx ~want loc + (generic_ctor ctx ~want loc name + (`Positional args)) args else if List.mem_assoc name operator_aliases then (* Asked before the package test, because [/=] and [=/=] have a slash in them and are not package calls. The did-you-mean cannot reach @@ -10763,10 +11328,10 @@ and ordinary_call ctx ~want loc name args = same thing here so the answer does not depend on which side of the fork the form fell down. *) Loc.failk "check/unknown-function" loc - "unknown function %s. A capitalised name is a type, and (%s \ - ...) is a generic type, which is not there yet — a generic \ - function is, written with $t in its parameter vector" - name name + "unknown function %s. A capitalised name is a type, and no \ + struct or generic struct %s is declared — a generic struct is \ + one whose fields introduce $t, as in (defstruct %s [x $t])" + name name name else Loc.failk "check/unknown-function" loc "unknown function %s" name (* Does the program's own definition of this name take this call over? @@ -10920,9 +11485,14 @@ and generic_call ctx ~want loc name vars pats pret args = | Types.Var u -> String.equal u v | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e | Types.Option e -> mentions v e + | Types.LArray (u, e) -> String.equal u v || mentions v e | Types.Map (k, w) -> mentions v k || mentions v w | Types.Fn (ps, r) | Types.CFn (ps, r) -> List.exists (mentions v) ps || mentions v r + | Types.Named k -> + (match Hashtbl.find_opt struct_apps k with + | Some (_, args) -> List.exists (mentions v) args + | None -> false) | _ -> false in let bound_exactly v = @@ -10950,7 +11520,7 @@ and generic_call ctx ~want loc name vars pats pret args = the [sort-by] path below is untouched by construction. *) let bound_scalar = match pat with - | Types.Var v when (not (generic_ty p)) && Types.is_numeric p -> + | Types.Var v when (not (open_ty p)) && Types.is_numeric p -> Some v | _ -> None in @@ -10971,11 +11541,11 @@ and generic_call ctx ~want loc name vars pats pret args = let bound_view = match pat, p with | Types.Var v, (Types.Slice _ | Types.Ptr _) - when not (generic_ty p || bound_exactly v) -> Some v + when not (open_ty p || bound_exactly v) -> Some v | _ -> None in let a = - if generic_ty p || bound_view <> None then check ctx a + if open_ty p || bound_view <> None then check ctx a else if bound_scalar <> None && not untyped_literal then (* On its own terms first. A form that has no type without a want — [(zeroed)] is the one that matters — refuses here and is @@ -11180,7 +11750,8 @@ and generic_call ctx ~want loc name vars pats pret args = !subst; let cparams = List.map (subst_ty !subst) pats in let cret = subst_ty !subst pret in - if List.exists generic_ty cparams || generic_ty cret then begin + List.iter (realise ctx.env loc) (cret :: cparams); + if List.exists open_ty cparams || open_ty cret then begin (* One generic function calling another at its *own* variable, seen from the abstract pass over the caller's body — [sort-by] calling [swap] at [t]. There is no copy to make yet: [t] is not a type. The node is @@ -11209,7 +11780,7 @@ and generic_call ctx ~want loc name vars pats pret args = 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 (generic_ty t) && not (pred_holds p.Ast.pname t) -> + | Some t when not (open_ty t) && not (pred_holds p.Ast.pname t) -> Loc.failk "check/predicate-unsatisfied" loc "%s is written {:where (%s $%s)}, and this call passes %s, \ which is not %s" @@ -11284,13 +11855,17 @@ and instantiate env loc gname vars subst cparams cret = concrete as one written out by hand. The [where] clause goes out of scope with them — there is nothing abstract left for it to permit, and every operator is answered by the concrete type it now has. *) + let saved_lens = env.lenvars and saved_ph = env.len_placeholder in env.subst <- List.map (fun v -> (v, List.assoc v subst)) vars; env.tyvars <- []; + env.lenvars <- []; + env.len_placeholder <- false; env.tvpreds <- []; env.chain <- env.chain @ [ (gname, cparams, loc) ]; let restore () = env.subst <- saved_subst; env.tyvars <- saved_vars; - env.tvpreds <- saved_preds; env.chain <- saved_chain + env.tvpreds <- saved_preds; env.chain <- saved_chain; + env.lenvars <- saved_lens; env.len_placeholder <- saved_ph in if Hashtbl.mem env.refused_generics gname then begin restore (); @@ -12137,10 +12712,28 @@ let collect env (decls : Ast.decl list) = | None -> ()); Hashtbl.add claimed n d.Ast.dloc) decls; + (* A defstruct whose fields introduce a variable is a template. *) + let generic_fields (fs : Ast.field list) = + let vs, _, _ = + sigil_vars ~kinds_of:(fun _ -> None) + (List.map (fun (f : Ast.field) -> f.Ast.fty) fs) + in + vs <> [] + in + let gpending = Hashtbl.create 4 in (* Names first, so a struct may mention one declared below it. *) List.iter (fun (d : Ast.decl) -> match d.Ast.d with + | Ast.Defstruct (n, fs, parent) when generic_fields fs -> + (match parent with + | Some t -> + fail t.Ast.tloc + "%s is generic, and a condition struct is not — a handler \ + matches one type, and %s is a type only at its arguments" n n + | None -> ()); + Hashtbl.replace env.locs n d.Ast.dloc; + Hashtbl.replace gpending n (fs, d.Ast.dloc) | Ast.Defstruct (n, _, _) -> Hashtbl.replace env.locs n d.Ast.dloc; Hashtbl.replace env.structs n { Tast.sname = n; fields = [] } @@ -12181,6 +12774,26 @@ let collect env (decls : Ast.decl list) = | Ast.Defalias (n, t) -> Hashtbl.replace env.aliases n t | _ -> ()) decls; + (* Each template's parameters, which needs every other template's: a + template's length argument to another is a length of its own. A cycle + between templates reads the arguments on it as types; any length among + them is then refused where it is used. *) + let rec params_of visiting n = + match Hashtbl.find_opt env.gstructs n with + | Some g -> Some (List.map snd g.gparams) + | None -> + match Hashtbl.find_opt gpending n with + | None -> None + | Some _ when List.mem n visiting -> None + | Some (fs, gloc) -> + let _, _, vs = + sigil_vars ~kinds_of:(params_of (n :: visiting)) + (List.map (fun (f : Ast.field) -> f.Ast.fty) fs) + in + Hashtbl.replace env.gstructs n { gparams = vs; gfields = fs; gloc }; + Some (List.map snd vs) + in + Hashtbl.iter (fun n _ -> ignore (params_of [] n)) gpending; (* Compile-time integer constants next, to a fixpoint, because an array length may name a constant declared below it — top-level names in a package are order-independent (plan.org, Modules). *) @@ -12317,6 +12930,17 @@ let collect env (decls : Ast.decl list) = Hashtbl.replace env.externs fn.Ast.name csym; Hashtbl.replace env.extern_locs fn.Ast.name loc | Ast.Defalias _ -> () + | Ast.Defstruct (n, fs, _) when Hashtbl.mem env.gstructs n -> + 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 + fail loc "%s declares the same field twice" n; + (* The template is checked once, here, at its variables: an unknown + 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)) | 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 @@ -12437,7 +13061,7 @@ let collect env (decls : Ast.decl list) = signature: it goes in [gsigs] and the function goes nowhere near [fns], because nothing can be called at [t]. Every call site turns it into an ordinary entry. *) - let vars = signature_tyvars fn in + let vars, lens = signature_tyvars env fn in (* The [where] clause is checked against the signature here, once, rather than at every use of it: a predicate nobody has heard of, or one about a variable the signature never bound, is a mistake @@ -12455,18 +13079,35 @@ let collect env (decls : Ast.decl list) = (if vars = [] then " — it binds none" else " — it binds " - ^ String.concat ", " (List.map (fun v -> "$" ^ v) vars))) + ^ String.concat ", " (List.map (fun v -> "$" ^ v) vars)); + (* A where clause takes type predicates, and a length is not a + type. Whether it should take value predicates over one is + 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) fn.Ast.fwhere; env.tyvars <- vars; + env.lenvars <- lens; env.tvpreds <- fn.Ast.fwhere; - let params = - List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params + let params, ret = + Fun.protect + ~finally:(fun () -> + env.tyvars <- []; env.lenvars <- []; env.tvpreds <- []) + (fun () -> + let params = + List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) + fn.Ast.params + in + let ret = + match fn.Ast.ret with + | None -> Types.Unit + | Some t -> resolve env t + in + params, ret) in - let ret = - match fn.Ast.ret with None -> Types.Unit | Some t -> resolve env t - in - env.tyvars <- []; - env.tvpreds <- []; if fn.Ast.fprivate <> Ast.Exported then Hashtbl.replace env.privates fn.Ast.name (fn.Ast.nloc, fn.Ast.fprivate); @@ -12477,7 +13118,8 @@ let collect env (decls : Ast.decl list) = end else begin Hashtbl.replace env.generics fn.Ast.name fn; - Hashtbl.replace env.gsigs fn.Ast.name (vars, params, ret) + Hashtbl.replace env.gsigs fn.Ast.name (vars, params, ret); + Hashtbl.replace env.glens fn.Ast.name lens end | Ast.Defvar (n, t, _, k) -> let ty = match t with @@ -12548,36 +13190,7 @@ let collect env (decls : Ast.decl list) = it is inline. Caught here rather than when a backend tries to lay the type out or a zero value is built for it — which would not fail, it would hang. *) let check_finite env = - let rec walk seen name = - if List.mem name seen then - fail (Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown) - "%s contains itself by value, so it has no size — go through (Ptr %s)" - name name; - let seen = name :: seen in - match Hashtbl.find_opt env.structs name with - | Some s -> List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) s.Tast.fields - | None -> - match Hashtbl.find_opt env.datas name with - | Some u -> - List.iter - (fun (c : Tast.variant) -> - List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) c.Tast.vfields) - u.Tast.cases - | None -> - (* A union whose member is itself is the same infinite type a struct's - is — the size is the largest member and the largest member is the - whole thing. Nothing about overlaying storage makes the recursion - finite, so it is on the same walk rather than left to hang the - layout calculator. *) - match Hashtbl.find_opt env.unions name with - | None -> () - | Some u -> - List.iter (fun (f : Tast.field) -> ty seen f.Tast.fty) u.Tast.fields - and ty seen = function - | Types.Named n -> walk seen n - | Types.Array (_, e) | Types.Option e -> ty seen e - | _ -> () - in + let walk _ n = finite_from env n in Hashtbl.iter (fun n _ -> walk [] n) env.structs; Hashtbl.iter (fun n _ -> walk [] n) env.datas; Hashtbl.iter (fun n _ -> walk [] n) env.unions @@ -12758,8 +13371,30 @@ let rec check_fn env (fn : Ast.fn) : Tast.fn = and check_generic env (fn : Ast.fn) = let vars, params, ret = Hashtbl.find env.gsigs fn.Ast.name in let saved_lifted = env.lifted and saved_vars = env.tyvars - and saved_preds = env.tvpreds in + and saved_preds = env.tvpreds and saved_lens = env.lenvars + and saved_ph = env.len_placeholder in + (* The body sees a length variable's array at [abstract_len], an ordinary + array every array operation already answers for; the signature keeps + its [Types.LArray] for call sites to bind against. *) + let rec at_placeholder (t : Types.t) = + match t with + | Types.LArray (_, e) -> Types.Array (abstract_len, at_placeholder e) + | Types.Slice (m, e) -> Types.Slice (m, at_placeholder e) + | Types.Array (n, e) -> Types.Array (n, at_placeholder e) + | Types.Ptr (m, e) -> Types.Ptr (m, at_placeholder e) + | Types.Vec e -> Types.Vec (at_placeholder e) + | Types.Option e -> Types.Option (at_placeholder e) + | Types.Map (k, v) -> Types.Map (at_placeholder k, at_placeholder v) + | Types.Fn (ps, r) -> Types.Fn (List.map at_placeholder ps, at_placeholder r) + | Types.CFn (ps, r) -> + Types.CFn (List.map at_placeholder ps, at_placeholder r) + | t -> t + in + let params = List.map at_placeholder params and ret = at_placeholder ret in env.tyvars <- vars; + env.lenvars <- + Option.value (Hashtbl.find_opt env.glens fn.Ast.name) ~default:[]; + env.len_placeholder <- true; (* What the abstract pass may assume. Every operator the body reaches asks [env.tvpreds] whether the variable was declared to support it, and every instantiation asks the concrete type the same question again. *) @@ -12769,7 +13404,9 @@ and check_generic env (fn : Ast.fn) = Hashtbl.remove env.fns fn.Ast.name; env.lifted <- saved_lifted; env.tyvars <- saved_vars; - env.tvpreds <- saved_preds + env.tvpreds <- saved_preds; + env.lenvars <- saved_lens; + env.len_placeholder <- saved_ph in (match check_fn env fn with | _ -> finish () @@ -14036,7 +14673,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : |> List.sort (fun (a : Tast.extern) b -> String.compare a.Tast.esym b.Tast.esym) in let p = - { Tast.structs = values (fun (s : Tast.structure) -> s.Tast.sname) env.structs; + { Tast.structs = + (* A struct copy at variables was only ever for an abstract pass. *) + List.filter + (fun (s : Tast.structure) -> + Hashtbl.find_opt env.copies s.Tast.sname <> Some true) + (values (fun (s : Tast.structure) -> s.Tast.sname) env.structs); datas = values (fun (u : Tast.data) -> u.Tast.dname) env.datas; unions = values (fun (u : Tast.structure) -> u.Tast.sname) env.unions; globals; externs; fns; cshim } @@ -14128,6 +14770,24 @@ let lifted_since env mark = let fresh = List.length env.lifted - mark in List.rev (List.filteri (fun i _ -> i < fresh) env.lifted) +(* The struct copies this env made that [have] does not hold: what an + expression checked against a running session named for the first time — + [(Pair 1 2)] typed at a REPL makes [(Pair i32)] — which the module built + for it has to lay out, and the session has to keep. *) +let fresh_copies env (have : Tast.structure list) = + Hashtbl.fold + (fun k at_vars acc -> + if at_vars + || List.exists (fun (s : Tast.structure) -> String.equal s.Tast.sname k) + have + then acc + else + match Hashtbl.find_opt env.structs k with + | Some s -> s :: acc + | None -> acc) + env.copies [] + |> List.sort (fun (a : Tast.structure) b -> String.compare a.Tast.sname b.Tast.sname) + let env_structs env (fns : Tast.fn list) = List.filter_map (fun (f : Tast.fn) -> Hashtbl.find_opt env.structs ("env/" ^ f.Tast.name)) diff --git a/lib/cimport.ml b/lib/cimport.ml index 9fea9ebe..266879f5 100644 --- a/lib/cimport.ml +++ b/lib/cimport.ml @@ -407,6 +407,7 @@ let rec ty_source (t : Ast.texpr) = | Ast.Tname n -> n | Ast.Tapp (n, args) -> Printf.sprintf "(%s %s)" n (String.concat " " (List.map ty_source args)) + | Ast.Tlen n -> Int64.to_string n | Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (ty_source e) | Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (ty_source e) diff --git a/lib/dev.ml b/lib/dev.ml index 8c54e3e7..c4c78efc 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1819,8 +1819,27 @@ let defs t = ~loc:(Loc.to_string loc) ()) classes in + (* A generic struct is listed by its template, as [(Pair $t)]; its copies + are struct names only the compiler wrote. *) + let structs = + Hashtbl.fold + (fun name _ acc -> + if Hashtbl.mem env.Check.copies name then acc + else entry ~name ~kind:"struct" ~sign:name ~loc:"" () :: acc) + env.Check.structs [] + @ Hashtbl.fold + (fun name (g : Check.gstruct) acc -> + entry ~name ~kind:"struct" + ~sign: + (Printf.sprintf "(%s %s)" name + (String.concat " " + (List.map (fun (p, _) -> "$" ^ p) g.Check.gparams))) + ~loc:"" () + :: acc) + env.Check.gstructs [] + in List.sort compare - (of_table "struct" env.Check.structs + (structs @ datas @ classes @ of_table "union" env.Check.unions @ of_table "enum" env.Check.enums diff --git a/lib/emit.ml b/lib/emit.ml index 3572b27b..fac5022a 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -370,7 +370,7 @@ let rec ll (t : Types.t) = integer spelling costs no casts and keeps the emitter honest about not knowing whether the bits are a pointer. *) | Types.Dyn -> "i64" - | Types.Var _ -> + | Types.Var _ | Types.Len _ | Types.LArray _ -> (* The checker rejects it by name — nothing reaches here. *) internal "no layout for %s" (Types.to_string t) @@ -638,7 +638,8 @@ let rec lay m (t : Types.t) : int * int = | Some u -> union_lay m u | None -> internal "no layout for struct %s" n) | Types.Dyn -> 8, 8 - | Types.Var _ -> internal "no layout for %s" (Types.to_string t) + | Types.Var _ | Types.Len _ | Types.LArray _ -> + internal "no layout for %s" (Types.to_string t) (* Size, alignment, and the offset of every member. *) and lay_fields m tys = @@ -1175,7 +1176,7 @@ let rec dty m d (t : Types.t) : int = reading: it prints, and the person reading it can hand it to the runtime's own printer. *) | Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned" - | Types.Var _ -> + | Types.Var _ | Types.Len _ | Types.LArray _ -> internal "no debug type for %s" (Types.to_string t) in Hashtbl.replace d.dtys key n; diff --git a/lib/js.ml b/lib/js.ml index 221faf9e..921d4683 100644 --- a/lib/js.ml +++ b/lib/js.ml @@ -249,6 +249,8 @@ let rec refuse_ty loc (t : Types.t) = host's own, and that work has not been done" | Types.Var n -> at loc "a type variable (%s) reached the backend, which cannot happen" n + | Types.Len _ | Types.LArray _ -> + at loc "a length variable reached the backend, which cannot happen" (* Aggregates in the sense that matters here: the types whose assignment copies in Flan and would alias in JS. A slice is deliberately not one — diff --git a/lib/load.ml b/lib/load.ml index a6f70b98..724ebd4a 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -205,8 +205,11 @@ let rec rename_texpr owned alias (t : Ast.texpr) : Ast.texpr = Ast.Tarray (rename_len owned alias l, rename_texpr owned alias e) | Ast.Tmap (k, v) -> Ast.Tmap (rename_texpr owned alias k, rename_texpr owned alias v) + (* The head too, when it is a generic struct the package declares. *) | Ast.Tapp (n, args) -> + let n = if List.mem n owned then qualify alias n else n in Ast.Tapp (n, List.map (rename_texpr owned alias) args) + | Ast.Tlen _ as k -> k | Ast.Tfn (env, ps, r) -> Ast.Tfn (env, List.map (rename_texpr owned alias) ps, rename_texpr owned alias r) @@ -792,8 +795,11 @@ let rec texpr_uses acc (t : Ast.texpr) = (match l with Ast.Lname n -> acc := (n, t.Ast.tloc) :: !acc | Ast.Lint _ -> ()); texpr_uses acc e | Ast.Tmap (k, v) -> texpr_uses acc k; texpr_uses acc v - | Ast.Tapp (_, args) -> List.iter (texpr_uses acc) args + | Ast.Tapp (n, args) -> + acc := (n, t.Ast.tloc) :: !acc; + List.iter (texpr_uses acc) args | Ast.Tfn (_, ps, r) -> List.iter (texpr_uses acc) ps; texpr_uses acc r + | Ast.Tlen _ -> () let rec expr_uses acc (e : Ast.expr) = let go = expr_uses acc in diff --git a/lib/parse.ml b/lib/parse.ml index e5190994..6263645a 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -136,7 +136,25 @@ let rec texpr (f : Form.t) : Ast.texpr = 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 <> [] -> - mk (Ast.Tapp (name, List.map texpr args)) + (* 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] + in + let arg (a : Form.t) = + match a.v with + | Int n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc } + | _ -> texpr a + in + mk (Ast.Tapp (name, List.map arg args)) | _ -> fail f "expected a type, found %s" (Form.to_string f) and len (f : Form.t) : Ast.len = diff --git a/lib/session.ml b/lib/session.ml index 41d45d6f..1b3744e6 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -597,7 +597,7 @@ let compatible ~loc (old_ : Tast.program) (new_ : Tast.program) = if not same then fail loc "%s changes layout. Restart to change it." - s.Tast.sname + (Types.to_string (Types.Named s.Tast.sname)) | None -> ()) new_.Tast.structs @@ -2610,10 +2610,12 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = let placed = List.filter (fun (f : Tast.fn) -> List.mem f.Tast.name own) placed 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 @ placed; - structs = t.program.Tast.structs @ Check.env_structs t.env lifted; + structs = + t.program.Tast.structs @ copies @ Check.env_structs t.env lifted; externs = t.program.Tast.externs @ externs } in let ir = @@ -2639,7 +2641,10 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = caller closes that half by taking a [held] before this and restoring it when either fails — a copy the session holds and no module defines is a null cell exactly as a stranded declaration is. *) - 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 }; { ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] } (* ── What a macro call expands to ──────────────────────────────────── *) diff --git a/lib/shim.ml b/lib/shim.ml index c3070b04..bbcdd7be 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -256,6 +256,7 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = fail loc "%s is a function type, and a C callback is not implemented" what | Ast.Tapp (n, _) -> fail loc "%s is %s, which is not a type this shim generator knows" what n + | Ast.Tlen n -> fail loc "%s is %Ld, which is not a type" what n (* ── What one parameter does at the boundary ────────────────────────── *) diff --git a/lib/types.ml b/lib/types.ml index 6e2bb57d..328909f9 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -106,6 +106,15 @@ type t = | Fn of t list * t (* (Fn [T ...] R) *) | CFn of t list * t (* (CFn [T ...] R) *) | Var of string (* a type variable — milestone 5 *) + (* The two halves of a length parameter, and neither is the type of a value. + [Len] is a length standing where a generic struct's argument goes — the 8 + in (Small 8 i32) — and what a length variable is bound to. [LArray] is a + fixed array whose length is a variable, [[$n $t]], and exists only in a + generic signature, as the pattern a call site binds [n] from. A generic + body is checked with its lengths at [Check.abstract_len], so neither ever + reaches a backend. *) + | Len of int64 + | LArray of string * t (* [dyn]: one machine word whose contents the runtime knows and this module does not. It is a written type — [(defonce x dyn 5)] boxes the 5 — and it is also what an unannotated [defn] parameter means, which is why it is a @@ -206,8 +215,20 @@ let rec equal a b = && List.for_all2 equal ps ps' && equal r r' | Var x, Var y -> String.equal x y + | Len x, Len y -> Int64.equal x y + | LArray (n, x), LArray (m, y) -> String.equal n m && equal x y | _ -> false +(* How a generic struct's copy is spelled to a reader. The copy is an + ordinary struct under a symbol-safe key — [Small-8-i32] — and this is the + key's written form, [(Small 8 i32)], filled in as each copy is made. Global + rather than on a checker's env because every message that prints a type + comes through here with no env in hand. The key determines the spelling, + so an entry left from an earlier program in the same process is wrong only + for a struct that program's successor declares under a copy's key by hand, + and then only in how a message spells it. *) +let display : (string, string) Hashtbl.t = Hashtbl.create 16 + let rec to_string = function | Int k -> ikind_name k | Float k -> fkind_name k @@ -215,7 +236,8 @@ let rec to_string = function | String -> "string" | Unit -> "()" | Never -> "Never" - | Named n | Enum n -> n + | Named n -> (match Hashtbl.find_opt display n with Some d -> d | None -> n) + | Enum n -> n | Slice (Mut, t) -> "[" ^ to_string t ^ "]" | Slice (Const, t) -> "[const " ^ to_string t ^ "]" | Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t) @@ -232,6 +254,8 @@ let rec to_string = function Printf.sprintf "(CFn [%s] %s)" (String.concat " " (List.map to_string ps)) (to_string r) | Var n -> "$" ^ n + | Len n -> Int64.to_string n + | LArray (n, t) -> Printf.sprintf "[$%s %s]" n (to_string t) | Dyn -> "dyn" let is_numeric = function Int _ | Float _ -> true | _ -> false diff --git a/lib/x86.ml b/lib/x86.ml index bcf1ae79..f5327a4c 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -532,6 +532,7 @@ let is_agg (t : Types.t) = the arithmetic. *) | Types.Dyn -> false | Types.Var v -> unsupported "type variable %s" v + | Types.Len _ | Types.LArray _ -> unsupported "length variable" let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false diff --git a/test/programs/generic-struct.flan b/test/programs/generic-struct.flan new file mode 100644 index 00000000..564f804e --- /dev/null +++ b/test/programs/generic-struct.flan @@ -0,0 +1,89 @@ +;;;; Generic structs, end to end: type parameters and length parameters. +;;;; +;;;; A defstruct whose fields introduce $t is a template, and each set of +;;;; arguments it is given is a copy — an ordinary struct. A parameter is a +;;;; length when it stands in an array's length slot, and a type anywhere else; +;;;; the arguments are written in the order the fields first introduce them. +;;;; +;;;; Small is Odin's Small_Array: a fixed-capacity array with a count, and no +;;;; allocation anywhere. + +(defstruct Small [items [$n $t] count i32]) + +;; A generic function over a generic struct binds both of its parameters from +;; the argument, and reads the length back as a value. +(defn append! [s (Ptr (Small $n $t)) x $t] bool + (if (< (.count s) n) + (do (set (at (.items s) (.count s)) x) + (set (.count s) (+ (.count s) 1)) + true) + false)) + +(defn pop! [s (Ptr (Small $n $t))] (Option $t) + (if (= (.count s) 0) + None + (do (set (.count s) (- (.count s) 1)) + (Some (at (.items s) (.count s)))))) + +(defn capacity [s (Ptr (Small $n $t))] i32 n) + +(defn total [s (Ptr (Small $n $t))] $t {:where (numeric? $t)} + (let [acc (the $t 0)] + (dotimes [i (.count s)] + (set acc (+ acc (at (.items s) i)))) + acc)) + +;; A type parameter alone, built positionally with the type read off the +;; fields, and returned under a variable. +(defstruct Pair [a $t b $t]) + +(defn swapped [p (Pair $t)] (Pair $t) (Pair (.b p) (.a p))) + +;; A copy that names itself through a pointer, and a literal field that +;; takes its width from the one beside it. +(defstruct Node [v $t next (Option (Ptr (Node $t)))]) + +(defn sum-list [n (Ptr (Node i64))] i64 + (loop [at n acc (the i64 0)] + (let [acc (+ acc (.v at))] + (match (.next at) + (Some p) (recur p acc) + None acc)))) + +;; A template naming another at its own parameters. +(defstruct Twice [x (Small $m $u) y (Small $m $u)]) + +;; A length variable straight on an array parameter. +(defn len-of [a [$k $e]] i32 k) + +(defconst cap 3) + +(defn main [] i32 + (let [s (the (Small 4 i32) (zeroed)) + f (the (Small cap f64) (zeroed))] + (append! (addr s) 10) + (append! (addr s) 20) + (append! (addr s) 30) + (println (total (addr s)) (.count s) (capacity (addr s))) + (append! (addr f) 1.5) + (append! (addr f) 2.5) + (append! (addr f) 3.5) + (println (append! (addr f) 4.5) (total (addr f)) (capacity (addr f))) + (println (pop! (addr f)) (pop! (addr f)) (.count f)) + (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))) + (let [c (the (Node i64) {.v 3}) + b (Node 2 (Some (addr c))) + a (Node 1 (Some (addr b)))] + (println (sum-list (addr a)))) + (let [w (the (Twice 2 u8) (zeroed))] + (append! (addr (.y w)) 7) + (println (.count (.x w)) (.count (.y w)) (capacity (addr (.x w))))) + (println (len-of [1 2 3]) (len-of [1.5 2.5])) + (let [v (vec-new (Pair i32))] + (push v (Pair 5 6)) + (println (.b (at v 0))) + (free v)) + 0)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 4f08c8bf..d9921546 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3466,6 +3466,18 @@ let () = outputs "generics" "programs/generics.flan" generics_out; outputs ~opt:"-O0" "generics, -O0" "programs/generics.flan" generics_out; + (* Generic structs — see the program's header. The third line is two pops + printed in one call, which is also the pin for a printed call being + 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\ + 0 1 2\n3 2\n6\n" + in + outputs "generic structs" "programs/generic-struct.flan" generic_struct_out; + outputs ~x86:true "generic structs, --x86" "programs/generic-struct.flan" + generic_struct_out; + (* integer?, end to end — see the program's own header. The first eight lines are the collapsed abs at six widths and both signed minimums (which answer themselves; the negation wraps). The [0 0] after them is diff --git a/test/test_flan.ml b/test/test_flan.ml index d306b1d1..9d0ad68d 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1470,10 +1470,10 @@ let () = can actually be written there; the parameter-vector suggestion survives where it works, which the return-type pin further down exercises. *) rejects_check "a real type variable at a field" "(defstruct Holder [x elem])" - ~needle:"a field is built at one type for every value"; + ~needle:"in a defstruct's fields that makes the struct generic over it"; rejects_check "and the field message offers what a field can hold" "(defstruct Holder [x elem])" - ~needle:"Write a concrete type here, or dyn to hold any value"; + ~needle:"Write $elem, a concrete type, or dyn to hold any value"; rejects_check "an unknown concrete type" "(defn f [x Widget] ())" ~needle:"unknown type Widget"; @@ -2871,13 +2871,11 @@ let () = (* [(Pair i32)] in a defonce falls down the value fork now that the third element takes either reading, and the generics answer the type fork gave it has to be reachable from here too. *) - (* A capitalised head with arguments is a *type* given type arguments, and - that is the half of generics that is not built — Types.Named is a bare - string with no room for parameters. The sentence says which half, since - generic functions are here and pointing at them is the useful part. *) + (* A capitalised head with arguments is a *type* given type arguments; with + no such struct declared, the sentence says how one is. *) rejects_check "a capitalised call with arguments is a generic type" "(defonce x (Pair i32)) (defn f [] i32 0)" - ~needle:"is a generic type, which is not there yet"; + ~needle:"no struct or generic struct Pair is declared"; accepts "and the generic function it points at is" "(defn pair-fst [a $t b $u] $t (do b a))\n\ (defn main [] () (println (pair-fst 1 true)))"; @@ -6701,9 +6699,74 @@ let () = "(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. *) - rejects_check "a sigil in a struct field, where nothing can bind one" - ~needle:"only a defn signature can" - "(defstruct S [v $t])"; + rejects_check "a sigil in a data case's field, where nothing can bind one" + ~needle:"only a defn signature or a defstruct's fields can" + "(defdata D [(C [v $t])])"; + + (* ── Generic structs: what is refused, and where ─────────────────── *) + rejects_check "a generic struct given the wrong number of arguments" + ~needle:"Pair takes 1 argument, (Pair $t), and this gives 2" + "(defstruct Pair [a $t b $t]) (defn f [p (Pair i32 i64)] i32 0)"; + rejects_check "a generic struct named with no arguments" + ~needle:"Pair is generic, and a type only once it is given its arguments" + "(defstruct Pair [a $t b $t]) (defn f [p Pair] i32 0)"; + rejects_check "a type where a length argument goes" + ~needle:"Small's $n is a length" + "(defstruct Small [items [$n $t] count i32]) \ + (defn f [p (Small i32 4)] i32 0)"; + rejects_check "a length where a type argument goes" + ~needle:"Small's $t is a type, and 4 is a length" + "(defstruct Small [items [$n $t] count i32]) \ + (defn f [p (Small 4 4)] i32 0)"; + rejects_check "a negative length argument" + ~needle:"-1 is negative" + "(defstruct Small [items [$n $t] count i32]) \ + (defn f [p (Small -1 i32)] i32 0)"; + rejects_check "one variable as both a length and a type" + ~needle:"$t stands for a length in one place here and a type in another" + "(defstruct Bad [x $t y [$t i32]])"; + rejects_check "a length variable where a type goes" + ~needle:"n is a length, not a type" + "(defn f [a [$n i32]] i32 (let [x (the n 0)] 0))"; + rejects_check "a where clause over a length variable" + ~needle:"$n is a length, and a where clause takes type predicates only" + "(defn f [a [$n i32]] i32 {:where (numeric? $n)} 0)"; + rejects_check "a generic struct that contains itself by value" + ~needle:"(Loop $t) contains itself by value" + "(defstruct Loop [next (Loop $t)])"; + rejects_check "a generic struct that asks for bigger copies of itself" + ~needle:"Grow names a copy of itself at a type built around its own" + "(defstruct Grow [next (Ptr (Grow [$t]))]) (defn f [p (Grow i32)] i32 0)"; + rejects_check "a copy whose key is already a struct's name" + ~needle:"Pair at these arguments is called Pair-i32, and Pair-i32 is \ + already defined" + "(defstruct Pair [a $t b $t]) (defstruct Pair-i32 [x i32]) \ + (defn f [p (Pair i32)] i32 0)"; + rejects_check "a generic struct literal whose fields decide nothing" + ~needle:"Pair's $t is not decided by the fields given here" + "(defstruct Pair [a $t b $t]) (defn f [] i32 (let [p (Pair {})] 0))"; + rejects_check "two fields that disagree about the variable" + ~needle:"(Pair $t)'s .b is i32 here, and this is f64" + "(defstruct Pair [a $t b $t]) \ + (defn f [] i32 (let [p (Pair (the i32 1) (the f64 2.5))] 0))"; + accepts "a literal field takes its width from a typed one beside it" + "(defstruct Pair [a $t b $t]) \ + (defn f [] f64 (let [p (Pair 1 (the f64 2.5))] (.a p)))"; + rejects_check "a generic struct as a condition" + ~needle:"Pair is generic, and a condition struct is not" + "(defstruct Pair :parent Error [a $t])"; + rejects_check "an operator a generic body's struct field does not support" + ~needle:"+ over the type variable $t" + "(defstruct Pair [a $t b $t]) (defn f [p (Pair $t)] $t (+ (.a p) (.b p)))"; + accepts "the same body with the predicate declared" + "(defstruct Pair [a $t b $t]) \ + (defn f [p (Pair $t)] $t {:where (numeric? $t)} (+ (.a p) (.b p))) \ + (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))"; + accepts "a defonce of a generic struct's copy" + "(defstruct Pair [a $t b $t]) (defonce g (Pair i32)) \ + (defn main [] i32 (.a g))"; (* ── The builtin table against the arms it describes ────────────── [Check.builtins] is what the editor's C-c C-v and M-. read for a name no diff --git a/test/test_session.ml b/test/test_session.ml index 5af415c9..73ff7f35 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -354,6 +354,26 @@ let () = | exception Loc.Error { Loc.dmsg = m; _ } -> fail "the session was poisoned by a bad expression: %s" m); + (* A generic struct's copy first named by an expression typed at the + session: the module built for it has to lay the copy out, and the + session keeps it, as it keeps a generic function's copy. *) + (let gt, _ = Session.create ~file:"programs/reload.flan" () in + (match Session.eval gt "(defstruct Pair [a $t b $t])" with + | _ -> () + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a generic struct was refused at the session: %s" m); + match Session.eval_expr gt "(println (.b (Pair 7 8)))" with + | e -> + if not (has e.Session.ir "%\"Pair-i32\" = type") then + fail "the expression's module did not carry the struct copy"; + if not + (List.exists + (fun (s : Tast.structure) -> String.equal s.Tast.sname "Pair-i32") + gt.Session.program.Tast.structs) + then fail "the session did not keep the struct copy an expression made" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "an expression 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