diff --git a/TODO.org b/TODO.org index 87c5a67c..b2cfc7d6 100644 --- a/TODO.org +++ b/TODO.org @@ -302,6 +302,14 @@ keyword resolves against the expected type and against nothing else, so two enum could always share a member spelling. What the prefix buys is the call site read on its own. +** WAIT ML-style patterns +Held 2026-09-25 as a future direction, like the JS backend: nested destructuring, +guards, or-patterns, literals at any depth, exhaustiveness over the nesting. + +** NEXT match over numbers and strings +Decided 2026-09-25: a match arm's pattern can be an integer, a float, a char or a +string literal, compared as =(= t lit)=; a match over such a type needs a =_= arm. + ** DONE match over enums CLOSED: [2026-09-25] =Ast.Pkw= is the keyword pattern; =Check.check_match= resolves it against the @@ -643,6 +651,10 @@ of !=. * Checker +** WAIT A _ body that returns an fn literal +Refused today; allowing it when the literal writes its parameter types is the +proposal. Postponed 2026-09-25 while .fln takes priority. + ** DONE The ownership flow analysis is repealed CLOSED: [2026-09-18] Static use-after-move and double-free checking is gone; types, allocators and the @@ -742,15 +754,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. @@ -759,12 +766,6 @@ clause here admits nothing but type predicates. Whether it should take value predicates over a length parameter deserves answering deliberately rather than falling out of the implementation. -** TODO "In instantiation of" notes -A refusal inside a copy points at the generic's source with no note naming the -call site that asked for that type. The data is there — =instantiation_origin= -exists and the session already uses it — and wiring it into every failure under an -instantiation is a lane of its own. - ** DONE A program is one compilation, so a generic's body is always visible CLOSED: [2026-09-25] Odin's and Zig's model: packages are never compiled separately. The cost is build @@ -989,15 +990,6 @@ ignore order, writable access has to alias the real storage. Flexible field orde waits for classes deliberately, because a class owns its layout and a =Vector2= should not pay for identity and metadata. Not implemented. -** TODO An error in a called generic's body is reported twice -=(defn g [x $t] u64 (nosuch x))= called once from =main= prints "unknown -function nosuch" twice at the same place and counts 2 errors — once from the -abstract pass and once from the instantiation. - -** TODO A type variable is printed without its $ -=Types.to_string= prints =Var t= as =t=, so a refusal reads "selection-sort -expects [t] here, found [3 i32]" where the source wrote =[$t]=. - ** DONE Two refusals suggested something that does not compile CLOSED: [2026-09-25] =vec-new= and =map-new= with no type no longer say "or give the binding a type"; @@ -1452,6 +1444,11 @@ out the first element typing the rest. * Dev loop +** WAIT A _ caller whose type follows a redefined callee +Its signature changes in the session but its body is not recompiled, so every call +stops on StaleCall naming a type nobody wrote. Proposal: recompile such callers. +Postponed 2026-09-25 while .fln takes priority. + ** TODO A prelude function shadowed live is reached by the prelude's own calls A defn of a prelude function's name sent to a running =flan dev= installs into the host's cell for that name, so the prelude's calls compiled into the host follow it; diff --git a/lib/ast.ml b/lib/ast.ml index 61dd2185..7d1a589f 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -29,6 +29,9 @@ and texpr_kind = constructor rather than [ret = None] because [None] already means () for [declare] and the shim. *) | Tinfer + (* 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 94812188..e633bc81 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -79,6 +79,54 @@ 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 + 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; @@ -192,13 +240,47 @@ type env = { chain. Odin has no cap of its own to copy, so there was nothing to borrow. *) mutable chain : (string * Types.t list * Loc.t) list; + (* Generics whose abstract pass was refused and recorded, in a whole-file + check that goes on after a refusal. A call site still gets a copy's + signature, but its body is not checked again: every refusal the abstract + 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; + (* Templates whose own check was refused while [deferred] was collecting: + a use of one is a copy with no fields, so the refusal is said once, at + the defstruct, and nothing downstream repeats it. *) + broken : (string, unit) Hashtbl.t; + (* While a whole-file check collects every error, the refusals [collect] + can go on past — a generic struct's template, a where clause over a + length — are kept here instead of ending the pass. [None] everywhere + else, where they raise as before. *) + mutable deferred : Loc.diag list option; + (* A generic defn's length variables, by name: the ones of its [gsigs] + variables that are lengths. *) + glens : (string, string list) Hashtbl.t; + (* 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 @@ -261,6 +343,15 @@ let new_env () = { subst = []; tvpreds = []; chain = []; + refused_generics = Hashtbl.create 4; + gstructs = Hashtbl.create 4; + copies = Hashtbl.create 8; + broken = Hashtbl.create 2; + deferred = None; + glens = Hashtbl.create 8; + lenvars = []; + len_placeholder = false; + schain = []; in_field = false; classes = Hashtbl.create 8; tracks = Hashtbl.create 16; @@ -273,6 +364,13 @@ let new_env () = { guard_next = false; } +(* A refusal [collect] can go on past: kept while a whole-file check is + collecting, in the order found, and raised otherwise. *) +let defer_or_raise env (d : Loc.diag) = + match env.deferred with + | Some l -> env.deferred <- Some (d :: l) + | None -> Loc.raise_diag d + (* Where a named type was declared, and what it has, as a note. This is the second half of the two-place messages: a refusal that says @@ -283,6 +381,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 -> @@ -298,8 +403,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 ] @@ -1237,6 +1342,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 @@ -1276,7 +1494,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 @@ -1340,15 +1568,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. *) @@ -1365,9 +1588,169 @@ 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 ?(at_definition = false) env loc name targs = + let key = struct_app name targs in + if Hashtbl.mem env.copies key then key + else if Hashtbl.mem env.broken name then begin + Hashtbl.replace env.copies key (List.exists generic_arg targs); + Hashtbl.replace env.structs key { Tast.sname = key; fields = [] }; + key + end + else begin + if Hashtbl.mem env.structs key || Hashtbl.mem env.datas key + || Hashtbl.mem env.unions key then + 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; + (* 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 && not at_definition -> + 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? *) +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 @@ -1401,12 +1784,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 @@ -1425,17 +1815,17 @@ 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, \ - 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 @@ -1465,6 +1855,21 @@ 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 + (* 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. @@ -1502,18 +1907,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 \ @@ -1525,7 +1928,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 \ @@ -1556,6 +1971,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 @@ -1935,6 +2351,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. *) @@ -2111,9 +2528,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"; @@ -2123,25 +2540,60 @@ 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.Tinfer -> () + | 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 @@ -2210,6 +2662,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 -> + (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_ + | _ -> Types.fits ~expected:pat ~actual:arg) (* 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 @@ -2226,12 +2689,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 @@ -2239,6 +2719,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 @@ -2272,36 +2783,12 @@ let unconstrained env loc op ~needs (t : Types.t) = | _ -> Loc.failk "check/unconstrained-type-variable" loc "%s over the type variable %s: nothing declares %s %s. Write \ - {:where (%s $%s)} at the head of the body, or take the operation as \ + {:where (%s %s)} at the head of the body, or take the operation as \ a parameter, a (Fn [%s %s] ...), and call it here" op (Types.to_string t) (Types.to_string t) needs needs (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) - | 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 @@ -2328,23 +2815,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 " @@ -3190,7 +3660,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 = @@ -3857,7 +4328,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" @@ -4593,14 +5064,14 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = | Some (Types.Int k) -> not (Types.signed k) | _ -> false) -> let t = Option.get want in - let gname, _, at = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in + (* [instantiate] adds the note naming the call that asked for this copy. *) + let gname, _, _ = List.nth ctx.env.chain (List.length ctx.env.chain - 1) in let var = match List.find_opt (fun (_, u) -> Types.equal u t) ctx.env.subst with | Some (v, _) -> Printf.sprintf "$%s = %s" v (Types.to_string t) | None -> Types.to_string t in Loc.failk literal_at_want loc - ~notes:[ Loc.note at (Printf.sprintf "%s is instantiated at %s here" gname var) ] "%Ld does not fit in %s, which holds no negative number, and %s is called \ at %s — the body has to work at every type it is called at, so write \ it with no negative literal, as in (- x %Ld) in place of (+ x %Ld)" @@ -4744,6 +5215,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 @@ -4896,7 +5384,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)))) @@ -6622,6 +7110,167 @@ 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 + (* 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 + (* Which field's value decided each variable, for the refusal of a + literal that does not fit what it decided. *) + let decided_by = ref [] in + List.iter + (fun ((f : Tast.field), (a : Ast.expr)) -> + match f.Tast.fty with + (* A literal at a variable a typed field already decided: it has to + be usable at that type, and when it is not the refusal names the + field that decided it. *) + | Types.Var v + when literal a && List.mem_assoc v !subst + && not (List.mem v !lit_only) -> + let b = List.assoc v !subst in + (match a.Ast.e, b with + | Ast.Float x, Types.Int _ -> + let notes = + match List.assoc_opt v !decided_by with + | Some (fname, at) -> + [ Loc.note at + (Printf.sprintf ".%s is %s here, which decides $%s" fname + (Types.to_string b) v) ] + | None -> [] + in + Loc.failk "check/generic-struct-field" a.Ast.loc ~notes + "%s's .%s is $%s, which is %s here, and %g is a float literal. \ + Write .%s as an integer, or give .%s a float type" + name f.Tast.fname v (Types.to_string b) x f.Tast.fname + (match List.assoc_opt v !decided_by with + | Some (fname, _) -> fname + | None -> f.Tast.fname) + | _ -> ()) + | Types.Var v when literal a && not (List.mem_assoc v !subst && not (List.mem v !lit_only)) -> + let t = (literal_type a) in + (match List.assoc_opt v !subst with + | 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 + 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 -> + let before = !subst in + if bind_ty subst f.Tast.fty t then + List.iter + (fun (v, _) -> + if not (List.mem_assoc v before) then + decided_by := (v, (f.Tast.fname, a.Ast.loc)) :: !decided_by) + !subst + else + fail a.Ast.loc "%s's .%s is %s here, and this is %s" + (Types.to_string (Types.Named open_key)) f.Tast.fname + (Types.to_string (subst_ty !subst f.Tast.fty)) + (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, 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) + (* [(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 @@ -6651,6 +7300,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 @@ -6658,15 +7315,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 @@ -6691,7 +7348,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 }) | Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d) @@ -6752,6 +7409,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 -> @@ -6827,7 +7487,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))) @@ -7163,9 +7823,7 @@ and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = (Printf.sprintf "this array's first element is %s, so every \ element is" - (match first.Tast.ty with - | Types.Var v -> "$" ^ v - | t -> Types.to_string t)) ] })) + (Types.to_string first.Tast.ty)) ] })) rest; raise (Loc.Error d) @@ -8034,7 +8692,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) @@ -8651,7 +9309,7 @@ and global_value ctx n = (* 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 (global_value ctx n) && type_named ctx n @@ -8684,8 +9342,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 (global_value ctx n) && type_named ctx n -> Some (resolve_name ctx.env ~seen:[] loc n, rest) @@ -8706,12 +9367,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 @@ -8735,6 +9396,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. *) @@ -8755,7 +9428,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 @@ -8763,7 +9436,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)" @@ -9250,7 +9923,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 @@ -11045,7 +11718,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 @@ -11074,7 +11747,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 @@ -11117,7 +11803,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 @@ -11438,6 +12124,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 @@ -11567,10 +12257,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? @@ -11724,9 +12414,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 = @@ -11754,7 +12449,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 @@ -11775,11 +12470,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 @@ -11984,7 +12679,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 @@ -12010,10 +12706,10 @@ 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 (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" @@ -12088,14 +12784,22 @@ 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 (); + sym + end else let tfn = (* Without recovery: a copy that does not check is refused whole, at the call that asked for it, as it always was. *) @@ -12103,6 +12807,60 @@ and instantiate env loc gname vars subst cparams cret = | tfn -> restore (); tfn | exception e -> restore (); + (* The refusal is inside the generic's source, which says nothing about + which call asked for this copy; the note names it. Nested copies + each add their own, so the notes walk the chain back to the call + the programmer wrote. *) + let at () = + String.concat ", " + (List.map + (fun v -> Printf.sprintf "$%s = %s" v + (Types.to_string (List.assoc v subst))) + vars) + in + let in_prelude (l : Loc.t) = String.equal l.Loc.file Prelude.file in + let e = + match e with + (* A prelude generic's body is source nobody at this call wrote, and + an editor cannot jump to it. The refusal moves to the call that + 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: 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 ("in the prelude, " ^ reason) ]; + expansion = None }) + | Loc.Error d when d.Loc.dloc <> loc -> + Loc.Error + (Loc.sort_notes + { d with + Loc.notes = + d.Loc.notes + @ [ Loc.note loc + (Printf.sprintf "%s is instantiated at %s here" + gname (at ())) ] }) + | e -> e + in (* A copy whose body did not check is not a copy. Both entries go back out, so a second call at the same types is the same refusal again rather than a cache hit on a function that does not exist. *) @@ -12921,10 +13679,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 = [] } @@ -12965,6 +13741,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). *) @@ -13101,6 +13897,22 @@ 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 + (match + struct_copy ~at_definition:true env loc n + (List.map (fun (p, _) -> Types.Var p) g.gparams) + with + | _ -> () + | exception Loc.Error d -> + Hashtbl.replace env.broken n (); + defer_or_raise env d) | Ast.Defstruct (n, fs, parent) -> let names = List.map (fun (f : Ast.field) -> f.Ast.fname) fs in if List.length (List.sort_uniq compare names) <> List.length names then @@ -13221,7 +14033,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 @@ -13239,30 +14051,59 @@ 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 + defer_or_raise env + (Loc.diag ~kind:"check/length-predicate" p.Ast.ploc + (Printf.sprintf + "$%s is a length, and a where clause takes type \ + predicates only — %s is about a type" + p.Ast.pvar p.Ast.pname))) fn.Ast.fwhere; + (* A predicate over a length was refused above; what is left is the + clause every copy is judged against. *) + let fn = + { fn with + Ast.fwhere = + List.filter + (fun (p : Ast.pred) -> not (List.mem p.Ast.pvar lens)) + fn.Ast.fwhere } + in env.tyvars <- vars; + env.lenvars <- lens; env.tvpreds <- fn.Ast.fwhere; - 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 -> Some Types.Unit + (* Read off the body by [infer_returns], once every + written signature is in [fns]; until then the name + has none. *) + | Some { Ast.t = Ast.Tinfer; tloc } -> + if vars <> [] then + Loc.failk "check/infer-generic" tloc + "%s is generic, and _ asks for its return type to be \ + read off one body — but each call site makes its own \ + copy. Write the return type, in terms of the $ \ + variables" + fn.Ast.name; + None + | Some t -> Some (resolve env t) + in + params, ret) in - let ret = - match fn.Ast.ret with - | None -> Some Types.Unit - (* Read off the body by [infer_returns], once every written - signature is in [fns]; until then the name has none. *) - | Some { Ast.t = Ast.Tinfer; tloc } -> - if vars <> [] then - Loc.failk "check/infer-generic" tloc - "%s is generic, and _ asks for its return type to be read \ - off one body — but each call site makes its own copy. \ - Write the return type, in terms of the $ variables" - fn.Ast.name; - None - | Some t -> Some (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); @@ -13276,7 +14117,8 @@ let collect env (decls : Ast.decl list) = else begin let ret = Option.get ret in 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 @@ -13347,37 +14189,11 @@ 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 - Hashtbl.iter (fun n _ -> walk [] n) env.structs; + let walk _ n = finite_from env n in + (* A generic struct's copy was asked this when it was made. *) + Hashtbl.iter + (fun n _ -> if not (Hashtbl.mem env.copies n) then walk [] n) + env.structs; Hashtbl.iter (fun n _ -> walk [] n) env.datas; Hashtbl.iter (fun n _ -> walk [] n) env.unions @@ -13667,8 +14483,30 @@ let rec check_fn ?sign 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. *) @@ -13678,7 +14516,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 () @@ -15140,6 +15980,7 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : time it runs every signature is sound, so a body that fails to check cannot make the next body fail — which is what makes a declaration a resync point that needs no resynchronising. *) + if keep_going then env.deferred <- Some []; grow_warnings := []; let decls = collect env decls in if !print_warnings then @@ -15152,6 +15993,9 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : check_union_members env; infer_returns ~keep_going ?tolerate ?previous env decls; let s = Loc.sink ~on:keep_going in + (match env.deferred with + | Some ds -> s.Loc.found <- ds; env.deferred <- None + | None -> ()); ignore (Loc.caught s (fun () -> check_main env decls)); (* Every generic body, checked once with its variables left abstract, and the result thrown away. This is the pass plan.org's rule needs and Odin @@ -15166,11 +16010,14 @@ let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name -> - ignore - (Loc.caught s (fun () -> + (match + Loc.caught s (fun () -> tolerant fn.Ast.name (fun () -> with_recovery env ~on:keep_going (fun () -> - Some (check_generic env fn))))) + Some (check_generic env fn)))) + with + | None -> Hashtbl.replace env.refused_generics fn.Ast.name () + | Some _ -> ()) | _ -> ()) decls; let globals = @@ -15254,7 +16101,12 @@ let build_program ~keep_going ?tolerate ?previous (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 } @@ -15347,6 +16199,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 4b47262e..e1df2a27 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 45ff7cc6..47010f6f 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -704,14 +704,12 @@ let host_loc t name = that was written finds nothing in the program, and these are how it gets from that name to what the program does hold. *) -(* Its signature as written, [$] and all — [Types.to_string] prints a variable - bare, and [[t]] is not how anyone wrote it. *) +(* Its signature as written, [$] and all. *) let generic_signature t name = match Hashtbl.find_opt t.session.Session.env.Check.gsigs name with | None -> None - | Some (vars, params, ret) -> - let dollar = List.map (fun v -> (v, Types.Var ("$" ^ v))) vars in - let show ty = Types.to_string (Check.subst_ty dollar ty) in + | Some (_, params, ret) -> + let show ty = Types.to_string ty in Some (Printf.sprintf "%s [%s] %s" name (String.concat " " (List.map show params)) (show ret)) @@ -1917,8 +1915,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 @@ -1999,13 +2016,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/emit.ml b/lib/emit.ml index 640078e6..01b82b72 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) @@ -647,7 +647,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 = @@ -1210,7 +1211,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 74f86563..a8f01620 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 906b4b50..d71e95e0 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -213,8 +213,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) @@ -801,9 +804,12 @@ 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.Tinfer -> () + | 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 14a9e68e..65460adb 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -99,6 +99,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 @@ -162,8 +172,44 @@ 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 <> [] -> - mk (Ast.Tapp (name, List.map texpr 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 = 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, 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)) | _ -> fail f "expected a type, found %s" (Form.to_string f) and len (f : Form.t) : Ast.len = diff --git a/lib/render.ml b/lib/render.ml index c5cf9f6d..5cf3f33f 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -103,6 +103,12 @@ let print_refusal _loc t = Printf.sprintf "no printer for %s — print the values you want out of it" (Types.to_string t) +(* The head a struct value prints under: its name, or for a generic struct's + copy the template and its arguments, [Pair i32], so the value reads + [(Pair i32 {.a 1 .b 2})] the way its type is written. Every renderer of a + struct value goes through this, so they all print the same text. *) +let head n = Types.struct_head n + let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr list = let render c depth e = render ~refuse c depth e in let loc = e.Tast.loc in @@ -333,7 +339,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 ("(" ^ 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 4919a57a..a0a4e96a 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -616,7 +616,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 @@ -1629,7 +1629,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 []; @@ -1741,7 +1741,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 []; @@ -2002,7 +2002,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 []; @@ -2319,7 +2319,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 = @@ -2356,11 +2356,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 = @@ -2373,7 +2377,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)))) @@ -2445,7 +2451,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 []; @@ -2486,17 +2492,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) @@ -2529,7 +2540,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 []; @@ -2715,7 +2726,7 @@ let eval_expr ?(origin = "") ?(pause = false) ?frame 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 []; @@ -2761,10 +2772,12 @@ let eval_expr ?(origin = "") ?(pause = false) ?frame 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 = @@ -2790,7 +2803,10 @@ let eval_expr ?(origin = "") ?(pause = false) ?frame 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 26be806b..f29f9d85 100644 --- a/lib/shim.ml +++ b/lib/shim.ml @@ -177,6 +177,107 @@ 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 _ | Ast.Tinfer -> () + 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.Tinfer -> "_" + | 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 _ | Ast.Tinfer -> 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 +285,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 @@ -258,6 +367,7 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = fail loc "%s is _, and a C signature writes every type out" 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 ────────────────────────── *) @@ -270,6 +380,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) @@ -547,6 +665,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 3513621f..a6f25857 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,29 @@ 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 + +(* 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 @@ -215,7 +245,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) @@ -231,7 +262,9 @@ let rec to_string = function | CFn (ps, r) -> Printf.sprintf "(CFn [%s] %s)" (String.concat " " (List.map to_string ps)) (to_string r) - | Var n -> n + | 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 10b3b60a..6b409272 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -533,6 +533,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..f295fbd8 --- /dev/null +++ b/test/programs/generic-struct.flan @@ -0,0 +1,109 @@ +;;;; 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)) + +;; One generic over the struct calling another at its own variables. +(defn append-all! [s (Ptr (Small $n $t)) xs [$t]] () + (dotimes [i (length xs)] + (append! s (at xs i)))) + +(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 copy as a map key, and a named function over one handed where a +;; function value is wanted. +(defn pair-sum [p (Pair i32)] i32 (+ (.a p) (.b p))) +(defn apply-to [f (Fn [(Pair i32)] i32) p (Pair i32)] i32 (f p)) + +;; 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)) + (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)))] + (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)) + (let [t (the (Small 5 i64) (zeroed)) + xs (the [3 i64] [1 2 3])] + (append-all! (addr t) (slice xs)) + (println (total (addr t)) (.count t))) + (let [m (map-new (Pair i32) i32)] + (put m (Pair 1 2) 12) + (put m (Pair 3 4) 34) + (println (get m (Pair 3 4)) (get m (Pair 2 1)) (apply-to pair-sum (Pair 7 8))) + (free m)) + 0)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 71bc029f..29f9a0b3 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -3523,6 +3523,19 @@ 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\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; + 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 @@ -3665,7 +3678,7 @@ let () = chain of instantiations and not a depth it gave up at. *) refuses "an unconstrained operator in a generic body" "programs/generic-reject.flan" - "nothing declares t numeric?"; + "nothing declares $t numeric?"; refuses "an unconstrained operator names the way out" "programs/generic-reject.flan" "{:where (numeric? $t)}"; refuses "a runaway instantiation" "programs/generic-runaway.flan" @@ -4279,6 +4292,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 @@ -4785,10 +4828,10 @@ level "1" the easier of the two to leave open. *) refuses "a nested function type does not widen" "programs/fn-generic-nested.flan" - "hof expects (Fn [(Fn [t] t)] i32) here"; + "hof expects (Fn [(Fn [$t] $t)] i32) here"; refuses "and neither does one in return position" "programs/fn-generic-nested-return.flan" - "call-twice expects (Fn [] (Fn [] t)) here"; + "call-twice expects (Fn [] (Fn [] $t)) here"; outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan" fn_capture_out; diff --git a/test/test_dev.ml b/test/test_dev.ml index 2fbffd7f..6789224b 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -802,6 +802,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 ea94d0d5..9527f95d 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1417,7 +1417,7 @@ let () = accepts "all-distinct over a type variable" "(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))"; rejects_check "a chain still wants the right predicate" - ~needle:"nothing declares t ordered?" + ~needle:"nothing declares $t ordered?" "(defn between [a $t b $t c $t] bool {:where (equal? $t)} (< a b c))"; (* One operand and none. Both would have to be [true] whatever they were handed, which is a typo carrying a value. *) @@ -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"; @@ -2873,13 +2873,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)))"; @@ -6187,6 +6185,110 @@ let () = check "and they are in source order" (List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2; 3 ])); + (* A generic whose abstract pass was refused is not checked again at each + copy: the refusal is one error, however many types call it, and the + caller's own later refusal is still found. *) + (match + Check.program_all + (Parse.program_all + (read "(defn g [x $t] u64 (nosuch x))\n\ + (defn main [] i32 (g 3) (g true) nope 0)\n")) + with + | _ -> check "a refused generic body is refused" false + | exception Loc.Errors ds -> + check "a refused generic body is one error, and its caller's is another" + (List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2 ])); + + (* A refusal inside a copy names the call that asked for it, and each copy + between: the chain walks back to the line the programmer wrote. *) + (match + checked + "(defn show [v $t] () (println v)) \ + (defn outer [v $t] () (show v)) \ + (defn main [] i32 (outer main) 0)" + with + | _ -> check "a copy with no printer is refused" false + | exception Loc.Error d -> + let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in + check "a refusal in a copy names both instantiations" + (contains d.Loc.dmsg "no printer for" + && notes + = [ "show is instantiated at $t = (CFn [] i32) here"; + "outer is instantiated at $t = (CFn [] i32) here" ])); + + (* A refusal made while collecting declarations — a generic struct that + holds itself, one that grows without end, a where clause over a length — + is one error among the rest of the file's, not the end of the check. *) + let all_lines src = + match Check.program_all (Parse.program_all (read src)) with + | _ -> [] + | exception Loc.Errors ds -> + List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds + in + check "a self-containing generic struct is one error of several" + (all_lines + "(defstruct Loop [next (Loop $t)])\n\ + (defn g [] i32 (let [p (the (Loop i32) (zeroed))] nope1))\n\ + (defn h [] i32 nope2)\n" + = [ 1; 2; 3 ]); + check "a generic struct that grows without end is one error of several" + (all_lines + "(defstruct Grow [next (Ptr (Grow [$t]))])\n\ + (defn g [] i32 (let [p (the (Grow i32) (zeroed))] nope1))\n\ + (defn h [] i32 nope2)\n" + = [ 1; 2; 3 ]); + check "a where clause over a length is one error of several" + (all_lines + "(defn f [a [$n i32]] i32 {:where (numeric? $n)} nope1)\n\ + (defn h [] i32 nope2)\n" + = [ 1; 1; 2 ]); + (* A literal that does not fit what a typed field decided names that field. *) + (match + checked + "(defstruct Pair [a $t b $t]) \ + (defn main [] i32 (let [p (Pair (the i32 1) 2.5)] 0))" + with + | _ -> check "a float literal where a typed field decided i32" false + | exception Loc.Error d -> + check "the refusal names the field that decided the variable" + (contains d.Loc.dmsg "Pair's .b is $t, which is i32 here" + && List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg ".a is i32 here, which decides $t") + d.Loc.notes)); + + (* A copy that cannot be built at a closure's type: the zeroed value in the + body is refused there, and the call that asked is named. *) + (match + checked + "(defn blank [x $t] $t (let [z (the $t (zeroed))] z)) \ + (defn use-it [f (Fn [i32] i32)] i32 (blank f) 0)" + with + | _ -> check "a zeroed closure in a copy is refused" false + | exception Loc.Error d -> + check "a copy at a closure type names the call that asked" + (List.exists + (fun (n : Loc.note) -> + contains n.Loc.nmsg "blank is instantiated at $t = (Fn [i32] i32) here") + d.Loc.notes)); + + (* A prelude generic's body is nobody's source at the call: the refusal is + at the call, and the prelude's line is a note. *) + (match + checked + "(defn keep [g (Vec u8)] bool true) \ + (defn use-it [xs [(Vec u8)]] i32 (length (filter xs keep)))" + with + | _ -> check "a prelude copy that cannot be built is refused" false + | exception Loc.Error d -> + 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)); + (* The parser resynchronises on a top-level form, so two bad declarations are two errors rather than one. *) (match Parse.program_all (read "(defn a)\n(defn b)\n") with @@ -6245,7 +6347,7 @@ let () = accepts "numeric? admits +" "(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))"; rejects_check "equal? does not admit <" - ~needle:"nothing declares t ordered?" + ~needle:"nothing declares $t ordered?" "(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))"; (* The entailments, which are the reason a signature is one predicate long rather than two. Every type the language orders is a number or an enum, @@ -6273,10 +6375,10 @@ let () = accepts "integer? admits the shifts" "(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))"; rejects_check "numeric? does not admit bit-and" - ~needle:"nothing declares t integer?" + ~needle:"nothing declares $t integer?" "(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))"; rejects_check "nor the shifts" - ~needle:"nothing declares t integer?" + ~needle:"nothing declares $t integer?" "(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))"; (* An integer?-bounded caller satisfies a numeric?-bounded callee: the entailment carries across generic calls exactly as ordered?-over-equal? @@ -6879,19 +6981,118 @@ 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. *) - 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))"; + (* 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))"; (* ── 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 0c10f5b2..58348b96 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -367,6 +367,76 @@ 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); + + (* 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