(** The checker: AST → typed IR. Two passes, because top-level names in a package are order-independent (plan.org, Modules): the first collects every type, signature and global, the second checks bodies against them. Mutually recursive functions need no forward declaration, and a struct may be used above where it is declared. Checking is *bidirectional*. An expression is checked against an expected type when there is one and inferred when there is not, which is what makes [None], a bare [0] and a struct literal work without any inference engine: the expected type flows in from the function's return type, the parameter it is being passed to, or the field it is being stored in. The rule from the two misparse bugs applies here too: *anything not yet implemented is rejected by name*, never approximated. Milestone 2 is calc-me.flan and nothing more (plan.org, Build sequence), so [Vec], [Map], [Result]/[try], user data types, closures, [dotimes], [defer], generics and cross-package imports are all errors with a message that says which milestone they belong to. *) let fail = Loc.fail (* A type in a message about the code at [loc], in that code's syntax. *) let tyname (loc : Loc.t) t = Types.spell ~indented:(Source.indented_at loc) t (* "A literal could not be built at the type this site asked for": 300 at a u8, 1.5 at an i32, 3000000000 at the i32 an unconstrained integer defaults to. It is kinded rather than left generic because one caller has to tell this refusal apart from every other one. [binary] retries a refused operand against the other operand's type (TODO.org, "Implicit numeric widening is legal; narrowing stays a hard error"), and it must not retry *this* one: a literal takes its width from the other side and always could, so a literal that does not fit is the program's mistake and not a pair of types that failed to meet. Without the kind the retry turns (+ u8-thing 300) into i32 arithmetic, which is a different language from the one the author decided on. *) let literal_at_want = "check/literal-at-want" (* A refusal that is two types failing to meet, a literal's included: what an arm checked at another arm's type says when the two simply differ. *) let is_mismatch (d : Loc.diag) = String.equal d.Loc.kind "check/type-mismatch" || String.equal d.Loc.kind literal_at_want (* [List.map]'s evaluation order is unspecified, and checking allocates frame slots as a side effect. Left-to-right is required, not a preference: a later let binding sees an earlier one, and slot numbering must be reproducible. *) let rec map_lr f = function | [] -> [] | x :: rest -> let y = f x in y :: map_lr f rest let rec map2_lr f xs ys = match xs, ys with | [], [] -> [] | x :: xs, y :: ys -> let z = f x y in z :: map2_lr f xs ys | _ -> invalid_arg "map2_lr" (* ── Environments ──────────────────────────────────────────────────── *) type binding = { slot : int; bty : Types.t; assignable : bool; (* locals are places; parameters are not — spec-memory *) (* Where the name came from, in words, when that is worth saying in a refusal about it. Set by the match-arm path and nowhere else: a case pattern binds the case's fields positionally, so [(Circle c)] over a one-field case binds [c] to an [f64] and the reach for [(.r c)] gets a type fact about [f64] instead of the one sentence that helps, which is that the field is already in hand. [None] everywhere else, and a refusal with [None] says exactly what it said before. *) bwhat : string option; (* The literal a [let] or [loop] bound this name to, when its type is read off the uses ([lit_session]). The initialiser's node, by identity, is the key: two expansions of one macro are two nodes. *) blit : Ast.expr option; } (* A class slot's type: what a value stored into it is checked against. A dyn value's tag is all a store can ask of it, so the scalar types a tag answers for, an instance of a class, and (Option T) of either, which admits nil as well. *) type slot_ty = | Sany (* no type written: any dyn value *) | Sval of Types.t (* bool, an integer type, f32, f64, string *) | Sclass of string (* an instance of this class *) | Sopt of slot_ty (* nil, or a value of the inner type *) let rec slot_text = function | Sany -> "dyn" | Sval t -> Types.to_string t | 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 undo journal a check that may be abandoned writes into: every table write a body's check makes goes through [jreplace]/[jremove]/[jset], which note how to take it back while a [snapshot_env] is open. So abandoning a check costs what it wrote, not the size of the tables it could have. *) let journal : (unit -> unit) list ref = ref [] let journal_open = ref 0 let jot undo = if !journal_open > 0 then journal := undo :: !journal let jreplace tbl k v = (if !journal_open > 0 then let old = Hashtbl.find_opt tbl k in jot (fun () -> match old with | Some o -> Hashtbl.replace tbl k o | None -> Hashtbl.remove tbl k)); Hashtbl.replace tbl k v let jremove tbl k = (if !journal_open > 0 then match Hashtbl.find_opt tbl k with | Some o -> jot (fun () -> Hashtbl.replace tbl k o) | None -> ()); Hashtbl.remove tbl k let jset r v = (if !journal_open > 0 then let old = !r in jot (fun () -> r := old)); r := v (* 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; (* The untagged unions, by name, and they are [Tast.structure] values on purpose: a union's members *are* a field list, and every one of them is at offset zero. Giving them a record of their own would have meant a second shape for [field_index] and for every walk over a member list, to say nothing new — which table the name is in is already what says whether the offsets are cumulative or all zero, exactly as it is for a data type. *) unions : (string, Tast.structure) Hashtbl.t; (* Every data type case, twice over: once under its full spelling ["U.C"], which is how a value of it is written, and once under the bare ["C"], which is how a [match] arm names it and how a mistake spells a constructor. The full spelling is a key rather than something split out of a dotted name at the use site, because a data type's own name can contain a slash (an imported [rl/U]) and may one day contain a dot; string surgery would own an edge this does not have to. The bare entry is deliberately last-writer-wins and is *only* used to say "C is a case of U, write (U.C ...)". Two data types may share a case name — construction is qualified and a pattern resolves against the scrutinee, so both are unambiguous — and refusing that would be a restriction with no mechanism behind it. *) cases : (string, string * Tast.variant) Hashtbl.t; aliases : (string, Ast.texpr) Hashtbl.t; consts : (string, int64) Hashtbl.t; (* compile-time array lengths *) locs : (string, Loc.t) Hashtbl.t; (* where each type was declared *) (* Enum name -> its members, in declaration order. A keyword at a call site resolves against this and nothing else. *) enums : (string, (string * int64) list) Hashtbl.t; (* A condition type -> the parent it names, [(defstruct T :parent P ...)]. Handler matching walks this chain; see [condition_chain]. *) parents : (string, string) Hashtbl.t; (* Flan name -> the C symbol it is really called by. A foreign function is an ordinary entry in [fns] as well; this only records how to name it. *) externs : (string, string) Hashtbl.t; (* Where each [declare] was written, by Flan name. A second table rather than a pair in [externs], because every other reader of that one wants the symbol and nothing else. *) extern_locs : (string, Loc.t) Hashtbl.t; fns : (string, Types.t list * Types.t) Hashtbl.t; (* The parameter vector as it was *written*, by function name: the names and the locations [fns] threw away when it resolved the types. Nothing needs it to compile; it exists so that a refusal at a call argument can point at the parameter that wanted the other type, which is the second half of every message in Elm and was the one thing the reader could not see from the caret. Missing for a foreign [declare] and for a generic copy, and a missing entry degrades to the message alone rather than to a wrong pointer — [declared_note]'s rule. *) fparams : (string, Ast.field list) Hashtbl.t; (* And where the defn was written, for the same reason: a refusal about a function can show it. Kept apart from [fparams] because a foreign [declare] has a location and no parameter vector worth showing. *) fn_locs : (string, Loc.t) Hashtbl.t; (* A fn with several arities (decision 139): the name as written, to each arity and the name it was renamed to ([version_name]). A fn with one arity is not in here and keeps its own name, so its symbol does not change. *) versions : (string, (int * string) list) Hashtbl.t; (* Every [defn-], by name, with where it was written and how far it is visible. See [private_ref]. *) privates : (string, Loc.t * Ast.privacy) Hashtbl.t; globals : (string, Types.t * bool) Hashtbl.t; (* type, is a constant *) (* Where each global was declared, so a refusal about one can show it. A second table rather than a third field, because every other reader of [globals] wants the type and the constness and nothing else. *) global_locs : (string, Loc.t) Hashtbl.t; (* Functions the checker made up: a handler-bind clause is lifted into one, because a handler is called from wherever the signal was and cannot be a branch in the function that established it. *) mutable lifted : Tast.fn list; (* ── Generics by monomorphisation (spike, milestone 5) ──────────────── A generic [defn] is *not* in [fns]: its signature mentions type variables and nothing can be called at it. It lives here, as the AST it was written as, and every call site turns it into an ordinary function with concrete types. Odin's model exactly — [find_or_generate_polymorphic_procedure] keeps the source [Entity] and hangs generated ones off it. *) generics : (string, Ast.fn) Hashtbl.t; (* Its signature as *written*: parameter and return types with [Types.Var] in them. This is the pattern a call site matches its argument types against to bind the variables. *) gsigs : (string, string list * Types.t list * Types.t) Hashtbl.t; (* The instantiation cache. Odin's [gen_procs] list, keyed the way Odin keys it: a linear scan comparing whole concrete signatures with [are_types_identical] — here [Types.equal] pairwise. Same types twice means one copy. *) insts : (string, (Types.t list * Types.t * string) list ref) Hashtbl.t; (* The copies themselves, in the order they were generated. They are ordinary [Tast.fn]s from here down; nothing in a backend knows they were ever generic. *) mutable instances : Tast.fn list; (* The type variables in scope while a generic signature is being resolved. Empty everywhere else, which is what keeps the lowercase rejection at [resolve_name] the default. *) mutable tyvars : string list; (* What each of them is bound to while one instantiation's body is checked. [resolve_name] consults it before anything else, so the body resolves [t] to [i32] and every node under it is concrete. *) mutable subst : (string * Types.t) list; (* The [where] predicates in scope: what the abstract pass may assume about the variables, and what each instantiation checks its concrete types answer yes to. Empty everywhere a generic signature or body is not being resolved, which is what keeps every refusal below the default. *) mutable tvpreds : Ast.pred list; (* The chain of instantiations currently being generated, innermost last: the generic's name and the concrete parameter types each copy was asked for. It is the refusal for a generic that instantiates itself without end — [(defn grow [x $t] () (grow [x x]))] asks for a copy at [[2 t]], which asks for one at [[2 [2 t]]], forever — and without it the checker does not fail, it *hangs*, which through [Session.eval] is [C-c C-c] hanging with the dev daemon wedged behind it. The test is structural rather than a depth count. A depth count names a number the programmer did not write and cannot act on; this names the 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 — 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 with no type. Filled by [pair_decls], which is where a slot vector is first readable. The type is a declaration about the values and not a layout: an instance is a dyn map whatever this says, and what reads it is [class_spec], which is what the runtime checks a store against. *) classes : (string, (string * slot_ty) list) Hashtbl.t; (* The bindings a dev build counts at every call: [Shim.resources], read off the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan name a program calls. *) tracks : (string, Shim.track) Hashtbl.t; (* Every [defn] whose return type was read off its body ([_]), with the form that decided it — what a stale-caller warning points at. *) inferred : (string, Loc.t) Hashtbl.t; (* The [_] bodies whose type could not be read because of an error of their own, while every error is being collected. Each stands in [fns] as Never, a call to one stands as a poison, and pass two reports the body's errors once. *) infer_failed : (string, Loc.diag option) Hashtbl.t; (* Recovery: checking goes on past a refused subexpression. See [check]. [recovering] is on only while a whole-file or session check is collecting every error; [recovered] is what it found, newest first; [poison] counts failed subexpressions and reads of what they were bound to, which is how an error caused by an earlier one is told apart and left unsaid. [speculating] turns recovery off inside a trial, whose refusal is an answer the caller acts on; [guard_next] turns it off for the one next [check], whose own refusal a caller re-words. *) mutable recovering : bool; mutable recovered : Loc.diag list; mutable poison : int; mutable speculating : int; mutable guard_next : bool; } (* The struct table [box] describes a struct from when it was handed no [ctx]: the newest program's, set by [new_env]. Every caller that has a [ctx] passes it, so its own program's table is the one read. *) let view_structs : (string, Tast.structure) Hashtbl.t ref = ref (Hashtbl.create 1) (* The global whose initialiser is being checked, and its form. A view taken there of storage the initialiser itself built is gone the moment the initialiser returns, so it is refused rather than left to the dev check: nothing could ever read it. *) let view_global_init : (string * Ast.reinit) option ref = ref None let rec new_env () = let env = new_env_record () in view_structs := env.structs; env and new_env_record () = { structs = Hashtbl.create 16; datas = Hashtbl.create 16; unions = Hashtbl.create 16; cases = Hashtbl.create 32; aliases = Hashtbl.create 16; consts = Hashtbl.create 16; locs = Hashtbl.create 16; enums = Hashtbl.create 8; parents = Hashtbl.create 8; externs = Hashtbl.create 32; extern_locs = Hashtbl.create 32; fns = Hashtbl.create 32; fparams = Hashtbl.create 32; fn_locs = Hashtbl.create 32; versions = Hashtbl.create 4; privates = Hashtbl.create 8; globals = Hashtbl.create 16; global_locs = Hashtbl.create 16; lifted = []; generics = Hashtbl.create 8; gsigs = Hashtbl.create 8; insts = Hashtbl.create 8; instances = []; tyvars = []; 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; inferred = Hashtbl.create 8; infer_failed = Hashtbl.create 4; recovering = false; recovered = []; poison = 0; speculating = 0; guard_next = false; } (* A check that may be abandoned — a trial, a probe, a return type read and thrown away, a tolerated body — opens one of these: [undo] puts back everything it wrote into [env], [keep] closes it and leaves the writes, which an enclosing one can still undo. Partial undo is the bug this exists for: rewinding [lifted] and not the generic cache left a copy made during a trial with the lambda it lifted gone, which is a link error. So the whole record is named, closed with warning 9: a new field stops this compiling until it is decided here. The tables a body's check writes go through the journal ([jreplace]); the lists and flags are held here, which costs nothing; the rest is written by the declaration passes alone, before any body is checked. *) let snapshot_env env : (unit -> unit) * (unit -> unit) = let[@warning "+9"] { lifted; instances; tyvars; subst; tvpreds; chain; deferred; lenvars; len_placeholder; schain; in_field; recovering; recovered; poison; speculating; guard_next; (* Journaled at their writes. *) structs = _; locs = _; copies = _; insts = _; fns = _; (* Declaration passes only. *) datas = _; unions = _; cases = _; aliases = _; consts = _; enums = _; parents = _; externs = _; extern_locs = _; fparams = _; fn_locs = _; versions = _; privates = _; globals = _; global_locs = _; generics = _; gsigs = _; refused_generics = _; gstructs = _; broken = _; glens = _; classes = _; tracks = _; inferred = _; infer_failed = _ } = env in incr journal_open; let mark = !journal in let close () = decr journal_open; if !journal_open = 0 then journal := [] in let undo () = let rec back l = if l != mark then match l with | u :: rest -> u (); back rest | [] -> () in back !journal; journal := mark; close (); env.lifted <- lifted; env.instances <- instances; env.tyvars <- tyvars; env.subst <- subst; env.tvpreds <- tvpreds; env.chain <- chain; env.deferred <- deferred; env.lenvars <- lenvars; env.len_placeholder <- len_placeholder; env.schain <- schain; env.in_field <- in_field; env.recovering <- recovering; env.recovered <- recovered; env.poison <- poison; env.speculating <- speculating; env.guard_next <- guard_next in (undo, close) (* 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 [Cursor has no field pos] is true, and the reader's next move is always to go and look at Cursor. Attaching the declaration's location and its actual field names means the answer arrives with the question, and [next-error] will take you there because a note prints as an entry of its own. Empty when 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 -> let names = match Hashtbl.find_opt env.structs name with | Some s -> List.map (fun (f : Tast.field) -> f.Tast.fname) s.Tast.fields | None -> (match Hashtbl.find_opt env.datas name with | Some u -> List.map (fun (c : Tast.variant) -> c.Tast.vname) u.Tast.cases | None -> match Hashtbl.find_opt env.unions name with | Some u -> List.map (fun (f : Tast.field) -> f.Tast.fname) u.Tast.fields | None -> []) in let what = if names = [] then shown ^ " is declared here" else shown ^ " is declared here, with " ^ String.concat ", " names in [ Loc.note at what ] (* One edit apart: a substitution, an insertion, a deletion, or a transposition of neighbours. Bounded at one, because two edits is no longer a typo, it is a guess. Hoisted out of [near_miss] so that the did-you-mean over *values* — function names, globals, locals — matches on exactly the same rule the one over types has always matched on, rather than on a second one that would drift. *) let one_edit a b = let la = String.length a and lb = String.length b in if abs (la - lb) > 1 then false else begin (* Walk both until they diverge, then require the tails to match with the single edit applied. *) let i = ref 0 in while !i < la && !i < lb && a.[!i] = b.[!i] do incr i done; let ta s k = String.sub s k (String.length s - k) in if la = lb then !i < la && (ta a (!i + 1) = ta b (!i + 1) (* stirng/string: two neighbours swapped. *) || (!i + 1 < la && a.[!i] = b.[!i + 1] && a.[!i + 1] = b.[!i] && ta a (!i + 2) = ta b (!i + 2))) else if la < lb then ta a !i = ta b (!i + 1) else ta a (!i + 1) = ta b !i end (* The same question asked of a candidate list the caller assembles, which for a value position is the function table, the globals and whatever is in scope — and nothing from the type tables, because a name written where a value goes was not a mistyped struct. *) let nearest cands n = List.find_opt (fun c -> c <> n && one_edit n c) cands (* What the last language called it. [long] is two edits from [i64] and so is outside [one_edit]'s net, which is right — two edits is a guess — but the name is not a guess at all: it is what C, Java, Go and Python spell an integer, and somebody writing it here has not mistyped anything, they have not yet learned that this language sizes its integers in the name. Without this list [long] falls through to the lowercase arm of [resolve_name] and is reported as generic code over a type variable, which is a sentence about a feature the reader was not reaching for. Two names that belong on this list by that reasoning are *not* on it: [int] and [float]. They are builtin aliases as of 2026-09-20 — [int] is [i32] and [float] is [f32], spelled in [Types.ikind_of_name] and [Types.fkind_of_name] — so they resolve rather than teach, and a row for either here would be dead code the next reader would trust. The exception stops at those two, on the author's decision: the default integer and the default float are the two spellings a program reaches for constantly, and [integer], [long], [double], [str] and the rest keep teaching. So [integer] still answers [i32] here even though [int] no longer does — the sibling spelling is still a name this language does not have. Short on purpose, and only names with one honest answer. [char] is not here: it is this language's own code point type. Nor [void]: it is a return type and the answer there is the shape [()], which is [parse]'s message to give and not this one's. Nor [usize] and [size_t]: the honest answer is "as wide as a pointer on this target", which is [u64] on x86-64 and [u32] on wasm32, and a message that named one of them would be wrong half the time on a tree that builds both. A name goes on this list when the answer does not depend on anything. *) let foreign_spelling = function | "integer" -> Some "i32" | "uint" | "unsigned" -> Some "u32" | "long" -> Some "i64" | "ulong" -> Some "u64" | "short" -> Some "i16" | "ushort" -> Some "u16" | "byte" -> Some "u8" | "double" -> Some "f64" | "boolean" -> Some "bool" | "string" -> Some "str" | _ -> None (* The builtin names, for the did-you-mean at a call — [prinltn] is a typo for [println], and [println] is not in any table the checker keeps, it is an arm of the call dispatch. The full [builtins] table is a long way below this point and carries a signature and a sentence per entry for eldoc; a forward reference to its names is cheaper than moving it or writing the list twice and letting the two drift. Filled once, immediately after that table. *) let builtin_names : string list ref = ref [] (* The same names as a set, and the two are not one because they are asked two different questions. The list above is read once, at a refusal, and its order is the order the did-you-mean walks. This is asked at *every* named call — [shadows_builtin] is the first arm of the dispatch — and a linear walk of eighty-odd strings per call is a cost a whole-program check pays in full: measured at about a third of check time on a program of twenty thousand calls. Filled beside the list. *) let builtin_set : (string, unit) Hashtbl.t = Hashtbl.create 128 (* Set while [bool_operands] asks an operand its type; see there. *) let probing = ref false (* ── builtin/, the reserved qualifier ────────────────────────────────── [builtin/length] is the builtin [length], whatever else the program has decided [length] means. It is the way out of the dead end shadowing used to leave: a [(defn length ...)] takes the bare name over for its whole file, and before this there was no remaining spelling for the thing it was wrapping, so the wrapper was unbounded recursion instead. The spelling is the package qualifier's, deliberately. A reader who knows that [rl/draw-fps] is [draw-fps] from the package imported as [rl] already knows what [builtin/length] is, and needs no second syntax to learn. What makes it work is that [builtin] is reserved rather than resolved: [Load]'s qualifier comes from the alias in an [import] form and from nowhere else, so refusing that one alias ([Load.reserved_alias]) is the whole of keeping this prefix unambiguous. It is legal when nothing is shadowed, too. A spelling that only compiles while some other declaration exists is a spelling nobody can write down in advance, and the point of an escape hatch is that it is always there. *) let builtin_prefix = "builtin/" let qualified_builtin n = let p = String.length builtin_prefix in if String.length n >= p && String.sub n 0 p = builtin_prefix then Some (String.sub n p (String.length n - p)) else None (* [builtin/] reached with something that is not a builtin's name. The did-you-mean is over the builtins alone and not over the program's own names: the reader wrote the qualifier, so they were reaching for a compiler name, and offering them a defn called [lem] would be answering a question they did not ask. Every other did-you-mean in this file keeps the candidates it already had. *) let not_a_builtin loc bare = if bare = "" then Loc.failk "check/unknown-builtin" loc "%s needs a name after it — the qualifier reaches a builtin, as \ (%slength v)" builtin_prefix builtin_prefix else match nearest !builtin_names bare with | Some m -> Loc.failk "check/unknown-builtin" loc "%s is not a builtin, so %s%s reaches nothing — did you mean %s%s?" bare builtin_prefix bare builtin_prefix m | None -> Loc.failk "check/unknown-builtin" loc "%s is not a builtin, so %s%s reaches nothing. The %s qualifier \ reaches the compiler's own names and nothing else; an ordinary \ function is called by the name it was defined under" bare builtin_prefix bare builtin_prefix (* One argument of a call, written back out as source. A name is its name and an integer is its digits; anything with structure inside it — a call, a field, an index — becomes the stand-in the caller supplies, because a suggestion with a hole in it is worse than one that names its blank. Shared by the refusals that answer a name nothing defines by writing the call the reader should have written. This spells one argument and says nothing about how many there are. Whether the result compiles is the caller's to arrange: a call site that writes out every argument it was given is only honest where the name it is suggesting takes that many, so the caller either knows the arity matches or falls back to a shape of its own. *) let spell_arg stand_for (a : Ast.expr) = match a.Ast.e with | Ast.Var v -> v | Ast.Int n -> Int64.to_string n | Ast.UInt (_, s) -> s | _ -> stand_for (* Operators other languages spell differently, each mapped to the Flan builtin that computes the same thing. Only exact equivalents: [mod] is left out because Clojure's is floored and [%] is not. [&&] and [||] are not here: they are the bit operators, and a bool reaching one is told which logical operator it wanted there. *) let operator_aliases = [ ("not=", ("!=", "Not-equal")); ("=/=", ("!=", "Not-equal")); ("/=", ("!=", "Not-equal")); ("<>", ("!=", "Not-equal")); ("==", ("=", "Equality")); ("===", ("=", "Equality")); ("!", ("not", "Logical not")) ] (* The fix, as the sentence that ends the refusal. The reader's call is written back out under the Flan name only when every argument can be spelled and the count is one the builtin takes, so a suggestion printed as code compiles once pasted. An argument that cannot be spelled leaves the call as it was, with only the name to change; a count the builtin does not take gets the builtin's shape. *) let alias_fix flan (args : Ast.expr list) = let spelled = List.map (spell_arg "") args in let n = List.length args in let arity_ok = match flan with | "not" -> n = 1 | "and" | "or" -> true | _ -> n >= 2 in if not arity_ok then Printf.sprintf "It is called as %s" (if flan = "not" then "(not x)" else "(" ^ flan ^ " x y)") else if List.mem "" spelled then Printf.sprintf "Write %s in its place" flan else Printf.sprintf "Write (%s)" (String.concat " " (flan :: spelled)) (* What a [break] or a [continue] may be talking about, innermost first. [Lloop] is a loop it is lexically inside, carrying its label if it was given one. [Lbarrier] is something a jump may not cross, named so the refusal can say which — and the barriers are the whole of the answer to the question [return]'s [in_frames] rule could not answer. [return] is refused inside a [handler-bind] or a [restart-case] blanketly, because a return *always* crosses the frames established there and leaves them on the stack pointing into a frame that has gone. A break crosses only sometimes: a loop written wholly inside a [restart-case] body has a perfectly good local break, and refusing it would be refusing the common case for the uncommon one. So the rule here is relative rather than blanket — a jump is refused exactly when a barrier stands between it and the loop it names — and the two rules agree on the case they share, because a [return] is a jump whose target is always outside every barrier. A [defer]'s forms are a barrier for a different reason with the same shape: they are copied into the function's exit paths, where the loop they were written next to no longer exists. A loop *inside* the defer is fine, which is again the relative rule and not a blanket one. A handler clause is not on this list at all: it is lifted into a function of its own and gets a fresh [ctx], so its loops start empty and nothing inside it can name a loop outside it. *) type lentry = | Lloop of string option (* A [(loop ...)], carrying the slot and type of each of its names so that a [recur] can rebind them. It is *also* a barrier for [break] and [continue]: a loop answers with the value of its body, so a jump that left one would have no value to give. A [while] written inside a loop is unaffected, which is the relative rule doing its job again. *) | Lrecur of (int * Types.t) list | Lbarrier of string (* Local inference for a number or character literal bound by a [let] or a [loop]: [(let [t 0.0] ... (set t (+ t x)))] makes [t] x's type. The form is checked with every literal local at its current guess while each use records what it says about the local. When the uses agree with the guesses that check is the answer; otherwise it is undone, the guesses are solved and it is checked again. Locals that feed one another are merged into one group (union-find), so a chain of any length settles in one more round. One session per function context, opened by its outermost such [let], so a lambda or a generic's copy is inferred on its own and a literal's type never depends on another function. What a use says about the local: - [Up t]: the local flows into a [t] — a parameter, a return, a field, an index. The local has to widen into [t]. - [Down t]: a [t] is [set] into it, or passed to [recur] for it. [t] has to widen into the local. - [Hint t]: an operator's other operand, which meets it at either; or a dyn it meets, as the dyn width ([Types.Dyn] here, i64 or f64 in [solve]). A [set] of arithmetic over such locals and literals into another merges them, as does an operator between two of them. *) type lit_con = Up | Down | Hint (* Initialiser nodes by identity: two expansions of one macro are two nodes and may print alike. *) module Phys = Hashtbl.Make (struct type t = Ast.expr let equal = ( == ) let hash = Hashtbl.hash end) type lit_session = { (* The type each literal local is checked at. Kept across rounds. *) decided : Types.t Phys.t; (* On while a round checks; off for a final check after one that failed. *) mutable recording : bool; (* This round's locals, numbered as they are bound, and their names. *) ids : int Phys.t; mutable keys : (Ast.expr * string) list; mutable count : int; (* Union-find over the numbers, and each one's uses. *) parent : (int, int) Hashtbl.t; cons : (int, lit_con * Types.t * Loc.t) Hashtbl.t; (* A use its guess could not serve was read at the type it asked for, so this round's check is not a program and is thrown away. *) mutable dirty : bool; } (* Nonzero while any recording check runs: the refusal memos ([arm_failed], [if_failed], [truthy_failed]) are not written then, since a refusal made at a guessed type must not be replayed at the decided one. *) let lit_recording = ref 0 (* The operands of the operators being checked that are literal locals, by location: a want reaching one is the other operand's type, a [Hint] and not an [Up], and a refusal there is the operator's to handle. *) let lit_operand_locs : Loc.t list ref = ref [] (* Set while arithmetic over literal locals is checked at the type of the local it is stored into ([lit_down]): the locals in it are merged with that one, so the guess it is checked at says nothing about them. *) let lit_quiet = ref false (* Text and bracket literals keep their typed reading while this is set (the [dyn] switch only): a [defconst]'s value, and a let-bound one some typed use wants. *) let typed_literals = ref false let with_typed_literals f = let was = !typed_literals in typed_literals := true; Fun.protect ~finally:(fun () -> typed_literals := was) f (* Per-function state. Slots are never reused, so [slots] is also the frame size — the interpreter allocates one array of this length per call. *) type ctx = { env : env; ret : Types.t; (* The literal-inference session of this function, while one is open. *) mutable lits : lit_session option; mutable slots : int; (* The type of each slot, newest first. A backend needs it to size the frame — nothing else records it, since the IR refers to slots by index. *) mutable slot_tys : Types.t list; (* The source name of each slot, newest first, parallel to [slot_tys]. [None] for a slot the checker invented -- see [Tast.fn.snames]. Recorded here rather than recovered later because this scope list is the only place that ever knows it. *) mutable slot_names : string option list; (* The slots an [as] bound in this function: [Tast.fn.as_slots]. *) mutable as_slots : int list; mutable scope : (string * binding) list; (* innermost first *) (* Deferred forms, most recently registered first — which is also the order they run in. [defer] is function-scoped, so this list belongs to the function and not to a block — see [defer_ok] for where one may be written and [check_fn] for where the list is spliced onto the exit paths. *) mutable defers : Tast.expr list; (* The slot that counts how many of them have registered, minted on the first [defer] this function writes and [None] until then. The normal exit paths need no such thing: falling off the end is below every defer in the text, and a [return] splices the ones registered above it, both of which are decided while checking. The *transfer* exit is the one path that is not, because a transfer can start anywhere, including in the initialiser of the very [let] whose body the defer is written in — and that defer has not registered yet. Running it there is not a leak the other way round; it is cleanup over a binding nothing has written, which is [(free v)] on whatever the stack held. So the count is kept at run time and the transfer path's copy of each defer is guarded on it. The cost is not all on the unwinding path, and the half that is not is the half worth naming: every function with a defer pays one i64 of frame, one store of zero at entry, and one store of an ordinal where each defer is written — on the ordinary path, whether anything ever transfers or not. What the unwind adds on top is one compare per defer. A store of a constant into a frame slot nothing else reads is about as little as a fact can cost, but it is not nothing and it is not only on the cold path. *) mutable defer_slot : int option; (* Where a [defer] may be written, which is exactly: a form whose extent is the whole function body. Two things have that extent and only two — a top-level form of the body, and a form in the body of a [let] that itself has it, to any depth. A [let] always registers and its bindings outlive the block textually enclosing them, because a [let] is not a frame here: its bindings are function slots like any other, and nothing is released at scope exit (spec-memory.md, "When storage is released"). Everything else is refused, and the two that matter are refused for a reason rather than by omission. [defer] is a *compile-time* construct — the cleanup is copied into every exit path — so a branch would have to express "maybe registered", which it cannot, and a loop body would fire once at function exit rather than once per iteration. The flag is set immediately before each form that may carry one, never once around a body: [check] clears it on entry, so a body whose first form set it would otherwise refuse the second. [defer_block] names the innermost construct that cleared it, so the refusal says which. *) mutable defer_ok : bool; mutable defer_block : string; (* Only for the two things a handler clause cannot do. [outer] is the establishing function's scope, kept so that a reference to one of its locals can be refused for the reason it is really refused for rather than as an unknown name. *) outer : (string * binding) list; (* Set on the context of a body the checker lifted into a function of its own — a handler clause, or an [fn] literal — and naming which, so the refusal below says why the enclosing function's locals are not there. Both are the same gap: capture does not exist. *) mutable outer_what : string option; (* What this body has captured out of [outer], in the order it first named each one: the source name, the *outer* binding the copy is taken from, and the slot in this body's own frame the copy is read into. Empty everywhere [outer] is, which is everywhere but a lifted body. The order is the environment's field order, so it is the order the copy is made in and the order the body reads it back in. First-reference order rather than declaration order because it is the only one this pass has: the outer scope is a list and the names on it were not all written for this body's sake. *) mutable caught : (string * (binding * int)) list; (* Whether the form being checked is the target of a place — indexed, sliced, a field read, its address taken — rather than a value. Granted by [check_target] to the one form it checks and withdrawn at the top of [check]. See [refuse_owned_copy]. *) mutable place_ok : bool; (* The context this body was lifted out of, so that capture can be transitive: an [fn] inside an [fn] naming a local of the function both were written in is captured by the middle one and then by the inner one out of the middle one's copy. Without it the inner body would see only what the middle body happened to have named already, which is a rule about the text and not about the scope. It is safe to reach into while it is on the stack, and only then: a lifted body is checked at the point it is written, so the parent is paused exactly there and its scope is the snapshot [outer] holds. *) parent : ctx option; (* The slot the environment pointer arrives in, minted the first time something is captured and [None] until then. Nameless, so the break loop hides it the way it hides every other slot the compiler made: what a reader wants to see is the copies, and those are under the names the source gave them. *) mutable envslot : int option; (* True wherever handler or restart frames established by this function are on the stack. A [return] from there would leave them pointing into a frame that has gone, so it is refused — the same rule as [defer] inside a block. *) mutable in_frames : string option; (* The loops and the barriers this form is inside, innermost first. See [lentry]: it is what [break] and [continue] resolve against, and the whole of why they are not a goto — a label that names no loop on this list is refused, so control can only leave a loop it is already in. *) mutable loops : lentry list; (* True where this form's value is the value of the enclosing [loop]'s body, which is the only place a [recur] may stand. Read and withdrawn at the top of [check] exactly as [defer_ok] is, and granted again by the three forms that pass a tail through: the last form of a block, both arms of an [if], and a [match] arm. Everything else is therefore non-tail by construction, and no walk has to enumerate the cases that are not. *) mutable tail : bool; (* True where this form's value is kept: a [let] binding's value, and what a block's last form, an [if]'s arms and a [match]'s arms inherit from the form they stand in. Read and withdrawn at the top of [check] as [tail] is. Only a one-armed [if] ([when]) asks: used, it answers an Option; not, it is a statement. [want] alone cannot say, since a statement and an unannotated [let] value both arrive with none. *) mutable used : bool; (* The arguments of the call being checked: each is kept, whatever the callee wants of it, so a [when] written as an operand answers its Option there rather than a Unit the other operands are then blamed against. *) mutable kept : Ast.expr list; (* True inside a [defer]'s forms. A defer is the cleanup a transfer runs on its way out (§5), so a transfer *starting* there has no answer: this function's defers are already half run and the first transfer's target is already in hand. Refused where it is written. *) mutable in_defer : bool; (* The function being checked, so a clause lifted out of it can be named after it. The name has to be stable and has to say whose it is: a redefinition module emits the clauses belonging to the bodies it is replacing, and nothing else in the program can tell it which those are. *) owner : string; } (* [?name] is the source name, when there is one. It is optional so that the several places that allocate a hidden slot say nothing and get [None] -- a synthesized slot cannot accidentally acquire a name it was never given. *) let fresh_slot ?name ctx ty = let s = ctx.slots in ctx.slots <- s + 1; ctx.slot_tys <- ty :: ctx.slot_tys; ctx.slot_names <- name :: ctx.slot_names; s (* The structural printer's context over this checker's tables, with the pieces aimed wherever [emit] sends them. [print] and [watch] differ in the emitter and in nothing else, and a second copy of this would be a second answer to which types the walk knows. *) let render_ctx ctx (emit : Render.emitter) : Render.ctx = { Render.structs = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.structs []; datas = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.datas []; unions = Hashtbl.fold (fun _ v acc -> v :: acc) ctx.env.unions []; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) ctx.env.enums []; emit; (* Neither [println] nor [watch] follows a pointer, and the allocation registry does not change that. spec-memory.md fixes what it prints — "Ptr and Handle print their address or identity rather than recursively dereferencing" — and a printed line belongs to the program, so it must read the same in a release build, where there is no registry to ask. Following one is the *inspector's* move, and session.ml is where that context is built. *) ptrs = None; alloc = (fun ty -> fresh_slot ctx ty) } (* Shadowing is legal -- [(let [v 11] (let [v 22] ...))] is two slots, both named [v] -- and the debug info has nowhere to put the distinction. Every [!DILocalVariable] is scoped to the subprogram, because the typed IR has no block structure for a [!DILexicalBlock] to be built from, so two variables called [v] land in one flat scope and lldb answers [p v] with whichever it finds first. Measured, not assumed: it answers with the *outer* one, so it prints 11 while the body it is stopped in is computing with 22, and the inner binding is not listed at all. That is the one outcome worse than printing [s3]: a name the debugger is confident about and wrong about. So a repeat of a name already bound in this function gets a suffix, and both bindings are then visible and unambiguous. [~] is the reader's delimiter and cannot occur in a source symbol (the same reason [destructure~nth] is spelled that way), so [v~2] is visibly the compiler's doing and can never collide with something the programmer wrote. This is a way of not lying, not a way of being right: [v] is still the outer binding everywhere, including inside the inner one's extent. Scoping the variables properly means emitting a [!DILexicalBlock] per [Let] and moving the [llvm.dbg.declare]s out of the entry block to the binding sites, which needs block structure this IR does not carry. *) let bind ctx ?what ?lit name bty ~assignable = let taken n = List.exists (fun s -> s = Some n) ctx.slot_names in let name' = if not (taken name) then name else let rec go k = let c = Printf.sprintf "%s~%d" name k in if taken c then go (k + 1) else c in go 2 in let slot = fresh_slot ~name:name' ctx bty in (* [ctx.scope] keeps the *source* name: the suffix is a debug-info artifact and resolving [v] must still find the innermost binding. *) ctx.scope <- (name, { slot; bty; assignable; bwhat = what; blit = lit }) :: ctx.scope; slot (* The last answer for each name, with the scope it was read from. A body is checked under one scope for long stretches and names the same local several times per form, so compared by identity this answers most lookups without walking a scope that, in a long [let], holds thousands of names. *) let lookup_cache : (string, (string * binding) list * binding option) Hashtbl.t = Hashtbl.create 64 let lookup ctx name = match Hashtbl.find_opt lookup_cache name with | Some (sc, r) when sc == ctx.scope -> r | _ -> let r = List.assoc_opt name ctx.scope in Hashtbl.replace lookup_cache name (ctx.scope, r); r (* Capture, spec-memory.md's case 2: a body lifted into a function of its own — an [fn] literal or a handler clause — naming a local of the function it was written in. The copy is taken where the value is made and not where it is read, so the name in the body means what the local held at that instant and nothing later can change it. What makes that safe is the extent: the copies live in a slot of the *enclosing* frame, and a value holding their address may not outlive it. [escapes] is the whole of what enforces that, and it is where the escaping half — an environment the collector allocates — is named. Answers the binding the body should use, minting one on first reference: a named slot of this body's own frame, which the prologue fills from the environment. Not assignable, and that is not an omission — see [captured_set]. A dyn is refused, and for the reason a struct field of dyn already is (see the [defstruct] arm): the collector's roots are frames, a captured copy lives inside a struct the checker synthesised, and nothing pushes the fields of one. A dyn in there would be a live value reachable only through memory the marker never walks. Milestone 2's per-type descriptors lift it, alongside the condition payload's and the struct field's. *) let rec capture ctx loc name = match List.assoc_opt name ctx.caught with (* Already captured, and named again from a scope that no longer lists it — a [let] inside the body restores what it displaced, and the copy's binding goes with it. One field, not two: the environment is keyed by the source name. *) | Some (outer, slot) -> Some { slot; bty = outer.bty; assignable = false; bwhat = None; blit = None } | None -> let from_parent () = (* Not a local of the body directly around this one, so ask whether that body can capture it in turn. The middle one takes a copy and this one takes a copy of that — which is the same value, because every copy on the way was taken at the moment its own value was made, and those moments are nested. *) match ctx.parent with | Some p -> capture p loc name | None -> None in let outer = match List.assoc_opt name ctx.outer with | Some b -> Some b | None -> if ctx.outer_what = None then None else from_parent () in match ctx.outer_what, outer with | Some _, Some (outer : binding) -> let slot = bind ctx name outer.bty ~assignable:false in ctx.caught <- ctx.caught @ [ (name, (outer, slot)) ]; Some { slot; bty = outer.bty; assignable = false; bwhat = None; blit = None } | _ -> None (* The one thing [capture] does not answer for. A captured name is a copy, so a store into it would change this body's copy and leave the local it came from as it was — which is a silent disagreement and not a feature. The ordinary "not assignable" message would name the wrong reason, so this one names the right one. [and] rather than a second [let] only so the two read together; neither calls the other. *) (* What [capture] would find, without capturing it. A guard that has to know the *type* of an enclosing local before deciding what a form means — a name in head position is a call through a value only if the value is a function — must not take a copy on the way to answering. The binding it answers with is only good for its type unless it came out of [caught]. *) and peek_outer ctx name = if ctx.outer_what = None then None else match List.assoc_opt name ctx.caught with | Some ((b : binding), slot) -> Some { slot; bty = b.bty; assignable = false; bwhat = None; blit = None } | None -> match List.assoc_opt name ctx.outer with | Some b -> Some b | None -> match ctx.parent with Some p -> peek_outer p name | None -> None and outer_local ctx name = ctx.outer_what <> None && (List.mem_assoc name ctx.caught || List.mem_assoc name ctx.outer || (match ctx.parent with | Some p -> outer_local p name | None -> false)) and captured_set ctx loc name = if outer_local ctx name then match ctx.outer_what with | Some what -> Loc.failk "check/capture-set" loc "%s cannot assign to %s: it is a copy of the enclosing function's \ local, taken where the value was made, so a store here would change \ the copy and leave %s as it was. %s" what name name (if String.equal what "a handler" then "Accumulate into a global, or put the value on the condition — \ capture is by value, which is what lets the copy be read at all" else "Return the new value, or keep it in a local of this fn") | None -> () let scoped ctx f = let saved = ctx.scope in let r = f () in ctx.scope <- saved; r (* A scope that is also a named blocker for [defer]. An arm of an [if] or a [match] runs only sometimes, and "maybe registered" is not something a compile-time construct can express — the cleanup is copied into every exit path or into none — so the refusal is about the branch and says so. Outside the [check] recursion on purpose: inside it the inferred type would be monomorphic, and the two callers pass functions returning different things. *) let branch ctx f = let blocker = ctx.defer_block in ctx.defer_block <- "a branch"; let r = scoped ctx f in ctx.defer_block <- blocker; r (* ── Type resolution ───────────────────────────────────────────────── *) let unimplemented loc what milestone = (* No repo filename in a message, and no milestone number either: neither means anything to somebody who has this compiler and nothing else. What they need is that the thing is not there yet. *) ignore milestone; fail loc "%s is not implemented yet" what (* Four names the randomness functions do not have, each with the name that does and a call that compiles. A reader who has never seen this language arrives at one of these by copying a line from somewhere, and what they need is the spelling that works — so these say what the surface *is*, not what it once was. The suggestions are checked by the suite, which compiles each one. [rand-int] answers a u64 whose every bit is a fresh draw, so a narrower draw is that value narrowed — which is why the [rand-u32] line suggests a cast rather than another function, and takes the high half, the half a reader should be taught to take. *) let no_such_rand name = match name with | "rand-u32" -> Some "there is no rand-u32 — a random integer is (rand-int), which answers \ a u64 with every bit drawn. For 32 bits of one, write \ (u32 (>> (rand-int) 32))" | "rand-f32" -> Some "there is no rand-f32 — a random float in [0, 1) is (rand), which \ answers an f64. For an f32, write (f32 (rand))" | "rand-i32-range" -> Some "there is no rand-i32-range — a random integer in [lo, hi) is \ (rand-int-range lo hi), which answers an i64: (rand-int-range 0 10) \ is one of 0 to 9, and (i32 (rand-int-range 0 10)) is that as an i32" | "rand-f32-range" -> Some "there is no rand-f32-range — a random float in [lo, hi) is \ (rand-float-range lo hi), which answers an f64, as in \ (rand-float-range 0.0 1.0)" | _ -> None (* ── where predicates ────────────────────────────────────────────────── A predicate is a compile-time question about a type, and that is the whole of it. It carries no implementation, selects no instance, and is not extensible: it gates a builtin the compiler already has. So there are no dictionaries, no coherence rules and no run-time cost — and the ceiling is that nobody can supply a [<] of their own, which does not bind because every operation the prelude and the containers need is a primitive. Odin's [where] clause is the same shape ([core/slice/slice.odin:289] is [where intrinsics.type_is_ordered(T)]) with forty-one predicates against these six. There is no [copyable?] any more and no Odin counterpart either: Odin has no move semantics, and since the repeal neither does this language, so [$T] never has to answer the question. [is-integer] is the narrowest numeric bound and exists because [is-numeric] was one type too wide for a family of bodies: an integer body under [is-numeric] is instantiated at f32 and f64 too, and (if (< x 0) (- 0 x) x) at -0.0 is the wrong abs while %, the bitwise operators and the shifts have no float meaning at all. A function that can be generalized should not need a variant per numeric type, and [is-integer] is what lets the integer-only ones say exactly what they need. [is-enum] admits exactly the enums. It entails [is-ordered] and [is-equal] and not [is-numeric]: an enum compares, and it converts to a number, but it is not one — no arithmetic, no literal. It is what licenses the generic enum-to-number conversion, beside [is-numeric]. *) let predicate_names = [ "is-ordered"; "is-equal"; "is-hashable"; "is-numeric"; "is-integer"; "is-enum" ] (* ── What a type owns, transitively ──────────────────────────────────── The one structural ownership question that survived the repeal, because it is not about copying at all. What it decides, and the only thing it decides, is whether a container of this element type has to be built against a region allocator — see [region_only] below and [flan_alloc_region_only] in the runtime. That is a question about *release*, so it is asked of every arm a release would have to reach and would not: a Vec or Map owns a block outright; an Option, a fixed array, a struct or a data type's case owns whatever its payload does. It does not live in [Types] for the reason [Types.keyable] gives: that module has no field table. The [seen] list is the cycle guard, and the cycle is real — the recursive dynamic value this exists for holds a [(Vec Value)], so [Value]'s walk reaches [Value]. Answering [false] for a name already on the path is right rather than merely terminating: whatever made the outer name own something was found by the arm that got here, and a name cannot contain itself by value anyway — [check_finite] refuses that — only through a container, which is an arm that answers for itself. [env.unions], the untagged ones, are deliberately not consulted: nothing anywhere records which member of one is live, so there is no fact this walk could read — an untagged union is treated as owning nothing, and what its members point at is the program's, through whatever tag it keeps beside the union. *) (* One edit apart — a substitution, an insertion, a deletion or a transposition of neighbours. Bounded at one, because two edits is no longer a typo, it is a guess. Shared by the unknown-type near miss and the enum member one. *) let one_edit a b = let la = String.length a and lb = String.length b in if abs (la - lb) > 1 then false else begin (* Walk both until they diverge, then require the tails to match with the single edit applied. *) let i = ref 0 in while !i < la && !i < lb && a.[!i] = b.[!i] do incr i done; let ta s k = String.sub s k (String.length s - k) in if la = lb then !i < la && (ta a (!i + 1) = ta b (!i + 1) (* stirng/string: two neighbours swapped. *) || (!i + 1 < la && a.[!i] = b.[!i + 1] && a.[!i + 1] = b.[!i] && ta a (!i + 2) = ta b (!i + 2))) else if la < lb then ta a !i = ta b (!i + 1) else ta a (!i + 1) = ta b !i end (* Whether [got] could be [want] once [want]'s type variables are bound: the same shape, a variable matching anything. Binding them consistently is the generic call's business; this only says a literal may take the shape. *) let rec fits_shape (want : Types.t) (got : Types.t) = match want, got with | Types.Var _, _ -> true | Types.Fn (ps, r), Types.Fn (qs, s) | Types.CFn (ps, r), Types.CFn (qs, s) -> List.length ps = List.length qs && List.for_all2 fits_shape ps qs && fits_shape r s | Types.Slice (a, x), Types.Slice (b, y) | Types.Ptr (a, x), Types.Ptr (b, y) -> a = b && fits_shape x y | Types.Vec x, Types.Vec y | Types.Option x, Types.Option y -> fits_shape x y | Types.Array (n, x), Types.Array (m, y) -> n = m && fits_shape x y | Types.Map (k, v), Types.Map (k', v') -> fits_shape k k' && fits_shape v v' | _ -> Types.equal want got (* [Dir.north] as the enum and the member's value, when [Dir] is an enum with a member [north]. *) let enum_member env name = match String.rindex_opt name '.' with | Some i when i > 0 && i < String.length name - 1 -> let e = String.sub name 0 i and m = String.sub name (i + 1) (String.length name - i - 1) in (match Hashtbl.find_opt env.enums e with | Some members -> Option.map (fun v -> (e, v)) (List.assoc_opt m members) | None -> None) | _ -> None (* The enum members' own near miss. One edit away is the usual typo; the second rule is for a package whose members carry a disambiguating prefix — raylib's Key spells them [key-r], [key-space] — where the natural mistake is writing the bare name. [:r] against [key-r] is four edits and one thought, so the rule is the thought: a member whose last segment is exactly the name written. *) let member_near_miss members k = List.find_opt (fun (m, _) -> one_edit k m || (let lm = String.length m and lk = String.length k in lm > lk + 1 && m.[lm - lk - 1] = '-' && String.sub m (lm - lk) lk = k)) members let owning_fields env n = match Hashtbl.find_opt env.structs n with | Some s -> [ s.Tast.fields ] | None -> match Hashtbl.find_opt env.datas n with | Some d -> List.map (fun (c : Tast.variant) -> c.Tast.vfields) d.Tast.cases | None -> [] let rec owning env ?(seen = []) (t : Types.t) = match t with | Types.Vec _ | Types.Map _ -> true | Types.Option e | Types.Array (_, e) -> owning env ~seen e | Types.Named n -> not (List.mem n seen) && List.exists (List.exists (fun (f : Tast.field) -> owning env ~seen:(n :: seen) f.Tast.fty)) (owning_fields env n) | _ -> false (* Does a value of this type hold a dyn anywhere — through a field, a case, an element or a view? Asked where the program is still being checked, so it reads the environment's tables rather than a finished program. *) let rec holds_dyn env ?(seen = []) (t : Types.t) = match t with | Types.Dyn -> true | Types.Array (_, e) | Types.Vec e | Types.Option e | Types.Slice (_, e) | Types.Ptr (_, e) -> holds_dyn env ~seen e | Types.Map (k, v) -> holds_dyn env ~seen k || holds_dyn env ~seen v | Types.Named n when not (List.mem n seen) -> let seen = n :: seen in let fields (fs : Tast.field list) = List.exists (fun (f : Tast.field) -> holds_dyn env ~seen f.Tast.fty) fs in (match Hashtbl.find_opt env.structs n with | Some s -> fields s.Tast.fields | None -> match Hashtbl.find_opt env.unions n with | Some u -> fields u.Tast.fields | None -> match Hashtbl.find_opt env.datas n with | Some d -> List.exists (fun (c : Tast.variant) -> fields c.Tast.vfields) d.Tast.cases | None -> false) | _ -> false (* Does a container of this type have to be built against an allocator that cannot free one block? Only the half a release would have to walk is asked: a map's key cannot own anything — [map_type] refuses one, because a key that owned storage would hash its header rather than what it points at — so the value is the whole of the question there. *) let region_only env (t : Types.t) = match t with | Types.Vec e -> owning env e | Types.Map (_, v) -> owning env v | _ -> false (* Does a concrete type answer yes? Checked at every instantiation, against the type the call site asked for. *) let pred_holds p (t : Types.t) = match p with | "is-ordered" -> Types.is_comparable t | "is-equal" -> Types.is_equatable t (* [Types.keyable] says yes to a struct and leaves its fields to [key_pair], which walks them at the operation. That split is the existing one and is kept: a generic declared [is-hashable] and instantiated at a struct whose fields are not keyable is refused where every other program is, by [key_pair]. *) | "is-hashable" -> Types.keyable t | "is-numeric" -> Types.is_numeric t | "is-integer" -> Types.is_integer t | "is-enum" -> (match t with Types.Enum _ -> true | _ -> false) | _ -> false (* What one declared predicate *also* gives you. These are entailments over the type system as it stands, not conveniences: every type [is_comparable] admits is a number or an enum, so it is equatable. The table is only sound while that is true — an ordered type with no [=] would make it wrong — so it lives in one place and says so. The gain is real ergonomics: [{:where (is-ordered $t)}] is enough for a [sort] that also compares, rather than two predicates on one line. *) let pred_entails ~declared ~wanted = String.equal declared wanted || match wanted, declared with | "is-ordered", ("is-numeric" | "is-integer" | "is-enum") -> true | "is-equal", ("is-numeric" | "is-ordered" | "is-integer" | "is-enum") -> true (* Every integer type is a number, so [is-integer] gives a body everything [is-numeric] does — the arithmetic, the written 0, the untyped integer literal — on top of the operations only it admits. The reverse is never true: [is-numeric] admits floats, which is exactly what a body under [is-integer] is promising it never meets. *) | "is-numeric", "is-integer" -> true | _ -> false let declares preds v wanted = List.exists (fun (p : Ast.pred) -> String.equal p.Ast.pvar v && pred_entails ~declared:p.Ast.pname ~wanted) preds (* Which variable, if any, a type bottoms out at. Only a bare variable can carry a predicate: [(Vec t)] is a Vec whatever [t] is, and its own properties are the Vec's. *) let tyvar_of (t : Types.t) = match t with Types.Var v -> Some v | _ -> None (* ── (Map K V), spec-memory.md ────────────────────────────────────────── Both halves are checked where the type is written, not where an operation is, so that a map nothing ever uses is still refused if it cannot work. [Check.key_pair] emits the hash and equality pair later, at the operation, and repeats these refusals rather than assuming: the two are reached by different paths and a silent disagreement between them would be worse than saying the same thing twice. *) let map_type ?(preds = []) loc (k : Types.t) (v : Types.t) = ignore preds; (* The value used to be refused here when it owned anything, in the same words [(Vec (Vec T))] used, and the refusal is gone for the reason set out over [map-new]: it was about *teardown*, and which tier this map will be built against is not knowable where its type is written. The question is asked at the construction instead, of the allocator, once. *) (* () has no bytes, so a slot for one is a slot of nothing: the cell geometry divides the cache line by the element size and there is nothing to divide by. It is also the natural spelling of a *set*, which is why someone will write it, so it is refused by name rather than by a crash. *) if Types.equal v Types.Unit then fail loc "a map value cannot be () — write (Map %s bool) and ignore the value" (tyname loc k); if Types.equal k Types.Unit then fail loc "a map key cannot be () — every key would be the same key"; (* The key, as far as the type alone can say. A struct passes here and is decided at the operation, by [key_pair], which walks its fields — the struct table is not necessarily complete while a type is being resolved, and every map that exists reaches an operation anyway, because a global map starts zeroed and a local needs (map-new). *) (* A type variable is a map key exactly when the [where] clause says it is hashable. Nothing else about it is knowable here, and falling through to [Types.keyable] would answer no for a variable that is about to be instantiated at [string]. *) if not (match k with | Types.Var v -> declares preds v "is-hashable" | k -> Types.keyable k) then fail loc "%s is not a map key. A key is an integer, an enum, a bool, a string, a \ fixed array of those, or a struct of those" (tyname loc k); Types.Map (k, v) (* The positions a function value may not be written in, and the one reason they are all the same position: something zeroes it. The zero is the whole reason: a capturing value's environment belongs to the collector and may be kept anywhere, and [(Option (Fn ...))] is how a field or a global holds one. ZII is the language's rule — an omitted struct field, a fixed array's elements, a [defonce] with no initialiser are all all-bytes-zero — and a zeroed function value is a null pointer with a signature on it, which is the one kind of zero that cannot be used for anything. Every other type's zero is a value: 0, false, an empty slice, [None], a data type's first case. So these are refused where they are written rather than left to crash at the call. A parameter, a return type, a [let] binding and an [(Option (Fn ...))] are not on the list: none of them is ever conjured, and an [Option]'s zero is a [None] whose tag nobody may look past. *) (* The two function types as one question, for every place that wants the signature and does not care which of them carries an environment: a call site, a shadowing guard, a walk over the parameters. Where the difference matters it is matched on directly, and there are few such places — the representation is [Emit]'s business and the coercion is [expect]'s. *) let fn_sig (t : Types.t) = match t with | Types.Fn (ps, r) | Types.CFn (ps, r) -> Some (ps, r) | _ -> None let callable_ty t = fn_sig t <> None (* A (CFn ...) is not on the list: it is one code address, and every call through one tests for null and signals NullCall (see [Emit.null_check]), so a zeroed one is an empty slot rather than a crash. That is what lets a table of function pointers be a struct or a fixed array. An (Fn ...) stays refused: a call through one is not tested, and (Option (Fn ...)) is the field that holds one. *) let rec no_zeroed_fn loc what (t : Types.t) = match t with | Types.Fn (ps, r) -> fail loc "%s cannot be %s — it would be zeroed, and a zeroed function value is a \ null pointer. Pass it as a parameter, hold it in a let, or store a \ %s if it captures nothing" what (tyname loc t) (tyname loc (Types.CFn (ps, r))) | Types.Array (_, e) -> no_zeroed_fn loc what e | _ -> () (* ── What may be overwritten with raw bytes ──────────────────────────── [(filled b)] and [(sentinel-filled)] are the only two things in the language that write a byte pattern over storage the type system has an opinion about, so the question they raise is which types survive having arbitrary bytes put in them. The answer here is the narrow one: numbers, and aggregates built out of numbers. Everything else is refused by name. What is being kept out, and why each one is not a matter of taste: - [dyn]. A struct that holds a dyn is rooted on the collector's root stack with a descriptor naming the byte offsets of its dyn words (see the per-type descriptor note at the bottom of this file). Filling one leaves a word that is not a dyn at an offset the collector is told to walk, and the next collection follows it. The refusal is what keeps that from being reachable at all. - [Vec], [(Map K V)], [Allocator]. An owning header: a pointer, a length, a capacity and an allocator the runtime frees through. A filled one is a free of a wild pointer the first time it is touched. - [string] and a slice. Two words, the second of which is a length every bounds check believes. A filled length is a bounds check that passes and an access that does not. - [bool]. The one refusal that is about the backends rather than the runtime: a bool is a byte here and an [i1] to LLVM, which reads the low bit, where x86 compares the whole byte against zero. 0xDE is false on one and true on the other, and byte-identical behaviour across the two backends is the property this feature is pinned on. - an enum, a data type, an [(Option T)], a function value. Each carries a tag or a case index that something later reads as a small number with a meaning, and a filled one names a case that does not exist. Floats are in: every bit pattern is a float, NaNs included, and both backends move one as bytes. So is a [Ptr], which the collector does not walk and whose poisoned value is the useful case, and an untagged union whose members are all admitted, filled over its whole size. *) let rec unfillable env seen (t : Types.t) : Types.t option = match t with | Types.Int _ | Types.Float _ | Types.Ptr _ -> None | Types.Array (_, e) -> unfillable env seen e | Types.Named n when not (List.mem n seen) -> (match match Hashtbl.find_opt env.structs n with | Some s -> Some s | None -> Hashtbl.find_opt env.unions n with | Some s -> List.fold_left (fun acc (fl : Tast.field) -> match acc with | Some _ -> acc | None -> unfillable env (n :: seen) fl.Tast.fty) None s.Tast.fields (* A data type, the one [Named] thing in neither table: its tag names a case, so the type itself is what the refusal names. *) | 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 jreplace struct_apps key (g, args); Hashtbl.replace Types.display key (Printf.sprintf "(%s %s)" g (String.concat " " (List.map Types.to_string args))); Hashtbl.replace Types.display_app key (g, 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 l = Option.value (Hashtbl.find_opt env.locs name) ~default:Loc.unknown in fail l "%s contains itself by value, so it has no size — go through %s" (tyname l (Types.Named name)) (tyname l (Types.Ptr (Types.Mut, Types.Named 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 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 keyed on the bare name and every membership test has to strip first. A name with no sigil is its own bare name. *) let tyvar_bare n = if n <> "" && n.[0] = '$' then String.sub n 1 (String.length n - 1) else n (* Is this name, as written, a type variable that is in scope here? Both spellings answer yes, because both denote the same variable: the sigil is the binding site's and is redundant rather than wrong in the body. Every test against [tyvars] or [subst] goes through this, so a caller cannot ask the question of the raw name and miss the spelling with the sigil — which is what made [(vec-new $t)] report a missing element type for a body that had written one. *) let tyvar_in_scope env n = let bare = tyvar_bare n in List.mem bare env.tyvars || List.mem_assoc bare env.subst let rec resolve env ?(seen = []) (t : Ast.texpr) : Types.t = let loc = t.Ast.tloc in match t.Ast.t with (* The one slot that takes [_] never reaches here: [collect] reads it off the body first. So every [_] that does is in a slot with no body behind it. *) | Ast.Tinfer -> Loc.failk "check/infer-misplaced" loc "_ here asks for a type to be read off a function body, and only a \ defn's return slot has a body to read. Write the type out" | Ast.Tname "const" -> fail loc "const is not a type on its own — it marks one that can only be read, \ as in [const u8] or (Ptr const u8)" | Ast.Tname n -> resolve_name env ~seen loc n | Ast.Tslice (c, e) -> Types.Slice ((if c then Types.Const else Types.Mut), resolve env ~seen e) | Ast.Tarray (l, e) -> let e = resolve env ~seen e in no_zeroed_fn loc "a fixed array's element" 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 built with (map-new) and filled with (put). *) | Ast.Tmap (k, v) -> map_type ~preds:env.tvpreds loc (resolve env ~seen k) (resolve env ~seen v) (* (Fn [T ...] R) is a code address and the environment it is called with: two words. A value made out of a name carries a null there; one made out of an [fn] that captures carries the address of its copies: a slot of the frame it was written in, or an environment the collector allocated when the value outlives that frame (see [place_closures]). (CFn [T ...] R) is the address alone, one word, and nothing that can capture — see [Types] for why the C is information rather than decoration, and for why it is not yet a capability. Nobody needs it: [Fn] accepts everything, and the commonest reason to reach for the narrow one is that a *named* function handed to an [Fn] pays a hop through the widening thunk where a [CFn] is a direct call. Where one may be *written* is narrower than where the type resolves, and the two rules live apart on purpose: this is what the spelling means, and [no_zeroed_fn] is where a position that would zero one is refused. A parameter, a return type and a let binding are the positions that work, for both. *) | Ast.Tfn (env', ps, r) -> let ps = List.map (resolve env ~seen) ps and r = resolve env ~seen r in if env' then Types.Fn (ps, r) else Types.CFn (ps, r) | Ast.Tapp (name, args) -> (match name, args with | "Ptr", [ a ] -> Types.Ptr (Types.Mut, resolve env ~seen a) (* The pointer beside [[const T]]: nothing is written through it, and a (Ptr T) converts to one. [const] cannot name a type, so this reading is the only one the two arguments have. *) | "Ptr", [ { Ast.t = Ast.Tname "const"; _ }; a ] -> Types.Ptr (Types.Const, resolve env ~seen a) | "Option", [ a ] -> Types.Option (resolve env ~seen a) | "Ptr", _ -> fail loc "a pointer type is (Ptr T), or (Ptr const T) for one \ nothing is written through" | "Option", _ -> fail loc "(Option T) takes exactly one type" | "Vec", [ a ] -> let e = resolve env ~seen a in (* A Vec of a Vec used to be refused here, and the refusal named two different failures under one sentence: that [clone] would duplicate inner headers instead of copying, and that [free] would drop their buffers on the floor. Only the second one was about *teardown*, and only the second one an arena answers — [free-all] takes the region and the inner blocks with it, because they came out of the same region. So the type is admitted, the tier is checked at the construction where the allocator is a value that exists (see [vec-new]), and [clone] stays refused at the operation, on its own merits, in its own words. It cannot be refused *here* because nothing here knows the tier: [with-allocator] rebinds a dynamic variable, so which allocator a [(vec-new)] meets is not a property of where the type is written. *) Types.Vec e | "Vec", _ -> fail loc "(Vec T) takes exactly one type" | "Map", [ k; v ] -> map_type ~preds:env.tvpreds loc (resolve env ~seen k) (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 | _ -> (* 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. *) let constructors = [ "Ptr"; "Option"; "Vec"; "Map" ] in (match if Hashtbl.mem env.aliases name || Hashtbl.mem env.structs name || Hashtbl.mem env.datas name || Hashtbl.mem env.unions name || Hashtbl.mem env.enums name then None else near_miss env ~also:constructors name with | Some m when List.mem m constructors -> Loc.failk "check/unknown-type" loc "unknown type %s — did you mean %s?" name m | _ -> ()); fail loc "%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 " ^ tyname a.Ast.tloc 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 jreplace env.copies key (List.exists generic_arg targs); jreplace 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 (tyname loc) 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. *) jreplace env.copies key generic; jreplace env.structs key { Tast.sname = key; fields = [] }; jreplace 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 (); jreplace env.structs key { Tast.sname = key; fields }; finite_from env key; key | exception e -> restore (); jremove env.copies key; jremove 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 (tyname loc (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 is no longer a typo, it is a guess. *) and near_miss env ?(also = []) n = (* [also] widens the candidate list past the types, and exactly one caller passes it: the defonce whose third element has to be a type *or* a value, whose suggestion is worth nothing if it can only ever name a type. *) let candidates = also @ Types.primitive_names @ Hashtbl.fold (fun k _ acc -> k :: acc) env.aliases [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.structs [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.datas [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.unions [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.enums [] in List.find_opt (fun c -> c <> n && one_edit n c) candidates and resolve_name env ~seen loc n = (* ── Type variables, with a sigil at the binding site ───────────────── [$t] *introduces* a variable and bare [t] uses it, which is Odin's spelling ([$T] in the signature, [T] in the body). The sigil is read as an ordinary symbol character, so the whole decision lives here: nothing in the reader, the parser or the AST knows the character means anything. Which names are variables is decided before this is ever called — [signature_tyvars] scans the signature for the sigil and puts the bare names in [env.tyvars] — so an unknown lowercase name is still the unknown-type error it always was. That is the point of the sigil: without 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.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 at all. Where none is — a struct field, a global, a [let] annotation — there is nowhere for a variable to bind and the fix is a concrete type. Where some are, the name is almost always a variable that was introduced once and spelled differently the second time, and the fix is one of the names that *is* bound. Naming them is the difference between a rule and an answer. Which names those are is read from [tyvars] during the abstract pass and from [subst] inside an instantiation, because the instantiation clears the first and fills the second — and a body is checked under both, so reading only one of them would answer the same mistake two ways in a single run. *) (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 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) | 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 " (List.map (fun v -> "$" ^ v) vars))) else match Types.ikind_of_name n with | Some k -> Types.Int k | None -> match Types.fkind_of_name n with | Some k -> Types.Float k | None -> match n with | "bool" -> Types.Bool | "char" -> Types.Char | "str" -> Types.String (* Lowercase and concrete, which the rule three screens down says is a type variable. It is spelled this way because it is a primitive and every other primitive is lowercase — [dyn] beside [i64] and [bool] reads as one of them, [Dyn] beside [Vec] and [Option] reads as a container over something. The type-variable rule is reached by a [when] guard below and this arm is before it, so the spelling costs nothing but the note. *) | "dyn" -> Types.Dyn | "Unit" -> Types.Unit | "Never" -> Types.Never (* A builtin opaque type, the way [string] is a builtin ptr+len. There is no user-writable constructor and no way to name its procedure: see Types, and TODO.org, "The escape was real: a value the compiler builds trips no function-value refusal". *) | "Allocator" -> Types.Alloc | _ when Hashtbl.mem env.aliases 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. Keeping them one case is what lets a data type be a field, a parameter, a return type and a slot without a single one of those paths learning that data types exist. *) | _ when Hashtbl.mem env.datas n -> Types.Named n (* And so is an untagged union, for the same reason: it is a value of a size and an alignment, and nothing that carries one has to know it is a union rather than a struct. *) | _ when Hashtbl.mem env.unions n -> Types.Named n | _ when Hashtbl.mem env.enums n -> Types.Enum n (* A typo in a primitive is lowercase too, and the type-variable rule below would otherwise report [f65] as unimplemented generics and send you to plan.org instead of to the character you mistyped. *) | _ when foreign_spelling n <> None -> Loc.failk "check/unknown-type" loc "unknown type %s — Flan spells it %s" n (Option.get (foreign_spelling n)) | _ when near_miss env n <> None -> Loc.failk "check/unknown-type" loc "unknown type %s — did you mean %s?" n (Option.get (near_miss env n)) (* An unknown lowercase name, and the sentence it gets used to be that generics were milestone 5 work. They are not: [$t] binds a type variable and bare [t] uses one, and [resolve_name] has already consulted [env.tyvars] and [env.subst] before anything reaches here. So a lowercase name arriving at this arm is one of exactly two things, and the message names both rather than sending somebody to a schedule. Either it is a typo too far from any type to be guessed at — the near-miss arm above catches the one-edit ones — or it is a type variable that was never introduced, which is the sigil's whole purpose to notice: without the binding site a mistyped type name silently became a type parameter and made the signature more 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: 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 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 \ defn signature introduced it — write $%s in the parameter vector \ to introduce one, and %s reads it from there" n n n | _ -> Loc.failk "check/unknown-type" loc "unknown type %s" n and array_len env loc = function | Ast.Lint n -> n | Ast.Lname n -> 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 (tyname loc 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 \ an array length" n) (* ── Pairing a defn's parameter vector ────────────────────────────────── [(defn f [x y] ...)] is one parameter [x] of type [y] if [y] names a type, and two parameters of type [dyn] if it does not. Parse could not tell — the long argument is beside its [defn] case — so it handed over the slots undecided and this is where they are paired, with every type name in hand: every file loaded, every macro expanded, every C header imported. The walk is left to right and takes two slots or one. A name followed by something that is a type takes two and is annotated; a name followed by another name that is not a type, or by nothing, takes one and is [dyn]. That is the whole rule, and it reads the way the vector reads. A name that *is* a type name pairs only when a type follows it: [[str str]] has one reading. [(defn f [i64 x] ...)] has two — a dyn parameter called [i64], or a pair written backwards — so it is refused rather than handed back as a signature nobody wrote. *) let is_type_name env n = Types.ikind_of_name n <> None || Types.fkind_of_name n <> None || List.mem n [ "bool"; "char"; "str"; "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 (* A type variable: [$t] in a signature is generics' binding site, and a slot holding one is a type however few of them there are. *) || (n <> "" && n.[0] = '$') (* A defn written without its return type puts the body's first form in the slot, and [(dotimes [i n] ...)] parses as a type application. Every type application's head is a constructor, and a constructor is capitalised, so a lowercase head there — or the name of a function — is a body form and not a malformed type. A capitalised head that is neither stays with [resolve], whose unknown-type and no-type-arguments sentences are the right ones for [(Vect i32)] and [(Pair i32)]. *) let missing_return_type env (fn : Ast.fn) = match fn.Ast.ret with | Some { Ast.t = Ast.Tapp (head, args); tloc } -> let lowercase = head <> "" && not (head.[0] >= 'A' && head.[0] <= 'Z') in let constructor = List.mem head [ "Ptr"; "Option"; "Vec"; "Map"; "Result" ] in (* [(vec i32)] is the constructor with the wrong case, not a body form — but only while every argument is a type, since [(map inc xs)] is a body form whose head is a function. *) let args_are_types = List.for_all (fun (a : Ast.texpr) -> match a.Ast.t with Ast.Tname n -> is_type_name env n | _ -> true) args in (match List.find_opt (fun c -> String.lowercase_ascii c = String.lowercase_ascii head && c <> head) [ "Ptr"; "Option"; "Vec"; "Map" ] with | Some c when args_are_types && not (is_type_name env head) -> Loc.failk "check/unknown-type" tloc "unknown type %s — did you mean %s?" head c | _ -> ()); if (not constructor) && (not (is_type_name env head)) && (lowercase || Hashtbl.mem env.fns head || List.mem head !builtin_names) then Loc.failk "check/return-type-missing" tloc "%s has no return type: (%s ...) stands where the return type goes, \ and %s is not a type. The return type is written between the \ parameter vector and the body, and a function that returns nothing \ writes () there, or _ to read it off the body" fn.Ast.name head head | _ -> () (* Before a bare symbol is allowed to become an unannotated parameter, the two ways it is more likely to be a type that went wrong. This is the cost dynamic-by-default puts on the parameter vector, and it is worth naming plainly: a slot with no type used to be a syntax error, and now it is a [dyn] parameter. So [(defn f [x f65] ())] — a typo for [f64] — no longer reads as a mistyped type. It reads as two parameters, one of them called [f65], and the function silently takes an argument nobody meant to give it. An arity that changes because of a typo, with no diagnostic, is the failure class Parse's [defn] comment calls the worst available, and the feature reintroduces it in a new place. Two rules take most of it back. A name within one edit of a type's name is the typo it looks like, and is refused with the same "did you mean" the resolver gives — the near-miss table is already there and is exactly the right question. And a capitalised name is a type by the convention the whole corpus keeps: not one parameter in the language is capitalised, while [Form], [Cursor], [Vector2] and the rest appear in these vectors constantly. So an unknown capitalised name is an unknown *type*, reported as one, rather than a parameter nobody would have spelled that way. What is left uncovered is a lowercase name that resembles no type: [(defn f [x widget] ())] is two dyn parameters and there is no evidence in the text that it was meant to be one. That case is the feature working as specified, and it is the residual the parent owns. *) let dyn_param_or_typo env n loc = (* [(defn idx [v i] dyn ...)] is two dyn parameters, and [i] is one edit from [i8], so the did-you-mean used to accuse a perfectly ordinary parameter name of being a mistyped type. What separates the two is the digits: this language sizes its machine types in the name, so a typo in one keeps them — [f65] for [f64], [i33] for [i32] — while [i], [v], [n] and [x] carry none and are what parameters are actually called. A name with no digit, one edit from a type that has one, is a parameter; the suggestion is dropped and the dyn reading stands, which is the reading the writer meant. *) let has_digit s = String.exists (fun c -> c >= '0' && c <= '9') s in let suggestion = match near_miss env n with | Some m when has_digit m && not (has_digit n) -> None | m -> m in (* In a .fln file the type sits after [name:], so it cannot be read as a second parameter and needs no word about parameter vectors. *) let fln = Source.indented_at loc in (* [string] is what most languages call the text type, so [[s string]] is far likelier one parameter of a misspelled type than two dyn ones. The other foreign spellings ([long], [byte], [double]) are ordinary parameter names and keep the dyn reading. *) if n = "string" then Loc.failk "check/unknown-type" loc "unknown type string — Flan spells it str%s" (if fln then "" else ". Otherwise string reads as a second parameter, because a \ parameter with no type is dyn, and wants another name"); match suggestion with | Some m when fln -> Loc.failk "check/unknown-type" loc "unknown type %s — did you mean %s?" n m | Some m -> Loc.failk "check/unknown-type" loc "unknown type %s — did you mean %s? Otherwise %s reads as a second \ parameter, because a parameter with no type is dyn" n m n | None -> if n <> "" && n.[0] = Char.uppercase_ascii n.[0] && n.[0] <> Char.lowercase_ascii n.[0] then if fln then Loc.failk "check/unknown-type" loc "unknown type %s" n else Loc.failk "check/unknown-type" loc "unknown type %s. A capitalised name in a parameter vector is a type; \ parameters are lowercase" n (* The pairings a parameter vector owes to a type the program declares under a name that is also a legal parameter name — a lowercase one, since a capitalised name is refused as a parameter. [(defn f [p point] ...)] is one parameter while [point] is a type and two dyn ones the moment it is not, so adding or removing the type re-pairs the signature with no edit to it. The type still wins; this is the warning at the parameter, filled by [pair_decls] and printed by [build_program] with the other warnings. *) let pairing_warnings : Loc.diag list ref = ref [] let pair_params ?(also = fun _ -> false) ?(declared = fun _ -> None) ?(hide = fun _ -> false) env (items : Ast.pitem list) : Ast.field list = let is_type_name env n = (is_type_name env n && not (hide n)) || also n in let warn_pairing n t tloc = let bare = match String.rindex_opt t '/' with | Some i -> String.sub t (i + 1) (String.length t - i - 1) | None -> t in match declared t with | Some (what, (at : Loc.t)) when bare <> "" && bare.[0] >= 'a' && bare.[0] <= 'z' -> pairing_warnings := Loc.diag ~kind:"check/parameter-reads-a-type" tloc (Printf.sprintf "[%s %s] is one parameter %s of type %s, the %s declared at %s, \ and not two dyn parameters. If two were meant, give the second \ a name no type has" n t n t what (Loc.to_string at)) :: !pairing_warnings | _ -> () in let dyn loc = { Ast.t = Ast.Tname "dyn"; tloc = loc } in let rec go = function | [] -> [] | Ast.Ptype t :: _ -> Loc.failk "check/parameter-name-expected" t.Ast.tloc "a parameter's name was expected here, and this is a type. Parameters \ are [name Type ...]" (* A parameter may share a type's name — [str] is a common name for text — when a type follows it: [[str str]] and [str: str] can only be a name then a type. Without a type after it, [[i64 x]] is a pair written backwards as likely as a dyn parameter called [i64], so that one is refused with both fixes. *) | Ast.Pname (n, loc) :: Ast.Ptype t :: rest when is_type_name env n -> { Ast.fname = n; fty = t; floc = loc } :: go rest | Ast.Pname (n, loc) :: Ast.Pname (t, tloc) :: rest when is_type_name env n && is_type_name env t -> { Ast.fname = n; fty = { Ast.t = Ast.Tname t; tloc }; floc = loc } :: go rest | Ast.Pname (n, loc) :: _ when is_type_name env n -> Loc.failk "check/parameter-named-type" loc "%s names a type, and no type follows this parameter called %s. Give \ it one, as [%s %s], or if the pair is backwards write [name %s]" n n n n n (* [_] reads a type off a body, and a parameter has none to read. *) | Ast.Pname (n, _) :: Ast.Pname ("_", tloc) :: _ -> Loc.failk "check/infer-misplaced" tloc "_ here asks for %s's type to be read off a body, and a parameter's \ type is never read off anything. Write its type, or leave it out \ and %s is dyn" n n | Ast.Pname (n, loc) :: Ast.Ptype t :: rest -> { Ast.fname = n; fty = t; floc = loc } :: go rest | Ast.Pname (n, loc) :: Ast.Pname (t, tloc) :: rest when is_type_name env t -> warn_pairing n t tloc; { Ast.fname = n; fty = { Ast.t = Ast.Tname t; tloc }; floc = loc } :: go rest (* The slot after this one is not a type, so this one is a parameter with no type written — unless the slot after it only *looks* unlike a type because it was mistyped, which is what the check is for. The next slot is the one interrogated, not this one: this one is a name either way. *) | Ast.Pname (n, loc) :: (Ast.Pname (t, tloc) :: _ as rest) -> dyn_param_or_typo env t tloc; { Ast.fname = n; fty = dyn loc; floc = loc } :: go rest | Ast.Pname (n, loc) :: rest -> { Ast.fname = n; fty = dyn loc; floc = loc } :: go rest in go items (* A class slot's type, held to the set a stored dyn value can be checked against. A class's name is a type here, and only here: it is not a type anywhere else in the language, since an instance is a dyn value. Every other type a slot could name — a struct, a Vec, a pointer — does not cross into dyn at all, so a slot of one could never be written. *) (* A class named in [cls]'s slot vector: [n] as written, or [n] in [cls]'s own package, since [Load] leaves a bare name in a slot vector unqualified. *) let class_named ~classes cls n = (* The class's own package first: an importer may declare a class of the same bare name, and a slot the package wrote means the package's. *) let own = match String.rindex_opt cls '/' with | Some i -> let q = String.sub cls 0 (i + 1) ^ n in if List.mem q classes then Some q else None | None -> None in match own with | Some _ -> own | None -> if List.mem n classes then Some n else None let rec slot_of env ~classes cls fname (t : Ast.texpr) : slot_ty = let refuse what = Loc.failk "check/slot-type" t.Ast.tloc "the slot %s of %s is declared %s, and a class slot holds a dyn value, \ which can be checked as bool, an integer type, f32, f64, string, a \ class, or (Option T) of one of those. Write one of those, or leave the \ type out and the slot holds any dyn value: [%s]" fname cls what fname in match t.Ast.t with | Ast.Tname n when class_named ~classes cls n <> None -> Sclass (Option.get (class_named ~classes cls n)) | Ast.Tapp ("Option", [ inner ]) -> (match slot_of env ~classes cls fname inner with | (Sval _ | Sclass _) as s -> Sopt s | Sany -> refuse "(Option dyn)" | Sopt _ as s -> refuse ("(Option " ^ slot_text s ^ ")")) | _ -> (match resolve env t with | Types.Dyn -> Sany | (Types.Bool | Types.Int _ | Types.Float _ | Types.String) as t -> Sval t | other -> refuse (tyname t.Ast.tloc other)) (* The type's word in the string the runtime reads: the scalar type's name, [#name] for a class, [?] in front for an Option. See [slot_type_of] in runtime/flan_dyn.c, which is the reader. *) let rec slot_word = function | Sany -> "" | Sval t -> Types.to_string t | Sclass c -> "#" ^ c | Sopt s -> "?" ^ slot_word s (* What the runtime is told a class is: one line per slot, in constructor order, the slot's name and then its type's word after a space — no type for a dyn slot. The same string goes to [flan_dyn_map_new_class] from the constructor and to [flan_dyn_class_def] from a reload, so the two cannot describe one class differently. *) let class_spec_of (slots : (string * slot_ty) list) = String.concat "\n" (List.map (fun (n, t) -> match t with Sany -> n | t -> n ^ " " ^ slot_word t) slots) let class_slots env n = Hashtbl.find_opt env.classes n (* A class's slot vector, paired by [pair_params]'s rule with the program's class names counted as types — so [[owner point]] is one slot holding a point. A lowercase name after a name that is neither a type nor a class is a second untyped slot, which is the rule for a [defn]'s parameters and is not changed here. In a vector that types none of its slots that is the plain reading — [[x y]] is two slots and says nothing more. In one that types some of them, two untyped names side by side are as likely a type nobody has declared, so that is said, at the second name, and the slot stays what the rule makes it. *) let pair_slots env ~classes cls (items : Ast.pitem list) : Ast.field list = let fields = pair_params ~also:(fun n -> class_named ~classes cls n <> None) env items in let untyped (f : Ast.field) = match f.Ast.fty.Ast.t with Ast.Tname "dyn" -> true | _ -> false in let written_dyn = List.exists (function Ast.Pname ("dyn", _) -> true | _ -> false) items in if List.exists (fun f -> not (untyped f)) fields && not written_dyn then begin let rec scan = function | (a : Ast.field) :: ((b : Ast.field) :: _ as rest) -> if untyped a && untyped b then prerr_endline (Loc.entry ~mark:'~' ~label:"warning: " b.Ast.floc (Printf.sprintf "%s reads as a slot of %s with no type, because no type or \ class is named %s. If it was meant as the type of %s, \ declare it; if it is a slot, write its type or write \ [%s dyn] to say it holds any value" b.Ast.fname cls b.Ast.fname a.Ast.fname b.Ast.fname)); scan rest | _ -> () in scan fields end; fields (* Every [defn] in the program, with its parameter vector paired. Run as a pass of its own, after the type names are registered and before any signature is resolved, so that nothing downstream ever sees an unpaired one. *) let pair_decls env (decls : Ast.decl list) : Ast.decl list = let classes = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with Ast.Defclass (n, _) -> Some n | _ -> None) decls in (* The types the program declares, with what kind and where, for [pair_params]'s warning. The prelude's are left out: its names are the language's, not a declaration the reader made. *) let types = Hashtbl.create 16 in List.iter (fun (d : Ast.decl) -> let add n what = if d.Ast.dloc.Loc.file <> Prelude.file && not (List.mem n Types.primitive_names) then Hashtbl.replace types n (what, d.Ast.dloc) in match d.Ast.d with | Ast.Defstruct (n, _, _) -> add n "struct" | Ast.Defenum (n, _) -> add n "enum" | Ast.Defalias (n, _) -> add n "alias" | Ast.Defdata (n, _) -> add n "data type" | Ast.Defunion (n, _) -> add n "union" | _ -> ()) decls; pairing_warnings := []; (* A prelude signature is paired against the prelude's types alone: a program's type named [t] must not turn the prelude's parameter [t] into a type. *) let fn ~prelude (f : Ast.fn) = match f.Ast.praw with | None -> f | Some items -> let hide n = prelude && Hashtbl.mem types n in { f with Ast.params = pair_params ~hide ~declared:(Hashtbl.find_opt types) env items; praw = None } in List.map (fun (d : Ast.decl) -> let prelude = String.equal d.Ast.dloc.Loc.file Prelude.file in match d.Ast.d with (* A class's slot vector is paired here and nowhere earlier, for the reason a [defn]'s is, and its constructor is written from the pairs — [Classes.expand] left the declaration as it was for exactly this. *) | Ast.Defclass (n, items) -> let slots = pair_slots env ~classes n items in Hashtbl.replace env.classes n (List.map (fun (f : Ast.field) -> (f.Ast.fname, slot_of env ~classes n f.Ast.fname f.Ast.fty)) slots); Classes.constructor n slots d.Ast.dloc | Ast.Defn f -> { d with Ast.d = Ast.Defn (fn ~prelude f) } | Ast.Declare (f, c) -> { d with Ast.d = Ast.Declare (fn ~prelude f, c) } | Ast.DeclareC (f, c) -> { d with Ast.d = Ast.DeclareC (fn ~prelude f, c) } | _ -> d) decls (* ── The third element of a defonce, decided ──────────────────────────── The author's rule, 2026-09-20: "if it's 3 atoms then it's dyn", and "dispatch the if it's a type do the right thing". [(defonce current-color i32)] is the zeroed static it has always been, and [(defonce score 0)] is a dyn global holding 0 — the same thing [(defonce score dyn 0)] spells out, lowered by the same path and not by a second one. [Parse] settled every shape a shape can settle and handed the rest over carrying both readings ([Ast.Ambiguous], beside the type reading in the same [Defvar]). What is left is the two forms only a name can settle, and this is the first point where every type name is in hand: the same point [pair_params] reads, for the same reason — a defonce may name a struct declared fifty lines below it. The type reading wins wherever there is one. That is what keeps today's programs meaning today's thing: [(defonce p Point)] is a zeroed [Point], [(defonce v (Vec i32))] is a zeroed [Vec], and a wrong type argument inside one stays a type error rather than becoming an unknown function. It is also why a built-in constructor is checked by name rather than by whether [resolve] happens to accept it — [(Vec i32 i32)] is a malformed [Vec] and not a call to something called [Vec]. A type and a value cannot share a name: [collect]'s [claimed] table is over every declaration kind there is, so one name is one declaration and the two readings can never both be live. *) let defvar_reads_as_type env (t : Ast.texpr) = match t.Ast.t with | 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. *) | _ -> true (* The bare symbol that is neither. Before the rule there was one reading and the message was "unknown type"; now the position takes either kind of name, so a message naming only one of them would send a reader looking for the wrong mistake. Both readings, both spellings, and the near miss over the value names as well as the type names. *) (* Both readings, and the paragraph that explains them — but only when both readings really are open. Three things get in ahead of it, because each one knows which of the two the writer meant and the paragraph would bury that under a lecture about a fork they are not standing at: a case name, which is a third thing entirely and has its own spelling; a name another language spells for a type this one has under a different name; and a plain type typo, where a confident one-edit suggestion turns a one-line answer into four lines of unrelated reading. The paragraph is for the name that genuinely could have been either and is neither. *) let defvar_neither env loc ~form gname n ~values ~cases = (match List.assoc_opt n cases with | Some dname -> Loc.failk "check/defvar-case-not-type" loc "%s is a case of the data type %s, and a case is not a type of its \ own — the global's type is the data type: (%s %s %s). Assign the \ case you want, as (set %s (%s.%s {.field value ...}))" n dname form gname dname gname dname n | None -> ()); (match foreign_spelling n with | Some m -> Loc.failk "check/unknown-type" loc "unknown type %s — Flan spells it %s" n m | None -> ()); (match near_miss env n with | Some m -> Loc.failk "check/unknown-type" loc "unknown type %s — did you mean %s?" n m | None -> ()); let hint = match near_miss env ~also:values n with | Some m -> Printf.sprintf " — did you mean %s?" m | None -> "" in Loc.failk "check/defvar-neither-type-nor-value" loc "%s is neither a type nor a value, and the third element of a %s has \ to be one or the other: a type there declares a zeroed global of that \ type — (%s %s i64) — and a value there declares a dyn global holding \ it — (%s %s 0). Nothing named %s is declared as either%s" n form form gname form gname n hint (* Every name a value could be written under, which is every declaration that is not a type plus whatever a session already has. The list is only ever asked "is this name declared at all", so a global that is itself a defonce still undecided belongs on it: what it resolves to is the next pass's question, not this one's. *) (* The infinities and NaNs, which the reader has no literal for and the integer-only constant folder cannot compute, so the compiler supplies them beside the prelude's f64-max and the rest. Negative infinity is [(- f64-inf)]. *) let special_float = function | "f64-inf" -> Some (Float.infinity, Types.F64) | "f64-nan" -> Some (Float.nan, Types.F64) | "f32-inf" -> Some (Float.infinity, Types.F32) | "f32-nan" -> Some (Float.nan, Types.F32) | _ -> None (* Case name -> the data type it belongs to, read off the declarations rather than out of [env.cases]: this runs inside [collect], which has registered the data type *names* by here but not resolved their cases, so the table would be empty. Last writer wins, exactly as [env.cases] does, and for the same reason — this is only ever asked "what is this a case of", and two data types may share a case name. *) let case_owners (decls : Ast.decl list) = List.concat_map (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defdata (dn, vs) -> List.map (fun (v : Ast.variant) -> (v.Ast.vname, dn)) vs | _ -> []) decls let value_names env (decls : Ast.decl list) = let declared = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defvar (n, _, _, _) | Ast.Defconst (n, _, _) -> Some n | Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) -> Some fn.Ast.name | _ -> None) decls in declared @ Hashtbl.fold (fun k _ acc -> k :: acc) env.globals [] @ Hashtbl.fold (fun k _ acc -> k :: acc) env.fns [] (* The decision, applied: an undecided defonce leaves this pass as one of the two forms that already existed, so no pass after it — the signature loop below, [check_global], either backend — has a third case to know about. The dyn reading is rewritten into exactly [(defonce x dyn )], which is the whole of "it lowers to the same thing": the startup lifting, the re-run guard and the collector root are the ones that form already had. *) (* A bracket form whose element names a value. [(defonce g [a b])] parses as a type and stays one — type wins wherever there is a type reading, which is the rule — so the element had to name an element type, and [b] names a defonce. Left alone this reaches [resolve_name], where a lowercase name that is no type is a type variable, and the answer is a paragraph about generic code the writer was not asking for. Both readings, and both spellings, at the element that decided it. The dyn spelling is the one that actually works: [(defonce g dyn [a b])] is a dyn global holding a vector, which is what the brackets meant to whoever wrote them. *) let rec bracket_value_element env values (t : Ast.texpr) = let elem (e : Ast.texpr) = match e.Ast.t with | Ast.Tname n when (not (is_type_name env n)) && List.mem n values -> Some (n, e.Ast.tloc) | _ -> bracket_value_element env values e in match t.Ast.t with | Ast.Tslice (_, e) -> elem e | Ast.Tarray (_, e) -> elem e | _ -> None let settle_defvars env (decls : Ast.decl list) : Ast.decl list = let values = lazy (value_names env decls) in let cases = lazy (case_owners decls) in (* A bracket form never reaches the fork below: [Parse.defvar3] gives it [Zeroed] outright, because a bracket that parses as a type has no second reading to carry. So the element check runs on both, and it is the only thing the [Zeroed] arm does. *) let brackets ~form gname (t : Ast.texpr) = match bracket_value_element env (Lazy.force values) t with | Some (v, vloc) -> Loc.failk "check/defvar-bracket-element-is-a-value" vloc "%s names a value, not a type, and the brackets around it were read \ as a type — a %s's third element is a type wherever there is a \ type reading, so %s had to be the element type. Write a type there \ for a zeroed global, or put dyn in front of the same brackets — \ (%s %s dyn ...) — for a dyn global holding the vector you wrote" v form v form gname | None -> () in let word = function Ast.Once -> "defonce" | Ast.Every -> "def" in List.map (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defvar (n, Some t, Ast.Zeroed, k) -> brackets ~form:(word k) n t; d | Ast.Defvar (n, Some t, Ast.Ambiguous e, k) -> let form = word k in if defvar_reads_as_type env t then begin brackets ~form n t; { d with Ast.d = Ast.Defvar (n, Some t, Ast.Zeroed, k) } end else begin (match t.Ast.t with | Ast.Tname s when not (List.mem s (Lazy.force values)) && special_float s = None -> defvar_neither env t.Ast.tloc ~form n s ~values:(Lazy.force values) ~cases:(Lazy.force cases) | _ -> ()); let dyn = { Ast.t = Ast.Tname "dyn"; tloc = t.Ast.tloc } in { d with Ast.d = Ast.Defvar (n, Some dyn, Ast.Init e, k) } end | _ -> d) decls (* ── Generics: the four operations monomorphisation needs ─────────────── Naming a variable, binding one from an argument, substituting the binding back in, and spelling the result as a symbol. Everything else about the feature is where these are called from. *) (* 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 sigil_vars ~kinds_of (ts : Ast.texpr list) = let acc = ref [] in 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"; (* [$i32] would shadow a machine type inside the body and read as one everywhere else. There is no reason to want it. *) if List.mem bare Types.primitive_names || 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; 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 -> 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], 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 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 and with the same rule: a variable already bound must match what it is bound to, so [(pair 1 2.0)] over [a $t b $t] is a refusal and not a second instantiation. *) (* [ro] is whether a [[T]] argument may meet a [[const $t]] pattern here: at the top of an argument's type, and under a const slice, which is exactly where [Types.const_widens] lets [expect] convert the value afterwards. *) let rec bind_ty ?(widen = false) ?(ro = true) subst (pat : Types.t) (arg : Types.t) = let inner = bind_ty ~ro:false subst in match pat, arg with | Types.Var v, a -> (match List.assoc_opt v !subst with | None -> subst := (v, a) :: !subst; true | Some b when Types.equal a b -> true (* Two arguments that differ only in const bind the variable to the read-only one, whichever came first — the same meeting an [if]'s two branches have. [expect] converts the writable argument afterwards. *) | Some b when ro -> (match Types.const_join a b with | Some j -> subst := (v, j) :: List.remove_assoc v !subst; true | None -> false) | Some _ -> false) | Types.Slice (m, p), Types.Slice (m', a) when m = m' || (ro && m = Types.Const) -> bind_ty ~ro:(m = Types.Const) subst p a | Types.Ptr (m, p), Types.Ptr (m', a) when m = m' || (ro && m = Types.Const) -> bind_ty ~ro:(m = Types.Const) subst p a | Types.Vec p, Types.Vec a | Types.Option p, Types.Option a -> inner p a (* A plain value at a [$t?] parameter binds [$t] to its own type, and [expect] wraps it (decision 138). At the top of an argument only, as the widening below: an element of a Vec is never wrapped, so [(Vec $t?)] meets a [(Vec i32)] as a mismatch. *) | Types.Option p, a when widen && (match a with Types.Dyn | Types.Never -> false | _ -> true) -> bind_ty ~widen subst p a | Types.Array (n, p), Types.Array (m, a) -> Int64.equal n m && inner p a | Types.Map (k, v), Types.Map (k', v') -> inner k k' && inner v v' (* Each function type against its own. *) | Types.Fn (ps, r), Types.Fn (ps', r') | Types.CFn (ps, r), Types.CFn (ps', r') -> List.length ps = List.length ps' && List.for_all2 inner ps ps' && inner r r' (* And the widening between them, which is admitted at the top of an argument's type and nowhere inside it. [(Fn [$t] $t)] against a [(CFn [i32] i32)] is the shape every caller of a generic higher-order function has, because a [defn]'s name carries [CFn]: [(apply2 bump 1)]. It has to bind here, where the variables are decided, and not only in [expect] — [generic_call] binds first and would have reported the mismatch before [expect] was ever reached. The prelude hides that: its higher-order functions bind [$t] from an earlier argument, so [subst_ty] has already made the parameter concrete by the time this sees it and [(map-in-place s double)] never took this path. [widen] is why it goes no deeper. The widening is a *value* the caller builds — a thunk, minted at the call — and there is exactly one place to build it, around the whole argument. A [(Fn [(Fn [$t] $t)] i32)] parameter handed a [(CFn [(CFn [i32] i32)] i32)] would need one built inside the argument's own parameter list, where no caller stands, so the two types do not meet there and the pattern does not match. What reaches the fallthrough below is an ordinary mismatch and is refused as one, the same answer a call with no type variables in it gets. One way, as everywhere else: a [CFn] pattern does not admit an [Fn] argument. *) | 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 let rec subst_ty subst (t : Types.t) = match t with | Types.Var v -> (match List.assoc_opt v subst with Some c -> c | None -> t) | Types.Slice (m, e) -> Types.Slice (m, subst_ty subst e) | Types.Array (n, e) -> Types.Array (n, subst_ty subst e) | Types.Map (k, v) -> Types.Map (subst_ty subst k, subst_ty subst v) | Types.Ptr (m, e) -> Types.Ptr (m, subst_ty subst e) | Types.Vec e -> Types.Vec (subst_ty subst e) | Types.Option e -> Types.Option (subst_ty subst e) | 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? 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 _ | 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 | Types.Fn (ps, r) | Types.CFn (ps, r) -> 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 straight into holes the rest of the language has no [dyn] answer for yet. *) let rec reaches_dyn (t : Types.t) = match t with | Types.Dyn -> true | Types.Slice (_, e) | Types.Array (_, e) | Types.Ptr (_, e) | Types.Vec e | Types.Option e -> reaches_dyn e | Types.Map (k, v) -> reaches_dyn k || reaches_dyn v | Types.Fn (ps, r) | Types.CFn (ps, r) -> List.exists reaches_dyn ps || reaches_dyn r | _ -> false (* The refusal plan.org's Types section asks for, in one place so that every operator says the same thing: with no constraints a type variable supports only what *every* type supports, so [=], [<], [+] and [hash] over one are rejected rather than silently instantiated at whatever type the first call site happened to use. With [where] there are now two ways out and the message names both: declare the predicate, or take the operation as a function value the way [sort-by] does. Declaring it is the one that keeps the call site short, which is the whole reason predicates exist — under the no-constraint rule [(sort xs)] had to become [(sort-by xs (fn [a b] (< a b)))] at every call site in the corpus. *) (* A predicate as a word in a sentence, [ordered (is-ordered)], and a where clause as the file at [loc] spells one. [v] is the variable with its [$]. *) let pred_word p = let w = if String.length p > 3 && String.sub p 0 3 = "is-" then String.sub p 3 (String.length p - 3) else p in if w = p then p else Printf.sprintf "%s (%s)" w p let where_text loc p v = if Source.indented_at loc then Printf.sprintf "where %s(%s)" p v else Printf.sprintf "{:where (%s %s)}" p v let unconstrained env loc op ~needs (t : Types.t) = if generic_ty t then match tyvar_of t with | Some v when declares env.tvpreds v needs -> () | _ -> Loc.failk "check/unconstrained-type-variable" loc "%s over the type variable %s: nothing declares %s %s. Write \ %s at the head of the body, or take the operation as \ a parameter, a (Fn [%s %s] ...), and call it here" op (tyname loc t) (tyname loc t) (pred_word needs) (where_text loc needs (tyname loc t)) (tyname loc t) (tyname loc 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 *hung*, and [Session.eval] runs the same code — so what hung was [C-c C-c], with the dev daemon wedged behind it and nothing to show the editor. That is the project's stated priority stopped by three lines of ordinary-looking Flan, which is why this is a refusal and not a cap. The spike stopped it with a depth counter refusing past 32. A number is the wrong thing to say: 32 is not in the program, the programmer cannot act on it, and a legitimate deep instantiation and a runaway one look identical in the message. **The structural test is exact.** A generic that is already on the chain and is being asked for again at a type that *contains* the type it was asked for before is growing, and growing without a smaller case is not going to stop. A generic that recurses at the *same* types never reaches here — the cache entry goes in before the body is checked — and one that recurses at a *smaller* or unrelated type is fine and stays fine. The message prints the chain, which is what the programmer can act on: each link is a call site and a type, and the place the type started growing is visible in the list. Odin has no cap of its own to copy, so there was nothing to borrow and this 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 runaway env loc gname cparams = let chain_text () = String.concat "\n " (List.map (fun (g, ps, l) -> Printf.sprintf "%s at (%s), asked for at %s" g (String.concat " " (List.map (tyname loc) ps)) (Loc.to_string l)) (env.chain @ [ (gname, cparams, loc) ])) in let earlier = List.find_opt (fun (g, ps, _) -> String.equal g gname && grows ~from_:ps ~to_:cparams) env.chain in (match earlier with | Some _ -> Loc.failk "check/runaway-instantiation" loc "%s instantiates itself without end — each copy asks for another at a \ type built around the one before:\n %s\nRecur at the same type, or \ at a smaller one" gname (chain_text ()) | None -> ()); (* The backstop. Nothing known reaches it; it exists so that a growth the test above does not recognise is still a refusal with the chain in it rather than a hang. *) if List.length env.chain >= 64 then Loc.failk "check/runaway-instantiation" loc "%s has been instantiated 64 deep and is still going:\n %s" gname (chain_text ()) (* [check_fn] is defined after the expression checker and an instantiation is made from inside it, so the knot is tied here and closed at the bottom of the file. One forward reference rather than moving a 90-line function. *) let check_fn_ref : (env -> Ast.fn -> Tast.fn) ref = ref (fun _ _ -> assert false) (* ── Small helpers over the AST ────────────────────────────────────── *) (* The untyped defconsts whose value is a char literal, by name, with the code point. A use where typed code wants a number is that literal at the number's type, as the literal written there would be, so a byte constant such as (defconst sep \,) still compares with a u8 (decision 127). Filled by the declaration pass of the program being checked. *) let char_consts : (string, int) Hashtbl.t = Hashtbl.create 8 (* A [+] or [-] pair found to be char arithmetic after the ordinary join refused it, with both operands checked on their own terms. *) exception Char_pair of Tast.expr * Tast.expr (* Untyped literals: their machine type comes from context, so when one is an operand of a binary operator we look at the *other* operand first. *) let is_literal (e : Ast.expr) = match e.Ast.e with | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true | _ -> false (* [addr] takes the address of a place, but the parser only builds places for [set]. Recover one from the expression it parsed instead. *) let place_of_expr (e : Ast.expr) : Ast.place option = match e.Ast.e with | Ast.Var s -> Some (Ast.Pvar s) | Ast.Field (t, f) -> Some (Ast.Pfield (t, f)) | Ast.Call ({ Ast.e = Ast.Var "at"; _ }, t :: idx) when idx <> [] -> Some (Ast.Pindex (t, idx)) | Ast.Call ({ Ast.e = Ast.Var "deref"; _ }, [ p ]) -> Some (Ast.Pderef p) | _ -> None let mk loc ty e : Tast.expr = { Tast.e; ty; loc } (* A local narrowed by [if x?]: the same slot, read as its payload. *) let narrowed_tag = "~narrowed" (* The locals of the function being checked that [if x?] must not narrow: one whose address is taken, which a pointer could clear behind the block's back, and one a fn assigns (decision 133, Kotlin's rule). *) let unnarrowable : string list ref = ref [] let unnarrowable_in (body : Ast.expr list) = let out = ref [] in let rec walk ~in_fn (e : Ast.expr) = (match e.Ast.e with | Ast.Call ({ Ast.e = Ast.Var ("addr" | "addr-of"); _ }, [ { Ast.e = Ast.Var x; _ } ]) -> out := x :: !out | Ast.Set (Ast.Pvar x, _) when in_fn -> out := x :: !out | _ -> ()); let in_fn = in_fn || (match e.Ast.e with Ast.Fn _ -> true | _ -> false) in ignore (Ast.map_children (fun x -> walk ~in_fn x; x) e) in List.iter (walk ~in_fn:false) body; !out (* The [bwhat] of a name an [as] bound (decision 136), for the refusal to assign it. *) let as_tag = "~as" let local_of loc (b : binding) = if b.bwhat = Some narrowed_tag then mk loc b.bty (Tast.Field (mk loc (Types.Option b.bty) (Tast.Local b.slot), 1)) else mk loc b.bty (Tast.Local b.slot) let unit_at loc = mk loc Types.Unit Tast.Unit (* The compiler temp an [and] leaves in its else arm; see [check_if]. *) let and_sentinel (x : Ast.expr) = match x.Ast.e with | Ast.Var n -> String.length n > 4 && String.sub n 0 4 = "and~" | _ -> false (* Integer arithmetic over literals alone, folded. Unlike [const_int] no name is read: a defconst has a type of its own, and only an untyped constant may stand at a type variable. *) let rec literal_arith (e : Ast.expr) : int64 option = match e.Ast.e with | Ast.Int n -> Some n | Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ x ]) -> Option.map Int64.neg (literal_arith x) | Ast.Call ({ Ast.e = Ast.Var op; _ }, x :: y :: rest) -> let step a b = match op with | "+" -> Some (Int64.add a b) | "-" -> Some (Int64.sub a b) | "*" -> Some (Int64.mul a b) | "/" when b <> 0L -> Some (Int64.div a b) | "%" when b <> 0L && rest = [] -> Some (Int64.rem a b) | _ -> None in List.fold_left (fun acc e -> match acc, literal_arith e with | Some a, Some b -> step a b | _ -> None) (literal_arith x) (y :: rest) | _ -> None (* A value with no type until one is asked of it: a literal, or arithmetic over literals alone. *) let lone_literal (e : Ast.expr) = is_literal e || literal_arith e <> None (* Set for one [check_value] entry: the literal is checked at the Option itself, not wrapped, so a refusal names the Option (decision 138). *) let skip_wrap = ref false (* [None] as written, which has no type until an Option is asked of it. *) let is_none_lit (e : Ast.expr) = match e.Ast.e with Ast.Var "None" -> true | _ -> false (* A value whose type comes only from defaults — a literal, [nil], [(Some 3)], arithmetic over literals, a [do] ending in one — so it takes the type of whatever meets it. An arm of this kind is checked after the others, at their type, and never decides a join. *) let rec adapts (e : Ast.expr) = lone_literal e || (match e.Ast.e with | Ast.Var "nil" -> true | Ast.Call ({ Ast.e = Ast.Var "Some"; _ }, [ x ]) -> adapts x | Ast.Call ({ Ast.e = Ast.Var ("+" | "-" | "*" | "/" | "%"); _ }, (_ :: _ as xs)) -> List.for_all adapts xs | Ast.Do (_ :: _ as xs) | Ast.Let (_, (_ :: _ as xs)) -> adapts (List.hd (List.rev xs)) | Ast.If (_, a, Some b) -> adapts a && adapts b | _ -> false) (* The environment for a lifted body, built once its own body has been checked and [caught] is therefore final. spec-memory.md's case 2, and the whole of its machinery. It is a struct the checker synthesises — one field per captured name, in first-reference order — and it is registered in the same table a [defstruct] goes in, so both backends lay it out with the calculator they already have and neither learns a new shape. Its name is the lifted function's, which is unique and stable for the reason that name is: a redefinition module emits the lifted functions belonging to the bodies it replaces, and it emits their environments with them. Two ends, and the copy is at the near one: - in the *enclosing* frame, a slot holding the struct, filled with a [Make] of the outer locals. That store is the copy, and it happens where the value is made. A literal written inside a loop stores into the same slot each time round, so each value is made from the locals as they were on its own iteration. - in the *lifted* frame, a slot holding the pointer, and a [Let] around the whole body reading each field back into the named slot the body has been checked against. Once, at entry, for the same reason a handler clause binds its condition once: what the body names is the copy and not an address, so nothing downstream has to know an environment exists. Both new slots are nameless, which is how the break loop is told to hide them: a reader wants the captured copies, and those are the named slots the body reads them into. Answers the prefixed body, the slot the pointer arrives in, the enclosing frame's binding, and the address to put in the value. *) let close_over ~fname (octx : ctx) (fctx : ctx) loc = match fctx.caught with | [] -> (fun body -> body), None, None, None | caught -> let ename = "env/" ^ fname in let fields = List.map (fun (n, ((b : binding), _)) -> { Tast.fname = n; fty = b.bty }) caught in jreplace fctx.env.structs ename { Tast.sname = ename; fields }; let ety = Types.Named ename in let eslot = fresh_slot fctx (Types.Ptr (Types.Mut, ety)) in let binds = List.mapi (fun i (_, ((b : binding), slot)) -> let p = mk loc (Types.Ptr (Types.Mut, ety)) (Tast.Local eslot) in (slot, mk loc b.bty (Tast.Field (mk loc ety (Tast.Deref p), i)))) caught in let prefix body = [ mk loc fctx.ret (Tast.Let (binds, body)) ] in let make = mk loc ety (Tast.Make (ename, List.map (fun (_, ((b : binding), _)) -> local_of loc b) caught)) in let mslot = fresh_slot octx ety in prefix, Some eslot, Some (mslot, make), Some (mk loc (Types.Ptr (Types.Mut, ety)) (Tast.Addr (Tast.Plocal mslot))) (* A source location as a value, for a runtime trap that has to name the site rather than the runtime. The bounds and slice traps get theirs from [Emit], which renders the [Loc.t] it is already carrying; a trap reached through a plain runtime call has no such carrier, so the string is built here and crosses as ptr+len like any other. *) let here loc = mk loc Types.String (Tast.Str (Loc.to_string loc)) (* Names for the value an [if let] over a plain name holds; [~] keeps them out of any reader's reach. *) let held_n = ref 0 (* The read-only slice a value's storage is reached through, if there is one: an element of a [[const T]], a field of such an element, or an element of an array that is. The last slice stepped through decides, because the const is shallow — an element of a [[const [u8]]] is itself a writable [[u8]], and what it views is not the outer slice's to protect. *) let rec const_reached (e : Tast.expr) = match e.Tast.e with | Tast.Prim (Tast.At, target :: idx) -> const_steps (const_reached target) target.Tast.ty (List.length idx) | Tast.Field (target, _) -> const_reached target | Tast.Deref p -> (match p.Tast.ty with Types.Ptr (Types.Const, _) -> Some p.Tast.ty | _ -> None) | _ -> None (* [ro] after stepping [n] dimensions into [ty], the way [indexed] steps. *) and const_steps ro (ty : Types.t) n = if n = 0 then ro else match ty with | Types.Slice (Types.Const, t) -> const_steps (Some ty) t (n - 1) | Types.Slice (Types.Mut, t) -> const_steps None t (n - 1) | Types.Array (_, t) -> const_steps ro t (n - 1) | _ -> ro (* A copy of a read-only slice's elements that can be written, spelled so it compiles: [clone], for exactly the element types clone copies. It refuses elements that own storage — a copy would share their blocks — and elements that hold a dyn, which its allocator storage cannot root. *) let const_copy env (e : Types.t) = if owning env e || holds_dyn env e then None else Some "(clone v)" (* Whether (clone x) accepts a value of this type — the same arms the clone builtin takes: a Vec or a Map whose elements own nothing, or a slice whose elements neither own storage nor hold a dyn. *) let clone_accepts env (t : Types.t) = match t with | Types.Vec _ | Types.Map _ -> not (region_only env t) | Types.Slice (_, e) -> not (owning env e || holds_dyn env e) | _ -> false (* The end of clone's refusal for a container of owning elements. Pushing the elements themselves into a second container would copy their headers and share their blocks, so the advice is a copy of each element where clone takes one, and otherwise that there is no copy to make. *) let insert_copies ?(loc = Loc.unknown) env (t : Types.t) = let elem = match t with | Types.Vec e | Types.Slice (_, e) | Types.Map (_, e) -> Some e | _ -> None in match elem with | Some e when clone_accepts env e -> "Build a second container and push a (clone x) of each element into it" | Some e -> Printf.sprintf "Nothing copies what a %s owns either, so read the elements where they \ are" (tyname loc e) | None -> "Build a second container and insert into it" (* A call written back out as source, for a fix that has to repeat what the reader wrote: names, integers and calls of those. Anything else is [None] and the caller says the fix in words. *) let rec spell_form (a : Ast.expr) = match a.Ast.e with | Ast.Var v -> Some v | Ast.Int n -> Some (Int64.to_string n) | Ast.UInt (_, s) -> Some s | Ast.Call (f, args) -> let parts = List.map spell_form (f :: args) in if List.mem None parts then None else Some ("(" ^ String.concat " " (List.filter_map Fun.id parts) ^ ")") | _ -> None (* A store through a read-only view: a [[const T]] or a (Ptr const T). *) let refuse_const_place env loc (view : Types.t) = match view with | Types.Ptr (_, ((Types.Vec _ | Types.Map _) as t)) -> Loc.failk "check/store-through-const" loc "this changes the %s behind a %s, which can only be read through. A \ container that has to change is handed over as a (Ptr %s)" (tyname loc t) (tyname loc view) (tyname loc t) | Types.Ptr (_, t) -> Loc.failk "check/store-through-const" loc "this writes through a %s, which can only be read, so what it points at \ is a value and not a place. (deref p) copies the %s out, and the copy \ can be written" (tyname loc view) (tyname loc t) | _ -> let elem = match view with Types.Slice (_, t) -> t | t -> t in Loc.failk "check/store-through-const" loc "this writes through a %s, which can only be read, so the element is a \ value and not a place. %s" (tyname loc view) (match const_copy env elem with | Some c -> Printf.sprintf "Write into a slice that can be written: %s copies v's elements \ into one" c | None -> Printf.sprintf "Where it has to be written, take it as a [%s] instead" (tyname loc elem)) (* A runtime call, with the result type spelled at the site. *) let rt loc ty sym args = mk loc ty (Tast.Prim (Tast.Rt sym, args)) (* ── The allocation registry's note ────────────────────────────────── TODO.org, "The allocation registry". One after every operation that may have allocated — which is *here*, and nowhere else, because here is the only place the concrete type is known. A Flan struct is exactly its C layout with no header and no tag word, so nothing at run time can say what is at an address; the allocator's caller knew, and this is the caller writing it down. The type is spelled with [Types.to_string], the same spelling a slot fingerprint and a DWARF node already key on, so a name that appears in a registry answer is a name the programmer wrote. It is built unconditionally and dropped by the backend in a release build (see [Emit]'s [Rt] arm). The checker does not know which kind of build this is and must not learn: a note that existed only in a dev build would make the two builds different *trees*, and every pass between here and the backend would have to agree about which one it was looking at. [target] is the container, passed by address like every other container operation; the extent comes off its header in the runtime, because the header is the only thing that knows where the storage landed. *) let reg_note loc sym (target : Tast.expr) sizes ty = rt loc Types.Unit sym ((target :: sizes) @ [ mk loc Types.String (Tast.Str (Types.to_string ty)) ]) (* [(do attempt note)] — the note runs only once the guard's retry loop has stopped, so it describes the storage the program ended up with rather than one of the attempts that failed. *) let with_note loc (guarded : Tast.expr) (note : Tast.expr) = mk loc Types.Unit (Tast.Do [ guarded; note ]) (* ── Reading a file at compile time, decision 1 ──────────────────────── The path is a *literal*, because the bytes have to be in hand before any value exists — this is Odin's rule too (check_load_directive rejects anything that is not Addressing_Constant) and it is what makes the result cost nothing at run time. It resolves relative to the directory of the file the form is written in, which is again Odin's rule (dir_from_path of the call's file). Relative to the compiler's working directory would make a package's assets depend on where flan was invoked from, which is the thing that cannot be right. An absolute path is taken as written. *) let embed_path loc (p : Ast.expr) = match p.Ast.e with | Ast.Str "" -> Loc.fail p.Ast.loc "an embedded path cannot be empty" | Ast.Str s when Filename.is_relative s -> let base = Filename.dirname loc.Loc.file in if String.equal base "" then s else Filename.concat base s | Ast.Str s -> s | _ -> Loc.fail p.Ast.loc "an embedded path must be a literal string" (* The whole read is guarded, not only the open. On Linux [open_in_bin] on a *directory* succeeds and [in_channel_length] answers a number; the read is where EISDIR arrives. Guarding only the open therefore turned (embed "dir") — someone who meant embed-dir — into an uncaught OCaml exception out of the checker, which is the one way a user can make the compiler crash rather than refuse. *) let read_embed_file path loc = match let ch = open_in_bin path in Fun.protect ~finally:(fun () -> close_in_noerr ch) (fun () -> really_input_string ch (in_channel_length ch)) with | s -> s | exception Sys_error msg -> if Sys.file_exists path && (try Sys.is_directory path with Sys_error _ -> false) then Loc.fail loc "cannot embed %s: it is a directory — use embed-dir for one of those" path else Loc.fail loc "cannot embed %s: %s" path msg | exception End_of_file -> Loc.fail loc "cannot embed %s: it changed size while being read" path (* Non-recursive, files only, sorted by name — the three things Odin's #load_directory settles, and the sort is the one that matters most here: readdir order is filesystem-dependent, so an unsorted embed would make the emitted .ll differ between two builds of identical sources. *) let read_embed_dir path loc = let names = match Sys.readdir path with | exception Sys_error msg -> Loc.fail loc "cannot embed %s: %s" path msg | a -> Array.to_list a in (* [Sys.is_directory] *raises* on a path that does not resolve, so the existence test has to come first: a dangling symlink in an embedded directory would otherwise crash the compiler before it was ever asked about. Non-recursive and files only, which is Odin's rule too. *) let files = List.filter (fun n -> let full = Filename.concat path n in Sys.file_exists full && not (try Sys.is_directory full with Sys_error _ -> true)) names in List.map (fun n -> (n, read_embed_file (Filename.concat path n) loc)) (List.sort String.compare files) let i64_at loc n = mk loc (Types.Int Types.I64) (Tast.Int (n, Types.I64)) (* spec-memory.md, "Alignment": the number is produced where the concrete element type is known, which without generics is simply the call site. *) let size_of loc t = mk loc (Types.Int Types.I64) (Tast.Prim (Tast.SizeOf t, [])) let align_of loc t = mk loc (Types.Int Types.I64) (Tast.Prim (Tast.AlignOf t, [])) (* The address of an expression, place or not: the type-erased runtime takes the element [push] copies by pointer. *) let addr_of loc (e : Tast.expr) = mk loc (Types.Ptr (Types.Mut, e.Tast.ty)) (Tast.Prim (Tast.AddrOf, [ e ])) (* ── A frame slot for a rendered number ──────────────────────────────── The printer and the prelude's number appends render a number into a buffer that is the caller's, one frame slot per call site, and write or copy it out before the next; i64->bytes and f64->bytes elsewhere answer text in the temp allocator instead. The slot is allocated here rather than in either backend on purpose: a slot is a function-lifetime frame location in both of them — an entry-block alloca in [Emit], a prologue-allocated offset in [X86] — where a backend temporary in [X86] is bump-allocated and reclaimed at the end of the expression that made it, which is exactly the lifetime a returned slice must outlive. Doing it once here also keeps the two backends symmetric by construction: each gains one pointer argument and no lifetime reasoning of its own. 64 bytes is agreed with flan_rt.c's FLAN_NUM_BYTES, which clamps the length it publishes to it. The zeroing the [Let] does is one 64-byte clear beside an snprintf. *) let num_bytes = 64L let to_bytes ctx loc pr (x : Tast.expr) = let bty = Types.Array (num_bytes, Types.Int Types.U8) in let bslice = Types.Slice (Types.Mut, (Types.Int Types.U8)) in let s = fresh_slot ctx bty in mk loc bslice (Tast.Let ([ (s, mk loc bty (Tast.Zero bty)) ], [ mk loc bslice (Tast.Prim (pr, [ x; addr_of loc (mk loc bty (Tast.Local s)) ])) ])) (* ── An Allocator value, made and used ───────────────────────────────── A value is two words, flan_rt.c's [flan_alloc_value]: the runtime's allocator record and the incarnation of it the value was made for, which arena-destroy bumps. Every runtime operation takes the bare record, typed [raw_alloc] here; [seal_alloc] makes a value from one and [use_alloc] opens one, trapping if the incarnation has moved. So a value kept past its arena's destroy traps at its next use, including after arena-new has taken the record back for another arena — which a one-word value could not tell from the new arena's own. Both cross through the value's address, since nothing the runtime answers or takes is a struct by value. *) let raw_alloc = Types.Ptr (Types.Mut, Types.Unit) let seal_alloc ctx loc (record : Tast.expr) = let s = fresh_slot ctx Types.Alloc in mk loc Types.Alloc (Tast.Let ([ (s, mk loc Types.Alloc (Tast.Zero Types.Alloc)) ], [ rt loc Types.Unit "flan_alloc_seal" [ record; addr_of loc (mk loc Types.Alloc (Tast.Local s)) ]; mk loc Types.Alloc (Tast.Local s) ])) let use_alloc ctx loc (v : Tast.expr) = let s = fresh_slot ctx Types.Alloc in mk loc raw_alloc (Tast.Let ([ (s, v) ], [ rt loc raw_alloc "flan_alloc_use" [ addr_of loc (mk loc Types.Alloc (Tast.Local s)); here loc ] ])) (* A string literal handed to a [declare-c] function goes to C without the copy the wrapper makes of any other string. Both backends write a NUL after a literal's bytes, and here — the one place that knows the argument is a literal — it is passed with its length encoded as -(n+1) by [flan_c_literal]. No other Flan string has a negative length, so the wrapper can tell ([Shim.cstr_helpers]); a string that merely ends in a NUL is still copied and refused. The callee is a declare-c when it binds the shim's symbol for its own name — directly, or through the flattened [-c] declaration the shim puts under a Flan wrapper. The encoded value passes through that wrapper untouched, because its body only forwards it. *) let c_literals ctx name (params : Types.t list) (args : Tast.expr list) = let sym = Shim.shim_symbol name in let bound n = Hashtbl.find_opt ctx.env.externs n = Some sym in if not (bound name || bound (Shim.raw_name name)) then args else List.map2 (fun (p : Types.t) (a : Tast.expr) -> match p, a.Tast.e with | Types.String, Tast.Str _ -> let loc = a.Tast.loc in let s = fresh_slot ctx Types.String in mk loc Types.String (Tast.Let ([ (s, mk loc Types.String (Tast.Zero Types.String)) ], [ rt loc Types.Unit "flan_c_literal" [ a; addr_of loc (mk loc Types.String (Tast.Local s)) ]; mk loc Types.String (Tast.Local s) ])) | _ -> a) params args (* ── The region requirement, emitted ─────────────────────────────────── spec-memory.md's arena rule, and the whole of what replaced the three refusals a container of owning elements used to meet at its *type*. The question those refusals asked was about teardown: the type-erased runtime copies and releases slots bytewise, so a [free] would release the slots and leave everything inside them stranded. A region never releases a slot — [free-all] takes the whole thing, inner blocks included, because they came out of the same region — so the premise does not hold there and the refusal was over-broad. What could not move with it is *where* the question is asked. [can-free] is a capability on an allocator value, read at run time, and [with-allocator] rebinds a dynamic variable, so the tier a [(vec-new)] will meet is not a property of the place its type is written. The compile-time half is therefore only the decision to ask — [region_only], a property of the element type and settled here — and the run-time half is the answer. One branch per container and never per element, which spec-memory.md fixes and which is a performance decision before it is a safety one: the alternative is a walk at release, and a walk at release is the registry of destructors the frame tier's reset exists to not have. Emitted at every site that can *allocate* for such a container, not only at its construction, and the extra sites are not belt and braces. ZII means a container can exist without ever passing through [vec-new]: a data type case's field left out of a literal, a [(defonce xs (Vec Value))] a global starts as. Those are zeroed, they have no allocator at all, and the first [push] is what adopts the context — so a guard only at the construction would have a hole exactly the width of ZII. The *container* is what is asked in both places, and at a construction that means the guard runs immediately after the init rather than before it. The allocator is right there as an argument of the site, but naming it twice in the emitted tree is not free: it is an arbitrary expression, and [(vec-new Value (arena-new 4096))] would build two arenas and guard the one it threw away. The container has recorded it by the time the init returns, so asking the container asks that one expression exactly once. It is still the point of construction and still before anything is put in; what a trap there costs is the empty block just taken, on a process that is about to die. At a growth the guard runs first, because there the container already exists and the allocation is what has to be stopped. A zeroed one answers from the context it is about to adopt, which is not a guess — [flan_vec_adopt] is the code that will take it, on this same call. *) let region_sym (t : Types.t) = match t with | Types.Vec _ -> "flan_vec_region_only" | Types.Map _ -> "flan_map_region_only" | _ -> assert false let region_check env loc (target : Tast.expr) (after : Tast.expr) = if not (region_only env target.Tast.ty) then after else mk loc after.Tast.ty (Tast.Do [ rt loc Types.Unit (region_sym target.Tast.ty) [ target; here loc ]; after ]) (* Every integer index into an array or slice is i32 at milestone 2. *) let index_ty = Types.Int Types.I32 (* A condition's type at run time is a number, and it has to be the *same* number in a module compiled later against a program already running. So it is a hash of the name and not an index into anything: an index would shift the moment a struct were added, and every handler pushed by the old code would then match the wrong type. FNV-1a over the name, 32 bits. *) let type_id name = let h = ref 0x811c9dc5 in String.iter (fun c -> h := (!h lxor Char.code c) land 0xffffffff; h := (!h * 0x01000193) land 0xffffffff) name; !h (* A condition type and every type it names as a parent, own first. The chain is static: a signal site knows its condition's type, so the whole walk a handler match makes is written into the site's descriptor, and the runtime only compares numbers. [collect] has refused a cycle, but the walk stops at one anyway rather than trusting that it ran. *) let condition_chain env name = let rec go seen n = if List.mem n seen then List.rev seen else match Hashtbl.find_opt env.parents n with | Some p -> go (n :: seen) p | None -> List.rev (n :: seen) in go [] name (* How a restart's parameter list is spelled, and with it what the two ends of an [invoke-restart] compare — spec-conditions.md §3's run-time check. A restart is found by name on a dynamic stack, so neither end can see the other and nothing static can be checked: what is compared at run time is this string's hash, alongside the count, and the string itself is carried so that a mismatch can say what was wanted and what was given. Comparing a 32-bit hash means two different parameter lists could in principle collide. The count is checked separately, which rules out every practical case (a collision would have to be between two lists of the same length), and the types are parenthesised so that [(Option i32)] cannot read as two parameters. *) let restart_sig tys = "(" ^ String.concat " " (List.map Types.to_string tys) ^ ")" (* ── The dyn boundary ─────────────────────────────────────────────────── Typed to dyn is implicit and dyn to typed is not. That asymmetry is the whole of the design and it is worth saying why it is not arbitrary. Boxing loses nothing: the value goes in and the runtime records what it was. It can happen anywhere a dyn is wanted without a reader being surprised, because nothing about the program's meaning turns on it. Unboxing can fail, at run time, on a value the compiler cannot inspect -- so it happens only where somebody *wrote a type*: a typed parameter, a typed binding, a typed field. Those are the places a reader already understands as a claim about what a value is, and a claim that can be wrong is exactly what a trap is for. Nowhere else does the compiler decide a dyn is an i64 on its own. Both directions go through [expect], because [expect] is already the one place a wanted type meets a produced one. Every site that annotates -- and only those sites -- calls it with [~want]. Milestone 1 boxes the scalars and refuses everything else by name. A typed container crossing into dyn is the interesting refusal: [(Vec i64)] has a representation the dyn runtime does not know how to walk, and heterogeneity at milestone 1 is served by the runtime's own vector behind [flan_dyn_vec_new] instead. That is a "not yet" and says so. *) let dyn_i64 = Types.Int Types.I64 let dyn_f64 = Types.Float Types.F64 (* The switch the unfinished half of TODO.org's "Dyn unless annotated" is measured with: [dyn] makes an unwanted text or bracket literal dyn (a let-bound one stays typed when a use wants it, [lit_session]), and [log] prints each literal local inference moved off its default. Deleted when that half lands. *) let lit_mode = try Sys.getenv "FLAN_LIT" with Not_found -> "" let lit_has m = List.mem m (String.split_on_char ',' lit_mode) (* An unconstrained float literal is an f64 (decision 121); it is an f32 only where typed code wants one. *) let float_default () = Types.F64 (* ── Literal locals ([lit_session]) ────────────────────────────────── *) (* The literal a [let] or [loop] initialiser is, when its type is to be read off the uses: a number or a character, negated or not. A bool has one type and a wide literal one (u64), so neither has anything to infer. *) let lit_kind (e : Ast.expr) = match e.Ast.e with | Ast.Int _ -> Some `Int | Ast.Byte _ -> Some `Char | Ast.Float _ -> Some `Float | Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ { Ast.e = Ast.Int _; _ } ]) -> Some `Int | Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ { Ast.e = Ast.Float _; _ } ]) -> Some `Float | Ast.Str _ | Ast.Arr (_ :: _) when lit_has "dyn" -> Some `Box | _ -> None (* What the literal is with no use to say otherwise. *) (* A text or bracket literal ([`Box]) is dyn, or with a typed use its typed reading; [Types.Unit] stands for "typed" in [decided], since the typed reading is the literal's own and not one a use names. *) let lit_default (_ : Ast.expr) = function | `Int -> Types.Int Types.I32 | `Char -> Types.Char | `Float -> Types.Float (float_default ()) | `Box -> Types.Dyn (* The types a use can give it: any number for an integer or a character, since an untyped integer constant is usable where a float is wanted, and only a float for a float. A character may also be a char, its own type. A type variable is admitted and left to [int_literal] to judge against its bound. Anything else — dyn, a struct — says nothing about the literal's type; the local keeps its guess and the use is checked as it always was. *) let lit_admits kind (t : Types.t) = match kind, t with | (`Int | `Char), (Types.Int _ | Types.Float _ | Types.Var _) -> true | `Char, Types.Char -> true | `Float, (Types.Float _ | Types.Var _) -> true | `Box, t -> not (Types.equal t Types.Dyn) | _ -> false (* What a use at [t] says about a literal local: an (Option T) wanted of it says T, since the local is built at T and then wrapped (decision 138), so [let w: i64? = x] makes [x] the i64 [let w: i64 = x] does. *) let rec lit_payload (t : Types.t) = match t with Types.Option p -> lit_payload p | t -> t (* The rounds a session may take before its last guesses are checked as they stand. Merging makes two the usual count; the bound only stops a pathological program from looping. *) let lit_rounds = 8 let lit_id (s : lit_session) (key : Ast.expr) = Phys.find_opt s.ids key let rec lit_root (s : lit_session) i = match Hashtbl.find_opt s.parent i with | Some p when p <> i -> let r = lit_root s p in Hashtbl.replace s.parent i r; r | _ -> i let lit_add (s : lit_session) key c = match lit_id s key with Some i -> Hashtbl.add s.cons i c | None -> () let lit_union (s : lit_session) a b = match lit_id s a, lit_id s b with | Some i, Some j -> let ri = lit_root s i and rj = lit_root s j in if ri <> rj then Hashtbl.replace s.parent (max ri rj) (min ri rj) | _ -> () (* What earlier sessions decided, while an outermost one is open. An outer session that checks its form again checks every lambda inside it again, and each of those opens a session of its own; starting that one from its last answer makes it settle in one round, where starting from the default made nested lambdas cost a factor per level. Keyed by the node and the type variables' bindings, since a generic's body is one node checked at several types. Only ever a first guess: a wrong one costs a round. *) let lit_depth = ref 0 let lit_memo : ((string * Types.t) list * Types.t) list Phys.t = Phys.create 64 let lit_guess ~subst (s : lit_session) key kind = match Phys.find_opt s.decided key with | Some t -> t | None -> let same (sb, _) = List.equal (fun (a, t) (b, u) -> String.equal a b && Types.equal t u) sb subst in match Option.bind (Phys.find_opt lit_memo key) (List.find_opt same) with | Some (_, t) -> t | None -> lit_default key kind (* Each literal local this round bound, with the type its group's uses decide or the first pair of uses no one type satisfies. Linear in locals and uses. *) let lit_solve (s : lit_session) = let keys = Array.of_list (List.rev s.keys) in let n = Array.length keys in let root = Array.init n (lit_root s) in let members = Array.make n [] in for i = n - 1 downto 0 do members.(root.(i)) <- i :: members.(root.(i)) done; let widens a b = Types.equal a b || Types.widens_to ~from:a ~into:b in let result = Array.make n (Ok Types.Unit) in Array.iteri (fun r ms -> if ms <> [] then begin let kinds = List.map (fun m -> Option.value (lit_kind (fst keys.(m))) ~default:`Int) ms in let kind = if List.mem `Box kinds then `Box else if List.mem `Float kinds then `Float else if List.mem `Int kinds then `Int else `Char in let dyn_width = match kind with `Float -> Types.Float Types.F64 | _ -> Types.Int Types.I64 in let cons = List.concat_map (fun m -> List.rev (Hashtbl.find_all s.cons m)) ms |> List.filter_map (fun (c, t, l) -> (* A character meeting dyn stays a char, which crosses as a dyn char; a number takes the dyn width. *) if kind = `Char && Types.equal t Types.Dyn then None else if kind <> `Box && Types.equal t Types.Dyn then Some (Hint, dyn_width, l) else if lit_admits kind t then Some (c, t, l) else None) in let pick c = List.filter_map (fun (c', t, l) -> if c' = c then Some (t, l) else None) cons in let res = if kind = `Box then Ok (if cons = [] then Types.Dyn else Types.Unit) else let ups = pick Up and downs = pick Down and hints = pick Hint in match ups with | (u0, l0) :: _ -> (match List.find_opt (fun (u, _) -> List.for_all (fun (u', _) -> widens u u') ups) ups with | None -> let (u1, l1) = List.find (fun (u, _) -> not (widens u u0 || widens u0 u)) ups in Error ((u0, l0), (u1, l1)) | Some (c, lc) -> (match List.find_opt (fun (d, _) -> not (widens d c)) downs with | None -> Ok c | Some (d, ld) -> Error ((c, lc), (d, ld)))) | [] -> (match downs @ hints with | [] -> (* No use names a type: the widest of the members' own. *) Ok (List.fold_left (fun acc m -> let t = lit_default (fst keys.(m)) kind in match Types.join acc t with Some j -> j | None -> acc) (lit_default (fst keys.(r)) kind) ms) | (t0, l0) :: rest -> let rec fold (t, l) = function | [] -> Ok t | (t', l') :: rest -> (match Types.join t t' with | Some j -> fold ((j, if Types.equal j t then l else l')) rest | None -> Error ((t, l), (t', l'))) in fold (t0, l0) rest) in List.iter (fun m -> result.(m) <- res) ms end) members; Array.to_list (Array.mapi (fun i (k, name) -> (k, name, result.(i))) keys) (* Converting to whatever width the other side of the boundary wants, with a [Cast] and not a silent reinterpretation. The name is for the direction it was written for: runtime/flan_dyn.h boxes integers as [i64] and floats as [f64] and offers no other width, so *into* a box this only ever widens, and a widening cast loses nothing. Coming back *out* it is used in both directions, and that is deliberate: [cast_dyn] below unboxes to [i64]/[f64] and then hands the value to this to reach the cast's target, which may be narrower ([(i32 d)]) or a different kind ([(f32 d)]). Nothing is lost quietly there either — the [Cast] emitted is the same node [(i32 x)] on a typed value emits, so the narrowing rule, the fptosi range check and NaN are the emitter's, identical to the typed spelling. This helper picks the node; it does not promise the conversion is free. *) let widen loc (want : Types.t) (e : Tast.expr) = if Types.equal want e.Tast.ty then e else mk loc want (Tast.Prim (Tast.Cast want, [ e ])) (* The sentence a refusal at this boundary gives. It names the type and says which direction failed, because "expected dyn, found (Vec i64)" would read as a type error the programmer could fix by writing something else, and there is nothing else to write -- the feature is not there yet. *) let no_dyn_yet loc ~into t extra = Loc.failk "check/dyn-not-yet" loc "%s does not cross into %s yet%s" (tyname loc t) (if into then "dyn" else "a written type") extra (* A typed container crossing into dyn is a view, and the runtime needs to know what one element is: its descriptor, a prefix code runtime/flan_dyn.c documents beside [desc_lay] and reads offsets out of by C's layout rule. Every number, bool, char, str, struct of those, and fixed array, slice or Vec of those can be described. [Error t] names the first type inside that cannot: a dyn, a pointer, a function, an Option, a map, an enum or a data type. None of those is refused for want of a descriptor letter — each is one a dyn value cannot be read out of or written into without a meaning nobody has decided. A str is read as a copy and never written, since a dyn text is a collector pointer and typed storage is never scanned; a [const] slice is refused because a dyn view can be written through. One is described only [~into] a written type ([into_typed]), as [c]. *) let rec view_desc ?(into = false) structs (t : Types.t) : (string, Types.t) result = let view_desc = view_desc ~into in let ( let* ) = Result.bind in match t with | Types.Int k -> Ok (match k with | Types.I8 -> "b" | Types.U8 -> "B" | Types.I16 -> "h" | Types.U16 -> "H" | Types.I32 -> "i" | Types.U32 -> "I" | Types.I64 -> "l" | Types.U64 -> "L") | Types.Float Types.F32 -> Ok "f" | Types.Float Types.F64 -> Ok "d" | Types.Bool -> Ok "?" | Types.Char -> Ok "C" | Types.String -> Ok "t" | Types.Array (n, e) -> let* d = view_desc structs e in Ok (Printf.sprintf "a%Ld;%s" n d) | Types.Slice (Types.Mut, e) -> let* d = view_desc structs e in Ok ("s" ^ d) | Types.Slice (Types.Const, e) when into -> let* d = view_desc structs e in Ok ("c" ^ d) | Types.Vec e -> let* d = view_desc structs e in Ok ("v" ^ d) | Types.Named n -> (match Hashtbl.find_opt structs n with | None -> Error t | Some st -> let* fs = List.fold_left (fun acc (fl : Tast.field) -> let* acc = acc in let* d = view_desc structs fl.Tast.fty in Ok ((fl.Tast.fname ^ ";" ^ d) :: acc)) (Ok []) st.Tast.fields in Ok ("{" ^ n ^ ";" ^ String.concat "" (List.rev fs) ^ "}")) | _ -> Error t (* A fix is spelled in the syntax of the file the mistake is in: the checker sees one AST for both, so the location's file is the only thing left that says which one the reader is looking at. *) let fln_source (loc : Loc.t) = Source.indented_at loc (* A version's own name: see [split_versions]. *) let version_name base arity = base ^ "~" ^ string_of_int arity (* The name as written and the arity, for a name [version_name] made. *) let version_of n = match String.rindex_opt n '~' with | Some i when i > 0 && i < String.length n - 1 -> let tail = String.sub n (i + 1) (String.length n - i - 1) in if String.for_all (fun c -> c >= '0' && c <= '9') tail then Some (String.sub n 0 i, int_of_string tail) else None | _ -> None (* A name as its reader wrote it: a version's is the name it is a version of, which is what every message about it says. *) let written_name n = match version_of n with | Some (b, _) -> b | None -> (* A generic version's copy, [pick~3-f64], is the copy [pick-f64]. *) match String.rindex_opt n '~' with | Some i when i > 0 -> let j = ref (i + 1) in while !j < String.length n && n.[!j] >= '0' && n.[!j] <= '9' do incr j done; if !j > i + 1 && !j < String.length n && n.[!j] = '-' then String.sub n 0 i ^ String.sub n !j (String.length n - !j) else n | _ -> n (* Which form defined each mutable global, [defonce] or [def], so a fix that rewrites the definition keeps the form the programmer chose. Filled where globals are collected; a name missing from it (a defconst) is given [defonce]. *) let global_forms : (string, Ast.reinit) Hashtbl.t = Hashtbl.create 16 (* The function being checked and its parameters, by slot. A stack because a generic's copy is checked from inside the body that called it. *) let grow_params : (ctx * (int * Ast.field) list) list ref = ref [] (* The two refusals below share their subject and their fix. The subject is the name as written when the refused value is a bare name, so the message can say [a is a [4 i64]]; anything longer is "this". The fix is the one spelling that works for every container either refusal reaches, whatever its element type or wherever it lives: make it a dyn value where it is built, and there is no view to refuse. *) let view_subject (e : Tast.expr) = match Loc.snippet e.Tast.loc with | Some s when s <> "" && String.for_all (fun c -> not (List.mem c [ ' '; '('; ')'; '['; ']'; '{'; '}'; '"'; '.'; ',' ])) s -> Some s | _ -> None let view_refusal kind loc (e : Tast.expr) reason = let ty = tyname loc e.Tast.ty in let fln = fln_source loc in (* A parameter is made by the caller, so its fix is its declaration. The name is compared as well as the slot: a closure numbers its slots from zero too, and is checked while its enclosing function is on the stack. *) let param = match e.Tast.e, view_subject e, !grow_params with | Tast.Local s, Some n, (ctx, ps) :: _ -> (match List.assoc_opt s ps with | Some (p : Ast.field) when p.Ast.fname = n -> Some (ctx.owner, n) | _ -> None) | _ -> None in let subject, fix = match param, view_subject e with | Some (f, n), _ -> ( Printf.sprintf "%s is a %s parameter" n ty, Printf.sprintf "Declare %s as dyn in %s's parameters: %s%s" n f n (if fln then ": dyn" else " dyn") ) | None, Some n when (match e.Tast.e with Tast.Global _ -> true | _ -> false) -> let every = match e.Tast.e with | Tast.Global g -> Hashtbl.find_opt global_forms g = Some Ast.Every | _ -> false in ( Printf.sprintf "%s is a %s" n ty, Printf.sprintf "Define %s as a dyn value, as in %s" n (if fln then Printf.sprintf "%s %s: dyn = [...]" (if every then "def" else "once") n else Printf.sprintf "(%s %s dyn [...])" (if every then "def" else "defonce") n) ) | None, Some n -> ( Printf.sprintf "%s is a %s" n ty, Printf.sprintf "Build %s as a dyn value where it is made, as in %s" n (if fln then Printf.sprintf "let %s: dyn = [...]" n else Printf.sprintf "(let [%s (the dyn [...])] ...)" n) ) | None, None -> ( Printf.sprintf "This is a %s" ty, Printf.sprintf "Build it as a dyn value where it is made, as in %s" (if fln then "the(dyn, [...])" else "(the dyn [...])") ) in Loc.failk kind loc "%s, and a dyn value is wanted here. %s. %s" subject reason fix let view_not_yet loc (e : Tast.expr) (inner : Types.t) = view_refusal "check/dyn-not-yet" loc e (Printf.sprintf "A dyn value sees into numbers, bools, str and structs, and arrays, \ slices and Vecs of those; a %s is none of these" (tyname loc inner)) (* Whether a view's storage is the current function's own frame, which is what the runtime's dev check needs to be told: it then records this activation and traps if the view is used after the call returns. A local, a parameter (copied into the frame, an array parameter too), a field or an array element of one, a slice cut directly from a local array, and a temporary [box] has bound to a slot of its own are all the frame's. For anything else — a slice's data, a [Ptr]'s target, a global — the dev runtime finds the frame that owns a stack address by the address itself, or else the registry block that holds it. *) let rec frame_root (e : Tast.expr) : bool = let rec all_array ty = function | [] -> true | _ :: rest -> (match ty with Types.Array (_, elem) -> all_array elem rest | _ -> false) in match e.Tast.e with | Tast.Local _ -> (match e.Tast.ty with Types.Slice _ -> false | _ -> true) | Tast.Field (target, _) -> (match target.Tast.ty with Types.Named _ -> frame_root target | _ -> false) | Tast.Prim (Tast.At, target :: idx) -> all_array target.Tast.ty idx && frame_root target | Tast.Prim (Tast.Slice, [ target; _; _ ]) -> (match target.Tast.ty with Types.Array _ -> frame_root target | _ -> false) | _ -> false (* Whether [e] names storage that already has an address, so a view can point at it; anything else is a temporary [box] binds to a slot first. *) let rec view_place (e : Tast.expr) : bool = match e.Tast.e with | Tast.Local _ | Tast.Global _ | Tast.Deref _ -> true | Tast.Field (target, _) -> (match target.Tast.ty with Types.Named _ -> view_place target | _ -> true) | Tast.Prim (Tast.At, _ :: _ :: _) -> true | _ -> false (* A value handed out of [f] that points into [f]'s own frame: returned (the last form's tails, or a [return]), or stored into a global or a field or array element of one. Both read a dead frame the moment [f] returns, so both are refused. Deliberately narrow — the exact spellings that can only be wrong, so nothing that could be valid is ever refused: - [(addr p)] where [p] is a local, a field of one, or an element of a local *array* (an array's elements are the frame's bytes; a Vec's or a slice's are not); - [(slice a …)] where [a] is such a place of array type; - a local bound by [let] to one of those and never assigned or addressed afterwards, which is also how a [return] under a [defer] arrives here. A parameter is a local: its value is copied into the frame (an array parameter too), so its address dies with the frame as well. Anything reached through a [Ptr] is not the frame's, and a struct literal holding such an address is not looked into. The store is let through in [main], whose frame outlives everything the program runs. A lifted [fn] literal or handler clause is checked as a function of its own: its parameters, its locals and its copies of what it captured are its frame. What this does not see is the enclosing function's frame escaping *through* one — a closure over a pointer to a local, handed out — because that is a value holding an address, not one of the spellings above. *) let refuse_frame_escapes (f : Tast.fn) = (* Keyed by slot alone: [fresh_slot] never reuses one, so a slot has at most one binding [Let] in the function. *) let binds = Hashtbl.create 16 in let unstable = Hashtbl.create 16 in (* A place a global owns, and so one that outlives every frame: the global, a field or array element of it, or an element of a Vec it holds — the Vec's block is the global's for as long as the global keeps it. A slice is not stepped through: its storage may be anyone's. *) let rec place_global = function | Tast.Pglobal g -> Some g | Tast.Pfield (t, _) -> expr_global t | Tast.Pindex (t, idx) when owned_levels t.Tast.ty idx -> expr_global t (* [(set (at v i) x)] on a Vec is a store through the checked element address [vec_at] builds. Any other pointer's target is not known to be the global's. *) | Tast.Pderef { Tast.e = Tast.Prim (Tast.Rt "flan_vec_at", t :: _); _ } -> expr_global t | _ -> None and expr_global (e : Tast.expr) = match e.Tast.e with | Tast.Global g -> Some g | Tast.Field (t, _) -> expr_global t | Tast.Prim (Tast.At, t :: idx) when owned_levels t.Tast.ty idx -> expr_global t | _ -> None and owned_levels ty = function | [] -> true | _ :: rest -> (match ty with | Types.Array (_, el) | Types.Vec el -> owned_levels el rest | _ -> false) (* [(at a i j)] is one node carrying every index; each level stepped must be an array for the element to be inside [a]'s own bytes. *) and all_array ty = function | [] -> true | _ :: rest -> (match ty with Types.Array (_, el) -> all_array el rest | _ -> false) in List.iter (Tast.walk (fun (e : Tast.expr) -> match e.Tast.e with | Tast.Let (bs, _) -> List.iter (fun (s, v) -> Hashtbl.replace binds s v) bs | Tast.Set (Tast.Plocal s, _) | Tast.Addr (Tast.Plocal s) -> Hashtbl.replace unstable s () | _ -> ())) f.Tast.body; (* The local at the root of a place inside this frame, if it is one. *) let rec root_expr (e : Tast.expr) = match e.Tast.e with | Tast.Local s -> Some s | Tast.Field (t, _) -> root_expr t | Tast.Prim (Tast.At, t :: idx) when all_array t.Tast.ty idx -> root_expr t | _ -> None in let root_place = function | Tast.Plocal s -> Some s | Tast.Pfield (t, _) -> root_expr t | Tast.Pindex (t, idx) when all_array t.Tast.ty idx -> root_expr t | _ -> None in (* What escapes: the root local, whether it is a slice (else an address), and whether the place is the bare local rather than a path into it — only then can the fix be spelled with its name alone. *) let rec escapes depth (e : Tast.expr) = match e.Tast.e with | Tast.Addr p -> Option.map (fun s -> (e, (s, `Addr, (match p with Tast.Plocal _ -> true | _ -> false)))) (root_place p) | Tast.Prim (Tast.Slice, [ t; _; _ ]) -> (match t.Tast.ty with | Types.Array _ -> Option.map (fun s -> ( e, (s, `Slice, (match t.Tast.e with Tast.Local _ -> true | _ -> false)) )) (root_expr t) | _ -> None) | Tast.Local s when depth < 32 && not (Hashtbl.mem unstable s) -> Option.bind (Hashtbl.find_opt binds s) (escapes (depth + 1)) | _ -> None in (* A slot with no name is a value the function made for itself, such as the array a literal like [(slice [7 8 9])] is stored in. *) (* What a lifted body is called in a message: its symbol is the compiler's. *) let who = let starts p = String.length f.Tast.name >= String.length p && String.sub f.Tast.name 0 (String.length p) = p in if starts "fn/" then "this fn" else if starts "handler/" then "this handler" else f.Tast.name in let what (s, kind, exact) = match f.Tast.snames.(s), kind, exact with | Some n, `Slice, true -> "a slice of " ^ n | Some n, `Slice, false -> "a slice of an array inside " ^ n | Some n, `Addr, true -> "the address of " ^ n | Some n, `Addr, false -> "an address inside " ^ n | None, `Slice, _ -> "a slice of a temporary array" | None, `Addr, _ -> "the address of a temporary" in (* Reported at the addr or slice itself: a [return] under a [defer], or a local bound to one, reaches here as a read of a slot, and the caret belongs on the form that took the address. *) let fail ~verb ~target ~fix_slice ~fix_addr ((e : Tast.expr), ((s, kind, exact) as hit)) = let fix = (* The slice as written, bounds and all, when the source can be read back; its root's name otherwise. *) let rec bound (b : Tast.expr) = match b.Tast.e with | Tast.Int (v, _) -> Some (Int64.to_string v) | Tast.Local i -> f.Tast.snames.(i) | Tast.Prim (Tast.Cast _, [ x ]) -> bound x | _ -> None in let rebuilt = match e.Tast.e, f.Tast.snames.(s), exact with | Tast.Prim (Tast.Slice, [ t; lo; hi ]), Some n, true -> (match t.Tast.ty, bound lo, bound hi with | Types.Array (len, _), Some "0", Some h when h = Int64.to_string len -> Some ("(slice " ^ n ^ ")") | _, Some l, Some h -> Some ("(slice " ^ n ^ " " ^ l ^ " " ^ h ^ ")") | _ -> None) | _ -> None in let written = match rebuilt, Loc.snippet ~lim:120 e.Tast.loc with | Some t, _ -> Some t | None, Some t when String.length t > 7 && String.sub t 0 7 = "(slice " && not (String.contains t '\n') && not (String.ends_with ~suffix:"\xe2\x80\xa6" t) -> Some t | _ -> None in match written, f.Tast.snames.(s), kind, exact with | Some t, _, `Slice, _ -> fix_slice ("wrap the slice in clone, as in (clone " ^ t ^ ")") | None, Some n, `Slice, true -> fix_slice ("wrap the slice in clone, as in (clone (slice " ^ n ^ "))") | _, _, `Slice, _ -> fix_slice "wrap the slice in (clone ...)" | _, _, `Addr, _ -> let pointee = match e.Tast.ty with | Types.Ptr (_, t) -> tyname e.Tast.loc t | t -> tyname e.Tast.loc t in fix_addr pointee in let whose = match f.Tast.snames.(s) with | Some n -> Printf.sprintf "%s is a local of %s" n who | None -> "That value lives in the frame of " ^ who in Loc.failk "check/frame-escape" e.Tast.loc "%s %s %s%s. %s, and its storage is gone once %s returns, so every \ later read through it reads whatever the next call leaves there. %s" (if String.equal who f.Tast.name then who else String.capitalize_ascii who) verb (what hit) target whose who fix in (* Every value position of the body, walked by [Tast.iter_tails]: a restart clause is a branch of this function whose value is the form's value when that restart is taken, and it is on that list. *) let tails = Tast.iter_tails (fun (e : Tast.expr) -> Option.iter (fail ~verb:"returns" ~target:"" ~fix_slice:(fun c -> "Return a copy the caller owns: " ^ c ^ ", which puts the elements in the context allocator") ~fix_addr:(fun t -> if String.equal who f.Tast.name then "Return the value instead: declare " ^ who ^ " to return " ^ t ^ " and drop the addr" else "Return the value, of type " ^ t ^ ", instead of its address: drop the addr")) (escapes 0 e)) in (* Only a store into the global itself can be fixed by changing the global's type; for a field, an element or a push, the value's type belongs to something else. *) let stored ~bare g v = Option.iter (fail ~verb:"stores" ~target:(" into the global " ^ g) ~fix_slice:(fun c -> "Store a copy that outlives the frame: " ^ c ^ ", which puts the elements in the context allocator") ~fix_addr:(fun t -> if bare then "Store the value instead: declare " ^ g ^ " as " ^ t ^ " and drop the addr" else "Store the value instead of its address")) (escapes 0 v) in let returns = not (Types.equal f.Tast.ret Types.Unit) in List.iter (Tast.walk (fun (e : Tast.expr) -> match e.Tast.e with | Tast.Return (Some v) when returns -> tails v | Tast.Set (p, v) when not (String.equal f.Tast.name "main") -> Option.iter (fun g -> stored ~bare:(match p with Tast.Pglobal _ -> true | _ -> false) g v) (place_global p) (* A push or put into a container a global owns: the element was bound to a slot first, and its address is what the call takes. *) | Tast.Prim (Tast.Rt ("flan_vec_push" | "flan_map_put"), target :: rest) when not (String.equal f.Tast.name "main") -> Option.iter (fun g -> List.iter (fun (a : Tast.expr) -> match a.Tast.e with | Tast.Prim (Tast.AddrOf, [ v ]) -> stored ~bare:false g v | _ -> ()) rest) (expr_global target) | _ -> ())) f.Tast.body; if returns then match List.rev f.Tast.body with x :: _ -> tails x | [] -> () (* ── String, the prelude's owned text ──────────────────────────────── A (defstruct String [bytes (Vec u8)]) in the prelude, kept valid UTF-8 by the arms in [named_call] that are the only way to change one — see [string_call]. Every run-time operation reaches the Vec, which is the struct's one field: the backends see a struct holding a Vec and nothing else, which is why neither has a String of its own. *) let string_ty = Types.Named "String" let is_string_ty t = Types.equal t string_ty let string_vec_ty = Types.Vec (Types.Int Types.U8) let u8_ty = Types.Int Types.U8 let string_or_ptr t = match t with | Types.Ptr (_, t) -> is_string_ty t | t -> is_string_ty t (* The String's (Vec u8), through a pointer to one too. *) let string_vec loc (s : Tast.expr) = let s = match s.Tast.ty with | Types.Ptr (_, t) when is_string_ty t -> mk loc t (Tast.Deref s) | _ -> s in mk loc string_vec_ty (Tast.Field (s, 0)) let box ?ctx loc (e : Tast.expr) : Tast.expr = let dyn sym args = rt loc Types.Dyn sym args in let structs = match ctx with Some c -> c.env.structs | None -> !view_structs in match e.Tast.ty with | Types.Dyn -> e (* Dyn text is immutable and a String is not, so a String crosses as a copy of its bytes rather than as the view any other struct would be. *) | t when is_string_ty t -> dyn "flan_dyn_from_string" [ string_vec loc e ] (* A dyn int is an i64, so a u64 past the largest i64 has none to become: read as its bits it would be a different, negative number. It traps here, at the crossing, as one read through a view does. *) | Types.Int Types.U64 -> dyn "flan_dyn_from_u64" [ e; here loc ] | Types.Int _ -> dyn "flan_dyn_from_i64" [ widen loc dyn_i64 e ] | Types.Float _ -> dyn "flan_dyn_from_f64" [ widen loc dyn_f64 e ] (* The ABI takes an [int32_t], because a C signature that says [_Bool] is a width argument nobody wants to have. *) | Types.Bool -> dyn "flan_dyn_from_bool" [ widen loc (Types.Int Types.I32) e ] (* A typed char stays a char on the dyn side (decision 127). *) | Types.Char -> dyn "flan_dyn_from_char" [ widen loc (Types.Int Types.I32) e ] (* A string is ptr+len and arrives as two arguments, the way every other (ptr, len) entry point in the runtime takes one. The runtime copies: the bytes may be a literal or a slice of a buffer the program goes on to write. *) | Types.String -> dyn "flan_dyn_from_bytes" [ e ] (* Unit does not box. A value of the zero-sized type carries nothing for a dyn word to hold, and [nil] -- the absent dyn value, writable as the literal [nil] -- is a different thing with a different constructor. The two get confused if unit is allowed to become one. *) | Types.Unit -> Loc.failk "check/dyn-unit" loc "() does not box into dyn. The absent dyn value is nil — write nil" | Types.Never -> e (* A [$t] is seen only in a generic's abstract pass; each copy is checked again at its concrete type, where the value boxes as that type does, and this node is thrown away with the rest of the pass. Admitting it is sound only when every type the variable can be at crosses, or a refusal would move from the definition to whichever call instantiates it at a pointer, an enum or a function, with no written requirement to blame — the rule beside [println]'s deferral. Every [is-numeric] type crosses (a u64 past the largest i64 traps at run time, not at a copy's check), so that bound admits it. [is-ordered] and [is-equal] do not: both admit an enum, which has no dyn value. The node is a cast rather than [flan_dyn_nil] because [is_nil_lit] would read that as a nil literal. *) | Types.Var v when (match ctx with | Some c -> declares c.env.tvpreds v "is-numeric" | None -> false) -> mk loc Types.Dyn (Tast.Prim (Tast.Cast Types.Dyn, [ e ])) | Types.Var _ -> let t = tyname loc e.Tast.ty in Loc.failk "check/dyn-type-variable" loc "%s may be a type with no dyn value, such as a pointer or an enum, so \ it crosses into dyn only as a number. Write %s at the head of the body" t (where_text loc "is-numeric" t) (* A view, not a copy: the box holds a small record naming where the storage is and what one element is (its descriptor, [view_desc]), and every read or write goes straight through to the container's own storage — see runtime/flan_dyn.h's view section. A Vec's view points AT the Vec's header and reads its pointer and length live, so a push through the view cannot go stale; a slice and a fixed array cannot grow, so a snapshot taken at the crossing is sound for both. A struct's view is a map-like value: (get p :x), (set (get p :x) v), (put p :x v). A container, array or struct is handed over by address. One that is not a place already — a call's result — is bound to a slot of its own first, so the view points at storage that lives as long as the frame rather than at a temporary the next statement reuses. [frame_root] then says whether the storage is this frame's, for the runtime's dev check. *) | Types.Vec _ | Types.Array _ | Types.Named _ | Types.Slice (Types.Mut, _) when (match e.Tast.ty with | Types.Named n -> Hashtbl.mem structs n | _ -> true) -> let desc_of t = match view_desc structs t with | Ok d -> mk loc Types.String (Tast.Str d) | Error inner -> view_not_yet loc e inner in let i32 n = mk loc (Types.Int Types.I32) (Tast.Int (n, Types.I32)) in let i64 n = mk loc dyn_i64 (Tast.Int (n, Types.I64)) in let bind, e = match ctx, e.Tast.ty with | Some ctx, (Types.Vec _ | Types.Array _ | Types.Named _) when not (view_place e) -> let sl = fresh_slot ctx e.Tast.ty in Some (sl, e), mk loc e.Tast.ty (Tast.Local sl) | _ -> None, e in (match !view_global_init with | Some (g, kind) when frame_root e -> let fln = fln_source loc in let ty = tyname loc e.Tast.ty in Loc.failk "check/dyn-view-lifetime" loc "%s is a dyn global, and its initialiser builds a %s that is gone \ once the initialiser returns, so a dyn view of it would outlive \ it. Give %s its type, as in %s" g ty g (let form = match kind with Ast.Every -> "def" | Ast.Once -> "defonce" in if fln then Printf.sprintf "%s %s: %s = ..." (match kind with Ast.Every -> "def" | Ast.Once -> "once") g ty else Printf.sprintf "(%s %s %s ...)" form g ty) | _ -> ()); let here = i32 (if frame_root e then 1L else 0L) in let view = match e.Tast.ty with | Types.Slice (_, elem) -> dyn "flan_dyn_view_slice" [ e; desc_of elem; here ] | Types.Vec elem -> dyn "flan_dyn_view_at" [ addr_of loc e; i64 0L; desc_of elem; i32 1L; here ] | Types.Array (n, elem) -> dyn "flan_dyn_view_at" [ addr_of loc e; i64 n; desc_of elem; i32 0L; here ] | t -> dyn "flan_dyn_view_at" [ addr_of loc e; i64 0L; desc_of t; i32 2L; here ] in (match bind with | None -> view | Some b -> mk loc Types.Dyn (Tast.Let ([ b ], [ view ]))) (* A dyn view is written through by (set (at d i) x), and nothing on the dyn side can tell a read-only one apart, so a [[const T]] does not cross. *) | Types.Slice (Types.Const, elem) -> Loc.failk "check/dyn-const-view" loc "%s does not cross into dyn: a dyn view can be written through, and a \ [const %s] can only be read. A dyn view is taken of the writable \ storage it came from" (tyname loc e.Tast.ty) (tyname loc elem) (* No view for a map yet, and the suggestion is the *literal* rather than a constructor call: there is no [(map-new dyn)] — [map_new_types] wants a key and a value, and [map_type] refuses dyn as a key — so naming one would be advice that does not compile. A dyn map is written {:k v}. *) | Types.Map _ -> no_dyn_yet loc ~into:true e.Tast.ty ". A dyn map is written as a literal, {:key value ...}" (* [Option] is on this list in name only: [expect] intercepts it before [box] ever sees one — [box_option] is the real answer, M2 item 4 — so this arm only fires for a direct caller that hands [box] an Option itself, and none does today. Left refused rather than removed, so a 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.Len _ | Types.LArray _ | Types.Vec _ | Types.Array _ | Types.Slice _ -> no_dyn_yet loc ~into:true e.Tast.ty "" (* Every dyn an expectation opened ([expect]'s dyn arm), by the node that opened it, and the box: what lets a caller that asked for a typed value see that the value was a dyn, whichever opening the want picked. Keyed by identity and held weakly, so it is gone with the tree. *) module Opened = Ephemeron.K1.Make (struct type t = Tast.expr let equal = ( == ) let hash = Hashtbl.hash end) let opened_by_want : Tast.expr Opened.t = Opened.create 16 (* What an [expect] mismatch found, by the refusal: the type a caller that skipped a join can still name the way the join would have. *) module Found = Ephemeron.K1.Make (struct type t = Loc.diag let equal = ( == ) let hash = Hashtbl.hash end) let mismatch_found : Types.t Found.t = Found.create 16 let unbox loc (want : Types.t) (e : Tast.expr) : Tast.expr = let need sym ty = rt loc ty sym [ e; here loc ] in match want with | Types.Float Types.F64 -> need "flan_dyn_need_f64_at" dyn_f64 | Types.Bool -> (* The ABI answers an [int32_t]; [bool] is an [i1]. The narrowing is the language's own cast and cannot fail — the runtime already decided the value was a bool, so what comes back is 0 or 1. *) widen loc Types.Bool (need "flan_dyn_need_bool_at" (Types.Int Types.I32)) (* Only a dyn char: an int is a number until (char n) converts it. *) | Types.Char -> rt loc Types.Char "flan_dyn_need_char" [ e; here loc ] (* Any integer width, checked at run time at this site (TODO.org, "Dyn unless annotated"): an int in the width's range, or a char's code point where it fits — ASCII only into a byte, since a byte past ASCII is not that char in UTF-8. The runtime answers an i64 it has already checked, so the narrowing after it cannot lose a bit. *) | Types.Int k -> let code = match k with | Types.I8 -> 0L | Types.U8 -> 1L | Types.I16 -> 2L | Types.U16 -> 3L | Types.I32 -> 4L | Types.U32 -> 5L | Types.I64 -> 6L | Types.U64 -> 7L in let n = rt loc dyn_i64 "flan_dyn_need_int" [ e; mk loc (Types.Int Types.I32) (Tast.Int (code, Types.I32)); here loc ] in if k = Types.I64 then n else mk loc want (Tast.Prim (Tast.Cast want, [ n ])) (* An f32 is refused rather than served by a need_f64 and a rounding: the box carries one float width, and narrowing is written or it does not happen (TODO.org, "Implicit numeric widening is legal; narrowing stays a hard error"). *) | Types.Float _ -> no_dyn_yet loc ~into:false want " — take it as f64 and convert" | _ -> no_dyn_yet loc ~into:false want "" (* A dyn where a str, a slice, a fixed array or a struct was written: [flan_dyn_need_as] with the written type's descriptor, answering through a slot of that type. The runtime decides, since only it can see what the dyn holds: a text is a str's own bytes, a view of the wanted elements is their own storage, a vec or a map is a checked copy, and a [T] that can be written through is never a copy — a write through one would not reach the dyn vec, so the answer would differ with the vec typed or dyn. Its comment in runtime/flan_dyn.c says where the copies live and how long a str from a text lasts. A fixed array or a struct that holds a Vec is refused: from a view it would be a second copy of an owning header. *) let into_typed ctx loc (want : Types.t) (got : Tast.expr) : Tast.expr = let structs = ctx.env.structs in let rec owns (t : Types.t) = match t with | Types.Vec _ -> true | Types.Array (_, e) -> owns e | Types.Named n -> (match Hashtbl.find_opt structs n with | Some st -> List.exists (fun (f : Tast.field) -> owns f.Tast.fty) st.Tast.fields | None -> false) | _ -> false in match view_desc ~into:true structs want with | Error inner -> no_dyn_yet loc ~into:false want (if Types.equal inner want then "" else Printf.sprintf " — a dyn value has no %s to become" (tyname loc inner)) | Ok _ when owns want -> no_dyn_yet loc ~into:false want " — it holds a Vec, which owns its storage" | Ok d -> let ds = fresh_slot ctx Types.Dyn and out = fresh_slot ctx want in let local s ty = mk loc ty (Tast.Local s) in mk loc want (Tast.Let ([ (ds, got); (out, mk loc want (Tast.Zero want)) ], [ rt loc Types.Unit "flan_dyn_need_as" [ local ds Types.Dyn; mk loc Types.String (Tast.Str d); addr_of loc (local out want); here loc ]; local out want ])) (* ── A numeric cast written on a dyn ───────────────────────────────── * TODO.org, "A numeric cast opens a dyn box". * [(f64 d)] where [d] is dyn. Until this, the only place in the language that opened a box was a typed parameter, which is why a program that wanted a number out of a dyn had to define a one-line function whose parameter slot did the unboxing and call *that*. A cast is already the operator for "convert this to that", so it is the spelling that should have worked, and now does. What is built is a branch on the box's tag, not a call that converts: (let ([s d]) (if (= (flan_dyn_cast_kind s "file:1:2" "u32" 0) 1) (u32 (flan_dyn_need_f64 s)) (u32 (flan_dyn_need_i64 s)))) Each arm is an ordinary [Cast] over an ordinary [need], so the conversion is *the same node* a typed operand of that type would have produced. That is the point of this shape rather than a coercing runtime entry point that answers the finished number: [(i64 2.5)] is not a bare [fptosi] in this compiler — [Emit.check_cast] range-checks it first and signals ArithError when the value will not fit, and the x86 backend does the same — so a C function returning an [int64_t] would have had to grow its own second opinion about range and NaN, in a second place, for two backends. Here there is nothing to keep in step: [(i64 float-box)] *is* [(i64 x)] with an unbox in front of it, which is exactly what the semantics say. [need_f64] and [need_i64] are the trapping entry points, and neither can trap here: each is reached only on the arm where the tag has already been read as its own. The trap that can happen is the runtime's, for a box holding a non-number, and [flan_dyn_cast_kind] owns that sentence — bool included, which is what [flan_dyn_need_i64] already does with a bool at a typed parameter. The cross-kind case does not trap: it converts and warns once for the site, the author's call, recorded in TODO.org, "A numeric cast opens a dyn box". The slot exists because the value is read three times — once for the tag, once on whichever arm runs — and the argument may be an arbitrary expression. [unbox_option] above builds the same shape for the same reason. *) let cast_dyn ctx loc (target : Types.t) (got : Tast.expr) : Tast.expr = let s = fresh_slot ctx Types.Dyn in let sv = mk loc Types.Dyn (Tast.Local s) in let want_float = match target with Types.Float _ -> 1 | _ -> 0 in let kind = rt loc (Types.Int Types.I32) "flan_dyn_cast_kind" [ sv; here loc; mk loc Types.String (Tast.Str (Types.to_string target)); mk loc (Types.Int Types.I32) (Tast.Int (Int64.of_int want_float, Types.I32)) ] in let is_float = mk loc Types.Bool (Tast.Prim (Tast.Eq, [ kind; mk loc (Types.Int Types.I32) (Tast.Int (1L, Types.I32)) ])) in let arm sym ty = widen loc target (rt loc ty sym [ sv ]) in mk loc target (Tast.Let ([ (s, got) ], [ mk loc target (Tast.If (is_float, arm "flan_dyn_need_f64" dyn_f64, arm "flan_dyn_int_of" dyn_i64)) ])) (* nil is written [nil] and nothing else produces it, so this is the whole of "the checker can see a nil reaching here" — a name, not a dataflow fact. There is no propagation through a [let] or a call in this checker (see "Ownership tracking repealed" — flow analysis was removed on purpose), so a [nil] bound to a name and used later is exactly the case the runtime trap below exists for. That is the intended split, not a gap: the syntax a reader can see is refused where they are looking at it, and everything one step removed from the syntax is caught when the program runs. *) let is_nil_lit (e : Tast.expr) = match e.Tast.e with | Tast.Prim (Tast.Rt "flan_dyn_nil", []) -> true | _ -> false (* ── nil <-> None at (Option T) ──────────────────────────────────────────── The dyn absence and the typed one are the same absence at the one boundary where both are meaningful, M2 item 4. Both directions build the same [If]-over-a-tag shape [get] and [map-remove] already build (check.ml 4780-4900): the tag says which of [Some]/[None] it is, and the payload, when there is one, crosses the scalar boundary [box]/[unbox] already own. (Option (Option T)) does not cross either direction. Boxing [Some] of an inner [None] would box that [None] as nil — the same nil an outer [None] becomes — which is exactly the ambiguity [(Some nil)] is refused for one level down; unboxing has the mirror problem, one dyn absence asked to tell two levels of it apart. The type stays legal on the typed side (it is already constructible: nothing here refuses it), only the crossing does not exist for it. (Option dyn) needs no case of its own. Its payload is already dyn, so boxing it is the identity and unboxing it is the identity; the only thing that has to hold is that the payload is never nil, which is [(Some nil)]'s refusal below, not this boundary's. *) let box_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr = match t with | Types.Option inner -> Loc.failk "check/option-nested-dyn" loc "(Option (Option %s)) does not cross into dyn — Some None and None \ would both box as nil" (tyname loc inner) | _ -> (* A literal [Some]/[None] built right here skips the runtime check: the checker already knows which case it is, so there is nothing to test at run time and the conversion is free on both backends. *) match got.Tast.e with | Tast.None_ -> rt loc Types.Dyn "flan_dyn_nil" [] | Tast.Some_ x -> if Types.equal t Types.Dyn then x else box ~ctx loc x | _ -> let s = fresh_slot ctx (Types.Option t) in let sv = mk loc (Types.Option t) (Tast.Local s) in let tag = mk loc (Types.Int Types.I8) (Tast.Field (sv, 0)) in let is_some = mk loc Types.Bool (Tast.Prim (Tast.Ne, [ tag; mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])) in let payload = mk loc t (Tast.Field (sv, 1)) in let some_dyn = if Types.equal t Types.Dyn then payload else box ~ctx loc payload in let none_dyn = rt loc Types.Dyn "flan_dyn_nil" [] in mk loc Types.Dyn (Tast.Let ([ (s, got) ], [ mk loc Types.Dyn (Tast.If (is_some, some_dyn, none_dyn)) ])) (* [=] over a dyn pair, answering a bool. Shared by the [=] builtin and a literal [match] over a dyn, which is (= t lit) by definition. *) let dyn_eq loc u v = unbox loc Types.Bool (rt loc Types.Dyn "flan_dyn_eq_at" [ box loc u; box loc v; here loc ]) let unbox_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr = let oty = Types.Option t in match t with | Types.Option inner -> Loc.failk "check/option-nested-dyn" loc "(Option (Option %s)) does not cross from dyn — a dyn has one absence, \ nil, which cannot tell None from Some None apart" (tyname loc inner) | _ when is_nil_lit got -> mk loc oty Tast.None_ | _ -> let s = fresh_slot ctx Types.Dyn in let sv = mk loc Types.Dyn (Tast.Local s) in let not_nil = mk loc Types.Bool (Tast.Prim (Tast.Eq, [ rt loc (Types.Int Types.I32) "flan_dyn_is_nil" [ sv ]; mk loc (Types.Int Types.I32) (Tast.Int (0L, Types.I32)) ])) in let none = mk loc oty Tast.None_ in let payload = if Types.equal t Types.Dyn then sv else unbox loc t sv in let some = mk loc oty (Tast.Some_ payload) in mk loc oty (Tast.Let ([ (s, got) ], [ mk loc oty (Tast.If (not_nil, some, none)) ])) (* What a numeric mismatch has left to say, now that widening is silent. TODO.org, "Implicit numeric widening is legal; narrowing stays a hard error": every conversion that cannot change the number happens by itself, so a numeric pair that still reaches a refusal is one of exactly two things, and this tells them apart. Either the wanted type is *narrower* — the conversion can lose, which is what the language has always refused to do without being told, and the sentence names the cast and points out that the other direction needed nothing. Or there is no direction at all: i32 and u32 are the same width and each holds values the other cannot, so neither widens and the program has to say which half it means to keep. Written once and used by both refusals that can report one — [expect]'s, and the binary operators' when their two operands have no join. *) (* ── The widening thunk ──────────────────────────────────────────────── One per signature, and the whole of what a [CFn] costs on its way into an [Fn]. Its parameters are the signature's, it declares the environment, and its body calls through what it finds there — because that is where the original bare address was put. Which is the move that makes the two conventions meet in exactly one place. Every body reachable through an [Fn] value declares the trailing environment, so every indirect call is exactly typed and nothing anywhere relies on a callee ignoring an argument it never declared. That was the first design's hinge and it does not survive wasm32: [call_indirect] compares the signature at the call and a spare argument is a trap. Per *signature* and not per name, so a program pays one small function per distinct shape it widens rather than one per function it widens. Two widenings of the same shape share a thunk, which is what the memo below is for — the same arrangement [struct_key_pair] uses for a map's hash and equality pair, and for the same reason. **The memo is keyed on the types and the symbol spells them back**, and both halves matter. [mangle_ty] cannot serve as the spelling: it flattens a whole signature into one hyphen-joined string, which loses arity and every type boundary with it, so [(CFn [(Ptr i32)] i32)] and [(CFn [ptr i32] i32)] — the second over a struct someone called [ptr] — both come out [cfn-ptr-i32-to-i32]. Keyed on that string, the second widening silently reuses the first's thunk and calls it with the wrong arity, which is a miscompile on both backends and not a refusal anywhere. So the key is the types, compared with [Types.equal], and the name is [thick_enc]'s encoding, which no two signatures share. ([mangle_ty]'s ambiguity is older than this and is still there for the generic instantiation names it was written for. At one type's granularity it is hard to reach; at a whole signature's it is a line of Flan away.) **Why the name has to be the signature and not a counter.** A counter over the thunks minted so far is unique within one compilation and says nothing across two: reorder the definitions in the file and [thick/0] is a different signature than it was. [Session.compatible] compares a reload's functions against the running program's *by name*, so a thunk that changed shape under a fixed name reads to it as a function whose signature was edited, and the dev loop answers a form reorder with "Restart to change it". Spelled from the types, the name moves with the shape and that comparison is right again for the same reason it is right everywhere else. [fparent] is []: not a name anyone wrote, so [defs] hides it, and a marker the redefinition modules match on to carry a copy of their own. *) (* A signature written so that it can be read back: every type is self-delimiting, so no two distinct signatures encode alike. An atom is its length and then its spelling, which is what closes the gap [mangle_ty] leaves — a name's boundaries are in the string rather than inferred from the separators. A constructor is one letter, and the two that hold a count write it before their children, so [(Fn [i32] i32)] and [(Fn [] (Fn [i32] i32))] cannot read alike. [Named] and [Enum] carry different letters because a struct and a C enum may share a spelling. *) let rec thick_enc (t : Types.t) = let atom s = Printf.sprintf "%d-%s" (String.length s) s in let arrow tag ps r = Printf.sprintf "%s%d-%s" tag (List.length ps) (String.concat "-" (List.map thick_enc (ps @ [ r ]))) in match t with | Types.Named n -> "n" ^ atom n | Types.Enum n -> "e" ^ atom n | Types.Var v -> "y" ^ atom v | Types.Slice (Types.Mut, e) -> "s" ^ thick_enc e | Types.Slice (Types.Const, e) -> "k" ^ thick_enc e | Types.Ptr (Types.Mut, e) -> "p" ^ thick_enc e | Types.Ptr (Types.Const, e) -> "q" ^ thick_enc e | Types.Vec e -> "v" ^ thick_enc e | Types.Option e -> "o" ^ thick_enc e | Types.Array (n, e) -> Printf.sprintf "a%Ld-%s" n (thick_enc e) | Types.Map (k, v) -> Printf.sprintf "m%s-%s" (thick_enc k) (thick_enc v) | Types.Fn (ps, r) -> arrow "f" ps r | Types.CFn (ps, r) -> arrow "c" ps r | t -> atom (mangle_ty t) let thick_thunk env loc ps r = let same (f : Tast.fn) = f.Tast.fparent = Some "" && List.length f.Tast.params = List.length ps && List.for_all2 Types.equal f.Tast.params ps && Types.equal f.Tast.ret r in match List.find_opt same env.lifted with | Some f -> f.Tast.name | None -> let n = List.length ps in let fty = Types.CFn (ps, r) in let args = List.mapi (fun i t -> mk loc t (Tast.Local i)) ps in let callee = mk loc fty (Tast.Local n) in let name = "thick/" ^ thick_enc fty in env.lifted <- { Tast.name; params = ps; slots = Array.of_list (ps @ [ fty ]); snames = Array.make (n + 1) None; as_slots = []; ret = r; body = [ mk loc r (Tast.CallPtr (callee, args)) ]; fdefers = []; fenv = Some n; fparent = Some ""; floc = loc } :: env.lifted; name (* The slot a lifted body's environment arrives in, minted when the body did not capture anything and so has none of its own. Every body that can be *reached* through an [Fn] value declares the parameter, whether or not it reads it: a lifted [fn] literal in an [Fn] position, and every handler clause, since [flan_signal] passes the frame's environment to all of them. The alternative is a call whose signature is one argument longer than the callee's, which SysV tolerates and wasm32 does not. The slot is nameless, so the break loop hides it, and a body that never reads it costs one store the optimiser drops. *) let declare_env ctx = function | Some _ as s -> s | None -> Some (fresh_slot ctx (Types.Ptr (Types.Mut, Types.Unit))) let numeric_note ?(fln = false) ~(want : Types.t) ~(got : Types.t) () = let cast = if fln then Printf.sprintf "%s(x)" (Types.spell ~indented:fln want) else Printf.sprintf "(%s x)" (Types.spell ~indented:fln want) in if not (Types.is_numeric want && Types.is_numeric got) then "" else if Types.widens_to ~from:want ~into:got then Printf.sprintf " — %s into %s can lose, so it has to be written: %s. The other way \ round, %s widens into %s by itself" (Types.spell ~indented:fln got) (Types.spell ~indented:fln want) cast (Types.spell ~indented:fln want) (Types.spell ~indented:fln got) else Printf.sprintf " — neither widens into the other, so the conversion has to be written: \ %s" cast (* The rest of the sentence when a read-only slice meets a writable one. *) let const_note ?(fln = false) env ~(want : Types.t) ~(got : Types.t) = match want, got with | Types.Slice (Types.Mut, e), Types.Slice (Types.Const, e') when Types.equal e e' -> let copy = Option.map (fun c -> if fln then "clone(v)" else c) (const_copy env e) in Printf.sprintf " — a %s can only be read, and never becomes a %s that can be written \ through. %sWhere nothing writes through it, the %s can be declared %s \ instead" (Types.spell ~indented:fln got) (Types.spell ~indented:fln want) (match copy with | Some c -> Printf.sprintf "%s copies v into a %s of its own. " c (Types.spell ~indented:fln want) | None -> "") (Types.spell ~indented:fln want) (Types.spell ~indented:fln got) | Types.Ptr (Types.Mut, e), Types.Ptr (Types.Const, e') when Types.equal e e' -> Printf.sprintf " — a %s can only be read through, and never becomes a %s that can be \ written through. Copy the %s out with %s and point at the copy; \ where nothing writes through it, the %s can be declared %s instead" (Types.spell ~indented:fln got) (Types.spell ~indented:fln want) (Types.spell ~indented:fln e) (if fln then "deref(p)" else "(deref p)") (Types.spell ~indented:fln want) (Types.spell ~indented:fln got) | _ -> "" let nil_has_no_none loc w = fail loc "nil has no None to become at %s — nil only converts to (Option T) \ or to dyn itself; wrap the type in Option, or keep the value dyn" (tyname loc w) (* A literal boxed where a dyn was wanted, and the literal. It brings no dyn of its own to an operator: (+ nil 1) over a literal 1 checked at dyn is as typed as (+ nil x) over an i32 x. *) let boxed_literal (e : Tast.expr) = match e.Tast.e with | Tast.Prim (Tast.Rt ("flan_dyn_from_i64" | "flan_dyn_from_f64" | "flan_dyn_from_char" | "flan_dyn_from_bool"), [ x ]) -> let x = match x.Tast.e with Tast.Prim (Tast.Cast _, [ y ]) -> y | _ -> x in (match x.Tast.e with | Tast.Int (n, _) when x.Tast.ty <> Types.Char -> (* The type the literal takes where nothing is wanted. *) let k = if Int64.compare n (Int64.of_int32 Int32.max_int) > 0 || Int64.compare n (Int64.of_int32 Int32.min_int) < 0 then Types.I64 else Types.I32 in Some (Types.Int k) | Tast.Int _ | Tast.Float _ | Tast.Bool _ -> Some x.Tast.ty | _ -> None) | _ -> None (* The operands of an arithmetic, bitwise or ordering operator gone dyn, before they are boxed: a literal [nil] among them with nothing else dyn is refused as [expect] refuses it at a typed want, whichever position it is in and whether or not the form has a want. A dyn that holds nil is the run-time trap's, so (+ 1 2 nil) is refused and (+ 1 2 (the dyn nil)) traps. [=] and [!=] ask no such question: nil is unequal to a number. *) let no_bare_nil (ops : Tast.expr list) = match List.find_opt is_nil_lit ops with | None -> () | Some nil -> let makes_dyn (e : Tast.expr) = e.Tast.ty = Types.Dyn && not (is_nil_lit e) && boxed_literal e = None in if not (List.exists makes_dyn ops) then match List.find_map (fun (e : Tast.expr) -> if e.Tast.ty <> Types.Dyn then Some e.Tast.ty else boxed_literal e) ops with | Some t -> nil_has_no_none nil.Tast.loc t | None -> () let rec expect ctx loc ~want (got : Tast.expr) = match want with | None -> got | Some w -> (* The boundary: where a wanted type meets a produced one, and the one place the language's implicit conversions live. It runs before [fits] rather than instead of it: what comes back is an ordinary expression of the wanted type, and if the coercion did not produce one the usual message is still the one that reports it. *) let got = match w, got.Tast.ty with | Types.Dyn, Types.Dyn -> got | Types.Dyn, Types.Option t -> box_option ctx loc t got | Types.Dyn, _ -> box ~ctx loc got | Types.Option t, Types.Dyn when not (is_nil_lit got) -> let opened = unbox_option ctx loc t got in Opened.replace opened_by_want opened got; opened | Types.Option t, Types.Dyn -> unbox_option ctx loc t got (* A bare T has no None to become, and this nil is one the checker can actually see — the literal, written right where the mismatch is. Refused here, at the offending line, instead of waiting for the runtime trap [unbox] would otherwise reach for two arms down. *) | w, Types.Dyn when is_nil_lit got -> nil_has_no_none loc w | _, Types.Dyn when Types.fits ~expected:w ~actual:Types.Dyn -> got | (Types.String | Types.Slice _ | Types.Array _), Types.Dyn -> let opened = into_typed ctx loc w got in Opened.replace opened_by_want opened got; opened | Types.Named n, Types.Dyn when Hashtbl.mem ctx.env.structs n -> let opened = into_typed ctx loc w got in Opened.replace opened_by_want opened got; opened | _, Types.Dyn -> let opened = unbox loc w got in Opened.replace opened_by_want opened got; opened (* Implicit widening, and this single arm is the whole of its surface. [expect] is called by every site that annotates and by nothing else, so an argument, a return, a let or defonce with a type, a struct field initialiser, a push into a Vec and a C import's parameter all get it here at once and none of them had to learn about it. The conversion is performed, not waved through: [widen] emits the same [Cast] node the written (i64 x) emits, so the backends sext or zext by the *source* type's signedness and nothing downstream sees a node whose type disagrees with its bits. [widens_to] is what keeps that honest — it admits only conversions that cannot change the number, so the cast this inserts is one no program can tell happened. *) | _ when Types.widens_to ~from:got.Tast.ty ~into:w -> widen loc w got (* The other widening, and the only coercion between the two function types. A bare address satisfies a signature that asks for an environment. It goes this way only — an [Fn] has an environment and a [CFn] has nowhere to put one — so the reverse falls through to the ordinary refusal, which names both types and is the right sentence. *) | Types.Fn (ps, r), Types.CFn (ps', r') when Types.fn_accepts ~from:(ps', r') ~into:(ps, r) -> mk loc w (Tast.Thicken (thick_thunk ctx.env loc ps r, got)) (* The same signature up to const, which [Types.fn_accepts] defines. *) | Types.Fn (ps, r), Types.Fn (ps', r') | Types.CFn (ps, r), Types.CFn (ps', r') when Types.fn_accepts ~from:(ps', r') ~into:(ps, r) -> { got with Tast.ty = w } (* A writable view seen as a read-only one. The two are the same two words, so the value is only retyped; the reverse is refused below, with [const_note] naming the copy that would make it writable. *) | (Types.Slice (Types.Const, _) | Types.Ptr (Types.Const, _)), _ when Types.const_widens ~from:got.Tast.ty ~into:w -> { got with Tast.ty = w } (* Decision 138, Swift's rule: a T where a (Option T) is wanted is [Some] of it. One level each time — a T? into a T?? is [Some] of the Option, never the Option itself — and the payload goes through this same boundary first, so a T into a T?? is [Some (Some t)] and an i32 into an (Option i64) is widened, then wrapped. Never the other way: a T? where a T is wanted is still refused, and a dyn is left to the nil <-> None arms above. When the payload is refused too, the refusal below names the Option, as it did before. *) | Types.Option t, g when (match g with Types.Dyn | Types.Never -> false | _ -> true) && not (Types.fits ~expected:w ~actual:g) -> (match expect ctx loc ~want:(Some t) got with | v when Types.fits ~expected:t ~actual:v.Tast.ty -> mk loc w (Tast.Some_ v) | _ -> got | exception Loc.Error _ -> got) | _ -> got in if Types.fits ~expected:w ~actual:got.Tast.ty then got else (* Kinded so that the one caller who knows more — a call argument, which can name the function and the parameter — can recognise this exact refusal at this exact span and say the rest. Every other reader of a diagnostic ignores [kind]. [numeric_note] is the rest of the sentence when both sides are numbers, and it is on this message rather than beside it because a reader who has just been told i64 and i32 are different types needs to be told, in the same breath, which direction needed nothing. *) (try Loc.failk "check/type-mismatch" loc "expected %s, found %s%s%s" (tyname loc w) (tyname loc got.Tast.ty) (numeric_note ~fln:(Source.indented_at loc) ~want:w ~got:got.Tast.ty ()) (const_note ~fln:(Source.indented_at loc) ctx.env ~want:w ~got:got.Tast.ty) with Loc.Error d -> Found.replace mismatch_found d got.Tast.ty; raise (Loc.Error d)) (* Something a [break] may not jump out of, named so the refusal can say which. See [lentry]: it is a barrier and not a blanket refusal, so a loop written wholly inside one keeps its own perfectly good local break. Outside the recursive group below because its callers hand it bodies of two shapes — one expression and a list of them — and inside it would be monomorphic. *) let barrier ctx what f = let loops = ctx.loops in ctx.loops <- Lbarrier what :: loops; let r = f () in ctx.loops <- loops; r (* ── Expressions ───────────────────────────────────────────────────── *) (* ── (Map K V): the key's hash and equality pair ──────────────────────── spec-memory.md restricts the first implementation to built-in structural key types — integers, enums, strings, fixed arrays, and value structs composed recursively from those — and makes equality and hashing for them compiler-provided structural operations rather than type classes. So there is no dispatch to design: every key type resolves, here, to a pair of symbols, and the pair is passed to the type-erased runtime the way Odin hangs its two contextless procs off a Map_Info. Most key types need no emitted function at all. A key whose equality is bytewise and whose bytes are all present is served by one runtime pair over (pointer, size), which is what [bytewise_key] identifies. Two kinds are not: - a [string] is ptr+len and its bytes are elsewhere, so two equal strings at different addresses must still hash the same; - a struct may have padding, whose bytes are indeterminate, so two structs that are equal field by field can differ bytewise — and it may hold a string, which brings the first problem inside it. A struct therefore gets a pair emitted for it, walking its fields, and that is the only case that does. *) let rec bytewise_key = function | Types.Int _ | Types.Enum _ | Types.Bool | Types.Char -> true | Types.Array (_, t) -> bytewise_key t | _ -> false let hash_ty = Types.Int Types.U64 (* The fresh context a frame starts from: no outer scope, no defers, no loops, and [defer_ok] false. As written it is a function the checker invented — nothing is reachable from it because none of it is a body anyone wrote — and that is how the emitted hashers and the constant-inference pass take it. A body someone *did* write starts here too and then reattaches the few fields that make it theirs: [owner] is the function's name, and an fn or a handler sets [outer] to the enclosing scope so that a reference to the enclosing function's locals is refused for the reason it is really refused for. Those are [with] clauses on this record rather than a literal of their own, so that a field added here is added to all of them. Each caller calls it again rather than sharing one value: [slots] and [slot_tys] are counted up per frame, and two frames that shared a context would share a slot counter. *) (* The return type a body is checked against while it is being read for one ([_] in a defn's return slot; see [infer_returns]). Compared by address, so no type written anywhere is ever mistaken for it. What each [return] in that body gives is pushed on [infer_seen]. *) let infer_ret = Types.Named "_" (* The type two arms meet at — an [if]'s two, or two exits of a [_] body — the same whichever comes first: the wider where one widens into the other without loss ([Types.join]), the read-only where they differ only in const, and dyn where either is dyn, the other boxed. [None] is a refusal. *) let arm_join (a : Types.t) (b : Types.t) = if Types.equal a Types.Never then Some b else if Types.equal b Types.Never then Some a else match Types.join a b with | Some j -> Some j | None -> match Types.const_join a b with | Some j -> Some j | None -> (* A T beside a T? meets at the T?, the T wrapped in [Some] (decision 138). Only the plain side moves, and by one level. *) let wraps p u = (match u with Types.Option _ | Types.Unit -> false | _ -> true) && (Types.equal p u || Types.widens_to ~from:u ~into:p) in (match a, b with | Types.Dyn, _ | _, Types.Dyn -> Some Types.Dyn | Types.Option p, u when wraps p u -> Some a | u, Types.Option p when wraps p u -> Some b | _ -> None) (* The type two untyped literals meet at: the wider of their own types, and an integer beside a float at the float — [(if c 1 2.5)] is an f32, though i32 does not widen into f32, because the 1 was never an i32 to lose. Only for literals: a typed i32 beside a float literal still has to be converted. *) let literal_meet (a : Types.t) (b : Types.t) = match Types.join a b, a, b with | Some j, _, _ -> Some j | None, Types.Int _, Types.Float _ -> Some b | None, Types.Float _, Types.Int _ -> Some a | None, _, _ -> None let infer_seen : (Types.t * Loc.t * bool) list ref = ref [] (* What a refused subexpression stands as while recovering. [Zero] of [Never] is a value nothing else builds, so it is recognisable; see [check]. *) let poison loc = { Tast.e = Tast.Zero Types.Never; ty = Types.Never; loc } (* A poison, or a read of a local one was bound to. *) let is_poison (r : Tast.expr) = Types.equal r.Tast.ty Types.Never && (match r.Tast.e with Tast.Zero Types.Never | Tast.Local _ -> true | _ -> false) let record_recovered env (d : Loc.diag) = let same (x : Loc.diag) = x.Loc.dloc = d.Loc.dloc && String.equal x.Loc.dmsg d.Loc.dmsg in if not (List.exists same env.recovered) then env.recovered <- d :: env.recovered (* [f] with recovery off, for a check whose refusal is an answer: a trial, a probe, a fallback that re-checks. *) let speculate env f = env.speculating <- env.speculating + 1; Fun.protect ~finally:(fun () -> env.speculating <- env.speculating - 1) f (* A refusal a caller has re-worded: recorded and stood in for while recovering, raised otherwise. The [check] it re-words was [guarded], so its own refusal came here rather than being recorded in its first wording. *) let refuse_or_poison env loc (d : Loc.diag) = if env.recovering && env.speculating = 0 then begin record_recovered env d; env.poison <- env.poison + 1; poison loc end else raise (Loc.Error d) (* [f], a declaration's body, with recovery on when [on]. Everything it recorded is raised as [Loc.Errors] at the end, together with whatever refusal ended it, so nothing checked with a poison in it is ever returned. *) let with_recovery env ~on f = if not on then f () else begin let saved = (env.recovering, env.recovered, env.poison) in let restore () = let r, d, p = saved in env.recovering <- r; env.recovered <- d; env.poison <- p in env.recovering <- true; env.recovered <- []; env.poison <- 0; match f () with | x -> let found = List.rev env.recovered in restore (); if found = [] then x else raise (Loc.Errors found) | exception Loc.Error d -> let found = List.rev env.recovered in restore (); (* Raised past the end of the body after something in it already failed: a return that does not fit, a value that is missing, both of them what the failure left behind. *) if found = [] then raise (Loc.Error d) else raise (Loc.Errors found) | exception e -> restore (); raise e end let invented_ctx env ret = { env; ret; lits = None; slots = 0; slot_tys = []; slot_names = []; as_slots = []; scope = []; defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; place_ok = false; envslot = None; parent = None; in_frames = None; loops = []; tail = false; used = false; kept = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "" } (* Whether a struct has exactly Error's two fields, which is what a parent must have: a handler for a parent is handed a view of that shape. *) let error_shaped env n = match Hashtbl.find_opt env.structs n with | Some s -> (match s.Tast.fields with | [ { Tast.fname = "name"; fty = Types.String }; { Tast.fname = "message"; fty = Types.String } ] -> true | _ -> false) | None -> false (* What a signal site tells the runtime about its condition. A condition that something could catch through a parent, and that is not Error-shaped itself, gets a printer lifted out of the signalling function: the runtime calls it only when a parent's handler is about to run, or nothing handled it, so a signal nobody catches that way costs nothing. It prints what [println] prints, fields and values, and that is the message such a handler reads. *) let condition_desc ctx loc name = let chain = condition_chain ctx.env name in let self = error_shaped ctx.env name in let render = if self || List.length chain < 2 then None else begin let ty = Types.Named name in let hctx = { (invented_ctx ctx.env Types.Unit) with owner = ctx.owner } in let pslot = fresh_slot hctx (Types.Ptr (Types.Mut, ty)) in let bslice = Types.Slice (Types.Mut, Types.Int Types.U8) in let emit x = mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_msg_emit", [ x ])) in let emitter : Render.emitter = { Render.ebytes = emit; estr = (fun x -> emit (mk loc bslice (Tast.Prim (Tast.EscapeBytes, [ x ])))); ei64 = (fun x -> emit (to_bytes hctx loc Tast.I64ToBytes x)); eu64 = (fun x -> emit (to_bytes hctx loc Tast.U64ToBytes x)); ef64 = (fun x -> emit (to_bytes hctx loc Tast.F64ToBytes x)); edyn = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_emit_msg", [ x ]))); enested = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_emit_msg", [ x ]))) } in let value = mk loc ty (Tast.Deref (mk loc (Types.Ptr (Types.Mut, ty)) (Tast.Local pslot))) in let body = Render.render (render_ctx hctx emitter) 0 value in let mine = List.filter (fun (l : Tast.fn) -> l.Tast.fparent = Some ctx.owner && String.length l.Tast.name >= 8 && String.sub l.Tast.name 0 8 = "message/") ctx.env.lifted in let fname = Printf.sprintf "message/%s/%d/%s" ctx.owner (List.length mine) name in ctx.env.lifted <- { Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ]; slots = Array.of_list (List.rev hctx.slot_tys); snames = Array.of_list (List.rev hctx.slot_names); as_slots = hctx.as_slots; ret = Types.Unit; body; fdefers = []; fenv = None; fparent = Some ctx.owner; floc = loc } :: ctx.env.lifted; Some fname end in { Tast.cname = name; cchain = List.map type_id chain; cself = self; crender = render } (* The address of field [i] of the struct the pointer in slot [p] points at. *) let field_addr_of loc sty fty p i = let target = mk loc sty (Tast.Deref (mk loc (Types.Ptr (Types.Mut, sty)) (Tast.Local p))) in mk loc (Types.Ptr (Types.Mut, fty)) (Tast.Addr (Tast.Pfield (target, i))) (* The pointer form is what a Map_Info holds; the direct form is what an emitted hasher calls. See flan_rt.c on why they are two symbols. *) let direct = function | "flan_hash_flat" -> "flan_key_hash_flat" | "flan_eq_flat" -> "flan_key_eq_flat" | "flan_hash_str" -> "flan_key_hash_str" | "flan_eq_str" -> "flan_key_eq_str" | s -> s (* The pair for [k]: (hash, equality), each a symbol to be taken the address of. Emits a function for a struct key the first time it sees one, and finds it in [env.lifted] every time after — the name is derived from the type, so two maps with the same key type share one pair. *) let rec key_pair env loc (k : Types.t) : Tast.fnref * Tast.fnref = match k with (* A hash and an equality for a type variable would have to be *chosen*, and nothing here can choose: the pair is emitted as concrete symbols and the concrete type does not exist until the instantiation. Refused rather than assumed — falling through to [bytewise_key] would hash whatever bytes the variable turned out to have, which is the wrong answer for a [string] and for any struct with padding. **This arm is a backstop and nothing normal reaches it.** Two things get there first. Inside an instantiation [env.subst] has already made [k] concrete, so there is no variable left. Outside one — in the abstract pass over a generic body — the map operations are *deferred* ([deferred_key] below): a key that is a variable declared [is-hashable] never asks for a pair here, and a variable that is not declared it never gets as far as a [(Map $t V)] to operate on, because [map_type] refuses the type where it is written. What is left for this arm is a key that is a variable by some route neither of those covers, and the honest answer 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. \ Write {:where (is-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" | t when bytewise_key t -> Tast.Rtfn "flan_hash_flat", Tast.Rtfn "flan_eq_flat" | t when is_string_ty t -> fail loc "a String owns its bytes, and a map would share them with it rather \ than copy them, so a String is not a map key. Key the map by str and \ put %s, which is the String's text for as long as the String is not \ changed" (if fln_source loc then "str(s)" else "(str s)") | Types.Named n when Hashtbl.mem env.structs n -> struct_key_pair env loc n (* A data type key would have to hash the tag and then only the bytes the case in hand actually uses — the rest of the payload is indeterminate, exactly as a struct's padding is, so hashing the blob would make two equal values hash differently. That is a per-case walk driven by a switch, which is a different shape from the field list [struct_key_pair] emits and which nothing has yet wanted. Refused by name rather than written untested. *) | Types.Named n when Hashtbl.mem env.datas n -> fail loc "%s is a data type, and a data type is not a map key — key on the tag, \ or on a struct holding what you meant" n (* And an untagged union is refused for the half of that reason which has nothing to do with a tag: a member smaller than the union leaves the rest of the storage indeterminate, so two values that agree about every byte anybody wrote hash differently. There is no per-member walk to write here either — nothing records which member was written, which is the type. *) | Types.Named n when Hashtbl.mem env.unions n -> fail loc "%s is a union, and a union is not a map key — key on the member you \ meant" n (* A bytewise array took the arm above; this is one whose elements need their own pair, a string's or a struct's. *) | Types.Array (n, e) -> array_key_pair env loc n e | Types.Float _ -> (* Not a milestone question, which is why it is said separately: NaN is not equal to itself, and 0.0 and -0.0 are equal while differing bytewise. A float key therefore has no equality for a hash map to use, whatever the implementation does. *) fail loc "a float is not a map key — NaN is not equal to itself. Key on an \ integer instead" | other -> fail loc "%s is not a map key. A key is an integer, an enum, a bool, a string, a \ fixed array of those, or a struct of those" (tyname loc other) and struct_key_pair env loc n = let hname = "map/hash/" ^ n and ename = "map/eq/" ^ n in let known name = List.exists (fun (f : Tast.fn) -> f.Tast.name = name) env.lifted in if known hname then Tast.Flanfn hname, Tast.Flanfn ename else begin let sty = Types.Named n in let fields = (Hashtbl.find env.structs n).Tast.fields in if fields = [] then fail loc "%s has no fields, so it is not a map key — every value of it would \ be the same key" n; let hparams = [ Types.Ptr (Types.Mut, sty); hash_ty; Types.Int Types.I64 ] in let eparams = [ Types.Ptr (Types.Mut, sty); Types.Ptr (Types.Mut, sty); Types.Int Types.I64 ] in (* Registered before the fields are walked, so a struct reached twice through two different fields emits one pair and not two. A struct cannot contain itself by value, so there is no cycle to break — only sharing. The body is filled in below; nothing can call these in between. *) let placeholder name ret params = { Tast.name; params; slots = Array.of_list params; snames = Array.make (List.length params) None; as_slots = []; ret; body = []; fdefers = []; fenv = None; fparent = None; floc = loc } in env.lifted <- placeholder hname hash_ty hparams :: placeholder ename (Types.Int Types.I8) eparams :: env.lifted; (* The hash: seed, then one combine per field, in declaration order. Each field is hashed by its own pair — the same recursion, so a string field hashes its bytes and a nested struct hashes field by field. Padding is never reached, because nothing here addresses anything but a field. *) let hctx = invented_ctx env hash_ty in let kp = fresh_slot ~name:"key" hctx (Types.Ptr (Types.Mut, sty)) in let seed = fresh_slot ~name:"seed" hctx hash_ty in ignore (fresh_slot ~name:"size" hctx (Types.Int Types.I64)); let acc = fresh_slot ~name:"h" hctx hash_ty in let steps = List.mapi (fun i (fl : Tast.field) -> let fty = fl.Tast.fty in let h, _ = key_pair env loc fty in let args = [ field_addr_of loc sty fty kp i; mk loc hash_ty (Tast.Local seed); size_of loc fty ] in let one = match h with | Tast.Rtfn s -> rt loc hash_ty (direct s) args | Tast.Flanfn s | Tast.Fnval s -> mk loc hash_ty (Tast.Call (s, args)) in mk loc Types.Unit (Tast.Set (Tast.Plocal acc, rt loc hash_ty "flan_hash_combine" [ mk loc hash_ty (Tast.Local acc); one ]))) fields in let hbody = (mk loc Types.Unit (Tast.Set (Tast.Plocal acc, mk loc hash_ty (Tast.Local seed)))) :: steps @ [ mk loc hash_ty (Tast.Local acc) ] in (* The equality: one early return per field, then true. Written as returns rather than as a conjunction so that the comparison stops at the first field that differs, which for a struct with a string field is the difference between one memcmp and two. *) let ectx = invented_ctx env (Types.Int Types.I8) in let ap = fresh_slot ~name:"a" ectx (Types.Ptr (Types.Mut, sty)) in let bp = fresh_slot ~name:"b" ectx (Types.Ptr (Types.Mut, sty)) in ignore (fresh_slot ~name:"size" ectx (Types.Int Types.I64)); let i8 v = mk loc (Types.Int Types.I8) (Tast.Int (v, Types.I8)) in let checks = List.mapi (fun i (fl : Tast.field) -> let fty = fl.Tast.fty in let _, eq = key_pair env loc fty in let args = [ field_addr_of loc sty fty ap i; field_addr_of loc sty fty bp i; size_of loc fty ] in let call = match eq with | Tast.Rtfn s -> rt loc (Types.Int Types.I8) (direct s) args | Tast.Flanfn s | Tast.Fnval s -> mk loc (Types.Int Types.I8) (Tast.Call (s, args)) in let differs = mk loc Types.Bool (Tast.Prim (Tast.Eq, [ call; i8 0L ])) in mk loc Types.Unit (Tast.If (differs, mk loc Types.Never (Tast.Return (Some (i8 0L))), unit_at loc))) fields in let ebody = checks @ [ i8 1L ] in let finish name ret params ctx body = { Tast.name; params; slots = Array.of_list (List.rev ctx.slot_tys); snames = Array.of_list (List.rev ctx.slot_names); as_slots = ctx.as_slots; ret; body; fdefers = []; fenv = None; fparent = None; floc = loc } in env.lifted <- finish hname hash_ty hparams hctx hbody :: finish ename (Types.Int Types.I8) eparams ectx ebody :: List.filter (fun (f : Tast.fn) -> f.Tast.name <> hname && f.Tast.name <> ename) env.lifted; Tast.Flanfn hname, Tast.Flanfn ename end (* The pair for a fixed array whose elements are not bytewise: the struct pair's shape, with the field list replaced by a loop over the elements, so [[64 string]] is one call site in a loop and not sixty-four. Each element is hashed and compared by its own pair, so an array of structs holding strings is served by the same recursion. *) and array_key_pair env loc n e = if Int64.compare n 0L <= 0 then fail loc "%s has no elements, so it is not a map key — every value of it would be \ the same key" (tyname loc (Types.Array (n, e))); let aty = Types.Array (n, e) in (* The type's printed form, with what a symbol cannot hold replaced. *) let tag = String.map (fun c -> match c with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> c | _ -> '_') (tyname loc aty) in (* The mangle is many-to-one — [a+b] and [a_b] come out alike — so a digest of the printed type, which is an identity, keeps two such keys apart. *) let tag = tag ^ "/" ^ String.sub (Digest.to_hex (Digest.string (Types.to_string aty))) 0 12 in let hname = "map/hash/array/" ^ tag and ename = "map/eq/array/" ^ tag in let known name = List.exists (fun (f : Tast.fn) -> f.Tast.name = name) env.lifted in if known hname then Tast.Flanfn hname, Tast.Flanfn ename else begin let pty = Types.Ptr (Types.Mut, aty) in let hparams = [ pty; hash_ty; Types.Int Types.I64 ] in let eparams = [ pty; pty; Types.Int Types.I64 ] in let placeholder name ret params = { Tast.name; params; slots = Array.of_list params; snames = Array.make (List.length params) None; as_slots = []; ret; body = []; fdefers = []; fenv = None; fparent = None; floc = loc } in env.lifted <- placeholder hname hash_ty hparams :: placeholder ename (Types.Int Types.I8) eparams :: env.lifted; let h, eq = key_pair env loc e in let call ret f args = match f with | Tast.Rtfn s -> rt loc ret (direct s) args | Tast.Flanfn s | Tast.Fnval s -> mk loc ret (Tast.Call (s, args)) in let elem_addr p i = let target = mk loc aty (Tast.Deref (mk loc pty (Tast.Local p))) in mk loc (Types.Ptr (Types.Mut, e)) (Tast.Addr (Tast.Pindex (target, [ mk loc index_ty (Tast.Local i) ]))) in (* The counter and its loop, which carries no break and no continue — the condition tast.ml puts on a [While] the checker invents. *) let loop ctx body = let i = fresh_slot ~name:"i" ctx index_ty in let iv = mk loc index_ty (Tast.Local i) in let limit = mk loc index_ty (Tast.Int (n, Types.I32)) in let one = mk loc index_ty (Tast.Int (1L, Types.I32)) in let cond = mk loc Types.Bool (Tast.Prim (Tast.Lt, [ iv; limit ])) in let step = mk loc Types.Unit (Tast.Set (Tast.Plocal i, mk loc index_ty (Tast.Prim (Tast.Add, [ iv; one ])))) in mk loc Types.Unit (Tast.Let ([ (i, mk loc index_ty (Tast.Int (0L, Types.I32))) ], [ mk loc Types.Unit (Tast.While (cond, [ body i ], [ step ])) ])) in let hctx = invented_ctx env hash_ty in let kp = fresh_slot ~name:"key" hctx pty in let seed = fresh_slot ~name:"seed" hctx hash_ty in ignore (fresh_slot ~name:"size" hctx (Types.Int Types.I64)); let acc = fresh_slot ~name:"h" hctx hash_ty in let hbody = [ mk loc Types.Unit (Tast.Set (Tast.Plocal acc, mk loc hash_ty (Tast.Local seed))); loop hctx (fun i -> let one = call hash_ty h [ elem_addr kp i; mk loc hash_ty (Tast.Local seed); size_of loc e ] in mk loc Types.Unit (Tast.Set (Tast.Plocal acc, rt loc hash_ty "flan_hash_combine" [ mk loc hash_ty (Tast.Local acc); one ]))); mk loc hash_ty (Tast.Local acc) ] in let ectx = invented_ctx env (Types.Int Types.I8) in let ap = fresh_slot ~name:"a" ectx pty in let bp = fresh_slot ~name:"b" ectx pty in ignore (fresh_slot ~name:"size" ectx (Types.Int Types.I64)); let i8 v = mk loc (Types.Int Types.I8) (Tast.Int (v, Types.I8)) in let ebody = [ loop ectx (fun i -> let same = call (Types.Int Types.I8) eq [ elem_addr ap i; elem_addr bp i; size_of loc e ] in mk loc Types.Unit (Tast.If (mk loc Types.Bool (Tast.Prim (Tast.Eq, [ same; i8 0L ])), mk loc Types.Never (Tast.Return (Some (i8 0L))), unit_at loc))); i8 1L ] in let finish name ret params ctx body = { Tast.name; params; slots = Array.of_list (List.rev ctx.slot_tys); snames = Array.of_list (List.rev ctx.slot_names); as_slots = ctx.as_slots; ret; body; fdefers = []; fenv = None; fparent = None; floc = loc } in env.lifted <- finish hname hash_ty hparams hctx hbody :: finish ename (Types.Int Types.I8) eparams ectx ebody :: List.filter (fun (f : Tast.fn) -> f.Tast.name <> hname && f.Tast.name <> ename) env.lifted; Tast.Flanfn hname, Tast.Flanfn ename end (* The pair as two expressions, ready to be passed. Their Flan type is [(Ptr ())]: one opaque word, which is all the backend needs. *) let key_fns env loc k = let h, e = key_pair env loc k in mk loc raw_alloc (Tast.FnAddr h), mk loc raw_alloc (Tast.FnAddr e) (* ── The map operations, deferred to the instantiation ───────────────── True when the key is a type variable, which means the operation cannot be built here and must be answered by the copy: [key_fns] emits concrete symbols and there is no concrete key type yet. The caller checks its arguments first and then returns a placeholder of the operation's own type, exactly as [print] does — see the allow-list comment at the [print] arm for what being on that list costs and why these are on it. The predicate is *required* before deferring, and that is the whole safety argument: with {:where (is-hashable $t)} in the signature, the instantiation refuses at the call site against a requirement the author wrote down. A variable with no such clause is refused here and now, at the definition, which is where the abstract pass wants every refusal that has nothing to point at. In practice [map_type] has already refused such a signature where the type was written; this repeats it rather than relying on that, the same way [key_pair] repeats [map_type]'s key check. *) let deferred_key env loc what (k : Types.t) = match k with | Types.Var v -> if not (declares env.tvpreds v "is-hashable") then Loc.failk "check/generic-map-key" loc "%s over a map keyed by the type variable %s needs %s to be hashable. \ Write {:where (is-hashable $%s)} at the head of the body" what (tyname loc k) (tyname loc k) v; true | _ -> false (* The body shared by [get] and [map-remove]: both answer an (Option V), both ask the runtime one question over (key address, out address, sizes, hash, equality), and the only thing that differs between them is which symbol is called. [sym] is therefore the whole of the difference, and the entry points above keep their own preambles — the dyn case and the deferred-key case are not the same on the two sides. The key is checked and the out slot zeroed by the caller's [k] and by [Tast.Zero] here; the Option is built here rather than in the runtime, because the runtime answers 1/0 and fills [out] only when it answers 1. It has no idea what an Option's layout is, and keeping it that way is what lets one entry point serve every value type. *) let map_lookup ctx ~want loc sym target kt vt k = let hash, eq = key_fns ctx.env loc kt in let ks = fresh_slot ctx kt in let out = fresh_slot ctx vt in let found = rt loc (Types.Int Types.I8) sym [ target; addr_of loc (mk loc kt (Tast.Local ks)); addr_of loc (mk loc vt (Tast.Local out)); size_of loc kt; size_of loc vt; hash; eq; here loc ] in let oty = Types.Option vt in let some = mk loc oty (Tast.Some_ (mk loc vt (Tast.Local out))) in let none = mk loc oty Tast.None_ in let cond = mk loc Types.Bool (Tast.Prim (Tast.Ne, [ found; mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])) in expect ctx loc ~want (mk loc oty (Tast.Let ([ (ks, k); (out, mk loc vt (Tast.Zero vt)) ], [ mk loc oty (Tast.If (cond, some, none)) ]))) (* The braced-pairs scan a struct literal, a union value and a data case all do: each key is refused if it has already been given, with a note at the first mention, and the table of what was given comes back for the fill that follows. [noun] is the word the message uses — a union's are members, the other two have fields — and [~known] is the caller's own unknown-key refusal, run after the duplicate check on the same pair so that a key given twice is reported as the duplicate it is rather than as whatever the second mention is. A caller that wants its unknown-key pass run over all the pairs first, before any of this, passes no [~known] and keeps its own loop. *) let given_once ~noun ?(known = fun _ _ -> ()) kvs = let seen = Hashtbl.create 8 in List.iter (fun (k, (v : Ast.expr)) -> (match Hashtbl.find_opt seen k with | Some (first : Ast.expr) -> Loc.failk "check/duplicate-field" v.Ast.loc ~notes:[ Loc.note first.Ast.loc (k ^ " is given here first") ] "%s %s is given twice" noun k | None -> ()); known k v; Hashtbl.add seen k v) kvs; seen (* ── Counting a library's resources ───────────────────────────────── [Shim.resources] says which bindings acquire, release or change a resource in place. The generated wrapper of each one carries [%res-acquire], [%res-release] and [%res-done] forms over its own locals — names the reader cannot produce, so no program can write them — and the call site opens the note with where it is. The runtime pairs the two by the binding's name. A resource is known by one field, not by its whole value: a program sets [looping] on a Music or the [transform] of a Model and still unloads the same resource. The field is the first pointer in the struct, depth first — an Image's pixels, a Sound's audio buffer, a Mesh's vertices, a Model's meshes — and, in a struct that holds no pointer, a field named [id], which is how a Texture2D or a RenderTexture2D names its GPU object. A struct with neither is keyed by every leaf field, hashed separately so padding never reaches the key. Every note is a [flan_dev_reg_note_] call. A release build drops that family before building its arguments, and none of the notes binds a slot, so what a release build emits is exactly what it emitted before the notes existed. *) let res_field env (t : Types.t) : int list option = let fields n = match Hashtbl.find_opt env.structs n with | Some s -> s.Tast.fields | None -> [] in let rec first_ptr t = match t with | Types.Named n when Hashtbl.mem env.structs n -> List.find_map (fun (i, (f : Tast.field)) -> match f.Tast.fty with | Types.Ptr _ -> Some [ i ] | ft -> Option.map (fun p -> i :: p) (first_ptr ft)) (List.mapi (fun i f -> (i, f)) (fields n)) | _ -> None in match first_ptr t with | Some p -> Some p | None -> (match t with | Types.Named n -> List.find_map (fun (i, (f : Tast.field)) -> if String.equal f.Tast.fname "id" then Some [ i ] else None) (List.mapi (fun i f -> (i, f)) (fields n)) | _ -> None) let rec res_hash loc env (e : Tast.expr) : Tast.expr = let seed = mk loc hash_ty (Tast.Int (0L, Types.U64)) in match e.Tast.ty with | Types.Named n when Hashtbl.mem env.structs n -> let fields = (Hashtbl.find env.structs n).Tast.fields in snd (List.fold_left (fun (i, acc) (fl : Tast.field) -> let leaf = mk loc fl.Tast.fty (Tast.Field (e, i)) in (i + 1, rt loc hash_ty "flan_hash_combine" [ acc; res_hash loc env leaf ])) (0, seed) fields) | t -> rt loc hash_ty "flan_key_hash_flat" [ addr_of loc e; seed; size_of loc t ] let res_key loc env (e : Tast.expr) : Tast.expr = match res_field env e.Tast.ty with | None -> res_hash loc env e | Some path -> let leaf = List.fold_left (fun (x : Tast.expr) i -> match x.Tast.ty with | Types.Named n -> let f = List.nth (Hashtbl.find env.structs n).Tast.fields i in mk loc f.Tast.fty (Tast.Field (x, i)) | _ -> x) e path in res_hash loc env leaf (* An argument that can be evaluated a second time and mean the same thing: a name, or the address of one or of a field of one. The in-place re-key reads its argument before and after the call, and anything with an effect in it is not re-keyed. *) let rec res_pure (e : Tast.expr) = match e.Tast.e with | Tast.Local _ | Tast.Global _ -> true | Tast.Field (x, _) -> res_pure x | Tast.Addr p | Tast.Prim (Tast.AddrOf, [ { Tast.e = Tast.Addr p; _ } ]) -> res_place p | Tast.Prim (Tast.AddrOf, [ x ]) -> res_pure x | _ -> false and res_place (p : Tast.place) = match p with | Tast.Plocal _ | Tast.Pglobal _ -> true | Tast.Pfield (t, _) -> res_pure t | _ -> false let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) = let str x = mk loc Types.String (Tast.Str x) in let call = mk loc ret (Tast.Call (name, args)) in let opened = if tr.Shim.acquire || tr.Shim.releases <> [] then [ rt loc Types.Unit "flan_dev_reg_note_res_site" [ str name; here loc ] ] else [] in let rekeyed = if ret <> Types.Unit then [] else List.filter_map (fun i -> match List.nth_opt args i with | Some ({ Tast.ty = Types.Ptr (_, t); _ } as p) when res_pure p -> Some (mk loc t (Tast.Deref p), t) | _ -> None) tr.Shim.rekey in (* The old keys go to the runtime before the call and the new ones after, in the reverse order, so it can pair them on a stack. *) let before = List.map (fun (v, _) -> rt loc Types.Unit "flan_dev_reg_note_res_rekey_from" [ res_key loc env v ]) rekeyed in let after = List.rev_map (fun (v, t) -> rt loc Types.Unit "flan_dev_reg_note_res_rekey_to" [ res_key loc env v; str (Types.to_string t) ]) rekeyed in match opened @ before, after with | [], [] -> call | pre, post -> mk loc ret (Tast.Do (pre @ [ call ] @ post)) (* Every expression goes through here, and [check_value] is the one that knows the forms. What this adds is [refuse_owned_copy], asked of whatever came back unless the form was checked as the target of a place. *) (* The conditions [check_truthy] has refused, each with the body it was checked in and its diagnostic, for as long as the outermost call is on the stack — see [check_truthy]. Physical identity on both, since a generic's body is the same syntax checked again at another type. *) let truthy_failed : (Ast.expr * (string * binding) list * Types.t * Loc.diag) list ref = ref [] (* Whether two scopes bind the same names at the same types, which is what a refusal under them can depend on — the slots are fresh on every pass. A memo keyed on less would replay a refusal after a retry changed a type. *) let same_scope (a : (string * binding) list) (b : (string * binding) list) = a == b || List.equal (fun (n, (x : binding)) (m, (y : binding)) -> String.equal n m && Types.equal x.bty y.bty) a b let truthy_depth = ref 0 (* The same for an [if], keyed on its condition and the expectation: an [if] whose else arm is tried on its own terms first (see [check_if]) would otherwise be re-checked, refused, by the trial of every [if] above it — the square of a refused or/and chain's length. *) let if_failed : (Loc.t, Ast.expr * ((string * binding) list * Types.t) * (Types.t option * bool) * Loc.diag) Hashtbl.t = Hashtbl.create 16 let if_depth = ref 0 (* An arm refused at the other arm's type, keyed the same way: the arm is then checked on its own terms, and an [if] above it that checks it again — its own trial, then for real — finds the refusal here rather than walking the arm to it once more, which in a chain nested in else arms would be twice per level. Cleared for each program. *) let arm_failed : (Loc.t, Ast.expr * ((string * binding) list * Types.t) * Types.t * Loc.diag) Hashtbl.t = Hashtbl.create 16 (* A dyn value opened at a typed want: the box, and the want it was opened at. Two arms that meet this way meet at dyn — the typed one is boxed, not the dyn one opened — whichever is written first. *) let not_kept = "check/arm-not-kept" let to_dyn ctx (x : Tast.expr) = expect ctx x.Tast.loc ~want:(Some Types.Dyn) x let opened_dyn ~(box : Tast.expr -> Tast.expr) (v : Tast.expr) = (* An opening is a value position of its own, whatever shape the conversion built. *) let stop x = Opened.mem opened_by_want x in let any = ref false in Tast.iter_tails ~stop (fun x -> if stop x then any := true) v; if not !any then None else (* Every value position meets at dyn: an opened one is put back to the box it opened, and any other is boxed. *) Some (Tast.map_tails ~stop ~ty:Types.Dyn (fun x -> match Opened.find_opt opened_by_want x with | Some b -> b | None -> box x) v) (* A Vec or a Map parameter is a copy of the caller's header — Odin's rule — so growing it reallocates a block only this function's copy points at, and the caller's container never sees the elements. The warnings found so far, one per parameter, printed by [build_program]; the parameters themselves are [grow_params], above [view_refusal], which reads them too. *) let grow_warnings : Loc.diag list ref = ref [] let note_grown ctx op loc (target : Tast.expr) = (* The parameter the container is reached from, through struct fields taken by value — a field of a parameter is in the parameter's copy too — and the path written back out. A [Deref] ends the walk: through a pointer the caller's own storage is what grows. *) let rec root (e : Tast.expr) = match e.Tast.e with | Tast.Local s -> Some (s, fun p -> p) | Tast.Field (inner, i) -> (match inner.Tast.ty with | Types.Named n -> (match Hashtbl.find_opt ctx.env.structs n with | Some st when i < List.length st.Tast.fields -> let f = (List.nth st.Tast.fields i).Tast.fname in Option.map (fun (s, path) -> (s, fun p -> Printf.sprintf "(.%s %s)" f (path p))) (root inner) | _ -> None) | _ -> None) | _ -> None in match target.Tast.ty, root target, !grow_params with | ((Types.Vec _ | Types.Map _) as t), Some (s, path), (c, ps) :: _ when c == ctx -> (match List.assoc_opt s ps with | Some (p : Ast.field) when not (List.exists (fun (d : Loc.diag) -> d.Loc.dloc = p.Ast.floc) !grow_warnings) -> let ts = tyname loc t in let msg = match target.Tast.e with | Tast.Local _ -> Printf.sprintf "%s is a %s passed by value, a copy of the caller's header, so \ the %s at %s grows this function's copy and the caller's \ container never sees it. Take it as (Ptr %s) and write (%s \ (deref %s) ...), and each caller passes (addr c) for its \ container c" p.Ast.fname ts op (Loc.to_string loc) ts op p.Ast.fname | _ -> let pt = tyname loc (List.nth ctx.slot_tys (ctx.slots - 1 - s)) in Printf.sprintf "%s is a %s passed by value, a copy of the caller's, so the %s \ at %s grows %s in this function's copy and the caller's never \ sees it. Take it as (Ptr %s), where %s reaches the caller's own, \ and each caller passes (addr c) for its %s c" p.Ast.fname pt op (Loc.to_string loc) (path p.Ast.fname) pt (path p.Ast.fname) pt in grow_warnings := Loc.diag ~kind:"check/grown-parameter" p.Ast.floc msg :: !grow_warnings | _ -> ()) | _ -> () (* Recovery, when [env.recovering] is on: a subexpression that is refused is recorded and stands as a [poison] of type [Never], which fits any want, so checking carries on around it and every error in a body is reported. What an earlier failure causes is not reported: an error raised by a node one of whose subexpressions failed, or with [Never] wanted, is dropped, as long as something has been recorded. That last condition keeps a poison from ever reaching a backend unreported — a scope with a poison in it always ends in a raise (see [with_recovery]). *) let rec check ctx ?want (e : Ast.expr) : Tast.expr = let env = ctx.env in let guarded = env.guard_next in env.guard_next <- false; if (not env.recovering) || env.speculating > 0 || guarded then check_plain ctx ?want e else begin let seen = env.poison in let caused () = (env.recovered <> [] || Hashtbl.length env.infer_failed > 0) && (env.poison > seen || want = Some Types.Never) in match check_plain ctx ?want e with | r -> if is_poison r then env.poison <- env.poison + 1; r | exception Loc.Error d -> if not (caused ()) then begin record_recovered env d; (* A call refused as a whole — the wrong number of arguments, say — never checked its arguments, and a mistake inside one is still a mistake. They are checked on their own, with no expectation, so only what no expectation could change is kept: a name that is not there. *) match e.Ast.e with (* A type written in a value position — [map-new([const u8], i32)] — is not a value to look names up in. *) | Ast.Call ({ Ast.e = Ast.Var ("map-new" | "builtin/map-new"); _ }, args) -> recheck_args ctx (List.filteri (fun i _ -> i >= 2) args) | Ast.Call ({ Ast.e = Ast.Var ("vec-new" | "builtin/vec-new"); _ }, args) -> recheck_args ctx (List.filteri (fun i _ -> i >= 1) args) | Ast.Call (_, args) -> recheck_args ctx args | _ -> () end; env.poison <- env.poison + 1; poison e.Ast.loc (* A checker arm that was never written for a [Never] operand may fail some other way over one. Only then, and only as a consequence. *) | exception (Not_found | Invalid_argument _ | Failure _ | Assert_failure _ | Match_failure _) when caused () -> env.poison <- env.poison + 1; poison e.Ast.loc end and recheck_args ctx (args : Ast.expr list) = let env = ctx.env in let before = env.recovered in List.iter (fun a -> ignore (check ctx a)) args; let rec fresh l = if l == before then [] else match l with [] -> [] | d :: r -> d :: fresh r in let kept = List.filter (fun (d : Loc.diag) -> String.starts_with ~prefix:"check/unknown-" d.Loc.kind || String.equal d.Loc.kind "check/private") (fresh env.recovered) in env.recovered <- kept @ before and check_plain ctx ?want (e : Ast.expr) : Tast.expr = let place = ctx.place_ok in ctx.place_ok <- false; let r = check_value ctx ?want e in if not place then refuse_owned_copy ctx r; r (* A form checked as the target of a place: indexed, sliced, a field read, measured, its address taken, or handed to a builtin that works on the container where it stands. *) and check_target ctx (e : Ast.expr) = ctx.place_ok <- true; check ctx e (* Decision 81 (2026-09-25). A value that owns storage — a Vec, a Map, or an array, Option or struct holding one — reached through a [[const T]] or a (Ptr const T) is not copied out as a value. Its header shares its block with the original, so a copy that could be grown, freed or handed on as writable would be the original written through. It is used where it stands instead: indexed, sliced (to a [[const T]]), its fields read when they own nothing, or its address taken as a (Ptr const T). Refusing at the source is the whole rule; there is no tracking of where a copy went. *) and refuse_owned_copy ctx (r : Tast.expr) = match const_reached r with | Some view when owning ctx.env r.Tast.ty -> let fln = Source.indented_at r.Tast.loc in let t = tyname r.Tast.loc r.Tast.ty in let fix = match r.Tast.ty with | (Types.Vec _ | Types.Map _) when not (region_only ctx.env r.Tast.ty) -> Printf.sprintf "%s copies it into a %s of its own" (if fln then "clone(v)" else "(clone v)") t (* Nothing copies an array, an Option or a struct that owns storage, nor a container whose elements do: its address is the way to it. *) | _ -> Printf.sprintf "%s gives a %s to read it through" (if fln then "addr(v)" else "(addr v)") (tyname r.Tast.loc (Types.Ptr (Types.Const, r.Tast.ty))) in Loc.failk "check/const-owned-copy" r.Tast.loc "this copies a %s out of a %s, which can only be read, and the copy \ would share its storage with the original. Use it where it stands — \ index it, slice it or read its fields — or %s" t (tyname r.Tast.loc view) fix | _ -> () and check_value ctx ?want (e : Ast.expr) : Tast.expr = let loc = e.Ast.loc in (* Read the permission this form was given and withdraw it in the same breath, so that nothing reached from here inherits it. The two callers that may grant it — [check_fn]'s body walk and [check_let]'s, below — grant it again before the *next* form rather than once around the body. *) let defer_ok = ctx.defer_ok in ctx.defer_ok <- false; (* The same read-and-withdraw, for the same reason: a [recur] is in tail position only if *this* form was, and nothing reached from here inherits it unless the arm below hands it on deliberately. *) let tail = ctx.tail in ctx.tail <- false; let used = ctx.used || List.memq e ctx.kept in ctx.used <- false; let skipping = !skip_wrap in skip_wrap := false; match e.Ast.e with (* A literal where an (Option T) is wanted is built at T and then wrapped (decision 138): [s = -1] over an [i64?] is [Some] of an i64 -1. It has no type until one is asked of it, so it is asked the payload's, rather than being built at a default and wrapped at the wrong width. *) | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ | Ast.Call _ | Ast.Arr (_ :: _) when (match want with Some (Types.Option _) -> not skipping | _ -> false) && (lone_literal e || (match e.Ast.e with Ast.Arr _ -> true | _ -> false)) -> let w = Option.get want in let t = match w with Types.Option t -> t | _ -> assert false in (match trial ctx (fun () -> check ctx ~want:t e) with | Ok v when Types.fits ~expected:t ~actual:v.Tast.ty -> mk loc w (Tast.Some_ v) | Ok v -> expect ctx loc ~want v (* Refused at T: checked again at the Option as it was before 138, so the refusal names what was wanted, [str?], and not only its payload. *) | Error _ -> skip_wrap := true; check ctx ?want e) (* A negative literal in a generic body, at an instantiation that made it unsigned. The cast the ordinary refusal names would be wrong at every other type the function is called at, so the fix is one that needs no negative number at all, and the refusal says which call asked. *) | Ast.Int n when Int64.compare n 0L < 0 && ctx.env.chain <> [] && (match want with | Some (Types.Int k) -> not (Types.signed k) | _ -> false) -> let t = Option.get want 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 (tyname loc t) | None -> tyname loc t in Loc.failk literal_at_want loc "%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)" n (tyname loc t) gname var (Int64.neg n) n | Ast.Int n -> int_literal loc ~want ~preds:ctx.env.tvpreds n | Ast.UInt (n, s) -> wide_literal loc ~want n s (* A char literal that ends up dyn is a dyn char, never an int. *) | Ast.Byte b when want = Some Types.Dyn -> rt loc Types.Dyn "flan_dyn_from_char" [ mk loc (Types.Int Types.I32) (Tast.Int (Int64.of_int b, Types.I32)) ] (* A char literal is a code point, and a byte type holds one only when it is ASCII: \é as a u8 would be 0xE9, which is not é in UTF-8 and never equals a byte of it. Refused by the char's name, not its number. *) | Ast.Byte b when (match want with | Some (Types.Int (Types.U8 | Types.I8)) -> b > 127 | Some (Types.Int Types.I16) -> b > 32767 | Some (Types.Int Types.U16) -> b > 65535 | _ -> false) -> let t = tyname loc (Option.get want) in let c = Form.byte_repr b in if (match want with | Some (Types.Int (Types.U8 | Types.I8)) -> true | _ -> false) then Loc.failk literal_at_want loc "%s is %d bytes in UTF-8, not one, so it is not a %s. Write the str \ \"%s\" for its bytes, or take its code point as an i32" c (String.length (Form.utf8 b)) t (Form.utf8 b) else Loc.failk literal_at_want loc "%s is code point %d, which does not fit in a %s. Take its code point \ as an i32" c b t (* Where typed code wants a number the literal is that number, as an integer literal would be; everywhere else it is a char (decision 127). *) | Ast.Byte b when (match want with | Some (Types.Int _ | Types.Float _) -> true | Some (Types.Var v) -> declares ctx.env.tvpreds v "is-numeric" | _ -> false) -> int_literal loc ~want ~preds:ctx.env.tvpreds (Int64.of_int b) | Ast.Byte b -> expect ctx loc ~want (mk loc Types.Char (Tast.Int (Int64.of_int b, Types.U32))) (* The float literal's own dyn case, for the reason the integer's has one: the ABI carries one width and the literal is built at it. f64 is already what an unconstrained float literal defaults to, so this only has to stop the "expected dyn, found the float literal" arm below from firing. *) | Ast.Float x when want = Some Types.Dyn -> box loc (mk loc dyn_f64 (Tast.Float (x, Types.F64))) | Ast.Float x -> let k = match want with | Some (Types.Float k) -> k (* A float literal at a type variable, refused even under [is-numeric] — the asymmetry with the integer literal above is deliberate and is the same asymmetry the concrete arms already have. An untyped integer constant is usable wherever a float is wanted; a float literal is never usable where an integer is wanted (Odin's rule, stated at the [Int] case). So [is-numeric] admits integers, and a body written with a float literal has no meaning at the integer half of its own bound. Refusing here keeps that a refusal at the definition rather than one that surprises whichever call site first instantiates at [i32]. *) | Some (Types.Var v) -> (* Under {:where (is-integer $t)} the sentence is simpler and its own: the bound has no float half at all, so the literal has no meaning at *any* type the variable can become, not merely at some. *) if declares ctx.env.tvpreds v "is-integer" then Loc.failk literal_at_want loc "the float literal %g cannot stand where $%s is wanted — \ {:where (is-integer $%s)} admits no float type. Write an integer \ literal, or take the value as a parameter" x v v else Loc.failk literal_at_want loc "the float literal %g cannot stand where $%s is wanted — %s may \ be instantiated at an integer type. Write an integer literal, \ which is admitted at every numeric type, or take the value as a \ parameter" x v (if declares ctx.env.tvpreds v "is-numeric" then Printf.sprintf "{:where (is-numeric $%s)} admits integers too, so $%s" v v else Printf.sprintf "$%s" v) | Some other when other <> Types.Never -> Loc.failk literal_at_want loc "expected %s, found the float literal %g" (tyname loc other) x | _ -> float_default () in (* Where f32 is wanted, a literal past its range would be infinity or 0, silently. *) (if k = Types.F32 && Float.is_finite x && x <> 0.0 then let f = Int32.float_of_bits (Int32.bits_of_float x) in if Float.is_integer f && f = 0.0 then Loc.failk literal_at_want loc "%g is too small for f32, which rounds it to 0 — the smallest \ f32 above 0 is about 1.4e-45" x else if not (Float.is_finite f) then Loc.failk literal_at_want loc "%g does not fit in f32, whose largest value is about 3.4e38" x); mk loc (Types.Float k) (Tast.Float (x, k)) | Ast.Str s when want = None && lit_has "dyn" && not !typed_literals -> box loc (mk loc Types.String (Tast.Str s)) | Ast.Str s -> expect ctx loc ~want (mk loc Types.String (Tast.Str s)) | Ast.Kw k -> (* Two keywords in one spelling, told apart by the expectation. Where an enum type is expected, :space resolves at compile time against its members and a typo is an error here rather than a wrong number at run time (plan.org, settled: keywords at typed call sites) — no runtime value exists at all. Everywhere else :foo is a first-class dyn value, interned by the runtime so two spellings of one name are one word and equality is an identity compare. The enum reading keeps priority because it existed first and costs nothing; nothing is lost, since a site that wants the dyn keyword against an enum expectation has none. *) (match want with | Some (Types.Enum name) -> let members = Hashtbl.find ctx.env.enums name in (match List.assoc_opt k members with | Some v -> mk loc (Types.Enum name) (Tast.Int (v, Types.I32)) | None -> (* The near miss first, because the raylib enums carry a disambiguating member prefix — [:r] is four edits from [:key-r] and one thought, and the list alone makes the reader do the thought. The list still follows: the suggestion can be wrong. *) (match member_near_miss members k with | Some (m, _) -> fail loc "%s has no member :%s — did you mean :%s? It has %s" name k m (String.concat " " (List.map (fun (m, _) -> ":" ^ m) members)) | None -> fail loc "%s has no member :%s — it has %s" name k (String.concat " " (List.map (fun (m, _) -> ":" ^ m) members)))) | Some Types.Dyn | None -> expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str k) ]) | Some other -> fail loc ":%s is an enum member where an enum is expected and a dyn keyword \ elsewhere, but %s is expected here" k (tyname loc other)) (* {:a 1 :b s} — a dyn map, built where it stands. Always dyn: the runtime owns the storage the way (vec-new dyn) does, keys and values are both dyn words, and a typed want other than dyn refuses through [expect] like any other dyn value would. The literal lowers to a fresh slot — a rooted one, because a slot of type dyn is what [Emit.root_plan] counts — so the map stays reachable across the allocations its own entries make. *) | Ast.MapLit (tag, kvs) -> let m = fresh_slot ctx Types.Dyn in let mval = mk loc Types.Dyn (Tast.Local m) in (* A class's constructor stores through [flan_dyn_slot_init], which is the plain store plus the slot's type check, worded for the constructor rather than for a [put] nobody wrote. *) let sets = List.map (fun ((k : Ast.expr), v) -> let args = [ mval; check ctx ~want:Types.Dyn k; check ctx ~want:Types.Dyn v ] in (* The key's location is the slot's, in the defclass: the constructor has no other place of its own to name. *) if tag = None then rt loc Types.Unit "flan_dyn_map_set" args else rt loc Types.Unit "flan_dyn_slot_init" (args @ [ here k.Ast.loc ])) kvs in (* A shape tag, if this is the literal a class's constructor was written from. It is the class's name interned as a keyword, and it goes into the object's header rather than into the entries — so everything below this line, the rooting included, is the untagged case unchanged. *) let empty = match tag with | None -> rt loc Types.Dyn "flan_dyn_map_new" [] | Some cls -> (* The class's slots and their types ride along, so the first instance built registers the class with the runtime and every store after it — this literal's own included — is checked. A class registered already, by an earlier instance or by a reload, keeps what it has: redefining one is a reload's business. *) let spec = match Hashtbl.find_opt ctx.env.classes cls with | Some slots -> class_spec_of slots | None -> "" in rt loc Types.Dyn "flan_dyn_map_new_class" [ rt loc Types.Dyn "flan_dyn_kw" [ mk loc Types.String (Tast.Str cls) ]; mk loc Types.String (Tast.Str spec) ] in expect ctx loc ~want (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 (List.mem name ctx.env.lenvars || (match List.assoc_opt name ctx.env.subst with | Some (Types.Len _) -> true | _ -> false)) && lookup ctx name = None -> 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; ctx.used <- used; block ctx ?want loc body (* [defer_ok] rides through: a [let] at the top level of a function body has exactly the function's extent, and so does a [let] nested inside one. [tail] rides through for the same shape of reason: a [recur] written as the last form of a [let] inside a loop body is in the loop's tail. *) | Ast.Let (bs, body) -> check_let ctx ~tail ~used ?want ~defer_ok loc bs body | Ast.If (c, t, e') -> check_if ctx ~tail ~used ?want loc c t e' | Ast.While (label, c, body) -> (* The condition is part of the loop even though it is written outside the braces — emit puts it in the header block, so it is re-evaluated at the top of every trip — but it stays outside [in_loop], because a [break] in a condition still means the enclosing loop and a [defer] there is still the outer block's. *) let names = narrows c in let c = check_truthy ctx c in let body = in_loop ctx ?label (fun () -> scoped ctx (fun () -> with_narrowed ctx names (fun () -> map_lr (fun b -> check ctx b) body))) in (* No latch: a [while] has nothing to run between the body and the test, so a [continue] can branch straight at the condition. *) expect ctx loc ~want (mk loc Types.Unit (Tast.While (c, body, []))) (* [Never], as [exit] and [return] are: nothing after one of these runs, and an [if] arm that ends in a break does not have to agree with the other. *) (* (loop [x 0 acc 1] body ...) — a loop that answers with the value of its body, and the only place a [recur] may stand. Not an IR node: it is a [let] over the names, a [While] whose condition is [true], and a jump. See [check_loop]. *) | Ast.Loop (bs, body) -> check_loop ctx ?want loc bs body | Ast.Recur args -> check_recur ctx ~tail loc args | Ast.Break label -> mk loc Types.Never (Tast.Break (loop_target ctx loc "break" label)) | Ast.Continue label -> mk loc Types.Never (Tast.Continue (loop_target ctx loc "continue" label)) | Ast.Return v when ctx.in_frames <> None -> ignore v; (* The frames are pushed and popped around the body, so an early exit would leave them on the handler or restart stack pointing into a frame that has gone. Rejected rather than left to corrupt it, the same rule as defer inside a block. *) fail loc "return is not allowed inside %s yet" (match ctx.in_frames with Some n -> n | None -> assert false) | Ast.Return v when ctx.ret == infer_ret -> let lit = match v with Some x -> adapts x | None -> false in let v = Option.map (check ctx) v in infer_seen := (match v with | Some (x : Tast.expr) -> (x.Tast.ty, loc, lit) | None -> (Types.Unit, loc, false)) :: !infer_seen; (match ctx.defers, v with | [], _ -> mk loc Types.Never (Tast.Return v) (* Thrown away after, so the order the defers run in is not built. *) | ds, _ -> mk loc Types.Never (Tast.Do (ds @ [ mk loc Types.Never (Tast.Return v) ]))) | Ast.Return v -> let v = match v with | None -> if not (Types.equal ctx.ret Types.Unit) then fail loc "this function returns %s, so return needs a value" (tyname loc ctx.ret); None | Some v -> Some (check ctx ~want:ctx.ret v) in (* The value is computed first, then whatever has been deferred *so far* runs, then the function returns — the order the fall-off-the-end path in [check_fn] has, so [(return x)] and a last form [x] agree. A defer written below this return has not executed yet and must not fire. *) (match ctx.defers, v with | [], _ -> mk loc Types.Never (Tast.Return v) | ds, Some (value : Tast.expr) when not (Types.equal value.Tast.ty Types.Never || Types.equal value.Tast.ty Types.Unit) -> let s = fresh_slot ctx value.Tast.ty in let r = mk loc Types.Never (Tast.Return (Some (mk loc value.Tast.ty (Tast.Local s)))) in mk loc Types.Never (Tast.Let ([ (s, value) ], ds @ [ r ])) (* A unit value has nothing to keep, and is still evaluated first. *) | ds, Some value when Types.equal value.Tast.ty Types.Unit -> mk loc Types.Never (Tast.Do ((value :: ds) @ [ mk loc Types.Never (Tast.Return (Some (unit_at loc))) ])) (* A value that never arrives is computed first too, and the defers after it are unreachable: a trap runs none, and a transfer out of it runs the function's [fdefers]. *) | _, Some _ -> mk loc Types.Never (Tast.Return v) | ds, None -> mk loc Types.Never (Tast.Do (ds @ [ mk loc Types.Never (Tast.Return None) ]))) (* (set (at target i) x) against a dyn target — a dyn vec from (vec-new dyn), or a typed container's own view (M2 item 3) — is a call and not a place: [flan_dyn_set_at] tag-checks [x]'s dyn tag against what the vec or the view holds and traps on a mismatch, which is not a memory write [Tast.Set] could express through a pointer. [target] is checked once, here, and handed to [vec_at]/[indexed] unchecked in the [else] branch below rather than re-checked by [check_place] — checking it twice would evaluate a target with a side effect twice. A dyn target indexed more than once — nothing in this milestone builds one — still falls to the ordinary [Ast.Set] arm below, and [indexed] refuses it by name. *) | Ast.Set (Ast.Pindex (target, [ idx ]), v) -> let target = check_target ctx target in if target.Tast.ty = Types.Dyn then let i = check ctx ~want:Types.Dyn idx in let v = check ctx ~want:Types.Dyn v in expect ctx loc ~want (rt loc Types.Unit "flan_dyn_set_at" [ target; i; v; here loc ]) else begin let p, pty = match target.Tast.ty with | Types.Vec _ -> let pp, ty = vec_at ctx loc target [ idx ] in Tast.Pderef pp, ty | _ -> (* [~place], for the reason [check_place] passes it: [indexed] accepts a string, and this arm never reaches [check_place]. *) let iidx, ty = indexed ~place:loc ctx target [ idx ] in Tast.Pindex (target, iidx), ty in let v = check ctx ~want:pty v in expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) end (* (set (get inst :slot) x) — a class instance's declared slot. A call and not a place for [flan_dyn_set_at]'s reason: the runtime has to look at the value to know it is an instance, which of its slots the key names, and whether [x] fits the type that slot was declared with, and it traps on each with a sentence of its own. A typed map has no such place; its entries are written with [put]. *) | Ast.Set (Ast.Pslot (target, k), v) -> let target = check ctx target in if target.Tast.ty <> Types.Dyn then fail loc "(get m k) is a place only on a class instance, and this is %s. A \ map's entries are written with put" (tyname loc target.Tast.ty); let k = check ctx ~want:Types.Dyn k in let v = check ctx ~want:Types.Dyn v in expect ctx loc ~want (rt loc Types.Unit "flan_dyn_slot_set" [ target; k; v; here loc ]) (* A name narrowed by [if x?] takes a value of its payload's type, which keeps it present. An Option would end the narrowing partway through the block, so it is refused (decision 133): the block reads x as present throughout. *) | Ast.Set (Ast.Pvar n, v) when (match lookup ctx n with Some b -> b.bwhat = Some narrowed_tag | None -> false) -> let b = Option.get (lookup ctx n) in (* A parameter or a captured copy is refused as it is outside the block. *) let place, _ = check_place ctx loc (Ast.Pvar n) in (match trial ctx (fun () -> check ctx ~want:b.bty v) with | Ok vv -> expect ctx loc ~want (mk loc Types.Unit (Tast.Set (place, vv))) | Error d -> (match trial ctx (fun () -> check ctx ~want:(Types.Option b.bty) v) with | Ok { Tast.ty = Types.Option _; _ } -> fail loc "%s is tested with %s? above, so in this block it is %s, and it \ cannot be given an Option here: the block reads it as present \ throughout. Assign a %s, or test a new name, as in while %s as \ item, and assign %s from that" n n (tyname loc b.bty) (tyname loc b.bty) n n | _ -> raise (Loc.Error d))) | Ast.Set ((Ast.Pvar n as p), v) when lit_recorded ctx n <> None -> let key = Option.get (lit_recorded ctx n) in let p, pty = check_place ctx loc p in let v = lit_down ctx key pty v in expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) (* (set (.name x) v) on a dyn is (put x :name v): a class slot's declared type is checked by put, and a map takes a key it did not hold. Not [flan_dyn_slot_set], which refuses a plain map — .name reads either, so assigning it writes either. The target is checked once, here. *) | Ast.Set (Ast.Pfield (target, name), v) -> let t = check_target ctx target in if t.Tast.ty = Types.Dyn then begin refuse_const_change ctx loc t; let k = dyn_kw ctx loc name in let v = check ctx ~want:Types.Dyn v in expect ctx loc ~want (rt loc Types.Unit "flan_dyn_map_put" [ t; k; v; here loc ]) end else begin let p, pty = field_place ~store:true ctx loc target t name in let v = check ctx ~want:pty v in expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) end | Ast.Set (p, v) -> let p, pty = check_place ctx loc p in let v = check ctx ~want:pty v in expect ctx loc ~want (mk loc Types.Unit (Tast.Set (p, v))) (* On a dyn, (.name x) is (get x :name) — the same call, so a missing key is nil and a value that is not a map traps with get's own sentence. *) | Ast.Field (target, name) -> let t = check_target ctx target in if t.Tast.ty = Types.Dyn then expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_get" [ t; dyn_kw ctx loc name; here loc ]) else let target, sname = struct_of ctx target t in let s = Option.get (fields_named ctx.env sname) in (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" (tyname loc (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)))) | Ast.Struct (name, kvs) -> check_struct ctx ~want loc name kvs | Ast.Bare kvs -> check_bare ctx ~want loc kvs (* A bracket literal where a dyn is wanted is the runtime's own vec, built where it stands — the same lowering the map literal gets, and what makes {:xs [1 2]} mean what it reads as. Everywhere else brackets stay the fixed-array literal they always were. *) | Ast.Arr items when want = Some Types.Dyn -> dyn_vec ctx loc (map_lr (fun x -> check ctx ~want:Types.Dyn x) items) | Ast.Arr items when want = None && lit_has "dyn" && not !typed_literals -> dyn_vec ctx loc (map_lr (fun x -> check ctx ~want:Types.Dyn x) items) | Ast.Arr items -> check_arr ctx ~want loc items (* (array 4 rl/Vector2). Parse already assembled the whole array type, so there is nothing to infer: resolve it and hand back its all-bytes-zero value, which is what a declared array with no initialiser gets. *) | Ast.ArrayOf t -> let ty = resolve ctx.env t in expect ctx loc ~want (mk loc ty (Tast.Zero ty)) (* Parse writes one only into a type position of a call named vec-new or map-new, and the builtins read it before it could get here. A program's own function of that name does not. *) | Ast.TypeArg _ -> fail loc "this is a type, and a value is wanted here" | Ast.ArrayFill (dims, v) -> check_array_fill ctx ~want loc dims v | Ast.ArrayGen (dims, f) -> check_array_gen ctx ~want loc dims f | Ast.The (t, v) -> check_the ctx ~want loc t v | Ast.Match (scrutinee, arms) -> check_match ctx ~tail ~used ?want loc scrutinee arms | Ast.IfLet (scrutinee, arm, els) -> check_if_let ctx ~tail ~used ?want loc scrutinee arm els | Ast.Chain (n, v, body) -> check_chain ctx ~want loc n v body | Ast.Narrow (names, body) -> with_narrowed ctx names (fun () -> ctx.tail <- tail; ctx.used <- used; check ctx ?want body) | Ast.Alias (pairs, body) -> scoped ctx (fun () -> List.iter (fun (g, h) -> match lookup ctx h with | Some b -> ctx.scope <- (g, b) :: ctx.scope | None -> ()) pairs; ctx.tail <- tail; ctx.used <- used; check ctx ?want body) (* Constant integer arithmetic where a type variable is wanted is folded to the literal it computes first, so [(+ x (+ 1 2))] is admitted wherever [(+ x 3)] is. The instantiation re-checks the form unfolded, at a concrete type, where the ordinary arithmetic is fine. *) | Ast.Call ({ Ast.e = Ast.Var ("+" | "-" | "*" | "/" | "%"); _ }, _) when (match want with Some (Types.Var _) -> true | _ -> false) && literal_arith e <> None -> int_literal loc ~want ~preds:ctx.env.tvpreds (Option.get (literal_arith e)) | Ast.Call (head, args) -> let outer = ctx.kept in (* A with-allocator's arguments after the first are a body, run in order, and not values. *) (match head.Ast.e with | Ast.Var ("with-allocator" | "builtin/with-allocator") -> ctx.kept <- [] | _ -> ctx.kept <- args); Fun.protect ~finally:(fun () -> ctx.kept <- outer) (fun () -> check_call ctx ~want loc head args) | Ast.Unwrap (Ast.Usome, v) -> (* Unwrap Some, else early-return None from the enclosing function, so the enclosing function must itself return an Option (plan.org). *) (match ctx.ret with | _ when ctx.ret == infer_ret -> Loc.failk "check/infer-some" loc "some returns None from the function when there is nothing, and \ this function's return type is read off its body, which cannot \ say what the Option holds. Write the return type: (Option T)" | Types.Option _ -> let v = check ctx v in (match v.Tast.ty with | Types.Option t -> expect ctx loc ~want (mk loc t (Tast.UnwrapSome v)) | other -> fail loc "some takes an (Option T), found %s" (tyname loc other)) | other -> fail loc "some early-returns None, so the enclosing function must return an \ Option; this one returns %s" (tyname loc other)) | Ast.Unwrap (Ast.Utry, _) -> unimplemented loc "try (Result)" 6 | Ast.Fn (params, body) -> check_fn ctx ~want loc params body | Ast.Dotimes (label, name, bounds, body) -> check_dotimes ctx ~want loc label name bounds body (* (signal c) : Unit, always — spec-conditions.md §1. A handler that returns normally leaves the signalling function to carry on, and with nothing matching this is a no-op, so nothing about it alters control flow. That is what makes it checkable here rather than needing the transfer machinery restart-case will want. *) | Ast.Signal (kind, c) -> let c = check ctx c in let name = match c.Tast.ty with | Types.Named n -> n (* Its own arm ahead of the general one. "A condition is a struct, not dyn" is true and useless here: a dyn holding a condition struct is one edit away from working, and the edit is naming the struct type. Since the descriptors landed, the fields inside it may be dyn — which is the half of the answer the general sentence would have hidden. *) | Types.Dyn -> fail c.Tast.loc "a condition is matched by its type and dyn is not one — write the \ condition's struct type, whose dyn fields are fine" | t -> fail c.Tast.loc "a condition is a struct, not %s" (tyname loc t) in (* A condition that *holds* a dyn is not refused. The condition crosses as a pointer to a value in the signalling frame, and that value is on the collector's root stack with its type's descriptor beside it — which is exactly the shape the transfer needed and could not have. Where the condition is not a place, the backends evaluate it into a rooted slot rather than a scratch temporary, so a handler that allocates cannot collect the payload it was handed. See [Emit.addr_rooted]. *) (* §1 and §2. [signal] is Unit whatever it finds; [error] is Never, because the only way past it is a handler that transfers — one that returns normally has not answered it, and the program stops. *) let ty, kind = match kind with | Ast.Ssignal -> (Types.Unit, Tast.Ssignal) | Ast.Serror -> (Types.Never, Tast.Serror) in expect ctx loc ~want (mk loc ty (Tast.Signal (kind, condition_desc ctx loc name, c))) | Ast.HandlerBind (clauses, body) -> check_handler_bind ctx ?want loc clauses body | Ast.HandlerCase (body, clauses) -> check_handler_case ctx ?want loc body clauses (* spec-conditions.md §3–§6: the transfer. Neither of these is a call — one establishes frames around a body, and the other leaves the function it is written in — so both are their own nodes all the way down. *) | Ast.RestartCase (body, clauses) -> check_restart_case ctx ?want loc body clauses | Ast.InvokeRestart (name, args) -> (* Never: control resumes at the restart-case, which yields the clause's value to *its* continuation, so nothing here has a value and nothing after it runs. The lookup is at run time because restarts are dynamically scoped and named — §4 — and so, for the same reason, is the check that these arguments are the ones the clause takes (§3). *) if ctx.in_defer then fail loc "invoke-restart is not allowed inside a defer"; let written = args in let args = map_lr (fun a -> check ctx a) args in List.iter (fun (a : Tast.expr) -> match a.Tast.ty with | Types.Unit | Types.Never -> fail a.Tast.loc "a restart argument must be a value, and this one is %s" (tyname loc a.Tast.ty) | _ -> ()) args; let sg = restart_sig (List.map (fun (a : Tast.expr) -> a.Tast.ty) args) in (* What the run-time refusal needs to write its fix, after the signature and a 0x1f: the syntax (i indented, p parenthesised), then each argument as written, or x. Only the message reads past the 0x1f; the comparison is on [type_id sg]. *) let said = let spell (a : Ast.expr) = match a.Ast.e with | Ast.Float x -> let t = Printf.sprintf "%g" x in if String.exists (fun c -> c = '.' || c = 'e' || c = 'n' || c = 'i') t then t else t ^ ".0" | _ -> (* The argument as written, when it is on one line of a file the checker can read; otherwise an ellipsis. *) let l = a.Ast.loc in match Loc.source_line l with | Some line when l.Loc.macro = None && l.Loc.eline = l.Loc.line && l.Loc.col >= 1 && l.Loc.ecol > l.Loc.col && l.Loc.ecol - 1 <= String.length line -> String.sub line (l.Loc.col - 1) (l.Loc.ecol - l.Loc.col) | _ -> spell_arg "\u{2026}" a in String.concat "\x1f" (sg :: (if fln_source loc then "i" else "p") :: List.map spell written) in (* Evaluated into slots first, so that an argument which transfers on its own is guarded before this form aims the channel, and so that a call written in an argument is on the ordinary walk rather than hidden inside a node that [Reach] and [Load] treat as a leaf. *) let binds = List.map (fun (a : Tast.expr) -> (fresh_slot ctx a.Tast.ty, a)) args in let locals = List.map (fun (s, (a : Tast.expr)) -> mk a.Tast.loc a.Tast.ty (Tast.Local s)) binds in let invoke = mk loc Types.Never (Tast.InvokeRestart (type_id name, name, locals, said, type_id sg, loc)) in expect ctx loc ~want (if binds = [] then invoke else mk loc Types.Never (Tast.Let (binds, [ invoke ]))) | Ast.Defer forms -> (* Registering is the whole of it: the forms are checked here, where they can see the scope they are written in, and the node left behind is [unit]. [check_fn] splices the registered list onto both exit paths. [defer_ok] is true for a top-level form of the body and for a form in a [let] whose extent is the body — see the field's comment. Anywhere else the cleanup would run at function exit rather than at the exit of the construct it was written in, so it is refused, and named. *) if not defer_ok then fail loc "defer is not allowed inside %s — a defer always runs at function \ exit. Write it at the top level of the function body, or in a let \ that is itself at the top level" ctx.defer_block; register_defer ctx loc forms and int_literal loc ~want ?(preds = []) ?(default = Types.I32) n = match want with | Some (Types.Int k) -> mk loc (Types.Int k) (Tast.Int (in_range loc k n, k)) (* An integer literal where a *type variable* is wanted: the abstract pass over a generic body, checking [(> x 0)] or [(+ x 1)] with [x] at [$t]. It is admitted exactly when [$t] is declared [is-numeric], and that bound is what makes it sound rather than optimistic: every type [is-numeric] admits is an integer or a float, and an untyped integer constant is usable at all of them — the same rule the [Float k] arm below encodes for a concrete float. So there is no instantiation of a [is-numeric] variable at which this literal has no meaning, which is the promise the abstract pass exists to make. The node built here is never emitted. A generic body produces no code; the instantiation re-checks the same form with [$t] substituted, and then the [Int k] or [Float k] arm above builds the literal at the concrete type and runs the range check. [I64] is the placeholder width and is chosen only so that a value too wide for [I32] survives the abstract pass to be ranged at the instantiation that actually has a type — [(defn f [x $t] $t (+ x 300))] is fine at [i32] and a refusal at [u8], and [u8] is where it is refused. *) | Some (Types.Var v) when declares preds v "is-numeric" -> mk loc (Types.Var v) (Tast.Int (n, Types.I64)) (* A literal in dyn position takes i64 and not the i32 an unconstrained one defaults to. This is where "dyn integers are i64" stops being a statement about the ABI and becomes one about the language: [(defonce x dyn 5)] holds an i64 five, and the defaulting question a wider set of boxes would raise never arises because there is only the one box. Handled here rather than left to [expect] so the literal is *built* at the right width — the range check below is the one that matters, and 3000000000 is a dyn integer even though it is not an i32. *) | Some Types.Dyn -> box loc (mk loc dyn_i64 (Tast.Int (in_range loc Types.I64 n, Types.I64))) (* An untyped integer constant is usable where a float is wanted, as in Odin. A float literal is never usable where an integer is wanted. *) | Some (Types.Float k) -> mk loc (Types.Float k) (Tast.Float (Int64.to_float n, k)) (* The same position without the bound. An unconstrained variable supports only what every type supports, and holding a number is not that, so the refusal names the bound that would admit it rather than reporting a type mismatch the programmer cannot act on. *) | Some (Types.Var v) -> Loc.failk literal_at_want loc "the integer literal %Ld cannot stand where $%s is wanted — nothing \ declares $%s numeric. Write {:where (is-numeric $%s)} at the head of \ the body" n v v v | Some Types.Char -> Loc.failk literal_at_want loc "the integer literal %Ld is not a char, and a char compares only with \ a char. Take its code point with %s, or make a char with %s" n (if Source.indented_at loc then "i32(c)" else "(i32 c)") (if Source.indented_at loc then Printf.sprintf "char(%Ld)" n else Printf.sprintf "(char %Ld)" n) | Some other when other <> Types.Never -> Loc.failk literal_at_want loc "expected %s, found the integer literal %Ld" (tyname loc other) n | _ -> mk loc (Types.Int default) (Tast.Int (in_range loc default n, default)) (* A wide literal where a dyn is wanted. A global's initialiser adds the fix (its type); anywhere else there is nothing to retype. *) and wide_at_dyn s = Printf.sprintf "expected dyn, found the integer literal %s, which is above the largest \ dyn int (9223372036854775807), so it has no dyn value" s (* An integer written at or above 2^63, in decimal or in hex. Only a u64 holds one, so it is accepted there and refused everywhere else, in the spelling it was written in — its pattern read as an i64 is a different number. *) and wide_literal loc ~want n s = match want with | Some (Types.Int Types.U64) -> mk loc (Types.Int Types.U64) (Tast.Int (n, Types.U64)) | Some (Types.Int k) -> Loc.failk literal_at_want loc "%s does not fit in %s" s (Types.ikind_name k) | Some (Types.Float _ as t) -> Loc.failk literal_at_want loc "%s is too large for any integer type but u64, and an integer literal \ where %s is wanted is read as one — write (%s (u64 %s))" s (tyname loc t) (tyname loc t) s | Some Types.Never | None -> Loc.failk literal_at_want loc "%s does not fit in i32, the type an integer literal takes when nothing \ says otherwise — write (u64 %s) for a u64" s s | Some Types.Dyn -> Loc.failk literal_at_want loc "%s" (wide_at_dyn s) | Some other -> Loc.failk literal_at_want loc "expected %s, found the integer literal %s, which only a u64 holds" (tyname loc other) s (* Arithmetic wraps, but a literal that does not fit its type is a typo, not a wrap — 300 is never what someone meant by a u8. *) and in_range ?(pattern = false) loc k n = let bits = Types.bits k in let ok = if Types.signed k then bits = 64 || (Int64.compare n (Int64.neg (Int64.shift_left 1L (bits - 1))) >= 0 && Int64.compare n (Int64.shift_left 1L (bits - 1)) < 0) (* A literal at or above 2^63 is a [UInt] and never reaches here as a literal; see [wide_literal]. [pattern] is the folded-constant path, which holds a u64 as its 64-bit pattern and cannot tell 2^64 - 1 from -1, so there every pattern is a u64. *) else if bits = 64 then pattern || Int64.compare n 0L >= 0 else Int64.compare n 0L >= 0 && Int64.compare n (Int64.shift_left 1L bits) < 0 in if ok then n else if Int64.compare n 0L < 0 && not (Types.signed k) then (* A negative number at an unsigned type is never the value it reads as. The cast is how to ask for the bit pattern, and names what it is. *) let mask = if bits = 64 then -1L else Int64.sub (Int64.shift_left 1L bits) 1L in let tn = Types.ikind_name k in Loc.failk literal_at_want loc "%Ld does not fit in %s, which holds no negative number — write (%s %Ld) \ for the %s with the same bits, %Lu" n tn tn n tn (Int64.logand n mask) else Loc.failk literal_at_want loc "%Ld does not fit in %s" n (Types.ikind_name k) (* The arms that are names rather than calls, and the same rule holds for them: each is in [builtins] below, and test_flan reads this match to check it. *) and var ctx ?(qualified = false) loc ~want name = match name with (* The qualifier in a value position: [builtin/nil], [builtin/true], [builtin/context/allocator] — the last one falls out for free, since stripping one prefix off it leaves a name this match has an arm for. A qualified name that gets past these arms must be refused and not handed on to the tables below, which is the whole difference between this and the call path. Falling through would look up [length] in [env.fns] and answer with the address of the very definition the reader wrote [builtin/] to get away from — the feature inverted, silently. So the catch-all arm below asks [qualified] before it looks anything up. *) | _ when not qualified && qualified_builtin name <> None -> let bare = Option.get (qualified_builtin name) in if not (Hashtbl.mem builtin_set bare) then not_a_builtin loc bare; var ctx ~qualified:true loc ~want bare | "true" | "false" -> expect ctx loc ~want (mk loc Types.Bool (Tast.Bool (name = "true"))) (* The dyn absence value, written down. It arrived with maps — (get m k) on a key the map does not hold answers it — and this is its producer, so a program can store one, compare against one, and put one in a map. It is always dyn here: whatever it becomes at a typed want — None at an (Option T), a refusal at a bare T — is [expect]'s boundary logic, M2 item 4. *) | "nil" -> expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_nil" []) (* [Dir.north]: an enum's member named through its type, as a data case is [Shape.Rect]; the same value as [:north] where a Dir is expected. *) | _ when lookup ctx name = None && enum_member ctx.env name <> None -> let head = String.sub name 0 (String.rindex name '.') in let field = String.sub name (String.length head + 1) (String.length name - String.length head - 1) in (* A local named like the enum shadows it, as a local shadows any global: [Dir.north] is then that local's field. *) if lookup ctx head <> None then check ctx ?want { Ast.e = Ast.Field ({ Ast.e = Ast.Var head; loc }, field); loc } else let e, v = Option.get (enum_member ctx.env name) in expect ctx loc ~want (mk loc (Types.Enum e) (Tast.Int (v, Types.I32))) | "None" -> (match want with | Some (Types.Option t) -> mk loc (Types.Option t) Tast.None_ (* The mirror of [nil] becoming [None]: at a dyn want, None *is* nil, with nothing to build and nothing to check — there is only one dyn absence and this is it, not an (Option T) that then gets boxed. *) | Some Types.Dyn -> rt loc Types.Dyn "flan_dyn_nil" [] | Some other when other <> Types.Never -> fail loc "expected %s, found None" (tyname loc other) | _ -> fail loc "nothing here says what None is an Option of — use it where an \ Option is expected, or name one, as in %s" (if fln_source loc then "the(Option(i32), None)" else "(the (Option i32) None)")) (* spec-memory.md puts the allocator in the calling convention as [context/allocator] and [context/temp]. They read as names rather than calls because that is how the spec writes them, and they are dynamic variables at run time rather than extra parameters — see docs/BUILT.md for why the literal reading of "calling convention" is deferred. *) | "context/allocator" -> expect ctx loc ~want (let s = fresh_slot ctx Types.Alloc in mk loc Types.Alloc (Tast.Let ([ (s, mk loc Types.Alloc (Tast.Zero Types.Alloc)) ], [ rt loc Types.Unit "flan_context_value" [ addr_of loc (mk loc Types.Alloc (Tast.Local s)) ]; mk loc Types.Alloc (Tast.Local s) ]))) | "context/temp" -> expect ctx loc ~want (seal_alloc ctx loc (rt loc raw_alloc "flan_context_temp" [])) | _ when qualified -> (* In [builtin_set] — the arm above checked — but not one of the four arms above this one, so it is a builtin that exists only as a call. There is no value to hand back: a builtin is an arm in the compiler, not a function in the program, so it has no address for a [Tast.FnAddr] to carry. Bare [length] in this position says "unknown name"; this says the true thing instead, which is that the name is real and the position is wrong. *) fail loc "%s%s is the builtin %s, which is a call and not a value — a builtin \ has no address to pass. Write (%s%s ...) at the call, or wrap it in a \ defn to pass that" builtin_prefix name name builtin_prefix name | _ -> match lookup ctx name with (* A literal local while its uses are being recorded: the use is noted. One its guess cannot serve is read at the type it asks for, so the check goes on to the uses after it, and the round is marked to be thrown away. A dyn want says the dyn width ([lit_solve]). *) | Some ({ blit = Some key; _ } as b) when (match ctx.lits, want with | Some s, Some t -> let t = lit_payload t in s.recording && not !lit_quiet && (Types.equal t Types.Dyn || lit_admits (Option.value (lit_kind key) ~default:`Int) t) | _ -> false) -> let s = Option.get ctx.lits and t = lit_payload (Option.get want) in let operand = List.memq loc !lit_operand_locs in let c = if operand || Types.equal t Types.Dyn then Hint else Up in lit_add s key (c, t, loc); (try expect ctx loc ~want (mk loc b.bty (Tast.Local b.slot)) with Loc.Error _ when lit_kind key <> Some `Box && not operand -> s.dirty <- true; expect ctx loc ~want (mk loc t (Tast.Local b.slot))) | Some b -> expect ctx loc ~want (local_of loc b) (* A local of the enclosing function, in a body that was lifted out of it: captured by value, here, where it is first named. Asked *before* the globals, because that is what the name means at the place it is written — inside the enclosing function a local shadows a global of the same name, and a body lifted out of it must not silently mean something else. *) | None when capture ctx loc name <> None -> let b = Option.get (capture ctx loc name) in expect ctx loc ~want (mk loc b.bty (Tast.Local b.slot)) | None -> match Hashtbl.find_opt ctx.env.globals name with | Some _ when Hashtbl.mem char_consts name && (match want with | Some (Types.Int _ | Types.Float _) -> true | _ -> false) -> check ctx ?want { Ast.e = Ast.Byte (Hashtbl.find char_consts name); loc } | Some (ty, _) -> expect ctx loc ~want (mk loc ty (Tast.Global name)) | None -> match Hashtbl.find_opt ctx.env.cases name with (* A case with no fields is a whole value on its own, so it is written as a name and not as a call — the same shape [None] has, and for the same reason: there is nothing to put in the braces. A case that does have fields is refused here rather than silently zeroed, because ZII on a constructor would quietly produce a value nobody wrote. *) | Some (dname, c) when String.contains name '.' -> if c.Tast.vfields <> [] then fail loc "%s has fields, so it needs them — write (%s {.%s ...})" name name (List.hd c.Tast.vfields).Tast.fname; expect ctx loc ~want (mk loc (Types.Named dname) (Tast.MakeCase (dname, c.Tast.vname, []))) | Some (dname, c) -> fail loc "%s is a case of the data type %s — write %s.%s" name dname dname c.Tast.vname | None -> (* A bare function name *is* the function. This is a Lisp-1 — one top-level namespace, enforced, so a defn and a defonce cannot share a name — and that is exactly what makes (map double xs) safe to read: there is no second binding of [double] for it to have meant instead, so Common Lisp's #'double would be punctuation answering a question this language does not ask. *) (* A name with several versions is several functions, so the name alone is not a value. A wanted function type with a count of parameters says which one was meant. *) let wanted_version () = match Hashtbl.find_opt ctx.env.versions name with | None -> None | Some vs -> match Option.bind want fn_sig with | Some (ps, _) when List.mem_assoc (List.length ps) vs -> Some (List.assoc (List.length ps) vs) | wanted -> let arities = String.concat "\n" (List.map (fun (_, v) -> " " ^ version_text ctx.env loc v) vs) in (match wanted with (* The function type wanted here takes a count none of them does, and no wrapping changes that. *) | Some (ps, _) -> let k = List.length ps in Loc.failk "check/several-versions" loc "%s has no arity that takes %d argument%s, which the \ function type wanted here does. Its arities are:\n%s" name k (if k = 1 then "" else "s") arities | None -> let fln = fln_source loc in let k, v0 = List.hd vs in let xs = match Hashtbl.find_opt ctx.env.fparams v0 with | Some fs -> List.map (fun (f : Ast.field) -> f.Ast.fname) fs | None -> List.init k (fun i -> Printf.sprintf "x%d" (i + 1)) in Loc.failk "check/several-versions" loc "%s has several arities, one per number of arguments, so \ the name alone does not say which function this is. \ Wrap it in a function that calls the one you mean, as \ in %s. Its arities are:\n%s" name (if fln then Printf.sprintf "fn(%s) => %s(%s)" (String.concat ", " xs) name (String.concat ", " xs) else Printf.sprintf "(fn [%s] (%s %s))" (String.concat " " xs) name (String.concat " " xs)) arities) in let name = match wanted_version () with Some v -> v | None -> name in (match Hashtbl.find_opt ctx.env.fns name with | Some (params, ret) -> private_ref ctx loc name; (* A foreign function is in [fns] too, and its emitted signature is C's: no transfer channel, and an aggregate flattened by the shim. Nothing could call the resulting pointer correctly, so it is refused for what it is rather than handed out. *) if Hashtbl.mem ctx.env.externs name then fail loc "%s is a foreign function, and its address is not a Flan \ function value. Wrap it in a defn and pass that" name; expect ctx loc ~want (mk loc (Types.CFn (params, ret)) (Tast.FnAddr (Tast.Fnval name))) | None -> (* The float constants no literal can write, reached only once every table above has missed, so a program's own binding of one of these names is the one it gets. *) match special_float name with | Some (x, k) -> expect ctx loc ~want (mk loc (Types.Float k) (Tast.Float (x, k))) | None -> unknown_name ctx loc (written_name name)) (* What remains of spec-memory.md's ownership section after the repeals of 2026-09-18 is the allocator's side alone: the region rule decides where a container of owning elements may be built, and the allocator's capability decides what a free means at run time. Everything copies — a container as its header, the copies aliasing one buffer — and which frees run, and in what order, is the program's own business, the same contract Odin ships with; the dev build's epoch words are the net under it. The flow analysis that used to live here (a per-function dead set, a borrow flag, a loop-iteration diff) went in the first repeal; the move-only concept itself — copy refusals, [copyable?], the struct/union owning rules — went in the second. See spec-memory.md, "The repeal". *) (* [defer_ok] is granted again before *every* form, not once before the block: [check] withdraws it as it starts, so granting it once would let the first form carry a defer and refuse the second — and two resources acquired in one [let] is the case the relaxation exists for. *) and block ctx ?want ?(defer_ok = false) loc body = match body with (* Withdrawn here too. An empty body has no last form to be the tail, so leaving the permission set would hand it to whatever is checked next. *) | [] -> ctx.tail <- false; ctx.used <- false; expect ctx loc ~want (unit_at loc) | _ -> (* A block's tail is its last form and nothing else. Callers that must not pass one on need do nothing: [check] withdrew it before they were reached, so [tail] is already false here for all of them. *) let tail = ctx.tail in let used = ctx.used in ctx.used <- false; let rec go = function | [ last ] -> ctx.defer_ok <- defer_ok; ctx.tail <- tail; ctx.used <- used; let l = check ctx ?want last in [ l ], l.Tast.ty | x :: rest -> ctx.defer_ok <- defer_ok; ctx.tail <- false; ctx.used <- false; let x = check ctx x in let rest, ty = go rest in x :: rest, ty | [] -> assert false in let body, ty = go body in mk loc ty (Tast.Do body) (* (fn [x y] BODY...) — a function value, lifted into a function of its own. The same arrangement a handler clause already uses, and deliberately so: this compiler has built and called function values internally since the Map landed, and the surface feature is that machinery given a name rather than a second one invented beside it. **Capture is by value.** The body sees its parameters, the program's globals, and the locals of the function it was written in — those last copied into an environment at the instant the value is made (see [capture] and [close_over]). The copies go on that function's frame, and [place_closures] moves them to an environment the collector allocates for a value that may outlive the frame — so it may be returned, stored or pushed like any other value: spec-memory.md's case 3. **The parameter types come from the position.** [Ast.Fn] carries names and no types — that is the surface syntax, not an omission here — so an fn is checkable exactly where something says what is wanted. An argument position does, because [named_call] threads the callee's parameter type into each argument; a bare [(let [f (fn [x] x)])] does not, and is refused saying so. *) and check_fn ctx ~want ?gen loc (params : string list) body = (* [gen] is (array-gen ...)'s way in for an inline fn: the *form* knows the parameter types — one i32 index per dimension — without there being a [(Fn ...)] want to say so, and the return is the annotated element type, or [None] to take the body's own. Everything else threads [want]. The caller has already checked the arity, in its own words. *) (* Which of the two function types was asked for. [CFn] is a bare address, so a literal written into one has nowhere to put an environment — it is checked exactly as an [Fn] is and then refused *if it turned out to capture*, which is a decision only the finished body can make. Nothing else differs. *) let bare = match want with Some (Types.CFn _) -> true | _ -> false in let pts, ret0 = match gen with | Some (pts, r) -> pts, r | None -> match Option.map fn_sig want with | Some (Some (ps, r)) when List.length ps = List.length params -> ps, Some r | Some (Some (ps, r)) -> fail loc "this fn has %d parameter%s and %s was wanted here" (List.length params) (if List.length params = 1 then "" else "s") (tyname loc (if bare then Types.CFn (ps, r) else Types.Fn (ps, r))) | _ -> match want with | Some other when other <> Types.Never -> fail loc "expected %s, found an fn" (tyname loc other) | _ -> if fln_source loc then fail loc "nothing here says what this fn's parameters are — an fn takes \ its types from the position it is written in. Pass it where a \ Fn(T, ...) -> R is expected, or name the type where it is \ bound: let f: Fn(T, ...) -> R = fn(...) => ..." else fail loc "nothing here says what this fn's parameters are — an fn takes \ its types from the position it is written in. Write it as an \ argument whose parameter is a (Fn [T ...] R), or a \ (CFn [T ...] R) when it captures nothing" in (* Its own frame and its own empty scope, with [outer] kept only so that a reference to the enclosing function's locals is refused for the reason it is really refused for. When the return is being inferred the context gets Unit provisionally — a [return] inside such a body would check against it, which is a rough edge left rough on purpose: the body of a generator is an expression, and no machinery is built for the form nobody writes. *) let fctx = { (invented_ctx ctx.env (Option.value ret0 ~default:Types.Unit)) with outer = ctx.scope; outer_what = Some "an fn"; parent = Some ctx; owner = ctx.owner } in List.iter2 (fun n t -> ignore (bind fctx n t ~assignable:false)) params pts; (* The last form is checked at the return type the position wants, as a defn's is at its declared one, so a value that takes its type from what is asked of it — a kept [when], [None], a bare struct — gets it here. *) let last_want = match ret0 with | Some r when not (Types.equal r Types.Unit) -> Some r | _ -> None in let n = List.length body in let fbody = map_lr (fun (i, e) -> if i = n - 1 then check fctx ?want:last_want e else check fctx e) (List.mapi (fun i e -> (i, e)) body) in (* The same rule an ordinary defn's body follows: the last form is the answer, and it has to be the declared return type — or, when nothing declared one ([ret0] is [None]), the last form's own type *is* the return, which is what lets a bare generator's element type be read off its body. *) let fbody, ret = match List.rev fbody with (* An fn with no body answers unit, the same as a defn whose declared return type is () and whose body is empty. Unlike a defn it declares no return type of its own, so there is nothing here to contradict — but the *position* names one, and a position wanting a value is the case [Check] has to refuse. Without this the empty body would simply fall through and the call would read a return value nothing ever wrote. *) | [] -> (match ret0 with | Some r when not (Types.equal r Types.Unit) -> fail loc "an fn with no body answers (), and this one is in a position \ that wants %s — write the value it should answer" (tyname loc r) | _ -> fbody, Types.Unit) | last :: rest -> (match ret0 with | Some r -> List.rev (expect fctx last.Tast.loc ~want:(Some r) last :: rest), r | None -> fbody, last.Tast.ty) in (* Named after the function it was written in and numbered within it, which is the handler clause's rule and is stable for the same reason: a redefinition module emits the lifted functions belonging to the bodies it replaces, and an index into the whole program's list could not say which those were. *) let fname = (* Counted per *kind*, not over everything this function has lifted. A handler clause and an fn share one list, and a shared counter would renumber every fn in a function the moment a handler-bind was added above one — a rename for a body that did not change, in the names a redefinition module emits. Two counters, two stable sequences. *) let mine = List.filter (fun (l : Tast.fn) -> l.Tast.fparent = Some ctx.owner && String.length l.Tast.name >= 3 && String.sub l.Tast.name 0 3 = "fn/") ctx.env.lifted in Printf.sprintf "fn/%s/%d" ctx.owner (List.length mine) in (* And the environment, now that the body has named everything it is going to. [close_over] allocates in both frames, so it runs after the body's slots and before the lifted function is recorded. *) let prefix, fenv, bind, addr = close_over ~fname ctx fctx loc in (* A [CFn] is a bare address and has nowhere to keep an environment, so a literal that captured cannot be one. Refused with the name of what it captured, because that is the fact the writer has to act on — and with the fix named, which is the wider type. *) if bare && fctx.caught <> [] then begin let names = List.map fst fctx.caught in Loc.failk "check/cfn-captures" loc "this fn captures %s, so it is a %s and not a %s: a CFn is the bare \ address, one word, with nowhere for the copies to live. Widen the \ position to Fn, or pass %s in as a parameter" (String.concat ", " names) (tyname loc (Types.Fn (pts, ret))) (tyname loc (Types.CFn (pts, ret))) (match names with [ n ] -> n | _ -> "them") end; (* An [Fn]-position literal declares the environment whether or not it captured: it is reached by a call that passes one. A [CFn]-position one must not — it is reached by calls that pass none, and a parameter nobody supplies is read off whatever the register held. *) let fenv = if bare then fenv else declare_env fctx fenv in let lifted = { Tast.name = fname; params = pts; slots = Array.of_list (List.rev fctx.slot_tys); snames = Array.of_list (List.rev fctx.slot_names); as_slots = fctx.as_slots; ret; body = prefix fbody; fdefers = []; fenv; fparent = Some ctx.owner; floc = loc } in refuse_frame_escapes lifted; ctx.env.lifted <- lifted :: ctx.env.lifted; let fty = if bare then Types.CFn (pts, ret) else Types.Fn (pts, ret) in (* [Flanfn] and not [Fnval], which is the handler clause's choice and is the same choice for the same reason. [Fnval] exists so that a *name* taken as a value in a dev build answers with the body that is current, which means a load from that name's indirection cell. A lifted body has no name anyone can type and no way to be redefined on its own: it is reached by address from the body it was written in, and a redefinition of that body carries its own copy. So the cell would never hold anything but this symbol, and asking for one is how a redefinition module came to reference a cell nothing declares. *) let v = match addr with | None -> mk loc fty (Tast.FnAddr (Tast.Flanfn fname)) (* The value, and the store that fills its environment on this frame around it. Whether the environment stays there is decided once the whole program is checked, by [place_closures]: a value that may outlive this frame has its copies moved to an environment the collector allocates instead. *) | Some a -> let c = mk loc fty (Tast.Closure (Tast.Flanfn fname, a)) in mk loc fty (Tast.Let ([ Option.get bind ], [ c ])) in expect ctx loc ~want v (* A handler runs where the *signal* was, not where it was established, so it cannot be a branch in the function that wrote it: it is lifted into a function of its own and reached through a pointer. It *can* see the establishing function's locals, by value: the same capture an [fn] literal gets, and the one place it has no escaping case left over. A handler frame is popped by the body that pushed it and nothing in the language can name one, so the establishing frame is alive whenever the clause runs and the copies on it are good. What is still refused is a store into a captured name — the clause holds a copy, and writing to it would leave the local as it was — so §1's accumulation case still accumulates into a global, and now with whatever the establishing function knew readable beside it. The body may not [return] either. The frames are pushed and popped around it, and an early exit would leave them on the stack pointing into a function that has gone. *) and check_handler_bind ctx ?want ?(what = "handler-bind") loc clauses body = let frames = (* Left to right, and not [List.map], whose order is unspecified: each of these calls lifts a function onto [ctx.env.lifted] and names it after the count already there, so an order nobody chose would number the clauses of one handler-bind differently between builds. The names go in a redefinition module, which is where that would be noticed — see the argument in [check_fn]. *) map_lr (fun (c : Ast.hclause) -> let ty = resolve ctx.env c.Ast.hty in let name = match ty with | Types.Named n -> n | t -> fail c.Ast.hloc "a handler matches a struct type, not %s" (tyname loc t) in (* Its own context: a fresh frame, an empty scope, and no way to reach the enclosing one. *) let hctx = { (invented_ctx ctx.env Types.Unit) with outer = ctx.scope; outer_what = Some "a handler"; parent = Some ctx } in (* The condition crosses as a pointer, because the handler runs while the signalling frame is still alive and there is nothing to copy. What the clause binds is the condition itself, though, so the pointer is a hidden parameter and the name is a slot loaded from it — a handler that passed [c] to something expecting the struct would otherwise be handed an address. *) let pslot = fresh_slot hctx (Types.Ptr (Types.Mut, ty)) in let cslot = bind hctx c.Ast.hname ty ~assignable:false in let hbody = map_lr (fun e -> check hctx e) c.Ast.hbody in let hbody = [ mk c.Ast.hloc Types.Unit (Tast.Let ([ (cslot, mk c.Ast.hloc ty (Tast.Deref (mk c.Ast.hloc (Types.Ptr (Types.Mut, ty)) (Tast.Local pslot)))) ], hbody)) ] in (* Named after the function it came out of, and numbered within it: stable against an unrelated handler-bind being added elsewhere, which an index into the whole program's lifted list would not be. *) let fname = (* Per kind, for the reason [check_fn] gives: an fn lifted out of the same function must not shift this sequence. *) let mine = List.filter (fun (l : Tast.fn) -> l.Tast.fparent = Some ctx.owner && String.length l.Tast.name >= 8 && String.sub l.Tast.name 0 8 = "handler/") ctx.env.lifted in Printf.sprintf "handler/%s/%d/%s" ctx.owner (List.length mine) name in (* And the environment, the same machinery an [fn] literal's capture uses and settled by the same argument — only with no escaping case to leave over. A handler frame is popped by the body that pushed it and nothing in the language can name one, so the clause cannot be reached from anywhere the establishing frame is not alive. So its copies stay on the establishing frame, in a slot rooted with the environment's descriptor. *) let prefix, fenv, bind, addr = close_over ~fname ctx hctx c.Ast.hloc in (* Every clause declares the environment, captured or not: [flan_signal] reads it off the frame and passes it to whichever clause matched, and it cannot know which of them captured. *) let fenv = declare_env hctx fenv in let lifted = { Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ]; slots = Array.of_list (List.rev hctx.slot_tys); snames = Array.of_list (List.rev hctx.slot_names); as_slots = hctx.as_slots; ret = Types.Unit; body = prefix hbody; fdefers = []; fenv; fparent = Some ctx.owner; floc = c.Ast.hloc } in refuse_frame_escapes lifted; ctx.env.lifted <- lifted :: ctx.env.lifted; { Tast.htype = type_id name; hfn = fname; henv = addr }, bind) clauses in (* The stores that fill the environments, one per clause that captured, around the whole form: a handler frame carries the address and the frame is pushed before the body runs, so the copies have to be made before either. *) let envbinds = List.filter_map snd frames in let frames = List.map fst frames in (* The flag is set on [ctx] itself and restored, not on a copy: [ctx.slots] and [ctx.slot_tys] are mutable, so a copy would allocate the body's slots into a record the function never sees again and the indices would collide. *) let saved = ctx.in_frames in (* [what] is the form the reader wrote. A handler-case establishes its frames through this function, so a [return] under one has to be refused naming handler-case rather than naming the machinery underneath it. *) ctx.in_frames <- Some what; (* The body's last form is the form's value, which is [with-allocator]'s shape and for the same reason: both wrap a body in something established around it and taken off after, and neither is a reason for the body to stop being an expression. §3 needs it — a [restart-case] whose body is a [handler-bind] has to agree in type with its clauses, which is how all four of this repository's crossing probes are written — and it is what [handler-case] is *not*: that one's value is its clause's, which is the whole difference between the two. [check_handler_case] below builds one out of this form and a [restart-case], so both spellings run through here and only the clause's landing place differs. This used to be [ignore want] and a flat [Types.Unit], and nothing complained, because a unit in value position is only caught where the expectation is checked. So the two backends each answered a caller that asked anyway, and answered differently: [emit.ml] a literal zero, this machine whatever the body's last form had left in the slot. Neither was a value; one of them merely looked like one. *) let body, ty = barrier ctx ("a " ^ what) (fun () -> let rec go = function | [] -> [ unit_at loc ], Types.Unit | [ last ] -> let l = check ctx ?want last in [ l ], l.Tast.ty | e :: rest -> let e = check ctx e in let rest, ty = go rest in e :: rest, ty in go body) in ctx.in_frames <- saved; let h = mk loc ty (Tast.Handled (frames, body)) in let h = if envbinds = [] then h else mk loc ty (Tast.Let (envbinds, [ h ])) in expect ctx loc ~want h (* (restart-case BODY (name [] BODY-1) ...) — spec-conditions.md §3 and §6. Unlike a handler, a clause runs *at* the restart-case, which is where it was written, so it is a branch in this function and sees this function's scope. What arrives from elsewhere is only the answer to "which clause": a transfer names the frame it is aimed at, and this form compares that against the frames it itself pushed. Every clause body and the body have the same type, and that is the type of the whole form — which is what makes the fall-through path visible in the source (§1): a restart-case in value position has to produce its type when no restart is invoked too. *) and check_restart_case ctx ?want loc body clauses = let saved = ctx.in_frames in ctx.in_frames <- Some "restart-case"; let tbody = barrier ctx "a restart-case" (fun () -> check ctx ?want body) in ctx.in_frames <- saved; restart_clauses ctx ?want ~what:"restart-case" loc tbody clauses (* The clauses of a [restart-case], checked against a body that has already been checked. Separate from the form above because [handler-case] supplies its own body — a [handler-bind] it built — and has to name itself in the refusals rather than naming the machinery it is made of. *) and restart_clauses ctx ?want ?(hidden = false) ~what loc (tbody : Tast.expr) clauses = (* With no expectation from outside, the body's own type is the expectation the clauses are checked against — unless it produced no value at all, in which case the first clause that does decides. *) let want = match want with | Some _ -> want | None -> if tbody.Tast.ty = Types.Never then None else Some tbody.Tast.ty in let ty = ref (match want with Some t -> Some t | None -> None) in let seen = ref [] in let clauses = map_lr (fun (c : Ast.rclause) -> (* Two clauses of one name would make §4's "the first frame offering the name" pick between them by an order nothing in the source shows. *) if List.mem c.Ast.rname !seen then fail c.Ast.rloc "this %s offers %s twice" what c.Ast.rname; seen := c.Ast.rname :: !seen; (* §3's parameters. They are slots in *this* function — a clause runs here, not where the invoke was — and the invoker stores into a buffer this frame owns, because its own frame is gone by the time the clause body starts (§5). Bound like a function's parameters: visible only in the clause, and not assignable. *) let params, b = scoped ctx (fun () -> let params = List.map (fun (p : Ast.field) -> let ty = resolve ctx.env p.Ast.fty in (match ty with | Types.Unit | Types.Never -> fail p.Ast.floc "%s would be a restart parameter of type %s, which is \ not a value" p.Ast.fname (tyname loc ty) | _ -> ()); (bind ctx p.Ast.fname ty ~assignable:false, ty)) c.Ast.rparams in (* Each is checked against what the form has settled on so far, so a clause that disagrees fails where it is written. The first one to produce a value is what settles it when nothing outside did. *) (params, (* The same barrier the body gets, and for the same reason: a clause runs after a transfer landed at this restart-case, with its frames still to be popped. *) barrier ctx ("a " ^ what) (fun () -> block ctx ?want:!ty c.Ast.rloc c.Ast.rbody))) in if !ty = None && b.Tast.ty <> Types.Never then ty := Some b.Tast.ty; let sg = restart_sig (List.map snd params) in { Tast.rname_id = type_id c.Ast.rname; rname = c.Ast.rname; rparams = params; rsig = sg; rsig_id = type_id sg; rbody = [ b ]; rloc = c.Ast.rloc; rreport = Option.value c.Ast.rreport ~default:""; rhidden = hidden }) clauses in let ty = match !ty with Some t -> t | None -> Types.Never in mk loc ty (Tast.RestartCase (clauses, tbody)) (* (handler-case BODY [(Type [c] BODY-1) ...]) — the unwinding handler, and spec-conditions.md's one remaining open question about it, answered: it *is* a handler-bind plus a transfer, built here rather than given nodes and backends of its own. (handler-case B [(T [c] A)]) == (restart-case (handler-bind [(T [c] (invoke-restart 'R c))] B) (R [c T] A)) That is Common Lisp's own definition of the operator, and every property this form is supposed to have falls out of the two it is made of rather than being re-implemented beside them. - The clause runs *here*, at the handler-case, because a restart clause does; so it sees this function's locals, which a handler clause cannot, and its value is the whole form's, because a restart-case's clause value is the whole restart-case's. - The stack below is gone by then. §5's defers, and the allocator a [with-allocator] rebound, are honoured on the way out because that is what a transfer already does for every frame it leaves. - A condition matching no clause installs no frame, so nothing here sees it and it keeps going outward exactly as it would have. - The body and every clause agree on one type, because §3 already says a restart-case's body and clauses do. A clause that disagrees is refused where it is written, like an [if] whose arms disagree. The condition crosses as a restart argument, which means by value into a buffer this frame owns — which is the only thing that can work, since §5 kills the signalling frame the condition was living on the moment the transfer starts. The restart the two halves meet over is named after this function and numbered within it, and the number is the count of handler clauses already lifted out of this function. That count never goes down, and every handler-case lifts at least one clause before the next one can read it, so within a name's own bucket the numbers are strictly increasing and no two forms can mint the same name. A clause body written inside another handler clause counts against the [] bucket rather than against a function's, which is the same argument again and not a hole: that bucket is one list for the whole program and it only grows. Uniqueness is the requirement rather than a nicety. Two handler-cases sharing a name, one inside the other's extent, would have the inner frame shadow the outer one (§4), which lands a condition at the wrong form — and, because the two would be expecting different condition types, lands it as a run-time signature refusal rather than as a wrong answer. *) and check_handler_case ctx ?want loc body clauses = let what = "handler-case" in (* Resolved once here, for the refusal below; [check_handler_bind] resolves them again for the frames, which is cheap and keeps that function whole. *) let names = List.map (fun (c : Ast.hclause) -> match resolve ctx.env c.Ast.hty with | Types.Named n -> n | t -> fail c.Ast.hloc "a handler matches a struct type, not %s" (tyname loc t)) clauses in (* Two clauses for one condition type: the first would take every one of them and the second could never run, and nothing in the source says which the reader meant. The same refusal a duplicate restart name gets, and for the same reason. *) let seen = ref [] in List.iter2 (fun (c : Ast.hclause) n -> if List.mem n !seen then fail c.Ast.hloc "this handler-case handles %s twice" n; seen := n :: !seen) clauses names; let k = List.length (List.filter (fun (l : Tast.fn) -> l.Tast.fparent = Some ctx.owner && String.length l.Tast.name >= 8 && String.sub l.Tast.name 0 8 = "handler/") ctx.env.lifted) in let rnames = List.map (Printf.sprintf "handler-case/%s/%d/%s" ctx.owner k) names in (* The handler half: one clause per arm, whose whole body is the transfer. It is lifted into a function of its own like any handler clause, and the condition it was handed is copied into the restart frame's buffer on its way out. *) let handlers = List.map2 (fun (c : Ast.hclause) r -> { c with Ast.hbody = [ { Ast.e = Ast.InvokeRestart (r, [ { Ast.e = Ast.Var c.Ast.hname; loc = c.Ast.hloc } ]); loc = c.Ast.hloc } ] }) clauses rnames in (* The landing half: one restart clause per arm, taking the condition as its single parameter and running what the reader actually wrote. *) let landings = List.map2 (fun (c : Ast.hclause) r -> { Ast.rname = r; rparams = [ { Ast.fname = c.Ast.hname; fty = c.Ast.hty; floc = c.Ast.hloc } ]; rreport = None; rbody = c.Ast.hbody; rloc = c.Ast.hloc }) clauses rnames in let tbody = check_handler_bind ctx ?want ~what loc handlers [ body ] in (* Hidden: the landing is reached only through the handler above, and a break loop under this form would otherwise list it as if someone could mean it. *) restart_clauses ctx ?want ~hidden:true ~what loc tbody landings (* The forms of a [defer], checked in place and hung on the function. What is left where it stands is one store: this defer's number into the counter [defer_slot] describes, which is how the transfer exit tells a defer that has registered from one the text has not reached yet. The form's type is still [unit], which is all a reader of the value can see. *) and register_defer ctx loc forms = (* Saved and put back rather than cleared, which is the same thing today and will not be the day a defer may hold one. Nothing reaches here from inside a defer now — [defer_ok] is false in there — so the saved value is always false; written this way so that if it ever is not, the flag comes back rather than being dropped. *) let was_in_defer = ctx.in_defer in ctx.in_defer <- true; (* A barrier, for the reason [defer] itself exists: these forms are *copied* into every exit path of the function, where the loop they were written beside is not running. A loop written inside the defer is below the barrier and breaks out of itself perfectly well. *) let forms = barrier ctx "a defer" (fun () -> map_lr (fun d -> check ctx d) forms) in ctx.in_defer <- was_in_defer; ctx.defers <- mk loc Types.Unit (Tast.Do forms) :: ctx.defers; let slot = match ctx.defer_slot with | Some s -> s | None -> let s = fresh_slot ctx (Types.Int Types.I64) in ctx.defer_slot <- Some s; s in mk loc Types.Unit (Tast.Set (Tast.Plocal slot, mk loc (Types.Int Types.I64) (Tast.Int (Int64.of_int (List.length ctx.defers), Types.I64)))) (* The transfer exit's copy of the defers, each under the count that says it registered. [ds] is innermost first, so the last one registered is at the head and the [j]th from the end is defer number [j]. The zero the counter starts at is written by [defer_counter_zero] below, at the top of the body: a slot is an alloca like any other and holds whatever the stack held until something stores to it, which at -O2 is not zero and is exactly how this was found. *) and guarded_defers slot (ds : Tast.expr list) = let n = List.length ds in List.mapi (fun i (d : Tast.expr) -> let loc = d.Tast.loc in let i64 = Types.Int Types.I64 in let test = mk loc Types.Bool (Tast.Prim (Tast.Ge, [ mk loc i64 (Tast.Local slot); mk loc i64 (Tast.Int (Int64.of_int (n - i), Types.I64)) ])) in mk loc Types.Unit (Tast.If (test, d, unit_at loc))) ds and defer_counter_zero slot loc = mk loc Types.Unit (Tast.Set (Tast.Plocal slot, mk loc (Types.Int Types.I64) (Tast.Int (0L, Types.I64)))) (* [defer_ok] says whether *this* let has the function's extent. If it does, so does every form in its body, including a nested let — which is why the flag is handed to the body rather than consumed here. *) (* A text or bracket literal local used where only its typed reading works — sliced, its address taken, cloned, destructured: a typed use, recorded. *) and lit_typed_use ctx (e : Ast.expr) = match e.Ast.e, ctx.lits with | Ast.Var n, Some s when s.recording -> (match lookup ctx n with | Some { blit = Some key; _ } when lit_kind key = Some `Box -> lit_add s key (Up, Types.Unit, e.Ast.loc) | _ -> ()) | _ -> () (* The literal local [n] names, while its uses are being recorded. *) and lit_recorded ctx n = match ctx.lits, lookup ctx n with | Some s, Some { blit = Some key; _ } when s.recording -> Some key | _ -> None (* [v] read as arithmetic: the literal locals among its operands, and the operands that are something else (a call, an index, a typed name). Number literals are neither. The result's type is the join of all of them, so the locals are merged with whatever [v] is stored into and the others are what it brings. *) and lit_parts ctx (v : Ast.expr) = (* [env]: names a [let] inside [v] binds, with what they were bound to, so (let [t a0] t) passes a0 through as (do a0) and an if's arms do. *) let rec go env (v : Ast.expr) (vars, others) = match v.Ast.e with | Ast.Var n -> (match List.assoc_opt n env with | Some (Some (vs, os)) -> (vs @ vars, os @ others) | Some None -> (vars, v :: others) | None -> match lookup ctx n with | Some { blit = Some k; _ } when lit_kind k <> Some `Box -> (k :: vars, others) | _ -> (vars, v :: others)) | Ast.Int _ | Ast.Float _ | Ast.Byte _ -> (vars, others) | Ast.Call ({ Ast.e = Ast.Var ("+" | "-" | "*" | "/" | "%" | "min" | "max"); _ }, args) when args <> [] -> List.fold_left (fun acc a -> go env a acc) (vars, others) args | Ast.Do (_ :: _ as xs) -> go env (List.nth xs (List.length xs - 1)) (vars, others) | Ast.Let (bs, (_ :: _ as xs)) -> let env = List.fold_left (fun env (b : Ast.binding) -> (b.Ast.bname, if b.Ast.bty = None then Some (go env b.Ast.bval ([], [])) else None) :: env) env bs in go env (List.nth xs (List.length xs - 1)) (vars, others) | Ast.If (_, t, Some e) -> go env e (go env t (vars, others)) | _ -> (vars, v :: others) in go [] v ([], []) (* A float literal, or an integer one past i32, anywhere in [v]'s arithmetic. *) and lit_wide_literals (v : Ast.expr) = let rec go (v : Ast.expr) = match v.Ast.e with | Ast.Float _ -> [ (Types.Float (float_default ()), v.Ast.loc) ] | Ast.Int n when Int64.compare n (Int64.of_int32 Int32.max_int) > 0 || Int64.compare n (Int64.of_int32 Int32.min_int) < 0 -> [ (Types.Int Types.I64, v.Ast.loc) ] | Ast.Call ({ Ast.e = Ast.Var ("+" | "-" | "*" | "/" | "%" | "min" | "max"); _ }, args) -> List.concat_map go args | _ -> [] in go v (* [v] stored into the literal local [key] (a [set] or a [recur]), while recording: the literal locals it is arithmetic over are merged with [key], and each other operand says, on its own terms, what it brings ([Down]) — never the guess the round happens to have. Then [v] is checked at [key]'s guess, quietly, since a want there is the guess and says nothing. *) and lit_down ctx key pty (v : Ast.expr) = let s = Option.get ctx.lits in let quietly f = let was = !lit_quiet in lit_quiet := true; Fun.protect ~finally:(fun () -> lit_quiet := was) f in let vars, others = lit_parts ctx v in List.iter (lit_union s key) vars; List.iter (fun (t, l) -> lit_add s key (Hint, t, l)) (lit_wide_literals v); List.iter (fun (o : Ast.expr) -> match trial ctx (fun () -> check ctx o) with | Ok e -> lit_add s key (Down, e.Tast.ty, o.Ast.loc) | Error _ -> ()) others; match trial ctx (fun () -> quietly (fun () -> check ctx ~want:pty v)) with | Ok e -> e | Error _ -> s.dirty <- true; quietly (fun () -> check ctx v) (* The type a literal initialiser is checked at while a session is open — its current guess, or the decision — numbering it while recording. [None] for anything that is not a literal, or with no session open. *) and lit_local ctx name (e : Ast.expr) = match ctx.lits, lit_kind e with | Some s, Some kind -> if s.recording && not (Phys.mem s.ids e) then begin Phys.replace s.ids e s.count; s.count <- s.count + 1; s.keys <- (e, name) :: s.keys end; Some (lit_guess ~subst:ctx.env.subst s e kind) | _ -> None (* A literal local's initialiser, at the type [lit_local] gave it: [Unit] is a text or bracket literal's typed reading ([lit_default]). *) and lit_init ctx t (e : Ast.expr) = if Types.equal t Types.Unit then with_typed_literals (fun () -> check ctx e) else check ctx ~want:t e (* [run] is a [let] or a [loop] with some of [inits] literals, and the outermost such form of this function: the session opens here. See [lit_session]. *) and with_lits : 'a. ctx -> Loc.t -> Ast.expr list -> (unit -> 'a) -> 'a = fun ctx loc inits run -> if ctx.lits <> None || not (List.exists (fun e -> lit_kind e <> None) inits) then run () else begin let s = { decided = Phys.create 16; recording = false; ids = Phys.create 16; keys = []; count = 0; parent = Hashtbl.create 16; cons = Hashtbl.create 16; dirty = false } in ctx.lits <- Some s; incr lit_depth; let remember () = let subst = ctx.env.subst in List.iter (fun (k, _) -> let kind = Option.value (lit_kind k) ~default:`Int in let t = lit_guess ~subst s k kind in let others = Option.value (Phys.find_opt lit_memo k) ~default:[] |> List.filter (fun (sb, _) -> sb != subst) in Phys.replace lit_memo k ((subst, t) :: others)) s.keys in Fun.protect ~finally:(fun () -> ctx.lits <- None; decr lit_depth; if !lit_depth = 0 then Phys.reset lit_memo) @@ fun () -> let unsettled = Loc.diag ~kind:"check/lit-unsettled" loc "unsettled" in (* The decisions the uses recorded so far make, written into [s.decided], and the locals whose decision moved. *) let settle () = let solved = lit_solve s in let moved = ref [] in List.iter (fun (k, name, r) -> match r with | Ok t -> let kind = Option.value (lit_kind k) ~default:`Int in if not (Types.equal t (lit_guess ~subst:ctx.env.subst s k kind)) then begin moved := (k, name, t) :: !moved; Phys.replace s.decided k t end | Error _ -> ()) solved; (solved, List.rev !moved) in let conflict solved = List.find_map (fun (k, name, r) -> match r with Error e -> Some (k, name, e) | Ok _ -> None) solved in let log () = if lit_has "log" then Phys.iter (fun k t -> let d = lit_default k (Option.value (lit_kind k) ~default:`Int) in if not (Types.equal t d) then Printf.eprintf "LITINF %s:%d:%d %s -> %s\n" k.Ast.loc.Loc.file k.Ast.loc.Loc.line k.Ast.loc.Loc.col (tyname loc d) (tyname loc t)) s.decided in let rec round n = Phys.reset s.ids; s.keys <- []; s.count <- 0; Hashtbl.reset s.parent; Hashtbl.reset s.cons; s.dirty <- false; s.recording <- true; incr lit_recording; (* A ref, because [trial] is monomorphic inside this recursive group. *) let answer = ref None in (* What the settle inside the trial found, which has already written its decisions: settling again outside would see nothing move. *) let settled = ref None in let outcome = Fun.protect ~finally:(fun () -> decr lit_recording; s.recording <- false) (fun () -> trial ctx (fun () -> let r = run () in let solved, moved = settle () in settled := Some (solved, moved); (* The guesses held: this check is the answer. *) if moved <> [] || s.dirty || conflict solved <> None then raise (Loc.Error unsettled); answer := Some r; poison loc)) in match outcome, !answer with | Ok _, Some r -> log (); remember (); r | _ -> let solved, moved = match !settled with Some sm -> sm | None -> settle () in (match conflict solved with | Some (k, name, ((t1, l1), (t2, l2))) -> lit_conflict k name t1 l1 t2 l2 | None -> ()); if moved <> [] && n < lit_rounds then round (n + 1) else if moved <> [] then begin (* Still moving: a local fed through more calls than the rounds follow. It is the local that needs its type written. *) let k, name, t = List.hd moved in lit_unsettled k name t end else begin (* Nothing left to learn: checked for real, so a refusal is the ordinary one and a whole-file check goes on past it. *) log (); remember (); run () end in round 1 end (* A literal local whose uses kept changing its type past [lit_rounds]. *) and lit_unsettled (k : Ast.expr) name t = let lit = lit_spelling k in let fix = if fln_source k.Ast.loc then Printf.sprintf "let %s: %s = %s" name (tyname k.Ast.loc t) lit else Printf.sprintf "(%s %s)" (tyname k.Ast.loc t) lit in Loc.failk "check/literal-unsettled" k.Ast.loc "the type of %s depends on too long a chain of the values stored into it \ to be read off them. Write the type it should have: %s" name fix and lit_spelling (k : Ast.expr) = let lit = match k.Ast.e with | Ast.Int n -> Int64.to_string n | Ast.Float x -> Printf.sprintf "%g" x | Ast.Byte b -> Printf.sprintf "\\%c" (Char.chr b) | Ast.Call (_, [ { Ast.e = Ast.Int n; _ } ]) -> Int64.to_string (Int64.neg n) | Ast.Call (_, [ { Ast.e = Ast.Float x; _ } ]) -> Printf.sprintf "%g" (-.x) | _ -> "..." in let whole = lit <> "" && String.for_all (fun c -> (c >= '0' && c <= '9') || c = '-') lit in if whole && lit_kind k = Some `Float then lit ^ ".0" else lit (* Two uses of a literal local that no one type satisfies. *) and lit_conflict (k : Ast.expr) name t1 l1 t2 l2 = let lit = match k.Ast.e with | Ast.Int n -> Int64.to_string n | Ast.Float x -> Printf.sprintf "%g" x | Ast.Byte b -> Printf.sprintf "\\%c" (Char.chr b) | Ast.Call (_, [ { Ast.e = Ast.Int n; _ } ]) -> Int64.to_string (Int64.neg n) | Ast.Call (_, [ { Ast.e = Ast.Float x; _ } ]) -> Printf.sprintf "%g" (-.x) | _ -> "..." in (* %g drops the point from a whole float; put it back so the fix reads as a float literal. 1e+20 already does. *) let whole = lit <> "" && String.for_all (fun c -> (c >= '0' && c <= '9') || c = '-') lit in let lit = if whole && lit_kind k = Some `Float then lit ^ ".0" else lit in let fix = if fln_source k.Ast.loc then Printf.sprintf "let %s: %s = %s" name (tyname l1 t1) lit else Printf.sprintf "(%s %s)" (tyname l1 t1) lit in Loc.failk "check/literal-uses" k.Ast.loc ~notes:[ Loc.note l1 (Printf.sprintf "%s is used as %s here" name (tyname l1 t1)); Loc.note l2 (Printf.sprintf "and as %s here" (tyname l2 t2)) ] "%s is used as %s and as %s, and %s can have only one type. Write the \ one it should have: %s" name (tyname l1 t1) (tyname l2 t2) lit fix and check_let ctx ?(tail = false) ?(used = false) ?want ?(defer_ok = false) loc bs body = with_lits ctx loc (List.filter_map (fun (b : Ast.binding) -> if b.Ast.bty = None then Some b.Ast.bval else None) bs) @@ fun () -> scoped ctx (fun () -> let bs = map_lr (fun (b : Ast.binding) -> let want = Option.map (resolve ctx.env) b.Ast.bty in let lit = if b.Ast.bty = None then lit_local ctx b.Ast.bname b.Ast.bval else None in ctx.used <- true; let v = match lit with | Some t -> lit_init ctx t b.Ast.bval | None -> check ctx ?want b.Ast.bval in (match v.Tast.ty with (* A refused initialiser, already reported: the name is bound to the poison so that what follows is still checked. *) | Types.Never when is_poison v -> () | Types.Unit | Types.Never -> fail b.Ast.bloc "%s would be bound to %s, which is not a value" b.Ast.bname (tyname loc v.Tast.ty) | _ -> ()); (* Locals are assignable places; parameters are not. *) let slot = bind ctx b.Ast.bname v.Tast.ty ~assignable:true ?lit:(Option.map (fun _ -> b.Ast.bval) lit) in (slot, v)) bs in (* After the bindings, because checking each of them withdrew it. *) ctx.tail <- tail; ctx.used <- used; let body = block ctx ?want ~defer_ok loc body in mk loc body.Tast.ty (Tast.Let (bs, [ body ]))) (* (dotimes [i n] body...) is a counting loop, not a new IR node: bind [i] to 0 and the bound to a hidden slot — [n] is evaluated once, before the loop, so a body that changes it cannot change the trip count — then step [i] at the end of the body. [i] is not assignable, so the step below is the only writer. *) (* What a loop still contributes to checking after the repeal is scoping, not ownership: the entry below is what [break] and [continue] resolve against, and the defer_block name is what makes a [defer] in here refused as "a loop body" — it would fire once at function exit rather than once per iteration, and the message says so. [fresh] and the iteration move-diff that used it are gone with the flow analysis. *) and in_loop ctx ?label ?entry f = (* The loop goes on the stack before the body is checked and comes off after, so a [break] inside it can see it and one outside it cannot. *) let loops = ctx.loops in ctx.loops <- (match entry with Some e -> e | None -> Lloop label) :: loops; let blocker = ctx.defer_block in ctx.defer_block <- "a loop body"; let r = f () in ctx.defer_block <- blocker; ctx.loops <- loops; r (* Which loop a [break] or a [continue] means, as a count of loops outwards from the innermost — which is what [Tast.Break] carries and what [emit] indexes. Refuses three things, each by its own reason: nothing to break out of, a label naming no loop this form is inside, and a jump that would cross a barrier. *) and loop_target ctx loc verb label = let rec go depth = function | [] -> (match label with | None -> fail loc "%s is only allowed inside a loop" verb | Some l -> fail loc "no loop named :%s encloses this %s — a label names one of the \ loops this form is written inside" l verb) | Lloop name :: rest -> (match label with | None -> depth | Some l when name = Some l -> depth | Some _ -> go (depth + 1) rest) (* A [loop] answers with the value of its body. A jump out of one would have to produce that value from somewhere and there is nowhere, so it is a barrier like the others, named as what it is. A [while] written inside a loop sits below this entry and keeps its own break. *) | Lrecur _ :: _ -> (match label with | None -> fail loc "%s cannot leave a (loop ...), and that is the nearest loop. \ Answer with the value, or use a while" verb | Some l -> fail loc "%s :%s would leave a (loop ...), and it may not. Answer with the \ value, or use a while" verb l) | Lbarrier what :: rest -> (* Crossing it would skip whatever the construct does on the way out — the handler or restart frames it pushed, or, for a defer, would jump to a loop that is not there on the path the forms were copied into. A loop nested inside the construct is below this entry and is never reached here, which is the whole point of the rule being relative. *) ignore rest; (match label with | None -> fail loc "%s cannot leave %s, and the nearest loop is outside it. Write the \ loop inside %s, or leave with a value and test that after" verb what what | Some l -> fail loc "%s :%s would leave %s, and it may not. Name a loop inside %s" verb l what what) in go 0 ctx.loops (* [(dotimes [i n] ...)], [(dotimes [i start stop] ...)] and [(dotimes [i start stop step] ...)]. **The convention.** [stop] is exclusive, so [(dotimes [i 0 n] ...)] is the same loop as [(dotimes [i n] ...)] — one rule rather than two, and the shorter form stays the longer one with its defaults left off. A negative step counts down and tests with [>] instead of [<], which is what makes [(dotimes [i 9 -1 -1] ...)] run 9 down to 0. **Each bound once, before the loop.** [start] is the counter's initial value, [stop] and a non-literal [step] each get a hidden slot, and all three are checked — and therefore evaluated — left to right, outside the counter's scope. A body that assigns to what they were computed from cannot change the trip count. **The sign of the step.** When it is a literal the direction is known here and the condition is the one comparison it always was, so nothing changed for every loop anyone has written. A literal 0 is refused: it is an infinite loop spelled as an accident. A step that is only known at run time gets a condition that asks the sign first, and the cost lands on exactly the loops that need it. A run-time 0 falls out of that test as a loop that runs no times at all — neither arm of the sign test holds — which is deterministic and terminating, the two things an accidental hang is not. *) and check_dotimes ctx ~want loc label name (b : Ast.bounds) body = (* Left to right, and all three before the counter is bound: they are evaluated before it exists, so [(dotimes [i i (* outer i *)] ...)] reads the outer name and the order a counter function sees is the written one. *) let start = Option.map (fun e -> check ctx ~want:index_ty e) b.Ast.dstart in let stop = check ctx ~want:index_ty b.Ast.dstop in let step = Option.map (fun e -> check ctx ~want:index_ty e) b.Ast.dstep in let int k = mk loc index_ty (Tast.Int (k, Types.I32)) in (* A literal step, if that is what was written. The default is 1, which is a literal too, so the one-bound form takes this path and emits exactly what it has always emitted. *) let literal = match step with | None -> Some 1L | Some { Tast.e = Tast.Int (k, _); _ } -> Some k | Some _ -> None in (match literal, step with | Some 0L, Some s -> fail s.Tast.loc "a step of 0 never moves the counter. Give it a step that moves, as \ in (dotimes [i 0 10 2] ...); left out, the step is 1" | _ -> ()); scoped ctx (fun () -> let i = bind ctx name index_ty ~assignable:false in let limit = fresh_slot ctx index_ty in (* A slot only when the step is not a literal: a literal needs no slot to be evaluated once, and the one-bound form's frame keeps the shape it had. *) let stepslot = match literal with None -> Some (fresh_slot ctx index_ty) | Some _ -> None in let body = in_loop ctx ?label (fun () -> map_lr (fun b -> check ctx b) body) in let iv = mk loc index_ty (Tast.Local i) in let limitv = mk loc index_ty (Tast.Local limit) in let stepv = match literal, stepslot with | Some k, _ -> int k | None, Some s -> mk loc index_ty (Tast.Local s) | None, None -> assert false in let cmp op = mk loc Types.Bool (Tast.Prim (op, [ iv; limitv ])) in let cond = match literal with | Some k when k > 0L -> cmp Tast.Lt | Some _ -> cmp Tast.Gt | None -> (* Both directions, asked in the order that leaves 0 with neither: the counter has not passed the stop *and* the step is going that way. Written as nested [If]s because that is what [and] and [or] already become, so nothing new reaches a backend. *) let sign op = mk loc Types.Bool (Tast.Prim (op, [ stepv; int 0L ])) in mk loc Types.Bool (Tast.If (sign Tast.Gt, cmp Tast.Lt, mk loc Types.Bool (Tast.If (sign Tast.Lt, cmp Tast.Gt, mk loc Types.Bool (Tast.Bool false))))) in let advance = mk loc Types.Unit (Tast.Set (Tast.Plocal i, mk loc index_ty (Tast.Prim (Tast.Add, [ iv; stepv ])))) in (* The step is the *latch* and not the last form of the body. Folded onto the body it would be skipped by a [continue], which branches past the rest of the body — so [i] would never advance and the loop would hang. That is the whole reason [Tast.While] carries a third list. *) let loop = mk loc Types.Unit (Tast.While (cond, body, [ advance ])) in let binds = (i, match start with Some s -> s | None -> int 0L) :: (limit, stop) :: (match stepslot, step with | Some s, Some v -> [ (s, v) ] | _ -> []) in expect ctx loc ~want (mk loc Types.Unit (Tast.Let (binds, [ loop ])))) (* ── (loop [...] ...) and (recur ...) ─────────────────────────────────── A loop is a [let] over its names, a [While] whose condition is [true], and two jumps: [recur] rebinds every name and continues, and falling off the end of the body breaks. Nothing new reaches the backend, which is the whole argument for [recur] over tail calls — the machinery is the one [while] and the labelled [break]/[continue] already needed. **The value.** A loop answers with the value of its body, so the result is written into a slot of its own on the way out and read after the loop. A body that is [Unit] needs no slot, and a body that is [Never] — one that only ever recurs or returns — needs neither a slot nor the break, because nothing falls off the end of it. **Why [Set] of a [Never] body is safe.** [emit] closes a block at its terminator and drops what follows ([ins] checks [f.live]), so when the body ends in a jump the store is simply never written. The one ordering that matters is inside [Tast.Set]: the place is resolved before the value, and a local's place is an address with no instruction behind it. **Why the invented [While] may carry jumps.** [tast.ml] says a [While] the checker invents contains none, because the depths it would carry were minted against a stack it is not on. This one is different and the difference is the licence: it is pushed on [ctx.loops] like any other, so the [Break 0] below and every [continue] a [recur] mints count from the same stack [emit] indexes. *) and check_loop ctx ?want loc bs body = with_lits ctx loc (List.map snd bs) @@ fun () -> scoped ctx (fun () -> (* Each initial value is evaluated once, before the loop, exactly as a [let]'s is and as [dotimes]'s bound is — and bound before the next is checked, as a [let]'s is, so a later initialiser sees an earlier name. *) let binds = map_lr (fun (n, v0) -> let lit = lit_local ctx n v0 in let v = match lit with Some t -> lit_init ctx t v0 | None -> check ctx v0 in (match v.Tast.ty with (* A refused initialiser, already reported: the name is bound to the poison so that what follows is still checked. *) | Types.Never when is_poison v -> () | Types.Unit | Types.Never -> fail v.Tast.loc "%s would be bound to %s, which is not a value" n (tyname loc v.Tast.ty) | _ -> ()); (bind ctx n v.Tast.ty ~assignable:true ?lit:(Option.map (fun _ -> v0) lit), v)) bs in let names = List.map (fun (slot, v) -> (slot, v.Tast.ty)) binds in (* The singleton is [in_loop]'s doing: it sits in this recursive group and is therefore monomorphic, and every other caller hands it a list. *) let tbody = match in_loop ctx ~entry:(Lrecur names) (fun () -> [ scoped ctx (fun () -> (* The body's last form is the loop's tail, which is the only place a [recur] may stand. [block] distributes it. *) ctx.tail <- true; block ctx ?want loc body) ]) with | [ b ] -> b | _ -> assert false in let ty = tbody.Tast.ty in let yes = mk loc Types.Bool (Tast.Bool true) in let leave = mk loc Types.Never (Tast.Break 0) in let inner, result = if ty = Types.Never then ([ tbody ], None) else if ty = Types.Unit then ([ tbody; leave ], None) else let r = fresh_slot ctx ty in ([ mk loc Types.Unit (Tast.Set (Tast.Plocal r, tbody)); leave ], Some r) in let loop = mk loc Types.Unit (Tast.While (yes, inner, [])) in match result with | None -> expect ctx loc ~want (mk loc ty (Tast.Let (binds, [ loop ]))) | Some r -> expect ctx loc ~want (mk loc ty (Tast.Let (binds @ [ (r, mk loc ty (Tast.Zero ty)) ], [ loop; mk loc ty (Tast.Local r) ])))) (* Which loop a [recur] means, and what it has to rebind. The same walk [break] and [continue] make, over the same stack and refusing on the same barriers — [recur] asks "may this jump cross that" and gets the answer that was already settled, not a second mechanism. *) and recur_target ctx loc = let rec go depth = function | [] -> fail loc "recur is only allowed inside a (loop ...) — write the repetition as \ a loop with a recur in its tail" | Lrecur names :: _ -> (depth, names) (* Unreachable while the tail rule holds — a loop body is not a tail position, so no [recur] is ever written inside one — but the depth is counted rather than assumed, because it is what [emit] indexes. *) | Lloop _ :: rest -> go (depth + 1) rest | Lbarrier what :: _ -> fail loc "recur would leave %s, and it may not. Write the loop inside %s" what what in go 0 ctx.loops and check_recur ctx ~tail loc args = let depth, names = recur_target ctx loc in (* Checked, which is the whole of why this is better than a silent TCO: a recur that is not in tail position is a compile error here, where under tail calls it would have been a stack overflow at run time. *) if not tail then fail loc "recur must be in the tail position of its loop — the last thing the \ body does, or the last thing in an if, match or let arm that is itself \ in the tail. Something here would still run afterwards"; let want = List.length names and got = List.length args in if want <> got then fail loc "this loop binds %d name%s and this recur passes %d" want (if want = 1 then "" else "s") got; let vals = List.map2 (fun a (slot, ty) -> match List.find_opt (fun (_, (b : binding)) -> b.slot = slot) ctx.scope with | Some (_, { blit = Some key; _ }) when (match ctx.lits with Some s -> s.recording | None -> false) -> lit_down ctx key ty a | _ -> check ctx ~want:ty a) args names in (* Every name is rebound at once. The new values go into temporaries first, so that (recur y x) swaps rather than writing y over x and then reading it back — the same reason Clojure's recur is simultaneous. *) let temps = List.map2 (fun v (_, ty) -> (fresh_slot ctx ty, v)) vals names in let sets = List.map2 (fun (t, _) (slot, ty) -> mk loc Types.Unit (Tast.Set (Tast.Plocal slot, mk loc ty (Tast.Local t)))) temps names in mk loc Types.Never (Tast.Let (temps, sets @ [ mk loc Types.Never (Tast.Continue depth) ])) (* Every boolean-position test in the language funnels through here: [if]'s own condition, [while]'s, and [not]'s argument. ([when] and [cond] are sugar built out of [Ast.If] in parse.ml, so they get this for free without a separate case. [and] and [or] are sugar too, and both their tests and their answers get this for free the same way — see [shortcircuit] in parse.ml, where each binds its test to a temp and answers that temp on the path it decides, so the deciding operand itself comes back rather than a bare bool.) A dyn scrutinee is tested for truthiness, Clojure's rule: nil and false are the only falsey values, and everything else — 0, "", an empty vec, an empty map, a keyword — is truthy. A typed scrutinee stays strictly bool, exactly as before. The scrutinee is checked with no expectation first so its own type decides which rule applies. That is fine for the passing cases — dyn, or already bool — but a *refused* one has to be re-checked with the old [want:Bool] rather than reported from here, and that covers two shapes of "asked the wrong question first": a bare integer or float literal answers differently to "what type is this" than to "is this a bool" (check.ml's int_literal/float arms only give the nicer answer, "expected bool, found the integer literal 5", when asked the second way), and [None] does not even have an answer to the first question — "nothing here says what None is an Option of" — where the second gets straight to "expected bool, found None". Asking the first way first is what makes the dyn case work, so the refusal path — success or exception both — asks the second way again, after the fact, purely to get the sentence a typed if has always given. [loc] comes from [c] itself, not from the caller's [if]/[while]/[not] — the built-in rt call and cast have to sit at the condition's own position or an --x86 disassembly and the dev inspector point at the wrong column when the two differ (an [if] whose test is not its first token). The [exception Loc.Error _] arm swallows a rejection from arbitrary depth inside [c] and re-runs the whole of [check ctx c] a second time, which is sound only because every one of [ctx]'s save-restore sites — [barrier], and the [in_frames]/[in_defer]/[loops]/[scope] plumbing [check] itself uses — is not exception-safe: a failure mid-walk can leave one of those pushed without its pop. Today that is harmless, because the second call always either succeeds outright or raises again and this function's own caller then aborts the compile — nothing downstream ever reads [ctx] again on that path. It would stop being harmless the day some later want-sensitive elaboration on this path can *succeed* by yielding a concrete [Bool] on retry rather than failing a second time: then the first, swallowed pass's half-restored state and any name or slot it registered before raising would both still be live. That same retry-on-failure is also, deliberately, not made cheaper by only retrying at the leaf that actually needs a nicer message (an int or float literal, or [None]) and re-raising everywhere else: the shorter path was tried and shelved, because "everywhere else" is not safe to generalise past [not]'s one level of nesting — a condition that is itself a compound form carrying its own literals arbitrarily deep (an [if] or [let] standing where a condition is expected) would need [want] threaded through exactly as far as this function's own second call already threads it, and stopping short changes which of *those* literals gets the nicer message, not just the speed. The cost that buys is real: nested [not] on a program that does not type-check re-runs this whole function once per level of nesting inside the level above it, which would be exponential in how deep the nesting goes. What keeps it linear is [truthy_failed]: a condition this function has already refused, in the same body, is refused again with the same diagnostic rather than re-checked, so a retry re-walks its subtree once and stops at the first condition below it that was settled. The message is the one the first pass produced, so no message changes. Keywords are a separate, deliberate loss rather than a bug: a bare [:kw] used to be checked here with [want:Types.Bool] from the start, so it hit the keyword arm's [Some other] case and refused by name — "is an enum member where an enum is expected and a dyn keyword elsewhere, but bool is expected here". Checking it here with no expectation first, as every other scrutinee now is, resolves it as the dyn keyword instead (there being no enum in play), and dyn keywords are unconditionally truthy — so [(if :kw a b)] now takes [a], where it used to refuse outright. The author's call: lispy truthiness wins wherever it can, so this refusal is given up on purpose and not special-cased back in; test_flan.ml pins the new answer down so it is not lost again by accident. *) and check_truthy ctx c = (* Only where a refusal is raised: while recovering, one is recorded where it happens and the check goes on, so a replayed one would hide others. *) if ctx.env.recovering && ctx.env.speculating = 0 then check_truthy_once ctx c else match List.find_opt (fun (n, sc, r, _) -> n == c && r == ctx.ret && same_scope sc ctx.scope) !truthy_failed with | Some (_, _, _, d) -> raise (Loc.Error d) | None -> let scope = ctx.scope in incr truthy_depth; Fun.protect ~finally:(fun () -> decr truthy_depth; if !truthy_depth = 0 then truthy_failed := []) (fun () -> try check_truthy_once ctx c with Loc.Error d as ex -> if !lit_recording = 0 then truthy_failed := (c, scope, ctx.ret, d) :: !truthy_failed; raise ex) and check_truthy_once ctx c = let loc = c.Ast.loc in (* Speculative, because a refusal here is answered by asking again at [bool]; and that second ask is guarded, because its refusal is re-worded below. Recovery sees each refusal once, in its final words. *) match speculate ctx.env (fun () -> check ctx c) with | c0 when c0.Tast.ty = Types.Dyn -> widen loc Types.Bool (rt loc (Types.Int Types.I32) "flan_dyn_truthy" [ c0 ]) | c0 when Types.fits ~expected:Types.Bool ~actual:c0.Tast.ty -> c0 | c0 -> (* Re-checked at [bool] first, and the answer is kept only when it is a message that knows something this one does not: a literal names itself ("found the integer literal 1"), and [None] names itself, and both of those point at the mistake better than a type name would. What comes back as the *generic* mismatch — "expected bool, found i32", which is true and tells a reader nothing they did not have — is the one replaced below. The rule, rather than the fact. [expected bool, found i32] is true and says nothing a reader did not already know; what they do not know is that this language has exactly two things a condition may be, and that the dyn one is not the typed one. A dyn condition is Clojure's — nil and false are false and 0 is true — so a message that told somebody to compare against zero *in general* would be wrong about half the language. It is said only of the typed side, which is where they are. The comparison is spelled with the condition's own name where there is one, because [(!= x 0)] is a thing to type and [(!= … 0)] is not. Anything more complicated than a name gets the operator and no template: a reconstructed expression would be a guess at code the reader can see for themselves. *) (ctx.env.guard_next <- true; match check ctx ~want:Types.Bool c with | c1 -> c1 | exception Loc.Error d when not (String.equal d.Loc.kind "check/type-mismatch") -> refuse_or_poison ctx.env loc d | exception Loc.Error _ -> let how = let zero = match c0.Tast.ty with Types.Float _ -> "0.0" | _ -> "0" in let comparable = match c0.Tast.ty with Types.Int _ | Types.Float _ -> true | _ -> false in match c.Ast.e, comparable with | Ast.Var n, true -> Printf.sprintf " — test it, as (!= %s %s)" n zero | _, true -> Printf.sprintf " — test it against %s with !=" zero | _ -> "" in (try Loc.failk "check/condition-not-bool" loc "a condition is a bool or a dyn, and this is %s%s" (tyname loc c0.Tast.ty) how with Loc.Error d -> refuse_or_poison ctx.env loc d)) | exception Loc.Error _ -> check ctx ~want:Types.Bool c and check_if ctx ?(tail = false) ?(used = false) ?want loc c t e = if ctx.env.recovering && ctx.env.speculating = 0 then check_if_once ctx ~tail ~used ?want loc c t e else match List.find_opt (fun (n, (sc, r), w, _) -> n == c && r == ctx.ret && w = (want, used) && same_scope sc ctx.scope) (Hashtbl.find_all if_failed c.Ast.loc) with | Some (_, _, _, d) -> raise (Loc.Error d) | None -> let scope = ctx.scope in incr if_depth; Fun.protect ~finally:(fun () -> decr if_depth; if !if_depth = 0 then Hashtbl.reset if_failed) (fun () -> try check_if_once ctx ~tail ~used ?want loc c t e with Loc.Error d as ex -> if !lit_recording = 0 then Hashtbl.add if_failed c.Ast.loc (c, (scope, ctx.ret), (want, used), d); raise ex) and check_if_once ctx ~tail ~used ?want loc c t e = if as_binds c = [] then check_if_tested ctx ~tail ~used ?want loc c t e else scoped ctx (fun () -> check_if_tested ctx ~tail ~used ?want loc c t e) and check_if_tested ctx ~tail ~used ?want loc c t e = let t = match narrows c with | [] -> t | names -> { t with Ast.e = Ast.Narrow (names, t) } in let c, t = match as_binds c with | [] -> (check_truthy ctx c, t) | _ -> (* What an [as] named reaches the block through a name no reader can write, bound in the scope this if was given; the else is checked without it. *) let cv, named = as_cond ctx c in (cv, { t with Ast.e = Ast.Alias (named, t) }) in (* Both arms are the tail, and a one-armed [if] counts: [(when c (recur ...))] is how nearly every loop is written, and the branch is still the last thing the body does. Both arms are kept when the [if] is. *) let in_tail f = ctx.tail <- tail; ctx.used <- used; f () in match e with | None -> check_when ctx ~used ?want loc c (fun ?want () -> branch ctx (fun () -> in_tail (fun () -> check ctx ?want t))) (* A kept chain whose last else is missing — a [cond] with no [:else], whose fallthrough is [(do)], or an [if] whose else is a [when] — is one [when] spread over several tests: an Option, [None] when no test holds, and [Some] of the arm that ran. *) | Some e when kept_open ~used want e -> (match e.Ast.e with | Ast.Do [] -> check_when ctx ~used:true ?want loc c (fun ?want () -> branch ctx (fun () -> in_tail (fun () -> check ctx ?want t))) | _ -> let tw = match want with | Some (Types.Option i) -> Some i | Some Types.Dyn -> Some Types.Dyn | _ -> None in let arm w = branch ctx (fun () -> in_tail (fun () -> check ctx ?want:w t)) in (* At an Option want the arm is asked the payload first, and the chain wraps it; refused there, it is asked the Option itself, which it then is (decision 140). So a T?? wanted of a T? arm is Some of it, and the chain's own None stays the outer one. *) let t, at_payload = match want with | Some (Types.Option _) -> (match trial ctx (fun () -> arm tw) with | Ok t -> t, true | Error d -> (match trial ctx (fun () -> arm want) with | Ok t -> t, false | Error _ -> raise (Loc.Error d))) | _ -> arm tw, false in let rest ~used ?want () = branch ctx (fun () -> ctx.tail <- tail; ctx.used <- used; check ctx ?want e) in match t.Tast.ty with | ty when at_payload && not (Types.equal ty Types.Never) -> let oty = Option.get want in let e = rest ~used:true ~want:oty () in mk loc oty (Tast.If (c, mk loc oty (Tast.Some_ t), e)) | Types.Unit -> expect ctx loc ~want (mk loc Types.Unit (Tast.If (c, t, rest ~used:false ()))) | Types.Never -> let e = rest ~used:true ?want () in mk loc e.Tast.ty (Tast.If (c, t, e)) | Types.Dyn -> let e = rest ~used:true ~want:Types.Dyn () in expect ctx loc ~want (mk loc Types.Dyn (Tast.If (c, t, e))) (* An arm that is already an Option is the chain's value as it is, and [None] when no test holds — one level flattened (decision 140): an arm's None and no arm running are one answer. *) | Types.Option _ as o -> let e = rest ~used:true ~want:o () in expect ctx loc ~want (mk loc o (Tast.If (c, t, e))) | ty -> let oty = Types.Option ty in let e = rest ~used:true ~want:oty () in expect ctx loc ~want (mk loc oty (Tast.If (c, mk loc oty (Tast.Some_ t), e)))) (* Two literal arms meet at the wider of their own types, as two literal elements of an array do: [(if c 1 2.5)] is an f64. *) | Some e when want = None && lone_literal t && lone_literal e && (match literal_join ctx t e with | Some j -> not (Types.equal j (Types.Int Types.I32)) | None -> false) -> let want = literal_join ctx t e in let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in let e = branch ctx (fun () -> in_tail (fun () -> check ctx ?want e)) in mk loc t.Tast.ty (Tast.If (c, t, e)) | Some e when want = None && ((adapts t && not (adapts e || is_none_lit e)) (* [if c then None else 5]: the else arm decides T, and None meets it at T? below, as the other order does. *) || (is_none_lit t && not (is_none_lit e))) && not (and_sentinel e) -> (* A literal has no type of its own until something asks, so with no expectation the other arm decides: [(if c 4000000 n)] over an i64 [n] is an i64, as [(+ 4000000 n)] is. *) let e = branch ctx (fun () -> in_tail (fun () -> check ctx e)) in let twant = if e.Tast.ty = Types.Never then None else Some e.Tast.ty in let then_at w = branch ctx (fun () -> in_tail (fun () -> check ctx ?want:w t)) in (* [None] or [Some(1)] beside a plain T: the two meet at T?, the other arm wrapped (decision 138). Tried only once the arm is refused at T, so an arm that fits T is never an Option. *) let t, e = match e.Tast.ty with | Types.Option _ | Types.Dyn | Types.Unit | Types.Never -> then_at twant, e | ety -> (match trial ctx (fun () -> then_at twant) with | Ok t -> t, e | Error _ -> let oty = Types.Option ety in (match trial ctx (fun () -> then_at (Some oty)) with | Ok t -> t, expect ctx e.Tast.loc ~want:(Some oty) e | Error _ -> then_at twant, e)) in let ty = if e.Tast.ty = Types.Never then t.Tast.ty else e.Tast.ty in mk loc ty (Tast.If (c, t, e)) | Some e -> let t = branch ctx (fun () -> in_tail (fun () -> check ctx ?want t)) in (* With no expectation the then-branch supplies one for the else-branch, unless it diverges, in which case the else-branch decides. *) (* A slice or a pointer from the then-branch is not the else-branch's want: the two may differ only in const, and they meet at the read-only one whichever side it is on — [Types.const_join]. *) let free_join = want = None && (match t.Tast.ty with Types.Slice _ | Types.Ptr _ -> true | _ -> false) in (* A bool arm and a dyn arm meet at dyn, the bool boxed — Clojure's rule, so (or false (box "s")) answers "s" rather than unboxing the string at bool and trapping. The other order already met at dyn, the then arm deciding. So after a bool then arm the else arm is checked on its own terms first, since checking it at bool is what unboxes it, and kept when it is a bool or a dyn. Anything else is abandoned and checked at bool as before, for that path's messages. A chain whose arms all fit is checked once; a refused one re-checks each level below the refusal once more, the square of its depth. *) (* The else arm at the then arm's type first, as it always was: a value that takes its type from what is asked of it — [(+ b 1)] beside an i64, [nil] beside an Option — is asked the then arm's. Only when that is refused as a mismatch is it checked on its own terms, and the two meet at [arm_join], so [(if c x32 y64)] is the i64 [(if c y64 x32)] is. A dyn opened at the then arm's type is not a meeting: the two meet at dyn, as they do the other way round. The arm is checked once each way at most, and a refusal at the then arm's type is kept ([arm_failed]) for the ifs above that check it again. *) let joined = if want <> None || free_join || t.Tast.ty = Types.Never || t.Tast.ty = Types.Bool || and_sentinel e || lone_literal e then None else let alone () = branch ctx (fun () -> in_tail (fun () -> check ctx e)) in let key = (ctx.scope, ctx.ret) in let at_then () = match List.find_opt (fun (n, (sc, r), w, _) -> n == e && r == ctx.ret && Types.equal w t.Tast.ty && same_scope sc ctx.scope) (Hashtbl.find_all arm_failed e.Ast.loc) with | Some (_, _, _, d) -> Error d | None -> match trial ctx (fun () -> branch ctx (fun () -> in_tail (fun () -> check ctx ~want:t.Tast.ty e))) with | Ok v -> Ok v | Error d -> if !lit_recording = 0 then Hashtbl.add arm_failed e.Ast.loc (e, key, t.Tast.ty, d); Error d in let meet v = match arm_join t.Tast.ty v.Tast.ty with | Some j -> Some (j, expect ctx v.Tast.loc ~want:(Some j) v) | None -> None in (* The else arm refused at T and fine at T? — [None], [Some(1)] — and the two meet at T?, the then arm wrapped (decision 138). *) let at_option () = match t.Tast.ty with | Types.Option _ | Types.Dyn | Types.Unit -> None | ty -> let oty = Types.Option ty in (match trial ctx (fun () -> branch ctx (fun () -> in_tail (fun () -> check ctx ~want:oty e))) with | Ok v when Types.equal v.Tast.ty oty -> Some (oty, v) | _ -> None) in (* Only where the arms met nowhere else, so nothing that met before meets differently: a dyn else arm still meets at dyn. *) match (match at_then () with | Ok v -> (match opened_dyn ~box:(to_dyn ctx) v with | Some box -> Some (Types.Dyn, box) | None -> Some (t.Tast.ty, v)) | Error _ when adapts e -> None | Error d -> (* A mismatch, or a dyn the then arm's type could not open: the arm on its own terms meets the then arm. Anything else refused it at the then arm's type, and that refusal is said. *) (match trial ctx (fun () -> let v = alone () in if is_mismatch d || Types.equal v.Tast.ty Types.Dyn then v else raise (Loc.Error (Loc.diag ~kind:not_kept v.Tast.loc ""))) with | Ok v -> meet v | Error own when String.equal own.Loc.kind not_kept -> None (* Refused on its own terms too, and not as a mismatch — an unknown name, say: that is the real error, and nothing is said about a type the arm was never going to have. *) | Error own when is_mismatch d && not (is_mismatch own) -> let v = alone () in (match meet v with | Some r -> Some r | None -> Some (t.Tast.ty, expect ctx v.Tast.loc ~want:(Some t.Tast.ty) v)) | Error _ -> None)) with | None -> at_option () | j -> j in match joined with | Some (j, v) -> let t = expect ctx t.Tast.loc ~want:(Some j) t in mk loc j (Tast.If (c, t, v)) | None -> let own_else = if want = None && t.Tast.ty = Types.Bool then match trial ctx (fun () -> let v = branch ctx (fun () -> in_tail (fun () -> check ctx e)) in match v.Tast.ty with | Types.Bool | Types.Dyn | Types.Never -> v | _ -> raise (Loc.Error (Loc.diag v.Tast.loc "not bool or dyn"))) with | Ok v -> Some v | Error _ -> None else None in let t = match own_else with | Some v when v.Tast.ty = Types.Dyn -> expect ctx t.Tast.loc ~want:(Some Types.Dyn) t | _ -> t in let ewant = match want with | Some _ -> want | None -> if t.Tast.ty = Types.Never || free_join then None else Some t.Tast.ty in (* [(and a b c)] is [(let [t a] (if t (let [u b] (if u c u)) t))], so the *last* operand of an [and] is the then arm and the sentinel that carries the previous operand's location is the else arm. With no expectation the then arm supplies one, the sentinel is checked against it, and the mismatch was reported at the sentinel — which is a caret on the operand before the one that is wrong. TODO.org, "and's last operand gets a misdirected caret", records three fixes for this that were rejected and one that was not: prefer the arm that is not a compiler temp when deciding which to blame. That is this. Only [and] needs it. In an [or] the chain sits in the else arm and the sentinel in the then arm, so every operand is already blamed at its own location; and with an expectation in hand both arms are checked against it rather than against each other, so nothing here runs. *) let e = match own_else with | Some v -> v | None -> let reworded = want = None && and_sentinel e in match branch ctx (fun () -> in_tail (fun () -> if reworded then ctx.env.guard_next <- true; check ctx ?want:ewant e)) with | v -> v | exception Loc.Error d when reworded && String.equal d.Loc.kind "check/type-mismatch" -> (try Loc.failk "check/shortcircuit-operand" t.Tast.loc "an and answers false or its last operand, so the two have to be \ one type — this operand is %s, and false is a bool" (tyname loc t.Tast.ty) with Loc.Error d -> refuse_or_poison ctx.env e.Ast.loc d) | exception Loc.Error d when reworded -> refuse_or_poison ctx.env e.Ast.loc d in let t, e = match free_join, Types.const_join t.Tast.ty e.Tast.ty with | true, Some j when e.Tast.ty <> Types.Never -> expect ctx t.Tast.loc ~want:(Some j) t, expect ctx e.Tast.loc ~want:(Some j) e | _ -> t, e in let ty = if t.Tast.ty = Types.Never then e.Tast.ty else if e.Tast.ty = Types.Never then t.Tast.ty else if Types.equal t.Tast.ty e.Tast.ty then t.Tast.ty else fail loc "the branches of this if have different types: %s and %s" (tyname loc t.Tast.ty) (tyname loc e.Tast.ty) in mk loc ty (Tast.If (c, t, e)) (* A one-armed [if], which [when] is. As a statement it is Unit whatever its branch evaluates to. Kept — a [let]'s value, an argument, a return, or anything else with a type wanted of it — it answers (Option T): [Some] of the branch when the test held and [None] when it did not. A branch that is already an Option is that Option, flattened one level (decision 140, Kotlin's [?.] rather than Rust's [bool::then]): [None] from the branch and a failed test are one answer. A (Option (Option T)) branch stays one. Dyn has no Option. Where a dyn is wanted, or the branch is a dyn, a false test answers nil and a true one the branch's value — one absence, as a dyn map's [get] has. A branch with no value (Unit) or none at all (Never) keeps the statement's Unit, so what is refused about binding one is refused as before. *) and check_when ctx ~used ?want loc c (branch_at : ?want:Types.t -> unit -> Tast.expr) = let stmt t = expect ctx loc ~want (mk loc Types.Unit (Tast.If (c, t, unit_at loc))) in let nil () = rt loc Types.Dyn "flan_dyn_nil" [] in let valueless (t : Tast.expr) = match t.Tast.ty with Types.Unit | Types.Never -> true | _ -> false in match want with | Some (Types.Unit | Types.Never) -> stmt (branch_at ()) | Some Types.Dyn -> let t = branch_at ~want:Types.Dyn () in mk loc Types.Dyn (Tast.If (c, t, nil ())) | Some (Types.Option inner as oty) -> (* The payload first, wrapped; refused there, the Option itself, which the branch then is (decision 140). *) let t = match trial ctx (fun () -> branch_at ~want:inner ()) with | Ok t -> if t.Tast.ty = Types.Never then t else mk loc oty (Tast.Some_ t) | Error d -> (match trial ctx (fun () -> branch_at ~want:oty ()) with | Ok t -> if t.Tast.ty = Types.Never then t else expect ctx loc ~want:(Some oty) t | Error _ -> raise (Loc.Error d)) in mk loc oty (Tast.If (c, t, mk loc oty Tast.None_)) | None when not used -> stmt (branch_at ()) | _ -> let t = branch_at () in if valueless t then stmt t else if Types.equal t.Tast.ty Types.Dyn then expect ctx loc ~want (mk loc Types.Dyn (Tast.If (c, t, nil ()))) else if (match t.Tast.ty with Types.Option _ -> true | _ -> false) then expect ctx loc ~want (mk loc t.Tast.ty (Tast.If (c, t, mk loc t.Tast.ty Tast.None_))) else let oty = Types.Option t.Tast.ty in expect ctx loc ~want (mk loc oty (Tast.If (c, mk loc oty (Tast.Some_ t), mk loc oty Tast.None_))) (* Whether a two-armed [if] is kept and its else chain ends without one — [(do)], or a one-armed [if] — so the whole chain answers an Option. *) and kept_open ~used want (e : Ast.expr) = let kept = match want with | Some (Types.Unit | Types.Never) -> false | Some _ -> true | None -> used in let rec open_ (e : Ast.expr) = match e.Ast.e with | Ast.Do [] | Ast.If (_, _, None) | Ast.IfLet (_, _, None) -> true | Ast.If (_, _, Some e') | Ast.IfLet (_, _, Some e') -> open_ e' | _ -> false in kept && open_ e (* The type two literals meet at, each at its own type — a wide integer at u64, which is the only type that holds one. *) and literal_join ctx (a : Ast.expr) (b : Ast.expr) = let own (x : Ast.expr) = match x.Ast.e with | Ast.UInt _ -> Some (Types.Int Types.U64) | _ -> probe ctx x.Ast.loc (fun () -> (check ctx x).Tast.ty) in match own a, own b with | Some x, Some y -> literal_meet x y | _ -> None (* Whether a name would reach a callee if it were called — a global function, a generic, or a local holding a function value. The three sources [named_call] itself consults, in its own order; builtins are deliberately not among them, so that [(println {.f v})] still reports what it reports today. *) and callable ctx name = Hashtbl.mem ctx.env.fns name || Hashtbl.mem ctx.env.gsigs name || (match lookup ctx name with | 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 (float_default ()) | Ast.UInt _ -> Types.Int Types.U64 | Ast.Byte b when b > 127 -> Types.Int Types.I32 | 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 (tyname loc 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 (tyname loc 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 literal_meet 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" (tyname loc (Types.Named open_key)) f.Tast.fname (tyname loc b) (tyname loc 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" (tyname loc (Types.Named open_key)) f.Tast.fname (tyname loc (subst_ty !subst f.Tast.fty)) (tyname loc 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 bare literal above: [(Cell 1 2)] is character-for-character an ordinary call and only the symbol table tells the two apart. So it is decided here, on the last arm of [named_call], which is to say *after* a local of function type, after a generic and after the global function table. Nothing can be shadowed into a struct constructor by accident, because a name is one declaration: [collect]'s [claimed] table spans every declaration kind, so a [defstruct Cell] and a [defn Cell] cannot both exist. A [(defclass point [x y])] constructor is a real [defn] that [Classes.expand] wrote before checking began, so [(point 1 2)] resolves in [env.fns] two arms above this one and never reaches here. ARITY IS EXACT, and that is the decision worth writing down. ZII is not withdrawn — it is what the designated form does, and [(Cell {.row 1})] still zeroes [.col]. What positional construction cannot do is *say* which field was left out: [(Cell 1)] reads as a Cell with one field given, and which one depends on a declaration order that the author is free to change later. A trailing field silently zeroed there is the field-reorder hazard at its worst, so a short argument list is a refusal that names the first field it did not reach, and points at the spelling that does mean "zero the rest". Odin's positional literal takes the same line. *) and positional_struct ctx ~want loc name args = if String.equal name "String" then refuse_string_inside loc; let s = Hashtbl.find ctx.env.structs name in let fields = s.Tast.fields in 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 = tyname loc (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 "%s has %d field%s and %d %s given positionally — .%s has no value. \ 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 ...})" 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)" 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 list of a call is checked against its parameters — same [map2_lr], same [~want], so an untyped literal takes the field's type and a nested bare literal (feature A above) gets an expectation here as well. The mismatch is reported at the argument, by [expect], in the words a call's argument already gets; what is added is a note saying which field that argument was, because at a positional call site the field name is the one thing the source does not show. The note is attached only to a failure raised at this argument's own location, and it says nothing about the failure — it names the position, which is true whatever went wrong there. *) let fields = map2_lr (fun (f : Tast.field) (a : Ast.expr) -> ctx.env.guard_next <- true; try check ctx ~want:f.Tast.fty a with | Loc.Error d when d.Loc.dloc = a.Ast.loc -> refuse_or_poison ctx.env a.Ast.loc (Loc.sort_notes { d with Loc.notes = d.Loc.notes @ [ Loc.note a.Ast.loc (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) fields args in expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) (* [{.f v}] with no type written in front of it, checked against whatever type the position it stands in expects. The whole of the feature is the one line that hands [kvs] to [check_struct] with the expected type's name: from there a bare literal and a named one are the same literal, checked by the same code. Duplicate fields, unknown fields, their notes and their error kinds, and ZII zero-fill for the fields left out are therefore not "the same rules" as the named form's — they are the named form's, reached through the same call. A named type is the only expectation that says anything. [Dyn] deliberately does not: braces at a dyn want are the dyn map literal ({:key value}, and [Ast.MapLit]) and always have been, and a [.field]-keyed brace was never part of that spelling. So a dyn want is refused here rather than quietly given a second meaning, and the message points at the map spelling because that is what someone at a dyn want almost certainly wanted. With no expectation at all there is nothing to infer from and the refusal names both ways out: write the type, or move the literal somewhere a type is known. *) and check_bare ctx ~want loc kvs = let written = "{" ^ String.concat " " (List.map (fun (k, _) -> "." ^ k) kvs) ^ " ...}" in match want with | Some (Types.Named n) -> check_struct ctx ~want loc n kvs | Some Types.Dyn -> Loc.failk "check/bare-struct-dyn" loc "a dyn is expected here, and %s is a struct field list, not a dyn map — \ a dyn map's keys are keywords, as {:%s value ...}" written (match kvs with (k, _) :: _ -> k | [] -> "key") | Some other -> Loc.failk "check/bare-struct-want" loc "%s is a struct field list and %s is expected here, which is not a \ struct type" written (tyname loc other) | None -> Loc.failk "check/bare-struct-untyped" loc "%s does not say which struct it builds — the fields alone do not name \ a type. Write it, as (Type %s), or put the literal where a type is \ already known: a function's return position, an argument of a call, a \ field of another literal, or a typed place being set. A let binding is \ none of those — a local takes its type from its value, so there is \ nothing there to read one off" written written (* A record-shaped literal: one form for both, because [(Name {.f v})] is the same syntax whether [Name] is a struct or a data type case, and the two differ only in what is built at the end. Deciding here rather than in the parser is what lets the decision be made against the tables, exactly. *) and check_struct ctx ~want loc name kvs = if String.equal name "String" then refuse_string_inside loc; 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 -> (match Hashtbl.find_opt ctx.env.cases name with (* The full spelling [U.C], which is how a data type value is written. Checked before the diagnostics below, since the bare-name entry in the same table is only ever a hint. *) | Some (dname, c) when String.contains name '.' -> check_case ctx ~want loc dname c kvs (* A bare case name. This was a listed bug: [(A {.x 1})] on a case of a data type reported "unknown struct A", because nothing in [env] could tell a case name from a misspelling. It can now, so it says what was meant. *) | Some (dname, c) -> fail loc "%s is a case of the data type %s, not a struct — write (%s.%s \ {.field value ...})" name dname dname c.Tast.vname | None -> if Hashtbl.mem ctx.env.datas name then fail loc "%s is a data type, so a value of it names a case — write (%s.%s \ {.field value ...}), for one of %s" name name (first_case_name ctx.env name) (case_list ctx.env name) (* [is_struct_map] (parse.ml) has two blind spots, not one: [(name {})] reads as a struct literal with no fields regardless of what [name] turns out to be, and so does [(name {.f v ...})] at ANY size — a [.field]-first map is never a dyn map argument, only ever this struct-literal shape, whatever [name] is. [(name {:a 1})] is the one that keeps [name] an ordinary call, because a keyword-keyed map is never mistaken for a struct literal. The [.field]-keyed blind spot is no longer a blind spot, and that is the argument half of the bare-literal feature. [(g {.row 2})] is a call to [g] whose one argument is a bare struct literal — the parameter is the expectation that names its type — and the only reason it arrives here wearing a struct literal's clothes is that the parser had to guess and guessed by shape. So it is handed back to [named_call] as the call it was written as, with the fields rebuilt into the [Ast.Bare] node the parser would have made had the braces stood anywhere else. Only for a name that is actually callable: an unknown name keeps the "unknown struct" report below, because a misspelled struct name is what that shape usually is. The empty braces keep their old refusal, because they are still genuinely ambiguous — [{}] is the zero-field struct literal AND the empty dyn map, with nothing in the shape to separate them — and that one does have the let-binding fix the message names. *) else if kvs <> [] && callable ctx name then named_call ctx ~want loc name [ { Ast.e = Ast.Bare kvs; loc } ] else if Hashtbl.mem ctx.env.fns name then (match kvs with | [] -> fail loc "%s is a function, not a struct — {} on its own is read as \ the zero-field struct literal, so it cannot be passed here \ as an empty map; bind it first, as (let [m {}] (%s m))" name name | _ -> fail loc "%s is a function, not a struct — {.field value ...} only \ ever builds a struct literal, never a map value, so it \ cannot be passed here as an argument; a dyn map's keys are \ keywords, as {:field value ...}" name) else Loc.failk "check/unknown-struct" loc ~notes:(declared_note ctx.env name) "unknown struct %s" name) | Some s -> let seen = given_once ~noun:"field" kvs ~known:(fun k (v : Ast.expr) -> 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" (tyname loc (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))) (* [(U {.member v})] — an untagged union value. At most one member, because the members are one storage: giving two would be writing two values over each other and the result would be whichever the compiler happened to store last. That is a real question with no answer, so it is refused rather than ordered. Giving none is the ordinary ZII value and is all-bytes-zero, the same as a struct with every field omitted. The one member is lowered here into a zeroed temporary and a store, rather than into a node of its own. A union value *is* a store into overlaid storage — [Set] over [Pfield] is exactly that operation and every backend already has it — so a [MakeUnion] node would have been the same three instructions written a fourth and fifth time, in each backend, with the layout rule spelled out again in each. Nothing downstream learns anything new from this form. *) and check_union ctx ~want loc name kvs = let u = Hashtbl.find ctx.env.unions name in List.iter (fun (k, (v : Ast.expr)) -> if Tast.field_index u k = None then Loc.failk "check/unknown-field" v.Ast.loc ~notes:(declared_note ctx.env name) "%s has no member %s" name k) kvs; (* Before the two-member refusal below, so [(U {.i 1 .i 2})] is told it named one member twice rather than that [i] and [i] are the same bytes — which is true and useless. Same helper, same note and the same [check/duplicate- field] kind as the struct path, because it is the same mistake; only the noun changes. The unknown-member refusal above stays its own full pass rather than being handed to [~known], so that [(U {.i 1 .i 1 .bad 2})] is still told about [.bad] first, as it is today. *) ignore (given_once ~noun:"member" kvs : (string, Ast.expr) Hashtbl.t); (match kvs with | (a, _) :: (b, (second : Ast.expr)) :: _ -> Loc.failk "check/union-two-members" second.Ast.loc "%s is a union, so only one member can be written — give %s or %s, not \ both" name a b | _ -> ()); match kvs with (* The two-member case left above, so this sees one or none. *) | _ :: _ :: _ -> assert false | [] -> expect ctx loc ~want (mk loc (Types.Named name) (Tast.Zero (Types.Named name))) | [ (k, v) ] -> let i = Option.get (Tast.field_index u k) in let fty = (List.nth u.Tast.fields i).Tast.fty in let v = check ctx ~want:fty v in let slot = fresh_slot ctx (Types.Named name) in let here = mk loc (Types.Named name) (Tast.Local slot) in expect ctx loc ~want (mk loc (Types.Named name) (Tast.Let ([ (slot, mk loc (Types.Named name) (Tast.Zero (Types.Named name))) ], [ mk loc Types.Unit (Tast.Set (Tast.Pfield (here, i), v)); here ]))) (* The cases of a data type, as written, for a message that has to name them. *) and case_list env dname = match Hashtbl.find_opt env.datas dname with | None -> "its cases" | Some u -> String.concat ", " (List.map (fun (c : Tast.variant) -> dname ^ "." ^ c.Tast.vname) u.Tast.cases) and first_case_name env dname = match Hashtbl.find_opt env.datas dname with | Some { Tast.cases = c :: _; _ } -> c.Tast.vname | _ -> "Case" (* [(U.C {.f v ...})]. The fields are checked and filled in exactly as a struct's are — literally so: the same [given_once] and [zii_fill], with only the index function and the name in the unknown-field message differing — and the only other difference is the node at the end and the type it carries. *) and check_case ctx ~want loc dname (c : Tast.variant) kvs = let full = dname ^ "." ^ c.Tast.vname in let seen = given_once ~noun:"field" kvs ~known:(fun k (v : Ast.expr) -> if Tast.vfield_index c k = None then Loc.failk "check/unknown-field" v.Ast.loc ~notes:(declared_note ctx.env dname) "%s has no field %s" full k) in let fields = zii_fill ctx loc seen c.Tast.vfields in expect ctx loc ~want (mk loc (Types.Named dname) (Tast.MakeCase (dname, c.Tast.vname, fields))) (* Omitted fields are zeroed — ZII, the same rule as a declaration with no initialiser (plan.org, Data model). Every field is present from here on, in declaration order, so no backend has to know about omission. [seen] is what [given_once] collected; [fields] is the declaration, and it is the declaration that fixes the order. *) and zii_fill ctx loc seen fields = map_lr (fun (f : Tast.field) -> match Hashtbl.find_opt seen f.Tast.fname with | Some v -> check ctx ~want:f.Tast.fty v | None -> mk loc f.Tast.fty (Tast.Zero f.Tast.fty)) fields and check_arr ctx ~want loc items = let elem_want = match want with | Some (Types.Array (_, t)) -> Some t | Some (Types.Slice (_, t)) -> Some t | _ -> None in match elem_want, items with | None, _ :: _ -> (match arr_elem_type ctx items with | Some t -> let n = Int64.of_int (List.length items) in expect ctx loc ~want (check_arr ctx ~want:(Some (Types.Array (n, t))) loc items) | None -> (match trial ctx (fun () -> dyn_vec ctx loc (map_lr (fun i -> check ctx ~want:Types.Dyn i) items)) with | Ok v -> expect ctx loc ~want v | Error d -> mixed_refusal ctx items d)) | _ -> let items = map_lr (fun i -> check ctx ?want:elem_want i) items in let n = Int64.of_int (List.length items) in let elem = match elem_want, items with | Some t, _ -> t | None, first :: _ -> first.Tast.ty | None, [] -> fail loc "an empty array literal needs a type — use it where one is expected, \ or name it, as in (the [0 i32] [])" in List.iter (fun (i : Tast.expr) -> if not (Types.fits ~expected:elem ~actual:i.Tast.ty) then fail i.Tast.loc "this array's elements are %s, but this one is %s" (tyname loc elem) (tyname loc i.Tast.ty)) items; (match want with | Some (Types.Array (m, _)) when not (Int64.equal m n) -> fail loc "expected %Ld elements, found %Ld" m n | _ -> ()); (* [n T] and [T] are distinct in type and in ownership (spec-memory.md), so an array literal does not satisfy a slice expectation. *) expect ctx loc ~want (mk loc (Types.Array (n, elem)) (Tast.Arr items)) (* The element type of an array literal nothing outside it names, or [None] for a dyn vector. Every element is looked at on its own terms first, by [probe], so nothing here is checked for real — [check_arr] does that once, at the answer. Elements that agree are a typed array: one type, or numbers that meet at the wider of them the way two operands of [+] do. A literal takes the others' type if it fits it, so [[(f32 1.0) 2.5]] is an [[2 f32]] and [[(u8 1) 300]] an [[2 i32]]. An element that cannot be checked without being told what it is — [None], a bare struct — takes the same type. Elements that do not agree — [[10 "Hi"]], a dyn beside anything that is not one — are a dyn vector, which is what the same brackets are where a dyn is expected. Numbers that do not agree are refused instead; see [numbers_disagree]. *) and arr_elem_type ctx (items : Ast.expr list) : Types.t option = let natural (i : Ast.expr) = match i.Ast.e with (* Refused with no want, and only a u64 holds one. *) | Ast.UInt _ -> Some (Types.Int Types.U64) | _ -> probe ctx i.Ast.loc (fun () -> (check ctx i).Tast.ty) in let fits t (i : Ast.expr) = probe ctx i.Ast.loc (fun () -> ignore (check ctx ~want:t i)) <> None in let lits, rest = List.partition lone_literal items in let typed, needs = List.partition_map (fun i -> match natural i with Some t -> Left (i, t) | None -> Right i) rest in let tys = List.filter (fun t -> t <> Types.Never) (List.map snd typed) in let lit_tys = List.filter_map natural lits in let join_with meet = function | [] -> None | t :: ts -> List.fold_left (fun acc t -> Option.bind acc (fun a -> meet a t)) (Some t) ts in let join_all = join_with Types.join in let mixed_dyn = List.mem Types.Dyn tys && (List.exists (fun t -> t <> Types.Dyn) tys || lits <> []) in let all_fit t = List.for_all (fits t) lits && List.for_all (fits t) needs in (* A candidate the literals do not all fit is widened by the ones that do not, once: [[x 2.5]] over an i32 [x] meets at f64. *) let settle = function | None -> None | Some t when all_fit t -> Some t | Some t -> let t' = List.fold_left (fun acc i -> if fits t i then acc else Option.bind acc (fun a -> Option.bind (natural i) (Types.join a))) (Some t) lits in (match t' with | Some t' when not (Types.equal t' t) && all_fit t' -> Some t' | _ -> None) in let candidates = if tys <> [] then [ join_all tys ] else join_with literal_meet lit_tys :: List.map Option.some lit_tys in if mixed_dyn then None else if tys = [] && lits = [] then (match typed, needs with | _ :: _, [] -> Some Types.Never (* Nothing here says what any of them is. The first one's own refusal is the one worth reading. *) | _, first :: _ -> ignore (check ctx first); None | [], [] -> None) else match List.fold_left (fun found c -> match found with Some _ -> found | None -> settle c) None candidates with | Some t -> Some t | None -> let numeric t = match t with Types.Int _ | Types.Float _ -> true | _ -> false in if needs = [] && List.for_all numeric (tys @ lit_tys) then numbers_disagree ctx (List.filter_map (fun i -> Option.map (fun t -> (i, t)) (natural i)) items) else None (* Numbers with no type they all meet at — an i32 beside an f32, an i64 beside a u64 — are refused rather than boxed into a dyn vector: the elements are all numbers, and which one should move is the program's to say. The fix named converts the second of the first disagreeing pair, into the float when one of the two is a float and into the first's type otherwise. *) and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a = fun ctx elems -> match elems with | [] -> fail Loc.unknown "internal: an array of numbers with no elements" | _ :: _ -> (* A literal is not one of the disagreeing types when it fits the others: each is checked at the type the rest meet at — or, with every element a literal, at the u64 a wide one needs — and the first that does not fit is the refusal, its own. *) let lit (e, _) = lone_literal e in let others = List.filter (fun p -> not (lit p)) elems in let meet = match others with | [] -> if List.exists (fun (e, _) -> match e.Ast.e with Ast.UInt _ -> true | _ -> false) elems then Some (Types.Int Types.U64) else None | (_, t) :: ts -> List.fold_left (fun acc (_, u) -> Option.bind acc (fun a -> Types.join a u)) (Some t) ts in (match meet with | Some (Types.Int _ as m) -> List.iter (fun (e, t) -> if lone_literal e && (match t with Types.Int _ -> true | _ -> false) then ignore (check ctx ~want:m e)) elems | _ -> ()); let pool = if others = [] then elems else others in let first, t1 = List.hd pool in let second, t2 = match List.find_opt (fun (_, t) -> Types.join t1 t = None) (List.tl pool) with | Some p -> p | None -> (match List.find_opt (fun (_, t) -> Types.join t1 t = None) elems with | Some p -> p | None -> List.nth elems (List.length elems - 1)) in let target, moved, moved_ty, other = match t1, t2 with | Types.Int _, Types.Float _ -> t2, first, t1, second | _ -> t1, second, t2, first in ignore ctx; let tn = tyname moved.Ast.loc target in Loc.failk "check/array-numbers-disagree" moved.Ast.loc ~notes:[ Loc.note other.Ast.loc (Printf.sprintf "this element is %s" tn) ] "this array's elements are %s and %s, and neither holds every value of \ the other — %s" (tyname moved.Ast.loc moved_ty) tn (match spell_arg "" moved with | "" -> Printf.sprintf "convert the %s element with the %s cast" (tyname moved.Ast.loc moved_ty) tn | x -> Printf.sprintf "convert one, as in (%s %s)" tn x) (* Elements that do not agree and cannot all become a dyn either: a struct beside a number, a type variable beside a literal. The dyn vector's refusal would be about dyn, which the program never mentioned, so the elements are refused against each other instead — the first one's type is what the rest are checked at, and the refusal points back at it. [d] is the answer if that finds nothing. *) and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = fun ctx items d -> (* Every check here only looks for a better sentence for [d]. *) speculate ctx.env @@ fun () -> match items with | [] -> raise (Loc.Error d) | first :: rest -> let first = check ctx first in let want = match first.Tast.ty with Types.Never -> None | t -> Some t in List.iter (fun (i : Ast.expr) -> match check ctx ?want i with | v -> (match want with | Some t when not (Types.fits ~expected:t ~actual:v.Tast.ty) -> fail i.Ast.loc "this array's elements are %s, but this one is %s" (tyname i.Ast.loc t) (tyname i.Ast.loc v.Tast.ty) | _ -> ()) | exception Loc.Error e when e.Loc.dloc = i.Ast.loc && want <> None -> raise (Loc.Error { e with Loc.notes = e.Loc.notes @ [ Loc.note first.Tast.loc (Printf.sprintf "this array's first element is %s, so every \ element is" (tyname first.Tast.loc first.Tast.ty)) ] })) rest; raise (Loc.Error d) (* A dyn vector built where it stands from elements already checked at dyn: the runtime's own vec, pushed to in order. *) and dyn_vec ctx loc (items : Tast.expr list) = let v = fresh_slot ctx Types.Dyn in let vval = mk loc Types.Dyn (Tast.Local v) in let pushes = List.map (fun x -> rt loc Types.Unit "flan_dyn_push" [ vval; x; here loc ]) items in mk loc Types.Dyn (Tast.Let ([ (v, rt loc Types.Dyn "flan_dyn_vec_new" []) ], pushes @ [ vval ])) (* ── (array-fill [r c] v) and (array-gen [r c] f) ────────────────────── TODO.org, "A value-producing array constructor". [(array 4 T)] is the zeroed array and [dotimes] is Unit, so between them there was no way to write "an array of these" as an *expression* — which is what a defonce initialiser has to be. These are that expression, at any rank. **The lowering, and why it is not an aggregate value.** [Tast.Arr] is the one the backends already have, and both build it element by element from a list that is as long as the array: an [insertvalue] chain on LLVM, a store per element on x86. A fill of [[600 800 u8]] is half a million elements and there is no list to be had. So these lower to a *loop over a slot*: bind the array to a slot, zero it, run one loop per dimension writing each element through [Tast.Set] of a [Pindex], and answer with the slot. Nothing new reaches a backend — it is [While], [Set] and [Pindex], which is the same argument [check_loop] makes for [recur] — and both backends get the form with no edit, the js one included. The value stays value-like for all that: the slot is the form's own, nothing else can name it, and the [Local] at the end is copied out exactly as any other array-typed expression is. In a [defonce] initialiser the copy is the store into the global that the startup function does; in a [let] it is the binding's own store. An in-place fill of the *destination*, skipping the temporary, would be the faster lowering and is deliberately not what this does — the destination is not a thing an expression may know about, and [mem2reg] plus the store-to-load forwarding both backends already get is where that cost goes. The slot is zeroed before the loops rather than left [Uninit]. An element type of [dyn] is the reason it has to be: between the binding and the store that overwrites it the collector may run, and it would read whatever the frame happened to hold as a dyn word. The double write is the price and it is one memset. **Row-major, pinned.** The first dimension is the outermost loop, so [[i][j]] runs with [j] fastest. A generator that prints, or counts, or appends, observes that order, so it is a promise: this is the order, not the order the nesting happened to come out in. **Evaluated once.** The fill value and the generator *value* are each bound to a slot before any loop starts, so [(array-fill [n] (next-id))] is one call and n copies of its answer — not n calls. A generator's *body*, of course, runs once per element; that is what it is for. *) (* The dimensions, resolved by the same rule the [n T] type spelling uses — [array_len] is literally that rule — with the one extra condition this form has and the type spelling does not: the fill counts in i32, because every index in the language is an i32, so a dimension that does not fit one has no loop that could reach its end. *) and array_dims ctx loc (dims : Ast.len list) = List.map (fun d -> let n = array_len ctx.env loc d in if n < 0L || Int64.compare n 2147483647L > 0 then fail loc "%Ld is not a dimension a fill can count to: an index in this \ language is an i32, and so is the loop that writes the elements" n; n) dims (* [r c] and an element type make [r [c T]], outermost first. *) and array_of_dims ns elem = List.fold_right (fun n t -> Types.Array (n, t)) ns elem (* The element type an annotation asks for, peeled one [Array] per dimension. [None] where the annotation is not an array of at least this rank: the mismatch is then [expect]'s to report against the whole type, which is the message that names both shapes rather than one of their leaves. *) and array_elem_want rank want = if rank = 0 then want else match want with | Some (Types.Array (_, t)) -> array_elem_want (rank - 1) (Some t) | _ -> None (* The shared lowering. [pre] is bound before any loop runs — that is what "evaluated once" means — and [element] is handed the index locals, in dimension order, to build the value one element takes. *) and array_build ctx loc ns elem ~pre ~element = let aty = array_of_dims ns elem in let arr = fresh_slot ctx aty in let arrv = mk loc aty (Tast.Local arr) in let islots = List.map (fun _ -> fresh_slot ctx index_ty) ns in let ivals = List.map (fun s -> mk loc index_ty (Tast.Local s)) islots in let zero = mk loc index_ty (Tast.Int (0L, Types.I32)) in let one = mk loc index_ty (Tast.Int (1L, Types.I32)) in let store = mk loc Types.Unit (Tast.Set (Tast.Pindex (arrv, ivals), element ivals)) in (* One [Let] and one [While] per dimension, the first dimension outermost. The counter is bound *inside* the enclosing loop's body so that it is re-zeroed on every pass of it, and the increment is the latch for the reason [check_dotimes] gives. These loops carry no [break] and no [continue], which is the condition [tast.ml] puts on a [While] the checker invents. *) let rec nest ns islots = match ns, islots with | [], [] -> store | n :: ns, i :: islots -> let iv = mk loc index_ty (Tast.Local i) in let limit = mk loc index_ty (Tast.Int (n, Types.I32)) in let cond = mk loc Types.Bool (Tast.Prim (Tast.Lt, [ iv; limit ])) in let step = mk loc Types.Unit (Tast.Set (Tast.Plocal i, mk loc index_ty (Tast.Prim (Tast.Add, [ iv; one ])))) in let loop = mk loc Types.Unit (Tast.While (cond, [ nest ns islots ], [ step ])) in mk loc Types.Unit (Tast.Let ([ (i, zero) ], [ loop ])) | _, _ -> fail loc "array fill: one counter per dimension" in mk loc aty (Tast.Let (pre @ [ (arr, mk loc aty (Tast.Zero aty)) ], [ nest ns islots; arrv ])) (* (the T e): [e] with [T] as its expectation, which is every conversion an annotation would make — a literal built at T, a narrower number widened — and nothing more. A dyn operand is the exception: an expectation would unbox it and trap at run time on a mismatch, and [the] is a statement about the type rather than a conversion, so it is refused and the cast named. [(the [T] [...])] asks for the literal's element type and answers the [n T] the literal is, since an array literal is never a slice. *) and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = let ty = resolve ctx.env t in (* A typed .fln lambda, [fn(c: C) -> bool => ...], reads as [(the (Fn [C] bool) (fn ...))]; where a CFn of the same signature is wanted, the literal is that CFn, as an untyped one would be. *) let ty = match ty, v.Ast.e, want with | Types.Fn (ps, r), Ast.Fn _, Some (Types.CFn (ps', r')) when List.length ps = List.length ps' && fits_shape (Types.Fn (ps', r')) (Types.Fn (ps, r)) -> (* A generic's [CFn($t) -> $t] binds [$t] from the literal's own types, as it would from any other argument's. *) Types.CFn (ps, r) | _ -> ty in let is_nil = match v.Ast.e with Ast.Var "nil" -> true | _ -> false in (* Quietly: what [v] is on its own terms is not a use of a literal local inside it — [[x]] read with no want would pin x at its guess, and the annotation's want below is the use that says what x is. *) let own_ty () = let was = !lit_quiet in lit_quiet := true; Fun.protect ~finally:(fun () -> lit_quiet := was) (fun () -> probe ctx loc (fun () -> (check ctx v).Tast.ty)) in if ty <> Types.Dyn && not is_nil && own_ty () = Some Types.Dyn (* A keyword naming one of an enum's members is that member at the enum's type, not a dyn: [let d: Dir = :north]. *) && not (match ty, v.Ast.e with Types.Enum _, Ast.Kw _ -> true | _ -> false) (* An array literal that is a dyn vector only because its elements do not agree among themselves — [[1, None]] — is built at the annotation when every element fits it, as [x: [2 i32?] = [1, None]] (decision 138). Nothing is converted: the literal is built at T. *) && not (let rec holds_option = function | Types.Option _ -> true | Types.Array (_, t) | Types.Slice (_, t) -> holds_option t | _ -> false in let rec elems_option = function | Types.Array (_, t) | Types.Slice (_, t) -> holds_option t | Types.Option t -> elems_option t | _ -> false in match v.Ast.e with | Ast.Arr _ when elems_option ty -> probe ctx loc (fun () -> ignore (check ctx ~want:ty v)) <> None | _ -> false) then begin let tn = tyname loc ty in let numeric = match ty with Types.Int _ | Types.Float _ -> true | _ -> false in (* In a .fln file the user wrote [x: T = v], not [the]. *) let fln = fln_source loc in let the_ = if fln then "a type annotation" else "the" in if numeric then fail v.Ast.loc "%s checks a value as %s and does not convert one, and this is a dyn \ — %s" the_ tn (match spell_arg "" v with | s when fln && s <> "" && not (String.exists (fun c -> c = ' ' || c = '(') s) -> Printf.sprintf "write %s(%s) to convert it" tn s | s when s = "" || fln -> Printf.sprintf "convert it with the %s cast instead" tn | s -> Printf.sprintf "write (%s %s) to convert it" tn s) else (* What a dyn does at this type is the boundary's own answer, asked of it rather than restated: some types take one where a value is passed, returned or stored, and the rest do not take one at all. *) let crosses = probe ctx loc (fun () -> ignore (expect ctx v.Ast.loc ~want:(Some ty) (check ctx v))) in match crosses with | Some () -> fail v.Ast.loc "%s checks a value as %s and does not convert one, and this is a \ dyn — a dyn becomes a %s where a %s is passed, returned or stored" the_ tn tn tn | None -> (match speculate ctx.env (fun () -> check ctx ~want:ty v) with | _ -> fail v.Ast.loc "%s checks a value as %s and does not convert one, and this is \ a dyn" the_ tn | exception Loc.Error d -> fail v.Ast.loc "%s checks a value as %s and does not convert one, and this is \ a dyn — %s" the_ tn d.Loc.dmsg) end; let r = match ty, v.Ast.e with | Types.Slice (_, elem), Ast.Arr items -> check_arr ctx ~want:(Some (Types.Array (Int64.of_int (List.length items), elem))) v.Ast.loc items | _ -> expect ctx v.Ast.loc ~want:(Some ty) (check ctx ~want:ty v) in (* (the dyn nil) is a dyn value that holds nil, not the literal: at a typed want it traps at run time as any dyn holding nil does, where a bare nil is refused. (the dyn 1) is likewise a dyn, not a literal that brings nothing dyn to an operator ([no_bare_nil]). [is_nil_lit] and [boxed_literal] see through nothing, so the [Do] hides both. *) let r = if ty = Types.Dyn && (is_nil_lit r || boxed_literal r <> None) then mk loc Types.Dyn (Tast.Do [ r ]) else r in expect ctx loc ~want r (* [f] run for its answer alone: whatever it wrote into the context is put back whether it succeeded or not, so a form can be checked once to see what it is and then checked again for real. [None] if it was refused. *) and probe : 'a. ctx -> Loc.t -> (unit -> 'a) -> 'a option = fun ctx loc f -> let answer = ref None in (match trial ctx (fun () -> answer := Some (f ()); raise (Loc.Error (Loc.diag loc "probe"))) with | _ -> ()); !answer and check_array_fill ctx ~want loc dims v = let ns = array_dims ctx loc dims in let elem_want = array_elem_want (List.length ns) want in (* The annotation's element type is the [want] the value is checked against, so a disagreement is reported at the value, in the ordinary expected/found words, rather than as a whole-array mismatch a line up. *) let v = check ctx ?want:elem_want v in let elem = match elem_want with Some t -> t | None -> v.Tast.ty in (* [resolve] refuses a fixed array of function values, because the elements this form does not write would be zeroed and a zeroed function value is a null pointer. The type is built here without going through [resolve], so the same guard has to be asked here. *) no_zeroed_fn loc "a fixed array's element" elem; let vs = fresh_slot ctx elem in let vv = mk loc elem (Tast.Local vs) in expect ctx loc ~want (array_build ctx loc ns elem ~pre:[ (vs, v) ] ~element:(fun _ -> vv)) and check_array_gen ctx ~want loc dims f = let ns = array_dims ctx loc dims in let rank = List.length ns in let plural n = if n = 1 then "" else "s" in let f = match f.Ast.e with (* The canonical inline form, [(array-gen [3 4] (fn [i j] ...))]. On its own [check] would refuse the fn — it takes its types from its position, and only an argument position names them — but *this* position knows them just as well: one i32 index per dimension, and the annotated element type as the return where the annotation reaches this deep. With no annotation the return is left for the body to say, which is the same inference the fill value gets. Arity is checked here so the refusal talks about dimensions and indices, not about parameters some (Fn ...) want expected. *) | Ast.Fn (ps, fbody) -> let got = List.length ps in if got <> rank then fail f.Ast.loc "this array-gen has %d dimension%s, so its generator is called with \ %d index%s — and this one takes %d argument%s" rank (plural rank) rank (if rank = 1 then "" else "es") got (plural got); check_fn ctx ~want:None ~gen:(List.init rank (fun _ -> index_ty), array_elem_want rank want) f.Ast.loc ps fbody | _ -> check ctx f in let elem = (* Either function type: the generator is called and nothing here cares whether an environment rides along. *) match fn_sig f.Tast.ty with | Some (ps, r) -> let got = List.length ps in if got <> rank then fail f.Tast.loc "this array-gen has %d dimension%s, so its generator is called with \ %d index%s — and this one takes %d argument%s" rank (plural rank) rank (if rank = 1 then "" else "es") got (plural got); List.iteri (fun k p -> if not (Types.equal p index_ty) then fail f.Tast.loc "an index is an i32, and this generator's argument %d is %s" (k + 1) (tyname loc p)) ps; r | None -> fail f.Tast.loc "array-gen's second element is a function value, called once per \ element with one i32 index per dimension, and this is %s — for one \ value repeated, write array-fill" (tyname loc f.Tast.ty) in no_zeroed_fn loc "a fixed array's element" elem; let fs = fresh_slot ctx f.Tast.ty in let fv = mk loc f.Tast.ty (Tast.Local fs) in expect ctx loc ~want (array_build ctx loc ns elem ~pre:[ (fs, f) ] ~element:(fun idxs -> mk loc elem (Tast.CallPtr (fv, idxs)))) and check_match ctx ?(tail = false) ?(used = false) ?(stmt = false) ?(opt = false) ?(flat = false) ?opt_rest ?want loc scrutinee arms = (* [stmt] is an [if let] with no else: a statement, Unit whatever its arm answers, as a one-armed [if] is when nothing keeps it. [opt] is one that is kept: its arm answers [Some], and the arm with no body [None]. *) let used = used && not stmt in let arms_ast_for_opt = arms in let want0 = want in let want = if stmt then None else if opt then (match want with | Some (Types.Option _) when flat -> want | Some (Types.Option i) -> Some i | _ -> None) else want in let s = check ctx scrutinee in (* What the arms are alternatives over. An [Option] is a two-case data type wearing a special coat, so the two shapes below are the same shape: a set of case names, an arity and a payload type per case, and a tag. Keeping them apart here rather than desugaring [Option] into a declared data type is deliberate — [Option] is generic and no declared data type is, so the coat is the part that cannot yet be taken off. *) let subject = match s.Tast.ty with | Types.Option t -> `Option t | Types.Named n when Hashtbl.mem ctx.env.datas n -> `Data (Hashtbl.find ctx.env.datas n) (* An enum is an i32 at run time and its members are all known, so the arms are a chain of [=] over a temporary, built at the foot of this function — a desugaring, not a new IR node. The exhaustiveness check is the one a data type gets. *) | Types.Enum n -> `Enum (n, Hashtbl.find ctx.env.enums n) (* An untagged union has nothing for the arms to be alternatives over. This is not a milestone and not a missing lowering: [match] reads a tag and decides, and the absence of a tag is the whole definition of this type. Said by name, because the two kinds of union are one keyword apart in the source and someone will write it. *) | Types.Named n when Hashtbl.mem ctx.env.unions n -> fail loc "%s is a union, and nothing in one records which member was written, \ so there is nothing to match on. Read the member you mean with \ (.member u), or use a defdata" n (* A number, a string or a dyn: the arms are literals, and each is the test (= t lit) over one temporary — the enum's chain, with [=]'s own two lowerings for the test, so a match over a dyn means what [=] over it means. [is_equatable]'s set minus the enums, which are above, and minus bool, below. *) | (Types.Int _ | Types.Float _ | Types.Char | Types.String | Types.Dyn) as t -> `Lit t (* A bool is a two-member enum spelled true and false: the same chain, and exhaustive without a [_] once both are named. *) | Types.Bool -> `Bool | other -> fail loc "match works on an Option, a data type, an enum, a bool, a number, a \ string or a dyn, not on %s" (tyname loc other) in (* A literal arm, spelled as it was written, for the refusals that name one. *) let spell (e : Ast.expr) = match e.Ast.e with | Ast.Int n -> Int64.to_string n | Ast.UInt (_, t) -> t | Ast.Float x when Float.is_integer x && Float.abs x < 1e15 -> Printf.sprintf "%.1f" x | Ast.Float x -> (* The shortest spelling that reads back as the same float. *) let rec go p = let t = Printf.sprintf "%.*g" p x in if p >= 17 || float_of_string t = x then t else go (p + 1) in go 1 | Ast.Byte b -> Form.byte_repr b | Ast.Str t -> Printf.sprintf "%S" t | Ast.Kw k -> ":" ^ k | Ast.Var b -> b | _ -> "this literal" in let what_ty t = match t with Types.Dyn -> "a dyn" | t -> tyname loc t in (* A literal match that compiles, over the scrutinee's own name where it has one, for the refusals that need to show the shape. *) let lit_arms_fix t = let name = match scrutinee.Ast.e with Ast.Var n -> n | _ -> "t" in Printf.sprintf "(match %s %s)" name (match t with | Types.String -> "\"yes\" 1 _ 0" | Types.Float _ -> "0.5 1 _ 0" | Types.Dyn -> "5 1 :go 2 _ 0" | _ -> "5 1 _ 0") in let bool_fix () = let name = match scrutinee.Ast.e with Ast.Var n -> n | _ -> "b" in Printf.sprintf "(match %s true 1 false 0)" name in (* The checked literal of each literal arm, by the key [resolve_pat] gave it. *) let lits : (string, Tast.expr) Hashtbl.t = Hashtbl.create 8 in let lit_values = ref [] in (* A literal arm over [t]: its checked value under a fresh key in [lits], refused if [t] cannot hold it or an earlier arm already equals it. *) let lit_arm (a : Ast.arm) t (e : Ast.expr) = let v = (* [=]'s dyn pair checks its literal at dyn, which boxes it. *) match trial ctx (fun () -> check ctx ~want:t e) with | Ok v -> v | Error _ -> (* A literal that does not fit is refused, where [=] would widen the pair and let the arm quietly never match. The literal's own refusal is not repeated: its fixes are casts, and a cast is not a pattern. *) (match t with | Types.Dyn -> fail a.Ast.aloc "this match is over a dyn, which holds a number as an i64 or \ an f64, and %s fits in neither. Change the arm to a value an \ i64 holds, or remove it" (spell e) | _ -> ()); let tn = tyname loc t in let an = match tn.[0] with | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn | _ -> "a " ^ tn in let why = match e.Ast.e, t with | Ast.Str _, _ -> "is a string" | _, Types.String -> "is a number" | (Ast.Int _ | Ast.UInt _ | Ast.Float _), Types.Char -> "is a number" | Ast.Float x, Types.Int _ when not (Float.is_integer x) -> "is not a whole number" | Ast.Float _, Types.Int _ -> "is a float" | _ -> "does not fit in one" in fail a.Ast.aloc "this match is over %s, so each arm has to be %s, and %s %s. \ Change the arm to a value %s holds, or remove it" tn an (spell e) why an in (* The arm's value at the scrutinee's type, and a second arm [=] could not tell from an earlier one is refused, since it can never be reached: 97 and \a are one u8, 0.1 and 0.10000000001 are one f32, and over a dyn 1 and 1.0 are equal. Compared pairwise rather than hashed, because dyn = between an integer and a float goes through the float and is not transitive past 2^53. *) let value = let f32 x = Int32.float_of_bits (Int32.bits_of_float x) in let num x = match t with Types.Float Types.F32 -> `F (f32 x) | _ -> `F x in match e.Ast.e, t with | Ast.Str s, _ -> `S s | (Ast.Int n | Ast.UInt (n, _)), Types.Float _ -> num (Int64.to_float n) | Ast.Byte b, Types.Float _ -> num (float_of_int b) | (Ast.Int n | Ast.UInt (n, _)), _ -> `I n | Ast.Byte b, _ -> `I (Int64.of_int b) | Ast.Float x, _ -> num x | Ast.Kw k, _ -> `K k | Ast.Var b, _ -> `B b | _ -> assert false in let same x y = match x, y with | `I a, `I b -> Int64.equal a b | `F a, `F b -> a = b | `I a, `F b | `F b, `I a -> Int64.to_float a = b | `S a, `S b | `K a, `K b | `B a, `B b -> String.equal a b | _ -> false in (match List.find_opt (fun (w, _) -> same value w) !lit_values with | Some (_, earlier) when earlier = spell e -> fail a.Ast.aloc "this match has two %s arms" earlier | Some (_, earlier) -> fail a.Ast.aloc "this match has two %s arms — %s equals it as %s, so this arm is \ never reached. Remove it" earlier (spell e) (match t with | Types.Dyn -> "a dyn" | t -> let tn = tyname loc t in (match tn.[0] with | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn | _ -> "a " ^ tn)) | None -> ()); lit_values := (value, spell e) :: !lit_values; let key = string_of_int (Hashtbl.length lits) in Hashtbl.replace lits key v; Some key, [] in (* Which case each arm names, and the type of each name it binds. This is the whole of what differs between the two subjects; everything below it is shared. *) let resolve_pat (a : Ast.arm) = match subject, a.Ast.pat with | _, Ast.Pwild -> None, [] | `Option elem, Ast.Pctor ("Some", [ x ]) -> Some "Some", [ (x, elem) ] | `Option _, Ast.Pctor ("Some", _) -> fail a.Ast.aloc "the Some pattern binds exactly one name" | `Option _, Ast.Pctor ("None", []) -> Some "None", [] | `Option _, Ast.Pctor ("None", _) -> fail a.Ast.aloc "None binds no names" | `Option _, Ast.Pctor (c, _) -> fail a.Ast.aloc "%s is not a case of Option — the cases are Some and None" c | `Enum (n, members), Ast.Pkw k -> if not (List.mem_assoc k members) then begin let all = String.concat " " (List.map (fun (m, _) -> ":" ^ m) members) in match member_near_miss members k with | Some (m, _) -> fail a.Ast.aloc "%s has no member :%s — did you mean :%s? It has %s" n k m all | None -> fail a.Ast.aloc "%s has no member :%s — it has %s" n k all end; Some k, [] (* [Dir.north ->], the member named through its enum. *) | `Enum (n, members), Ast.Pctor (c, []) when String.length c > String.length n + 1 && String.sub c 0 (String.length n + 1) = n ^ "." -> let k = String.sub c (String.length n + 1) (String.length c - String.length n - 1) in if not (List.mem_assoc k members) then fail a.Ast.aloc "%s has no member %s — it has %s" n k (String.concat " " (List.map (fun (m, _) -> n ^ "." ^ m) members)); Some k, [] | `Enum (n, members), Ast.Pctor (c, _) -> fail a.Ast.aloc "this match is over the enum %s, and %s is not one of its members. An \ arm names a member as a keyword: %s" n c (String.concat " " (List.map (fun (m, _) -> ":" ^ m) members)) | `Lit t, Ast.Plit e -> lit_arm a t e (* Over a dyn a keyword is a value like any other, so :north is the arm (= d :north), and true and false are the arms (= d true) and (= d false). *) | `Lit Types.Dyn, Ast.Pkw k -> lit_arm a Types.Dyn { Ast.e = Ast.Kw k; loc = a.Ast.aloc } | `Lit Types.Dyn, Ast.Pctor (("true" | "false") as b, []) -> lit_arm a Types.Dyn { Ast.e = Ast.Var b; loc = a.Ast.aloc } | `Bool, Ast.Pctor (("true" | "false") as b, []) -> Some b, [] | `Bool, Ast.Pctor (c, _) -> fail a.Ast.aloc "%s names a case, and this match is over a bool, whose arms are true \ and false, as in %s" c (bool_fix ()) | `Bool, Ast.Pkw k -> fail a.Ast.aloc ":%s is a keyword, and this match is over a bool, whose arms are true \ and false, as in %s" k (bool_fix ()) | `Bool, Ast.Plit e -> fail a.Ast.aloc "%s is a literal, and this match is over a bool, whose arms are true \ and false, as in %s" (spell e) (bool_fix ()) | `Lit t, Ast.Pkw k -> fail a.Ast.aloc ":%s is an enum member, and this match is over %s, whose arms are \ literals, as in %s" k (what_ty t) (lit_arms_fix t) | `Lit t, Ast.Pctor (c, _) -> fail a.Ast.aloc "%s names a case, and this match is over %s, whose arms are \ literals, as in %s" c (what_ty t) (lit_arms_fix t) | `Option _, Ast.Plit e -> fail a.Ast.aloc "%s is a literal, and this match is over an Option, whose arms are \ (Some x) and None" (spell e) | `Enum (n, members), Ast.Plit e -> fail a.Ast.aloc "%s is a literal, and this match is over the enum %s, whose arms \ name its members as keywords: %s" (spell e) n (String.concat " " (List.map (fun (m, _) -> ":" ^ m) members)) | `Data u, Ast.Plit e -> fail a.Ast.aloc "%s is a literal, and this match is over the data type %s, whose \ arms name its cases: %s" (spell e) u.Tast.dname (String.concat ", " (List.map (fun (v : Tast.variant) -> v.Tast.vname) u.Tast.cases)) | `Option _, Ast.Pkw k -> fail a.Ast.aloc ":%s is an enum member, and this match is over an Option, whose arms \ are (Some x) and None" k | `Data u, Ast.Pkw k -> fail a.Ast.aloc ":%s is an enum member, and this match is over the data type %s, \ whose arms name its cases: %s" k u.Tast.dname (String.concat ", " (List.map (fun (v : Tast.variant) -> v.Tast.vname) u.Tast.cases)) | `Data u, Ast.Pctor (c, names) -> (* A pattern names the case bare: the scrutinee's type already says which data type, so [(Node l r)] is unambiguous even where two data types share the case name. The qualified spelling is accepted too, since that is how the value was written and writing it again should not be an error. *) let bare = let full = u.Tast.dname ^ "." in let n = String.length full in if String.length c > n && String.sub c 0 n = full then String.sub c n (String.length c - n) else c in (match Tast.case_index u bare with | None -> fail a.Ast.aloc "%s is not a case of %s — the cases are %s" c u.Tast.dname (String.concat ", " (List.map (fun (v : Tast.variant) -> v.Tast.vname) u.Tast.cases)) | Some (_, v) -> (* Positional, in declaration order, and all of them or none: a pattern that bound some of a case's fields would be silently reading the wrong one after a field is inserted. Refused with the count, which is the thing that is wrong. *) if List.length names <> List.length v.Tast.vfields then fail a.Ast.aloc "%s.%s has %d field%s, and this pattern binds %d — a case pattern \ binds every field, in declaration order (%s)" u.Tast.dname bare (List.length v.Tast.vfields) (if List.length v.Tast.vfields = 1 then "" else "s") (List.length names) (String.concat " " (List.map (fun (f : Tast.field) -> f.Tast.fname) v.Tast.vfields)); Some bare, List.map2 (fun n (f : Tast.field) -> (n, f.Tast.fty)) names v.Tast.vfields) in let want = ref want in let seen = Hashtbl.create 8 in let saw_wild = ref false in let resolved = map_lr (fun (a : Ast.arm) -> let ctor, binds = resolve_pat a in (match ctor with | None -> saw_wild := true | Some c -> if Hashtbl.mem seen c then fail a.Ast.aloc "this match has two %s arms" (match subject, a.Ast.pat with | `Enum _, _ -> ":" ^ c | _, Ast.Plit e -> spell e | _ -> c); Hashtbl.add seen c ()); (a, ctor, binds)) arms in (* With nothing expected of the match, the first arm's type is every arm's — unless that arm is a bare literal, which has no type until asked. So the arms whose value is a literal are checked last, and take their type from the others, as an [if]'s literal arm does. The order is only the order they are checked in; they are put back in source order below. *) let literal_arm ((a : Ast.arm), _, _) = match List.rev a.Ast.body with last :: _ -> adapts last | [] -> false in (* Every arm a literal: they meet at the wider of their own types, as an [if]'s two do. *) (if !want = None && resolved <> [] && List.for_all literal_arm resolved then let lasts = List.map (fun ((a : Ast.arm), _, _) -> List.hd (List.rev a.Ast.body)) resolved in match lasts with | first :: rest -> let j = List.fold_left (fun acc x -> Option.bind acc (fun a -> Option.bind (literal_join ctx first x) (literal_meet a))) (literal_join ctx first first) rest in (match j with | Some t when not (Types.equal t (Types.Int Types.I32)) -> want := Some t | _ -> ()) | [] -> ()); (* With nothing expected, the arms meet at [arm_join], as an [if]'s do, in whatever order they are written: each typed arm is checked on its own terms, the join so far grows with it, and every arm is brought to the final join at the end. An arm that needs an expectation — [nil], a bare struct — is checked at the join so far, as it was at the first arm's type before. *) let free = !want = None in let order = let idx = List.mapi (fun i r -> (i, r)) resolved in if !want <> None then idx else let typed = List.filter (fun (_, r) -> not (literal_arm r)) idx in (* A bare [None] that would be checked first has nothing to take its type from and was always refused; it goes after the others, so it meets their T at T? (decision 138). Only the leading ones move, so no order that checked before changes. *) let none_arm (_, ((a : Ast.arm), _, _)) = match List.rev a.Ast.body with last :: _ -> is_none_lit last | [] -> false in let rec lead acc = function | x :: rest when none_arm x -> lead (x :: acc) rest | rest -> (List.rev acc, rest) in let nones, typed = match lead [] typed with | _ :: _ as nones, rest when List.length nones < List.length idx -> nones, rest | _ -> [], typed in typed @ List.filter (fun (_, r) -> literal_arm r) idx @ nones in let checked = map_lr (fun (i, ((a : Ast.arm), ctor, binds)) -> i, branch ctx (fun () -> (* What each name in this arm is, in words, for the one refusal that needs it: a case pattern binds fields positionally, so the i'th name is the i'th field of the case the arm named. Derived here rather than carried out of [resolve_pat], because the case and the subject are both still in hand and the alternative was widening that function's result for one message. *) let fields = match subject, ctor with | `Data u, Some c -> (match Tast.case_index u c with | Some (_, v) -> List.map (fun (fd : Tast.field) -> Printf.sprintf "%s.%s's field %s" u.Tast.dname c fd.Tast.fname) v.Tast.vfields | None -> []) | `Option _, Some "Some" -> [ "the Option's payload" ] | _ -> [] in let binds = List.mapi (fun i (n, ty) -> let what = List.nth_opt fields i in bind ctx ?what n ty ~assignable:false) binds in (* Every arm is the tail, exactly as an [if]'s two arms are. Restored here because checking the scrutinee withdrew it. *) ctx.tail <- tail; ctx.used <- used; let arm = (a, ctor, binds) in let empty = opt && a.Ast.body = [] in let body = if empty then unit_at a.Ast.aloc else if free && !want <> None && not (literal_arm arm) then (* As an [if]'s else arm: at the join so far first, on its own terms only when that is refused as a mismatch. *) let at w () = block ctx ?want:w a.Ast.aloc a.Ast.body in let w = Option.get !want in let head = List.hd a.Ast.body in let at_join () = match List.find_opt (fun (n, (sc, r), w', _) -> n == head && r == ctx.ret && Types.equal w' w && same_scope sc ctx.scope) (Hashtbl.find_all arm_failed head.Ast.loc) with | Some (_, _, _, d) -> Error d | None -> (match trial ctx (at (Some w)) with | Ok b -> Ok b | Error d -> if !lit_recording = 0 then Hashtbl.add arm_failed head.Ast.loc (head, (ctx.scope, ctx.ret), w, d); Error d) in (* Where it would be refused: an arm fine at T? — [None], [Some(1)] — meets a T join at T? (decision 138), and [arm_join] wraps the arms before it. *) let refused () = let fallback () = at !want () in match w with | Types.Option _ | Types.Dyn | Types.Unit -> fallback () | _ -> let oty = Types.Option w in (match trial ctx (at (Some oty)) with | Ok b when Types.equal b.Tast.ty oty -> b | _ -> fallback ()) in match at_join () with | Ok b -> (match opened_dyn ~box:(to_dyn ctx) b with | Some box -> want := Some Types.Dyn; box | None -> b) | Error d -> (match trial ctx (fun () -> let b = at None () in if is_mismatch d || Types.equal b.Tast.ty Types.Dyn then b else raise (Loc.Error (Loc.diag ~kind:not_kept b.Tast.loc ""))) with | Ok b -> b | Error own when String.equal own.Loc.kind not_kept -> refused () | Error own when is_mismatch d && not (is_mismatch own) -> at None () | Error _ -> refused ()) else block ctx ?want:!want a.Ast.aloc a.Ast.body in let body = if stmt && body.Tast.ty <> Types.Unit && body.Tast.ty <> Types.Never then mk body.Tast.loc Types.Unit (Tast.Do [ body; unit_at body.Tast.loc ]) else body in (if body.Tast.ty <> Types.Never && not stmt && not empty then match !want with | None -> want := Some body.Tast.ty | Some w when free -> (match arm_join w body.Tast.ty with | Some j -> want := Some j | None -> ()) | Some _ -> ()); { Tast.acase = ctor; binds; abody = [ body ] })) order in let checked = match free, !want with | true, Some j -> (* Said at the arm's value, its last form, as a refusal checked at the join would have been — not at its pattern. *) let rec value (x : Ast.expr) = match x.Ast.e with | Ast.Do (_ :: _ as xs) | Ast.Let (_, (_ :: _ as xs)) -> value (List.hd (List.rev xs)) | _ -> x.Ast.loc in let value_loc i = let (a : Ast.arm), _, _ = List.nth resolved i in match List.rev a.Ast.body with | x :: _ -> value x | [] -> a.Ast.aloc in (* Each arm refused on its own, so every arm that cannot meet the join is said, as each would be checked at it. *) List.map (fun (i, (arm : Tast.arm)) -> let empty = opt && (let (a : Ast.arm), _, _ = List.nth resolved i in a.Ast.body = []) in match arm.Tast.abody with | [ b ] when not (empty || Types.equal b.Tast.ty j || b.Tast.ty = Types.Never) -> let at = value_loc i in let b = try expect ctx at ~want:(Some j) b with Loc.Error d -> refuse_or_poison ctx.env at d in (i, { arm with Tast.abody = [ b ] }) | _ -> (i, arm)) checked | _ -> checked in let arms = List.map snd (List.sort (fun (i, _) (j, _) -> compare i j) checked) in (* [opt]: what the pattern's arm answered decides the whole, as a one-armed [if]'s branch does — no value is a statement, Never stays Never, a dyn is the value or nil, and anything else is [Some] of it. The arm with no body is the rest of the chain, [opt_rest], checked now that its want is known, or [None] when the chain ends here. *) let opt_result = ref None in let arms = if not opt then arms else let raw = List.fold_left2 (fun acc (a : Ast.arm) (arm : Tast.arm) -> match a.Ast.body, arm.Tast.abody with | _ :: _, [ b ] -> Some b.Tast.ty | _ -> acc) None arms_ast_for_opt arms in let rest ~used ?want () = match opt_rest with | Some f -> Some (f ~used ?want ()) | None -> None in let fill body_of wild_of = List.map2 (fun (a : Ast.arm) (arm : Tast.arm) -> match a.Ast.body, arm.Tast.abody with | [], _ -> { arm with Tast.abody = [ wild_of a ] } | _, [ b ] -> { arm with Tast.abody = [ body_of b ] } | _ -> arm) arms_ast_for_opt arms in match raw with | None | Some Types.Unit -> opt_result := Some Types.Unit; let r = rest ~used:false () in fill Fun.id (fun a -> match r with | Some e when e.Tast.ty = Types.Unit || e.Tast.ty = Types.Never -> e | Some e -> mk e.Tast.loc Types.Unit (Tast.Do [ e; unit_at e.Tast.loc ]) | None -> unit_at a.Ast.aloc) | Some Types.Never -> (match rest ~used:true ?want:want0 () with | Some e -> opt_result := Some e.Tast.ty; fill Fun.id (fun _ -> e) | None -> (match want0 with | Some (Types.Option _ as o) -> opt_result := Some o; fill Fun.id (fun a -> mk a.Ast.aloc o Tast.None_) | _ -> opt_result := Some Types.Unit; fill Fun.id (fun a -> unit_at a.Ast.aloc))) | Some Types.Dyn -> opt_result := Some Types.Dyn; let r = rest ~used:true ~want:Types.Dyn () in fill Fun.id (fun a -> match r with | Some e -> e | None -> rt a.Ast.aloc Types.Dyn "flan_dyn_nil" []) (* Already an Option: the whole, one level flattened (decision 140). *) | Some (Types.Option _ as o) when flat || want0 = None -> opt_result := Some o; let r = rest ~used:true ~want:o () in fill Fun.id (fun a -> match r with | Some e -> e | None -> mk a.Ast.aloc o Tast.None_) | Some t -> let oty = Types.Option t in opt_result := Some oty; let r = rest ~used:true ~want:oty () in fill (fun b -> mk b.Tast.loc oty (Tast.Some_ b)) (fun a -> match r with | Some e -> e | None -> mk a.Ast.aloc oty Tast.None_) in (* Exhaustiveness is refused, not defaulted. A match that silently fell through would have to produce a value of the match's type out of nothing, and there is no such value for most types; and the case a data type grows tomorrow is exactly the one a reader wants to be told about today. A [_] arm is the way to say "the rest", written where it can be seen. *) let missing = match subject with | `Option _ -> List.filter (fun c -> not (Hashtbl.mem seen c)) [ "Some"; "None" ] | `Data u -> List.filter_map (fun (c : Tast.variant) -> if Hashtbl.mem seen c.Tast.vname then None else Some (u.Tast.dname ^ "." ^ c.Tast.vname)) u.Tast.cases | `Enum (_, members) -> List.filter_map (fun (m, _) -> if Hashtbl.mem seen m then None else Some (":" ^ m)) members | `Bool -> List.filter (fun c -> not (Hashtbl.mem seen c)) [ "true"; "false" ] | `Lit _ -> [] in (* No list of literals covers a number, a string or a dyn, so a literal match always needs its [_]. Refused here, before the chain below, which would otherwise run a lone last arm untested as the enum's does. *) (match subject with | `Lit t when not !saw_wild -> Loc.failk "check/non-exhaustive-match" loc "this match is not exhaustive — its arms are literals, and no list of \ them covers every %s. Add a _ arm for the rest, as in %s" (match t with Types.Dyn -> "dyn value" | t -> tyname loc t) (lit_arms_fix t) | _ -> ()); if not !saw_wild && missing <> [] then (* The data type's declaration, because that is where the case list this match failed to cover actually lives, and because adding a case there is what makes a match non-exhaustive in the first place. *) Loc.failk "check/non-exhaustive-match" loc ~notes:(match subject with | `Data u -> declared_note ctx.env u.Tast.dname | `Enum (n, _) -> declared_note ctx.env n | `Option _ | `Bool | `Lit _ -> []) "this match is not exhaustive — %s %s no arm. Add %s, or a _ arm for \ the rest" (String.concat ", " missing) (if List.length missing = 1 then "has" else "have") (if List.length missing = 1 then "it" else "them"); let ty = if stmt then Types.Unit else if opt then (match !opt_result with Some t -> t | None -> Types.Never) else match !want with Some t -> t | None -> Types.Never in match subject with | `Option _ | `Data _ -> mk loc ty (Tast.Match (s, arms)) | `Enum _ | `Bool | `Lit _ -> (* The scrutinee once, into a temporary, and then an [if] per arm in the order written. A [_] arm ends the chain, and so does the last arm of a match with none: it is exhaustive by the check above, so the last member's test is the only one left and cannot fail on a value the enum declares. *) let slot = fresh_slot ctx s.Tast.ty in let local = mk loc s.Tast.ty (Tast.Local slot) in let body (a : Tast.arm) = match a.Tast.abody with [ b ] -> b | bs -> mk loc ty (Tast.Do bs) in let rec chain = function | [] -> unit_at loc | ({ Tast.acase = None; _ } as a) :: _ -> body a | [ a ] -> body a | ({ Tast.acase = Some m; _ } as a) :: rest -> let test = match subject with | `Enum (_, members) -> let v = mk loc s.Tast.ty (Tast.Int (List.assoc m members, Types.I32)) in mk loc Types.Bool (Tast.Prim (Tast.Eq, [ local; v ])) | `Bool when String.equal m "true" -> local | `Bool -> mk loc Types.Bool (Tast.Prim (Tast.Not, [ local ])) | `Lit Types.Dyn -> dyn_eq loc local (Hashtbl.find lits m) | _ -> mk loc Types.Bool (Tast.Prim (Tast.Eq, [ local; Hashtbl.find lits m ])) in mk loc ty (Tast.If (test, body a, chain rest)) in mk loc ty (Tast.Let ([ (slot, s) ], [ chain arms ])) (* [if let P = v] — (if-let [P v] then else) — is the two-arm match [(match v P then _ else)]. With no else it is a statement, Unit whatever [then] answers, as a one-armed [if] is. A pattern that cannot fail — [_], or a plain name, which is a name to bind and not a case — tests nothing, and is refused toward [let]. A bare name is a case when some data type, Option or bool has a case of that name, or it names an enum member through its enum. *) and check_if_let ctx ~tail ~used ?want loc scrutinee (arm : Ast.arm) els = let fln = fln_source loc in let is_case n = List.mem n [ "None"; "Some"; "true"; "false" ] || String.contains n '.' || Hashtbl.fold (fun _ u acc -> acc || Tast.case_index u n <> None) ctx.env.datas false in let irrefutable name = match name with | Some n -> Loc.failk "check/if-let-irrefutable" arm.Ast.aloc "the pattern %s is a plain name, which always matches, so this if let \ has nothing to test. Bind the value with %s" n (if fln then Printf.sprintf "let %s = ..." n else Printf.sprintf "(let [%s ...] ...)" n) | None -> Loc.failk "check/if-let-irrefutable" arm.Ast.aloc "the pattern _ always matches, so this if let has nothing to test. \ Use the value directly, or match on it" in match arm.Ast.pat with | Ast.Pwild -> irrefutable None | Ast.Pctor (n, []) when not (is_case n) -> if_let_name ctx ~tail ~used ?want loc scrutinee n arm els | _ -> let wild body = { Ast.pat = Ast.Pwild; body; aloc = loc } in (* Kept with no else at the end of its chain, it is a [when] over a pattern: [Some] of the arm that ran and [None] when none did — or, where a dyn is wanted, the value or nil. *) let open_end = match els with None -> true | Some e -> kept_open ~used:true None e in let kept = match want with | Some (Types.Unit | Types.Never) -> false | Some _ -> true | None -> used in let at (x : Ast.expr) e = { Ast.e; loc = x.Ast.loc } in match els with | _ when kept && open_end -> let rest = match els with Some e -> e | None -> at scrutinee (Ast.Var "nil") in (match want with | Some Types.Dyn -> check_match ctx ~tail ~used:true ?want loc scrutinee [ arm; wild [ rest ] ] | _ -> (* The rest of the chain is checked once the arm's own type is known, as a one-armed [if]'s else is: see [opt] in [check_match]. *) let opt_rest = Option.map (fun e ~used ?want () -> branch ctx (fun () -> ctx.tail <- tail; ctx.used <- used; check ctx ?want e)) els in (* The arm at the payload first, as [check_when] asks it; refused there, at the Option itself (decision 140). *) let go ~flat () = check_match ctx ~tail ~used:true ~opt:true ~flat ?opt_rest ?want loc scrutinee [ arm; wild [] ] in expect ctx loc ~want (match want with | Some (Types.Option _) -> (match trial ctx (go ~flat:false) with | Ok r -> r | Error d -> (match trial ctx (go ~flat:true) with | Ok r -> r | Error _ -> raise (Loc.Error d))) | _ -> go ~flat:false ())) | Some e -> check_match ctx ~tail ~used ?want loc scrutinee [ arm; wild [ e ] ] | None -> expect ctx loc ~want (check_match ctx ~tail ~stmt:true loc scrutinee [ arm; wild [] ]) (* [if let g = x] with a plain name: over an Option it is [if let Some(g) = x], and over a dyn it binds [g] when [x] is not nil. [x] is checked once and held under a name no reader can produce; the rest is the form it stands for, checked as that form is. Anything else always holds a value, so there is nothing to test. *) and if_let_name ctx ~tail ~used ?want loc scrutinee n (arm : Ast.arm) els = let sv = check ctx scrutinee in let fln = fln_source loc in let held f = scoped ctx (fun () -> incr held_n; let h = Printf.sprintf "~if%d" !held_n in let s = bind ctx h sv.Tast.ty ~assignable:false in let hv = { Ast.e = Ast.Var h; loc = scrutinee.Ast.loc } in let r = f hv in mk loc r.Tast.ty (Tast.Let ([ (s, sv) ], [ r ]))) in match sv.Tast.ty with | Types.Option _ -> held (fun hv -> check_if_let ctx ~tail ~used ?want loc hv { arm with Ast.pat = Ast.Pctor ("Some", [ n ]) } els) | Types.Dyn -> held (fun hv -> let at e = { Ast.e; loc = arm.Ast.aloc } in let test = at (Ast.Call (at (Ast.Var "!="), [ hv; at (Ast.Var "nil") ])) in let bnd = { Ast.bname = n; bty = None; bval = hv; bloc = arm.Ast.aloc } in let body = { Ast.e = Ast.Let ([ bnd ], arm.Ast.body); loc = arm.Ast.aloc } in ctx.tail <- tail; ctx.used <- used; check ctx ?want { Ast.e = Ast.If (test, body, els); loc }) | t -> Loc.failk "check/if-let-irrefutable" arm.Ast.aloc "%s is %s, which always holds a value, so this if let has nothing to \ test. A plain name in an if let binds what an Option or a dyn holds \ when it holds something. Bind this value with %s" (spell_arg "the value" scrutinee) (tyname loc t) (if fln then Printf.sprintf "let %s = ..." n else Printf.sprintf "(let [%s ...] ...)" n) (* The locals a condition tests with [x?], through [and]: those it narrows in the block it guards (decision 133). Not through [or] or [not], where the test holding says nothing about [x]. *) and narrows (c : Ast.expr) = match Ast.unpause c with | Some x -> narrows x | None -> match c.Ast.e with | Ast.Call ({ Ast.e = Ast.Var "?"; _ }, [ { Ast.e = Ast.Var x; _ } ]) -> [ x ] | Ast.If (p, q, Some { Ast.e = Ast.Var "false"; _ }) -> narrows p @ narrows q | Ast.IfLet (_, { Ast.pat = Ast.Pctor (g, []); body = [ q ]; _ }, Some { Ast.e = Ast.Var "false"; _ }) when as_name g -> narrows q | _ -> [] and as_binds c = Ast.as_binds c and as_name g = Ast.as_name g (* A condition with [as] in it, as the bool it tests, and each name it binds with the hidden name the block reads it through. The chain runs left to right and stops at the first test that fails, so each value is found once. Each name an [as] binds is one slot, read by the rest of the chain and, through [Ast.Alias], by the block. *) and as_cond ctx (c : Ast.expr) = let named = ref [] in let no loc = mk loc Types.Bool (Tast.Bool false) in let rec go (c : Ast.expr) = let loc = c.Ast.loc in match Ast.unpause c, c.Ast.e with (* A pause mark on a test of the chain stops before it and leaves the chain as it was. *) | Some x, Ast.Do [ pause; _ ] -> let pv = check ctx pause in let xv = go x in mk loc Types.Bool (Tast.Do [ pv; xv ]) | _, _ -> match c.Ast.e with | Ast.If (p, q, Some { Ast.e = Ast.Var "false"; _ }) when as_binds q <> [] -> let pv = check_truthy ctx p in let qv = with_narrowed ctx (narrows p) (fun () -> go q) in mk loc Types.Bool (Tast.If (pv, qv, no loc)) | Ast.IfLet (e, { Ast.pat = Ast.Pctor (g, []); body = [ q ]; _ }, Some { Ast.e = Ast.Var "false"; _ }) when as_name g -> let ev = check ctx e in let refuse t = Loc.failk "check/as-not-optional" e.Ast.loc "%s is %s, which always holds a value, so as has nothing to test. \ as names what an Option or a dyn holds, when it holds something. \ It is not a conversion: a number is converted with its type's \ name, as in i32(x)" (source_text e) (tyname loc t) in (* [g] is a slot of its own under its own name, so locals, the stepper, the inspector and the watch view show it as the program reads it. A dyn is held there directly; an Option is held in a hidden slot and its payload copied into [g]'s once the test holds. *) let bound ty = scoped ctx (fun () -> let slot = bind ctx ~what:as_tag g ty ~assignable:false in ctx.as_slots <- slot :: ctx.as_slots; let b = Option.get (lookup ctx g) in incr held_n; named := (g, Printf.sprintf "~as%d" !held_n, b) :: !named; (slot, go q)) in (match ev.Tast.ty with | Types.Option t -> let hs = fresh_slot ctx ev.Tast.ty in let hv = mk loc ev.Tast.ty (Tast.Local hs) in let slot, qv = bound t in mk loc Types.Bool (Tast.Let ([ (hs, ev) ], [ mk loc Types.Bool (Tast.If (opt_is_some loc hv, mk loc Types.Bool (Tast.Let ([ (slot, opt_payload loc t hv) ], [ qv ])), no loc)) ])) | Types.Dyn -> let slot, qv = bound Types.Dyn in let sv = mk loc Types.Dyn (Tast.Local slot) in mk loc Types.Bool (Tast.Let ([ (slot, ev) ], [ mk loc Types.Bool (Tast.If (dyn_not_nil loc sv, qv, no loc)) ])) | t -> refuse t) | _ -> check_truthy ctx c in let cv = go c in let named = List.rev !named in List.iter (fun (_, h, b) -> ctx.scope <- (h, b) :: ctx.scope) named; (cv, List.map (fun (g, h, _) -> (g, h)) named) (* [f] with each of [names] that is a local (Option T) read as its payload: the same slot, so a field set through it lands in the Option itself. A dyn stays as it is; a name that is not a local is not narrowed. Assigning the name a T writes the payload and it stays present; assigning it an Option is refused ([narrowed_set]). *) and with_narrowed : 'a. ctx -> string list -> (unit -> 'a) -> 'a = fun ctx names f -> if names = [] then f () else let held = ref [] in let r = scoped ctx (fun () -> List.iter (fun n -> match lookup ctx n with | Some { bty = Types.Option _; _ } when List.mem n !unnarrowable -> held := n :: !held | Some ({ bty = Types.Option t; _ } as b) when b.bwhat <> Some narrowed_tag -> ctx.scope <- (n, { b with bty = t; bwhat = Some narrowed_tag; blit = None }) :: ctx.scope | _ -> ()) names; (* A name something else can clear stays an Option; a refusal in the block about it says why, and how to copy what it holds. *) if !held = [] then f () else let note (d : Loc.diag) = let has s sub = let ls = String.length s and lb = String.length sub in let rec go i = i + lb <= ls && (String.sub s i lb = sub || go (i + 1)) in go 0 in let about = if has d.Loc.dmsg "Option" then !held else [] in match about with | [] -> d | n :: _ -> { d with Loc.notes = d.Loc.notes @ [ Loc.note d.Loc.dloc (Printf.sprintf "%s? does not make %s its payload here: %s's address \ is taken, or a fn assigns it, in this function, so \ something else could clear it. Write if %s as g, \ which copies what it holds into g" n n n n) ] } in (* Raised, or recorded while recovering: noted either way. *) let before = ctx.env.recovered in let r = try f () with | Loc.Error d -> raise (Loc.Error (note d)) | Loc.Errors ds -> raise (Loc.Errors (List.map note ds)) in let rec fresh l = if l == before then l else match l with d :: t -> note d :: fresh t | [] -> [] in ctx.env.recovered <- fresh ctx.env.recovered; r) in r (* [x?]: whether x holds a value — an Option that is Some, a dyn that is not nil. *) and check_present ctx ~want loc (args : Ast.expr list) = match args with | [ x ] -> let xv = check ctx x in let s = fresh_slot ctx xv.Tast.ty in let sv = mk loc xv.Tast.ty (Tast.Local s) in let held e = mk loc Types.Bool (Tast.Let ([ (s, xv) ], [ e ])) in (match xv.Tast.ty with | Types.Option _ -> expect ctx loc ~want (held (opt_is_some loc sv)) | Types.Dyn -> expect ctx loc ~want (held (dyn_not_nil loc sv)) | t -> let hint = match x.Ast.e with | Ast.Var n -> Printf.sprintf ". A name cannot end in ? either: a yes-or-no name \ starts with is- or has-, as in is-%s" n | _ -> "" in fail loc "%s is %s, which always holds a value, so %s? has nothing to \ test%s" (source_text x) (tyname loc t) (source_text x) hint) | _ -> fail loc "? tests one value: x?" (* The tag test and the payload of an Option held in a local, and the nil test of a dyn: the shapes [box_option] and [unbox_option] build. *) and opt_is_some loc (sv : Tast.expr) = mk loc Types.Bool (Tast.Prim (Tast.Ne, [ mk loc (Types.Int Types.I8) (Tast.Field (sv, 0)); mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])) and opt_payload loc t (sv : Tast.expr) = mk loc t (Tast.Field (sv, 1)) and dyn_not_nil loc (sv : Tast.expr) = mk loc Types.Bool (Tast.Prim (Tast.Eq, [ rt loc (Types.Int Types.I32) "flan_dyn_is_nil" [ sv ]; mk loc (Types.Int Types.I32) (Tast.Int (0L, Types.I32)) ])) (* [x ?? d]: what [x] holds, or [d] when it holds nothing — [None], or nil over a dyn. [d] is evaluated only then. A chain, [(?? a b c)], is read from the right, [a ?? (b ?? c)], so a default may itself be an Option and the whole is then an Option, as in Swift. *) and check_coalesce ctx ~want loc (args : Ast.expr list) = match args with | [] | [ _ ] -> fail loc "?? takes a value and a default: x ?? d" | x :: rest -> let d = match rest with | [ d ] -> d | d :: _ -> { Ast.e = Ast.Call ({ Ast.e = Ast.Var "??"; loc }, rest); loc = d.Ast.loc } | [] -> assert false in let xv = check ctx x in let s = fresh_slot ctx xv.Tast.ty in let sv = mk loc xv.Tast.ty (Tast.Local s) in let held ty e = mk loc ty (Tast.Let ([ (s, xv) ], [ mk loc ty e ])) in (match xv.Tast.ty with | Types.Option t -> (match trial ctx (fun () -> expect ctx d.Ast.loc ~want:(Some t) (check ctx ~want:t d)) with | Ok dv -> expect ctx loc ~want (held t (Tast.If (opt_is_some loc sv, opt_payload loc t sv, dv))) | Error first -> let o = Types.Option t in (match trial ctx (fun () -> expect ctx d.Ast.loc ~want:(Some o) (check ctx ~want:o d)) with | Ok dv -> expect ctx loc ~want (held o (Tast.If (opt_is_some loc sv, sv, dv))) | Error _ -> raise (Loc.Error first))) | Types.Dyn -> let dv = check ctx ~want:Types.Dyn d in expect ctx loc ~want (held Types.Dyn (Tast.If (dyn_not_nil loc sv, sv, dv))) | t -> fail x.Ast.loc "the left side of ?? is %s, which always holds a value, so there is \ nothing to fall back from. ?? takes an Option or a dyn" (tyname loc t)) (* The source text of [e], for a message the program prints when it runs. *) and source_text (e : Ast.expr) = match Loc.snippet ~lim:48 e.Ast.loc with | Some t -> t | None -> spell_arg "the value" e (* [x!]: what [x] holds, and a trap at this site naming [x] when it holds nothing. The trap never returns; the zero after it only gives the arm its type, so no backend needs a call typed Never. *) and check_unwrap ctx ~want loc (args : Ast.expr list) = match args with | [ x ] -> let xv = check ctx x in let s = fresh_slot ctx xv.Tast.ty in let sv = mk loc xv.Tast.ty (Tast.Local s) in let text = source_text x in let fail_with none zero ty = mk loc ty (Tast.Do [ rt loc Types.Unit "flan_unwrap_fail" [ here loc; mk loc Types.String (Tast.Str (Printf.sprintf "%s is %s, so %s! has no value to give" text none text)) ]; zero ]) in let held ty e = mk loc ty (Tast.Let ([ (s, xv) ], [ mk loc ty e ])) in (match xv.Tast.ty with | Types.Option t -> expect ctx loc ~want (held t (Tast.If (opt_is_some loc sv, opt_payload loc t sv, fail_with "None" (mk loc t (Tast.Zero t)) t))) | Types.Dyn -> expect ctx loc ~want (held Types.Dyn (Tast.If (dyn_not_nil loc sv, sv, fail_with "nil" (rt loc Types.Dyn "flan_dyn_nil" []) Types.Dyn))) | t -> fail x.Ast.loc "%s is %s, which always holds a value, so ! has nothing to unwrap. \ Leave the ! out" text (tyname loc t)) | _ -> fail loc "! unwraps one value: x!" (* [a?.b]: [(?. [n a] body)] — [body] over what [a] holds, bound to [n], or None when it holds nothing (nil over a dyn). [body] already an Option is not wrapped again, so [a?.b?.c] is one Option; [body] with no value makes the whole a statement. *) and check_chain ctx ~want loc n (v : Ast.expr) (body : Ast.expr) = let hv = check ctx v in let s = fresh_slot ctx hv.Tast.ty in let sv = mk loc hv.Tast.ty (Tast.Local s) in let arm t ~dyn = scoped ctx (fun () -> let p = bind ctx n t ~assignable:false in let bv = if dyn then check ctx ~want:Types.Dyn body else check ctx body in (p, bv)) in let held ty e = mk loc ty (Tast.Let ([ (s, hv) ], [ mk loc ty e ])) in match hv.Tast.ty with | Types.Option t -> let p, bv = arm t ~dyn:false in let inner ty e = mk loc ty (Tast.Let ([ (p, opt_payload loc t sv) ], [ e ])) in (match bv.Tast.ty with | Types.Unit | Types.Never -> expect ctx loc ~want (held Types.Unit (Tast.If (opt_is_some loc sv, inner Types.Unit bv, mk loc Types.Unit Tast.Unit))) | Types.Option _ as o -> expect ctx loc ~want (held o (Tast.If (opt_is_some loc sv, inner o bv, mk loc o Tast.None_))) | b -> let o = Types.Option b in expect ctx loc ~want (held o (Tast.If (opt_is_some loc sv, inner o (mk loc o (Tast.Some_ bv)), mk loc o Tast.None_)))) | Types.Dyn -> let p, bv = arm Types.Dyn ~dyn:true in let ty = match bv.Tast.ty with Types.Unit | Types.Never -> Types.Unit | _ -> Types.Dyn in let none = if ty = Types.Unit then mk loc Types.Unit Tast.Unit else rt loc Types.Dyn "flan_dyn_nil" [] in expect ctx loc ~want (held ty (Tast.If (dyn_not_nil loc sv, mk loc ty (Tast.Let ([ (p, sv) ], [ bv ])), none))) | t -> fail v.Ast.loc "%s is %s, which always holds a value, so ?. has nothing to test. \ Write . instead" (source_text v) (tyname loc t) (* ── Places ────────────────────────────────────────────────────────── *) (* The fields a name has, whether it is a struct or an untagged union. The two are one record and differ only in what the offsets come out as, which is a question for the layout and not for this — so [.x] is one path and not two, and a union member is read with the accessor everything else is read with. That is the whole of what makes punning ordinary code. *) (* Every name a value could be standing under here: what is in scope, the globals, the functions — generic ones included, since a call to one is written exactly like a call to any other. No type names: a symbol written where a value goes was not a mistyped struct, and offering one would send the reader to the wrong file. *) and value_candidates ctx = List.map fst ctx.scope @ Hashtbl.fold (fun k _ acc -> k :: acc) ctx.env.globals [] @ Hashtbl.fold (fun k _ acc -> k :: acc) ctx.env.fns [] @ Hashtbl.fold (fun k _ acc -> k :: acc) ctx.env.gsigs [] (* The name nothing answers to, refused with whatever this position can still tell the reader. Two readings get in ahead of the bare refusal. The first is the dot: [p.x] is how C, Go and Odin spell field access and it is the habit everyone arrives with, so a symbol with a dot in it and a lowercase head is almost never a name — it is an accessor written the way the last language wrote it. The head is looked up, so the sentence can say what [p] actually is rather than guess, and the struct's declaration comes along as a note when there is one. Capitalised heads are left alone: [Shape.Circle] is a real spelling in this language and a typo in one is a mistyped case, not a dot-infix habit. The second is the near miss, over values only — see [value_candidates]. *) and unknown_name : 'a. ?setting:bool -> ctx -> Loc.t -> string -> 'a = fun ?(setting = false) ctx loc name -> (* A retired randomness name gets its own sentence and gets it first. It has no dot in it, and the near miss below would answer "did you mean rand?" for [rand-f32] — true and not much use, where the line in [no_such_rand] names the function and spells the call. Everything else falls through to the two readings this was built for. *) (match no_such_rand name with | Some msg -> Loc.failk "check/unknown-name" loc "%s" msg | None -> ()); (* In the indented syntax a binary operator needs spaces, so [x-1], [i+1] and [x/2] are one name each. When the parts either side of an operator character are a value in scope and a number or another value, that is almost certainly the arithmetic, and the sentence says how to spell it. *) (if Source.indented_at loc then begin let known s = s <> "" && (String.for_all (fun c -> (c >= '0' && c <= '9') || c = '.') s || lookup ctx s <> None || Hashtbl.mem ctx.env.globals s) in let n = String.length name in let rec scan i = if i < n - 1 then match name.[i] with | ('-' | '+' | '*' | '/') as c when i > 0 && known (String.sub name 0 i) && known (String.sub name (i + 1) (n - i - 1)) -> Loc.failk "check/unknown-name" loc "unknown name %s — an operator needs a space on each side, so \ this is one name and not arithmetic. Did you mean %s %c %s?" name (String.sub name 0 i) c (String.sub name (i + 1) (n - i - 1)) | _ -> scan (i + 1) in scan 0 end); let dot = String.index_opt name '.' in let head, field = match dot with | Some i when i > 0 && i + 1 < String.length name -> String.sub name 0 i, String.sub name (i + 1) (String.length name - i - 1) | _ -> "", "" in let lower = head <> "" && head.[0] = Char.lowercase_ascii head.[0] && head.[0] <> Char.uppercase_ascii head.[0] in if lower then begin let ty = match lookup ctx head with | Some b -> Some b.bty | None -> Option.map fst (Hashtbl.find_opt ctx.env.globals head) in let sname = match ty with | Some (Types.Named n) when fields_named ctx.env n <> None -> Some n | Some (Types.Ptr (_, (Types.Named n))) when fields_named ctx.env n <> None -> Some n | _ -> None in match sname, ty with | Some sn, _ -> let s = Option.get (fields_named ctx.env sn) in let notes = declared_note ctx.env sn in (* In a [set] the accessor is the *place*, so the spelling to give is [(set (.x p) 1)] and not [(.x p)] on its own. Saying "read" at an assignment would be a sentence that does not apply to the form it is printed under. *) let how = if setting then Printf.sprintf "a field is assigned through an \ accessor, so write (set (.%s %s) ...)" field head else Printf.sprintf "a field is read with an accessor, so write (.%s %s)" field head in if Tast.field_index s field <> None then Loc.failk "check/dot-access" loc ~notes "unknown name %s — %s" name how else Loc.failk "check/dot-access" loc ~notes "unknown name %s — %s, and %s has no field %s" name how sn field | None, Some Types.Dyn -> let how = if setting then Printf.sprintf "(set (.%s %s) ...)" field head else Printf.sprintf "(.%s %s)" field head in Loc.failk "check/dot-access" loc "unknown name %s — a dot is part of the name here, not field access. \ %s is dyn, and its :%s is reached with %s" name head field how | None, Some t -> Loc.failk "check/dot-access" loc "unknown name %s — a dot is part of the name here, not field access. \ A field is reached through an accessor, (.%s %s), and %s is %s, \ which has no fields" name field head head (tyname loc t) | None, None -> Loc.failk "check/unknown-name" loc "unknown name %s — nothing named %s is in scope either. A field is \ reached through an accessor, (.%s %s), not with a dot" name head field head end else (* [x++]: a name may end in +, so the increment of another language reads as one unknown name. *) let n = String.length name in let stem = if n > 2 then String.sub name 0 (n - 2) else "" in let suffix = if n > 2 then String.sub name (n - 2) 2 else "" in if (suffix = "++" || suffix = "--") && List.mem stem (value_candidates ctx) then Loc.failk "check/unknown-name" loc "unknown name %s — to %s %s, write %s" name (if suffix = "++" then "add one to" else "take one from") stem (if Source.indented_at loc then Printf.sprintf "%s(%s) or %s %s= 1" suffix stem stem (String.make 1 suffix.[0]) else Printf.sprintf "(%s %s)" suffix stem) else match nearest (value_candidates ctx) name with | Some m -> Loc.failk "check/unknown-name" loc "unknown name %s — did you mean %s?" name m | None -> Loc.failk "check/unknown-name" loc "unknown name %s" name (* 1st, 2nd, 3rd, and every other one. *) and ordinal n = let suffix = if n mod 100 >= 11 && n mod 100 <= 13 then "th" else match n mod 10 with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th" in string_of_int n ^ suffix (* Check one argument of a call to [name], and if the refusal is the plain type mismatch raised against *this* argument's own span, say the two things the caret cannot: which argument of which function this is, and where the parameter that wanted the other type is declared. The span test is what keeps the claim true. A mismatch deeper inside the argument — an element of a vec literal, an argument of a nested call — is raised against its own location and is re-raised untouched, because calling that "the 2nd argument of add" would be a sentence that reads well and points at the wrong form. The rekind is what stops a nested call from being named twice: once enriched, it is no longer the kind this looks for. *) and check_arg ctx name i (want : Types.t) (a : Ast.expr) = ctx.env.guard_next <- true; match check ctx ~want a with | e -> e | exception Loc.Error d when String.equal d.Loc.kind "check/type-mismatch" && d.Loc.dloc == a.Ast.loc -> let which = ordinal (i + 1) in let notes = match Hashtbl.find_opt ctx.env.fparams name with | Some ps when List.length ps > i -> let p = List.nth ps i in [ Loc.note p.Ast.floc (Printf.sprintf "%s's %s parameter %s is declared %s" (written_name name) which p.Ast.fname (tyname p.Ast.floc want)) ] | _ -> [] in refuse_or_poison ctx.env a.Ast.loc (Loc.diag ~kind:"check/argument-type" ~notes a.Ast.loc (Printf.sprintf "%s — this is the %s argument of %s" d.Loc.dmsg which (written_name name))) | exception Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d and fields_named env n : Tast.structure option = match Hashtbl.find_opt env.structs n with | Some s -> Some s | None -> Hashtbl.find_opt env.unions n (* The target of [.field] is a struct or an untagged union, or one level of pointer to one. The auto-deref is inserted here as a real node, so no backend re-derives it. The target comes checked, because every caller looks first for a dyn, whose [.name] is a map entry and not a field. *) and struct_of ctx (target : Ast.expr) (t : Tast.expr) : Tast.expr * string = let has n = fields_named ctx.env n <> None in (match t.Tast.ty with | Types.Named "String" | Types.Ptr (_, Types.Named "String") -> refuse_string_inside target.Ast.loc | _ -> ()); match t.Tast.ty with | Types.Named n when has n -> t, n | Types.Ptr (_, (Types.Named n)) when has n -> mk t.Tast.loc (Types.Named n) (Tast.Deref t), n (* A data type's fields belong to one case, and which case it is holding is only known after the tag has been read. [.field] would have to be a read that might be reading something else, so it is not one: [match] is how a data type is opened, and it binds the fields it has proved are there. *) | (Types.Named n | Types.Ptr (_, Types.Named n)) when Hashtbl.mem ctx.env.datas n -> fail target.Ast.loc "%s is a data type, and its fields belong to a case — reach them with \ (match ...), whose arms bind the fields of the case they matched" n | other -> (* The pattern bound this, and it looks like a destructuring that did not take: [(match s (Circle c) (.r c))] over a one-field case binds [c] to the payload itself. "f64 is not a struct" is true and is a type fact where the reader needs to be told the value is already in hand. *) (match target.Ast.e with | Ast.Var n -> (match lookup ctx n with | Some { bwhat = Some w; _ } when w = narrowed_tag -> fail target.Ast.loc "%s is tested with %s? above, so here it is what the Option \ holds, %s, and %s has no fields" n n (tyname target.Ast.loc other) (tyname target.Ast.loc other) | Some { bwhat = Some w; _ } when w <> as_tag -> fail target.Ast.loc "%s is %s — the pattern bound it to %s, so the value is already \ in hand and there is no field left to read" n (tyname target.Ast.loc other) w | _ -> ()) | _ -> ()); fail target.Ast.loc "%s is not a struct, so it has no fields" (tyname target.Ast.loc other) (* (at s i) reads a string's byte, and reading is the whole of what a string does here: it is a view of bytes the program does not own — a literal's are in constant storage, where a store is dropped on one backend and faults on the other — so there is no address of one to hand out either. [addr] asks the same question and gets the same answer, so the refusal names taking the address rather than only assigning. It is a function and not a case inside [check_place] because [check_place] is no longer the only way to a [Pindex]: the single-index [set] arm checks its target itself and calls [indexed] directly, and [indexed] accepts a string. Both call this, so neither can drift away from the other. *) and refuse_string_place loc (ty : Types.t) = if Types.equal ty Types.String then fail loc "a string is read-only, so (at s i) is a value and not a place. Copy \ the bytes into a buffer you own and write that" (* Whether a checked place is read-only storage: reached through a [[const T]] or a (Ptr const T), or a byte of a string. Its address is a (Ptr const T). *) and place_const (p : Tast.place) = match p with | Tast.Plocal _ | Tast.Pglobal _ -> false | Tast.Pfield (t, _) -> const_reached t <> None | Tast.Pderef t -> (match t.Tast.ty with Types.Ptr (Types.Const, _) -> true | _ -> false) | Tast.Pindex (t, idx) -> let rec through_string ty n = n > 0 && (match ty with | Types.String -> true | Types.Array (_, e) | Types.Slice (_, e) -> through_string e (n - 1) | _ -> false) in const_steps (const_reached t) t.Tast.ty (List.length idx) <> None || through_string t.Tast.ty (List.length idx) (* Growing, shrinking or freeing a Vec or a Map that is read-only storage. The backends hand the runtime the container's address, so this is the store [check_place] refuses, made through the header instead of through a [set]. Writing into the Vec's own buffer is not refused: the const is shallow. *) and refuse_const_change _ctx loc (target : Tast.expr) = match const_reached target with | None -> () | Some view -> let t = tyname loc target.Tast.ty in let holder = match view with Types.Slice (_, e) | Types.Ptr (_, e) -> e | t -> t in Loc.failk "check/store-through-const" loc "this changes a %s reached through a %s, which can only be read. Where \ it has to change, take the %s it lives in as a [%s] or a (Ptr %s) \ instead" t (tyname loc view) (tyname loc holder) (tyname loc holder) (tyname loc holder) and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = match p with | Ast.Pvar name -> (* Scope first, and the capture refusal only where scope did not settle it. A body's *own* [let] may shadow a name the enclosing function also has, and a store into that one is an ordinary store — asking about the capture before looking would refuse it with a message about a copy that is not the thing being written to. *) (match lookup ctx name with | Some b -> if not b.assignable then begin (* Not assignable, so it is either a parameter or a captured copy. Which one decides the message, and the copy's reason is its own. *) (match List.assoc_opt name ctx.caught with | Some (_, slot) when slot = b.slot -> captured_set ctx loc name | _ -> ()); if b.bwhat = Some as_tag then fail loc "%s names what an as test found, and it cannot be given a new \ value. To change it, copy it into a local first: let %s2 = %s" name name name; fail loc "%s is a parameter, and a parameter is not assignable — bind a \ local with let" name end; if b.bwhat = Some narrowed_tag then (Tast.Pfield (mk loc (Types.Option b.bty) (Tast.Local b.slot), 1), b.bty) else Tast.Plocal b.slot, b.bty | None -> (* Not in scope here at all: a name of the enclosing function, which a lifted body may read as a copy and may not write to. *) captured_set ctx loc name; match Hashtbl.find_opt ctx.env.globals name with | Some (_, true) -> (* Four words, before: the name and the fact, and nothing about what to do or where the decision was made. [no_container_defconst] is the house's own shape for this and the note is [declared_note]'s. A defconst is what the linker writes into the image, so there is no assignment to allow — the fix is the other declaration. *) let notes = match Hashtbl.find_opt ctx.env.global_locs name with | Some at -> [ Loc.note at (name ^ " is declared a constant here") ] | None -> [] in Loc.failk "check/set-constant" loc ~notes "%s is a constant, and a constant is not assignable. Declare it \ with defonce if it has to change" name | Some (ty, false) -> Tast.Pglobal name, ty | None -> unknown_name ~setting:true ctx loc name) | Ast.Pfield (target, name) -> let t = check_target ctx target in if t.Tast.ty = Types.Dyn then begin let x = match target.Ast.e with Ast.Var x -> x | _ -> "x" in if Source.indented_at loc then fail loc "%s.%s is an entry of a dyn map, and has no address. Read it into \ a local: let v = %s.%s" x name x name else fail loc "(.%s %s) is an entry of a dyn map, and has no address. Read it \ into a local: (let [v (.%s %s)] ...)" name x name x end; field_place ~store ctx loc target t name | Ast.Pindex (target, idx) -> let target = check_target ctx target in (match target.Tast.ty with (* The same bounds and epoch check the value form gets, through the same helper: an element of a Vec is a place because a Vec element is assignable, and a set that skipped the checks would be the asymmetry [nth] was removed for. *) | Types.Vec _ -> let p, ty = vec_at ctx loc target idx in Tast.Pderef p, ty | _ -> let idx, ty = indexed ~place:loc ~store ctx target idx in Tast.Pindex (target, idx), ty) | Ast.Pderef target -> let target = check ctx target in (match target.Tast.ty with | Types.Ptr (Types.Const, _) as view when store -> refuse_const_place ctx.env loc view | Types.Ptr (_, t) -> Tast.Pderef target, t | other -> fail loc "deref takes a (Ptr T), found %s" (tyname loc other)) (* Only [set] writes a class slot, and it has its own arm above. A slot lives in a map the collector may move entries of, so it has no address to hand out. *) | Ast.Pslot _ -> fail loc "a class slot (get inst :slot) is written with set and has no address. \ Read it into a local with let" (* The dyn keyword [:name], for a dyn's [.name]. *) and dyn_kw ctx loc name = check ctx ~want:Types.Dyn { Ast.e = Ast.Kw name; loc } (* A struct field as a place, over a target already checked. *) and field_place ~store ctx loc target t name = let target, sname = struct_of ctx target t in let s = Option.get (fields_named ctx.env sname) in 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" (tyname loc (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 (* An index or a slice bound that is a literal is known now, so it is an error now rather than a trap later. Only literals: a [defconst] is a global in the typed IR, not a folded constant, so [(at arr size)] still traps at runtime — which is what the emitted bounds check is for. A negative literal is wrong whatever the target, but a length is static only for [n T]. *) and static_index loc (ty : Types.t) ~past_end what k = if k < 0L then fail loc "%s %Ld is negative — indices count from 0" what k; match ty with (* [past_end] is the difference between an index and a slice bound: the last valid index is len - 1, but a slice may end at len. *) | Types.Array (n, _) when if past_end then k > n else k >= n -> fail loc "%s %Ld is out of bounds for length %Ld" what k n | _ -> () (* The literal value of a checked expression, if it has one. *) and literal (e : Tast.expr) = match e.Tast.e with Tast.Int (k, _) -> Some k | _ -> None (* An index is [i32] internally, but a *narrower* integer may be written as one: indexing is not arithmetic on the value, so there is nothing for a visible cast to warn about, and requiring (i32 c) at every subscript would be noise. A u32 is included because it cannot lose a value the bounds check would then miss — anything above 2^31 truncates to a negative i32, which the unsigned comparison rejects. i64 and u64 are not: 2^32 + 5 truncates to 5 and would read the wrong element with no trap at all, so those need the cast written out. *) and index_expr ctx (e : Ast.expr) = (* No [want]: an expectation of [i32] would reject a [u32] index outright, before there is anything here to convert. An untyped literal still defaults to [i32] on its own. *) let v = check ctx e in match v.Tast.ty with | Types.Int Types.I32 -> v | Types.Int k when Types.bits k <= 32 -> { v with Tast.ty = index_ty; Tast.e = Tast.Prim (Tast.Cast index_ty, [ v ]) } | Types.Int k -> fail e.Ast.loc "an index is an i32, and %s is wider — write (i32 …)" (Types.ikind_name k) | other -> fail e.Ast.loc "an index is an integer, found %s" (tyname e.Ast.loc other) (* [(at a i)] and [(at grid row col)]: one index per dimension. [~place] carries the location of the form being assigned into, and is given by the two callers that are building somewhere to store. It is asked at *every* dimension rather than once about the target: [(at g 0 0)] over a [[2 string]] reaches a string at the last step and nowhere before it, so a question asked only of [g] would miss it. *) and indexed ?place ?(store = true) ctx (target : Tast.expr) (idx : Ast.expr list) = (match place with | Some l when store -> Option.iter (refuse_const_place ctx.env l) (const_steps (const_reached target) target.Tast.ty (List.length idx)) | _ -> ()); let rec go ty = function | [] -> [], ty | i :: rest -> let elem = match ty with | Types.Array (_, t) | Types.Slice (_, t) -> t (* A string indexes to its bytes, and only to read them. *) | Types.String -> if store then Option.iter (fun l -> refuse_string_place l ty) place; Types.Int Types.U8 | Types.Named "String" -> refuse_string_index i.Ast.loc ~store:(store && place <> None) | other -> fail i.Ast.loc "%s cannot be indexed" (tyname i.Ast.loc other) in let loc = i.Ast.loc in let i = index_expr ctx i in (match literal i with | Some k -> static_index loc ty ~past_end:false "index" k | None -> ()); let rest, ty = go elem rest in i :: rest, ty in go target.Tast.ty idx (* ── Calls ─────────────────────────────────────────────────────────── *) and check_call ctx ~want loc (head : Ast.expr) (args : Ast.expr list) = match head.Ast.e with (* The resource notes [Shim] writes into a tracked binding's wrapper; see [res_key]. The reader never produces a name beginning with '%'. *) | Ast.Var (("%res-acquire" | "%res-release") as which) -> (match args with | [ v; { Ast.e = Ast.Str owner; _ } ] -> let v = check ctx v in let sym = if which = "%res-acquire" then "flan_dev_reg_note_res_acquire" else "flan_dev_reg_note_res_release" in expect ctx loc ~want (rt loc Types.Unit sym [ res_key loc ctx.env v; mk loc Types.String (Tast.Str (Types.to_string v.Tast.ty)); mk loc Types.String (Tast.Str owner) ]) | _ -> fail loc "internal: %s takes a local and a name — a compiler bug" which) | Ast.Var "%res-done" -> (match args with | [ { Ast.e = Ast.Str owner; _ } ] -> expect ctx loc ~want (rt loc Types.Unit "flan_dev_reg_note_res_done" [ mk loc Types.String (Tast.Str owner) ]) | _ -> fail loc "internal: %%res-done takes a name — a compiler bug") (* [i32?] where a value goes: the type, not a value. *) | Ast.Var "Option" when fln_source loc && (match args with | [ { Ast.e = Ast.Var n; _ } ] -> lookup ctx n <> None | _ -> false) -> let n = match args with [ { Ast.e = Ast.Var n; _ } ] -> n | _ -> "" in fail loc "%s? reads as the type Option(%s), because a capitalised name before ? \ is taken for a type. To test the local %s, give it a lowercase name, \ as in %s?" n n n (String.uncapitalize_ascii n) | Ast.Var "Option" when fln_source loc -> fail loc "%s is an Option type, and a value is wanted here. On a value that may \ hold nothing, x?.field reads through it, x! unwraps it and x ?? d gives \ a default" (match Loc.snippet loc with Some t -> t | None -> "this") | Ast.Var name -> named_call ctx ~want loc name args (* ((Ptr Color) p): a pointer cast, spelled the way (i32 x) is — the type is the head. It changes what the pointer is said to point at and nothing else, and checks nothing: the caller is promising the bytes are that type, as with [slice-from]. Both backends already lower a Ptr-to-Ptr [Cast] to no instruction. Adding const is allowed; dropping it is not, or a cast would undo the const [addr] put there. The rule is about the outer pointer only: the cast is unchecked, so ((Ptr (Ptr u8)) q) over a (Ptr const (Ptr const u8)) is refused for the outer const but a (Ptr (Ptr const u8)) casts to (Ptr (Ptr u8)) — what lies deeper is the writer's promise, like everything else the cast asserts. There is no cast between a pointer and an integer, and no pointer arithmetic. *) | Ast.Call ({ Ast.e = Ast.Var "Ptr"; _ }, _) when (match type_of_expr head with Some _ -> true | None -> false) -> let target = resolve ctx.env (Option.get (type_of_expr head)) in let spelled = tyname loc target in (match args with | [ a ] -> let a_loc = a.Ast.loc in let spelled_a = spell_arg "p" a in let a = check ctx a in (match a.Tast.ty, target with | Types.Ptr (Types.Const, _), Types.Ptr (Types.Mut, u) -> fail loc "%s is a %s, which cannot be written through, and %s would allow \ writes. Write (%s %s)" spelled_a (tyname loc a.Tast.ty) spelled (tyname loc (Types.Ptr (Types.Const, u))) spelled_a | Types.Ptr _, _ -> expect ctx loc ~want (mk loc target (Tast.Prim (Tast.Cast target, [ a ]))) | (Types.Slice _ | Types.Array _ | Types.String), _ -> fail a_loc "%s converts a pointer, found %s. The address of the first \ element is (addr (at %s 0)); write (%s (addr (at %s 0)))" spelled (tyname loc a.Tast.ty) spelled_a spelled spelled_a | Types.Int _, _ -> fail a_loc "%s converts a pointer, found %s. There is no conversion between \ an integer and a pointer" spelled (tyname loc a.Tast.ty) | Types.Dyn, _ -> fail a_loc "%s converts a pointer, found dyn. A dyn value never holds a \ pointer; give %s a pointer type" spelled spelled_a | other, _ -> fail a_loc "%s converts a pointer, found %s. The address of a place is \ (addr %s); write (%s (addr %s))" spelled (tyname loc other) spelled_a spelled spelled_a) | _ -> fail loc "%s takes one pointer, given %d" spelled (List.length args)) (* A computed head: ((choose k) 3). The head is an ordinary expression and the only thing asked of it is that it be a function. *) | _ -> call_value ctx ~want loc (check ctx head) args (* The indirect call, once the callee is checked. Shared by the computed head above and by a name that resolved to a local or a parameter of function type, which is the shape every caller of [map] has. *) and call_value ctx ~want loc (callee : Tast.expr) args = (* Either function type: calling one is calling the other, and the difference — whether an environment rides along — is the backend's to lower. Nothing here has to know which. *) match fn_sig callee.Tast.ty with | Some (params, ret) -> if List.length args <> List.length params then fail loc "this function value takes %d argument%s, given %d" (List.length params) (if List.length params = 1 then "" else "s") (List.length args); let args = map2_lr (fun p a -> check ctx ~want:p a) params args in expect ctx loc ~want (mk loc ret (Tast.CallPtr (callee, args))) | None -> fail loc "this is a %s and not a function, so it cannot be called" (tyname loc callee.Tast.ty) (* A builtin's arity. The count is the builtin's and can only be the builtin's: a defn of the same name written in the program now takes the call over before any builtin arm is reached ([shadows_builtin] at the top of [named_call]), so a call measured here is a call to the builtin and there is no second signature for the reader to have meant. The note that used to say otherwise — "this is the builtin get, which a defn of the same name does not replace" — described a resolution order this compiler no longer has. *) and arity _ctx loc name n args = if List.length args <> n then fail loc "%s takes %d argument%s, given %d" name n (if n = 1 then "" else "s") (List.length args) (* The operators that take two operands or more: [+ - * /], [min]/[max], the three bitwise combining operators, and the six comparisons. The first ten fold left; the ordered comparisons chain and [!=] asks about every pair, which [cmp_over] and the two pair-pickers under it explain. [%] and the shifts are not in that set — a chain of remainders or of shifts has no reading a reader would agree on in advance, so there the arity error is the useful answer. Two is the floor, and the two missing cases are refused rather than invented. Zero operands would have to mean an identity element, 0 for + and 1 for *, and a sum with no terms in it is a typo far more often than it is an intent. One operand is refused for every operator but [-], whose one operand form is negation and is [named_call]'s. For [/] it would be the reciprocal, and integer division makes that a trap: [(/ 3)] would be 0. A one-operand comparison would have to be [true] — there is no pair to disagree, and nothing for a lone value to be distinct from — and a test that is true whatever it is handed is a typo with a value, which is the worst kind. So it is refused here with the rest. *) and fold_arity loc name args = match args with | _ :: _ :: _ -> () | [ _ ] when String.equal name "/" -> fail loc "/ takes two arguments or more, given 1 — there is no reciprocal; \ write (/ 1.0 x)" | [ _ ] when String.equal name "!=" -> fail loc "!= takes two arguments or more, given 1 — a test for distinctness \ needs something to be distinct from, as in (!= x y)" | [ _ ] when is_comparison name -> fail loc "%s takes two arguments or more, given 1 — a comparison needs a second \ value to compare against, as in (%s x y)" name name | _ -> fail loc "%s takes two arguments or more, given %d" name (List.length args) and is_comparison = function | "=" | "!=" | "<" | "<=" | ">" | ">=" -> true | _ -> false (* The first two operands decide the type — [binary] picks which of them is allowed to, and that decision is not re-made per pair — and every operand after them is checked against it. *) (* The operand, not the form. "[+] takes numbers, found string" with the caret over the whole [(+ "a" "b")] is the exact "whole form vs operand" shape the [check_truthy] work already fixed once: the reader has to find which of the operands is the one being talked about, and the compiler knew. And a text operand gets the extra clause, because [+] on two strings is a reach for concatenation and the answer is a function rather than an operator here. Named without a call shape on purpose: [concat] and [join] take a slice of byte slices and the spelling that builds one from string literals is not a clause in a sentence. *) and not_numeric name what (a : Tast.expr) = let text = match a.Tast.ty with | Types.String -> true | Types.Slice (_, (Types.Int Types.U8)) -> true | _ -> false in let where = a.Tast.loc in if a.Tast.ty = Types.Bool && String.equal what "integers" then bool_bits where name else if a.Tast.ty = Types.Char then char_arith where name else if text then fail where "%s takes %s, and this is %s — there is no %s on text. The prelude \ concatenates with concat and join" name what (tyname where a.Tast.ty) name else fail where "%s takes %s, found %s" name what (tyname where a.Tast.ty) (* What a char refuses: every operator but [+] and [-] with an integer and [-] with a char ([char_step], decision 131). The refusal names the two conversions. *) and char_arith loc name = let fln = fln_source loc in Loc.failk "check/char-arithmetic" loc "%s. Take its code point with %s, and make a char of one with %s" (match name with | "+" -> "+ adds an integer to a char, and not a char to a char" | "-" -> "- takes an integer or a char from a char, and not a char from \ an integer" | _ -> name ^ " does no arithmetic on a char") (if fln then "i32(c)" else "(i32 c)") (if fln then "char(n)" else "(char n)") (* One step of char arithmetic (decision 131, Kotlin's rules): a char plus or minus an integer is a char, checked to be a scalar value — at compile time when both sides are constants, at run time otherwise — and a char minus a char is the distance between them, an integer at the width the site wants (i32 when it wants none), as any integer expression is. A step with no char in it is the ordinary one. Anything else with a char in it is refused. *) and char_step ~want loc name (a : Tast.expr) (b : Tast.expr) : Tast.expr = let i64 e = widen loc dyn_i64 e in let const (e : Tast.expr) = match e.Tast.e with Tast.Int (n, _) -> Some n | _ -> None in let op = if String.equal name "+" then Tast.Add else Tast.Sub in let scalar n = Int64.compare n 0L >= 0 && Int64.compare n 0x10ffffL <= 0 && not (Int64.compare n 0xd800L >= 0 && Int64.compare n 0xdfffL <= 0) in let not_scalar n = Loc.failk "check/char-range" loc "this is %s, which is not a Unicode scalar value, so it is not a \ char. A char is a code point from 0 to 0x10FFFF, outside 0xD800 \ to 0xDFFF" n in let kind = match want with Some (Types.Int k) -> k | _ -> Types.I32 in match a.Tast.ty, b.Tast.ty with | Types.Char, Types.Char when String.equal name "-" -> let t = Types.Int kind in (match const a, const b with | Some x, Some y -> int_literal loc ~want:(Some t) (Int64.sub x y) | _ -> mk loc t (Tast.Prim (Tast.Sub, [ widen loc t a; widen loc t b ]))) | Types.Char, Types.Int k | Types.Int k, Types.Char when not (String.equal name "-" && b.Tast.ty = Types.Char) -> let c, n = if a.Tast.ty = Types.Char then a, b else b, a in (match const c, const n with (* A u64 past the largest i64 is held as a negative i64: no char. *) | Some _, Some v when k = Types.U64 && Int64.compare v 0L < 0 -> not_scalar (Printf.sprintf "past 0x10FFFF") | Some x, Some y -> let r = if op = Tast.Add then Int64.add x y else Int64.sub x y in if scalar r then mk loc Types.Char (Tast.Int (r, Types.U32)) else not_scalar (Int64.to_string r) (* The runtime takes the integer as itself — a u64 unsigned, anything else as an i64 — and checks the sum for overflow, so no large one wraps round to a char or to a wrong number in the trap. *) | _ -> rt loc Types.Char (if k = Types.U64 then "flan_char_step_u64" else "flan_char_step_i64") [ widen loc (Types.Int Types.I32) c; (if k = Types.U64 then n else i64 n); mk loc (Types.Int Types.I32) (Tast.Int ((if op = Tast.Sub then 1L else 0L), Types.I32)); here loc ]) | _ -> char_arith (if a.Tast.ty = Types.Char then a.Tast.loc else b.Tast.loc) name; assert false (* Whether [e] may be a char, read off its form without checking it: a name bound to one, a (char n), a function returning one, or [+]/[-] over any of those. What decides whether a [+] or [-] is checked as char arithmetic before the want of its site reaches its operands. A char literal is not on the list: beside a number it is that number. *) and maybe_char ctx (e : Ast.expr) = match e.Ast.e with | Ast.Var n -> (match lookup ctx n with | Some b -> b.bty = Types.Char | None -> match peek_outer ctx n with | Some b -> b.bty = Types.Char | None -> (match Hashtbl.find_opt ctx.env.globals n with | Some (t, _) -> t = Types.Char | None -> false)) | Ast.Call ({ Ast.e = Ast.Var "char"; _ }, [ _ ]) -> true | Ast.Call ({ Ast.e = Ast.Var ("+" | "-"); _ }, args) -> List.exists (maybe_char ctx) args | Ast.Call ({ Ast.e = Ast.Var f; _ }, _) -> (match Hashtbl.find_opt ctx.env.fns f with | Some (_, r) -> r = Types.Char | None -> false) | _ -> false (* ── A conversion whose operand is a type variable ───────────────────── [(i32 x)] where [x] is a [$t]. The concrete question — is this a number — has no answer during the abstract pass, and asking it anyway is what refused [(i32 (at xs i))] inside a body bounded [is-integer]. The question the bound can answer is the one asked here: does what the [where] clause declares about the variable entail the predicate this conversion needs. Which predicate that is comes from the *target*, and the rule is the concrete arm's rule read off a set rather than a type: a conversion legal at every type the bound admits is legal at the variable, and one illegal at any of them is refused. A number target needs [is-numeric] — every type it admits converts to every numeric target today, truncating or rounding by the same rule a written f64 follows. An enum target needs [is-integer], because [is-numeric] admits f32 and f64 and a float has no enum reading. [is-ordered], [is-equal] and [is-hashable] are refused: they say what can be compared, not what is a number, and nothing about a bound that only orders says a conversion means anything. That they happen to admit only numbers and enums today is a fact about [Types.is_comparable], not about what the predicate claims — keying conversions to it would make widening [is-ordered] to strings a silent change to what converts. The message says what the variable is known to be and what to write. Both spellings compile as written, and the clause spelling is [unconstrained]'s so that the family says it one way: a body with no clause is given the whole clause, and a body that already has one is told which predicate to add rather than a clause that would drop the ones it has. *) and cast_operand ctx loc name ~needs ?also ~what ~is v = if declares ctx.env.tvpreds v needs || (match also with | Some (p, _) -> declares ctx.env.tvpreds v p | None -> false) then () else (* A conversion two bounds license is refused naming both, since which one the reader meant is theirs to say. *) let is = match also with Some (_, is') -> is ^ " or " ^ is' | None -> is in let declared = List.filter_map (fun (p : Ast.pred) -> if String.equal p.Ast.pvar v then Some p.Ast.pname else None) ctx.env.tvpreds in let known = match declared with | [] -> Printf.sprintf "Nothing here says %s is %s" v is | ps -> Printf.sprintf "The where clause says %s is %s, and that does not make it %s" v (String.concat " and " (List.map pred_word ps)) is in let fix = let alt clause = match also with | Some (p, is') -> Printf.sprintf ", or %s for %s" (Printf.sprintf clause p v) is' | None -> "" in if ctx.env.tvpreds = [] then Printf.sprintf "write %s at the head of the body%s" (where_text loc needs ("$" ^ v)) (if Source.indented_at loc then alt "where %s($%s)" else alt "{:where (%s $%s)}") else if Source.indented_at loc then Printf.sprintf "add %s($%s) to the where clause%s" needs v (alt "%s($%s)") else Printf.sprintf "add (%s $%s) to the where clause%s" needs v (alt "(%s $%s)") in Loc.failk "check/unconstrained-type-variable" loc "%s converts %s. %s — %s" name what known fix and fold_left_prim ctx ~want loc name p ~needs ok what args = refuse_kept_when ctx name args; let x, y, rest = match args with x :: y :: rest -> x, y, rest | _ -> assert false in let charish = String.equal name "+" || String.equal name "-" in let nwant = numeric_want want in (* A char literal is a char here, not the number, when no number is wanted; one that may be a char by its form keeps the want off the pair, which a char minus a char answers at the want's width itself. *) let int_lit (e : Ast.expr) = match e.Ast.e with Ast.Int _ -> true | _ -> false in (* A char literal later in the chain is a char only while everything before it is an integer literal too; beside a typed number it is that number, as in (+ b c \0) over bytes. *) let untyped = ref (int_lit x && int_lit y) in let char_lit (e : Ast.expr) = match e.Ast.e with Ast.Byte _ -> nwant = None && !untyped | _ -> false in let a, b = try (match x.Ast.e, y.Ast.e with | Ast.Int _, Ast.Byte _ when charish && nwant = None -> raise_notrace (Char_pair (check ctx x, check ctx y)) | _ -> ()); let pwant = if charish && (maybe_char ctx x || maybe_char ctx y) then None else nwant in char_operands ctx ~charish name [ x; y ] (fun () -> binary ctx ~dyn_ok:true ~char_ok:charish name loc ~want:pwant [ x; y ]) with Char_pair (a, b) -> a, b in (* One dyn operand makes the whole fold dyn, whichever side it is on. The typed side is boxed by [dyn_fold]; a literal was already built at dyn by [binary], so [(+ x 1)] over a dyn x folds an i64 one. *) let is_char (e : Tast.expr) = e.Tast.ty = Types.Char in if charish && a.Tast.ty <> Types.Dyn && b.Tast.ty <> Types.Dyn && (is_char a || is_char b || List.exists (maybe_char ctx) rest || (let rec any = function | [] -> false | r :: tl -> char_lit r || (untyped := !untyped && int_lit r; any tl) in let was = !untyped in let r = any rest in untyped := was; r)) then (* Left to right, each step char arithmetic when a char is in it and the ordinary join when none is: (- \z \a 1) is 25 - 1, and (+ 1 2 \a) is 3 + \a. *) let rec steps acc = function | [] -> expect ctx loc ~want acc | (arg : Ast.expr) :: tl -> let lit = char_lit arg in untyped := !untyped && int_lit arg; if is_char acc || maybe_char ctx arg || lit then let v = check ctx arg in if v.Tast.ty = Types.Dyn then dyn_fold ctx ~want loc name [ acc; v ] tl else if is_char acc || is_char v then steps (char_step ~want:nwant loc name acc v) tl else match fold_operand ctx acc.Tast.ty (expect ctx arg.Ast.loc ~want:(Some acc.Tast.ty) v) with | `Typed v -> steps (mk loc acc.Tast.ty (Tast.Prim (p, [ acc; v ]))) tl | `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl else match fold_arg ctx acc.Tast.ty arg with | `Typed v -> steps (mk loc acc.Tast.ty (Tast.Prim (p, [ acc; v ]))) tl | `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl in let first = if is_char a || is_char b then char_step ~want:nwant loc name a b else mk loc a.Tast.ty (Tast.Prim (p, [ a; b ])) in steps first rest else if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then dyn_fold ctx ~want loc name [ a; b ] rest else begin (* [~needs] is the operator's own bound: [is-numeric] for the arithmetic, [is-integer] for the bitwise fold. Asking the tighter question here is what keeps a bitwise body's refusal at the *definition* — under [is-numeric] the abstract pass admitted [(bit-and x 1)] and the refusal arrived from inside the generic's source at whichever call site first instantiated at a float, which is the misplaced diagnostic the pass exists to avoid. *) unconstrained ctx.env loc name ~needs a.Tast.ty; (* Past [unconstrained] a variable here is one the [where] clause admitted, so the concrete predicate below has nothing to say about it — it is answered again, per copy, at the instantiation. *) if not (ok a.Tast.ty || generic_ty a.Tast.ty) then not_numeric name what a; let ty = a.Tast.ty in let rec steps acc = function | [] -> expect ctx loc ~want acc | arg :: tl -> match fold_arg ctx ty arg with | `Typed v -> steps (mk loc ty (Tast.Prim (p, [ acc; v ]))) tl | `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl in steps (mk loc ty (Tast.Prim (p, [ a; b ]))) rest end (* An operand past a fold's first pair, checked at the type so far. A dyn one is taken back as the dyn it was, not opened at that type: a typed operand beside a dyn gives dyn (rule 117), so from there on the fold is the dyn runtime's, and (+ 1 2 d) is (+ 3 d). *) and fold_operand ctx ty (v : Tast.expr) = if v.Tast.ty = Types.Dyn && not (Types.equal ty Types.Dyn) then `Dyn v else match opened_dyn ~box:(to_dyn ctx) v with | Some d -> `Dyn d | None -> `Typed v (* An operand past a fold's first pair, from the source: at the type so far, and on its own terms only when that is refused, as [binary_pair] checks the second of the pair. A dyn it turns out to be joins the fold as a dyn, so (+ 1 2 (the dyn nil)) traps at run time as (+ (the dyn nil) 1 2) does instead of being refused for a nil with no value at i32, and a dyn beside a [$t] is not opened at the variable. Anything else is checked at the type again, for real, so its refusal is the one it always gave and recovery records it. *) and fold_arg ctx ty (arg : Ast.expr) = match trial_at ctx arg ty with | Ok v -> fold_operand ctx ty v | Error _ -> (* Only asked, and asked with the literal locals' uses unrecorded: a [trial] does not take back what the session recorded, and the operand on its own terms is not how the program reads it unless it is a dyn — (+ x y) over an int x and a float y would merge the two and move the refusal onto x. A dyn is then checked again, recorded. *) let unrecorded f = match ctx.lits with | Some s when s.recording -> s.recording <- false; Fun.protect ~finally:(fun () -> s.recording <- true) f | _ -> f () in let is_dyn = probe ctx arg.Ast.loc (fun () -> unrecorded (fun () -> (check ctx arg).Tast.ty)) = Some Types.Dyn in if is_dyn then `Dyn (to_dyn ctx (check ctx arg)) else fold_operand ctx ty (check ctx ~want:ty arg) (* A pair an arithmetic operator refused, when one operand is a char: that is the refusal to give, rather than the mismatch between the two. Asked only after the refusal, so a pair that checks costs nothing more. *) and char_operands ctx ?(charish = false) name (args : Ast.expr list) f = try f () with Loc.Error _ as ex -> (* [+] and [-] take a char beside an integer (decision 131): the pair is read again on its own terms, and [char_step] decides. *) let own () = List.map (fun a -> trial ctx (fun () -> check ctx a)) args in (match charish, args with | true, [ x; y ] -> (match own () with | [ Ok a; Ok b ] when (a.Tast.ty = Types.Char && (Types.is_integer b.Tast.ty || b.Tast.ty = Types.Char)) || (b.Tast.ty = Types.Char && Types.is_integer a.Tast.ty) -> raise_notrace (Char_pair (check ctx x, check ctx y)) | _ -> ()) | _ -> ()); (* A char literal beside a number is that number, so it says nothing unless every operand is a literal. *) let all_lit = List.for_all is_literal args in List.iter (fun (a : Ast.expr) -> let lit = match a.Ast.e with Ast.Byte _ -> true | _ -> false in if all_lit || not lit then match trial ctx (fun () -> check ctx a) with | Ok e when e.Tast.ty = Types.Char -> char_arith a.Ast.loc name | _ -> ()) args; raise ex (* An operand is kept, so a form with no else at its end — a [when], a [cond] or an [if]/[if let] chain with no final else, or a [do] or [let] ending in one — answers an Option there. Beside a number that is refused at the form itself, before the operands are checked against each other, where the number beside it would be blamed instead. One over a dyn answers a dyn, and that is left to the operator. *) and refuse_kept_when ctx name (args : Ast.expr list) = (* The form with no else, found at the end of [a]. *) let rec else_less (a : Ast.expr) = match a.Ast.e with | Ast.If (_, _, None) | Ast.IfLet (_, _, None) -> Some a | Ast.If (_, _, Some e) | Ast.IfLet (_, _, Some e) -> if open_tail e then Some a else None | Ast.Do (_ :: _ as xs) | Ast.Let (_, (_ :: _ as xs)) -> else_less (List.nth xs (List.length xs - 1)) | _ -> None and open_tail (e : Ast.expr) = match e.Ast.e with | Ast.Do [] -> true | _ -> else_less e <> None in let ty (a : Ast.expr) = probe ctx a.Ast.loc (fun () -> (check ctx a).Tast.ty) in let number (a : Ast.expr) = match a.Ast.e with | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true | _ when else_less a <> None -> false | _ -> (match ty a with Some t -> Types.is_numeric t | None -> false) in List.iter (fun (a : Ast.expr) -> match else_less a with | Some form -> (match ty a with | Some (Types.Option _ as t) when List.exists (fun b -> b != a && number b) args -> let fln = fln_source form.Ast.loc in let what = match form.Ast.e with | Ast.If (_, _, None) -> if fln then "if without an else" else "when" | Ast.IfLet _ -> "if let without an else" | _ -> if fln then "if chain without an else" else "chain without an else" in Loc.failk "check/kept-when" form.Ast.loc "this %s is an operand of %s, so its value is kept, and there it \ gives %s: Some of its value when a test holds, None when none \ does. The other side is a number. Give it an else, or unwrap \ what it gives with match" what name (tyname form.Ast.loc t) | _ -> ()) | None -> ()) args (* The dyn lowering of a fold: one call per operator application, left to right, each taking and answering a dyn word. The typed side of a mixed pair is boxed on the way in — [box] is the identity on something already dyn, so this needs no case analysis of its own. *) and dyn_fold ctx ~want loc name first rest = let sym = match name with | "+" -> "flan_dyn_add" | "-" -> "flan_dyn_sub" | "*" -> "flan_dyn_mul" | "/" -> "flan_dyn_div" | "%" -> "flan_dyn_rem" | "min" -> "flan_dyn_min" | "max" -> "flan_dyn_max" | _ -> dyn_bits_sym name in (* A bitwise fold takes integers on both sides, and the typed side of a mixed pair can be asked now rather than at run time. *) let bitwise = not (List.mem name [ "+"; "-"; "*"; "/"; "%"; "min"; "max" ]) in if bitwise then List.iter (fun (v : Tast.expr) -> if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v) first; (* The site travels with the operands. A dyn arithmetic trap is this language's type error, and until now it printed with no file, no line and no column — [here loc] is the same string literal [cast_dyn] hands the runtime, and the runtime prints it as a GNU prefix. *) let apply acc b = rt loc Types.Dyn sym [ acc; box ~ctx loc b; here loc ] in let operand arg = if bitwise then begin let v = check ctx arg in if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v; v end else check ctx ~want:Types.Dyn arg in let rest = map_lr operand rest in no_bare_nil (first @ rest); let acc = match first with | [ a; b ] -> apply (box ~ctx loc a) b | _ -> assert false in let acc = List.fold_left apply acc rest in expect ctx loc ~want acc (* The runtime's entry point for each bit operation on a dyn int. *) and dyn_bits_sym name = match name with | "bit-and" -> "flan_dyn_bitand" | "bit-or" -> "flan_dyn_bitor" | "bit-xor" -> "flan_dyn_bitxor" | "bit-not" -> "flan_dyn_bitnot" | "<<" -> "flan_dyn_shl" | ">>" -> "flan_dyn_shr" | "rotate-left" -> "flan_dyn_rotl" | "rotate-right" -> "flan_dyn_rotr" | "popcount" -> "flan_dyn_popcount" | "leading-zeros" -> "flan_dyn_clz" | "trailing-zeros" -> "flan_dyn_ctz" | _ -> invalid_arg ("dyn_bits_sym " ^ name) (* An operand of a bit operation, once it is known not to be dyn: an integer, or a type variable the where clause bounds by [is-integer]. A bool is the likeliest thing to arrive here — [a && b] is logical and in C — so it is answered with the operator that does what was meant. *) and bits_operand ctx loc name (v : Tast.expr) = match v.Tast.ty with | Types.Int _ -> () | t when generic_ty t -> unconstrained ctx.env loc name ~needs:"is-integer" t | Types.Bool -> bool_bits v.Tast.loc name | Types.Char -> char_arith v.Tast.loc name | other -> fail loc "%s takes integers, found %s" name (tyname loc other) (* A bool operand is refused before the operands are joined, and not left to [bits_operand]: the join sees a bool beside an integer as a plain mismatch, "expected i32, found bool", which says nothing of [and]. Each operand's own type is asked in a trial that is always abandoned, so the check leaves no trace — no slot, no lifted lambda, no recorded refusal — and the real check below is the only one that counts. A literal is never a bool, and a call to an arithmetic or bit operator answers a number or a dyn, so neither is asked. Nor is anything asked while a probe is running: the probe wants a type, and asking again inside it would check a nest of these once per level for every level above it, which doubles with each level. *) and bool_operands ctx name (args : Ast.expr list) = if not !probing then let never_bool (a : Ast.expr) = match a.Ast.e with | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ -> true | Ast.Call ({ Ast.e = Ast.Var h; _ }, _) -> List.mem h [ "+"; "-"; "*"; "/"; "%"; "bit-and"; "bit-or"; "bit-xor"; "bit-not"; "&&"; "||"; "^^"; "~~"; "<<"; ">>"; "rotate-left"; "rotate-right"; "popcount"; "leading-zeros"; "trailing-zeros" ] && not (shadows_builtin ctx a.Ast.loc h) | _ -> false in let is_bool (a : Ast.expr) = (not (never_bool a)) && let ty = ref None in probing := true; Fun.protect ~finally:(fun () -> probing := false) (fun () -> ignore (trial ctx (fun () -> let v = check ctx a in ty := Some v.Tast.ty; Loc.failk "check/probe" a.Ast.loc "abandoned"))); !ty = Some Types.Bool in List.iter (fun a -> if is_bool a then bool_bits a.Ast.loc name) args and bool_bits loc name = let fln = fln_source loc in let shown = if not fln then name else match name with | "bit-and" -> "&&" | "bit-or" -> "||" | "bit-xor" -> "^^" | "bit-not" -> "~~" | n -> n in let logic = match name with | "bit-and" -> Some (if fln then "a and b" else "(and a b)") | "bit-or" -> Some (if fln then "a or b" else "(or a b)") | "bit-xor" -> Some (if fln then "a != b" else "(!= a b)") | "bit-not" -> Some (if fln then "not a" else "(not a)") | _ -> None in Loc.failk "check/bits-of-bool" loc "%s works on the bits of an integer, and this is a bool. %s" shown (match logic with | Some l -> Printf.sprintf "For true and false, write %s" l | None -> "True and false are combined with and, or and not") (* A comparison over three operands or more asks about more than one pair, and every operand is bound to a slot before any pair is looked at. That is what makes "left to right, exactly once" true of the lowering and not only of the source: an operand two pairs name is written down once. The spelling a reader would reach for, [(and (< a b) (< b c))], evaluates b twice, which is wrong the moment b is a call — that is the whole reason this is a form the compiler builds rather than a macro. The pairs are then required to hold, and the conjunction stops at the first one that does not. That costs nothing observable, because by the time any pair is compared every operand has already been evaluated — stopping skips a machine compare, never a call. [pairs] says which pairs this operator asks about and [link] builds one comparison, so the two readings below and the dyn lowering of each are the same code with two arguments changed. *) and cmp_over ctx loc ty ~pairs ~link ops = let binds = List.map (fun (e : Tast.expr) -> fresh_slot ctx ty, e) ops in let locals = List.map (fun (s, _) -> mk loc ty (Tast.Local s)) binds in let rec conj = function | [ t ] -> t | t :: rest -> mk loc Types.Bool (Tast.If (t, conj rest, mk loc Types.Bool (Tast.Bool false))) | [] -> assert false in let tests = List.map (fun (a, b) -> link a b) (pairs locals) in mk loc Types.Bool (Tast.Let (binds, [ conj tests ])) (* The ordered comparisons chain: [(< a b c)] asks whether a is below b and b is below c. The other reading, the left fold [(< (< a b) c)], compares a bool against a number, and there is no program that meant it. So the pairs are the adjacent ones, n-1 of them, and the operand in the middle is the one two of them share. *) and adjacent_pairs xs = match xs with | a :: (b :: _ as rest) -> (a, b) :: adjacent_pairs rest | _ -> [] (* [!=] is the one that does not chain. "Is this sequence increasing" and "are these values all different" are different questions, and only the first is about adjacent pairs: under chaining [(!= 1 2 1)] would be true, because each neighbour differs from the next, while the thing anyone means by it is false. So [!=] asks about *every* pair — Common Lisp's [/=] — which is n(n-1)/2 comparisons rather than n-1. That growth is fine at the sizes anyone writes: four operands is six compares of values already in slots. It is also invisible to every program there is today, because two operands is one pair either way and does not come through here at all. *) and all_pairs xs = match xs with | [] -> [] | x :: rest -> List.map (fun y -> (x, y)) rest @ all_pairs rest (* ── Allocation failure, spec-memory.md ──────────────────────────────── No allocating operation returns an error and none can fail silently. When the allocator cannot satisfy a request the operation signals (StorageExhausted {.bytes n .align a .allocator id}) with [error] — whose type is Never — inside a [restart-case] offering [retry]. That is one rule over every allocating operation, which is what keeps [push] and [reserve] at Unit, [clone] at the container, and no signature anywhere growing a Result. Odin's [append] returns an ignorable Allocator_Error and its type-erased path returns the old length on a failed reserve; an append that appends nothing and says nothing is the outcome this rule exists to make impossible. It is *compiler-emitted at the point of failure*, which spec-memory.md names as the exception to plan.org's "restarts go at the resync point, once": a restart established at a parser's top-level loop cannot re-attempt an allocation, and only the allocation site can. The shape is built out of nodes that already exist — a while, a restart-case and an error — so the backend learns nothing new about allocation: (let [ok false] (while (not ok) (restart-case (do (set ok ATTEMPT) (if (not ok) (error (StorageExhausted {...})))) (retry [])))) A handler that frees something, releases a scratch region or grows the arena and then invokes [retry] lands in the clause, the clause falls through, and the while re-tests and re-attempts the *same* request. With nothing handling it, [error] stops the program on the frame that erred, as §2 says. [attempt] must be a call that can be repeated: every argument to it is bound to a slot before the loop, so a retry does not re-evaluate the element expression a push was given. *) and alloc_guard ctx loc (attempt : Tast.expr) = let ok = fresh_slot ctx Types.Bool in let okv = mk loc Types.Bool (Tast.Local ok) in let notok () = mk loc Types.Bool (Tast.Prim (Tast.Not, [ okv ])) in let i8 n = mk loc (Types.Int Types.I8) (Tast.Int (n, Types.I8)) in (* The runtime answers 1 or 0 and never reports failure any other way. *) let attempt = mk loc Types.Bool (Tast.Prim (Tast.Ne, [ attempt; i8 0L ])) in (* A value struct on the signalling frame's stack, with fixed numeric fields and no rendered message: formatting would allocate, and this is the one path that must not. Rendering happens in the handler or the break loop, where a working allocator is known. *) let cond = mk loc (Types.Named "StorageExhausted") (Tast.Make ("StorageExhausted", [ rt loc (Types.Int Types.I64) "flan_alloc_fail_bytes" []; rt loc (Types.Int Types.I64) "flan_alloc_fail_align" []; rt loc (Types.Int Types.I64) "flan_alloc_fail_id" [] ])) in let signal = mk loc Types.Never (Tast.Signal (Tast.Serror, condition_desc ctx loc "StorageExhausted", cond)) in let attempt_then_signal = mk loc Types.Unit (Tast.Do [ mk loc Types.Unit (Tast.Set (Tast.Plocal ok, attempt)); mk loc Types.Unit (Tast.If (notok (), signal, unit_at loc)) ]) in let clause = (* Compiler-emitted, so it takes no parameters: nothing outside can hand this one a value. [rsig] is therefore the empty signature, and its hash the same one a written [(retry [] ...)] gets — the two must agree, since an [invoke-restart] cannot tell them apart. *) let sg = restart_sig [] in { Tast.rname_id = type_id "retry"; rname = "retry"; rparams = []; rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ]; rloc = loc; rreport = "Try the allocation again"; rhidden = false } in let body = mk loc Types.Unit (Tast.RestartCase ([ clause ], attempt_then_signal)) in mk loc Types.Unit (Tast.Let ([ (ok, mk loc Types.Bool (Tast.Bool false)) ], [ mk loc Types.Unit (Tast.While (notok (), [ body ], [])) ])) (* ── File failure, decisions 2 and 5 ─────────────────────────────────── The same shape [alloc_guard] has, for the same reason and out of the same nodes: the operation signals inside a [restart-case] it establishes itself, so nothing anywhere grows a Result and neither [slurp] nor [barf] can fail silently. Compiler-emitted at the point of failure, which spec-memory.md already names as the exception to plan.org's "restarts go at the resync point, once" — a restart at an outer loop cannot re-open a file. Two restarts, and they are the textbook pair Common Lisp establishes for a file-error: retry the file may be there now — the handler made a directory, mounted something, or waited. use-value [p string] try this other path instead. [use-value]'s parameter *is* the path slot, so the clause body is [unit]: emit.ml's [bind_params] stores the invoker's argument straight into the slot the attempt reads, the clause falls through, and the while re-tests and re-attempts against the new path. Typed restarts landed this session and this is the first thing the compiler itself emits one for. [attempt] must be repeatable, so the path is a slot read at each turn of the loop rather than an expression re-evaluated. *) and file_guard ctx loc ~path_slot ~op mk_steps = let ok = fresh_slot ctx Types.Bool in let okv = mk loc Types.Bool (Tast.Local ok) in let notok () = mk loc Types.Bool (Tast.Prim (Tast.Not, [ okv ])) in let i8 n = mk loc (Types.Int Types.I8) (Tast.Int (n, Types.I8)) in (* Fixed fields and no rendered message, exactly as StorageExhausted: the condition is built on the failing frame's stack and formatting is the handler's job. [path] is whatever the attempt last used, so a handler that supplied one through [use-value] sees the path that actually failed. *) let cond = mk loc (Types.Named "FileError") (Tast.Make ("FileError", [ mk loc Types.String (Tast.Local path_slot); mk loc (Types.Int Types.I32) (Tast.Int (Int64.of_int op, Types.I32)); mk loc (Types.Int Types.I32) (Tast.Prim (Tast.Cast (Types.Int Types.I32), [ rt loc (Types.Int Types.I64) "flan_file_fail_reason" [] ])) ])) in let signal () = mk loc Types.Never (Tast.Signal (Tast.Serror, condition_desc ctx loc "FileError", cond)) in (* One step of the attempt: run the runtime call, record whether it worked, and signal if it did not. The last step a caller gives is what leaves [ok] true, which is what stops the loop. *) let try_ (attempt : Tast.expr) = mk loc Types.Unit (Tast.Do [ mk loc Types.Unit (Tast.Set (Tast.Plocal ok, mk loc Types.Bool (Tast.Prim (Tast.Ne, [ attempt; i8 0L ])))); mk loc Types.Unit (Tast.If (notok (), signal (), unit_at loc)) ]) in let clause name report params = let sg = restart_sig (List.map snd params) in { Tast.rname_id = type_id name; rname = name; rparams = params; rsig = sg; rsig_id = type_id sg; rbody = [ unit_at loc ]; rloc = loc; rreport = report; rhidden = false } in let body = mk loc Types.Unit (Tast.RestartCase ([ clause "retry" "Try the file operation again" []; clause "use-value" "Try again with another path" [ (path_slot, Types.String) ] ], mk loc Types.Unit (Tast.Do (mk_steps try_)))) in mk loc Types.Unit (Tast.Let ([ (ok, mk loc Types.Bool (Tast.Bool false)) ], [ mk loc Types.Unit (Tast.While (notok (), [ body ], [])) ])) (* Is this bare symbol the name of a type? Every table [resolve_name] will look in, and the data type table is one of them: a data type is [Named] exactly as a struct is, so (vec-new Form) is as ordinary as (vec-new Cell). It was left out when data types landed, which made the prelude's own (vec-new Form) fail with "nothing here says what (vec-new) is a Vec of" — a message about a missing annotation for a program that had written one. One list, read by both callers, so the next kind of type added cannot be added to one of them. *) (* A global value that a bare name in a type position would reach instead of a type. A type variable in scope is not shadowed by one: the prelude's generics write [(vec-new t)], and a program's [(defonce t ...)] must not change what the prelude means. *) and global_value ctx n = Hashtbl.mem ctx.env.globals n && not (tyvar_in_scope ctx.env 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 ~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 | _ -> false) and type_named ctx n = (* A type variable names a type here too, which is what lets [(vec-new t)] and [(vec-new $t)] be written in a generic body: inside an instantiation [resolve_name] answers with the concrete element type, and during the abstract pass it answers [Var t] and the [Vec] that comes back is a [(Vec t)] — generic, and refused by anything that needs a size. *) tyvar_in_scope ctx.env n (* A sigil is only ever written where a type goes, so a name carrying one is answered here even when nothing binds it: [resolve_name] then says that a variable has no binding site outside a defn signature, which is the mistake, instead of this form reporting a missing element type. *) || n <> tyvar_bare n || List.mem n Types.primitive_names (* Answered as a type so [resolve_name] says it is spelled [str], rather than this form saying no element type was written. *) || n = "string" || Hashtbl.mem ctx.env.structs n || Hashtbl.mem ctx.env.datas n || Hashtbl.mem ctx.env.unions n || Hashtbl.mem ctx.env.enums n || Hashtbl.mem ctx.env.aliases n (* A local or global that shares a type's name — [str] is a common name for text — is the binding in (vec-new str), and then nothing names the type. Said here so the refusal names the binding rather than a missing type. *) and shadowed_type_arg ctx loc what args = match args with | { Ast.e = Ast.Var n; _ } :: _ when type_named ctx n && (lookup ctx n <> None || global_value ctx n) -> fail loc "%s here is the value named %s and not the type, so nothing says what \ (%s) makes — rename that binding to write the type" n n what (* [vec-new(grain?)] for a lowercase type: where a value is written, ? after anything but a capitalised or primitive name is the test [x?]. *) | { Ast.e = Ast.Call ({ Ast.e = Ast.Var "?"; _ }, [ { Ast.e = Ast.Var n; _ } ]); _ } :: _ when type_named ctx n && lookup ctx n = None && not (global_value ctx n) -> fail loc "%s? here is the test that a value is present, and %s is a type. Where a \ value is written, the Option of a type is Option(%s): %s(Option(%s))" n n n what n | _ -> () (* The element type for [vec-new]: a leading bare symbol naming a type, a leading type expression — [(vec-new [u8])], [(vec-new (Ptr Cell))], which Parse has already read as one — or the expectation at the site. A bare symbol shadowed by a local or a global is that binding — an allocator, in practice — and not a type. *) and vec_new_elem ctx ~want loc args = let named = match args with | 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) | _ -> None in match named with | Some (t, rest) -> t, rest | None -> (match want with | Some (Types.Vec t) -> t, args | _ -> shadowed_type_arg ctx loc "vec-new" args; fail loc "nothing here says what (vec-new) is a Vec of — write the element \ type, as (vec-new i32)") (* A type written as an argument to vec-new or map-new, read back out of the expression Parse made of it. Only the shapes that cannot be a value there: 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 ?(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 ~generic e in let all es = let ts = List.filter_map inner es in if List.length ts = List.length es then Some ts else None in match e.Ast.e with | Ast.TypeArg t -> Some t (* Before the [[n T]] arm below, which would read [const] as a length. *) | Ast.Arr [ { Ast.e = Ast.Var "const"; _ }; x ] -> Option.map (fun t -> mk (Ast.Tslice (true, t))) (inner x) | Ast.Arr [ x ] -> Option.map (fun t -> mk (Ast.Tslice (false, t))) (inner x) | Ast.Arr [ { Ast.e = Ast.Int n; _ }; x ] -> Option.map (fun t -> mk (Ast.Tarray (Ast.Lint n, t))) (inner x) | Ast.Arr [ { Ast.e = Ast.Var n; _ }; x ] -> Option.map (fun t -> mk (Ast.Tarray (Ast.Lname n, t))) (inner x) | Ast.Call ({ Ast.e = Ast.Var (("Fn" | "CFn") as which); _ }, [ { Ast.e = Ast.Arr ps; _ }; r ]) -> (match all ps, inner r with | Some ps, Some r -> Some (mk (Ast.Tfn (which = "Fn", ps, r))) | _ -> None) | 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. *) and map_kv loc what (t : Types.t) = match t with | Types.Map (k, v) -> k, v | other -> fail loc "%s takes a (Map K V), found %s" what (tyname loc other) (* The key and value for [map-new]: two leading bare symbols naming types, or the expectation at the site. The same rule [vec-new] uses, with the same escape for a symbol that is really a binding — an allocator, in practice — and the pair is written together or not at all, because (map-new str) says half of a type and half is not a type. *) and map_new_types ctx ~want loc args = let is_type n = lookup ctx n = None && not (global_value ctx n) && type_named ctx n in (* 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 ~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 in 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 ~generic:(Hashtbl.mem ctx.env.gstructs) a <> None -> fail loc "(map-new) names a key and no value — write both, as (map-new str \ i32)" | { Ast.e = Ast.Var k; _ } :: rest when is_type k && rest = [] -> fail loc "(map-new %s) names a key and no value — write both, as (map-new %s \ i32)" k k | _ -> (match want with | Some (Types.Map (k, v)) -> k, v, args | _ -> shadowed_type_arg ctx loc "map-new" args; fail loc "nothing here says what (map-new) maps — write the key and value \ types, as (map-new str i32)") (* The element type, or the reason this is not a Vec. *) and vec_elem loc what (t : Types.t) = match t with | Types.Vec e -> e | other -> fail loc "%s takes a (Vec T), found %s" what (tyname loc other) (* The allocator an operation uses: the one named at the site, or the current implicit one. spec-memory.md: an operation never falls back to a hidden global allocator, and an explicit allocator can override the context. *) and allocator_arg ctx loc = function | [] -> rt loc raw_alloc "flan_context_use" [ here loc ] | [ a ] -> alloc_value ctx loc a | _ -> fail loc "at most one allocator may be named here" (* An Allocator value, checked and opened: the record every runtime call takes, after [use_alloc] has compared the incarnation. *) and alloc_value ctx loc e = use_alloc ctx loc (check ctx ~want:Types.Alloc e) (* A copy of [src]'s elements — a string's bytes or a slice's elements — into a block from [a], answered as a slice over it: (bytes s), (clone xs) and the number conversions. The lowering mirrors [vec-new]: a hidden (Vec T) temp holds the block so the allocation registry can read its extent, the attempt sits under [alloc_guard] so a failure signals StorageExhausted with retry, and the answer is the [slice] of the whole of it. The slice carries no allocator: (free s) hands the block back to the context allocator or the one named, and a dev build's registry — which the note gives the Vec's allocator — refuses the wrong one. The source is bound before the guard's loop, so a retry re-attempts the same copy rather than re-evaluating the expression that produced it. Same rule as [push]'s element. No [region_check]: that guard compares a Vec header being *stored* against the region it lands in, and the header here is a temp nothing stores. *) and dup_elems ctx loc elem (src : Tast.expr) (a : Tast.expr) = let sty = src.Tast.ty in let sv = fresh_slot ctx sty in let v = fresh_slot ctx (Types.Vec elem) in let out = fresh_slot ctx (Types.Slice (Types.Mut, elem)) in let attempt = rt loc (Types.Int Types.I8) "flan_bytes_dup" [ mk loc (Types.Vec elem) (Tast.Local v); a; mk loc sty (Tast.Local sv); size_of loc elem; align_of loc elem; here loc ] in let fill = rt loc Types.Unit "flan_vec_as_slice" [ mk loc (Types.Vec elem) (Tast.Local v); addr_of loc (mk loc (Types.Slice (Types.Mut, elem)) (Tast.Local out)); mk loc index_ty (Tast.Int (0L, Types.I32)); mk loc index_ty (Tast.Int (-1L, Types.I32)); size_of loc elem; here loc ] in mk loc (Types.Slice (Types.Mut, elem)) (Tast.Let ([ (sv, src); (v, mk loc (Types.Vec elem) (Tast.Zero (Types.Vec elem))); (out, mk loc (Types.Slice (Types.Mut, elem)) (Tast.Zero (Types.Slice (Types.Mut, elem)))) ], [ with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_slice" (mk loc (Types.Vec elem) (Tast.Local v)) [ size_of loc elem ] elem); fill; mk loc (Types.Slice (Types.Mut, elem)) (Tast.Local out) ])) (* The address of an element, bounds-checked, with the allocator's epoch checked first. Both the value form [(at v i)] and the place form [(set (at v i) x)] come through here, so they cannot drift apart — which is the asymmetry [nth] was removed for. *) (* A new, empty (Vec elem) from the opened allocator [a]: (vec-new)'s lowering, which (string-new) shares for the Vec under a String. *) and vec_init ?note ctx loc elem (a : Tast.expr) = let note = Option.value note ~default:elem in let v = fresh_slot ctx (Types.Vec elem) in let attempt = rt loc (Types.Int Types.I8) "flan_vec_init" [ mk loc (Types.Vec elem) (Tast.Local v); a; i64_at loc 0L; size_of loc elem; align_of loc elem; here loc ] in mk loc (Types.Vec elem) (Tast.Let ([ (v, mk loc (Types.Vec elem) (Tast.Zero (Types.Vec elem))) ], [ with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_vec" (mk loc (Types.Vec elem) (Tast.Local v)) [ size_of loc elem ] note); region_check ctx.env loc (mk loc (Types.Vec elem) (Tast.Local v)) (mk loc (Types.Vec elem) (Tast.Local v)) ])) and vec_at ctx loc (target : Tast.expr) (idx : Ast.expr list) = let elem = vec_elem loc "at" target.Tast.ty in match idx with | [ i ] -> let i = index_expr ctx i in rt loc (Types.Ptr (Types.Mut, elem)) "flan_vec_at" [ target; i; size_of loc elem; here loc ], elem | _ -> fail loc "a Vec takes exactly one index, as (at v i)" (* [(get xs i ...)] over an array, a slice, a string or a Vec: the element as [(Some e)], or [None] when any index is out of range, negative included, where [at] would trap. One index per dimension, as [at] takes. The indices are evaluated once, left to right, before any test. An array's length is static, so the array itself is read once and is not copied; a slice's, a string's or a Vec's is read off the value, so that value is put in a slot first unless it is already a name. Each level is tested before the next is reached, because a Vec of Vecs has no inner length to test until the outer index is known to be in range. The element is then read by [at] as usual, whose own check can no longer fail. *) and checked_get ctx ~want loc (target : Tast.expr) (idx : Ast.expr list) = let rec result ty = function | [] -> ty | (i : Ast.expr) :: rest -> (match ty with | Types.Array (_, t) | Types.Slice (_, t) | Types.Vec t -> result t rest | Types.String -> result (Types.Int Types.U8) rest | other -> fail i.Ast.loc "get takes an array, a slice, a string, a Vec, a Map or a dyn, and \ %s cannot be indexed" (tyname i.Ast.loc other)) in let oty = Types.Option (result target.Tast.ty idx) in let none () = mk loc oty Tast.None_ in let is_name (e : Tast.expr) = match e.Tast.e with Tast.Local _ | Tast.Global _ -> true | _ -> false in (* A value a call answered is bound before the indices run, so the target is still evaluated first. *) let pre = ref [] in let target = match target.Tast.e with | Tast.Call _ | Tast.CallPtr _ -> let s = fresh_slot ctx target.Tast.ty in pre := [ (s, target) ]; mk loc target.Tast.ty (Tast.Local s) | _ -> target in let islots = map_lr (fun (i : Ast.expr) -> let v = index_expr ctx i in let s = fresh_slot ctx index_ty in (s, v)) idx in let ivar (s, _) = mk loc index_ty (Tast.Local s) in let i32 k = mk loc index_ty (Tast.Int (k, Types.I32)) in let within i len = let ge = mk loc Types.Bool (Tast.Prim (Tast.Ge, [ i; i32 0L ])) in let lt = mk loc Types.Bool (Tast.Prim (Tast.Lt, [ i; len ])) in mk loc Types.Bool (Tast.If (ge, lt, mk loc Types.Bool (Tast.Bool false))) in (* The value reached so far is [base] indexed by [path], innermost last. *) let reached base path ty = if path = [] then base else mk loc ty (Tast.Prim (Tast.At, base :: List.rev path)) in (* A value whose length is read as well as indexed, in a slot unless it is a name already. *) let named cur k = if is_name cur then k cur else let s = fresh_slot ctx cur.Tast.ty in mk loc oty (Tast.Let ([ (s, cur) ], [ k (mk loc cur.Tast.ty (Tast.Local s)) ])) in let rec go base path ty = function | [] -> mk loc oty (Tast.Some_ (reached base path ty)) | i :: rest -> let i = ivar i in (match ty with | Types.Array (n, t) -> mk loc oty (Tast.If (within i (i32 n), go base (i :: path) t rest, none ())) | Types.Slice _ | Types.String -> let t = match ty with Types.Slice (_, t) -> t | _ -> Types.Int Types.U8 in named (reached base path ty) (fun cur -> let len = mk loc index_ty (Tast.Prim (Tast.Len, [ cur ])) in mk loc oty (Tast.If (within i len, go cur [ i ] t rest, none ()))) | Types.Vec t -> named (reached base path ty) (fun cur -> let n = rt loc (Types.Int Types.I64) "flan_vec_len" [ cur; here loc ] in let len = mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ])) in let p = rt loc (Types.Ptr (Types.Mut, t)) "flan_vec_at" [ cur; i; size_of loc t; here loc ] in mk loc oty (Tast.If (within i len, go (mk loc t (Tast.Deref p)) [] t rest, none ()))) | _ -> assert false) in expect ctx loc ~want (mk loc oty (Tast.Let (!pre @ islots, [ go target [] target.Tast.ty islots ]))) (* [(get d k ...)] over a dyn: a map's value at the key, a vec's or a text's element at the index, or nil when there is none — dyn has no Option. More than one key walks a level per key, and a nil level answers nil. *) and dyn_get ctx ~want loc (target : Tast.expr) (keys : Ast.expr list) = let nil () = rt loc Types.Dyn "flan_dyn_nil" [] in let one v k = rt loc Types.Dyn "flan_dyn_get_at" [ v; k; here loc ] in (* A slot per key only when there are several: one key goes straight to [flan_dyn_get_at]. Over a text or a vec that runs [at]'s own body in the runtime, so [get] and [at] count a text the same way whatever [at] comes to count. *) let slotted = List.length keys > 1 in let keys = map_lr (fun k -> let v = check ctx ~want:Types.Dyn k in ((if slotted then fresh_slot ctx Types.Dyn else -1), v)) keys in let kvar (s, _) = mk loc Types.Dyn (Tast.Local s) in let rec go v = function | [] -> v | k :: rest when rest = [] -> one v (kvar k) | k :: rest -> let s = fresh_slot ctx Types.Dyn in let sv = mk loc Types.Dyn (Tast.Local s) in let is_nil = mk loc Types.Bool (Tast.Prim (Tast.Ne, [ rt loc (Types.Int Types.I32) "flan_dyn_is_nil" [ sv ]; mk loc (Types.Int Types.I32) (Tast.Int (0L, Types.I32)) ])) in mk loc Types.Dyn (Tast.Let ([ (s, one v (kvar k)) ], [ mk loc Types.Dyn (Tast.If (is_nil, nil (), go sv rest)) ])) in match keys with | [ (_, k) ] -> expect ctx loc ~want (one target k) | _ -> let ts = fresh_slot ctx Types.Dyn in expect ctx loc ~want (mk loc Types.Dyn (Tast.Let ((ts, target) :: keys, [ go (mk loc Types.Dyn (Tast.Local ts)) keys ]))) (* [(slice v)], [(slice v lo)] and [(slice v lo hi)] over a Vec — the arm for it is in [slice], and this is the half that differs from an array's. The result is a non-owning view: copying it copies ptr+len and never the elements, and it carries no allocator, so freeing through one is not expressible. What makes a Vec's view different from an array's is that the storage it names can move — a [push], a [put] or a [reserve] may reallocate and leave the view addressing the old block. Nothing checks that, which is the explicit Zig/Odin contract spec-memory.md chose over a borrow checker, and it is written down where a reader meets it: beside [push] in BUILT.md and in spec-memory.md's "Borrowing". It used to be spelled [as-slice], on the theory that a second name warns about that. It does not: the input type already decides which of the two things happens, so there was no choice at the call site for the name to express — and the moment it warned about was the moment the view is taken, while the danger arrives later, at the push. No slot and no length read at any arity: -1 is the runtime's "to the end", so the short forms pass a constant where an array passes its length, and the target appears exactly once in all three. A Vec a *call* returned is accepted, where an array a call returned is refused a screen down. The array is a dangle — the view outlives a temporary the frame reuses — and this is not: the storage a returned Vec owns lives to its allocator's free-all or destroy, so the view reads what it says it reads. What a returned Vec loses is the owner, and losing the owner is a leak, which this language has already decided is defined behaviour (spec-memory.md on overwriting a global Vec: "overwrites the first block and leaks it; there is no drop"). [(length (mk))] and [(at (mk) 0)] lose exactly the same owner and are accepted; refusing the third of those three would be a rule about one spelling rather than about a hazard, and under a region allocator there is nothing to leak at all. *) and vec_slice ctx ~want loc (target : Tast.expr) elem (bounds : Ast.expr list) = let int k = mk loc index_ty (Tast.Int (k, Types.I32)) in (* Every bound the reader wrote goes through here, and the -1 below does not: a negative literal is refused exactly as it is on an array, in the same words, and that refusal has to happen on the bounds a person wrote rather than on the pair that comes out of this — the sentinel *is* a -1, and checking afterwards would refuse (slice v) itself. There is no static length to check the other direction against. *) let bound (b : Ast.expr) = let v = index_expr ctx b in (match literal v with | Some k -> static_index b.Ast.loc (Types.Vec elem) ~past_end:true "slice bound" k | None -> ()); v in (* -1 is the runtime's "to the end". A Vec's length is not static, so unlike an array there is no constant to fold and the runtime reads the length word the header is carrying anyway. *) let to_end () = int (-1L) in let lo, hi = match bounds with | [] -> int 0L, to_end () | [ lo ] -> bound lo, to_end () | [ lo; hi ] -> let lo = bound lo and hi = bound hi in (* The same refusal the other targets get, and it is asked only here, where both ends are bounds somebody wrote. *) (match literal lo, literal hi with | Some a, Some b when a > b -> fail loc "slice [%Ld %Ld) runs backwards — lo must not exceed hi" a b | _ -> ()); lo, hi | _ -> assert false in let out = fresh_slot ctx (Types.Slice (Types.Mut, elem)) in let fill = rt loc Types.Unit "flan_vec_as_slice" [ target; addr_of loc (mk loc (Types.Slice (Types.Mut, elem)) (Tast.Local out)); lo; hi; size_of loc elem; here loc ] in expect ctx loc ~want (mk loc (Types.Slice (Types.Mut, elem)) (Tast.Let ([ (out, mk loc (Types.Slice (Types.Mut, elem)) (Tast.Zero (Types.Slice (Types.Mut, elem)))) ], [ fill; mk loc (Types.Slice (Types.Mut, elem)) (Tast.Local out) ]))) (* ── String ─────────────────────────────────────────────────────────── The prelude's (defstruct String [bytes (Vec u8)]) is valid UTF-8 because nothing outside the prelude can reach the Vec: its field cannot be named and the struct cannot be built ([refuse_string_inside]), and it is not indexed ([refuse_string_index]). Every byte arrives through an arm below. Text the checker cannot prove valid is checked at run time, at the site that stores it, and a bad byte stops the program there (flan_utf8_check, flan_rune_check) — a str may hold any bytes, since (str b) does not check. A string literal and an integer literal are checked here instead, so text written in the source costs nothing at run time. A [const u8] is refused rather than checked: bytes become text through (str b) or (bytes->string v), which says at the call that a check is wanted. Positions are characters and lengths are bytes, the rule str has. The character index is found by a walk (flan_string_index), which signals BoundsError with the character count as the length. *) and refuse_string_inside loc = if not (String.equal loc.Loc.file Prelude.file) then begin let fln = fln_source loc in Loc.failk "check/string-private" loc "a String keeps its bytes to itself, which is how they stay valid \ UTF-8. Make one with %s, read it with %s or %s, and change it with \ append, insert and remove" (if fln then "string-new(text)" else "(string-new text)") (if fln then "str(s)" else "(str s)") (if fln then "bytes-view(s)" else "(bytes-view s)") end and refuse_string_index loc ~store = let fln = fln_source loc in if store then Loc.failk "check/string-set-index" loc "a String cannot be changed one byte at a time. A character in UTF-8 \ is one to four bytes, so writing a single byte can leave text that is \ not valid. Change it by character position instead: %s, then %s" (if fln then "remove(s, i)" else "(remove s i)") (if fln then "insert(s, i, c)" else "(insert s i c)") else Loc.failk "check/string-index" loc "a String is not indexed, because in UTF-8 a byte position and a \ character position are different numbers. Read byte i with %s, or \ walk the characters with %s" (if fln then "str(s)[i]" else "(at (str s) i)") (if fln then "runes(s)" else "(runes s)") (* An argument that may be a String: checked with no expectation when its type does not depend on one — a name, a call, a field — and against [otherwise] when it does, as the builtin always checked it. *) and maybe_string ctx ~otherwise (x : Ast.expr) = match x.Ast.e with | Ast.Var _ | Ast.Call _ | Ast.Field _ -> let e = check ctx x in if string_or_ptr e.Tast.ty then e else expect ctx x.Ast.loc ~want:(Some otherwise) e | _ -> check ctx ~want:otherwise x (* A String's bytes as a [const u8]: a view of the Vec, costing nothing, and good until the String next grows — (slice v)'s contract. *) and string_bytes ctx loc (s : Tast.expr) = let v = vec_slice ctx ~want:None loc (string_vec loc s) u8_ty [] in { v with Tast.ty = Types.Slice (Types.Const, u8_ty) } (* A str, a String or a [const u8], as a [const u8]: what rune-count and runes read. *) and text_bytes ctx what (x : Ast.expr) = let e = match x.Ast.e with | Ast.Str _ -> check ctx ~want:Types.String x | _ -> check ctx x in let loc = x.Ast.loc in match e.Tast.ty with | Types.String -> mk loc (Types.Slice (Types.Const, u8_ty)) (Tast.Prim (Tast.Bytes, [ e ])) | t when string_or_ptr t -> string_bytes ctx loc e | Types.Slice (_, Types.Int Types.U8) -> { e with Tast.ty = Types.Slice (Types.Const, u8_ty) } | other -> fail loc "%s takes a str, a String or a [const u8], found %s" what (tyname loc other) (* The String an operation changes, written as the String or a pointer to one, and refused when it is reached through something read-only. *) and string_target ctx loc what (t : Tast.expr) = let t = match t.Tast.ty with | Types.Ptr (_, ty) when is_string_ty ty -> mk loc ty (Tast.Deref t) | ty when is_string_ty ty -> t | other -> fail loc "%s takes a String to change, found %s" what (tyname loc other) in refuse_const_change ctx loc t; t (* What append and insert were given to store: text, as a [const u8] and whether it is known valid, or a code point. *) and string_piece ctx what (x : Ast.expr) = let loc = x.Ast.loc in let rune e = (match literal e with | Some c when c < 0L || c > 0x10ffffL || (c >= 0xd800L && c <= 0xdfffL) -> fail loc "%Ld is not a Unicode scalar value, so it has no UTF-8 encoding and \ a String cannot hold it" c | _ -> ()); `Rune e in match x.Ast.e with | Ast.Str lit -> if not (String.is_valid_utf_8 lit) then fail loc "this text is not valid UTF-8, and a String holds only valid UTF-8"; let e = check ctx ~want:Types.String x in `Text (mk loc (Types.Slice (Types.Const, u8_ty)) (Tast.Prim (Tast.Bytes, [ e ])), true) | Ast.Int _ | Ast.Byte _ -> rune (check ctx ~want:(Types.Int Types.I32) x) | _ -> let e = check ctx x in match e.Tast.ty with | Types.String -> `Text (mk loc (Types.Slice (Types.Const, u8_ty)) (Tast.Prim (Tast.Bytes, [ e ])), false) | t when string_or_ptr t -> `Text (string_bytes ctx loc e, true) | Types.Int Types.I32 -> rune e | Types.Char -> rune (widen loc (Types.Int Types.I32) e) | Types.Int k when Types.widens_to ~from:(Types.Int k) ~into:(Types.Int Types.I32) -> rune (widen loc (Types.Int Types.I32) e) | Types.Int _ -> fail loc "a code point is an i32, and this is %s. Write %s" (tyname loc e.Tast.ty) (if fln_source loc then "i32(c)" else "(i32 c)") | Types.Slice (_, Types.Int Types.U8) -> fail loc "%s takes text, and bytes are not text until they are checked. \ Write %s, which is checked when it is stored" what (if fln_source loc then "str(b)" else "(str b)") | other -> fail loc "%s takes a str, a String, a char or a code point, found %s" what (tyname loc other) (* One allocating store into a String's Vec, under the retry guard, with the dev registry told of the block it ends up in — push's shape. Every argument is bound to a slot before the loop, so a retry re-attempts only the call. *) and string_store ctx loc (v : Tast.expr) (binds : (int * Tast.expr) list) (checks : Tast.expr list) (attempt : Tast.expr) = mk loc Types.Unit (Tast.Let (binds, checks @ [ region_check ctx.env loc v (with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_vec" v [ size_of loc u8_ty ] string_ty)) ])) (* A text piece or a code point stored at byte offset [off] of the String's Vec [v], -1 for the end. *) and string_put ctx loc (v : Tast.expr) (off : Tast.expr) piece = let i64 = Types.Int Types.I64 in let o = fresh_slot ctx i64 in let ov = mk loc i64 (Tast.Local o) in let at_end = match off.Tast.e with Tast.Int (-1L, _) -> true | _ -> false in match piece with | `Rune c -> let r = fresh_slot ctx (Types.Int Types.I32) in string_store ctx loc v [ (r, c); (o, off) ] [] (rt loc (Types.Int Types.I8) "flan_string_put_rune" [ v; ov; mk loc (Types.Int Types.I32) (Tast.Local r); here loc ]) | `Text (b, valid) -> let bty = Types.Slice (Types.Const, u8_ty) in let bs = fresh_slot ctx bty in let bv = mk loc bty (Tast.Local bs) in let checks = if valid then [] else [ rt loc Types.Unit "flan_utf8_check" [ bv; here loc ] ] in string_store ctx loc v [ (bs, b); (o, off) ] checks (if at_end then rt loc (Types.Int Types.I8) "flan_vec_append" [ v; bv; size_of loc u8_ty; align_of loc u8_ty; here loc ] else rt loc (Types.Int Types.I8) "flan_vec_insert" [ v; ov; bv; size_of loc u8_ty; align_of loc u8_ty; here loc ]) (* A character position as a byte offset, signalling BoundsError when it is not one. [past_end] admits the position after the last character. *) and string_index ctx loc (v : Tast.expr) (i : Ast.expr) ~past_end = let i = index_expr ctx i in rt loc (Types.Int Types.I64) "flan_string_index" [ v; i; mk loc (Types.Int Types.I32) (Tast.Int ((if past_end then 1L else 0L), Types.I32)); here loc ] (* A prelude function by the name it was written under, which a program's own function of that name moves aside (see [shadow_prelude]). *) and prelude_fn ctx name = let moved = "prelude~/" ^ name in if Hashtbl.mem ctx.env.fns moved then moved else name (* Whether [name] is the prelude's own function. *) and prelude_defined ctx name = match Hashtbl.find_opt ctx.env.fn_locs name with | Some at -> String.equal at.Loc.file Prelude.file | None -> false (* A call to a prelude function that answers a String, its text arguments checked here, at the call the program wrote, before the call is made. The builders — (to-lower b), (join parts sep) — take bytes, and their answer is valid exactly when every piece of text they were given is (UTF-8 is self-synchronising, so a valid [from] matches a valid [s] only on character boundaries). Each builder also checks its own answer, the backstop for a builder reached through a function value; on this path that check has nothing left to find, and stops nobody at the prelude's line. *) and prechecked_call ctx loc name ret (args : Tast.expr list) = let bytes = function | Types.Slice (_, Types.Int Types.U8) | Types.String -> true | _ -> false in let binds, checks, uses = List.fold_right (fun (a : Tast.expr) (bs, cs, us) -> let check = match a.Tast.ty with | t when bytes t -> Some "flan_utf8_check" | Types.Slice (_, t) when bytes t -> Some "flan_utf8_check_parts" | _ -> None in match check with | None -> (bs, cs, a :: us) | Some sym -> let sl = fresh_slot ctx a.Tast.ty in let v = mk a.Tast.loc a.Tast.ty (Tast.Local sl) in ((sl, a) :: bs, rt loc Types.Unit sym [ v; here loc ] :: cs, v :: us)) args ([], [], []) in let call = mk loc ret (Tast.Call (name, uses)) in if checks = [] then call else mk loc ret (Tast.Let (binds, checks @ [ call ])) (* Whether an operand is a String, read off what the operand is without checking it: a local or a global of that type, a call to a function that answers one, a field of that type, or one of the builtins that make one. A comparison asks this of every operand, so it must not walk them. *) and peeks_string ctx (a : Ast.expr) = let rec ty (a : Ast.expr) = match a.Ast.e with | Ast.Var n -> (match lookup ctx n with | Some b -> Some b.bty | None -> (match Hashtbl.find_opt ctx.env.globals n with | Some (t, _) -> Some t | None -> None)) | Ast.Call ({ Ast.e = Ast.Var ("string-new" | "bytes->string"); _ }, _) -> Some string_ty | Ast.Call ({ Ast.e = Ast.Var "deref"; _ }, [ p ]) -> (match ty p with Some (Types.Ptr (_, t)) -> Some t | _ -> None) | Ast.Call ({ Ast.e = Ast.Var f; _ }, _) -> (match Hashtbl.find_opt ctx.env.fns f with | Some (_, ret) -> Some ret | None -> None) | Ast.Field (t, name) -> (match ty t with | Some (Types.Named n | Types.Ptr (_, Types.Named n)) -> (match fields_named ctx.env n with | Some st -> (match Tast.field_index st name with | Some i -> Some (List.nth st.Tast.fields i).Tast.fty | None -> None) | None -> None) | _ -> None) | _ -> None in match ty a with Some t -> string_or_ptr t | None -> false (* = and != over a String and a String or a str: the texts' bytes compared, through the str view each has, which is the comparison str already has. The orderings are refused as they are on a str, naming is-bytes-less. *) and string_compare ctx ~want loc name p args = (match name with | "=" | "!=" -> () | _ -> fail loc "%s orders machine numbers and enums, and a String is neither. Text is \ ordered by its bytes with %s" name (if fln_source loc then "is-bytes-less(bytes-view(a), bytes-view(b))" else "(is-bytes-less (bytes-view a) (bytes-view b))")); let as_str (x : Ast.expr) = let e = match x.Ast.e with | Ast.Str _ -> check ctx ~want:Types.String x | _ -> check ctx x in match e.Tast.ty with | Types.String -> e | t when string_or_ptr t -> mk x.Ast.loc Types.String (Tast.Prim (Tast.StrOfBytes, [ string_bytes ctx x.Ast.loc e ])) | other -> fail x.Ast.loc "%s compares a String with a String or a str, found %s" name (tyname x.Ast.loc other) in let ops = List.map as_str args in let link u v = mk loc Types.Bool (Tast.Prim (p, [ u; v ])) in match ops with | [ a; b ] -> expect ctx loc ~want (link a b) | _ -> let pairs = if String.equal name "!=" then all_pairs else adjacent_pairs in expect ctx loc ~want (cmp_over ctx loc Types.String ~pairs ~link ops) and string_call ctx ~want loc name args = let i64 n = mk loc (Types.Int Types.I64) (Tast.Int (n, Types.I64)) in match name, args with (* (string-new), (string-new text), (string-new a), (string-new text a): vec-new's shape, the text copied in — checked at run time when it is a str, since a str may hold any bytes. *) | "string-new", ([] | [ _ ] | [ _; _ ]) -> let text, a = match args with | [] -> None, allocator_arg ctx loc [] | [ x ] -> (match x.Ast.e with | Ast.Str _ -> Some (string_piece ctx name x), allocator_arg ctx loc [] | _ -> let e = check ctx x in if Types.equal e.Tast.ty Types.Alloc then None, use_alloc ctx loc e else (* Checked already, so classified from what it turned out to be and never checked a second time. *) let piece = match e.Tast.ty with | Types.String -> `Text (mk loc (Types.Slice (Types.Const, u8_ty)) (Tast.Prim (Tast.Bytes, [ e ])), false) | t when string_or_ptr t -> `Text (string_bytes ctx loc e, true) | other -> fail x.Ast.loc "string-new takes a str or a String to copy, an allocator, \ or both, found %s" (tyname loc other) in Some piece, allocator_arg ctx loc []) | [ x; a ] -> let piece = match string_piece ctx name x with | `Rune _ -> fail x.Ast.loc "string-new copies a str or a String, not a code point" | p -> p in Some piece, allocator_arg ctx loc [ a ] | _ -> assert false in let sl = fresh_slot ctx string_ty in let s = mk loc string_ty (Tast.Local sl) in let v = vec_init ~note:string_ty ctx loc u8_ty a in let fill = match text with | None -> [] | Some p -> [ string_put ctx loc (string_vec loc s) (i64 (-1L)) p ] in expect ctx loc ~want (mk loc string_ty (Tast.Let ([ (sl, mk loc string_ty (Tast.Make ("String", [ v ]))) ], fill @ [ s ]))) | "string-new", _ -> fail loc "string-new is (string-new), (string-new text), (string-new a) \ or (string-new text a)" (* (bytes->string v) and (bytes->string v a): the bytes of a (Vec u8) copied into a new String once they are checked, here. A copy, because v — and any slice taken of it — could otherwise go on writing into the String's block; v is untouched and still the caller's to free. The prelude's builders are the one exception: each hands over a Vec nothing else can reach, so there the Vec becomes the String with no copy, still checked, and re-noted so a dev build's registry calls the block a String. *) | "bytes->string", (x :: rest) when List.length rest <= 1 -> let v = check ctx ~want:string_vec_ty x in if String.equal loc.Loc.file Prelude.file && rest = [] then begin let sl = fresh_slot ctx string_vec_ty in let vv = mk loc string_vec_ty (Tast.Local sl) in let view = vec_slice ctx ~want:None loc vv u8_ty [] in expect ctx loc ~want (mk loc string_ty (Tast.Let ([ (sl, v) ], [ rt loc Types.Unit "flan_utf8_check" [ view; here loc ]; reg_note loc "flan_dev_reg_note_vec" vv [ size_of loc u8_ty ] string_ty; mk loc string_ty (Tast.Make ("String", [ vv ])) ]))) end else begin let a = allocator_arg ctx loc rest in let src = fresh_slot ctx string_vec_ty in let view = vec_slice ctx ~want:None loc (mk loc string_vec_ty (Tast.Local src)) u8_ty [] in let sl = fresh_slot ctx string_ty in let s = mk loc string_ty (Tast.Local sl) in let bytes = { view with Tast.ty = Types.Slice (Types.Const, u8_ty) } in expect ctx loc ~want (mk loc string_ty (Tast.Let ([ (src, v); (sl, mk loc string_ty (Tast.Make ("String", [ vec_init ~note:string_ty ctx loc u8_ty a ]))) ], [ string_put ctx loc (string_vec loc s) (i64 (-1L)) (`Text (bytes, false)); s ]))) end | "bytes->string", _ -> fail loc "bytes->string is (bytes->string v) or (bytes->string v a), over a (Vec u8)" | "append", [ target; x ] -> let t = check_target ctx target in (match t.Tast.ty with (* A run of bytes onto a (Vec u8), or through a pointer to one: the prelude's builders' tool, and raw bytes, so nothing is checked. The runtime finds a run that lies inside the Vec's own block before it grows it, so (append (addr b) (slice b)) reads what it meant to. *) | Types.Vec (Types.Int Types.U8) | Types.Ptr (_, Types.Vec (Types.Int Types.U8)) -> let v = match t.Tast.ty with | Types.Ptr (_, ty) -> mk loc ty (Tast.Deref t) | _ -> t in refuse_const_change ctx loc v; note_grown ctx "append" loc v; let bty = Types.Slice (Types.Const, u8_ty) in let b = check ctx ~want:bty x in let bs = fresh_slot ctx bty in let attempt = rt loc (Types.Int Types.I8) "flan_vec_append" [ v; mk loc bty (Tast.Local bs); size_of loc u8_ty; align_of loc u8_ty; here loc ] in expect ctx loc ~want (mk loc Types.Unit (Tast.Let ([ (bs, b) ], [ region_check ctx.env loc v (with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_vec" v [ size_of loc u8_ty ] u8_ty)) ]))) | ty when string_or_ptr ty -> let s = string_target ctx loc name t in let piece = string_piece ctx name x in expect ctx loc ~want (string_put ctx loc (string_vec loc s) (i64 (-1L)) piece) | other -> fail loc "append takes a String, or a (Vec u8) to add bytes to, found %s" (tyname loc other)) | "insert", [ target; i; x ] -> let s = string_target ctx loc name (check_target ctx target) in let v = string_vec loc s in let piece = string_piece ctx name x in let off = string_index ctx loc v i ~past_end:true in expect ctx loc ~want (string_put ctx loc v off piece) | "remove", [ target; i ] -> let s = string_target ctx loc name (check_target ctx target) in let v = string_vec loc s in let off = string_index ctx loc v i ~past_end:false in expect ctx loc ~want (rt loc (Types.Int Types.I32) "flan_string_remove" [ v; off; here loc ]) | "runes", [ x ] -> let b = text_bytes ctx name x in expect ctx loc ~want (mk loc (Types.Named "Runes") (Tast.Make ("Runes", [ b ]))) | "rune-count", [ x ] -> let b = text_bytes ctx name x in expect ctx loc ~want (mk loc (Types.Int Types.I32) (Tast.Call (prelude_fn ctx "rune-count", [ b ]))) | ("append" | "insert" | "remove" | "runes" | "rune-count"), _ -> let shape = match name with | "append" -> "(append s x)" | "insert" -> "(insert s i x)" | "remove" -> "(remove s i)" | "runes" -> "(runes s)" | _ -> "(rune-count s)" in fail loc "%s is %s" name shape | _ -> assert false (* Every arm below is a name an editor can be asked about and no program ever wrote down, so each one needs a line in [builtins] further down this file. A new arm without an entry fails the build — test_flan reads both. *) and named_call ?(qualified = false) ctx ~want loc name args = let prim p ty args = expect ctx loc ~want (mk loc ty (Tast.Prim (p, args))) in match name with (* [builtin/length], before anything else including the shadowing guard below. The prefix is stripped and the same dispatch runs again with [qualified], which is the one thing the guard consults: a qualified call has said which of the two it means, so there is nothing left for shadowing to decide. Everything after this point sees the bare name, so an arity or a type refusal on [(builtin/length 1 2)] reads exactly as it does on [(length 1 2)] — which is the point of the spelling, not a loss of detail. Recursion rather than a flag threaded through the arms because there is only one thing to skip. It cannot loop: the stripped name has no second [builtin/] on it unless somebody wrote [builtin/builtin/length], which is stripped once and then refused by name. *) | _ when not qualified && qualified_builtin name <> None -> let bare = Option.get (qualified_builtin name) in if not (Hashtbl.mem builtin_set bare) then not_a_builtin loc bare; named_call ~qualified:true ctx ~want loc bare args (* The user's own definition, ahead of every builtin arm below — and behind the qualifier above, which is the one spelling it does not take over. Clojure's rule: a [(defn get ...)] takes the name over, and a call written in the program that defines it reaches that definition rather than the builtin it is named after. The defn site is warned about once (see [shadowed_builtins]); the call sites say nothing, because at a call site there is nothing surprising left — the name means what the file says it means. What this arm does NOT do is let one file's definition reach into another's: [shadows_builtin] answers false for a call in the prelude and for a call in imported package code, which is the same visibility rule a defn has everywhere else. *) | _ when (not qualified) && shadows_builtin ctx loc name -> ordinary_call ctx ~want loc name args (* .fln's [x ?? d] and [x!]; no .fln name can take them over. *) | "??" -> check_coalesce ctx ~want loc args | "?" -> check_present ctx ~want loc args | "!!" -> check_unwrap ctx ~want loc args (* ── arithmetic and comparison ─────────────────────────────────── *) (* (- x) negates, Clojure's rule. A literal operand is the negative literal, so it takes its type from the site as any literal does. A float is subtracted from -0.0, which is exact negation — 0.0 - 0.0 would answer +0.0 — and an integer from 0, which wraps as (- 0 x) does. *) | "-" when List.length args = 1 -> let x = List.hd args in (match x.Ast.e, literal_arith x with (* Integer arithmetic over literals alone negates to a literal, so [(- (- 1))] is the literal 1 and fits a u8. *) | _, Some n when n <> Int64.min_int -> check ctx ?want { Ast.e = Ast.Int (Int64.neg n); loc } | Ast.Float v, _ -> check ctx ?want { Ast.e = Ast.Float (-.v); loc } | _ -> let v = check ctx ?want:(numeric_want want) x in if v.Tast.ty = Types.Char then Loc.failk "check/char-arithmetic" x.Ast.loc "- does not negate a char. Take its code point with %s, and make a \ char of one with %s" (if fln_source loc then "i32(c)" else "(i32 c)") (if fln_source loc then "char(n)" else "(char n)"); if v.Tast.ty = Types.Dyn then expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_neg" [ v; here loc ]) else begin unconstrained ctx.env loc name ~needs:"is-numeric" v.Tast.ty; if not (Types.is_numeric v.Tast.ty || generic_ty v.Tast.ty) then not_numeric name "numbers" v; let zero = match v.Tast.ty with | Types.Float k -> mk loc v.Tast.ty (Tast.Float (-0.0, k)) | ty -> int_literal loc ~want:(Some ty) ~preds:ctx.env.tvpreds 0L in expect ctx loc ~want (mk loc v.Tast.ty (Tast.Prim (Tast.Sub, [ zero; v ]))) end) | "+" | "-" | "*" | "/" -> let p = match name with | "+" -> Tast.Add | "-" -> Tast.Sub | "*" -> Tast.Mul | _ -> Tast.Div in fold_arity loc name args; fold_left_prim ctx ~want loc name p ~needs:"is-numeric" Types.is_numeric "numbers" args (* Remainder stays at two: (% a b c) is (% (% a b) c), which is a thing nobody writes on purpose. *) | "%" -> arity ctx loc name 2 args; refuse_kept_when ctx name args; let a, b = char_operands ctx name args (fun () -> binary ctx ~dyn_ok:true name loc ~want:(numeric_want want) args) in if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then dyn_fold ctx ~want loc name [ a; b ] [] else begin unconstrained ctx.env loc name ~needs:"is-numeric" a.Tast.ty; if not (Types.is_numeric a.Tast.ty || generic_ty a.Tast.ty) then not_numeric name "numbers" a; prim Tast.Rem a.Tast.ty [ a; b ] end | "=" | "!=" | "<" | "<=" | ">" | ">=" -> let p = match name with | "=" -> Tast.Eq | "!=" -> Tast.Ne | "<" -> Tast.Lt | "<=" -> Tast.Le | ">" -> Tast.Gt | _ -> Tast.Ge in fold_arity loc name args; let x, y, rest = match args with x :: y :: rest -> x, y, rest | _ -> assert false in refuse_kept_when ctx name args; if List.exists (fun a -> peeks_string ctx a) args then string_compare ctx ~want loc name p args else (* The first pair decides the type, and whether this is a dyn comparison at all, exactly as it does for the folding operators: [binary] joins the two, and every operand after them is checked against the answer. Past the first pair nothing widens, which is [fold_left_prim]'s rule and not a second one. *) let a, b = try binary ctx ~dyn_ok:true name loc ~want:None [ x; y ] with Loc.Error _ as ex -> (* A char beside an integer: said as the char's rule, not as the mismatch (decision 131). *) (* Neither a literal, whose own refusal already says what it is. *) (match if is_literal x || is_literal y then [] else List.map (fun a -> trial ctx (fun () -> check ctx a)) [ x; y ] with | [ Ok a; Ok b ] when (a.Tast.ty = Types.Char && Types.is_integer b.Tast.ty) || (b.Tast.ty = Types.Char && Types.is_integer a.Tast.ty) -> let fln = fln_source loc in Loc.failk "check/char-compare" loc "%s compares a char only with a char, and this is %s beside it. \ Take its code point with %s, or make a char with %s" name (tyname loc (if a.Tast.ty = Types.Char then b.Tast.ty else a.Tast.ty)) (if fln then "i32(c)" else "(i32 c)") (if fln then "char(n)" else "(char n)") | _ -> raise ex) in (* Which pairs this operator asks about. Every one but [!=] chains, and [!=] asks about all of them — see [all_pairs]. At two operands the two readings are one pair and the same answer, which is why the two-operand path below is the same code it always was. *) let pairs = if String.equal name "!=" then all_pairs else adjacent_pairs in (* A comparison with a dyn operand answers a *bool*, not a dyn, even though the runtime's own entry point answers a dyn holding one. The reason is where the result goes: a comparison is overwhelmingly the test of an [if] or a [while], and those want an i1. So the need_bool is applied here, once, and a program that really wants the comparison as a dyn value boxes it again on the way into wherever it is going — which [box] does for free at that boundary. [=] and [!=] are the pair that never traps: the runtime compares structurally and answers false for values of unrelated types, because two things being unalike is the answer to "are these equal", not an error. The orderings do trap, and rightly — there is no true answer to whether a string is less than a vector. *) (* [ops] are every operand, not yet boxed. *) let dyn_chain ops = let sym = match name with | "=" | "!=" -> "flan_dyn_eq" | "<" -> "flan_dyn_lt" | "<=" -> "flan_dyn_le" | ">" -> "flan_dyn_gt" | _ -> "flan_dyn_ge" in (* [eq] traps only on a view whose storage is gone, and [dyn_eq] gives it the site for that; the four orderings trap on a mismatch, and get one, for the reason [dyn_fold] gives. Every pair of a chain gets the same site — the whole comparison is written at one place, and a trap from any of its pairs happened there. *) let site = if String.equal sym "flan_dyn_eq" then [] else [ here loc ] in (* [!=] has no entry point of its own: there is one structural equality and the negation is an [i1] flip the backend folds away. *) let link u v = let cmp = if String.equal sym "flan_dyn_eq" then dyn_eq loc u v else unbox loc Types.Bool (rt loc Types.Dyn sym ([ u; v ] @ site)) in if String.equal name "!=" then mk loc Types.Bool (Tast.Prim (Tast.Not, [ cmp ])) else cmp in let ops = match rest with | [] -> [ a; b ] | _ -> ops () in if not (String.equal sym "flan_dyn_eq") then no_bare_nil ops; let r = match List.map (box ~ctx loc) ops with | [ a; b ] -> link a b | ops -> cmp_over ctx loc Types.Dyn ~pairs ~link ops in expect ctx loc ~want r in if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then dyn_chain (fun () -> a :: b :: map_lr (fun e -> check ctx ~want:Types.Dyn e) rest) else begin (* [=] and [!=] admit types [<] does not. A handle is one: a pair of numbers in one word and where being the same entity is the question the type exists to answer — ordering handles would order a slot index, which is a free-list artefact and means nothing. A string is the other, and for the opposite reason: being the same entity is not the question at all, being the same bytes is, and that has a true answer with no ordering attached — plan.org, Types calls out an ordering as a collation the language has not picked. Backend codegen (emit.ml, x86.ml) has a [Types.String] case in the [Eq]/[Ne] arm and nowhere else. A bool is the third: two values and no order between them. *) let ok = match name with | "=" | "!=" -> Types.is_equatable a.Tast.ty | _ -> Types.is_comparable a.Tast.ty in unconstrained ctx.env loc name ~needs:(match name with "=" | "!=" -> "is-equal" | _ -> "is-ordered") a.Tast.ty; if not (ok || generic_ty a.Tast.ty) then (match name with | "=" | "!=" -> fail loc "%s compares numbers, chars, enums, strings and bools, and %s \ is none of those" name (tyname loc a.Tast.ty) | _ -> fail loc "%s orders machine numbers, chars and enums, and %s is none of \ those" name (tyname loc a.Tast.ty)); match rest with | [] -> prim p Types.Bool [ a; b ] | _ -> let ty = a.Tast.ty in let link u v = mk loc Types.Bool (Tast.Prim (p, [ u; v ])) in let rest = map_lr (fold_arg ctx ty) rest in (* A dyn past the first pair makes the whole chain the dyn runtime's, for [fold_operand]'s reason: a chain is its pairs, and a pair with a dyn in it is a dyn comparison. *) if List.exists (function `Dyn _ -> true | `Typed _ -> false) rest then dyn_chain (fun () -> a :: b :: List.map (function `Dyn d -> d | `Typed v -> v) rest) else let ops = a :: b :: List.map (function `Typed v -> v | `Dyn d -> d) rest in expect ctx loc ~want (cmp_over ctx loc ty ~pairs ~link ops) end | "not" -> arity ctx loc name 1 args; (* Same truthiness as [if]: a dyn argument is negated on nil/false vs. everything else, not narrowed to a strict bool first. *) prim Tast.Not Types.Bool [ check_truthy ctx (List.hd args) ] (* Bitwise operators are integers-only. They take the ordinary join — an operand that widens into the other does, so (bit-and u8-flags u32-mask) is a u32 and — and the shifts below do not, which is the one carve-out widening has (TODO.org, "Implicit numeric widening is legal; narrowing stays a hard error"). *) | "bit-and" | "bit-or" | "bit-xor" -> let p = match name with | "bit-and" -> Tast.BitAnd | "bit-or" -> Tast.BitOr | _ -> Tast.BitXor in fold_arity loc name args; bool_operands ctx name args; fold_left_prim ctx ~want loc name p ~needs:"is-integer" Types.is_integer "integers" args (* The .fln operators, which the indented reader already spells as the words above; a form built some other way may still carry them. [~qualified] skips the shadowing arm, because a program that means its own [&&] has been answered by that arm already under this name. *) | "&&" | "||" | "^^" | "~~" -> let canon = match name with | "&&" -> "bit-and" | "||" -> "bit-or" | "^^" -> "bit-xor" | _ -> "bit-not" in named_call ~qualified:true ctx ~want loc canon args | "bit-not" | "popcount" | "leading-zeros" | "trailing-zeros" -> arity ctx loc name 1 args; bool_operands ctx name args; let v = check ctx ?want:(numeric_want want) (List.hd args) in if v.Tast.ty = Types.Dyn then expect ctx loc ~want (rt loc Types.Dyn (dyn_bits_sym name) [ v; here loc ]) else begin bits_operand ctx loc name v; let p = match name with | "bit-not" -> Tast.BitNot | "popcount" -> Tast.Popcount | "leading-zeros" -> Tast.Clz | _ -> Tast.Ctz in prim p v.Tast.ty [ v ] end (* The shifts stay at two, and not only because a shift chain reads badly: each count would be checked against the same width below, so (<< x 30 30) would pass two legal shifts and still shift the value away entirely. [~join:false] is the one place widening is deliberately not symmetric. The count still widens *to* the value's type — (<< i64-x u8-n) is fine — but the value never widens to the count's, which the general rule would do for (<< u8-x i32-n). It would be the wrong answer twice over: the result's type and the width the shift wraps at would be taken from a number that is only saying how far, and the range check just below, along with [emit]'s mask, is keyed to the *value's* width. A count wider than the value is refused and is told to write the cast. The rotations share the rule and not the range check: a rotation by the width is the value unchanged, so every count means something and is taken modulo the width. *) | "<<" | ">>" | "rotate-left" | "rotate-right" -> let p = match name with | "<<" -> Tast.Shl | ">>" -> Tast.Shr | "rotate-left" -> Tast.Rotl | _ -> Tast.Rotr in arity ctx loc name 2 args; bool_operands ctx name args; let a, b = binary ctx ~dyn_ok:true ~join:false name loc ~want:(numeric_want want) args in if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then begin (* The typed side of a mixed pair still has to be an integer: the dyn half is asked at run time, and this half can be asked now. *) List.iter (fun (v : Tast.expr) -> if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v) [ a; b ]; no_bare_nil [ a; b ]; expect ctx loc ~want (rt loc Types.Dyn (dyn_bits_sym name) [ box ~ctx loc a; box ~ctx loc b; here loc ]) end else begin bits_operand ctx loc name a; (* A shift by the operand's own width or more is poison in LLVM, which at -O2 turns the whole function into an undefined value rather than into a wrong number. A literal count is rejected here — that is the typo — and [emit] masks a computed one, so no shift can reach the hardware out of range. *) (match a.Tast.ty, b.Tast.e with | Types.Int k, Tast.Int (n, _) when p = Tast.Shl || p = Tast.Shr -> let w = Int64.of_int (Types.bits k) in if Int64.unsigned_compare n w >= 0 then fail loc "%s by %Ld is out of range for %s, which is %d bits wide" name n (tyname loc a.Tast.ty) (Types.bits k) | _ -> ()); prim p a.Tast.ty [ a; b ] end (* (min a b) and (max a b) evaluate each operand once — hence the slots — because a min over two calls must not call either of them twice. Which is also why this one does not go through [fold_left_prim]: there is no Prim to fold, and the pair it folds is a whole comparison. Each step puts *both* of its sides in slots, the accumulated pick included, so the three-operand form is two nested lets and still exactly one evaluation of each operand — where reusing the previous [If] as an operand of the next would have duplicated everything inside it. *) | "min" | "max" -> fold_arity loc name args; let x, y, rest = match args with x :: y :: rest -> x, y, rest | _ -> assert false in let a, b = binary ctx ~dyn_ok:true name loc ~want:(numeric_want want) [ x; y ] in if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then dyn_fold ctx ~want loc name [ a; b ] rest else begin (* [min] and [max] are [<] with a pick, so [is-ordered] is what they want — not [is-numeric]. A generic that declares [is-ordered] gets both. They stay builtins now that generics could express them, and the reason is the two lines above rather than the type system: they are variadic, and each step puts both of its sides in slots so that every operand is evaluated exactly once. A prelude [(defn min [a $t b $t] $t ...)] would be binary and would have to be nested at the call site, which is where the double evaluation this arm exists to prevent would come back. The generic half is already theirs — [is-ordered] admits them inside any body that declares it — so collapsing them would cost the arity and the evaluation rule and buy nothing. *) unconstrained ctx.env loc name ~needs:"is-ordered" a.Tast.ty; (* A char orders, so it has a least and a greatest too. *) if not (Types.is_numeric a.Tast.ty || a.Tast.ty = Types.Char || generic_ty a.Tast.ty) then not_numeric name "numbers" a; let ty = a.Tast.ty in let cmp = if String.equal name "min" then Tast.Lt else Tast.Gt in let pick a b = let sa = fresh_slot ctx ty and sb = fresh_slot ctx ty in let la = mk loc ty (Tast.Local sa) and lb = mk loc ty (Tast.Local sb) in let test = mk loc Types.Bool (Tast.Prim (cmp, [ la; lb ])) in mk loc ty (Tast.Let ([ (sa, a); (sb, b) ], [ mk loc ty (Tast.If (test, la, lb)) ])) in let rec steps acc = function | [] -> expect ctx loc ~want acc | arg :: tl -> match fold_arg ctx ty arg with | `Typed v -> steps (pick acc v) tl | `Dyn d -> dyn_fold ctx ~want loc name [ acc; d ] tl in steps (pick a b) rest end (* A type handed to the prelude's slice reductions: the reach for the type-limit constants under the name of the reduction beside them. *) | ("max-of" | "min-of") when (not (shadows_builtin ctx loc name)) && (match args with [ a ] -> type_arg ctx a | _ -> false) -> let which = if String.equal name "max-of" then "max-value" else "min-value" in fail loc "%s reduces a slice to its %s element, and this is a type — the %s value \ of a type is (%s %s)" name (if which = "max-value" then "largest" else "least") (if which = "max-value" then "largest" else "least") which (spell_arg "i32" (List.hd args)) (* (max-value T) and (min-value T): the type-limit constants, by type, so a generic body can name its own type's. Odin's max(T) and min(T), and the same answer for a float: the largest finite value and its negation, not the smallest positive one. *) | "max-value" | "min-value" -> arity ctx loc name 1 args; if not (type_arg ctx (List.hd args)) then 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 ~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 in let max = String.equal name "max-value" in let v = match ty with | Types.Int k -> let b = Types.bits k in let n = if Types.signed k then let top = Int64.shift_left 1L (b - 1) in if max then Int64.sub top 1L else Int64.neg top else if not max then 0L else if b = 64 then -1L else Int64.sub (Int64.shift_left 1L b) 1L in mk loc ty (Tast.Int (n, k)) | Types.Float k -> let m = match k with | Types.F32 -> Int32.float_of_bits 0x7f7fffffl | Types.F64 -> Float.max_float in mk loc ty (Tast.Float ((if max then m else -.m), k)) | Types.Var v -> if not (declares ctx.env.tvpreds v "is-numeric") then Loc.failk "check/unconstrained-type-variable" a.Ast.loc "%s is a limit of a numeric type, and nothing declares $%s \ numeric — write {:where (is-numeric $%s)} at the head of the body" name v v; int_literal loc ~want:(Some ty) ~preds:ctx.env.tvpreds 0L | _ -> fail a.Ast.loc "%s takes a numeric type (is-numeric), and %s is not one — as in (%s i32)" name (tyname loc ty) name in expect ctx loc ~want v (* (zeroed) is the all-bytes-zero value of whatever it is being stored into, so it only means anything where a type is expected of it. *) | "zeroed" -> arity ctx loc name 0 args; (match want with | Some ty when ty <> Types.Never -> no_zeroed_fn loc "this" ty; mk loc ty (Tast.Zero ty) | _ -> fail loc "zeroed needs to know the type it is zeroing — use it where one is \ expected, or name it, as in (the [4 i32] (zeroed))") (* [zeroed]'s two siblings, and the same shape exactly: a value of whatever type is expected of it, so [(set grid (filled 0xFF))] is how a place is filled and there is no second spelling to learn. What they add over [zeroed] is the bytes — [(filled b)] repeats one the program picks, and [(dead-beef)] repeats four — and with them the question [zeroed] never has to ask: zero is a value every type can have, and 0xDE is not. [unfillable] above is the whole of the answer. [dead-beef] takes the pattern or leaves it out, and leaving it out is defined as writing the default: the [None] arm below builds the same literal the source would have, so [(dead-beef)] and [(dead-beef 0xDEADBEEF)] are the same node by construction and no backend has a second path for the bare form. The pattern is an ordinary u32 expression, which is the byte arm's rule at four times the width — a literal out of range meets [in_range]'s located "does not fit in u32", and anything computed is guaranteed by its type instead. Both builtins take a value rather than only a literal for the same reason: refusing one would be a restriction with no mechanism behind it, since neither backend needs the number early. *) | "filled" | "dead-beef" -> let is_byte = String.equal name "filled" in if is_byte then arity ctx loc name 1 args else if List.length args > 1 then fail loc "%s takes the pattern or nothing at all, given %d arguments" name (List.length args); (match want with | Some ty when ty <> Types.Never -> (match unfillable ctx.env [] ty with | Some bad -> Loc.failk "check/fill-not-plain-data" loc "%s writes raw bytes over %s, and %s is not plain data — %s. \ Fill only numbers and pointers, and structs, unions and fixed \ arrays built out of them" name (tyname loc ty) (if Types.equal bad ty then "it" else tyname loc bad) (match bad with | Types.Dyn -> "a dyn is one word the collector walks by descriptor, and a \ filled one is a root pointing at nothing" | Types.Vec _ | Types.Map _ | Types.Alloc -> "it owns its storage through a pointer and an allocator, and \ a filled header frees a wild address" | Types.String | Types.Slice _ -> "it is a pointer and a length every bounds check believes" | Types.Bool -> "a bool is an i1 to LLVM and a whole byte to the x86 backend, \ so a filled one would not even agree with itself across the \ two" | Types.Option _ -> "it carries a tag saying whether the value is there, and a \ filled one says yes over a payload nobody wrote" | Types.Fn _ | Types.CFn _ -> "it is a code address, and a call through a filled one jumps \ into whatever 0xDE bytes happen to address" | Types.Named n when Hashtbl.mem ctx.env.datas n -> "it carries a tag that names a case, and no byte pattern \ names a real one" | Types.Enum _ -> "an enum's values are the members it declared, and no byte \ pattern is one of them" | _ -> "it is not one of the types this rule admits") | None -> ()); if is_byte then let b = check ctx ~want:(Types.Int Types.U8) (List.hd args) in mk loc ty (Tast.Fill (ty, b)) else let pat = match args with | [ a ] -> check ctx ~want:(Types.Int Types.U32) a (* The bare form, written out. Not a default a backend applies: the node that leaves here is the one the spelled-out call would have left, which is what makes the equivalence a fact about the IR rather than a promise two emitters keep separately. Masked to 32 bits, and that is the whole of why this is not [Int64.of_int32] on its own: [dead_beef_default] is an [int32] whose top bit is set, so widening it signed would put -559038737 on a node tagged [u32] — where the same pattern *written out* arrives as 3735928559, because [in_range] admits it as the unsigned value it is. Two spellings of one builtin would then carry two different payloads, and "the same node by construction" would be false for anything that reads one. *) | _ -> mk loc (Types.Int Types.U32) (Tast.Int (Int64.logand (Int64.of_int32 Tast.dead_beef_default) 0xFFFFFFFFL, Types.U32)) in mk loc ty (Tast.DeadBeef (ty, pat)) | _ -> fail loc "%s needs to know the type it is filling — use it where one is \ expected, or name it, as in (the [4 u32] (%s))" name (if is_byte then "filled 0xFF" else name)) (* The one half of a destructuring [let] that [Parse] cannot do on its own. Everything else about a pattern is bindings and field accesses it already wrote; the arity is a *type* question — how many elements the value has — and there are no types in the parser. So the pattern's shape travels here as arguments: which element this binding wants, how many names the pattern binds, and whether that count is exact or a minimum (it is a minimum when the pattern ends in [& rest]). No source symbol can contain a [~] — the reader makes it a delimiter — so this name is unspellable and nothing but [Parse] can reach it. *) | "destructure~nth" -> (match args with | [ target; { Ast.e = Ast.Int i; _ }; { Ast.e = Ast.Int n; _ }; { Ast.e = Ast.Int exact; _ } ] -> let plural k = if Int64.equal k 1L then "" else "s" in lit_typed_use ctx target; let target = check ctx target in (match target.Tast.ty with | Types.Array (m, elem) -> if Int64.equal exact 1L && not (Int64.equal m n) then fail loc "this pattern binds %Ld name%s, but %s has %Ld element%s — a \ pattern over a fixed array names every element, or ends in \ [& rest]" n (plural n) (tyname loc target.Tast.ty) m (plural m); if Int64.equal exact 0L && Int64.compare m n < 0 then fail loc "this pattern binds %Ld name%s before the &, but %s has only %Ld \ element%s" n (plural n) (tyname loc target.Tast.ty) m (plural m); prim Tast.At elem [ target; mk loc index_ty (Tast.Int (i, Types.I32)) ] (* The asymmetry is real and is the reason this is refused rather than lowered to a bounds-checked [at]: a fixed array's length is in its type, so [[a b]] over a [[2 f32]] is a claim the checker can settle, and over a [[T]] it is a claim about a number that does not exist until the program runs. Turning it into a runtime trap would be a pattern that type checks and then kills the program, which is the trade this language does not make. *) | Types.Slice _ -> fail loc "a pattern cannot destructure %s — a slice's length is not known \ until the program runs, so nothing here can check it has %Ld \ element%s. Use %s and test %s yourself" (tyname loc target.Tast.ty) n (plural n) (if fln_source loc then "s[i]" else "(at s i)") (if fln_source loc then "length(s)" else "(length s)") | other -> fail loc "%s is not a fixed array, so [a b ...] cannot destructure it" (tyname loc other)) | _ -> fail loc "destructure~nth is written by the compiler and cannot be called") (* ── allocators, spec-memory.md ────────────────────────────────── *) (* Every one of these is an ordinary named call, which is the whole of the escape TODO.org's "The escape was real: a value the compiler builds trips no function-value refusal" describes: [check_call] already routes a named call through here, so none of the four function-value refusals is anywhere near it. *) (* A *user-written* allocator, and the reason it is still refused now that function values exist. It was diagnosed as needing "a defn's name in value position"; it has that, and it is still two things short, both of them nameable and neither of them a function-value question any more. The built-in set needs none of it: heap-allocator and arena-new are C symbols the emitter names, and no Flan type mentions them. *) | "make-allocator" | "allocator-from" | "allocator" -> fail loc "a user-written allocator is not implemented yet — use (arena-new ...) \ with a backing buffer" | "heap-allocator" -> arity ctx loc name 0 args; expect ctx loc ~want (seal_alloc ctx loc (rt loc raw_alloc "flan_heap_allocator" [])) (* The capacity is explicit and there is no growing backing store: an arena whose size is decided by the program is one a program can reason about, and it is the only shape under which "exhausted" is a state a test can reach on purpose. *) | "arena-new" -> arity ctx loc name 1 args; let cap = check ctx ~want:(Types.Int Types.I64) (List.hd args) in expect ctx loc ~want (seal_alloc ctx loc (rt loc raw_alloc "flan_arena_new" [ cap ])) (* Hands the pages back, which [free-all] deliberately does not — see TODO.org, "Allocators, (Vec T) and StorageExhausted". *) | "arena-destroy" -> arity ctx loc name 1 args; let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_arena_destroy", [ a ]))) (* One of spec-memory.md's two release points. It takes the source location as a string so that an allocator with no region to release names the site rather than the runtime. *) | "free-temp" -> arity ctx loc name 0 args; expect ctx loc ~want (rt loc Types.Unit "flan_free_temp" []) | "free-all" -> arity ctx loc name 1 args; let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_alloc_free_all", [ a; here loc ]))) (* The capability set, read off the allocator value. Odin asks its procedure (Query_Features returning an Allocator_Mode_Set); a field is the same answer without the round trip, which is the call this made. *) | "can-free" -> arity ctx loc name 1 args; let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc Types.Bool (Tast.Prim (Tast.Ne, [ mk loc (Types.Int Types.I8) (Tast.Prim (Tast.Rt "flan_alloc_can_free", [ a ])); mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))) | "can-free-all" -> arity ctx loc name 1 args; let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc Types.Bool (Tast.Prim (Tast.Ne, [ mk loc (Types.Int Types.I8) (Tast.Prim (Tast.Rt "flan_alloc_can_free_all", [ a ])); mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))) (* The counter [free-all] bumps. A container records it and traps if it moved; this is the same number, readable, so a program can say what it saw. *) | "alloc-epoch" -> arity ctx loc name 1 args; let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_epoch", [ a ]))) (* The allocator's identity — its address — which is what the condition's :allocator field carries, so a handler holding several regions can tell which one ran out. *) | "alloc-id" -> arity ctx loc name 1 args; let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_id", [ a ]))) (* A ceiling on live bytes, 0 for none. spec-memory.md's retry restart is answerable only by a handler that can make the *same* request succeed, and for a fixed backing store the handler that works is the one that grows it: releasing the region a container lives in invalidates the container, which is what the epoch check catches. So the spec's "grows the arena and then invokes retry" needs a ceiling to raise, and this is it. It is also how a program exhausts an allocator on purpose. *) | "alloc-budget" -> arity ctx loc name 1 args; let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_budget", [ a ]))) | "set-alloc-budget" -> arity ctx loc name 2 args; (match args with | [ a; n ] -> let a = alloc_value ctx loc a in let n = check ctx ~want:(Types.Int Types.I64) n in expect ctx loc ~want (mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_alloc_set_budget", [ a; n ]))) | _ -> assert false) (* "Did you forget to free" is an allocator-tier question and this is the tier answering it — spec-memory.md, "Leaking is defined behaviour". *) | "alloc-live-blocks" -> arity ctx loc name 1 args; let a = alloc_value ctx loc (List.hd args) in expect ctx loc ~want (mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_live_blocks", [ a ]))) (* (with-allocator A BODY...). It rebinds and releases nothing: not at the end of the body, not anywhere. spec-memory.md is explicit that this is not a scope-end release point and that it is the point on which Odin's [defer delete] and Carp's scope-end frees were both rejected. *) | "with-allocator" -> (match args with | [] -> fail loc "with-allocator is (with-allocator allocator body ...)" | a :: body -> (* Two values in this frame, handed to the runtime by address: the one to install, checked here so a stale one traps at this site, and the room for the one it displaces, so the restore puts that back with its incarnation (flan_rt.c, flan_context_set). *) let a = let pair = Types.Array (2L, Types.Alloc) in let s = fresh_slot ctx pair in let first = addr_of loc (mk loc pair (Tast.Local s)) in mk loc raw_alloc (Tast.Let ([ (s, mk loc pair (Tast.Arr [ check ctx ~want:Types.Alloc a; mk loc Types.Alloc (Tast.Zero Types.Alloc) ])) ], [ rt loc raw_alloc "flan_alloc_use" [ first; here loc ]; addr_of loc (mk loc pair (Tast.Local s)) ])) in let body, ty = scoped ctx (fun () -> match body with | [] -> [ unit_at loc ], Types.Unit | _ -> let rec go = function | [ last ] -> let l = check ctx ?want last in [ l ], l.Tast.ty | e :: rest -> let e = check ctx e in let rest, ty = go rest in e :: rest, ty | [] -> assert false in go body) in expect ctx loc ~want (mk loc ty (Tast.WithAlloc (a, body)))) (* ── (Vec T), spec-memory.md ───────────────────────────────────── *) (* Every one of these is a named call over a type-erased runtime, with size_of and align_of produced here because here is where the concrete element type is known. No generics are involved and none are needed. *) (* (vec-new), (vec-new T), (vec-new a), (vec-new T a). [let] has no type annotation — parse.ml settles that a triple binding is ambiguous and types are inferred — so a local Vec has nowhere to say what it holds, and the element type is written at the call instead. This is not the explicit instantiation syntax the generics section rules out: nothing here is generic, and the name is resolved as an ordinary type, not bound to a type variable. Where the context does say — a defonce's type, a function's return type, an argument — it is not needed and may be left out. *) | "vec-new" -> let elem, args = vec_new_elem ctx ~want loc args in (* [(vec-new dyn)] is not a [(Vec dyn)]. At milestone 1 the heterogeneous container is the dyn runtime's own object, and its type is [dyn] like everything else the runtime hands back — which is what lets [push], [at] and [length] on it go through the dyn operations rather than through a type-erased Vec over eight-byte elements. The two could be made to coincide later, and the reason not to now is the collector: a Flan Vec's storage comes from an allocator the program named, and the words in it would be roots the collector has to find inside a block it does not own. The runtime's own vector is storage the collector already knows about. *) if elem = Types.Dyn then begin if args <> [] then fail loc "(vec-new dyn) takes no allocator — its storage is the dyn \ runtime's"; expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_vec_new" []) end else expect ctx loc ~want (vec_init ctx loc elem (allocator_arg ctx loc args)) (* Unit, not a Result and not an ignorable error code: see [alloc_guard]. *) | "push" -> arity ctx loc name 2 args; (match args with | [ target; x ] -> let target = check_target ctx target in refuse_const_change ctx loc target; (* A push into a dyn container is a call and nothing else: no allocation guard, no restart, no region check. The dyn runtime owns the storage and answers a failure to grow it on its own terms — the guard and the retry restart exist for an allocator the *program* named, and here there is none to name. *) if target.Tast.ty = Types.Dyn then expect ctx loc ~want (rt loc Types.Unit "flan_dyn_push" [ target; check ctx ~want:Types.Dyn x; here loc ]) else begin let elem = vec_elem loc "push" target.Tast.ty in note_grown ctx "push" loc target; let x = check ctx ~want:elem x in (* The element is bound before the loop so that a [retry] re-attempts the allocation and not the expression that produced the value. *) let e = fresh_slot ctx elem in let attempt = rt loc (Types.Int Types.I8) "flan_vec_push" [ target; addr_of loc (mk loc elem (Tast.Local e)); size_of loc elem; align_of loc elem; here loc ] in (* Re-noted after every push, not only the first: a push that grows the Vec moves the storage, and the note is keyed on the base address, so an unmoved block costs a probe and an overwrite with the same numbers. This is the insert per allocation TODO.org's "The allocation registry" settles on, and the settled answer to what it costs is "measure a real program". *) expect ctx loc ~want (mk loc Types.Unit (Tast.Let ([ (e, x) ], [ region_check ctx.env loc target (with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_vec" target [ size_of loc elem ] elem)) ]))) end | _ -> assert false) | "reserve" -> arity ctx loc name 2 args; (match args with | [ target; n ] -> let target = check_target ctx target in refuse_const_change ctx loc target; let n = check ctx ~want:index_ty n in note_grown ctx "reserve" loc target; let n64 = mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Cast (Types.Int Types.I64), [ n ])) in (* Deferred: the sizes are known abstractly but the hash is not, so the node is a unit no-op and the copy builds the real one. *) if (match target.Tast.ty with | Types.Map (k, _) -> deferred_key ctx.env loc "reserve" k | _ -> false) then expect ctx loc ~want (mk loc Types.Unit Tast.Unit) else let attempt, note = match target.Tast.ty with (* For a map the number is entries, not slots: the runtime sizes the block so that [n] still sits under the load factor, which is the only reading of "room for n" that does not reallocate on the nth put. *) | Types.Map (k, v) -> let hash, _ = key_fns ctx.env loc k in rt loc (Types.Int Types.I8) "flan_map_reserve" [ target; n64; size_of loc k; size_of loc v; hash; here loc ], reg_note loc "flan_dev_reg_note_map" target [ size_of loc k; size_of loc v ] target.Tast.ty | _ -> let elem = vec_elem loc "reserve" target.Tast.ty in rt loc (Types.Int Types.I8) "flan_vec_reserve" [ target; n64; size_of loc elem; align_of loc elem; here loc ], reg_note loc "flan_dev_reg_note_vec" target [ size_of loc elem ] elem in expect ctx loc ~want (region_check ctx.env loc target (with_note loc (alloc_guard ctx loc attempt) note)) | _ -> assert false) (* spec-memory.md's first release point. Since the repeal, what it consumes it consumes at run time only: nothing marks the binding dead, so a second [free] or a read after this one type-checks and misbehaves at run time — the allocator aborts on a double free it can see, and the epoch word traps a read through a released region. That is the Odin contract: free is a thing you write, and writing it twice is yours to not do. *) | "free" -> (match args with | [ _ ] | [ _; _ ] -> () | _ -> fail loc "free is (free v), or (free s allocator) for a slice"); let target = check_target ctx (List.hd args) in refuse_const_change ctx loc target; (match target.Tast.ty, args with | (Types.Vec _ | Types.Map _), [ _; _ ] -> fail loc "a %s knows the allocator it came from, so free takes only the \ container. Write (free %s)" (tyname loc target.Tast.ty) (spell_arg "v" (List.hd args)) | _ -> ()); (* A container of owning elements is refused here, and a reader will assume the opposite — that [free] recurses — so this says why it does not and what does. The bytes this container holds are element *headers*, and releasing the block those headers sit in says nothing about the blocks they point at. Nothing type-erased can walk them: the runtime sees a size and an alignment and has never heard of the element type. That is the same fact the type-level refusals used to state, and the arena did not change it — what the arena changed is that it no longer matters there, because the inner blocks came out of the same region and [free-all] takes them with everything else. So the honest answer is not to recurse, and it is not to release the backing store quietly either. Releasing the outer block alone would be "I freed it" spelt over a program that leaked everything inside, and this file refuses that collapse everywhere else — [flan_alloc_free_all] traps rather than no-op for the same reason. It is refused instead, at the one place a reader is looking when they want to know. The guard at construction is what makes the advice reachable: such a container is region-allocated or it does not exist, so there is always a [free-all] to point at. *) (match target.Tast.ty with | t when is_string_ty t -> (match args with | [ _; _ ] -> fail loc "a String knows the allocator it came from, so free takes only \ the String. Write %s" (if fln_source loc then "free(" ^ spell_arg "s" (List.hd args) ^ ")" else "(free " ^ spell_arg "s" (List.hd args) ^ ")") | _ -> ()); expect ctx loc ~want (rt loc Types.Unit "flan_vec_free" [ string_vec loc target; size_of loc u8_ty; align_of loc u8_ty; here loc ]) | (Types.Vec _ | Types.Map _) when region_only ctx.env target.Tast.ty -> fail loc "%s holds elements that own storage, and free releases only the \ block those elements sit in. Write (free-all a) on the region it \ was built against" (tyname loc target.Tast.ty) | Types.Vec elem -> expect ctx loc ~want (rt loc Types.Unit "flan_vec_free" [ target; size_of loc elem; align_of loc elem; here loc ]) | Types.Map (k, v) -> expect ctx loc ~want (rt loc Types.Unit "flan_map_free" [ target; size_of loc k; size_of loc v; here loc ]) (* A slice (bytes s) or (clone xs) answered: its block goes back to the allocator it came from, which a slice does not carry — so it is the context allocator, as Odin's delete defaults to, or the one named. A dev build checks the block against the allocation registry and traps on a slice that is not the start of a block, or on the wrong allocator, instead of handing one allocator another's block. *) | Types.Slice (Types.Const, _) -> fail loc "%s can only be read, so it cannot be freed. Free the [%s] it was \ copied into" (tyname loc target.Tast.ty) (match target.Tast.ty with | Types.Slice (_, e) -> tyname loc e | t -> tyname loc t) (* A view written right here — (slice ...) or (slice-from ...) — is storage something else owns, known without running anything. *) | Types.Slice (Types.Mut, _) when (match (List.hd args).Ast.e with | Ast.Call ({ Ast.e = Ast.Var ("slice" | "slice-from"); _ }, _) -> true | _ -> false) -> fail loc "this is a view of storage something else owns, so it cannot be \ freed. Only a slice (bytes s) or (clone xs) made can be" | Types.Slice (Types.Mut, elem) -> let a = allocator_arg ctx loc (List.tl args) in expect ctx loc ~want (rt loc Types.Unit "flan_slice_free" [ target; size_of loc elem; align_of loc elem; a; here loc ]) | other -> (* A field is never freed on its own: it would leave its owner partly dead with no way to say so. *) fail loc "free takes a Vec, a Map, or a slice (bytes s) or (clone xs) made — \ found %s" (tyname loc other)) (* Emitted by the prelude's [into] when no (map f) is in the chain, so that every element pushed is a source element as it stands. A push copies an element's header, and for an element that owns storage the copy and the source then share one block: growing an element through either side reallocates it and frees the block the other still points at. That is a use after free the program never wrote, under a name that promised a copy, so it is refused here. A bare (push w (at v 0)) is not: it copies a header in plain sight, the Odin contract every container follows. Arguments are the source, then the destination and the transforms as written — those two only to be spelled back in the fix, never checked. *) | "into-copies-elements" -> (match args with | src :: dst :: transforms -> let s = check ctx src in let elem = match s.Tast.ty with | Types.Vec e | Types.Slice (_, e) | Types.Array (_, e) -> Some e | _ -> None in (match elem with | Some e when owning ctx.env e -> let v = spell_arg "v" src in let et = tyname loc e in let fix = if clone_accepts ctx.env e then match spell_form dst, List.map spell_form transforms with | Some d, ts when not (List.mem None ts) -> Printf.sprintf "Add (map clone) to the chain, which copies what each \ element owns: (into %s)" (String.concat " " ((v :: d :: List.filter_map Fun.id ts) @ [ "(map clone)" ])) | _ -> "Add (map clone) to the chain, which copies what each element \ owns" else Printf.sprintf "Nothing copies what a %s owns, so no copy of %s can stand on \ its own: read the elements where they are, or build each new \ element and push that" et v in Loc.failk "check/into-shares-elements" src.Ast.loc "into copies each element of %s as it stands, and an element of \ %s is a %s, which owns storage — the copy would share each \ element's block with %s, and growing either one frees the block \ the other points at. %s" v v et v fix | _ -> ()); expect ctx loc ~want (mk loc Types.Unit Tast.Unit) | _ -> expect ctx loc ~want (mk loc Types.Unit Tast.Unit)) (* (clone v) uses the current allocator, (clone v a) names one. A deep, independent copy: spec-memory.md's "copying is always explicit". *) | "clone" -> (match args with | target :: rest when List.length rest <= 1 -> lit_typed_use ctx target; (* Checked once, then dispatched on what it turned out to be: checking it inside a guard as well would allocate the target's slots twice and evaluate whatever it was written as twice. *) let target = check_target ctx target in let a = allocator_arg ctx loc rest in (match target.Tast.ty with (* A String's copy is a copy of its bytes, which are valid already. *) | t when is_string_ty t -> let v = string_vec loc target in let d = fresh_slot ctx string_vec_ty in let attempt = rt loc (Types.Int Types.I8) "flan_vec_clone" [ mk loc string_vec_ty (Tast.Local d); v; a; size_of loc u8_ty; align_of loc u8_ty; here loc ] in expect ctx loc ~want (mk loc string_ty (Tast.Make ("String", [ mk loc string_vec_ty (Tast.Let ([ (d, mk loc string_vec_ty (Tast.Zero string_vec_ty)) ], [ with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_vec" (mk loc string_vec_ty (Tast.Local d)) [ size_of loc u8_ty ] string_ty); mk loc string_vec_ty (Tast.Local d) ])) ]))) (* The refusal that did *not* come down with the type-level ones, and the distinction is worth being exact about, because the sentence they all used to share bundled two different failures: that a clone would duplicate inner headers instead of copying, and that a free would leak what those headers own. Only the second was about teardown, and only the second is answered by a region. What disqualifies [clone] is not that it copies a header — so do [at] and [get], and they are fine, because they promise nothing and hand back an alias into a region nobody individually frees. It is that [clone] *allocates a new block and promises independence*. spec-memory.md calls it a deep copy; what a memcpy of the slots delivers is a second container whose elements still point into the first one's blocks. Two containers, one set of inner buffers, under a name that says otherwise — and putting the copy in a second arena makes it worse, not better, because tipping that arena leaves the copy's elements pointing into an arena that is still live while its own storage is gone. Refused at the operation rather than at the type, because that is where the promise is made. *) | (Types.Vec _ | Types.Map _) when region_only ctx.env target.Tast.ty -> fail loc "%s cannot be cloned — its elements own storage, and nothing here \ can walk one to copy what it owns. %s" (tyname loc target.Tast.ty) (insert_copies ~loc:target.Tast.loc ctx.env target.Tast.ty) (* A slice's elements, copied into a block from the allocator and answered as a slice over it — what (bytes s) does for a string's bytes, and the same lowering. The same refusal as a Vec's, for the same reason: a copy of owning elements is a copy of their headers. *) | Types.Slice (_, elem) when owning ctx.env elem -> fail loc "%s cannot be cloned — its elements own storage, and nothing here \ can walk one to copy what it owns. %s" (tyname loc target.Tast.ty) (insert_copies ~loc:target.Tast.loc ctx.env target.Tast.ty) (* The copy is a block from an allocator, which the collector does not walk, so a dyn in it would be a root nothing marks. *) | Types.Slice (_, elem) when holds_dyn ctx.env elem -> fail loc "%s cannot be cloned — its elements hold a dyn, and the copy would \ live in allocator storage the collector does not look in. Build \ a dyn vector from the elements instead" (tyname loc target.Tast.ty) | Types.Slice (_, elem) -> expect ctx loc ~want (dup_elems ctx loc elem target a) (* A map's clone reinserts rather than copying the block, because the seed is derived from the block's address — see flan_rt.c. That is the runtime's business; from here it is one more allocating call under the same guard. *) | Types.Map (k, v) when deferred_key ctx.env loc "clone" k -> (* Deferred, and the placeholder is a zeroed map of the same type — the value a (map-new) starts from, so everything written around the clone still checks against the type it will have. *) let mty = Types.Map (k, v) in expect ctx loc ~want (mk loc mty (Tast.Zero mty)) | Types.Map (k, v) -> let mty = Types.Map (k, v) in let hash, _ = key_fns ctx.env loc k in let d = fresh_slot ctx mty in let attempt = rt loc (Types.Int Types.I8) "flan_map_clone" [ mk loc mty (Tast.Local d); target; a; size_of loc k; size_of loc v; hash; here loc ] in expect ctx loc ~want (mk loc mty (Tast.Let ([ (d, mk loc mty (Tast.Zero mty)) ], [ with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_map" (mk loc mty (Tast.Local d)) [ size_of loc k; size_of loc v ] mty); mk loc mty (Tast.Local d) ]))) | _ -> let elem = vec_elem loc "clone" target.Tast.ty in let d = fresh_slot ctx (Types.Vec elem) in let attempt = rt loc (Types.Int Types.I8) "flan_vec_clone" [ mk loc (Types.Vec elem) (Tast.Local d); target; a; size_of loc elem; align_of loc elem; here loc ] in expect ctx loc ~want (mk loc (Types.Vec elem) (Tast.Let ([ (d, mk loc (Types.Vec elem) (Tast.Zero (Types.Vec elem))) ], [ with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_vec" (mk loc (Types.Vec elem) (Tast.Local d)) [ size_of loc elem ] elem); mk loc (Types.Vec elem) (Tast.Local d) ])))) | _ -> fail loc "clone is (clone v) or (clone v allocator)") (* ── String, the prelude's owned text ───────────────────────────── Each is [string_call]'s, which says what each one checks. *) | "string-new" | "bytes->string" | "append" | "insert" | "remove" -> string_call ctx ~want loc name args | "runes" | "rune-count" -> string_call ctx ~want loc name args (* ── (Map K V), spec-memory.md ─────────────────────────────────── *) (* Every one of these is a named call over the same type-erased runtime the Vec uses, with the two sizes and the key's hash and equality pair produced here because here is where the concrete types are known. No generics are involved and none are needed — which is exactly what Odin's Map_Info says too, being two sizes and two contextless procs. *) (* (map-new), (map-new K V), (map-new a), (map-new K V a). The same shape [vec-new] has and for the same reason: a [let] has no type annotation, so a local map has nowhere else to say what it holds. Where the context does say — a defonce's type, a parameter, a return type — the pair may be left out. *) | "map-new" -> let k, v, args = map_new_types ctx ~want loc args in let a = allocator_arg ctx loc args in let mty = map_type ~preds:ctx.env.tvpreds loc k v in let m = fresh_slot ctx mty in let attempt = rt loc (Types.Int Types.I8) "flan_map_init" [ mk loc mty (Tast.Local m); a; size_of loc k; size_of loc v; here loc ] in expect ctx loc ~want (mk loc mty (Tast.Let ([ (m, mk loc mty (Tast.Zero mty)) ], [ with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_map" (mk loc mty (Tast.Local m)) [ size_of loc k; size_of loc v ] mty); region_check ctx.env loc (mk loc mty (Tast.Local m)) (mk loc mty (Tast.Local m)) ]))) (* (put m k v) — the upsert. Unit, not a Result and not an ignorable error code: see [alloc_guard]. spec-memory.md is explicit that it either inserts or replaces, and that (set (get m k) v) is not map syntax. *) | "put" -> arity ctx loc name 3 args; (match args with | [ target; k; v ] -> let target = check_target ctx target in refuse_const_change ctx loc target; (* A put into a dyn map is a call and nothing else, the way a push into a dyn vec is: the runtime owns the storage, so there is no guard, no restart and no region check. An equal key's value is replaced. The site rides along for the one refusal a put can meet, a class instance's typed slot. *) if target.Tast.ty = Types.Dyn then expect ctx loc ~want (rt loc Types.Unit "flan_dyn_map_put" [ target; check ctx ~want:Types.Dyn k; check ctx ~want:Types.Dyn v; here loc ]) else begin let kt, vt = map_kv loc "put" target.Tast.ty in note_grown ctx "put" loc target; let k = check ctx ~want:kt k in let v = check ctx ~want:vt v in (* Deferred: the arguments are checked — so a move here is still a move and a borrow still a borrow — and the node itself is a unit no-op, thrown away with the rest of the abstract pass. *) if deferred_key ctx.env loc "put" kt then expect ctx loc ~want (mk loc Types.Unit Tast.Unit) else (* Both are bound before the loop, so that a [retry] re-attempts the allocation and not the expressions that produced the key and the value. The same rule [push] follows for its element. *) let ks = fresh_slot ctx kt and vs = fresh_slot ctx vt in let hash, eq = key_fns ctx.env loc kt in let attempt = rt loc (Types.Int Types.I8) "flan_map_put" [ target; addr_of loc (mk loc kt (Tast.Local ks)); addr_of loc (mk loc vt (Tast.Local vs)); size_of loc kt; size_of loc vt; hash; eq; here loc ] in expect ctx loc ~want (mk loc Types.Unit (Tast.Let ([ (ks, k); (vs, v) ], [ region_check ctx.env loc target (with_note loc (alloc_guard ctx loc attempt) (reg_note loc "flan_dev_reg_note_map" target [ size_of loc kt; size_of loc vt ] target.Tast.ty)) ]))) end | _ -> assert false) (* (get m k) -> (Option V). Absence is None, not an untyped nil, and the answer is a copy of the value's bytes — for an owning value, a copy of its header, aliasing what the map's slot points at. There is no allocation here and therefore no guard: a lookup that finds nothing is an answer, not a failure. *) | "get" -> (match args with | target :: (_ :: _ :: _ as idx) -> (* Two indices or more: an array, a slice or a Vec, one per dimension, or a dyn walked a level per index. A map takes one key. *) let target = check_target ctx target in (match target.Tast.ty with | Types.Map _ -> fail loc "a map's get takes one key, as (get m k), and this has %d" (List.length idx) | Types.Named "String" -> (ignore (refuse_string_index (List.hd idx).Ast.loc ~store:false); assert false) | Types.Dyn -> dyn_get ctx ~want loc target idx | _ -> checked_get ctx ~want loc target idx) | [ target; k ] -> let target = check_target ctx target in (match target.Tast.ty with | Types.Array _ | Types.Slice _ | Types.String | Types.Vec _ -> checked_get ctx ~want loc target [ k ] (* The same refusal [at] gives: a String is not indexed. *) | Types.Named "String" -> (ignore (refuse_string_index k.Ast.loc ~store:false); assert false) | Types.Dyn -> dyn_get ctx ~want loc target [ k ] | _ -> (* A dyn map's absence is nil, not None: the typed map can promise an (Option V) because V was written down, and a dyn map has nothing to write. nil is an ordinary dyn value the caller compares against — and (contains? m k) is the question to ask when nil might also be stored under the key. *) let kt, vt = map_kv loc "get" target.Tast.ty in let k = check ctx ~want:kt k in (* Deferred, and the placeholder is [None] rather than [Unit]: this form answers an (Option V), and the abstract pass still has to type-check whatever the body does with the answer. *) if deferred_key ctx.env loc "get" kt then expect ctx loc ~want (mk loc (Types.Option vt) Tast.None_) else map_lookup ctx ~want loc "flan_map_get" target kt vt k) | _ -> arity ctx loc name 2 args; assert false) (* (keyword s) -> the interned dyn keyword named by the bytes, for a name that only exists at run time — a reader building :texture-path out of a token's text. A literal :foo never comes through here. *) | "keyword" -> arity ctx loc name 1 args; (match args with | [ s ] -> let s = check ctx s in (match s.Tast.ty with | Types.String | Types.Slice (_, (Types.Int Types.U8)) -> expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_kw" [ s ]) | other -> fail loc "keyword takes a string or a [u8], found %s" (tyname loc other)) | _ -> assert false) (* (class-of v) -> the class's name as a keyword, or nil. It is the dyn side's one question about shape, and the dispatch a (defgeneric ...) compiles to is this call and a comparison — so what a class dispatcher is, exactly, is the shape tag of the first argument as the dispatch function, which is what makes the CLOS half and the Clojure half one mechanism rather than two. Anything that is not an instance answers nil rather than trapping: an ordinary map, a number, nil itself. Asking is not a claim, and the question is askable of every value — the same line [get] takes about an absent key. *) | "class-of" -> arity ctx loc name 1 args; (match args with | [ v ] -> expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_class_of" [ check ctx ~want:Types.Dyn v ]) | _ -> assert false) (* (type-of v) -> the value's kind as a keyword, or a class instance's class name. A typed argument crosses into dyn first, as it does for class-of and every other dyn builtin, so it answers the kind the crossing makes of it: a typed i32 is :int and an f32 is :float. That keeps one answer per value whichever side of the program holds it. *) | "type-of" -> arity ctx loc name 1 args; (match args with | [ v ] -> expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_type_of" [ check ctx ~want:Types.Dyn v ]) | _ -> assert false) (* (chars t) and (text x): a dyn text as a vec of its chars, and back. A dyn text is immutable, so a vec of chars is how one is edited. *) | "chars" | "text" -> arity ctx loc name 1 args; let sym = if name = "chars" then "flan_dyn_chars" else "flan_dyn_text" in expect ctx loc ~want (rt loc Types.Dyn sym [ check ctx ~want:Types.Dyn (List.hd args); here loc ]) (* (map-remove m k) -> (Option V): the value that was there, or None when the key was not. The same answer [get] gives, for the same reason — a key that is not in the map is an answer and not a failure — and the value comes back rather than being dropped on the floor, which is what makes "take this out and use it" one call instead of a get and a remove that hash the key twice. It allocates nothing and releases nothing, so unlike [put] there is no alloc_guard and no region check around it: a key and a value live inside the one block the map allocated, and removal moves entries within that block. That is what makes it mean the same thing on a map backed by an arena — or by any allocator that refuses can-free — as on a heap-backed one. Nothing is freed per entry because nothing was allocated per entry. *) | "map-remove" -> arity ctx loc name 2 args; (match args with | [ target; k ] -> let target = check_target ctx target in refuse_const_change ctx loc target; let kt, vt = map_kv loc "map-remove" target.Tast.ty in let k = check ctx ~want:kt k in (* Deferred exactly as [get] is, and with [None] for the same reason: the abstract pass still has to check whatever the body does with the answer. *) if deferred_key ctx.env loc "map-remove" kt then expect ctx loc ~want (mk loc (Types.Option vt) Tast.None_) else map_lookup ctx ~want loc "flan_map_remove" target kt vt k | _ -> assert false) (* (map-next m (addr cur) (addr k) (addr v)) -> bool, and the whole of map iteration. Before it there was no way to read a map's keys or its values at all: every other map operation addresses one entry by hashing it, and nothing walked the block. Three out-pointers rather than a returned pair, because there are no tuples and a (Option K) would answer only half of an entry — the value would then cost a second hash of the key just answered. The cursor is an i64 the caller owns and the loop reads as one: (let [cur 0 k 0 v 0] (while (map-next m (addr cur) (addr k) (addr v)) ...)) The prelude's map-keys and map-values are this loop over a generic key. No hash and no equality pair go with it — walking asks nothing about a key — so this is the one map entry point whose signature carries neither, and the sizes are still needed because the runtime is type-erased. *) (* (map-next m cur k) walks the keys alone. It is what lets a walk need no place for a value, which matters when the value is a function value: one cannot be zeroed to make the place, and a key never is one. *) | "map-next" -> (match args with | [ _; _; _ ] | [ _; _; _; _ ] -> () | _ -> fail loc "map-next is (map-next m (addr cursor) (addr k) (addr v)) or, for \ the keys alone, (map-next m (addr cursor) (addr k)) — given %d \ arguments" (List.length args)); (match args with | target :: cur :: k :: rest -> let target = check_target ctx target in let kt, vt = map_kv loc "map-next" target.Tast.ty in let cur = check ctx ~want:(Types.Ptr (Types.Mut, (Types.Int Types.I64))) cur in let k = check ctx ~want:(Types.Ptr (Types.Mut, kt)) k in let vp = Types.Ptr (Types.Mut, vt) in let v = match rest with | [ v ] -> check ctx ~want:vp v | _ -> mk loc vp (Tast.Zero vp) in let found = rt loc (Types.Int Types.I8) "flan_map_next" [ target; cur; k; v; size_of loc kt; size_of loc vt; here loc ] in expect ctx loc ~want (mk loc Types.Bool (Tast.Prim (Tast.Ne, [ found; mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))) | _ -> assert false) (* (has-key m k). (get m k) answers the same question, but through an Option the caller then has to match; this is the form a condition wants, and it copies no value. *) | "has-key" -> arity ctx loc name 2 args; (match args with | [ target; k ] -> let target = check_target ctx target in (* The dyn map's question, one word with the typed one. It exists on the dyn side because absence there is nil, and a map can also store nil under a key — (get m k) answering nil cannot tell the two apart, and this can. The bool comes back unboxed the way a dyn comparison does, because a presence test is overwhelmingly an if's condition. *) if target.Tast.ty = Types.Dyn then expect ctx loc ~want (unbox loc Types.Bool (rt loc Types.Dyn "flan_dyn_map_contains_at" [ target; check ctx ~want:Types.Dyn k; here loc ])) else begin let kt, vt = map_kv loc "has-key" target.Tast.ty in let k = check ctx ~want:kt k in (* Deferred, and the placeholder is a [bool] — the form a condition wants, so the condition around it still has to check. *) if deferred_key ctx.env loc "has-key" kt then expect ctx loc ~want (mk loc Types.Bool (Tast.Bool false)) else let hash, eq = key_fns ctx.env loc kt in let ks = fresh_slot ctx kt in let found = rt loc (Types.Int Types.I8) "flan_map_has" [ target; addr_of loc (mk loc kt (Tast.Local ks)); size_of loc kt; size_of loc vt; hash; eq; here loc ] in expect ctx loc ~want (mk loc Types.Bool (Tast.Let ([ (ks, k) ], [ mk loc Types.Bool (Tast.Prim (Tast.Ne, [ found; mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])) ]))) end | _ -> assert false) (* ── Assets, decision 1: embedded at compile time ────────────── Odin's #load and #load_directory are the model (src/parser.cpp, src/check_builtin.cpp's check_load_directive), and the reason it is the right answer here is TODO.org's "Assets are embedded at compile time": it is a *compiler* feature, so it needs no build flags, no linker arguments and no per-target packaging, and it works identically on desktop and web. That matters more here than it does for Odin, because [Load] gives link flags only to a directory package — the single file doing (rl/load-texture "brush.png") is structurally the one file with no link channel. Embedding has no such hole. Odin's `#` is not imported. An s-expression language already has a head position for a name, so these are ordinary named calls spelled [embed] and [embed-dir], resolved here exactly as [vec-new] and [heap-allocator] are. The result costs nothing at run time: the bytes become a `private unnamed_addr constant` string, the same one every string literal already becomes, and emit.ml's [escape] is byte-exact, so a PNG survives the round trip through the .ll. Bound with [defconst], an [embed-dir] becomes an LLVM constant outright (emit.ml's [const]). The slice this hands back points into .rodata, so it is a [const u8]: a store through it would segfault at -O0 and be deleted at -O2, and the type refuses it at compile time instead. Copy the bytes for a writable buffer. *) | "embed" -> (match args with | [ p ] | [ p; _ ] -> (* The spelling is settled before the file is opened, so a program that asks for a type embed cannot read a file as is told that, rather than being told the file is missing and left to discover the other half after fixing it. *) (match args with | [ _; { Ast.e = Ast.Var "str"; _ } ] | [ _ ] -> () | [ _; t ] -> fail t.Ast.loc "embed's second argument is str, or nothing for a [const u8]" | _ -> ()); let data = read_embed_file (embed_path loc p) p.Ast.loc in let as_string () = mk loc Types.String (Tast.Str data) in (* A [Str] node typed [const u8] rather than a [Bytes] prim over one. [Bytes] is identity — emit.ml lowers String and Slice _ to the same %slice — and the prim would make the node non-constant, so an (embed-dir) in a defconst could not be an LLVM constant. Both of emit.ml's string emitters take the bytes and ignore the node's type, so this is the same constant either way, and it is one a global can hold. *) let as_bytes () = mk loc (Types.Slice (Types.Const, Types.Int Types.U8)) (Tast.Str data) in (* Two spellings rather than one that changes type with its context. Odin threads a type_hint everywhere and can afford (embed "p") to mean a string here and a []u8 there; with structural equality and a container that never converts to another container -- implicit widening is numbers only -- the same text meaning two types would be a wart. [want] is a fallback only, and nothing depends on it. *) (match args with | [ _; { Ast.e = Ast.Var "str"; _ } ] -> expect ctx loc ~want (as_string ()) | _ -> (match want with | Some Types.String -> as_string () | _ -> expect ctx loc ~want (as_bytes ()))) | _ -> fail loc "embed is (embed \"path\") for a [const u8], or (embed \"path\" str)") (* ── What a macro says when it has to refuse ─────────────────── The one thing a macro could not do, written down in the prelude where [unless] settles for it: "a macro has no error facility: it runs inside the compiler and anything it signals aborts the compile with no location. So a malformed (unless) answers a name nothing defines, and the report is 'unknown name unless-takes-a-test-and-a-body' at the call site, which is the right place and the wrong sentence." A name nothing defines carries a name. It cannot carry a sentence, and a type provider's refusals are all sentence: the third element of this vector is a string where the first two were integers; there is no file at assets/x.edn; :size is a map with keys of two kinds. Those name a position in a *data* file, which no symbol the expansion could invent will hold. So a macro that has to refuse expands to a call to this, and the string is the report. The string is a form the macro built, so it has no line of its own and takes the call site's — the [defedn] the author wrote. The location is theirs and the sentence is the macro's, which is the two halves the prelude's note says are never both right at once. A builtin and not a declaration, because it has to fail *here*: a declared function would compile, link and run, and the compile it was meant to stop would have succeeded. The whole of it is one arm, and the argument is a literal for the same reason [embed]'s path is one — there is nothing at this point in a compile to compute a string from. *) | "compile-error" -> arity ctx loc name 1 args; (match (List.hd args).Ast.e with | Ast.Str s -> fail loc "%s" s | _ -> fail (List.hd args).Ast.loc "compile-error takes a literal string") | "embed-dir" -> arity ctx loc name 1 args; let arg = List.hd args in let entries = read_embed_dir (embed_path loc arg) arg.Ast.loc in if not (Hashtbl.mem ctx.env.structs "EmbedFile") then fail loc "embed-dir answers a [n EmbedFile], and EmbedFile is not in scope"; let ety = Types.Named "EmbedFile" in let elems = List.map (fun (nm, data) -> mk loc ety (Tast.Make ("EmbedFile", [ mk loc Types.String (Tast.Str nm); mk loc (Types.Slice (Types.Const, Types.Int Types.U8)) (Tast.Str data) ]))) entries in expect ctx loc ~want (mk loc (Types.Array (Int64.of_int (List.length entries), ety)) (Tast.Arr elems)) (* ── slurp and barf, decisions 2 and 5 ───────────────────────── [slurp] reads a whole file and answers a (Vec u8). It allocates, which is why it waited for Vec, and it follows spec-memory.md's rule to the letter: no allocating operation returns an error, so there is no Result here and no out-parameter — a failure to allocate is StorageExhausted under [retry] and a failure to read is FileError under [retry] and [use-value]. The two guards nest rather than merge, and that is the point: they are two different failures with two different answerable questions, and a handler that grows an arena is not the handler that supplies another path. Everything is inside the file loop, so a [use-value] that names a different file re-measures it and re-allocates for its size. The Vec is freed at the top of each turn, which is why a retry does not leak; freeing a Vec that never allocated is a no-op (flan_rt.c, flan_vec_free). *) | "slurp" -> (match args with | path :: rest when List.length rest <= 1 -> let path = check ctx ~want:Types.String path in let a = allocator_arg ctx loc rest in let ps = fresh_slot ctx Types.String in let psv () = mk loc Types.String (Tast.Local ps) in let u8 = Types.Int Types.U8 in let vt = Types.Vec u8 in let v = fresh_slot ctx vt in let vv () = mk loc vt (Tast.Local v) in let n = fresh_slot ctx (Types.Int Types.I64) in let nv () = mk loc (Types.Int Types.I64) (Tast.Local n) in let steps try_ = [ (* The size first, because it is the step that does not allocate: a missing file is found before any storage is committed to it. *) try_ (rt loc (Types.Int Types.I8) "flan_file_size" [ psv (); addr_of loc (nv ()) ]); (* Previous turn's storage, if a retry brought us back here. *) rt loc Types.Unit "flan_vec_free" [ vv (); size_of loc u8; align_of loc u8; here loc ]; with_note loc (alloc_guard ctx loc (rt loc (Types.Int Types.I8) "flan_vec_init" [ vv (); a; nv (); size_of loc u8; align_of loc u8; here loc ])) (reg_note loc "flan_dev_reg_note_vec" (vv ()) [ size_of loc u8 ] u8); (* Fills the Vec the line above sized. A file that grew since the measurement is truncated to the buffer; one that shrank leaves a shorter Vec. Both are successful reads of what was there. *) try_ (rt loc (Types.Int Types.I8) "flan_slurp_into" [ vv (); psv (); size_of loc u8; here loc ]) ] in expect ctx loc ~want (mk loc vt (Tast.Let ([ (ps, path); (n, i64_at loc 0L); (v, mk loc vt (Tast.Zero vt)) ], [ file_guard ctx loc ~path_slot:ps ~op:0 steps; vv () ]))) | _ -> fail loc "slurp is (slurp path) or (slurp path allocator)") (* [barf] writes a whole file, and on the web target it signals — every time, with the path in the condition. Decision 2, and the reason is worth having at the call site: Flan has NO conditional compilation, so "isolate this to desktop" is not expressible in source and a build-time refusal would be unusable; a silent no-op is worse than either, because that is how a save file disappears with nothing said. So the program gets a condition and decides. Nothing here reads the target — the refusal is flan_rt.c's, one #ifdef in the host layer, which is exactly where the two targets are already implemented twice. *) | "barf" -> arity ctx loc name 2 args; (match args with | [ path; data ] -> let path = check ctx ~want:Types.String path in let data = byte_slice ctx data in let ps = fresh_slot ctx Types.String in let ds = fresh_slot ctx (Types.Slice (Types.Const, Types.Int Types.U8)) in let steps try_ = [ try_ (rt loc (Types.Int Types.I8) "flan_file_write" [ mk loc Types.String (Tast.Local ps); mk loc (Types.Slice (Types.Const, Types.Int Types.U8)) (Tast.Local ds) ]) ] in (* Both operands are bound before the loop so that a retry re-attempts the write and not the expressions that produced it — the same rule alloc_guard states for push. *) expect ctx loc ~want (mk loc Types.Unit (Tast.Let ([ (ps, path); (ds, data) ], [ file_guard ctx loc ~path_slot:ps ~op:1 steps ]))) | _ -> assert false) (* ── the three that change the filesystem ────────────────────────── [delete-file], [rename-file] and [make-directory] are [barf]'s shape with a different runtime call, and they are here rather than as prelude [declare]s for the one thing a declare cannot do: signal [FileError] with the two restarts the compiler emits. A declare could only answer a bool, and "the delete failed, here is a boolean" is the shape decision 5 exists to keep out of this language — a handler that made the parent directory and wants [retry], or that has another path and wants [use-value], has nothing to hold onto. Each answers [()] and not a bool for the same reason [barf] does: the failure is the condition, so a return value would only ever be true. The questions that are *not* failures — does this exist, how big is it — answer a value instead, and those two are prelude functions over one [declare] because nothing about them needs a restart. [op] continues the FileError numbering the prelude names: 0 read, 1 write, and 2, 3, 4 here. A handler matching on it is matching on the prelude's [file-op-delete] and friends, not on a literal. *) | "delete-file" | "make-directory" -> arity ctx loc name 1 args; let sym, op = if String.equal name "delete-file" then "flan_file_delete", 2 else "flan_file_mkdir", 4 in let path = check ctx ~want:Types.String (List.hd args) in let ps = fresh_slot ctx Types.String in let steps try_ = [ try_ (rt loc (Types.Int Types.I8) sym [ mk loc Types.String (Tast.Local ps) ]) ] in expect ctx loc ~want (mk loc Types.Unit (Tast.Let ([ (ps, path) ], [ file_guard ctx loc ~path_slot:ps ~op steps ]))) (* Two paths and one restart slot, so the guard holds the *source*: a [use-value] renames a different file to the same destination. That is the direction a handler can act on — the destination it asked for is the one thing it already knows — and it is written down here because the other reading is equally plausible until somebody says which it is. The destination is bound before the loop, exactly as [barf] binds its data, so a retry re-attempts the rename and not the expression that computed where to. *) | "rename-file" -> arity ctx loc name 2 args; (match args with | [ from_; to_ ] -> let from_ = check ctx ~want:Types.String from_ in let to_ = check ctx ~want:Types.String to_ in let ps = fresh_slot ctx Types.String in let ds = fresh_slot ctx Types.String in let steps try_ = [ try_ (rt loc (Types.Int Types.I8) "flan_file_rename" [ mk loc Types.String (Tast.Local ps); mk loc Types.String (Tast.Local ds) ]) ] in expect ctx loc ~want (mk loc Types.Unit (Tast.Let ([ (ps, from_); (ds, to_) ], [ file_guard ctx loc ~path_slot:ps ~op:3 steps ]))) | _ -> assert false) (* ── containers ────────────────────────────────────────────────── *) (* [at] and [length] were already the names for a fixed array and a slice, so a Vec extends them rather than adding a parallel pair — which is the asymmetry [nth] was removed for. A Vec's length is i32 like every other length here (index_ty): widening indices is one change across all of them and not a Vec question. *) | "length" -> arity ctx loc name 1 args; let target = List.hd args in let a = check_target ctx target in (match a.Tast.ty with | Types.Array _ | Types.Slice _ | Types.String -> prim Tast.Len index_ty [ a ] | Types.Vec _ -> let n = rt loc (Types.Int Types.I64) "flan_vec_len" [ a; here loc ] in expect ctx loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) (* Bytes, as on a str (decision 107); rune-count counts characters. *) | t when is_string_ty t -> let n = rt loc (Types.Int Types.I64) "flan_vec_len" [ string_vec loc a; here loc ] in expect ctx loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) (* Extended rather than given a name of its own, for the reason [at] and [length] were extended over Vec: one question, one word. *) | Types.Map _ -> let n = rt loc (Types.Int Types.I64) "flan_map_len" [ a; here loc ] in expect ctx loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) (* A dyn length is an i32 like every other length here, not a dyn holding one. [length] is what an index loop compares against, and handing back a boxed number would make [(< i (length xs))] a dyn comparison and a pair of allocations per iteration. The runtime answers a dyn; it is unboxed at once and narrowed the way the Vec's i64 above is. *) | Types.Dyn -> let n = unbox loc (Types.Int Types.I64) (rt loc Types.Dyn "flan_dyn_len_at" [ a; here loc ]) in expect ctx loc ~want (mk loc index_ty (Tast.Prim (Tast.Cast index_ty, [ n ]))) | other -> fail loc "length takes an array, a slice, a str, a String, a Vec or a Map, \ found %s" (tyname loc other)) | "at" -> (match args with | target :: idx when idx <> [] -> let target = check_target ctx target in (match target.Tast.ty with | Types.Vec _ -> let p, elem = vec_at ctx loc target idx in expect ctx loc ~want (mk loc elem (Tast.Deref p)) (* One index, because a dyn container is one dimension: the nested [(at grid r c)] spelling walks a type the compiler can see through, and here it cannot. [(at (at g r) c)] is the spelling that works and is what the refusal names. *) | Types.Dyn -> (match idx with | [ i ] -> expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_at" [ target; check ctx ~want:Types.Dyn i; here loc ]) | _ -> fail loc "(at ...) over a dyn takes one index — write (at (at x i) j)") | _ -> let idx, ty = indexed ctx target idx in prim Tast.At ty (target :: idx)) | _ -> fail loc "%s is (%s collection index ...)" name name) (* (slice a), (slice a lo) and (slice a lo hi). The two short forms are written out here into the three-argument one and are that form after this line: same node, same checks, same code. Nothing is added at run time, because neither missing argument needs anything computed — [lo] is 0, and [hi] is the length, which on a fixed array is the constant [length] already folds to and on a slice or a string is the length word the value is carrying anyway. The target is read twice when [hi] is the implicit length, so a target that is not already a name goes into a slot first: [(slice (f x))] must call [f] once. An array target never needs the slot, because its length is a constant and the target appears exactly once. One name over every target that has elements, a Vec included. There used to be a second, [as-slice], for the Vec alone; the input type already decides which semantics apply — a Vec can only be borrowed, an array can only be viewed, and no call site chooses — so the second name expressed nothing and is gone. [vec_slice] above is the Vec's half. *) | "slice" -> (match args with | [] | _ :: _ :: _ :: _ :: _ -> fail loc "slice is (slice a), (slice a lo) or (slice a lo hi) — given %d \ arguments" (List.length args) | target :: bounds -> lit_typed_use ctx target; let target = check_target ctx target in let ty = target.Tast.ty in match ty with (* A Vec leaves here: everything below is written around a length the compiler can see, and a Vec's is a word the runtime reads. *) | Types.Vec elem -> vec_slice ctx ~want loc target elem bounds (* A dyn leaves too, as [at] over one does: the bounds are dyn, like [at]'s index, and a missing [hi] is nil, which the runtime reads as the length. *) | Types.Dyn -> let bound b = check ctx ~want:Types.Dyn b in let nil () = rt loc Types.Dyn "flan_dyn_nil" [] in let lo, hi = match bounds with | [] -> box loc (mk loc dyn_i64 (Tast.Int (0L, Types.I64))), nil () | [ lo ] -> bound lo, nil () | [ lo; hi ] -> bound lo, bound hi | _ -> assert false in expect ctx loc ~want (rt loc Types.Dyn "flan_dyn_slice" [ target; lo; hi; here loc ]) | _ -> (* A string slices to a string, not to a [u8]: the result views the same bytes and is read-only for the same reason the source is, and calling it a byte slice would hand out a writable-looking view of storage the program does not own. *) let result = match ty with (* An array reached through a [[const T]] or a (Ptr const T) is read-only storage, and so is a view of it. *) | Types.Array (_, t) when const_reached target <> None -> Types.Slice (Types.Const, t) | Types.Array (_, t) -> Types.Slice (Types.Mut, t) | Types.Slice (m, t) -> Types.Slice (m, t) | Types.String -> Types.String | other -> fail loc "slice takes an array, a slice, a string or a Vec, found %s" (tyname loc other) in (* An array that came back from a call is a value in a temporary this expression does not own: the slice would outlive it and view whatever the frame reused those bytes for, with nothing to trap on. A [let] gives it a name and a lifetime, so that is what the refusal names. An array *literal* is not this case — it is written here and the frame holds it for as long as the form it is written in. *) (match ty, target.Tast.e with | Types.Array _, (Tast.Call _ | Tast.CallPtr _) -> fail loc "this slices an array a call returned, which is a temporary the \ slice would outlive. Bind it first: (let [a (…)] (slice a …))" | _ -> ()); let int k = mk loc index_ty (Tast.Int (k, Types.I32)) in (* [hi] is wanted twice only when it is the implicit length of something whose length is not static. *) (* An array literal is also given a slot, so that what the slice views lives for the whole function in both backends: the x86 backend otherwise holds it in an expression temporary, reclaimed as soon as the slice has been made, and a later temporary — (clone ...)'s own, say — was written over it. *) let needs_slot = (match ty, target.Tast.e with | Types.Array _, Tast.Arr _ -> true | _ -> false) || List.length bounds < 2 && (match ty with Types.Array _ -> false | _ -> true) && (match target.Tast.e with | Tast.Local _ | Tast.Global _ -> false | _ -> true) in let slot = if needs_slot then Some (fresh_slot ctx ty) else None in let src () = match slot with | Some s -> mk loc ty (Tast.Local s) | None -> target in let whole_len () = match ty with | Types.Array (n, _) -> int n | _ -> mk loc index_ty (Tast.Prim (Tast.Len, [ src () ])) in (* [index_expr] and not an [i32] expectation, which is what this used to be. One builtin cannot answer two ways about the same bound, and the question is settled by what every *other* subscript in the language already does: [indexed] and [vec_at] both take their index through here, so [(at a c)] over a [u32] compiles and [(slice a c)] used to not. A bound is a subscript; it takes the subscript rule. Nothing is loosened by it that a bounds check does not still catch — [index_expr] admits an integer narrower than 32 bits and a u32, whose out-of-range values truncate to a negative i32 the unsigned comparison rejects, and refuses i64 and u64 by name. *) let lo_loc, lo, hi_loc, hi = match bounds with | [] -> loc, int 0L, loc, whole_len () | [ lo ] -> lo.Ast.loc, index_expr ctx lo, loc, whole_len () | [ lo; hi ] -> lo.Ast.loc, index_expr ctx lo, hi.Ast.loc, index_expr ctx hi | _ -> assert false in (* A bound may sit one past the end, so the length is checked against lo and hi both, not against the last valid index. *) (match literal lo with | Some k -> static_index lo_loc ty ~past_end:true "slice bound" k | None -> ()); (match literal hi with | Some k -> static_index hi_loc ty ~past_end:true "slice bound" k | None -> ()); (match literal lo, literal hi with | Some a, Some b when a > b -> fail loc "slice [%Ld %Ld) runs backwards — lo must not exceed hi" a b | _ -> ()); let body = mk loc result (Tast.Prim (Tast.Slice, [ src (); lo; hi ])) in (match slot with | None -> expect ctx loc ~want body | Some s -> expect ctx loc ~want (mk loc result (Tast.Let ([ (s, target) ], [ body ]))))) (* (slice-from p n) — TODO.org, "A pointer from C needs a length before it can be indexed". A (Ptr T) that came back from C is readable at element 0 through [deref] and nowhere else, because [indexed] takes an Array or a Slice and a pointer is neither. C hands back an address and no length, so the length has to come from the caller, and this is the form that says so out loud. **What the caller is promising**, and the compiler checks none of it: that [p] really addresses [n] consecutive [T], that they are initialised, and that they outlive every use of the result. Get it wrong and this reads memory that is not there — the bounds check the result carries will agree with a length that was a lie, because the length *is* the lie. It is the same trust [declare-c] already extends, written at the one site where somebody had to know the answer anyway. No marker on the name. A [?] in this language means *asks* ([is-font-valid]), and this does not ask; [zeroed], the nearest neighbour — a value conjured rather than derived — carries no marker either. The argument's type is the marker: only a (Ptr T) is accepted, and a (Ptr T) only ever arrives from a [declare-c], an [addr] or a pointer cast, so the site already says where the promise comes from. **The count is any integer.** It is widened to i64 here, sign- or zero-extended by its own kind, so both backends see one i64 and the length word is what the caller wrote. The [n >= 0] test the backends plant runs in every build, release included and [--no-bounds-checks] included: it is not a bounds check against a known length (there is none), it is the claim that the word being stored is a count at all. A u64 above 2^63 fails it too, and should — no pointer has that many elements behind it. **It owns nothing.** The result is a [Types.Slice], the same non-owning view (slice v) answers; (free s) on it is the program's error, which a dev build's registry traps as a slice no allocator handed out. It carries no allocator epoch either — a slice is two words, see TODO.org "A stale slice reads poison in a dev build" — so a view made over arena memory that is later freed reads the dev build's poison and does not trap. *) | "slice-from" -> arity ctx loc name 2 args; (match args with | [ target; n ] -> let target_loc = target.Ast.loc in let spelled_target = spell_arg "p" target in let target = check ctx target in let elem = match target.Tast.ty with | Types.Ptr (_, t) -> t | other -> fail target_loc "slice-from takes a (Ptr T) and the number of elements behind \ it, found %s. A slice or an array already has a length; \ (slice v lo hi) views part of one" (tyname loc other) in let n_loc = n.Ast.loc in let spelled_n = spell_arg "n" n in let n = check ctx n in (match n.Tast.ty with | Types.Int _ -> () | Types.Var v -> cast_operand ctx n_loc name ~needs:"is-integer" ~what:"an element count" ~is:"an integer" v | other -> fail n_loc "slice-from counts elements with an integer, found %s. Write \ (slice-from %s (i64 %s))" (tyname loc other) spelled_target spelled_n); (* A negative literal is a lie the checker can see, so it does not wait for the run-time test emit.ml plants beside it. *) (match literal n with | Some k when k < 0L -> fail n_loc "slice-from length %Ld is negative" k | _ -> ()); let i64 = Types.Int Types.I64 in let n = if Types.equal n.Tast.ty i64 then n else mk n.Tast.loc i64 (Tast.Prim (Tast.Cast i64, [ n ])) in (* A read-only pointer gives a read-only slice, or [slice-from] would undo the const [addr] put there. *) let m = match target.Tast.ty with Types.Ptr (m, _) -> m | _ -> Types.Mut in prim Tast.SliceFrom (Types.Slice (m, elem)) [ target; n ] | _ -> assert false) (* ── pointers ──────────────────────────────────────────────────── *) | "addr" -> arity ctx loc name 1 args; let a = List.hd args in lit_typed_use ctx a; (match place_of_expr a with | None -> fail a.Ast.loc "addr takes the address of a place — a name, (.field x), (at a i) \ or (deref p)" | Some p -> let p, ty = check_place ~store:false ctx a.Ast.loc p in let m = if place_const p then Types.Const else Types.Mut in expect ctx loc ~want (mk loc (Types.Ptr (m, ty)) (Tast.Addr p))) | "deref" -> arity ctx loc name 1 args; let a = check ctx (List.hd args) in (match a.Tast.ty with | Types.Ptr (_, t) -> expect ctx loc ~want (mk loc t (Tast.Deref a)) | other -> fail loc "deref takes a (Ptr T), found %s" (tyname loc other)) (* ── Option ────────────────────────────────────────────────────── *) (* (Some nil) cannot be built. Some marks a value present; nil is dyn's own way of saying absent; a present absence is what would make nil and None the same case of an (Option dyn) and break nil <-> None at the boundary in both directions. Refused here at the literal, which the checker can see the same way it sees any other [nil]; a dyn value that only turns out to be nil once the program runs is caught by the runtime guard on the value instead, named for what it refuses rather than just that it does. *) | "Some" -> arity ctx loc name 1 args; let arg = List.hd args in let inner = match want with Some (Types.Option t) -> Some t | _ -> None in (* A literal [nil] is refused by this form's own message below, not by [expect]'s bare-T refusal — checking it against [inner] here would let a bare T's "wrap the type in Option" reach the reader even though the type here is already wrapped in one. Checked with no want instead, which is exactly what a bare [nil] resolves against on its own (see [var]'s "nil" arm), so it arrives below still dyn and still nil. *) let ast_nil = match arg.Ast.e with Ast.Var "nil" -> true | _ -> false in let a = check ctx ?want:(if ast_nil then None else inner) arg in let a = if not (Types.equal a.Tast.ty Types.Dyn) then a else if is_nil_lit a then Loc.failk "check/some-nil" loc "(Some nil) cannot be built — Some marks a value present, and nil \ is dyn's absence. Use None instead" else rt loc Types.Dyn "flan_dyn_need_not_nil" [ a ] in expect ctx loc ~want (mk loc (Types.Option a.Tast.ty) (Tast.Some_ a)) (* ── the milestone-2 host primitives (plan.org) ────────────────── *) (* (bytes-view s): the string's own storage seen as a [const u8], costing nothing. The slice aliases the string, and a literal's bytes are in read-only memory — a store through them would trap at -O0 and be deleted as undefined at -O2 — so the view is one that can only be read, and a store through it is refused here rather than at run time. (bytes s) is the writable copy. Reading through it is the whole use: is-bytes-equal, split, index-of-bytes and every other comparison walks a string's bytes without copying them. *) | "bytes-view" -> arity ctx loc name 1 args; let a = maybe_string ctx ~otherwise:Types.String (List.hd args) in if string_or_ptr a.Tast.ty then expect ctx loc ~want (string_bytes ctx loc a) else prim Tast.Bytes (Types.Slice (Types.Const, Types.Int Types.U8)) [ a ] (* (bytes s) / (bytes s a): a *writable copy* of the string's bytes, from the context allocator or one named — never a hidden malloc, which is spec-memory.md's frozen rule over every allocating operation. It used to be the zero-cost reinterpret above, and the author's in-place sort over (bytes "INSERTIONSORT") wrote into the string constant; "I would expect bytes to copy" is the ruling this implements. The lowering is [dup_elems], which (clone xs) shares for any slice. *) | "bytes" -> (match args with | s :: rest when List.length rest <= 1 -> let s = check ctx ~want:Types.String s in let a = allocator_arg ctx loc rest in expect ctx loc ~want (dup_elems ctx loc (Types.Int Types.U8) s a) | _ -> fail loc "bytes is (bytes s) or (bytes s allocator)") (* (str b): a [u8] seen as a str. The mirror of (bytes-view s), spelled the same way — a type name in head position, like (bytes s) and unlike the numeric casts, which go through [is_cast] and really do convert. It costs nothing. emit.ml lowers Types.String and Types.Slice _ to the same %slice, 16 bytes at align 8, so a string and a [u8] are already the identical value at run time; both this and [Bytes] emit as the argument itself. What changes is only what the checker will let the value be passed to — which is the whole gap: i64->bytes answers a [u8] and every declare-c text parameter wants a string, and nothing joined them. Two decisions are baked in here. 1. It does NOT check UTF-8, because `str` does not claim UTF-8. The prelude settles this: is-valid-utf8 is an ordinary function you call when you care, decode-rune/rune-at/rune-count all take [u8] rather than string, and decode-rune answers {.ok false .width 1} on a malformed byte rather than assuming its input is well-formed. The one place the runtime treats a string differently from a byte slice is flan_escape_bytes, for a string nested in a printed structure, and that is a byte-wise escape table with no decoding in it. So there is no code that would be wrong about a string of arbitrary bytes, and a check here would be the only enforcement point in the language — a claim the rest of it does not make. 2. It takes a [const u8], so a [u8] and a (bytes-view s) are both accepted. This direction only loses the ability to write — a string is read-only everywhere — so the result of (str b) can reach strictly fewer stores than b could. The text i64->bytes and f64->bytes answer lives in the temp allocator until the next (free-temp); calling it a string does not copy it, so text kept past the frame is cloned first. *) | "str" -> arity ctx loc name 1 args; (* A String's str is a view of its bytes, as (str (slice v)) is of a Vec's: it costs nothing and lasts until the String next grows. *) let a = maybe_string ctx ~otherwise:(Types.Slice (Types.Const, Types.Int Types.U8)) (List.hd args) in if string_or_ptr a.Tast.ty then prim Tast.StrOfBytes Types.String [ string_bytes ctx loc a ] else prim Tast.StrOfBytes Types.String [ a ] | "bytes->f64" -> arity ctx loc name 1 args; prim Tast.BytesToF64 (Types.Float Types.F64) [ byte_slice ctx (List.hd args) ] | "bytes->i64" -> arity ctx loc name 1 args; prim Tast.BytesToI64 (Types.Int Types.I64) [ byte_slice ctx (List.hd args) ] (* The number's text in the temp allocator: flan_i64_temp and flan_f64_temp render it and bump-allocate the bytes there in one call, so the slice outlives the frame — a function may return one and a Vec may hold one — until the next (free-temp). A number drawn every frame is reclaimed every frame; text kept longer is cloned. The number is bound before the guard's loop, so a retry does not evaluate it twice. The prelude's calls — append-i64, append-f64, format-f64, gensym — are answered with a frame slot instead ([to_bytes]): each copies the bytes into a Vec before the next conversion, so the temp copy would be work thrown away. *) | "f64->bytes" | "i64->bytes" -> arity ctx loc name 1 args; let f64 = name = "f64->bytes" in let nty = if f64 then Types.Float Types.F64 else Types.Int Types.I64 in let x = check ctx ~want:nty (List.hd args) in let bslice = Types.Slice (Types.Mut, Types.Int Types.U8) in expect ctx loc ~want (if String.equal loc.Loc.file Prelude.file then to_bytes ctx loc (if f64 then Tast.F64ToBytes else Tast.I64ToBytes) x else let xs = fresh_slot ctx nty and out = fresh_slot ctx bslice in let attempt () = rt loc (Types.Int Types.I8) (if f64 then "flan_f64_temp" else "flan_i64_temp") [ mk loc nty (Tast.Local xs); addr_of loc (mk loc bslice (Tast.Local out)) ] in (* The guard — a retry restart around the attempt — is entered only once a first attempt has failed, so the common case pays one call and a compare. A failure then re-attempts under the guard exactly as it would have. *) let failed = mk loc Types.Bool (Tast.Prim (Tast.Eq, [ attempt (); mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])) in mk loc bslice (Tast.Let ([ (xs, x); (out, mk loc bslice (Tast.Zero bslice)) ], [ mk loc Types.Unit (Tast.If (failed, alloc_guard ctx loc (attempt ()), unit_at loc)); mk loc bslice (Tast.Local out) ]))) | "write-stdout" -> arity ctx loc name 1 args; prim Tast.WriteStdout Types.Unit [ byte_slice ctx (List.hd args) ] (* (println x) and (print x): the structural printer, selected on the type the argument checked to. plan.org, Milestone 5 — "compiler-provided, per concrete type". That is not overloading and needs no type variables: there is no dispatch at run time and no user-supplied printer to pick between. The walk itself is render.ml, shared with the REPL, which is what stops the two from drifting apart. [min]/[max]/[zeroed] above dispatch on the resolved argument type the same way. The slots the slice arm needs come out of the frame of whatever function this call is written in, via [fresh_slot] — allocated once per call site, at check time, not once per iteration of a loop around it. A string prints raw here and quoted inside a structure. Those are not in conflict: (println "hello") has to print hello or it is useless, and (println b) where b has a string field has to quote it or the field cannot be told from the punctuation. The split is exactly top level vs nested, which is why it lives here and not in the walk. *) | "print" | "println" -> (* Variadic, with Clojure's spacing: every argument prints in order with a single space between each pair, and [println] ends the line. No arity check — (println) is the newline alone and (print) is nothing, which is also Clojure's answer. Each argument gets the same walk it would get alone, so one call mixes typed and dyn values freely, and a bad argument is refused at its own location: the arguments are checked one by one below, each carrying its own loc, and render.ml fails on the expression's loc rather than the form's. *) (* Printing is a read, not a move: the walk goes over the value and keeps nothing. Without this, (println v) would consume a Vec and every printing of one would be its last. *) let checked = List.map (fun target -> check ctx target) args in (* ── The allow-list, and what it takes to get on it ─────────────── plan.org names [println] as the one compiler-provided exception — it "selects a structural printer at each concrete instantiation" — and that cannot be reconciled with an abstract pass as written: a pass that decides an operator's legality *without* substituting cannot make an exception for the one operator whose legality is only decidable after substituting. So the exception is made explicit: these two forms are *deferred* to instantiation, and every other operator is answered where it is written. Every member of this list is a place where a refusal moves from the definition to a call site, which is the thing the abstract pass exists to prevent. **That cost is not the same for every member, and the list is not closed.** What makes it bearable is whether the call site has a *stated requirement* to be refused against. [print] and [println] have none and need none: every type prints, so there is no [where] predicate for printability — one would always hold and would be noise on a signature — and there is correspondingly no call site these can be refused at. They are deferred and then always succeed. That is the cheapest possible membership. The map operations — [put], [get], [has-key], [map-remove], [reserve], [clone], through [deferred_key] beside [key_fns] — are the other kind, and they are here on a different argument. They *can* fail at a concrete type, so deferring them does move a refusal. But [{:where (is-hashable $t)}] is in the signature, and it is the author's own written requirement: an instantiation at a non-hashable type is refused against that clause, by name, at the call that asked for the type. That is a refusal the caller can act on and one the generic's author chose to be responsible for — categorically different from an unconstrained [(+ a b)] failing deep in a body with no signature to blame, which is the case the abstract pass exists to prevent and which stays refused at the definition. A generic that does *not* declare the predicate gets no deferral: [deferred_key] checks first, and [map_type] has usually refused the signature already. So the rule for adding to this list is not a headcount. It is: either the operation cannot fail after substituting, or a declared predicate gives its failure a place to land. Anything else is answered here. The node produced here is a unit no-op, thrown away with the rest of the abstract pass. The real printer is selected when the copy is 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 -> 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 let write x = mk loc Types.Unit (Tast.Prim (Tast.WriteStdout, [ x ])) in (* One frame slot per conversion the printer emits, which is what [to_bytes] is for. The printer writes each number out before making the next, so a shared buffer would in fact have served it — but the slot is what the node now carries, and a printer that assembled its own buffer would be a second answer to the same question. [escape] is the one that still renders into a static: it is reachable from nowhere but here, and its 1KB buffer per printed string field is a frame cost with no bug behind it. Said here so the asymmetry is a decision and not an oversight. *) let conv pr x = to_bytes ctx loc pr x in let emitter : Render.emitter = { Render.ebytes = write; estr = (fun x -> write (mk loc bslice (Tast.Prim (Tast.EscapeBytes, [ x ])))); ei64 = (fun x -> write (conv Tast.I64ToBytes x)); eu64 = (fun x -> write (conv Tast.U64ToBytes x)); ef64 = (fun x -> write (conv Tast.F64ToBytes x)); edyn = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_print_at", [ x; here loc ]))); enested = (fun x -> mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_dyn_print_nested_at", [ x; here loc ]))) } in let rc = render_ctx ctx emitter in let c_top = emitter.Render.edyn in let render_one a = match a.Tast.ty with | Types.String | Types.Slice (_, (Types.Int Types.U8)) -> [ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ a ]))) ] (* A char at the top prints as the character itself (129a), through the runtime's dyn printer so the two sides agree. *) | Types.Char -> [ c_top (box loc a) ] (* A String prints as its text, raw at the top as a str does. *) | t when is_string_ty t -> [ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ string_bytes ctx loc 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 (small-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 node would be entitled to assume it appears once. *) let space () = write (mk loc bslice (Tast.Prim (Tast.Bytes, [ mk loc Types.String (Tast.Str " ") ]))) in let parts = match checked with | [] -> [] | first :: rest -> render_one first @ List.concat_map (fun a -> space () :: render_one a) rest in let nl = if String.equal name "println" then [ write (mk loc bslice (Tast.Prim (Tast.Bytes, [ mk loc Types.String (Tast.Str "\n") ]))) ] else [] in expect ctx loc ~want (mk loc Types.Unit (Tast.Do (parts @ nl))) (* (watch "name" v) — v rendered into the dev watch table under the name. The same walk as [print], with the pieces aimed at flan_dev.c's watch slot instead of stdout, so a struct, a slice, an option or a dyn value watches the way it prints. The value is evaluated once, before the table is asked whether anyone is looking, so a side effect in it happens whether or not a watch buffer is open. The walk runs only when one is: [flan_dev_watch_begin_n] answers 0 when the table is not armed or is full, and the render is skipped. Outside a dev build the backends drop the guarded [If] whole — see [Tast.is_watch_guard] — so a release build evaluates the value and makes no call at all. *) | "watch" -> 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 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 let emitter : Render.emitter = { Render.ebytes = (fun x -> unit_rt "flan_dev_watch_emit" [ x ]); estr = (fun x -> unit_rt "flan_dev_watch_emit_str" [ x ]); ei64 = (fun x -> unit_rt "flan_dev_watch_emit_i64" [ x ]); eu64 = (fun x -> unit_rt "flan_dev_watch_emit_u64" [ x ]); ef64 = (fun x -> unit_rt "flan_dev_watch_emit_f64" [ x ]); edyn = (fun x -> unit_rt "flan_dyn_emit_watch" [ x ]); enested = (fun x -> unit_rt "flan_dyn_emit_watch" [ x ]) } in (* A place is read where it stands; anything else is bound to a slot of this frame first, so the walk — which names its argument once per field — does not run it once per field. *) let bind, value = match v.Tast.e with | Tast.Local _ | Tast.Global _ -> [], v | _ -> let s = fresh_slot ctx v.Tast.ty in [ (s, v) ], mk loc v.Tast.ty (Tast.Local s) in let body = match value.Tast.ty with (* A string watches quoted, as it renders inside a structure: the table's rows are values, and an unquoted one could not be told from a number. *) | Types.String -> [ emitter.Render.estr (mk loc bslice (Tast.Prim (Tast.Bytes, [ value ]))) ] | _ -> Render.render ~refuse:(fun _loc t -> Printf.sprintf "%s has no rendering, so it cannot be watched — watch the \ values you want out of it instead" (tyname loc t)) (render_ctx ctx emitter) 0 value in let begin_ = mk loc (Types.Int Types.I32) (Tast.Prim (Tast.Rt Tast.watch_begin, [ label ])) in let zero = mk loc (Types.Int Types.I32) (Tast.Int (0L, Types.I32)) in let open_ = mk loc Types.Bool (Tast.Prim (Tast.Ne, [ begin_; zero ])) in let guarded = mk loc Types.Unit (Tast.If ( open_, mk loc Types.Unit (Tast.Do (body @ [ unit_rt "flan_dev_watch_end" [] ])), mk loc Types.Unit Tast.Unit )) in expect ctx loc ~want (match bind with | [] -> guarded | _ -> mk loc Types.Unit (Tast.Let (bind, [ guarded ]))) end | "exit" -> arity ctx loc name 1 args; prim Tast.Exit Types.Never [ check ctx ~want:index_ty (List.hd args) ] | "argv" -> arity ctx loc name 0 args; prim Tast.Argv (Types.Slice (Types.Mut, Types.String)) [] (* ── casts: (i32 x), (f64 x), and an enum both ways ──────────────── (i32 e) and (GamepadAxis n) are written here rather than in an arm of their own because they are the same operation: an enum is an i32 at run time — Types.Enum says so — and emit.ml's [cast] already reduces one to its i32 before choosing an instruction. So both directions cost nothing: src and target are equal after that reduction and [cast] answers the value unchanged. Why this does not give the typo back. The property worth keeping is that :spcae at a call site is an error at that site, and it still is: a keyword resolves against the parameter's enum and a bare integer does not fit one. What changes is only that a program can *say* it means the conversion, by name, at the site. The rule was never "an integer is dangerous", it was "an integer must not arrive silently", and a written (GamepadAxis i) is not silent. Three sub-decisions: 1. enum → any numeric is always allowed and never checked. It is lossless to i32 by construction, and a narrower target truncates by the same rule every int→int cast already follows — no special case, and (f32 e) means (f32 (i32 e)) rather than an arbitrary refusal. 2. integer → enum accepts a value that is not a declared member. raylib's gesture is a bitfield and an OR of flags is a legal Gesture that is no single member, so refusing it would refuse correct programs; and session.ml's printer already falls through to the number for an out-of-range enum, on purpose, so refusing to *construct* one while blessing its display would be incoherent. An Option would make every site unwrap for no safety bought, and a literal-only refusal would catch nothing — the bitfield case is a run-time value. 3. Only an integer converts *to* an enum. Not a float, which has no meaning here, and not another enum: an enum-to-enum hop goes through (i32 x) so that both ends are written down. *) | _ when Hashtbl.mem ctx.env.enums name -> arity ctx loc name 1 args; let target = resolve_name ctx.env ~seen:[] loc name in let a = check ctx (List.hd args) in (match a.Tast.ty with | Types.Int _ -> () (* A type variable, answered by its bound rather than by a type it does not have yet: [is-integer] admits exactly the integer kinds, which is what sub-decision 3 above asks for, and [is-numeric] is a bound too wide because it admits the floats that decision refuses. *) | Types.Var v -> cast_operand ctx loc name ~needs:"is-integer" ~what:"an integer to an enum" ~is:"an integer" v | other -> fail loc "%s converts an integer to an enum, found %s — an enum or a \ float goes through (i32 x) first" name (tyname loc other)); prim (Tast.Cast target) target [ a ] (* A cast to a *type variable*: [(t x)] or [($t x)] inside a generic body. The name is not one [is_cast] knows, because [is_cast] asks whether the name is a machine type and [t] is not — so this is its own arm, above the ordinary one and below the enums, and it reaches the same [Cast] prim. Inside an instantiation [resolve_name] has already answered with the concrete target, so the copy casts to a real type and the emitter sees nothing unusual. During the abstract pass the target is [Var t] and the [where] clause is what says the cast means anything at all: a cast produces a number, so [is-numeric] is what admits it. A sigil on a name nothing binds comes here too, for the reason [type_named] takes one: the character is only ever written where a type goes, so [resolve_name] gets to say that a variable has no binding site outside a defn signature. Otherwise [($u x)] would be an unknown function in the same body where [(vec-new $u)] is an unbound variable — one mistake told two ways. Only where nothing else claims the name, though. Nothing stops a defn, a struct or a binding from carrying the character, and a call to one is a call and not a type: this arm sits above the arms that would have found it — [ordinary_call] and, last of all, [positional_struct] — so it has to decline first, once per table a name can be declared in. *) | _ when (tyvar_in_scope ctx.env name || (name <> tyvar_bare name && lookup ctx name = None && not (Hashtbl.mem ctx.env.structs name) && not (Hashtbl.mem ctx.env.fns name) && not (Hashtbl.mem ctx.env.gsigs name))) && List.length args = 1 -> let target = resolve_name ctx.env ~seen:[] loc name in unconstrained ctx.env loc ("a cast to " ^ name) ~needs:"is-numeric" target; let a = check ctx (List.hd args) in (match a.Tast.ty with | Types.Enum _ -> () | t when Types.is_numeric t -> () (* The operand's own bound, asked the same way the target's was one line up. Accepting every [generic_ty] here took the target's [is-numeric] as if it said something about the operand, so a second variable declared only [is-ordered] passed the abstract pass. Nothing wrong was ever emitted — [is-ordered] admits numbers and enums and both convert at the instantiation — which is the point: the hole is only reachable the day [is-ordered] admits a type that does not, and that day is why the question is asked of the predicate and not of the set it denotes. *) | Types.Var v -> cast_operand ctx loc name ~needs:"is-numeric" ~also:("is-enum", "an enum") ~what:"a number or an enum" ~is:"a number" v | t -> fail loc "%s converts a number, found %s" name (tyname loc t)); prim (Tast.Cast target) target [ a ] (* (char n): a code point made a char. Only a Unicode scalar value is one, so a literal is checked here and anything else at run time. *) | "char" when List.length args = 1 -> let x = List.hd args in let char_lit n = mk loc Types.Char (Tast.Int (n, Types.U32)) in let fln = fln_source loc in let not_scalar n = Loc.failk literal_at_want loc "%Ld is not a Unicode scalar value, so it is not a char. A char is a \ code point from 0 to 0x10FFFF, outside 0xD800 to 0xDFFF" n in (match x.Ast.e, literal_arith x with | Ast.Byte b, _ -> expect ctx loc ~want (char_lit (Int64.of_int b)) | _, Some n -> if Int64.compare n 0L >= 0 && Int64.compare n 0x10ffffL <= 0 && not (Int64.compare n 0xd800L >= 0 && Int64.compare n 0xdfffL <= 0) then expect ctx loc ~want (char_lit n) else not_scalar n | _ -> let a = check ctx x in let checked i64 = rt loc Types.Char "flan_char_of" [ i64; here loc ] in (match a.Tast.ty with | Types.Char -> expect ctx loc ~want a (* A u64 goes as itself, so one past 2^63 is named as the number it is and not as the negative i64 with its bits. *) | Types.Int Types.U64 -> expect ctx loc ~want (rt loc Types.Char "flan_char_of_u64" [ a; here loc ]) | Types.Int _ -> expect ctx loc ~want (checked (widen loc dyn_i64 a)) (* Explicit, so a dyn int converts as a typed one does. *) | Types.Dyn -> expect ctx loc ~want (checked (rt loc dyn_i64 "flan_dyn_int_of" [ a ])) | t -> fail loc "char makes a char from an integer code point, found %s%s" (tyname loc t) (match t with | Types.Float _ -> if fln then " — convert it with i32(x) first" else " — convert it with (i32 x) first" | _ -> ""))) | _ when is_cast name && List.length args = 1 -> let target = resolve_name ctx.env ~seen:[] loc name in (* An integer literal too wide for the i32 it would default to is checked at the target instead, so (u64 2935910691) and (i64 5000000000) are the constants they say. One that fits i32 keeps the default and the cast, which is what (u32 -1) has always meant. *) let operand_want = match (List.hd args).Ast.e, target with | Ast.Int n, (Types.Int _ | Types.Float _) when Int64.compare n (-2147483648L) < 0 || Int64.compare n 2147483647L > 0 -> Some target | Ast.UInt _, (Types.Int _ | Types.Float _) -> Some target (* A char literal is the number at the target, so (u8 \é) is refused as a u8 literal is. *) | Ast.Byte _, (Types.Int _ | Types.Float _) -> Some target (* A float literal likewise: (f64 0.1) is the f64 nearest 0.1 and not the f32 one widened, and (u64 1.8e19) converts the f64 it says. *) | _, Types.Float _ when lit_kind (List.hd args) = Some `Float -> Some target | _, Types.Int _ when lit_kind (List.hd args) = Some `Float -> Some (Types.Float Types.F64) | _ -> None in let a = check ctx ?want:operand_want (List.hd args) in (match a.Tast.ty with | Types.Enum _ -> () (* A dyn opens here — [cast_dyn], TODO.org, "A numeric cast opens a dyn box". Only on this arm: the generic one above casts to a type *variable*, whose [where] clause says the operand is numeric, and a dyn is not what a [is-numeric] bound admits. *) | Types.Dyn -> () | t when Types.is_numeric t -> () (* A char's code point, into any integer width. *) | Types.Char when Types.is_integer target -> () | Types.Char -> fail loc "%s converts a number, and a char converts only to an integer, \ as %s" name (if fln_source loc then "i32(c)" else "(i32 c)") (* The operand of a conversion inside a generic body. The target is a machine type, so what is in question is only the operand, and the [where] clause is what answers it. *) | Types.Var v -> cast_operand ctx loc name ~needs:"is-numeric" ~also:("is-enum", "an enum") ~what:"a number or an enum" ~is:"a number" v | t -> fail loc "%s converts a number, found %s" name (tyname loc t)); (match a.Tast.ty with | Types.Dyn -> expect ctx loc ~want (cast_dyn ctx loc target a) | _ -> prim (Tast.Cast target) target [ a ]) (* ── ordinary calls ────────────────────────────────────────────── *) | _ -> ordinary_call ctx ~want loc name args (* Everything that is not a builtin arm: a local of function type, a generic signature, the function table, and the refusals for a name that is none of them. Reached two ways — by falling past every arm above, and by the shadowing guard at the very top of [named_call], which sends a call whose name the program has defined straight here. One function so that both routes resolve a name by exactly the same rules. *) and ordinary_call ctx ~want loc name args = match () with (* A local or a parameter holding a function value, called by the name it is bound to — which is what the body of [map] looks like. It is checked before the global function table: a binding shadows a defn of the same name (one namespace, ordinary lexical scoping). A local of any *other* type falls through to the table, so a program that shadows a function name with an i32 and then calls the function still means the function. A local of the *enclosing* function holding one is the same case: a lifted body captures it by value and then calls the copy. [peek_outer] rather than [capture] in the guard, because a guard must not take a copy on its way to deciding what a form means. *) (* A [_] function whose body failed has no return type to give; its own errors are reported with its body, so a call to it stands in. *) | _ when ctx.env.recovering && Hashtbl.mem ctx.env.infer_failed name && lookup ctx name = None -> List.iter (fun a -> ignore (check ctx a)) args; ctx.env.poison <- ctx.env.poison + 1; poison loc (* A local bound to a refused initialiser's stand-in, called: the refusal is already reported, so the call stands in too, its arguments still checked. *) | _ when ctx.env.recovering && (match lookup ctx name with | Some b -> Types.equal b.bty Types.Never | None -> false) -> List.iter (fun a -> ignore (check ctx a)) args; ctx.env.poison <- ctx.env.poison + 1; poison loc | _ when (match lookup ctx name with | Some b -> callable_ty b.bty | None -> match peek_outer ctx name with | Some b -> callable_ty b.bty | None -> false) -> (* The binding the guard already found, read directly. Going back through [check] would repeat the lookup. *) (match lookup ctx name with | Some b -> call_value ctx ~want loc (local_of loc b) args | None -> match capture ctx loc name with | Some b -> call_value ctx ~want loc (mk loc b.bty (Tast.Local b.slot)) args | None -> assert false) (* A global holding a function value — a (CFn ...) table entry's cousin, since a global is one of the zeroed positions a CFn may sit in. Called by its name the way a local one is. *) | _ when (match Hashtbl.find_opt ctx.env.globals name with | Some (ty, _) -> callable_ty ty | None -> false) -> let ty, _ = Hashtbl.find ctx.env.globals name in call_value ctx ~want loc (mk loc ty (Tast.Global name)) args (* A name with several versions: the number of arguments picks one, and the call is then a call to that version by its own name. *) | _ when Hashtbl.mem ctx.env.versions name -> let vs = Hashtbl.find ctx.env.versions name in (match List.assoc_opt (List.length args) vs with | Some v -> ordinary_call ctx ~want loc v args | None -> let n = List.length args in Loc.failk "check/no-version" loc "%s has no arity that takes %d argument%s. It has these:\n%s" name n (if n = 1 then "" else "s") (String.concat "\n" (List.map (fun (_, v) -> " " ^ version_text ctx.env loc v) vs))) | _ when Hashtbl.mem ctx.env.gsigs name -> private_ref ctx loc name; let vars, params, ret = Hashtbl.find ctx.env.gsigs name in generic_call ctx ~want loc name vars params ret args | _ -> match Hashtbl.find_opt ctx.env.fns name with | Some (params, ret) -> private_ref ctx loc name; if List.length args <> List.length params then fail loc "%s takes %d argument%s, given %d" name (List.length params) (if List.length params = 1 then "" else "s") (List.length args); let i = ref (-1) in let args = map2_lr (fun p a -> incr i; check_arg ctx name !i p a) params args in let args = c_literals ctx name params args in (match Hashtbl.find_opt ctx.env.tracks name with | Some tr -> expect ctx loc ~want (tracked_call loc ctx.env name tr ret args) | None when Hashtbl.mem ctx.env.classes name -> (* A class's constructor, told where it was called from so that a slot it refuses names this call and not only the defclass. The arguments go into temps first: one may itself construct, and the site is set last, immediately before the call, so nothing between the two can replace it. The constructor takes it as its first act; one reached through a function value finds none. *) let temps = List.map (fun (a : Tast.expr) -> (fresh_slot ctx a.Tast.ty, a)) args in let uses = List.map (fun (s, (a : Tast.expr)) -> mk a.Tast.loc a.Tast.ty (Tast.Local s)) temps in expect ctx loc ~want (mk loc ret (Tast.Let (temps, [ rt loc Types.Unit "flan_dyn_ctor_site" [ here loc ]; mk loc ret (Tast.Call (name, uses)) ]))) | None -> let call = mk loc ret (Tast.Call (name, args)) in expect ctx loc ~want (if is_string_ty ret && prelude_defined ctx name && not (String.equal loc.Loc.file Prelude.file) then prechecked_call ctx loc name ret args else call)) | None -> if Hashtbl.mem ctx.env.datas name then fail loc "%s is a data type, so a value of it names a case — write \ (%s.%s {.field value ...})" name name (first_case_name ctx.env name) else if Hashtbl.mem ctx.env.cases name then (* [(U.C)] and [(C)]: a case written as a call. Both are how someone reaches for a constructor, and neither is one. *) let dname, c = Hashtbl.find ctx.env.cases name in fail loc "%s is a case of the data type %s — write (%s.%s {.field value ...}), \ or %s.%s on its own when it has no fields" 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 these: [not=] is one edit from [not], which is the wrong answer, and [&&] is no edit at all from [and]. *) let flan, what = List.assoc name operator_aliases in Loc.failk "check/unknown-function" loc "there is no %s. %s is %s. %s" name what flan (alias_fix flan args) else if String.contains name '/' then unimplemented loc (Printf.sprintf "the call %s into an imported package" name) 4 else if name = "as-slice" then (* A name nothing defines, near enough to [slice] to be worth a sentence rather than a did-you-mean: whatever [slice] is given decides what the view means, so there is one word for it and this says which. Asked here, after every table, so that a program that defines an [as-slice] of its own still reaches its own. *) (* The call is written back out rather than described, and every argument the reader wrote that can be spelled is spelled ([spell_arg]), so the suggestion is always a form that compiles rather than a form with a hole in it. *) let spell = spell_arg in let call = match args with | [] -> "(slice v)" | t :: bounds -> let names = [ "lo"; "hi" ] in let bounds = List.mapi (fun i b -> " " ^ spell (try List.nth names i with _ -> "n") b) bounds in "(slice " ^ spell "v" t ^ String.concat "" bounds ^ ")" in Loc.failk "check/unknown-function" loc "there is no as-slice. slice takes the view, and what it is given \ says what the view is: over a Vec it borrows the storage the Vec \ owns, over an array or a string it looks at the value itself. \ Write %s" call else if name = "slice-from-ptr" then (* The name this form had before; code written against it lands here. Said as the form to write, with the reader's arguments, and not as a rename — a first-time reader has no old name to be told about. *) let call = match args with | [ p; n ] -> "(slice-from " ^ spell_arg "p" p ^ " " ^ spell_arg "n" n ^ ")" | _ -> "(slice-from p n)" in Loc.failk "check/unknown-function" loc "there is no slice-from-ptr. A slice from a pointer and a count of \ the elements behind it is slice-from. Write %s" call else if no_such_rand name <> None then (* A retired randomness name, which is a name and not a near miss: "did you mean rand?" for [rand-f32] would be true and would not say what to write, and the line in [no_such_rand] does. *) Loc.failk "check/unknown-function" loc "%s" (Option.get (no_such_rand name)) else if name = "len" then (* [len] is an ordinary name and the count is [length], so this is the one sentence a program that reached for the short word needs. It is said rather than guessed at because the did-you-mean below cannot reach it: [len] and [length] are three edits apart, and the net is one. Asked here, after every table and after the shadowing guard at the head of the dispatch, so a program that defines a [len] of its own reaches its own — this is only ever the answer for a name that nothing in the program has taken. The reader's own argument is spelled back only when there is one of it. [length] takes exactly one, so writing three of them out would produce a suggestion that is refused for a second reason the moment it is pasted — and a suggestion that does not compile is the bug this spelling exists to avoid. [as-slice] above can write every argument out because [slice] takes one, two or three; this cannot, and the difference is the arity and not the style. *) let call = match args with | [ a ] -> "(length " ^ spell_arg "v" a ^ ")" | _ -> "(length v)" in Loc.failk "check/unknown-function" loc "there is no len. The number of elements in an array, a slice, a \ string, a Vec or a Map is length. Write %s" call else (* The did-you-mean comes first, and for a capitalised head it is asked of the *type* tables as well: [(Piont 1 2)] with [Point] declared is a typo, and the generics sentence below would be a confident answer about a feature nobody was reaching for. Only a capitalised head consults the types — a lowercase name written where a value goes was not a mistyped struct, which is [value_candidates]' whole point. *) let capitalised = name <> "" && name.[0] = Char.uppercase_ascii name.[0] && name.[0] <> Char.lowercase_ascii name.[0] in let guess = match nearest (!builtin_names @ value_candidates ctx) name with | Some _ as m -> m | None -> if capitalised then near_miss ctx.env name else None in (* A near miss that names a value rather than a function is still the near miss, but [(m)] would be refused in its turn, so the sentence says how that name is written instead. *) let callable m = let fn_ty = function | Types.Fn _ | Types.CFn _ | Types.Dyn -> true | _ -> false in match lookup ctx m with | Some b -> fn_ty b.bty | None -> match Hashtbl.find_opt ctx.env.globals m with | Some (ty, _) -> fn_ty ty | None -> not (List.mem m [ "true"; "false"; "nil"; "None"; "context/allocator"; "context/temp" ]) in (* [(string b)], [(byte x)]: another language's name for a type, used as the conversion, which Flan spells with its own type name. *) (match foreign_spelling name with | Some m -> Loc.failk "check/unknown-function" loc "unknown function %s — Flan spells it %s" name m | None -> ()); match guess with | Some m when not (callable m) -> if args = [] then Loc.failk "check/unknown-function" loc "unknown function %s — did you mean %s? It is a value and not a \ function, so it is written without parentheses" name m else Loc.failk "check/unknown-function" loc "unknown function %s. The nearest name, %s, is a value and not a \ function" name m | Some m -> Loc.failk "check/unknown-function" loc "unknown function %s — did you mean %s?" name m | None -> if args <> [] && capitalised then (* [(defonce p (Pair i32))]. A capitalised head with arguments and no near miss anywhere is somebody reaching for a parameterised type, which is what the type resolver says about [(Pair i32)] when the same text lands in a type position. Before defonce took either reading, that is the message this text got; it says the 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 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? Two questions, in this order, and the order is what makes the guard cheap enough to be the first arm of the dispatch. Is the name a builtin's at all. One lookup in [builtin_set], false for every call to an ordinary function — which is most calls in most programs — and the question that stops the second from being asked at all. Asking it first also keeps the arms that are not calls — an enum cast, a cast to a type variable, a machine-type cast — exactly where they were, since a name that reaches one of those is not a builtin's either. Is there a definition of it that reaches this call: a local of function type, or a defn — ordinary or generic — written in this same file. And is the definition visible here, which is asked of the two files: the one the definition was written in and the one this call is written in. A definition shadows the builtin through its own file and no further, which is the same visibility a defn has everywhere else — the prelude is the language's own source and means the builtin wherever it writes one, and an imported package keeps the builtin it was written against no matter what the program importing it decides to call [get]. The file and not the enclosing function's name. A package's functions are qualified at the import ([rl/get]), so asking whether the owner's name carries a slash answers correctly everywhere a call sits inside a function — and wrongly in the one place a call does not: a package's global initialiser, which is checked with no owner at all. An importer defining [length] reached inside an imported [(defonce sz i32 (length "abcd"))] and changed what it computed. The files were never wrong about it. What it costs is the REPL: an expression evaluated with no file behind it is not the file the defn was written in, so it reaches the builtin. That is the conservative direction, and C-c C-c — which sends the buffer's own path — is not affected. *) (* A [defn-] is its module's own. A use of one — a call, or the name taken as a value — is refused unless it is written inside the module that declares it. A directory package is every file in its directory, so the test there is the two files' directories; a single file imported outright is that file alone, which [Load] records by narrowing the flag to [Private_to_file]. Realpath'd, because one side is usually the path the importer was given on the command line and the other the one [Load] resolved. Code the package's own macro wrote counts as inside, wherever it was expanded: SBCL's rule, where a macro's expansion refers to its package's internal symbols freely. What the importer wrote itself does not, even when it is an argument the macro passed through. [Expand.unmarshal] tells the two apart already: a node the macro invented carries the call site's location with the macro's name on it and no separate call site, and a form the author wrote keeps its own position with the call recorded beside it. The macro's package is its qualifier, which is the function's when both come from the same module, because an import qualifies every name a directory declares under the one alias it is read as. Only a qualified name is asked about. An unqualified one belongs to the program being built, and nothing outside a program can name it. *) and private_ref ctx loc name = let qualifier n = match String.rindex_opt n '/' with | Some i -> Some (String.sub n 0 i) | None -> None in let written_by_own_macro () = match loc.Loc.macro, loc.Loc.msite with | Some m, None -> qualifier m <> None && qualifier m = qualifier name | _ -> false in match Hashtbl.find_opt ctx.env.privates name with | Some (at, scope) when String.contains name '/' -> let real file = try Unix.realpath file with Unix.Unix_error _ -> file in let inside = match scope with | Ast.Private_to_file -> String.equal (real at.Loc.file) (real loc.Loc.file) | _ -> String.equal (Filename.dirname (real at.Loc.file)) (Filename.dirname (real loc.Loc.file)) in if not inside && not (written_by_own_macro ()) then begin let where = match scope with | Ast.Private_to_file -> real at.Loc.file | _ -> "the files in " ^ Filename.dirname (real at.Loc.file) in let name = written_name name in Loc.failk "check/private" loc ~notes:[ Loc.note at (Printf.sprintf "%s is declared here" name) ] "%s is private to its package: it is declared with defn-, so only %s \ can use it. Declaring it with defn instead makes it usable from here" name where end | _ -> () (* One version of a name, as a line in a message: its parameters, named and typed, spelled the way the file around [loc] writes a function. *) and version_text env loc v = let base = match version_of v with Some (b, _) -> b | None -> v in let names, tys = match Hashtbl.find_opt env.fns v, Hashtbl.find_opt env.gsigs v with | Some (ps, _), _ -> ( (match Hashtbl.find_opt env.fparams v with | Some fs -> List.map (fun (f : Ast.field) -> f.Ast.fname) fs | None -> []), ps ) | None, Some (_, ps, _) -> ( (match Hashtbl.find_opt env.generics v with | Some fn -> List.map (fun (f : Ast.field) -> f.Ast.fname) fn.Ast.params | None -> []), ps ) | None, None -> ([], []) in let param i t = let n = match List.nth_opt names i with Some n -> n | None -> "_" in if fln_source loc then n ^ ": " ^ tyname loc t else n ^ " " ^ tyname loc t in let ps = List.mapi param tys in if fln_source loc then base ^ "(" ^ String.concat ", " ps ^ ")" else "(" ^ base ^ " [" ^ String.concat " " ps ^ "])" and shadows_builtin ctx loc name = (* Where the definition was written, if this name has one. A generic is in [generics] and nowhere near [fn_locs], so both tables are asked. *) let declared_in () = let name = match Hashtbl.find_opt ctx.env.versions name with | Some ((_, v) :: _) -> v | _ -> name in match Hashtbl.find_opt ctx.env.fn_locs name with | Some at -> Some at.Loc.file | None -> (match Hashtbl.find_opt ctx.env.generics name with | Some fn -> Some fn.Ast.nloc.Loc.file | None -> None) in (* A local of function type is lexical: it cannot be in scope anywhere but the file that bound it, so there is no file to compare. *) let local_fn () = match lookup ctx name with | Some b -> (match b.bty with Types.Fn _ -> true | _ -> false) | None -> false in Hashtbl.mem builtin_set name && (local_fn () || (match declared_in () with | Some file -> String.equal file loc.Loc.file | None -> false)) (* ── A call to a generic function ─────────────────────────────────────── The whole of instantiation, and it is at the call site because the call site is the only place the concrete types exist. Odin does the same thing in the same place: [check_expr.cpp]'s [find_or_generate_polymorphic_procedure] runs from call checking, builds the concrete proc type from the operands, scans the base entity's [gen_procs] for an [are_types_identical] match, and generates a new [Entity] only on a miss. *) and generic_call ctx ~want loc name vars pats pret args = if List.length args <> List.length pats then fail loc "%s takes %d argument%s, given %d" (written_name name) (List.length pats) (if List.length pats = 1 then "" else "s") (List.length args); (* Arguments first, and with no expectation where the parameter's type still mentions a variable — there is nothing to expect until the argument has said what it is. So an untyped literal falls to its own default and [(id 3)] instantiates at i32, which is the one place inference at a generic call site is weaker than at a monomorphic one. A variable already bound by an earlier argument is substituted back into the parameters still to come, so [(sort-by (slice ns 0 4) (fn [a b] (< a b)))] works: by the time the [fn] is reached, [(Fn [$t $t] bool)] has become [(Fn [i32 i32] bool)] and the literal has the position it needs to take its types from. Left to right, which is the order Odin's operands are gathered in and the order [map2_lr] already guarantees. *) let subst = ref [] in (* Does the signature bind [v] anywhere *inside* a type — [[$t]], [(Fn [$t $t] bool)], [(Vec $t)]? A bare [$t] parameter is a scalar the join below may move; a variable reached through a constructor is bound exactly, because a container's elements cannot be rewritten and a function value's type is its own. One scan, answered per variable. *) let rec mentions v (t : Types.t) = match t with | 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 = List.exists (fun (p : Types.t) -> match p with Types.Var _ -> false | t -> mentions v t) pats in (* Pairs that met no join while the arguments were walked. They are not refused on the spot because a *later* argument can still settle them: (f u32-x i32-y i64-z) has no join at the second argument and a perfectly good one — i64, which both widen into — at the third. Each entry is re-asked against the final binding below, so acceptance cannot depend on the order the arguments were written in. *) let pending = ref [] in let targs = map2_lr (fun pat a -> let p = subst_ty !subst pat in (* Which variable, if any, this parameter *is* — written as a bare [$t] and already bound by an argument to the left. That is the one shape implicit widening can reach, because [Types.widens_to] admits only numeric scalars: a variable bound inside [[$t]] or [(Fn [$t $t] bool)] leaves a parameter no widening applies to, so the [sort-by] path below is untouched by construction. *) let bound_scalar = match pat with | Types.Var v when (not (open_ty p)) && Types.is_numeric p -> Some v | _ -> None in (* An untyped constant has no type of its own to keep, so it still takes the variable's — [(clamp-to y 0 10)] with [y] an i64 means three i64s and there is no conversion anywhere in it. Everything else is checked on its own terms. *) let untyped_literal = match a.Ast.e with | Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ -> true | _ -> false in (* A bare [$t] an earlier argument bound to a slice or a pointer: this argument may differ from it only in const, and the two meet at the read-only one ([Types.const_join]), whichever came first. So it is checked on its own terms rather than against the binding. *) let bound_view = match pat, p with | Types.Var v, (Types.Slice _ | Types.Ptr _) when not (open_ty p || bound_exactly v) -> Some v | _ -> None in (* A typed .fln lambda, [(the (Fn [i32] i32) (fn ...))], at a [CFn($t) -> $t] parameter: the literal is a CFn at its own types, and those bind [$t] below as any argument's type would. *) let typed_cfn = match p, a.Ast.e with | Types.CFn _, Ast.The (t, { Ast.e = Ast.Fn _; _ }) -> (match resolve ctx.env t with | Types.Fn (ps, r) when fits_shape p (Types.CFn (ps, r)) -> Some (Types.CFn (ps, r)) | _ -> None | exception Loc.Error _ -> None) | _ -> None in let a = if typed_cfn <> None then check ctx ~want:(Option.get typed_cfn) a else 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 checked against the parameter as it always was; the trial leaves no trace of the attempt. *) (match trial ctx (fun () -> check ctx a) with | Ok r -> r | Error _ -> check ctx ~want:p a) else check ctx ~want:p a in (* **Mixed widths at one variable join at the wider type.** The rule used to refuse the pair both ways — TODO.org, "abs is one generic, and a bound joins to the wider type", records the join as the coherent alternative and refusing as the direction that could be walked back. It was walked back on 2026-09-20, by the author: a numeric argument at a variable an earlier argument already bound resolves the variable to whichever of the pair the other widens into, value-preserving widening only, so [(is-eq2 (i8 3) (i64 3))] and its reverse are one copy at i64. A pair with no join — u64 against i64 — is still refused: there is no type that holds every value of both, and inventing one would be picking a type neither argument was written at. Only where the variable is bound by bare scalars. A variable the signature also reaches through a container is bound exactly — a slice's elements cannot be rewritten to a wider width — so those keep the refusal, in their own words. And only where the pair is one widening has an opinion about: a string where $t was bound to i64 is an ordinary mismatch and gets the ordinary refusal below. *) let handled = match bound_view, Types.const_join p a.Tast.ty with | Some v, Some j -> subst := (v, j) :: List.remove_assoc v !subst; true | _ -> match bound_scalar with | Some v when (not (Types.equal p a.Tast.ty)) && Types.is_numeric a.Tast.ty -> (match Types.join p a.Tast.ty with | Some j when Types.equal j p -> (* This argument widens into the binding; the wrap happens with the others, once the binding is final. *) true | Some j when not (bound_exactly v) -> subst := (v, j) :: List.remove_assoc v !subst; true | Some _ -> Loc.failk "check/tyvar-no-widening" a.Tast.loc "%s's $%s was bound to %s by an earlier argument, and this \ one is %s. The signature also binds $%s inside a \ container or function type, which binds its element \ exactly — the pair cannot join at the wider type there. \ Write the conversion — (%s x) — or pass the arguments at \ one type" (written_name name) v (tyname loc p) (tyname loc a.Tast.ty) v (tyname loc p) | None -> pending := (v, p, a.Tast.ty, a.Tast.loc) :: !pending; true) | _ -> false in (* [~widen]: this is the top of an argument's type, which is the one place a widening thunk can be built around it. See [bind_ty]. *) if (not handled) && not (bind_ty ~widen:true subst p a.Tast.ty) then fail a.Tast.loc "%s expects %s here, found %s%s" (written_name name) (tyname loc p) (tyname loc a.Tast.ty) (match p, a.Tast.ty with | Types.Slice (Types.Mut, _), Types.Slice (Types.Const, e) -> Printf.sprintf " — %s takes a slice it may write through, and a %s can \ only be read%s" (written_name name) (tyname loc a.Tast.ty) (match const_copy ctx.env e with | Some c -> Printf.sprintf ". %s copies v into one that can be written" c | None -> "") | _ -> ""); a) pats args in (* Every variable has to be determined by an argument. A return-only variable has nothing to bind it — there is no explicit instantiation syntax by design (plan.org) — so it is refused here, where the signature can be named, rather than producing a copy with a hole in it. *) List.iter (fun v -> if not (List.mem_assoc v !subst) then fail loc "%s's type variable $%s is not determined by any argument" (written_name name) v) vars; (* The pairs that met no join, re-asked now that every argument has spoken. A later, wider argument dissolves one — u32 and i32 both widen into an i64 that arrived third — and one still standing is the real refusal: these two widths meet at no type. *) List.iter (fun (v, t1, t2, ploc) -> let final = List.assoc v !subst in let fits t = Types.equal t final || Types.widens_to ~from:t ~into:final in if not (fits t1 && fits t2) then Loc.failk "check/tyvar-no-join" ploc "this call binds %s's $%s to both %s and %s, and neither holds \ every value of the other. Write the conversion you mean at one \ of the arguments, or pass them at one type" (written_name name) v (tyname loc t1) (tyname loc t2)) !pending; (* The binding is final; the arguments it out-widened catch up. Only a bare [$t] parameter can be here — [bound_exactly] kept every container-bound variable at one exact type — and the cast is the same node the written conversion would have built. *) let targs = map2_lr (fun (pat : Types.t) a -> match pat with | Types.Var v -> (match List.assoc_opt v !subst with | Some f when (not (Types.equal f a.Tast.ty)) && Types.is_numeric a.Tast.ty && Types.widens_to ~from:a.Tast.ty ~into:f -> widen a.Tast.loc f a | Some f when Types.const_widens ~from:a.Tast.ty ~into:f -> { a with Tast.ty = f } | _ -> a) (* And the other widening, for the same reason and at the same moment: a [CFn] argument against an [(Fn [$t] $t)] parameter. A parameter that still mentioned a variable was checked with no expectation at all — there was nothing to expect until the argument had spoken — so [expect] never saw the pair and never built the value the instance's signature needs. It is built here, once the binding is final, exactly as the numeric catch-up above is. A *concrete* [Fn] parameter never reaches this: it was checked with a want in the first pass and [expect] widened it there. The arm is total over the pair, and that is the point of writing it as an [if] rather than as a guard. [bind_ty]'s fallthrough is [Types.fits], which admits [Never] where the instance's signature wants a type — so a binding can succeed over a pair these two words cannot bridge, and a fallthrough of "hand the argument over unchanged" would pass one word where the instance declares two. Every [CFn] arriving at an [Fn] parameter either gets its thunk here or gets the refusal, which is the answer [expect] gives a call with no type variables in it. *) | _ -> (match subst_ty !subst pat, a.Tast.ty with (* A plain value at a [$t?] parameter, which [bind_ty] bound through the Option: wrapped now that $t is known (decision 138). *) | Types.Option _ as o, at when (match at with Types.Option _ | Types.Dyn | Types.Never -> false | _ -> true) -> expect ctx a.Tast.loc ~want:(Some o) a | Types.Fn (ps, r), Types.CFn (ps', r') -> if Types.equal (Types.Fn (ps, r)) (Types.Fn (ps', r')) then mk a.Tast.loc (Types.Fn (ps, r)) (Tast.Thicken (thick_thunk ctx.env a.Tast.loc ps r, a)) else fail a.Tast.loc "%s expects %s here, found %s" (written_name name) (tyname loc (Types.Fn (ps, r))) (tyname loc a.Tast.ty) | _ -> a)) pats targs in (* **A type variable is not instantiated at dyn.** Nothing stopped it before: [dyn] is an ordinary case of [Types.t], so it substituted like any other type and a copy was generated at it. The copy then reached whatever the body did with the value, and the dyn answers are not all there — [(Option dyn)] has no descriptor the collector can find, [slice] over a [(Vec dyn)] refuses. So the refusal existed, it just arrived from inside the generic's own source: [(or-else (Some d) e)] over two dyns is reported against [:385], a line the caller did not write and cannot act on. Every one of those is this refusal arriving late and in the wrong place. Refusing at the binding is also the honest statement of the split. Two models answer "one body, many types" here and they are not rivals: this one instantiates at compile time and keeps the types, and [defgeneric] / [defmulti] dispatch at run time on a value that carries its own. A dyn argument is asking the second question of the first machinery. The message says so and names the other spelling. Bounded variables were already refused — [pred_holds] says no to dyn for all four predicates — so this closes the unbounded half, which is exactly the half that reached the prelude-source diagnostics. A variable that *does* carry a clause is left to that refusal deliberately: it names the predicate the signature actually wrote down, which is the more specific answer of the two, and the generic cast's pin depends on it. *) let clause_on v = match Hashtbl.find_opt ctx.env.generics name with | None -> false | Some gfn -> List.exists (fun (p : Ast.pred) -> String.equal p.Ast.pvar v) gfn.Ast.fwhere in List.iter (fun (v, t) -> if reaches_dyn t && not (clause_on v) then Loc.failk "check/tyvar-at-dyn" loc "this call would instantiate %s at $%s = %s, and a type variable \ is not instantiated at dyn. Write the type the value has, or use \ a defgeneric with a defmethod per class" (written_name name) v (tyname loc t)) !subst; let cparams = List.map (subst_ty !subst) pats in let cret = subst_ty !subst pret in 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 built so the call still type-checks and is thrown away with the rest of the abstract pass; the real copy is generated when the caller is instantiated and the same call site resolves [t] to a concrete type. But the callee's [where] clause is answerable here, and has to be. The whole promise of the abstract pass is that a generic's refusals arrive at its definition; if the predicate were left to the instantiation, [(defn f [x $t] () (sort [x]))] would be accepted at its definition and refused at whichever call site first instantiated it — a refusal in code the caller did not write, which is the thing the pass exists to avoid. So the caller has to declare at least what the callee asks for, and [pred_entails] means [is-ordered] covers a callee wanting [is-equal] without anyone writing both. *) (match Hashtbl.find_opt ctx.env.generics name with | None -> () | Some gfn -> List.iter (fun (p : Ast.pred) -> match List.assoc_opt p.Ast.pvar !subst with | Some (Types.Var v) when not (declares ctx.env.tvpreds v p.Ast.pname) -> Loc.failk "check/predicate-not-carried" loc "%s is written %s, and this call passes the \ type variable $%s, which nothing here declares %s. Add \ %s to this function's own clause" (written_name name) (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)) v (pred_word p.Ast.pname) (where_text loc p.Ast.pname ("$" ^ v)) | Some t when not (open_ty t) && not (pred_holds p.Ast.pname t) -> Loc.failk "check/predicate-unsatisfied" loc "%s is written %s, and this call passes %s, \ which is not %s" (written_name name) (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)) (tyname loc t) (pred_word p.Ast.pname) | _ -> ()) gfn.Ast.fwhere); expect ctx loc ~want (mk loc cret (Tast.Call (name, targs))) end else let sym = instantiate ctx.env loc name vars !subst cparams cret in expect ctx loc ~want (mk loc cret (Tast.Call (sym, targs))) (* Cache or generate, Odin's loop. The key is the whole concrete signature compared pairwise with [Types.equal] — [are_types_identical] — so calling at the same type twice makes one copy. *) and instantiate env loc gname vars subst cparams cret = let cache = match Hashtbl.find_opt env.insts gname with | Some r -> r | None -> let r = ref [] in jreplace env.insts gname r; r in let same (ps, r, _) = List.length ps = List.length cparams && List.for_all2 Types.equal ps cparams && Types.equal r cret in match List.find_opt same !cache with | Some (_, _, sym) -> sym | None -> let sym = gname ^ "-" ^ String.concat "-" (List.map (fun v -> mangle_ty (List.assoc v subst)) vars) in (* Each instantiation checks the concrete types answer the [where] clause. This is the half of the feature that only exists per copy: the abstract pass took the predicates on trust, and here is where the trust is settled, at the call site that asked, naming it. Before the name-collision check, on purpose. The prelude keeps a per-width family beside a generic where the generic's bound refuses some widths — [abs] under [is-integer] beside the declared [abs-f32] and [abs-f64] — so a float caller of [abs] computes the sym [abs-f64], and "abs-f64 is already defined, rename one of them" is the wrong sentence for what went wrong: the bound refused the type, and that is the message with the fix in it. *) let fn = Hashtbl.find env.generics gname in List.iter (fun (p : Ast.pred) -> match List.assoc_opt p.Ast.pvar subst with | None -> () | Some t -> if not (pred_holds p.Ast.pname t) then Loc.failk "check/predicate-unsatisfied" loc "this call instantiates %s at $%s = %s, and %s is not %s. %s is \ written %s — pass a type the predicate admits" (written_name gname) p.Ast.pvar (tyname loc t) (tyname loc t) (pred_word p.Ast.pname) (written_name gname) (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar))) fn.Ast.fwhere; if Hashtbl.mem env.fns sym then fail loc "%s at these types is called %s, and %s is already defined — rename \ one" gname sym sym; runaway env loc gname cparams; (* The entry goes in *before* the body is checked, which is what makes a recursive generic function terminate: the call to itself at the same types finds this and does not generate a second copy. *) jset cache ((cparams, cret, sym) :: !cache); jreplace env.fns sym (cparams, cret); let saved_subst = env.subst and saved_vars = env.tyvars and saved_preds = env.tvpreds and saved_chain = env.chain in (* Inside the copy there are no variables left: [resolve_name] answers [t] with the concrete type, so every node the body produces is as 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.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. *) match speculate env (fun () -> !check_fn_ref env { fn with Ast.name = sym }) with | 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 (tyname loc (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. *) jset cache (List.filter (fun (_, _, s) -> s <> sym) !cache); jremove env.fns sym; raise e in env.instances <- tfn :: env.instances; sym and is_cast name = Types.ikind_of_name name <> None || Types.fkind_of_name name <> None and byte_slice ctx (a : Ast.expr) = check ctx ~want:(Types.Slice (Types.Const, Types.Int Types.U8)) a and numeric_want want = match want with Some (Types.Int _ | Types.Float _) -> want | _ -> None (* Both operands of a binary operator have one type, so one side has to decide it. Check the side that carries the most information first: a non-literal over a literal, and a float literal over an integer one, since an integer constant converts to a float and not back. Widening (TODO.org, "Implicit numeric widening is legal; narrowing stays a hard error") does not retire that rule, it finishes it. Three things decide, in this order: 1. An expectation, if the site has one, and it reaches *both* operands. So (defn f [] i64 (+ a b)) over two i32s widens each operand and adds at i64, rather than adding at i32 and widening the sum. That is the better of the two readings and it costs nothing to prefer it, because no program that compiled before can reach it — the pair used to be a refusal. 2. A literal, exactly as before: it takes its width from the other operand, so (+ x 1) over a u64 x is still u64 arithmetic and (let [h fnv-offset]) over a u64 defconst still means what it meant. [needs_want] is what marks the forms this applies to and it is untouched. 3. Otherwise the *wider* side decides — [Types.join], whichever operand the other widens into, with a [Cast] put on the narrower one. (+ i32-var i64-var) is an i64 add. Equal width across signedness has no join, by construction: neither i32 nor u32 widens into the other, and the refusal says which cast to write. The mechanism for 3 is a *trial*: ask y for [a]'s type, and if that refusal is the one widening was invented for, look again the other way round. Two things have to be true for a trial to be honest, and both are below. [trial] is the first. Checking is not a function of its argument — it allocates frame slots and it opens scopes — so a check that is abandoned has to leave no trace, and [scoped] cannot help: it restores the scope on the way *out*, which an exception does not take. Without this a binding from the abandoned pass outlives it, which is visible as a name that should be unknown resolving anyway, and worse, as a shadow: the inner binding of (let [t ...] ... (let [t ...] t) ... t) survives into the outer t's slot with nothing ever stored in it. That is an uninitialised read, produced by a program the compiler accepted. [literal_at_want] is the second. A trial that refused because a *literal* could not be built at the wanted type is not a pair of types that failed to meet — the literal had no type of its own to bring — so looking again would answer with the literal's default and quietly move (+ u8-thing 300) to i32. Rule 2 above is not a description of the old language kept for continuity; it is what the author decided, and the kind is how the trial obeys it. *) and trial ctx f = (* Everything a check writes into the context, put back if the check is abandoned — and it is *everything* on purpose, not a chosen subset. Picking the fields that looked like they mattered was tried twice and was wrong twice. [scope] and the slot fields were the first round, found as an uninitialised read. The second round was worse, because the symptom was the other way up: a form that opens a window and closes it on the way out — [check_frames] setting [in_frames], [loop] pushing onto [loops] — leaves that window *open* when a trial inside it is abandoned, and then refuses a perfectly good program. (println (+ i32-x (handler-bind [] i64-y))) (return 0) compiled before this lane and was refused after it, with "return is not allowed inside handler-bind yet" pointing at a line with no handler-bind anywhere near it. A false refusal is not a lesser bug than a false accept; it is just quieter about being one. So the rule here is not judgement, it is the whole record. Three fields would have self-healed anyway — [defer_ok] and [tail] are read and cleared on entry to [check], [outer_what] is never written after the context is built — and they are restored regardless, because "this one cannot currently leak" is exactly the reasoning that produced two rounds of leaks. The destructuring below is closed and warning 9 is turned on for it, so a new field on [ctx] stops this function compiling until somebody decides about it, rather than joining the list of things nobody noticed. [env] is put back the same way, whole, by [snapshot_env]: a function lifted, a generic copy made and cached, a struct registered — all of it goes together, since keeping one of a pair without the other is how a copy ends up calling a lambda that was never emitted. Only [Loc.Error] is caught. A timeout or a stack overflow is not a refusal to reconsider, and silently continuing past one would turn a resource failure into a wrong answer. *) let[@warning "+9"] { env = _; ret = _; lits = _; slots; slot_tys; slot_names; as_slots; scope; defers; defer_slot; defer_ok; defer_block; outer = _; outer_what; caught; place_ok; envslot; parent = _; in_frames; loops; tail; used; kept; in_defer; owner = _ } = ctx in let undo, keep = snapshot_env ctx.env in match speculate ctx.env f with | r -> keep (); Ok r | exception Loc.Error d -> undo (); ctx.slots <- slots; ctx.slot_tys <- slot_tys; ctx.slot_names <- slot_names; ctx.as_slots <- as_slots; ctx.scope <- scope; ctx.defers <- defers; ctx.defer_slot <- defer_slot; ctx.defer_ok <- defer_ok; ctx.defer_block <- defer_block; ctx.outer_what <- outer_what; ctx.in_frames <- in_frames; ctx.caught <- caught; ctx.place_ok <- place_ok; ctx.envslot <- envslot; ctx.loops <- loops; ctx.tail <- tail; ctx.used <- used; ctx.kept <- kept; ctx.in_defer <- in_defer; Error d | exception e -> keep (); raise e (* Whether the trial's refusal is one worth reconsidering. A literal that did not fit is not, and neither is a refusal a program cannot make any use of having a second opinion on. *) and reconsiderable (d : Loc.diag) = not (String.equal d.Loc.kind literal_at_want) (* [a] was checked, y refused [a]'s type, and [b] is y on its own terms — held by the caller when it has one, taken here when it does not. If the pair has a join it can only be [b]'s type (had it been [a]'s, the trial would have passed), so [a] is the operand that moves. *) and join_widen (a : Tast.expr) (b : Tast.expr) = match Types.join a.Tast.ty b.Tast.ty with | Some t when not (Types.equal t a.Tast.ty) -> Some (widen a.Tast.loc t a, widen b.Tast.loc t b) | _ -> None and join_pair ctx (a : Tast.expr) (y : Ast.expr) (d : Loc.diag) = (* Check y on its own terms to find out whether it was simply the wider operand. This trial is guarded too: if y cannot check without an expectation at all — [None], [(zeroed)] — the original refusal is the one reported, so no form loses the expectation it used to get. *) match trial ctx (fun () -> check ctx y) with | Error _ -> raise (Loc.Error d) | Ok b -> (match join_widen a b with | Some pair -> pair | None -> raise (Loc.Error d)) (* [y] checked at [w] in a trial, and a refusal kept ([arm_failed]) so the same operand asked again at the same type, in the same scope, is refused without being walked: a chain of these nested in their second operands is asked once per level above it. *) and trial_at ctx (y : Ast.expr) (w : Types.t) = match List.find_opt (fun (n, (sc, r), w', _) -> n == y && r == ctx.ret && Types.equal w' w && same_scope sc ctx.scope) (Hashtbl.find_all arm_failed y.Ast.loc) with | Some (_, _, _, d) -> Error d | None -> (match trial ctx (fun () -> check ctx ~want:w y) with | Ok b -> Ok b | Error d -> if !lit_recording = 0 then Hashtbl.add arm_failed y.Ast.loc (y, (ctx.scope, ctx.ret), w, d); Error d) and binary ctx ?(dyn_ok = false) ?(join = true) ?(char_ok = false) name loc ~want args = match args with | [ x; y ] -> lit_operands ctx x y (fun () -> binary_pair ctx ~dyn_ok ~join ~char_ok loc ~want x y) | _ -> fail loc "%s takes two arguments" name (* An operator's two operands, while literal locals' uses are recorded: one beside a literal local says the type it meets it at ([Hint]), and two of them are merged. Checked exactly as ever, so a round whose guesses hold is the program. *) and lit_operands ctx (x : Ast.expr) (y : Ast.expr) f = let key (e : Ast.expr) = match e.Ast.e with Ast.Var n -> lit_recorded ctx n | _ -> None in match ctx.lits, key x, key y with | Some s, kx, ky when kx <> None || ky <> None -> let float_lit (e : Ast.expr) = lit_kind e = Some `Float in (* A char local beside an integer literal stays a char: the pair is char arithmetic, or a comparison the checker refuses (decision 131). Only typed code that wants a particular integer makes it a number. *) let lit_add s k ((_, _, _) as c) (other : Ast.expr) = match lit_kind k, lit_kind other with | Some `Char, Some `Int -> () | _ -> lit_add s k c in (* Before the check, which refuses a float literal beside an integer guess. *) (match kx, ky with | Some k, _ when float_lit y -> lit_add s k (Hint, Types.Float (float_default ()), y.Ast.loc) y | _, Some k when float_lit x -> lit_add s k (Hint, Types.Float (float_default ()), x.Ast.loc) x | _ -> ()); let saved = !lit_operand_locs in lit_operand_locs := x.Ast.loc :: y.Ast.loc :: saved; let a, b = try Fun.protect ~finally:(fun () -> lit_operand_locs := saved) f with Loc.Error _ as ex -> (* Refused at the guess, as (+ acc x) is over an i32 guess and an i64 x: what the other operand is on its own terms is the use. *) let own (k, (other : Ast.expr)) = match trial ctx (fun () -> check ctx other) with | Ok e -> lit_add s k (Hint, e.Tast.ty, other.Ast.loc) other | Error _ -> () in (match kx, ky with | Some k, None -> own (k, y) | None, Some k -> own (k, x) | _ -> ()); raise ex in (match kx, ky with | Some k1, Some k2 -> lit_union s k1 k2 | Some k, None -> lit_add s k (Hint, b.Tast.ty, y.Ast.loc) y | None, Some k -> lit_add s k (Hint, a.Tast.ty, x.Ast.loc) x | None, None -> ()); a, b | _ -> f () and binary_pair ctx ~dyn_ok ~join ~char_ok loc ~want (x : Ast.expr) (y : Ast.expr) = (* A char defconst no local shadows reads as the literal it names. *) let is_literal (e : Ast.expr) = is_literal e || (match e.Ast.e with | Ast.Var n -> Hashtbl.mem char_consts n && lookup ctx n = None && peek_outer ctx n = None | _ -> false) in let y_decides = (is_literal x && not (is_literal y)) || (match x.Ast.e, y.Ast.e with | (Ast.Int _ | Ast.UInt _ | Ast.Byte _), Ast.Float _ -> true | _ -> false) in (* A form that cannot be checked without being told what is wanted. A literal takes its width from the expectation, and a keyword has no meaning at all without one — [:lo] resolves against the enum the site expects and there is no keyword type to fall back on. Everything else checks on its own terms. *) let needs_want (f : Ast.expr) = is_literal f || (match f.Ast.e with Ast.Kw _ -> true | _ -> false) in (* A dyn the want opened is put back: beside a dyn a typed operand gives dyn (rule 117), so the pair is the dyn runtime's and only its answer is opened at the want. Opening the operand first made (+ p 1 1) at an i32 want an i32 add that wraps, where (+ 1 1 p) was a dyn add whose answer traps at the i32. *) let reopen (v : Tast.expr) = if not dyn_ok then v else match opened_dyn ~box:(to_dyn ctx) v with Some d -> d | None -> v in if y_decides then begin let b = reopen (check ctx ?want y) in (* An integer literal before a char, under [+] or [-], is an integer: the pair is char arithmetic ([char_step]). *) let a = match x.Ast.e with | (Ast.Int _ | Ast.UInt _) when char_ok && b.Tast.ty = Types.Char -> check ctx x | _ -> check ctx ~want:b.Tast.ty x in a, b end (* [dyn_ok] is set by the operators that have a dyn lowering, and it exists to stop the second operand being coerced to the first's type before anybody has asked whether the pair is a dyn one. Without it [(+ n x)] over an [i64] n and a dyn x threads [i64] into the second check, [expect] does what an annotation site asked for and unboxes, and the result is a *machine* add of a value the runtime was never asked about: the program traps on a float instead of promoting, and nothing in the source says why. The mirror image [(+ x n)] boxed correctly, so the bug was visible only in one operand order. Both sides are checked on their own terms here and the caller decides. That is safe exactly when neither operand needs an expectation, which is what [needs_want] settles — a literal still gets the first operand's type, so [(+ x 1)] over a dyn x goes on building an i64 one. *) else if dyn_ok && not (needs_want y) then begin let a = reopen (check ctx ?want x) in (* y at [a]'s type first, and on its own terms only if that is refused: checking it both ways every time made a chain of these nested in their second operands twice as slow per level. A dyn opened at [a]'s type is seen for what it was. *) let at_a = if a.Tast.ty = Types.Dyn then None else Some (trial_at ctx y a.Tast.ty) in match at_a with | Some (Ok b') -> (match opened_dyn ~box:(to_dyn ctx) b' with Some box -> a, box | None -> a, b') | _ -> let b = check ctx y in (* Nothing dyn about this pair after all, so it is put back the way the typed path built it. Re-checking only when the types actually differ keeps the common case to one check of each operand. *) if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn || Types.equal a.Tast.ty b.Tast.ty then a, b (* Asking y for [a]'s type stays the first thing tried, and not only for continuity: y was checked above with no expectation at all, and an expectation is information. A sum of two products handed to an f32 function is the case — test/programs/math.flan does it — because every literal inside those products defaults to f64 on its own terms, so reading the join off the two unexpected halves would answer f64 for a form the site asked to be f32. The re-check builds them at f32 as it always did. [b] is only used when that re-check refuses, which is the direction [expect] cannot serve: a is the narrower operand and it is the one that has to move. Nothing is checked a third time — the own-terms [b] already in hand is the answer. *) else (match match at_a with | Some (Error d) -> Error d | _ -> trial_at ctx y a.Tast.ty with | Ok b' -> a, b' | Error d -> (match if join && reconsiderable d then join_widen a b else None with | Some pair -> pair | None -> raise (Loc.Error d))) end else begin let a = reopen (check ctx ?want x) in match trial_at ctx y a.Tast.ty with | Ok b -> a, b | Error d -> (* The join moves [a] to something wider, and [a] already has the type asked of the whole: that can only be refused, so y is not walked on its own terms to find it out. *) let doomed = match want with Some w -> Types.equal a.Tast.ty w | None -> false in if join && reconsiderable d && not doomed then join_pair ctx a y d else (* Doomed: said the way the join would have been refused — the pair at the wider type, at this form — when y's own refusal names the wider type it found. *) match want, (if doomed then Found.find_opt mismatch_found d else None) with | Some w, Some found when String.equal d.Loc.dloc.Loc.file y.Ast.loc.Loc.file && d.Loc.dloc = y.Ast.loc -> (match Types.join w found with | Some j when not (Types.equal j w) -> ignore (expect ctx loc ~want:(Some w) (mk loc j Tast.Unit)); raise (Loc.Error d) | _ -> raise (Loc.Error d)) | _ -> raise (Loc.Error d) end (* ── The builtins, said out loud ─────────────────────────────────────── A name, a signature and one line, for every name [named_call] and [var] answer without the program having written it. The editor's C-c C-v used to say "the running program defines no arena-new", which was true and useless: a builtin is in the compiler, so it is in no program's symbol table and [Dev.defs] had nothing to hand over. This is what it hands over instead. It lives here rather than in dev.ml because it describes the arms above it, and a table in another file drifts from them silently. [test_flan]'s [builtin_table] reads this file and the arms and fails on either one having a name the other does not, so the drift is a failing build rather than a name that answers nothing. The signature follows [Dev.signature_of_fn]'s shape — [name [params] ret] — so eldoc reads a builtin the way it reads a defn. Where an arm does not have one shape the signature says what is true rather than inventing one: [?] marks an argument that may be left out, [|] separates the types an arm really does accept, and the predicate names are the compiler's own ([is-numeric], [is-ordered], [is-equal] — check.ml's [where] evaluator), because a generic's author already writes them. Three names have no shape at all and carry a bare name instead of a bracket list; their line says why. One line each, because this is read in an echo area and a help buffer. The lines are the arms' own reasons, cut down — where an arm argues for a decision above itself, the sentence a person needs at the call site is the conclusion, not the argument. *) let builtins : (string * string * string) list = [ (* arithmetic and comparison *) ("+", "+ [is-numeric ...] is-numeric", "Sum, folded left over two or more operands. Two operands of different \ numeric types meet at the wider one when that cannot lose — i32 and i64 \ add at i64 — and i32 with u32 has no such type and is refused."); ("-", "- [is-numeric ...] is-numeric", "Difference, folded left: (- a b c) is ((a - b) - c). With one operand, \ its negation: (- x)."); ("*", "* [is-numeric ...] is-numeric", "Product, folded left over two or more operands of one numeric type."); ("/", "/ [is-numeric ...] is-numeric", "Quotient, folded left. Integer division truncates toward zero."); ("%", "% [is-numeric is-numeric] is-numeric", "Remainder, and it stays at two operands: (% a b c) would mean \ (% (% a b) c), which is a thing nobody writes on purpose."); ("=", "= [is-equal ...] bool", "Equality, chained over two operands or more: (= a b c) is a = b and \ b = c, which is every operand alike. It admits two types < does not: a \ handle, where \"the same entity\" is the question the type exists to \ answer, and a string, compared bytewise by content rather than \ ordered."); ("!=", "!= [is-equal ...] bool", "All different: (!= a b c) is true when every operand differs from every \ other, so (!= 1 2 1) is false. Over everything = accepts. A float NaN \ is != to everything, itself included."); ("<", "< [is-ordered ...] bool", "Less than, chained: (< a b c) is a < b and b < c, and every operand is \ evaluated once. Machine numbers and enums only — ordering a handle \ would order a free-list slot index, which means nothing."); ("<=", "<= [is-ordered ...] bool", "Less than or equal, chained like <."); (">", "> [is-ordered ...] bool", "Greater than, chained like <."); (">=", ">= [is-ordered ...] bool", "Greater than or equal, chained like <."); ("not", "not [bool] bool", "Negates a bool. Nothing else in this language is a truth value."); ("bit-and", "bit-and [int ...] int", "Bitwise and, folded left; a && b in a .fln file. Integers only; operands \ of different widths meet at the wider one, the way + does."); ("bit-or", "bit-or [int ...] int", "Bitwise or, folded left over integers; a || b in a .fln file."); ("bit-xor", "bit-xor [int ...] int", "Bitwise exclusive or, folded left over integers; a ^^ b in a .fln file."); ("bit-not", "bit-not [int] int", "Every bit of an integer flipped; ~~a in a .fln file."); ("&&", "&& [int ...] int", "bit-and, by its .fln spelling."); ("||", "|| [int ...] int", "bit-or, by its .fln spelling."); ("^^", "^^ [int ...] int", "bit-xor, by its .fln spelling."); ("~~", "~~ [int] int", "bit-not, by its .fln spelling."); ("<<", "<< [int int] int", "Left shift. The value's type decides — a narrower count widens to it, a \ wider one is refused — and a literal count at or past the value's width \ is refused too. On a dyn int, a count outside 0 to 63 traps."); (">>", ">> [int int] int", "Right shift, arithmetic on a signed type and logical on an unsigned one. \ The value's type decides and the count widens to it; a literal count at \ or past the width is refused, as it is for <<."); ("rotate-left", "rotate-left [int int] int", "The bits of the value moved left by the count, the ones that fall off \ the top coming back in at the bottom. The count is taken modulo the \ width."); ("rotate-right", "rotate-right [int int] int", "The bits of the value moved right by the count, wrapping round to the \ top. The count is taken modulo the width."); ("popcount", "popcount [int] int", "How many bits of the integer are set. The answer has the operand's \ type."); ("leading-zeros", "leading-zeros [int] int", "How many zero bits come before the highest set bit, counted within the \ operand's width: the width itself for 0."); ("trailing-zeros", "trailing-zeros [int] int", "How many zero bits come after the lowest set bit: the width for 0."); ("min", "min [is-ordered ...] is-ordered", "The smallest of two or more operands, each of them evaluated exactly \ once however many there are. Two widths meet at the wider: (min i8-x \ i16-y) is an i16."); ("max", "max [is-ordered ...] is-ordered", "The largest of two or more operands, each evaluated exactly once."); ("max-value", "max-value [type] T", "The largest value of a numeric type: (max-value u8) is 255, and at a \ float the largest finite value. Takes a type variable under \ {:where (is-numeric $t)}."); ("min-value", "min-value [type] T", "The least value of a numeric type: (min-value i8) is -128, 0 at an \ unsigned type, and at a float the negation of the largest finite value."); ("zeroed", "zeroed [] T", "The all-bytes-zero value of whatever it is being stored into, so it \ only means anything where a type is expected of it."); ("filled", "filled [u8] T", "Every byte of whatever it is being stored into set to one byte, as in \ (set grid (filled 0xFF)). Numbers only, and structs and fixed arrays \ built out of them."); ("dead-beef", "dead-beef [u32?] T", "A four-byte pattern repeating over whatever it is being stored into, \ written so a hex dump reads it left to right: 0xDEADBEEF with no \ argument, the u32 given otherwise. A size that is not a multiple of \ four ends on a prefix of the pattern. Same types [filled] takes."); ("destructure~nth", "destructure~nth [[n T] i32 i32 i32] T", "Written by the compiler for a destructuring let, and unspellable: the \ reader makes ~ a delimiter, so no source symbol can name this."); (* allocators, spec-memory.md *) ("make-allocator", "make-allocator", "A user-written allocator, not implemented and refused wherever it is \ written. Use (arena-new n), which is the parameterised allocator that \ does exist."); ("allocator-from", "allocator-from", "A user-written allocator, not implemented — see make-allocator."); ("allocator", "allocator", "A user-written allocator, not implemented — see make-allocator."); ("heap-allocator", "heap-allocator [] Allocator", "The process heap as an Allocator: it releases one block at a time, so \ can-free is true of it."); ("arena-new", "arena-new [i64] Allocator", "A new arena of exactly this many bytes. The capacity is explicit and \ the backing store never grows, which is what makes \"exhausted\" a \ state a test can reach on purpose."); ("arena-destroy", "arena-destroy [Allocator] ()", "Hands the arena's pages back to the system, which free-all \ deliberately does not."); ("free-temp", "free-temp [] ()", "Releases everything in the temp allocator, context/temp — where \ i64->bytes and f64->bytes put their text. Called once a frame; a dev \ build also does it at every frame boundary the agent polls at. Text \ kept past the frame is cloned out first."); ("free-all", "free-all [Allocator] ()", "Releases everything the allocator holds and bumps its epoch, keeping \ the capacity. It traps rather than quietly doing nothing when there is \ no region to release."); ("can-free", "can-free [Allocator] bool", "Whether this allocator can release a single block, read off its \ capability set rather than asked of a query procedure."); ("can-free-all", "can-free-all [Allocator] bool", "Whether this allocator can release everything it holds at once."); ("alloc-epoch", "alloc-epoch [Allocator] i64", "The counter free-all bumps. A container records it and traps if it \ moved; this is the same number, readable, so a program can say what it \ saw."); ("alloc-id", "alloc-id [Allocator] i64", "The allocator's identity — its address — which is what a condition's \ :allocator field carries, so a handler holding several regions can \ tell which one ran out."); ("alloc-budget", "alloc-budget [Allocator] i64", "The ceiling on live bytes, 0 for none. A handler that answers \ StorageExhausted with retry is the one that raises it."); ("set-alloc-budget", "set-alloc-budget [Allocator i64] ()", "Sets the ceiling on live bytes; 0 for none. It is also how a program \ exhausts an allocator on purpose."); ("alloc-live-blocks", "alloc-live-blocks [Allocator] i64", "How many blocks are still live — \"did you forget to free\", answered \ at the tier that can answer it."); ("with-allocator", "with-allocator [Allocator body ...] T", "Runs the body with this allocator in the context, and answers the \ body's last expression. It releases nothing: not at the end of the \ body, not anywhere."); (* (Vec T) *) ("vec-new", "vec-new [T? Allocator?] (Vec T)", "An empty Vec. A let has no type annotation, so the element type is \ written at the call — (vec-new i32) — wherever the context does not \ say it; an allocator may be named the same way."); ("push", "push [(Vec T) T] ()", "Appends one element, growing the Vec through its allocator. Unit and \ not an error code: a failed allocation signals StorageExhausted."); ("reserve", "reserve [(Vec T)|(Map K V) i32] ()", "Makes room for n more. For a map the number is entries rather than \ slots — the block is sized so that n still sits under the load \ factor."); ("free", "free [(Vec T)|(Map K V)|String|[T] Allocator?] ()", "Releases the container's block. It does not recurse into elements that \ own storage — such a container is refused here, and releasing its \ region with free-all is the answer. A slice (bytes s) or (clone xs) \ made goes back to the current allocator, or the one named; a dev build \ traps on a slice from another allocator or not from one at all."); ("clone", "clone [(Vec T)|(Map K V)|String|[T] Allocator?] (Vec T)|(Map K V)|String|[T]", "A deep, independent copy, from the current allocator or one named. \ A slice's copy is a slice over a new block, released by (free s) or by \ its allocator's free-all. Refused for elements that own \ storage: a bytewise copy would alias the original's blocks under a \ name promising otherwise."); ("into-copies-elements", "into-copies-elements [src dst transform...] ()", "What into writes when its chain has no (map f). Refuses a source whose \ elements own storage, because pushing them as they stand would share \ their blocks. Not meant to be written by hand."); (* String *) ("string-new", "string-new [(str|String)? Allocator?] String", "A String: owned, growable text that is always valid UTF-8. Empty, or \ a copy of the text given; from the current allocator or one named, and \ released by (free s). A str is checked as it is copied in."); ("bytes->string", "bytes->string [(Vec u8) Allocator?] String", "A new String holding a copy of the Vec's bytes, once they are checked \ to be UTF-8 — here, at run time. Bytes that are not stop the program \ at this call. The Vec is untouched and is still yours to free."); ("append", "append [String str|String|i32] () append [(Vec u8) [const u8]] ()", "Adds text or one code point to the end of a String. A str is checked \ to be UTF-8 as it is stored and a code point to be a Unicode scalar \ value; a literal is checked when the program is compiled. Onto a \ (Vec u8), or a pointer to one, it adds raw bytes."); ("insert", "insert [String i32 str|String|i32] ()", "Stores text or a code point before the character at position i, \ counting characters and not bytes; i may be the character count, \ which is the end. Checked as append checks, and a position past the \ end signals BoundsError."); ("remove", "remove [String i32] i32", "Takes out the character at position i, counting characters, and \ answers its code point. A position past the end signals BoundsError."); ("runes", "runes [str|String|[const u8]] Runes", "A cursor over the text's chars: (runes-next (addr it)) answers \ the next one, or None at the end. A malformed byte in a str comes back \ as U+FFFD."); ("rune-count", "rune-count [str|String|[const u8]] i32", "How many characters — code points — the text holds, where length \ counts bytes. A malformed byte counts as one."); (* (Map K V) *) ("map-new", "map-new [K? V? Allocator?] (Map K V)", "An empty map. The key and value types are written at the call — \ (map-new string i32) — wherever the context does not say them."); ("put", "put [(Map K V) K V] ()", "Inserts or replaces. Unit rather than an error code, and \ (set (get m k) v) is not map syntax."); ("get", "get [(Map K V) K]|[collection i32 ...] (Option V)|(Option T)", "The value at the key, or None. Nothing signals here — a lookup that \ finds nothing is an answer — and the value comes back as a copy of \ its bytes. Over an array, a slice, a string or a Vec it is at that \ answers None for an index out of range, negative included, one index \ per dimension. Over a dyn it answers nil for an absent key or index, \ and more keys walk a level each."); ("map-remove", "map-remove [(Map K V) K] (Option V)", "Removes the entry and answers the value it held, or None if there was \ none."); ("map-next", "map-next [(Map K V) (Ptr i64) (Ptr K) (Ptr V)] bool", "Walks the map one entry per call through a cursor the caller owns, and \ is the whole of map iteration: (while (map-next m (addr cur) (addr k) \ (addr v)) ...)."); ("??", "?? [(Option T)|dyn T ...] T", "x ?? d in .fln: what x holds, or d when x is None (nil over a dyn). d is \ evaluated only then. a ?? b ?? c reads from the right, and a default \ that is itself an Option keeps the whole an Option."); ("?", "? [(Option T)|dyn] bool", "x? in .fln: whether x holds a value — Some, or a dyn that is not nil. \ In if x?, elif x? and while x?, a local x is its payload in the block."); ("!!", "!! [(Option T)|dyn] T", "x! in .fln: what x holds. When x is None (nil over a dyn) the program \ stops there, naming x."); ("has-key", "has-key [(Map K V) K] bool", "Whether the key is present, copying no value — the form a condition \ wants, where get would hand back an Option to match on. Over a dyn map \ it is the question that stays askable when nil might also be stored \ under the key."); ("class-of", "class-of [dyn] dyn", "The class's name as a keyword for a value built by a defclass \ constructor, and nil for everything else — an ordinary map included. \ It is what a defgeneric dispatches on, so a class dispatcher is this \ call over the first argument and a defmulti whose body is (class-of x) \ is the same generic function written the other way."); ("type-of", "type-of [dyn] dyn", "The value's kind as a keyword — :nil :bool :int :float :text :vec \ :keyword :map :char — or, for a value built by a defclass constructor, the \ class's name as class-of answers it. A typed value answers the kind it \ has as a dyn value: an i32 is :int."); ("chars", "chars [dyn] dyn", "A dyn text's characters, as a new dyn vector of chars. A dyn text \ counts characters, not bytes, in length, at and slice."); ("text", "text [dyn] dyn", "The dyn text a dyn vector of chars, or a single char, spells: \ (text (chars t)) is t."); ("keyword", "keyword [str|[const u8]] dyn", "The interned dyn keyword named by the bytes, for a name that only \ exists at run time — a reader building :texture-path out of a token's \ text. A literal :foo is already one."); (* assets, embedded at compile time *) ("embed", "embed [\"path\" str?] [const u8]", "The file's bytes, read at compile time and baked in as a constant; \ (embed \"p\" str) reads it as a str instead. The path is \ relative to the file the form is written in, and the slice points into \ read-only data."); ("embed-dir", "embed-dir [\"path\"] [n EmbedFile]", "Every file in the directory, read at compile time, as a fixed array of \ EmbedFile. It does not descend."); ("compile-error", "compile-error [\"message\"] ()", "Refuses the compile with that message, at the form it is written in. \ What a macro expands to when it has to say why: a name nothing defines \ carries a name, and this carries a sentence."); (* files *) ("slurp", "slurp [str Allocator?] (Vec u8)", "Reads a whole file. No Result and no out-parameter: a failure to read \ signals FileError under retry and use-value, and a failure to allocate \ signals StorageExhausted."); ("barf", "barf [str [const u8]] ()", "Writes a whole file. On the web target it signals FileError every \ time, with the path — there is no conditional compilation, so the \ program decides rather than the build."); ("delete-file", "delete-file [str] ()", "Removes the file, or signals FileError with retry and use-value. It \ answers () and not a bool, because the failure is the condition."); ("make-directory", "make-directory [str] ()", "Creates the directory, or signals FileError. () for the reason \ delete-file answers one."); ("rename-file", "rename-file [str str] ()", "Renames the first path to the second, or signals FileError. A \ use-value names a different source for the same destination, which is \ the direction a handler can act on."); (* containers *) ("length", "length [[n T]|[T]|str|String|(Vec T)|(Map K V)] i32", "How many elements. One question and one word across an array, a slice, \ a string, a Vec and a Map. A str and a String count bytes, as rune-count \ does not; a dyn text counts characters."); ("at", "at [collection i32 ...] T", "The element at an index, bounds-checked — and for a Vec with the \ allocator's epoch checked first. On a string it is the byte, a u8. It \ is also a place, so (set (at v i) x) goes through the same check; a \ string is the exception, being a view it does not own."); ("slice", "slice [[n T]|[T]|str|(Vec T) i32? i32?] [T]|str", "The half-open range [lo hi) as a non-owning view. lo defaults to 0 and \ hi to the length, so (slice a) is the whole of it and (slice a n) is \ the tail from n. A bound may sit one past the end; a literal pair that \ runs backwards is refused here. A string slices to a string. A view of \ a Vec is a borrow from storage the Vec owns, and a push, a put or a \ reserve on that Vec may invalidate it."); ("slice-from", "slice-from [(Ptr T) n] [T]", "Puts a length on a pointer that came back from C; n is any integer \ type. The caller promises it addresses that many initialised T and that \ they outlive the result; the compiler checks none of it. A negative n \ traps in every build."); ("addr", "addr [place] (Ptr T)", "The address of a place — a name, (.field x), (at a i) or (deref p) — \ and not of an arbitrary expression."); ("deref", "deref [(Ptr T)] T", "The value behind a pointer, and a place, so (set (deref p) x) writes \ through it."); (* Option *) ("Some", "Some [T] (Option T)", "Wraps a value as a present Option. None is the other half, and is \ written as a name rather than as a call. Where an (Option T) is \ expected a T is wrapped with no Some written, one level at a time; an \ Option is never unwrapped that way."); (* the host primitives *) ("bytes", "bytes [str Allocator?] [u8]", "A writable copy of the string's bytes, from the current allocator or \ one named. It allocates like vec-new does — a failure signals \ StorageExhausted with retry — and (free b) releases it, through the \ current allocator or (free b a) through the one it came from. For reading without a copy, \ bytes-view."); ("bytes-view", "bytes-view [str|String] [const u8]", "The string's own storage seen as a read-only byte slice. It costs \ nothing — both are a ptr and a length at run time — and it decodes \ nothing. A store through it is a compile error; bytes is the writable \ copy."); ("str", "str [[const u8]|String] str", "A byte slice, or a String's text, seen as a str, and free at run time. \ A String's str lasts until the String next changes. It does not check \ UTF-8, because `str` does not claim UTF-8 — is-valid-utf8 is an \ ordinary function you call when you care."); ("char", "char [int|char|dyn] char", "A code point as a char. Only a Unicode scalar value is one — 0 to \ 0x10FFFF, outside 0xD800 to 0xDFFF: a literal is checked when it \ compiles and any other value when it runs. (i32 c) is the way back."); ("bytes->f64", "bytes->f64 [[const u8]] f64", "Parses a float out of the bytes."); ("bytes->i64", "bytes->i64 [[const u8]] i64", "Parses an integer out of the bytes."); ("f64->bytes", "f64->bytes [f64] [u8]", "The number's text, %g, in the temp allocator: it lasts until the next \ (free-temp). Clone it to keep it longer."); ("i64->bytes", "i64->bytes [i64] [u8]", "The number's text, in the temp allocator: it lasts until the next \ (free-temp). Clone it to keep it longer."); ("write-stdout", "write-stdout [[const u8]] ()", "Writes the bytes to standard output exactly as given: no newline and \ no formatting."); ("print", "print [T ...] ()", "The structural printer, selected for each argument's concrete type; \ arguments print in order with a single space between them. A string \ prints raw at the top level and quoted inside a structure, and a Ptr \ or a Handle prints its address rather than being followed. Printing \ is a read, so it does not consume the value."); ("println", "println [T ...] ()", "print, with a newline after it — (println) alone is the newline."); ("watch", "watch [str T] ()", "Writes the value, rendered as print renders it, into the dev session's \ watch table under the name, where M-x flan-watch shows it. Does nothing \ when no watch buffer is open. Outside a dev build it only evaluates \ the value."); ("exit", "exit [i32] never", "Ends the process with this status. It has no value, so nothing written \ after it runs."); ("argv", "argv [] [str]", "The command line, as a slice of strings."); (* the names rather than calls — [var]'s arms. Their signature is the [name type] shape [Dev.defs] gives a global, because that is what they are at the site: a value, not a call. *) ("true", "true bool", "The true boolean literal."); ("false", "false bool", "The false boolean literal."); ("nil", "nil dyn", "The absent dyn value: what (get m k) answers for a key a dyn map does \ not hold. It becomes None where an (Option T) is wanted, and stays dyn \ everywhere else."); ("None", "None (Option T)", "The absent Option. It takes its type from its context — a return type, \ a parameter, or (the (Option i32) None) — because nothing about the \ word says what it is an Option of."); ("context/allocator", "context/allocator Allocator", "The allocator in effect here: what with-allocator rebinds, and what an \ allocating operation uses when none is named at the site."); ("context/temp", "context/temp Allocator", "The scratch allocator the calling convention carries beside \ context/allocator.") ] (* The forward reference declared beside [nearest], filled the moment the table it names exists. Nothing reads it before a call is checked, and no call is checked before this module is loaded. *) let () = builtin_names := List.map (fun (n, _, _) -> n) builtins; List.iter (fun (n, _, _) -> Hashtbl.replace builtin_set n ()) builtins (* ── The one thing shadowing owes the reader ──────────────────────────── A defn named after a builtin is legal and it wins ([shadows_builtin]), and that is a large thing to have happened in silence: every [(get m k)] in the file now means something the reader has to go and look at. So it is said once, where the decision was made, and never again at the call sites — a footgun notice, not a lint. It is a warning and it says so in the one way that matters: nothing raises and the exit status does not move. Unlike [memory_sites] it is behind no flag, because there is nothing to tune — a program either renamed a builtin or it did not, and the line is one line and rare. The second half of the sentence names the way out. Until [builtin/] there was none: a file that defined [length] had given the builtin [length] up for the whole file, and a defn that meant to *wrap* it was unbounded recursion instead. Saying so here is the cheapest place it can be said — the reader is being told the name was taken over, and the next thing they want to know is what is left. The prelude is skipped: its defns are the language's own and a collision there is a compiler bug rather than news for whoever is compiling. So are qualified names, for the reason [shadows_builtin]'s [visible] gives — [rl/get] is not [get] and shadows nothing. *) let shadowed_builtins (decls : Ast.decl list) : Loc.diag list = (* Once per name: the arities of one fn are one definition. *) let said = Hashtbl.create 4 in List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defn fn when Hashtbl.mem builtin_set fn.Ast.name && not (Hashtbl.mem said fn.Ast.name) && (Hashtbl.replace said fn.Ast.name (); true) && not (String.contains fn.Ast.name '/') && not (String.equal fn.Ast.nloc.Loc.file Prelude.file) -> Some (Loc.diag ~kind:"check/shadows-builtin" (* A fn with several arities is warned about at its fn line. *) (if fn.Ast.fgroup <> None then d.Ast.dloc else fn.Ast.nloc) (Printf.sprintf "%s shadows the builtin %s — every call in this program now \ reaches your definition — the builtin stays reachable as %s%s" fn.Ast.name fn.Ast.name builtin_prefix fn.Ast.name)) | _ -> None) decls (* ── Declarations: pass 1, collect ─────────────────────────────────── *) (* Constant folding, only over integers and only for defconst — enough for an array length like (/ screen-height cell-size). *) let rec const_int env (e : Ast.expr) : int64 option = match e.Ast.e with | Ast.Int n -> Some n | Ast.Byte b -> Some (Int64.of_int b) | Ast.Var n -> Hashtbl.find_opt env.consts n | Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ x ]) -> Option.map Int64.neg (const_int env x) (* A conversion to an integer type, which is how a negative number is written as an unsigned constant's bit pattern: [(u64 -1)]. Truncated to the type's width and extended by its sign, as the cast does at run time. *) | Ast.Call ({ Ast.e = Ast.Var k; _ }, [ x ]) when Types.ikind_of_name k <> None -> let k = Option.get (Types.ikind_of_name k) in let bits = Types.bits k in Option.map (fun n -> if bits = 64 then n else if Types.signed k then Int64.shift_right (Int64.shift_left n (64 - bits)) (64 - bits) else Int64.logand n (Int64.sub (Int64.shift_left 1L bits) 1L)) (const_int env x) (* Left to right over any number of operands, because that is how the checker reads the same form: an array length that type-checks as a product of three literals and is then not a constant would be a distinction with nothing behind it. [%] is still two, as it is there. *) | Ast.Call ({ Ast.e = Ast.Var op; _ }, x :: y :: rest) -> let step a b = match op with | "+" -> Some (Int64.add a b) | "-" -> Some (Int64.sub a b) | "*" -> Some (Int64.mul a b) | "/" when b <> 0L -> Some (Int64.div a b) | "%" when b <> 0L && rest = [] -> Some (Int64.rem a b) | _ -> None in List.fold_left (fun acc e -> match acc, const_int env e with | Some a, Some b -> step a b | _ -> None) (const_int env x) (y :: rest) | _ -> None (* [(defconst grid [rows [cols u8]])]. A two-element defconst has no type slot — the second form is always a value — so the brackets were read as an array *literal* and [u8] as a name in it, and the refusal that came out was "unknown name u8", which sends the reader to look for a missing definition of something the language has had all along. A type name inside an array literal is unambiguous evidence, because a type and a value cannot share a name: [collect]'s claimed table is over every declaration kind there is. So finding one means the whole form was meant as a type, and the form that takes one is [defonce]. *) let rec defconst_type_shaped env gname (v : Ast.expr) = match v.Ast.e with | Ast.Arr items -> List.iter (fun (i : Ast.expr) -> match i.Ast.e with | Ast.Var n when is_type_name env n -> Loc.failk "check/defconst-is-a-type" i.Ast.loc "%s is a type, and this is a value: a two-element defconst has no \ type slot, so the brackets around it were read as an array \ literal and %s as a name in it. A global declared by its type is \ a defonce — write (defonce %s ...) with the same brackets" n n gname | _ -> defconst_type_shaped env gname i) items | _ -> () (* Every parent a struct names, now that every struct has its fields. A parent has exactly [Error]'s two fields, [name string] and [message string], and that is not a style rule: a handler that matched through the link is handed the signal site's descriptor rather than the condition, because the condition's layout is its own type's and the handler's type is an ancestor's. The descriptor's first two fields are the name and the sentence, so a parent shaped any other way would be read off bytes that are not its fields. *) let check_parents env = Hashtbl.iter (fun child parent -> let loc = Option.value (Hashtbl.find_opt env.locs child) ~default:Loc.unknown in if not (error_shaped env parent) then begin let has = match Hashtbl.find_opt env.structs parent with | Some { Tast.fields = []; _ } -> "none" | Some s -> String.concat " " (List.map (fun (f : Tast.field) -> f.Tast.fname ^ " " ^ Types.to_string f.Tast.fty) s.Tast.fields) | None -> "none" in let fix = match Hashtbl.find_opt env.parents parent with | Some _ -> Printf.sprintf "(defstruct %s :parent %s)" parent (Hashtbl.find env.parents parent) | None -> Printf.sprintf "(defstruct %s :parent Error)" parent in fail loc "%s names %s as its parent, and a parent has exactly the fields \ [name string message string], because a handler for a parent is \ handed the name and the message of whatever it caught. %s has \ [%s]. Declare it with no field vector, %s, which gives it those \ two" child parent parent has fix end; (* A cycle is a chain with no root; the walk stops at the repeat. *) let chain = condition_chain env child in match Hashtbl.find_opt env.parents (List.nth chain (List.length chain - 1)) with | Some back -> fail loc "%s's parents go round in a loop, %s -> %s, and a chain of parents \ has to end at a type with no parent, such as Error" child (String.concat " -> " chain) back | None -> ()) env.parents (* Untyped constants to a fixpoint, and for the same reason: one untyped constant may be defined in terms of another declared after it. A constant that still does not check once no progress is left has a real error, so the last round is run without swallowing it. *) (* ── One fn, several arities (decision 139) ───────────────────────────── [fn f] with [(g: Grain) -> bool] and [(r: i32, c: i32) -> bool] under it is one function with two arities, and a call picks one by how many arguments it passes. [Parse.splice] made one [defn] per arity, all at the form's location; nothing past the checker knows either: each arity is renamed here to a name of its own, and from then on it is an ordinary function with an ordinary symbol, cell and stale-call word. The [~] is what keeps the renamed name out of a program's reach — it ends a symbol in both readers — as it does for [prelude~]. A fn with one arity keeps its name, so its symbol is what it always was; only a name with two or more is renamed, all of its arities alike, so no arity is the plain name's by accident of order. The form is the unit of definition, Clojure's: the arities are closed, and a second [fn f] anywhere is [f] defined twice whatever its arity, since letting it add one would make which arities exist depend on which files were read. Types play no part in the choice. *) let split_versions env (decls : Ast.decl list) : Ast.decl list = let arities = Hashtbl.create 16 in List.iter (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defn fn -> let n = fn.Ast.name and k = List.length fn.Ast.params in let seen = Option.value ~default:[] (Hashtbl.find_opt arities n) in (match seen with | (_, _, group, gloc) :: _ when fn.Ast.fgroup = None || group <> fn.Ast.fgroup -> let fln = fln_source d.Ast.dloc in Loc.failk "check/defined-twice" d.Ast.dloc ~notes:[ Loc.note gloc (n ^ " is already defined here") ] "%s is defined twice. A function with several arities is one \ definition, each arity under it:\n\n%s" n (if fln then Printf.sprintf " fn %s\n (a: T) -> R\n ...\n \ (a: T, b: T) -> R\n ..." n else Printf.sprintf " (defn %s ([a T] R ...) ([a T b T] R ...))" n) (* [main] is called by the startup code, by its own name, so it has one arity. *) | (_, first, _, _) :: _ when String.equal n "main" -> Loc.failk "check/defined-twice" fn.Ast.nloc ~notes:[ Loc.note first "main's other arity is here" ] "main has one arity: the program's startup calls it by its \ name" | _ -> ()); (match List.find_opt (fun (j, _, _, _) -> j = k) seen with | Some (_, first, _, _) -> Loc.failk "check/defined-twice" fn.Ast.nloc ~notes:[ Loc.note first "the other one is here" ] "%s has two arities with %d parameter%s. Each arity takes a \ different number of arguments, which is how a call picks one" n k (if k = 1 then "" else "s") | None -> ()); Hashtbl.replace arities n (seen @ [ (k, fn.Ast.nloc, fn.Ast.fgroup, d.Ast.dloc) ]) | _ -> ()) decls; Hashtbl.iter (fun n seen -> if List.length seen > 1 then Hashtbl.replace env.versions n (List.sort compare (List.map (fun (k, _, _, _) -> (k, version_name n k)) seen))) arities; if Hashtbl.length env.versions = 0 then decls else List.map (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defn fn when Hashtbl.mem env.versions fn.Ast.name -> let v = version_name fn.Ast.name (List.length fn.Ast.params) in { d with Ast.d = Ast.Defn { fn with Ast.name = v } } | _ -> d) decls let settle_consts env consts = let infer (_, v) = with_typed_literals (fun () -> (check (invented_ctx env Types.Unit) v).Tast.ty) in let pending = ref consts in let rec settle () = let left = List.filter (fun ((n, _) as c) -> match speculate env (fun () -> infer c) with | ty -> Hashtbl.replace env.globals n (ty, true); false | exception Loc.Error _ -> true) !pending in let progressed = List.length left < List.length !pending in pending := left; if progressed && left <> [] then settle () in settle (); List.iter (fun c -> ignore (infer c)) !pending (* Set by [collect], read by [build_program] once [infer_returns] ran. *) let consts_after_infer : (string * Ast.expr) list ref = ref [] let collect env (decls : Ast.decl list) = (* One pass over every declaration kind before any of the others, because the tables below are per-kind — structs, data types, aliases, enums, functions and globals each have their own — and a collision between two of them would otherwise be found by LLVM, as [redefinition of function '@flan.item'], or not at all. A [defn item] and a [defonce item] are two declarations of one name and are rejected here. *) (* The qualifier is reserved on this side too. [(defn builtin/length ...)] reads — the reader treats [/] as an ordinary symbol character — and would otherwise land in [env.fns] under a name nothing can ever call, because [named_call] strips the prefix before any table is consulted. A declaration that can only ever be dead is refused where it is written rather than left to be discovered. [Load] refuses the same qualifier from the other direction, at an import's alias. *) List.iter (fun (d : Ast.decl) -> match Ast.declared_name d with | Some n when qualified_builtin n <> None -> fail d.Ast.dloc "%s cannot be declared: %s is a reserved qualifier, so a name \ spelled with it reaches the compiler's builtins and never a \ declaration — nothing could call this one" n builtin_prefix (* [[const u8]] is a read-only slice only because no constant can be named [const]: [[n T]] takes a constant's name for [n], and a declaration of that name would make the brackets mean two things. A local cannot be an array length, so only a declaration is refused. *) | Some "const" -> Loc.failk "check/reserved-const" d.Ast.dloc "const cannot be declared: it is reserved for the read-only slice \ type, [const T]. Choose another name" | _ -> ()) decls; let claimed = Hashtbl.create 64 in let is_defn (d : Ast.decl) = match d.Ast.d with Ast.Defn _ -> true | _ -> false in List.iter (fun (d : Ast.decl) -> match Ast.declared_name d with | None -> () | Some n -> (match Hashtbl.find_opt claimed n with (* Two [defn]s of one name are either the arities of one fn or one name defined twice, and the arities are known only once the parameter vectors are paired — [split_versions], below [pair_decls], says which. *) | Some (_, true) when is_defn d -> () | Some (first, _) -> (* The second one is the error, because it is the one to delete; the first is the note, because without it the message is a claim the reader has to go and verify. *) Loc.failk "check/defined-twice" d.Ast.dloc ~notes:[ Loc.note first (n ^ " is already defined here") ] "%s is defined twice" n | None -> Hashtbl.add claimed n (d.Ast.dloc, is_defn d))) 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 = [] } | Ast.Defdata (n, _) -> Hashtbl.replace env.locs n d.Ast.dloc; Hashtbl.replace env.datas n { Tast.dname = n; cases = [] } | Ast.Defunion (n, _) -> Hashtbl.replace env.locs n d.Ast.dloc; Hashtbl.replace env.unions n { Tast.sname = n; fields = [] } (* [int] and [float] are builtin aliases (Types), and a program that declared them itself — which this one's author did, before they were builtin — must not quietly stop meaning what it says. The alias table is never consulted for either name: [resolve_name] answers from [ikind_of_name] first, so a [(defalias int i64)] left to register would be read as [i32] at every use and nothing would ever say so. So the target decides. Spelled as the builtin's own type, the declaration is true and is accepted as the no-op it is — the old program still compiles, and deleting the line is a cleanup rather than a fix. Spelled as anything else it is refused, because the only alternative is to silently mean something else. Nothing is written to the table either way: the name resolves without it. *) | Ast.Defalias (n, { Ast.t = Ast.Tname target; _ }) when n = "int" || n = "float" -> let builtin = if n = "int" then "i32" else "f32" in if target <> builtin then Loc.failk "check/builtin-alias" d.Ast.dloc "%s is a builtin alias for %s and cannot be redefined as %s — \ delete this defalias, or give the type another name" n builtin target | Ast.Defalias (n, _) when n = "int" || n = "float" -> let builtin = if n = "int" then "i32" else "f32" in Loc.failk "check/builtin-alias" d.Ast.dloc "%s is a builtin alias for %s and cannot be redefined — delete \ this defalias, or give the type another name" n builtin | 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). *) let fold_consts () = let progress = ref false in List.iter (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defconst (n, _, v) when not (Hashtbl.mem env.consts n) -> (match const_int env v with | Some i -> Hashtbl.replace env.consts n i; progress := true | None -> ()) | _ -> ()) decls; !progress in while fold_consts () do () done; let field (f : Ast.field) : Tast.field = (* The flag is reset through [Fun.protect] because a refusal here does not end the run: [program_all] carries on collecting diagnostics, and a flag left set would misword every later unknown-type message. *) env.in_field <- true; let fty = Fun.protect ~finally:(fun () -> env.in_field <- false) (fun () -> 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 } in (* Constants with no declared type are inferred from their value, which needs every other signature in hand — so they are deferred to a pass of their own below. *) let untyped = ref [] in Hashtbl.reset char_consts; (* Enums come first, in a pass of their own: a signature below may name one, and [resolve] has to find it before it resolves that signature. *) List.iter (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defenum (n, members) -> let names = List.map fst members in if List.length (List.sort_uniq compare names) <> List.length names then fail d.Ast.dloc "%s declares the same member twice" n; Hashtbl.replace env.enums n members; Hashtbl.replace env.locs n d.Ast.dloc | _ -> ()) decls; (* Every type name is registered by here — structs, data types and unions by the names-first pass, aliases with them, enums by the pass just above — so this is the first point at which a [defn]'s parameter vector can be paired. It is done before the signature loop below rather than inside it, because a signature may name a type declared further down and pairing must not depend on the order the file was written in. *) let decls = pair_decls env decls in let decls = split_versions env decls in (* And for the same reason, at the same point: a three-element defonce is a type or a value by name, and every type name is registered by here. *) let decls = settle_defvars env decls in List.iter (fun (d : Ast.decl) -> let loc = d.Ast.dloc in match d.Ast.d with | Ast.Package _ -> () | Ast.Defenum _ -> () (* Imports are gone by now: [Load] resolved them into these very decls, so one reaching the checker is a driver that skipped that step. *) | Ast.Import (alias, _) -> fail loc "internal: the import of %s was not resolved before checking" alias (* [Shim.expand] rewrote every one of these into a [Declare] and a [Defn] before [collect] ran, so one arriving here is a driver that skipped that step. *) | Ast.DeclareC (fn, _) -> fail loc "internal: the declare-c of %s was not expanded before checking" fn.Ast.name | Ast.Declare (fn, csym) -> if Hashtbl.mem env.fns fn.Ast.name then fail loc "%s is declared twice" fn.Ast.name; let params = List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params in let ret = match fn.Ast.ret with None -> Types.Unit | Some t -> resolve env t in (* What may cross the boundary. A slice or a string goes as ptr+len, a scalar as itself; an aggregate does not go at all, because how one is passed differs per target and reproducing that here would be three calling conventions to maintain. Pass (Ptr T) instead and let the C shim dereference it — that is what the shim is for. *) let crossable what (t : Types.t) = match t with | Types.Int _ | Types.Float _ | Types.Bool | Types.Ptr _ | Types.Enum _ | Types.Unit -> () | Types.String | Types.Slice _ when what = "a parameter" -> () (* Its own arm, because the general advice below is wrong for it and dangerously so. A dyn is one machine word and would cross without complaint — [(Ptr dyn)] is not the fix and there is nothing for a shim to read: what the C side would receive is a word whose meaning only the dyn runtime knows, and C has no way to ask. Refused by name rather than let through as an integer. *) | Types.Dyn -> fail loc "%s of %s is dyn, which does not cross to C — take the value \ at a written type and pass that" what fn.Ast.name (* Its own arm too, because "pass (Ptr T)" is nonsense for a function and the real objection is worth stating. A [CFn] is one word and is the right *shape* for a C callback — that is what it is for — but a Flan function's emitted signature still ends with the transfer channel, and a C caller knows nothing about one. So the address is not a C function pointer yet, and what would make it one is dropping the channel from a signature that cannot transfer (TODO.org, "CFn and C's calling convention"). A [Fn] is two words and is not even the right shape. *) | Types.CFn _ | Types.Fn _ -> fail loc "%s of %s is %s, and a Flan function's address is not a C \ function pointer yet — not even a CFn's. Its signature ends \ with the transfer channel, and a C caller knows nothing \ about one; the C in CFn is about having no environment, \ which is what a C function pointer would need, and not about \ crossing today. Write the callback in C, or give the binding \ a (Ptr ()) and let the shim pass C's own" what fn.Ast.name (tyname loc t) | _ -> fail loc "%s of %s is %s, which cannot cross to C directly — pass \ (Ptr %s) and let the shim read it" what fn.Ast.name (tyname loc t) (tyname loc t) in List.iter (crossable "a parameter") params; crossable "the return type" ret; Hashtbl.replace env.fns fn.Ast.name (params, ret); 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 fail loc "%s declares the same field twice" n; (* The parent is recorded here and its shape checked once every struct has its fields, below, since it may be declared later. *) (match parent with | None -> Hashtbl.remove env.parents n | Some t -> (match resolve env t with | Types.Named pn when Hashtbl.mem env.structs pn -> if String.equal pn n then fail t.Ast.tloc "%s cannot be its own parent" n; Hashtbl.replace env.parents n pn | pt -> fail t.Ast.tloc "%s names %s as its parent, and a parent is a condition \ struct, such as Error, the root every error descends from" n (tyname loc pt))); let fields = List.map field fs in (* Recorded before the refusal below rather than after it, because the refusal asks [region_only], which walks this very declaration: a recursive value's field is a [(Vec Value)] and answering for it means reading [Value]'s own cases back out of the table. A [fail] aborts the whole compilation, so an entry left behind by a declaration that is about to be refused is never read. *) (* A dyn field used to be refused here, for the reason a condition's was: the collector's roots are the frames, and a struct outlives the frame that built it, so its dyn field was a live value reachable only through memory the marker never walked. The per-type descriptors lifted that. A struct that holds a dyn now gets a descriptor saying at which byte offsets its dyn words sit, and every slot, global and temporary that holds one goes on the collector's root stack with that descriptor beside it — see runtime/flan_dyn.h's [flan_dyn_root_push_desc], which is also where the reason no instance carries a header word is written down. What is still refused is a dyn the descriptor cannot reach: one inside a typed container, behind a pointer, or in a data type's payload, where the offset is not a static property of the type. That refusal is [hidden_dyn] below, and it is made over the whole program rather than here, because the type that hides it may be declared after the one that names it. *) Hashtbl.replace env.structs n { Tast.sname = n; fields }; (* A struct field may own storage. Since the repeal a struct holding a [(Vec i32)] is an ordinary value: assignment copies the header bytes, the copies alias one buffer, and freeing through two copies is the program's bug — Odin's contract, kept whole. The region rule is separate and survives on its own ground: a field whose container holds *owning* elements can only have been built against a region allocator — the guard at its construction is what makes sure of it (see [vec-new]) — so that graph is released by one [free-all] and no teardown recurses anywhere. *) | Ast.Defdata (n, vs) -> (* A data type with no cases has no value, so nothing could ever be given one, and a parameter of that type would be a function nothing can call. It parses; it is refused here rather than surviving to a layout with a tag and no case for the tag to name. *) if vs = [] then fail loc "%s declares no cases — a data type is (defdata %s [(Case [field \ Type ...]) ...])" n n; let cnames = List.map (fun (v : Ast.variant) -> v.Ast.vname) vs in if List.length (List.sort_uniq compare cnames) <> List.length cnames then fail loc "%s declares the same case twice" n; let cases_with_loc = List.map (fun (v : Ast.variant) -> let fnames = List.map (fun (f : Ast.field) -> f.Ast.fname) v.Ast.vfields in if List.length (List.sort_uniq compare fnames) <> List.length fnames then fail v.Ast.vloc "%s.%s declares the same field twice" n v.Ast.vname; let vfields = List.map field v.Ast.vfields in v.Ast.vloc, { Tast.vname = v.Ast.vname; vfields }) vs in let cases = List.map snd cases_with_loc in (* Registered before the field refusal below, not after, for the reason the struct's copy of this gives: [region_only] has to read this data type's own cases back out to answer for a [(Vec Value)] that names [Value]. The two declarations do this identically because a data type that could hold a container where a struct could not would be a hole in the same rule. *) Hashtbl.replace env.datas n { Tast.dname = n; cases }; (* A case's fields are a struct and may own storage, on the struct's terms since the repeal: copies alias, and the free is the program's to write. The region rule still applies on its own ground — a [(Vec Value)] case field can only have been built against a region, so the recursive dynamic value parses into an arena and one [free-all] releases the graph, no teardown anywhere. *) List.iter (fun (c : Tast.variant) -> Hashtbl.replace env.cases (n ^ "." ^ c.Tast.vname) (n, c); Hashtbl.replace env.cases c.Tast.vname (n, c)) cases (* Nothing records which member of a union is live, so nothing — the program included — can free the right one through the union itself. Since the repeal that is a fact about the value and not a refusal: a member may own storage, and freeing it is done through whatever tag the program keeps beside the union, as C does. *) | Ast.Defunion (n, ms) -> if ms = [] then fail loc "%s declares no members — a union is (defunion %s [member Type \ ...])" n n; let names = List.map (fun (f : Ast.field) -> f.Ast.fname) ms in if List.length (List.sort_uniq compare names) <> List.length names then fail loc "%s declares the same member twice" n; let fields = List.map field ms in Hashtbl.replace env.unions n { Tast.sname = n; fields } | Ast.Defn fn -> missing_return_type env fn; (* A signature that introduces a type variable is a *pattern*, not a 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, 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 about this definition and is refused at this definition. *) List.iter (fun (p : Ast.pred) -> if not (List.mem p.Ast.pname predicate_names) then Loc.failk "check/unknown-predicate" p.Ast.ploc "%s is not a type predicate. The ones there are: %s" p.Ast.pname (String.concat ", " predicate_names); if not (List.mem p.Ast.pvar vars) then Loc.failk "check/unbound-predicate-variable" p.Ast.ploc "$%s is not a type variable of %s%s" p.Ast.pvar fn.Ast.name (if vars = [] then " — it binds none" else " — it binds " ^ 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, 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 if fn.Ast.fprivate <> Ast.Exported then Hashtbl.replace env.privates fn.Ast.name (fn.Ast.nloc, fn.Ast.fprivate); if vars = [] then begin Option.iter (fun ret -> Hashtbl.replace env.fns fn.Ast.name (params, ret)) ret; Hashtbl.replace env.fparams fn.Ast.name fn.Ast.params; Hashtbl.replace env.fn_locs fn.Ast.name fn.Ast.nloc end 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.glens fn.Ast.name lens end | Ast.Defvar (n, t, _, k) -> let ty = match t with | Some t -> resolve env t | None -> fail loc "%s %s needs a type" (match k with Ast.Once -> "defonce" | Ast.Every -> "def") n in Hashtbl.replace env.globals n (ty, false); Hashtbl.replace global_forms n k; Hashtbl.replace env.global_locs n loc | Ast.Defconst (n, Some t, _) -> Hashtbl.replace env.globals n (resolve env t, true); Hashtbl.replace env.global_locs n loc | Ast.Defconst (n, None, v) -> (match v.Ast.e with | Ast.Byte b -> Hashtbl.replace char_consts n b | _ -> ()); defconst_type_shaped env n v; Hashtbl.replace env.global_locs n loc; untyped := (n, v) :: !untyped (* [Classes.expand] ran at the top of [build_program] and left none of these behind, the way [Shim.expand] leaves no [declare-c] behind. A driver that assembled a declaration list and skipped that pass would otherwise get a missing name from wherever the constructor was called, with nothing pointing here. *) | Ast.Defclass (n, _) -> fail loc "internal: the class %s reached the checker unpaired — \ pair_decls writes its constructor, and did not run" n | Ast.Defgeneric { Ast.name = n; _ } | Ast.Defmulti { Ast.name = n; _ } -> fail loc "internal: %s reached the checker unexpanded — Classes.expand did \ not run over this declaration list" n | Ast.Defmethod m -> fail loc "internal: a method of %s reached the checker unexpanded — \ Classes.expand did not run over this declaration list" m.Ast.mgen) decls; (* The untyped constants ([settle_consts]). One that calls a [_] function waits for [infer_returns], which needs every signature this pass registers; it is settled after that, and its refusal is the one a written return type would get. *) let inferred_names = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defn { Ast.name; ret = Some { Ast.t = Ast.Tinfer; _ }; _ } -> Some name | _ -> None) decls in let waits (_, v) = let acc = ref [] in Load.expr_uses acc v; List.exists (fun (n, _) -> List.mem n inferred_names) !acc in let late, now = List.partition waits (List.rev !untyped) in consts_after_infer := late; settle_consts env now; check_parents env; (* The paired declarations, handed back so that pass two checks the bodies of the same functions whose signatures this pass registered. Pairing needs the type names, which only this pass has; every pass after it needs the result, and a [defn] still carrying an unpaired vector would check as a function of no parameters at all. *) decls (* A type that contains itself by value has no finite size. [(Ptr T)] and a slice are indirections and break the cycle; a fixed array does not, because 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 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 (* No [bool] and no data type anywhere inside a union, at any depth — see the [Defunion] arm in [collect] for why an [i1] read out of a union is the one punning hazard Flan refuses rather than defines. It runs here, after [collect], because it has to look through a member's *struct* to reach the fields inside it and the struct table is only complete once every declaration has been walked. A union that contains itself is impossible by [check_finite] above, so the recursion terminates without a seen set — except through a [Ptr], which this does not follow: a bool behind a pointer is a bool in someone else's storage and is loaded from an address, not reinterpreted out of a blob. *) let check_union_members env = let rec walk uname where (t : Types.t) = match t with | Types.Bool -> fail (Option.value (Hashtbl.find_opt env.locs uname) ~default:Loc.unknown) "%s is a bool, and a union may not hold one at any depth — hold a u8 \ in the union and compare it yourself" where (* An [Option] is deliberately not on this list, and the difference is worth stating because a reader will ask. Its [match] lowers to a test of the tag byte and a branch, so a scribbled tag reads as a [Some] with a garbage payload — a number nobody stored, which is exactly what this language says a union read is. A data type's lowers to a chain of comparisons with an [unreachable] after the last one. *) | Types.Array (_, e) | Types.Option e -> walk uname where e | Types.Named n when Hashtbl.mem env.datas n -> fail (Option.value (Hashtbl.find_opt env.locs uname) ~default:Loc.unknown) "%s is %s, a data type, and a union may not hold one at any depth — \ hold the %s beside the union" where n n | Types.Named n -> (match Hashtbl.find_opt env.structs n with | Some st -> List.iter (fun (f : Tast.field) -> walk uname (where ^ "." ^ f.Tast.fname) f.Tast.fty) st.Tast.fields | None -> match Hashtbl.find_opt env.unions n with | None -> () | Some u -> List.iter (fun (f : Tast.field) -> walk uname (where ^ "." ^ f.Tast.fname) f.Tast.fty) u.Tast.fields) | _ -> () in Hashtbl.iter (fun n (u : Tast.structure) -> List.iter (fun (f : Tast.field) -> walk n (n ^ "'s member " ^ f.Tast.fname) f.Tast.fty) u.Tast.fields) env.unions (* ── Declarations: pass 2, check bodies ────────────────────────────── *) (* The names a body hands back or stores into: every name mentioned in a value it answers — its last form's tails, a [return]'s value — and the name at the root of every [set] place. A parameter among them is not warned at for growing: the grown copy goes back to the caller, or the copy is the function's own business. *) let escaping_names ~returns (body : Ast.expr list) : string list = let names = ref [] in let rec mentions (e : Ast.expr) = (match e.Ast.e with Ast.Var n -> names := n :: !names | _ -> ()); ignore (Ast.map_children (fun x -> mentions x; x) e) in let rec tails (e : Ast.expr) = match e.Ast.e with | Ast.Do es | Ast.Let (_, es) -> (match List.rev es with x :: _ -> tails x | [] -> ()) | Ast.If (_, a, b) -> tails a; Option.iter tails b | Ast.IfLet (_, a, b) -> (match List.rev a.Ast.body with x :: _ -> tails x | [] -> ()); Option.iter tails b | Ast.Chain (_, _, b) -> tails b | Ast.Match (_, arms) -> List.iter (fun (a : Ast.arm) -> match List.rev a.Ast.body with x :: _ -> tails x | [] -> ()) arms (* A value that is the parameter, a field of it, or a literal built with it. A call's result is its callee's business, and a unit form — the push itself, last in a function that returns nothing — answers nothing. *) | Ast.Var _ | Ast.Field _ | Ast.Struct _ | Ast.Bare _ | Ast.Arr _ | Ast.MapLit _ -> mentions e | _ -> () in let rec root (e : Ast.expr) = match e.Ast.e with | Ast.Var n -> names := n :: !names | Ast.Field (x, _) -> root x | Ast.Call ({ Ast.e = Ast.Var ("at" | "deref"); _ }, x :: _) -> root x | _ -> () in let rec walk (e : Ast.expr) = (match e.Ast.e with | Ast.Return (Some x) -> tails x | Ast.Set (Ast.Pvar n, _) -> names := n :: !names | Ast.Set ((Ast.Pfield (x, _) | Ast.Pindex (x, _) | Ast.Pderef x | Ast.Pslot (x, _)), _) -> root x | _ -> ()); ignore (Ast.map_children (fun x -> walk x; x) e) in List.iter walk body; if returns then (match List.rev body with x :: _ -> tails x | [] -> ()); !names let rec check_fn ?sign env (fn : Ast.fn) : Tast.fn = let params, ret = match sign with Some s -> s | None -> Hashtbl.find env.fns fn.Ast.name in (* A [_] body whose type could not be read stands in [fns] as Never (see [infer_returns]); pass two reads it the same way again, so its errors are reported here, once, with every other body's. *) let ret = match sign, fn.Ast.ret with | None, Some { Ast.t = Ast.Tinfer; _ } when Hashtbl.mem env.infer_failed fn.Ast.name -> infer_ret | _ -> ret in let ctx = { (invented_ctx env ret) with owner = fn.Ast.name } in let was_unnarrowable = !unnarrowable in unnarrowable := unnarrowable_in fn.Ast.fbody; Fun.protect ~finally:(fun () -> unnarrowable := was_unnarrowable) @@ fun () -> List.iter2 (fun (p : Ast.field) ty -> if List.mem_assoc p.Ast.fname ctx.scope then begin let first = List.find_opt (fun (q : Ast.field) -> q.Ast.fname = p.Ast.fname) fn.Ast.params in let notes = match first with | Some q when q != p -> [ Loc.note q.Ast.floc ("the first " ^ p.Ast.fname ^ " is here") ] | _ -> [] in Loc.failk "check/duplicate-parameter" p.Ast.floc ~notes "%s has two parameters named %s" fn.Ast.name p.Ast.fname end; ignore (bind ctx p.Ast.fname ty ~assignable:false)) fn.Ast.params params; let grow_before = !grow_warnings in let grow_saved = !grow_params in grow_params := ( ctx, List.filter_map (fun (p : Ast.field) -> Option.map (fun b -> (b.slot, p)) (List.assoc_opt p.Ast.fname ctx.scope)) fn.Ast.params ) :: grow_saved; let escaping = lazy (let names = escaping_names ~returns:(not (Types.equal ret Types.Unit)) fn.Ast.fbody in List.filter_map (fun (p : Ast.field) -> if List.mem p.Ast.fname names then Some p.Ast.floc else None) fn.Ast.params) in Fun.protect ~finally:(fun () -> grow_params := grow_saved; let added = List.filteri (fun i _ -> i < List.length !grow_warnings - List.length grow_before) !grow_warnings in if added <> [] then grow_warnings := List.filter (fun (d : Loc.diag) -> not (List.mem d.Loc.dloc (Lazy.force escaping))) added @ grow_before) @@ fun () -> let body = match fn.Ast.fbody with | [] -> if Types.equal ret Types.Unit || ret == infer_ret then [] else fail fn.Ast.nloc "%s returns %s but has no body" (written_name fn.Ast.name) (tyname fn.Ast.nloc ret) | body -> (* The last form is the return value, unless the function returns Unit, in which case whatever it evaluates to is discarded. *) let want = if Types.equal ret Types.Unit || ret == infer_ret then None else Some ret in (* Every form here is at the top level of the function body, so every one of them may carry a [defer] — and so may a form inside a [let] written here, which is what [ctx.defer_ok] carries down. [check] registers it and yields [unit]; the permission is granted again before each form because [check] withdraws it as it starts. A trailing [defer] is still a [defer] and not the return value, so the expectation is not put to it: it would only ever report [Unit] against the declared return type, which names the wrong problem. *) let is_defer (e : Ast.expr) = match e.Ast.e with Ast.Defer _ -> true | _ -> false in (* A dyn function whose value-giving form gives none — a [while], a [set] — reaches [box]'s unit refusal, which can only say that () is not a dyn value. Here the function is known, so the refusal is restated as what went wrong with it. Only a refusal at the body's own tail is: one deeper in the last form (a unit argument to a dyn parameter) is about that argument and keeps its own message. *) let rec tail_locs (e : Ast.expr) = e.Ast.loc :: (match e.Ast.e with | Ast.Do es | Ast.Let (_, es) -> (match List.rev es with x :: _ -> tail_locs x | [] -> []) | Ast.If (_, a, b) -> tail_locs a @ (match b with Some b -> tail_locs b | None -> []) | _ -> []) in let restate_unit last (d : Loc.diag) = let at (l : Loc.t) = l.Loc.file = d.Loc.dloc.Loc.file && l.Loc.line = d.Loc.dloc.Loc.line && l.Loc.col = d.Loc.dloc.Loc.col in if d.Loc.kind = "check/dyn-unit" && Types.equal ret Types.Dyn && List.exists at (tail_locs last) then Loc.diag ~kind:"check/dyn-unit" d.Loc.dloc (Printf.sprintf "%s is declared to return dyn, but the last form of its body \ gives no value. End the body with the value to return (nil \ for none), or declare %s to return nothing: %s" fn.Ast.name fn.Ast.name (if fln_source d.Loc.dloc then Printf.sprintf "fn %s(...) -> ()" fn.Ast.name else Printf.sprintf "(defn %s [...] () ...)" fn.Ast.name)) else d in (* The refusal arrives either raised or, under recovery, recorded on [env.recovered] while checking goes on; both are restated. *) let check_last last = let env = ctx.env in let before = env.recovered in let r = try check ctx ?want last with Loc.Error d -> Loc.raise_diag (restate_unit last d) in let rec fresh = function | l when l == before -> l | d :: rest -> restate_unit last d :: fresh rest | [] -> [] in env.recovered <- fresh env.recovered; r in let rec go = function | [ last ] -> ctx.defer_ok <- true; [ (if is_defer last then check ctx last else check_last last) ] | x :: rest -> ctx.defer_ok <- true; let x = check ctx x in x :: go rest | [] -> assert false in go body in (* Function exit runs the defers, innermost first. An explicit [return] ran its own (see [check]); this is the fall-off-the-end path. A trap does not run them — it is [noreturn] and then [unreachable] — and that is the same rule the bounds checks already follow. *) let body = let ends_never = match List.rev body with | (last : Tast.expr) :: _ -> Types.equal last.Tast.ty Types.Never | [] -> false in match ctx.defers with | [] -> body (* A body read only for its type is thrown away after. *) | _ when ret == infer_ret -> body (* A body that never falls off the end — its last form a [return], say — has no fall-off path to put the defers on, and a copy of them there is code after a terminator. *) | _ when ends_never -> body | ds when Types.equal ret Types.Unit -> body @ ds | ds -> (* The result is computed before the defers run and returned after, so it goes through a slot rather than staying the last form. *) let rec split = function | [ last ] -> ([], last) | x :: rest -> let (init, last) = split rest in (x :: init, last) | [] -> assert false in let init, last = split body in let s = fresh_slot ctx ret in let loc = last.Tast.loc in init @ [ mk loc ret (Tast.Let ([ (s, last) ], ds @ [ mk loc ret (Tast.Local s) ])) ] in (* The counter's zero, at the top of the body and above every store to it. Nothing else in the function reads the slot, so this is the whole of its cost on the path that never transfers. *) let body = match ctx.defer_slot with | None -> body | Some s -> defer_counter_zero s fn.Ast.nloc :: body in let checked = { Tast.name = fn.Ast.name; params; slots = Array.of_list (List.rev ctx.slot_tys); snames = Array.of_list (List.rev ctx.slot_names); as_slots = ctx.as_slots; (* The same defers again, for the transfer exit path §5 describes. The normal path has them spliced into [body] above; this one is guarded on the count, because a transfer can start above a defer that the text has not reached and cleanup over an unwritten binding is not cleanup. *) ret; body; fdefers = (match ctx.defer_slot with | None -> ctx.defers | Some s -> guarded_defers s ctx.defers); fenv = None; fparent = None; floc = fn.Ast.nloc } in let checked = if sign = None && ret == infer_ret then (* Pass two over a [_] body pass one could not read: its errors are raised above; a body that checks has the refusal pass one made about its exits, or waited on one that did, and stands as Never. *) match Hashtbl.find_opt env.infer_failed fn.Ast.name with | Some (Some d) -> raise (Loc.Error d) | _ -> { checked with Tast.ret = Types.Never } else checked in refuse_frame_escapes checked; checked (* The generic body, checked once with its variables abstract. Nothing is kept — the [Tast.fn] it produces is thrown away, and so is anything it lifted — because a generic function has no code: only its instantiations do. What is kept is the *refusal*: an operator an unconstrained variable does not support fails here, at the definition, naming the variable, rather than at whichever call site happened to instantiate it at a type that worked. The holes in it are real and are the report's business: [println] is plan.org's one compiler-provided exception and this pass rejects it. *) 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 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. *) env.tvpreds <- fn.Ast.fwhere; jreplace env.fns fn.Ast.name (params, ret); let finish () = jremove env.fns fn.Ast.name; env.lifted <- saved_lifted; env.tyvars <- saved_vars; env.tvpreds <- saved_preds; env.lenvars <- saved_lens; env.len_placeholder <- saved_ph in (match check_fn env fn with | _ -> finish () | exception e -> finish (); raise e) (* ── Return types read off the body ([_]) ──────────────────────────── Between the two passes: every written signature is in [fns], and a [defn] whose return slot is [_] gets its entry here, from its own body and nothing else — never a call site (docs/SPIKE-INFERENCE.md, "The cheap first step"). Its parameters are written, so the body checks exactly as it would with the type written, and the Tast is thrown away: pass two checks the body again against the type found, which is what keeps literals and [return]s coerced the way a written signature would coerce them. One such body may call another, so the bodies are read callees first and then to a fixpoint, the untyped-[defconst] loop's shape. A cycle among them never settles and is refused by name; a body that calls its own name is the cycle of one. *) (* The type one body gives, and the form that decided it. The exits — the last form and every [return], less what never arrives — meet at [arm_join], the function an [if]'s arms meet at, in any order: the typed ones decide and the lone literals take their type; literals alone meet at the wider of their own types. The body is then checked against that type exactly as a written one would be, so whatever [if] refuses between its arms is refused between exits, in the same words. None gives (); no value beside a value is refused, since () does not take a value's place. *) and read_return env (fn : Ast.fn) params = (* One check of the body against [ret], thrown away with everything it wrote into [env] ([snapshot_env]); pass two checks it again for real. *) let attempt ret = let undo, _ = snapshot_env env in let seen = !infer_seen in infer_seen := []; let restore () = undo (); infer_seen := seen in match speculate env (fun () -> check_fn ~sign:(params, ret) env fn) with | exception e -> restore (); raise e | tf -> let returns = List.rev !infer_seen in restore (); (tf, returns) in let tf, returns = attempt infer_ret in let last = match List.rev tf.Tast.body, List.rev fn.Ast.fbody with | (x : Tast.expr) :: _, (a : Ast.expr) :: _ -> [ (x.Tast.ty, x.Tast.loc, adapts a) ] | (x : Tast.expr) :: _, [] -> [ (x.Tast.ty, x.Tast.loc, false) ] | [], _ -> [] in let arrive = List.filter (fun (t, _, _) -> not (Types.equal t Types.Never)) (returns @ last) in let unit (t, _, _) = Types.equal t Types.Unit in (match List.find_opt unit arrive, List.find_opt (fun x -> not (unit x)) arrive with | Some (_, bare, _), Some (t, valued, _) -> Loc.failk "check/infer-mixed" bare ~notes:[ Loc.note valued ("this gives " ^ tyname valued t) ] "%s gives no value here and %s on another path, and its return \ type is read off its body. Give this path a value too, or write \ the return type" fn.Ast.name (tyname bare t) | _ -> ()); match arrive with | [] -> (Types.Unit, fn.Ast.nloc) | (t, l, _) :: rest when not (List.exists (fun (u, _, _) -> not (Types.equal t u)) rest) -> (t, l) | (t0, l0, _) :: _ -> (* Where no join exists the first typed exit's type is the one checked against, so the refusal is the one [if] gives its else arm. *) let meet ?(join = arm_join) = function | [] -> None | ((t, l, _) :: _) as xs -> let j = List.fold_left (fun acc (u, _, _) -> Option.bind acc (fun a -> join a u)) (Some t) xs in let at = match j with | Some j -> (match List.find_opt (fun (u, _, _) -> Types.equal u j) xs with | Some (_, l', _) -> l' | None -> l) | None -> l in Some (Option.value j ~default:t, at) in let decided = match meet (List.filter (fun (_, _, lit) -> not lit) arrive) with | Some d -> d | None -> (* Every exit a literal: they meet as two literals do. *) Option.value (meet ~join:literal_meet arrive) ~default:(t0, l0) in ignore (attempt (fst decided)); decided and infer_returns ~keep_going ?tolerate ?(previous = fun _ -> None) env (decls : Ast.decl list) = let pending = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defn ({ Ast.ret = Some { Ast.t = Ast.Tinfer; _ }; _ } as fn) when not (Hashtbl.mem env.gsigs fn.Ast.name) -> Some fn | _ -> None) decls in if pending <> [] then begin let names = List.map (fun (fn : Ast.fn) -> fn.Ast.name) pending in (* The other pending names each body mentions, with where. A local of the same name is counted too, which only matters once the fixpoint has stalled on a real error, and then only to pick which to show. *) let calls (fn : Ast.fn) = let acc = ref [] in List.iter (Load.expr_uses acc) fn.Ast.fbody; List.filter (fun (n, _) -> List.mem n names) (List.rev !acc) in let deps = List.map (fun (fn : Ast.fn) -> (fn.Ast.name, calls fn)) pending in let byname = List.map (fun (fn : Ast.fn) -> (fn.Ast.name, fn)) pending in (* Callees first, so a program with no cycle settles in one round. *) let order = let visited = Hashtbl.create 16 and out = ref [] in let rec visit n = if not (Hashtbl.mem visited n) then begin Hashtbl.replace visited n (); List.iter (fun (m, _) -> visit m) (List.assoc n deps); out := List.assoc n byname :: !out end in List.iter visit names; List.rev !out in let params_of (fn : Ast.fn) = List.map (fun (p : Ast.field) -> resolve env p.Ast.fty) fn.Ast.params in let settle (fn : Ast.fn) = let params = params_of fn in let ret, cause = read_return env fn params in Hashtbl.replace env.fns fn.Ast.name (params, ret); Hashtbl.replace env.inferred fn.Ast.name cause in (* A body [tolerate] excuses keeps the signature it was compiled with, [previous]'s, the way pass two keeps its compiled body: it is a stale caller, not a change. *) (* A body that fails for its own reasons is left to pass two, which reports its errors with every other body's. Until then it stands as Never, which fits anywhere, so its callers are not refused for its sake; a [_] body that calls it cannot be read either, and waits the same way. *) let failed = env.infer_failed in let fail_quietly ?refusal (fn : Ast.fn) = Hashtbl.replace failed fn.Ast.name refusal; Hashtbl.replace env.fns fn.Ast.name (params_of fn, Types.Never) in (* Only while every error is collected: a check that stops at the first reports this body's own, here. *) let excused (fn : Ast.fn) = match settle fn with | () -> () | exception (Loc.Error d as e) -> (match tolerate, previous fn.Ast.name with | Some ok, Some (params, ret) when ok env fn.Ast.name d -> Hashtbl.replace env.fns fn.Ast.name (params, ret) | _ -> if keep_going then fail_quietly ~refusal:d fn else raise e) in let rec rounds left = let still = List.filter (fun (fn : Ast.fn) -> if List.exists (fun (m, _) -> Hashtbl.mem failed m) (List.assoc fn.Ast.name deps) then begin fail_quietly fn; false end else match settle fn with | () -> false | exception Loc.Error _ -> true) left in if still <> [] && List.length still < List.length left then rounds still else still in (* A loop of [_] bodies that give no value on any way out — a countdown that calls itself — is (): each is read with the others taken as (), and kept only when every one of them gives () back. *) let units stuck = List.iter (fun (fn : Ast.fn) -> Hashtbl.replace env.fns fn.Ast.name (params_of fn, Types.Unit)) stuck; let all_unit = List.for_all (fun (fn : Ast.fn) -> match read_return env fn (params_of fn) with | t, cause when Types.equal t Types.Unit -> Hashtbl.replace env.inferred fn.Ast.name cause; true | _ -> false | exception Loc.Error _ -> false) stuck in if not all_unit then List.iter (fun (fn : Ast.fn) -> Hashtbl.remove env.fns fn.Ast.name; Hashtbl.remove env.inferred fn.Ast.name) stuck; all_unit in let rec stalled left = let stuck = rounds left in if stuck <> [] then refuse stuck and refuse stuck = let stuck_names = List.map (fun (fn : Ast.fn) -> fn.Ast.name) stuck in let waits n = List.filter (fun (m, _) -> List.mem m stuck_names) (List.assoc n deps) in (* One that waits on nothing else stuck failed on its own body: check it again, unswallowed, and its own error is the report. *) (match List.find_opt (fun n -> waits n = []) stuck_names with | Some n -> excused (List.assoc n byname); stalled (List.filter (fun (fn : Ast.fn) -> fn.Ast.name <> n) stuck) | None -> (* Every one waits on another, so following the first wait from any of them comes back round: that loop is the cycle. *) let rec walk path n = if List.mem n path then let rec from = function | m :: rest when m = n -> m :: rest | _ :: rest -> from rest | [] -> [] in from (List.rev path) else walk (n :: path) (fst (List.hd (waits n))) in let cycle = walk [] (List.hd stuck_names) in (* Told from the one written first, which is where a reader of the file meets the loop. *) let cycle = let index n = let rec at i = function | [] -> max_int | m :: rest -> if m = n then i else at (i + 1) rest in at 0 names in let start = List.fold_left (fun a n -> if index n < index a then n else a) (List.hd cycle) cycle in let rec rot = function | m :: rest when m <> start -> rot (rest @ [ m ]) | l -> l in rot cycle in if units (List.map (fun n -> List.assoc n byname) cycle) then stalled (List.filter (fun (fn : Ast.fn) -> not (List.mem fn.Ast.name cycle)) stuck) else let first = List.hd cycle in let fn = List.assoc first byname in let next i = List.nth cycle ((i + 1) mod List.length cycle) in let notes = List.mapi (fun i n -> let callee = next i in let at = List.assoc callee (waits n) in Loc.note at (if n = callee then n ^ " calls itself here" else Printf.sprintf "%s calls %s here" n callee)) cycle in (* Collected like any refusal when every error is: the loop's first member carries it into pass two, the rest stand quietly. *) match (match cycle with | [ n ] -> Loc.failk "check/infer-recursive" fn.Ast.nloc ~notes "%s calls itself, so its return type cannot be read off its \ body. Write the return type in its signature" n | _ -> Loc.failk "check/infer-recursive" fn.Ast.nloc ~notes "%s call each other (%s), so %s of their return types can \ be read off their bodies. Write the return type of one of \ them in its signature" (String.concat " and " cycle) (String.concat " → " (cycle @ [ first ])) (if List.length cycle = 2 then "neither" else "none")) with | () -> () | exception (Loc.Error d as e) -> if not keep_going then raise e; List.iter (fun n -> fail_quietly ?refusal:(if n = first then Some d else None) (List.assoc n byname)) cycle; stalled (List.filter (fun (fn : Ast.fn) -> not (List.mem fn.Ast.name cycle)) stuck)) in stalled order end (* The knot from [instantiate]: a call site makes a copy, and making one is checking a function. *) let () = check_fn_ref := check_fn (* A container's only compile-time *constant* is the zeroed one: a Vec's or a Map's real value exists at run time, behind an allocator. That fact has not changed. What changed is what follows from it. It used to follow that a container global could only ever start zeroed, and the argument was that there was nowhere for a computed initialiser to run: [Emit.const] said "there is no init-at-startup path, by design", and the backend that did run initialisers at startup ran them out of .init_array, which a reload module deliberately has none of. A rule that held on one backend and not the other would not be a rule, so the language refused the form on both. There is an init-at-startup path now, and it is the same one on both backends: a computed initialiser is lifted into a function of its own and the program calls it from [main], after the runtime is up and before any of the program's own code runs. So the premise is gone and the refusal goes with it. (defonce g (Vec u8) (slurp "level.edn")) is an ordinary program now, and it is the shape the author kept writing. What is still refused is [uninit] on one, and that is a different rule with a reason of its own: a Vec's garbage pointer is not a garbage number. Every operation on it dereferences a block address nobody wrote, where a zeroed Vec is a real empty Vec — null block, zero length, zero capacity — and is the value a program would have written anyway. What a runtime-loaded global is for has not changed either. The data is loaded once and it outlives main: a main that returns and is entered again finds the global exactly as it left it, because nothing between the two runs touches it — and that now includes a reload, which does not re-run initialisers. Assigning a second time overwrites the first block and leaks it — there is no [drop] and no cross-function flow analysis that could see the second assignment, so that is the manual-memory answer and the language's own: free is a thing you write. *) let rec zero_only (t : Types.t) = match t with | Types.Vec _ | Types.Map _ -> true | Types.Option e | Types.Array (_, e) -> zero_only e | _ -> false let container_global_init loc n (ty : Types.t) (init : Ast.init) = if zero_only ty then match init with | Ast.Uninit -> fail loc "the global %s is %s, and uninit on one is refused. Write (defonce \ %s %s) with no initialiser — a zeroed %s is an empty one" n (tyname loc ty) n (tyname loc ty) (tyname loc ty) | _ -> () (* A container global has to be a [defonce]. A [defconst] is not an assignable place — [check_place] refuses one by name — and a container's only constant is the zeroed one, so a constant Vec could only ever hold the empty value it was declared with: nothing could ever put the file's bytes in it. Refused here, where the fix is one keyword, rather than at the (set ...) that discovers it three forms later. *) let no_container_defconst loc n (ty : Types.t) = if zero_only ty then fail loc "the global %s is %s, and a %s global is a defonce, not a defconst — a \ defconst would stay the empty %s it was declared as. Write (defonce %s \ %s) and fill it in a function" n (tyname loc ty) (tyname loc ty) (tyname loc ty) n (tyname loc ty) (* A union member written into a *constant* would have to be encoded into the blob at link time, which is the byte-level encoder a data type case does not have either: a constant is what the linker writes, and a union value is a store. Refused here, where the message can name the way through, rather than at the emitter as "this one is computed", which is true and says nothing. A defonce is no longer any of this and no longer asks. Its computed initialiser is lifted into a function that runs at startup, so the member is written by exactly the store that writes one anywhere else — the encoder was only ever needed because there was nothing to run. A zeroed union needs none of this either and is the ordinary declaration. *) let no_union_const env loc n (v : Tast.expr) = match v.Tast.ty, v.Tast.e with (* The all-bytes-zero value is a constant and needs none of this, so it is the one initialiser that goes through — which is what makes (U {}) and a declaration with no value the same thing here as everywhere else. *) | _, (Tast.Zero _ | Tast.Uninit _) -> () | Types.Named un, _ when Hashtbl.mem env.unions un -> fail loc "the constant %s is the union %s, and a union member cannot be written \ into a constant. Leave it zeroed, or make it a defonce" n un | _ -> () (* A defconst's value is what the linker writes into the program's image, so it has to be a value the linker can write: a literal, a zero, an aggregate of those — [Tast.const_init]'s set, which is [Emit.const]'s accepted set asked as a question. The integer arithmetic a defconst is allowed to be written as is already gone by here: [collect]'s folding pass turned [(/ screen-height cell-size)] into its answer before any type resolved, so what arrives here is an [Int] and passes. The author's rule, 2026-09-20: "defconst should not be computed, it's the equivalent to a compiler const." Refused here rather than in a backend because a backend can only refuse the program it is asked to emit, and the two were not asking the same question — [Emit.const] refused a computed defconst by name while the x86 backend ran it through the startup function behind an [.init~once.] flag, like a defonce. One refusal in the checker is the same program refused the same way on both, and it is the only place that can say what to do instead. A data type case says it with its own message, which is the one thing a reader could not work out from "this is computed": the case would have to be serialised into the payload blob, and that is an encoder rather than an order of operations. It is searched for the way [Emit.const] used to find it — down through the aggregates, because a case inside a struct literal is the same unwritable value as a case on its own, and [(defconst g S (S {.u (U.B {.x 1})}))] told about "computed" would be advice nobody could follow. Left to right and stopping at the first value the image cannot hold, which is [Emit.const]'s own order: it spelled the fields in order and failed at the one it could not spell. So a computed field written before a case field is still the general message, because that is the field a reader meets first. *) (* The first subexpression a constant image has no value for, descending through the aggregates whose parts are themselves constants. [None] is a value the linker can write, which is [Tast.const_init] arrived at from the other side — the two walk the same nodes, and this one keeps the offender rather than the verdict. *) let rec unwritable (e : Tast.expr) = match e.Tast.e with | Tast.Int _ | Tast.Float _ | Tast.Bool _ | Tast.Str _ | Tast.Unit | Tast.Zero _ | Tast.Uninit _ | Tast.None_ -> None | Tast.Make (_, es) | Tast.Arr es -> List.find_map unwritable es | Tast.Some_ v -> unwritable v | _ -> Some e let const_defconst_init env loc n (v : Tast.expr) = match unwritable v with | None -> () | Some { Tast.e = Tast.MakeCase (dname, case, _); _ } -> fail loc "a constant cannot be %s.%s. Make it a defonce, or declare it zeroed, \ which is %s.%s" dname case dname (match Hashtbl.find_opt env.datas dname with | Some { Tast.cases = c :: _; _ } -> c.Tast.vname | _ -> "its first case") | Some _ -> fail loc "a constant's value must be a compile-time constant — the constant %s \ is computed. A defonce may have a computed initialiser, because it runs \ at startup and stores the result; a defconst is what the linker writes \ into the image and has nowhere to run. Write (defonce %s ...), or give \ the constant a literal — integer constants may also be written as \ arithmetic over literals and other constants, which is folded here" n n (* A global's initialiser runs at startup: from [main], after the runtime is up, before a line of the program's own code. Nothing has established a handler or a restart by then, and nothing outside the initialiser can — the program has not started. That used to be the reason all four of the condition forms were refused inside one, and the refusal lived in [x86.ml] because that was the only backend with an init-at-startup path. Its argument was that a transfer out of an initialiser would return into the loader, which was true of a .init_array constructor and is not true of a call from [main]. So the rule is narrower now, and what is left of it is what is still true. A [handler-bind] or a [restart-case] *inside* an initialiser is ordinary code: it pushes its frames, runs, and pops them, all before the initialiser returns, and nothing it does is visible outside. Both backends run it exactly as they run it in any other function — which is what makes (defonce data (Vec u8) (slurp "level.edn")) an ordinary program, since [slurp] is a restart-case with its own signal inside it, and that is the shape the author kept reaching for. What is refused is a [signal] or an [invoke-restart] with no condition machinery around it at all. Everywhere else in the language those two are answered by a frame some *caller* established; in an initialiser there is no caller, so one with nothing around it is inert by construction — a signal nothing can hear, or an invoke-restart that can only fail at the invoke site. Either form counts as enclosure, including a restart-case around a signal: that pair is [slurp], and a restart-case says what the initialiser wants to happen when nobody answers, which is the thing an unenclosed one cannot say. A clause's body is not in this walk at all — a handler-bind clause is lifted into a function of its own — so the [invoke-restart] a handler writes is never the one refused here. *) let no_transfer_in_init n (v : Tast.expr) = (* The nodes that are under a handler or a restart within this initialiser, by identity: [Tast.walk] visits nodes rather than paths, so the enclosure is recorded in one pass and asked in the next. *) let covered = ref [] in Tast.walk (fun (e : Tast.expr) -> let cover body = List.iter (Tast.walk (fun x -> covered := x :: !covered)) body in match e.Tast.e with | Tast.Handled (_, body) -> cover body | Tast.RestartCase (cs, body) -> cover [ body ]; List.iter (fun (c : Tast.rclause) -> cover c.Tast.rbody) cs | _ -> ()) v; Tast.walk (fun (e : Tast.expr) -> let bad what can = fail e.Tast.loc "%s in the initialiser of the global %s, with no handler-bind or \ restart-case around it, can only %s. Write one inside the \ initialiser, or move the whole thing into a function" what n can in if List.memq e !covered then () else match e.Tast.e with | Tast.Signal _ -> bad "signal" "go unheard" | Tast.InvokeRestart _ -> bad "invoke-restart" "fail at the invoke site" | _ -> ()) v (* A computed initialiser, lifted into a function of its own that returns the value. The global's initialiser becomes the call, which is the whole of what the backends had to learn: one of them already lowers an initialiser as ordinary code and now lowers a call, and the other emits the global zeroed and stores the call's result at startup. A function rather than the expression left in place, for a reason that is not tidiness: an initialiser can contain a [let], and a [let] needs a frame. The slots were allocated on a context this function discarded, so what the backend got was a slot index into a frame of size zero — [(defonce c i64 (let [x (i64 5)] (+ x 1)))] crashed the x86 backend with an out-of-bounds index, and there was no frame to give it without inventing one. This is that frame, and it is the one every other body already has. [fparent] is the global rather than a function, which is a small widening of what the field means: nobody wrote this name, so completing it or jumping to it is meaningless, and the one reader that asks — [Dev]'s [defs] — wants exactly that answer. The others are unaffected: a whole-program build emits a cell for every function it emits, and a redefinition module reaches this one through neither, because a reload does not run initialisers. *) let lift_ginit ctx loc n ty (v : Tast.expr) = no_transfer_in_init n v; let fname = "global/" ^ n in ctx.env.lifted <- { Tast.name = fname; params = []; slots = Array.of_list (List.rev ctx.slot_tys); snames = Array.of_list (List.rev ctx.slot_names); as_slots = ctx.as_slots; (* An initialiser is a nested form as far as [defer_ok] is concerned, so nothing can register one here and both of these are empty. Written the same way [check_fn] writes them anyway, so that the day the rule widens this does not quietly become the one exit path that runs a defer nobody reached. *) ret = ty; body = (match ctx.defer_slot with | None -> [ v ] | Some s -> [ defer_counter_zero s loc; v ]); fdefers = (match ctx.defer_slot with | None -> ctx.defers | Some s -> guarded_defers s ctx.defers); fenv = None; fparent = Some n; floc = loc } :: ctx.env.lifted; { Tast.e = Tast.Call (fname, []); ty; loc } let check_global env (d : Ast.decl) : Tast.global option = let ctx () = invented_ctx env Types.Unit in match d.Ast.d with | Ast.Defvar (n, _, init, kind) -> let ty, _ = Hashtbl.find env.globals n in no_zeroed_fn d.Ast.dloc (Printf.sprintf "the global %s" n) ty; container_global_init d.Ast.dloc n ty init; (* A [def]'s initialiser is lifted into [global/] whatever it is — a zero, a literal, a computed expression — where a [defonce]'s is lifted only when it is computed. The lifting is what makes the form's promise reachable: the host's startup function calls the initialiser through its function cell, so a re-evaluated [def] swaps the cell and the next re-run stores the *edited* value. A constant left inline would be baked into the host's startup body, and every re-run would paint the stale value back. The same lifted function is what [Session.eval]'s store thunk calls to assign the new value straight away, which is the other half of what [defparameter] means. [uninit] is the one exception on both forms: there is nothing to run, so there is nothing to lift. *) let lift_always = (match kind with Ast.Once -> false | Ast.Every -> true) in let ginit = match init with | Ast.Zeroed when lift_always -> let c = ctx () in lift_ginit c d.Ast.dloc n ty { Tast.e = Tast.Zero ty; ty; loc = d.Ast.dloc } | Ast.Zeroed -> { Tast.e = Tast.Zero ty; ty; loc = d.Ast.dloc } | Ast.Uninit -> (* Everywhere else [uninit] is an opt-out from ZII and the bytes are whatever they were: a garbage f64 is a garbage number. A data type is the one type where that is qualitatively worse — the tag steers control flow, a tag no case names falls past every comparison in a [match], and the block after them is [unreachable], which LLVM is entitled to assume cannot happen. So the one place where garbage becomes "the optimiser may do anything" is refused by name, and the zeroed form, which is the first declared case, is named beside it. *) (match ty with | Types.Named un when Hashtbl.mem env.datas un -> fail d.Ast.dloc "%s is a data type, and uninit on one is refused. Drop the \ uninit — a zeroed %s is %s" (tyname d.Ast.dloc ty) un (match Hashtbl.find_opt env.datas un with | Some { Tast.cases = c :: _; _ } -> un ^ "." ^ c.Tast.vname | _ -> "its first case") | _ -> ()); { Tast.e = Tast.Uninit ty; ty; loc = d.Ast.dloc } | Ast.Init v -> let c = ctx () in (match v.Ast.e with | Ast.UInt (_, s) when ty = Types.Dyn -> Loc.failk literal_at_want v.Ast.loc "%s. Give %s the type u64" (wide_at_dyn s) n | _ -> ()); let v = view_global_init := Some (n, kind); Fun.protect ~finally:(fun () -> view_global_init := None) (fun () -> check c ~want:ty v) in if Tast.const_init v && not lift_always then v else lift_ginit c d.Ast.dloc n ty v (* [settle_defvars] turned every one of these into a [Zeroed] or an [Init] during [collect], and this pass runs over the list that pass handed back. One arriving here is a driver that checked a global without collecting first. *) | Ast.Ambiguous _ -> fail d.Ast.dloc "internal: the third element of (%s %s ...) was never decided" (match kind with Ast.Once -> "defonce" | Ast.Every -> "def") n in Some { Tast.gname = n; gty = ty; ginit; gconst = false; gfolded = false; grerun = (match kind with Ast.Once -> false | Ast.Every -> true) } | Ast.Defconst (n, _, v) -> let ty, _ = Hashtbl.find env.globals n in no_zeroed_fn d.Ast.dloc (Printf.sprintf "the global %s" n) ty; no_container_defconst d.Ast.dloc n ty; (* [collect] already folded the integer constants, because an array length has to be known before any type resolves. Use that value here rather than the expression it came from: a global's initialiser has to be a compile-time constant, and [(/ screen-height cell-size)] is one — the folding pass is the only thing that knows it. *) (* A folded conversion is still a value of the type it converts to. *) (match v.Ast.e, ty with | Ast.Call ({ Ast.e = Ast.Var c; _ }, [ _ ]), Types.Int kind when (match Types.ikind_of_name c with | Some k -> k <> kind && not (Types.widens_to ~from:(Types.Int k) ~into:(Types.Int kind)) | None -> false) -> fail v.Ast.loc "expected %s, found %s" (Types.ikind_name kind) c | _ -> ()); let ginit = match Hashtbl.find_opt env.consts n, ty with | Some k, Types.Int kind -> (* Still range-checked: this path skips [check], and [in_range] is the only thing that rejects 300 as a u8. *) { Tast.e = Tast.Int (in_range ~pattern:(match v.Ast.e with Ast.Int _ -> false | _ -> true) v.Ast.loc kind k, kind); ty; loc = d.Ast.dloc } | _ -> with_typed_literals (fun () -> check (ctx ()) ~want:ty v) in no_union_const env d.Ast.dloc n ginit; (* After the union's own refusal, so a computed union member keeps the message that names its way through rather than the general one. *) const_defconst_init env d.Ast.dloc n ginit; (* [env.consts] holds exactly the constants the folding pass consumed, so membership is the question "is this value in the program's shape?" *) Some { Tast.gname = n; gty = ty; ginit; gconst = true; gfolded = Hashtbl.mem env.consts n; grerun = false } | _ -> None (* The entry point, plan.org: (defn main [args [string]] i32), with both the parameter and the return type optional. *) (* Where [main] was written. [env.locs] is the table of where each *type* was declared — [collect] fills it for structs, data types, unions and enums and for nothing else — so a function's own location is not in it and the [find_opt] idiom the rest of this file uses does not apply here. The declaration list does have it, and the caller is holding the list anyway. Without this both refusals below opened with :0:0, which tells a reader that a rule exists and not where they broke it, and gives [next-error] nothing to jump to. A [main] that arrived some other way — a [declare], say — still has no [defn] to point at, so that case keeps the unknown span rather than inventing one. *) let main_loc (decls : Ast.decl list) = let is_main (d : Ast.decl) = match d.Ast.d with Ast.Defn fn -> fn.Ast.name = "main" | _ -> false in match List.find_opt is_main decls with | Some { Ast.d = Ast.Defn fn; _ } -> fn.Ast.nloc | _ -> Loc.unknown let check_main env decls = let at = main_loc decls in match Hashtbl.find_opt env.fns "main" with | None -> () (* a library, or a file being checked on its own *) | Some (params, ret) -> let ok_params = match params with | [] -> true | [ Types.Slice (_, Types.String) ] -> true | _ -> false in if not ok_params then fail at "main takes no parameters or one [str], not (%s)" (String.concat (if Source.indented_at at then ", " else " ") (List.map (tyname at) params)); if not (Types.equal ret Types.Unit || Types.equal ret (Types.Int Types.I32)) then fail at "main returns i32 or nothing, not %s" (tyname at ret) (* The environment as well as the program. A session needs it to check an expression typed at a REPL against the program the process is running — and it has to be this one rather than anything rebuilt from declarations, because [program] prepends the prelude and no accumulated AST contains it. *) (* Separate entry points below rather than a flag on the one the session calls, for the reason [Parse] gives at the same fork: [Loc.Errors] is a second exception that the session and the daemon do not catch, so the guarantee that they never see one should be structural and not a default argument. *) (* ── The order the initialisers run in ─────────────────────────────── *) (* Declaration order is the order a program's globals are started in, and it is the wrong one as soon as one of them is computed from another: [(defonce b i64 (+ a 10))] written above [(defonce a i64 (+ 1 2))] read a zero and answered 10 without saying anything. So the computed ones are sorted by what they need, which is what Odin does (src/checker.cpp, [calculate_global_init_order]) and for the same reason — the alternative is a rule about where in the file a global has to be written, which is a rule about text rather than about meaning. Only the computed globals are sorted, and only against each other. A constant initialiser cannot read a global at all — [Tast.const_init]'s accepted set has no [Global] in it — so a constant is already there before anything runs: it is in the object image on one backend and written from .init_array before main on the other. That makes the partition total and the sort small, and it is why a global initialised from a [defconst] needs no edge. The dependency is transitive through calls, not just through what the initialiser names: [(defonce a i64 (f))] where [f] reads [b] needs [b] started first, and an analysis that only looked at the initialiser's own text would order that pair by luck. Odin's graph is transitive for the same reason. A cycle is refused rather than broken. Some global in it would have to be started from another's zero, and which one that is cannot be read off the program — the two spellings of the same cycle would differ only in which line the compiler happened to reach first. *) let init_order (globals : Tast.global list) (fns : Tast.fn list) = let computed = List.filter (fun (g : Tast.global) -> not (Tast.const_init g.Tast.ginit)) globals in if computed = [] then globals else begin let is_computed = Hashtbl.create 8 in List.iter (fun (g : Tast.global) -> Hashtbl.replace is_computed g.Tast.gname ()) computed; let ftbl = Hashtbl.create 64 in List.iter (fun (f : Tast.fn) -> Hashtbl.replace ftbl f.Tast.name f) fns; (* What each function reads, to a fixpoint over the call graph: its own references, plus everything its callees read. A round that changes nothing is the answer, which needs no special case for a recursive function and no visited set to get wrong. *) let reads = Hashtbl.create 64 in let calls = Hashtbl.create 64 in let add tbl k v = let cur = try Hashtbl.find tbl k with Not_found -> [] in if not (List.mem v cur) then Hashtbl.replace tbl k (v :: cur) in List.iter (fun (f : Tast.fn) -> let note n = if Hashtbl.mem is_computed n then add reads f.Tast.name n else if Hashtbl.mem ftbl n then add calls f.Tast.name n in List.iter (Reach.expr_refs note) f.Tast.body; List.iter (Reach.expr_refs note) f.Tast.fdefers) fns; let changed = ref true in while !changed do changed := false; Hashtbl.iter (fun caller callees -> List.iter (fun callee -> List.iter (fun g -> let cur = try Hashtbl.find reads caller with Not_found -> [] in if not (List.mem g cur) then begin Hashtbl.replace reads caller (g :: cur); changed := true end) (try Hashtbl.find reads callee with Not_found -> [])) callees) (Hashtbl.copy calls) done; (* And what each computed global needs, which is the same walk over its initialiser — whose one node is a call to the function the initialiser was lifted into, so the answer is that function's reads. *) let needs (g : Tast.global) = let acc = ref [] in let note n = let put r = if not (List.mem r !acc) then acc := r :: !acc in if Hashtbl.mem is_computed n then put n else List.iter put (try Hashtbl.find reads n with Not_found -> []) in Reach.expr_refs note g.Tast.ginit; if List.mem g.Tast.gname !acc then fail g.Tast.ginit.Tast.loc "the global %s is initialised from itself — leave it zeroed and \ load it in a function" g.Tast.gname; !acc in let deps = List.map (fun (g : Tast.global) -> (g.Tast.gname, needs g)) computed in let deps_of n = try List.assoc n deps with Not_found -> [] in (* Kahn's, in declaration order: of the globals that are ready, the one written first goes first, so the emitted order is the source's wherever the source's order was possible at all. *) let done_ = Hashtbl.create 8 in let order = ref [] in let progress = ref true in while !progress do progress := false; List.iter (fun (g : Tast.global) -> if not (Hashtbl.mem done_ g.Tast.gname) && List.for_all (fun d -> Hashtbl.mem done_ d) (deps_of g.Tast.gname) then begin Hashtbl.replace done_ g.Tast.gname (); order := g :: !order; progress := true end) computed done; (match List.filter (fun (g : Tast.global) -> not (Hashtbl.mem done_ g.Tast.gname)) computed with | [] -> () | (g : Tast.global) :: _ -> (* The whole ring, not one name out of it. A cycle is a fact about a set of globals and a message naming one of them leaves the reader to find the rest; naming each edge says which read to break. *) let stuck n = not (Hashtbl.mem done_ n) && List.mem_assoc n deps in let rec ring path n = if List.mem n path then let rec cut = function | [] -> [] | x :: r -> if String.equal x n then x :: r else cut r in cut path else match List.find_opt stuck (deps_of n) with | None -> path @ [ n ] | Some d -> ring (path @ [ n ]) d in let r = ring [] g.Tast.gname in let edges = List.mapi (fun i n -> Printf.sprintf "%s needs %s's value" n (List.nth r ((i + 1) mod List.length r))) r in fail g.Tast.ginit.Tast.loc "the globals %s initialise each other: %s. Leave one zeroed and load \ it in a function" (String.concat " and " r) (String.concat ", " edges)); (* The sorted sequence, dropped back into the slots the computed globals already occupied. Everything else — a constant, a zeroed container — stays exactly where it was declared, so a diff of the emitted image shows the reordering and nothing else. *) let seq = ref (List.rev !order) in List.map (fun (g : Tast.global) -> if Hashtbl.mem is_computed g.Tast.gname then match !seq with | x :: rest -> seq := rest; x | [] -> g else g) globals end (* ── What a per-type descriptor can reach ─────────────────────────────── * * The struct dyn field is no longer refused: a type that holds dyn words at * static offsets gets a descriptor naming those offsets, and every place a * value of it can live — a frame slot, a global, a temporary a call answered * with — goes on the collector's root stack with that descriptor beside it. * runtime/flan_dyn.h's [flan_dyn_root_push_desc] is where the whole of that * argument is written, including why no instance carries a header word. * * What a static offset cannot express is what is left, and it is refused here * rather than emitted as a descriptor that quietly omits a field: * * - a dyn inside a typed container. A [(Vec S)] holds its elements in * allocator memory of a length nothing static knows, so the dyn words of * one are not a list of offsets. The M2 queue's item 3 is the * descriptor that can say it — pointer, length and element type — and it is * a different shape from this one, deliberately. A [(Map K V)] is the same * fact twice over. * - a dyn in a data type's payload. The cases overlay one another, so which * words are dyn depends on the tag, which is a run-time question. The same * goes for a C union's members. * - a dyn inside an [(Option T)], whose payload exists only under the tag: the * words of a [None] are zero and marking them is harmless, but that is a * fact about how this compiler happens to build one and not something the * type says, and a descriptor that relied on it would be relying on it * silently. * * A [(Ptr S)] and a [[S]] are deliberately *not* on that list, and the reason * is worth stating because it looks like an omission. Neither owns storage. * The only storage this compiler hands out for a type that holds dyn is a * frame slot, a global, or a fixed array inside one of those — and all three * are rooted with their descriptor already, so a pointer or a slice into one * addresses bytes the collector is marking. That is what makes a condition's * payload work at all: a handler clause is lifted to a function taking a * [(Ptr Cond)], and the value it points at is in the signalling frame with a * descriptor beside it. Storage that came from C is the program's business the * way every other pointer from C is. * * And one cap, which is not a representation question but an arithmetic one: * the offsets of a fixed array are flattened one element at a time, so an * array of a million structs would be a million-word table in .rodata. The * repeat form that avoids it is item 3's machinery, so this says so instead of * building half of it. *) let desc_offsets_max = 4096 (* Is there a dyn in the storage a value of this type *is*, which is not the same as whether its printed form mentions dyn anywhere. A pointer and a slice are stopped at, because what they address is somebody else's storage and is rooted where it was declared. That is the same line [hidden_dyn] takes for a bare [(Ptr S)], and taking it here as well is what lets [(Vec (Ptr Cond))] be written — a vector of pointers to condition structs holds no dyn words of its own, and refusing it with a sentence about the dyn inside it was wrong twice over. *) let rec dyn_reach ~through p seen (t : Types.t) = let go = dyn_reach ~through p seen in match t with | Types.Dyn -> true | Types.Array (_, e) | Types.Vec e | Types.Option e -> go e | Types.Map (k, v) -> go k || go v | Types.Ptr (_, e) | Types.Slice (_, e) -> through && go e | Types.Fn _ -> false | Types.Named n when not (List.mem n seen) -> let seen = n :: seen in let field (fl : Tast.field) = dyn_reach ~through p seen fl.Tast.fty in (match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n) p.Tast.structs with | Some s -> List.exists field s.Tast.fields | None -> match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n) p.Tast.datas with | Some u -> List.exists (fun (c : Tast.variant) -> List.exists field c.Tast.vfields) u.Tast.cases | None -> match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n) p.Tast.unions with | Some u -> List.exists field u.Tast.fields | None -> false) | _ -> false let dyn_anywhere p seen t = dyn_reach ~through:false p seen t (* The other question, and it is a different one: is there a dyn reachable from here *at all*, pointers and slices followed. Only the foreign boundary asks it, and it has to — the storage on the far side of a pointer is rooted where it was declared when the declaration was Flan's, and is rooted nowhere at all when it was C's. Keeping the two apart is the whole of the fix: the narrowing above is right for a Flan type, and reusing it at the boundary made [(Ptr (Ptr S))] and [(Ptr [S])] answer no. *) let dyn_through p seen t = dyn_reach ~through:true p seen t (* Is a dyn reachable from here only by going through a pointer or a slice. This is the parameter question. Flan supplies the storage one level down from a foreign parameter — it passes the address of a place, and a place is a frame slot, a global or an array inside one, all of them rooted with their descriptor — so a [(Ptr S)] parameter is an ordinary borrow and stays writable. What is *below* that level is C's, and a pointer or a slice found there is a hop into storage nothing rooted. *) let rec dyn_behind_pointer p seen (t : Types.t) = let go = dyn_behind_pointer p seen in match t with (* The crossing, and the [seen] set does *not* travel across it. The two walks ask different questions — this one does not count a direct dyn, the one below it does — so a name already visited on the way here would be pruned from a question it was never asked. That is not a nicety: a struct with a pointer to itself and a dyn field is exactly the shape that hits it, and [(defstruct Node [next (Ptr Node) x dyn])] at [(Ptr Node)] was accepted while the same thing unrolled into two types was refused. C hung a node off [next], put a dyn in it, and the collector freed it — which is the one failure this whole boundary exists to prevent. It still terminates. This walk's own [seen] guards its own [Named] recursion, and each crossing starts a separate finite walk of its own. *) | Types.Ptr (_, e) | Types.Slice (_, e) -> dyn_through p [] e | Types.Array (_, e) | Types.Vec e | Types.Option e -> go e | Types.Map (k, v) -> go k || go v | Types.Dyn | Types.Fn _ -> false | Types.Named n when not (List.mem n seen) -> let seen = n :: seen in let field (fl : Tast.field) = dyn_behind_pointer p seen fl.Tast.fty in (match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n) p.Tast.structs with | Some s -> List.exists field s.Tast.fields | None -> match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n) p.Tast.datas with | Some u -> List.exists (fun (c : Tast.variant) -> List.exists field c.Tast.vfields) u.Tast.cases | None -> match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n) p.Tast.unions with | Some u -> List.exists field u.Tast.fields | None -> false) | _ -> false (* How many dyn words a descriptor for this type would name, which is what the cap above is about. Only the by-value shapes contribute; the rest are refused by [hidden_dyn] before this number matters. *) (* Saturated at one past the cap, because the number only ever has to be compared with it. That is not tidiness: [(defonce big [4611686018427387904 S])] is a length an [Int64.to_int] multiplication wraps *negative* on, so an honest product made the test [n > desc_offsets_max] false, the declaration was accepted, and the emitter then sat building the offset list until something killed it. A refusal that overflows into an acceptance is worse than no refusal. Every arm below stays at or under [desc_offsets_max + 1], so nothing here can multiply two numbers large enough to wrap. *) let sat n = if n > desc_offsets_max then desc_offsets_max + 1 else n let rec dyn_words p seen (t : Types.t) = match t with | Types.Dyn -> 1 | Types.Array (n, e) -> let w = dyn_words p seen e in (* Out of range in either direction saturates. A negative length is nonsense and the layout refuses it further down, but this arm has to answer *something*, and the one thing it must not answer is a small number: [Int64.to_int (-1L) * w] is negative, which reads as under the cap and is how the overflow above got through in the first place. *) if w = 0 then 0 else if Int64.compare n 0L < 0 || Int64.compare n (Int64.of_int (desc_offsets_max + 1)) > 0 then desc_offsets_max + 1 else sat (Int64.to_int n * w) | Types.Named nm when not (List.mem nm seen) -> (match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = nm) p.Tast.structs with | Some s -> List.fold_left (fun acc (fl : Tast.field) -> sat (acc + dyn_words p (nm :: seen) fl.Tast.fty)) 0 s.Tast.fields | None -> 0) | _ -> 0 (* The first place under this type where a dyn sits that no descriptor reaches, as the type to name in the refusal. *) let rec hidden_dyn p seen (t : Types.t) : Types.t option = let under e = if dyn_anywhere p seen e then Some t else None in match t with | Types.Dyn -> None | Types.Array (_, e) -> hidden_dyn p seen e | Types.Vec e | Types.Option e -> under e (* A Map's values are walked through the value type's own descriptor, so a dyn there is found wherever that descriptor finds one. A key never holds one: dyn is not a key type. *) | Types.Map (k, v) -> if dyn_anywhere p seen k then Some t else hidden_dyn p seen v (* A pointer and a slice are views of storage something else roots; see the note above. What they point at is checked where it is declared. *) | Types.Ptr (_, e) | Types.Slice (_, e) -> hidden_dyn p seen e | Types.Fn _ -> None | Types.Named n when not (List.mem n seen) -> let seen = n :: seen in (match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n) p.Tast.structs with | Some s -> List.fold_left (fun acc (fl : Tast.field) -> match acc with | Some _ -> acc | None -> hidden_dyn p seen fl.Tast.fty) None s.Tast.fields | None -> (* A data type's payload and a union's members both overlay, so any dyn in one is hidden by the type itself and not by a member of it. *) match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n) p.Tast.datas with | Some u -> if List.exists (fun (c : Tast.variant) -> List.exists (fun (fl : Tast.field) -> dyn_anywhere p seen fl.Tast.fty) c.Tast.vfields) u.Tast.cases then Some t else None | None -> match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n) p.Tast.unions with | Some u -> if List.exists (fun (fl : Tast.field) -> dyn_anywhere p seen fl.Tast.fty) u.Tast.fields then Some t else None | None -> None) | _ -> None (* Every place a value can live: a global, a parameter, a return, a frame slot. Two passes want exactly this list — the descriptor refusal below and the [--no-gc] site collection at the bottom of the file — and each walked it itself until the phrase naming an unnamed slot drifted between the two. One walk now; the callers keep their own filters, which is where they really differ. [visit] is handed the location, the phrase naming the place, and the type. [~slot] says whether this is a frame slot: that is the one distinction a caller filters on, and a caller cannot recover it from the type. [?after_fn] runs at the end of each function, before the next is begun, so that a caller which also walks the body emits its diagnostics in the order a single loop over [p.Tast.fns] gave them. *) let value_sites (p : Tast.program) ?(after_fn = fun (_ : Tast.fn) -> ()) (visit : slot:bool -> _) = List.iter (fun (g : Tast.global) -> visit ~slot:false g.Tast.ginit.Tast.loc (Printf.sprintf "the global %s" g.Tast.gname) g.Tast.gty) p.Tast.globals; List.iter (fun (fn : Tast.fn) -> List.iteri (fun i t -> visit ~slot:false fn.Tast.floc (Printf.sprintf "parameter %d of %s" (i + 1) fn.Tast.name) t) fn.Tast.params; visit ~slot:false fn.Tast.floc (Printf.sprintf "the return type of %s" fn.Tast.name) fn.Tast.ret; Array.iteri (fun i t -> (* A slot the program named is called by that name; one the checker synthesised has none to give, and "a local" is the phrase both passes now use for it. The preposition is [in] either way, because a named slot has always read "%s in %s". *) let named = if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None in visit ~slot:true fn.Tast.floc (Printf.sprintf "%s in %s" (match named with Some n -> n | None -> "a local") fn.Tast.name) t) fn.Tast.slots; after_fn fn) p.Tast.fns (* Over the whole program rather than at each declaration, because the type that hides a dyn may be declared after the one that names it — and because a struct nobody ever holds a value of costs nothing either way. *) (* Does a value of this type hold an (Fn ...) in its own storage — the function values a collector-allocated environment may hang off. A pointer and a slice are views of storage checked where it is declared. *) let rec holds_fn p seen (t : Types.t) = let go = holds_fn p seen in match t with | Types.Fn _ -> true | Types.Array (_, e) | Types.Vec e | Types.Option e -> go e | Types.Map (k, v) -> go k || go v | Types.Named n when not (List.mem n seen) -> let seen = n :: seen in let field (fl : Tast.field) = holds_fn p seen fl.Tast.fty in (match List.find_opt (fun (s : Tast.structure) -> s.Tast.sname = n) p.Tast.structs with | Some s -> List.exists field s.Tast.fields | None -> match List.find_opt (fun (u : Tast.data) -> u.Tast.dname = n) p.Tast.datas with | Some u -> List.exists (fun (c : Tast.variant) -> List.exists field c.Tast.vfields) u.Tast.cases | None -> match List.find_opt (fun (u : Tast.structure) -> u.Tast.sname = n) p.Tast.unions with | Some u -> List.exists field u.Tast.fields | None -> false) | _ -> false let dyn_descriptors (p : Tast.program) = let check loc what (t : Types.t) = (match hidden_dyn p [] t with | Some at -> Loc.failk "check/dyn-descriptor" loc "%s is %s, and the dyn inside %s is one no descriptor can find. The \ collector marks a struct's dyn fields by their byte offsets, which \ %s does not have — its storage is not part of the value. Hold the \ dyn in a struct field, or wait for the typed container view" what (tyname loc t) (tyname loc at) (tyname loc at) | None -> ()); (* The count is saturated, so the message says more-than rather than a figure the reader could check — which is the honest thing to print, since the figure it would otherwise print is the one that wrapped. *) if dyn_words p [] t > desc_offsets_max then Loc.failk "check/dyn-descriptor" loc "%s is %s, whose descriptor would name more than %d dyn words. The \ offsets of an array are flattened one element at a time, and %d is \ the most this compiler will write out — the repeat form that would \ avoid it arrives with the typed container view" what (tyname loc t) desc_offsets_max desc_offsets_max in (* The foreign boundary, which is the one place the note above admits an honest hole. Every slot, global and array this compiler hands out for a type that holds dyn is rooted with its descriptor. Storage that came from C is not: nothing pushed a root for it, nothing ever will, and a dyn word sitting in it is a live value the collector cannot see and will free. A bare dyn is already refused by name at this boundary for a different reason — C has no way to ask what the word means — and this is the same sentence at one remove. The rule is about *ownership* and not about shape, so the two directions are asked different questions and the answer to "is a (Ptr S) allowed" is "which way is it going": - A return, and anything reachable from it however many pointers deep, is C's storage. [(Ptr S)], [(Ptr (Ptr S))] and [(Ptr [S])] are all refused, and the last two are the ones a one-level check missed — following a pointer is exactly what [dyn_anywhere] stops doing, which is right for a Flan type and wrong here. - A parameter's outermost level is Flan's. The compiler passes the address of a *place*, and a place is a frame slot, a global or an array inside one — rooted with its descriptor and marked for the whole call. So [(Ptr S)] and [[S]] as parameters are ordinary borrows and stay writable, which is what a read-only C inspector wants and what shim.ml's own advice tells people to write. Below that level the storage is C's again: a [(Ptr (Ptr S))] parameter is an out-parameter, and what C writes into it is a pointer of C's own. *) List.iter (fun (e : Tast.extern) -> let refuse what (t : Types.t) why = Loc.failk "check/dyn-descriptor" e.Tast.eloc "%s of %s (the C symbol %s) is %s, and a dyn is reachable through \ it. %s, so the collector cannot mark that word and will free what \ it names — pass the fields across at written types instead" what e.Tast.ename e.Tast.esym (tyname e.Tast.eloc t) why in (* One level in, because that level is the compiler's own: what a foreign parameter of pointer or slice type receives is the address of a place. Below it the question is [dyn_behind_pointer]'s again. *) let below (t : Types.t) = match t with Types.Ptr (_, e) | Types.Slice (_, e) -> e | t -> t in List.iteri (fun i t -> if dyn_behind_pointer p [] (below t) then refuse (Printf.sprintf "parameter %d" (i + 1)) t "The outermost level is this compiler's own storage and is \ rooted, but what lies below it is C's and nothing rooted that") e.Tast.eparams; if dyn_through p [] e.Tast.eret then refuse "the return type" e.Tast.eret "What C hands back points at storage this compiler never rooted") p.Tast.externs; value_sites p (fun ~slot:_ loc what t -> check loc what t) (* See lib/closures.ml. *) let is_env_struct = Closures.is_env_struct let heap_env = Closures.heap_env let place_closures fns = Closures.place ~dev:false fns (* A program's function named as a prelude function takes the name over, the way a definition of a builtin's name does: every call written in the file that defines it reaches the program's, and every call anywhere else — the prelude's own among them, which were written against the prelude's signature — keeps reaching the prelude's. The prelude's is renamed out of the way, under a qualifier no source can spell, rather than dropped. Functions only: a type or a global of the prelude's name is still defined twice. *) let prelude_alias = "prelude~" (* Off for a check whose warnings were already printed for the same source: the dev program re-creating the session its launcher built and warned for. *) let print_warnings = ref true (* Where a dev eval's own forms are, so its warnings are said for those and not again, on every later eval, for everything the session holds. [None] is a build or a check, which says everything. *) let warn_within : Loc.t list option ref = ref None (* The warnings [say_warnings] kept since [build_program] began, in order: what a dev eval hands the editor in its reply as well as printing. *) let said_warnings : Loc.diag list ref = ref [] let say_warnings (ds : Loc.diag list) = let within (at : Loc.t) = match !warn_within with | None -> true | Some spans -> List.exists (fun (s : Loc.t) -> String.equal s.Loc.file at.Loc.file && s.Loc.line <= at.Loc.line && at.Loc.line <= max s.Loc.line s.Loc.eline) spans in let ds = List.filter (fun (d : Loc.diag) -> within d.Loc.dloc) ds in said_warnings := !said_warnings @ ds; if !print_warnings then List.iter (fun (d : Loc.diag) -> prerr_endline (Loc.entry ~mark:'~' ~label:"warning: " d.Loc.dloc d.Loc.dmsg)) ds (* A name the renaming above made, which nobody wrote: left out of every listing a person reads, and shown as whose it is where a frame has to be. *) let internal_name n = String.starts_with ~prefix:(prelude_alias ^ "/") n let shown_name n = let n = written_name n in if internal_name n then let p = String.length prelude_alias + 1 in "the prelude's " ^ String.sub n p (String.length n - p) else n let shadow_prelude (prelude : Ast.decl list) (decls : Ast.decl list) = (* A value name, and whether it is a function's. A program's global takes a prelude function's name over as a program's function does: both are names a call or a read reaches, and the prelude's own uses keep the prelude's. *) let value_name (d : Ast.decl) = match d.Ast.d with | Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) -> Some (fn.Ast.name, true) | Ast.Defvar (n, _, _, _) | Ast.Defconst (n, _, _) -> Some (n, false) | _ -> None in let theirs = List.map fst (List.filter_map value_name prelude) in let taken = List.filter_map (fun (d : Ast.decl) -> match value_name d with | Some (n, f) when List.mem n theirs -> Some (n, d.Ast.dloc, f) | _ -> None) decls in let warnings = List.map (fun (n, at, f) -> Loc.diag ~kind:"check/shadows-prelude" at (Printf.sprintf "%s shadows the prelude's %s — every %s in this file now \ reaches your definition" n n (if f then "call" else "use"))) taken in let taken = List.map (fun (n, at, _) -> (n, at)) taken in let prelude, decls = List.fold_left (fun (prelude, decls) (n, (at : Loc.t)) -> ( List.map (Load.rename_refs [ n ] prelude_alias) prelude, List.map (fun (d : Ast.decl) -> if String.equal d.Ast.dloc.Loc.file at.Loc.file then d else Load.rename_refs [ n ] prelude_alias d) decls )) (prelude, decls) taken in (prelude @ decls, warnings) (* ── A function that calls itself on every path (decision 142) ───────── Rust's [unconditional_recursion], and like it only the obvious case, with no false positives: from entry, every path reaches a direct call of the same name at the same arity before anything can leave. So a branch (an [if], [match], [if-let], [?.], [??]; [when] and [and]/[or] are [If] by now), a loop body, a handler, a restart and a closure each end the search rather than being looked into, and anything that may leave — [return], [some]/[try], a signal, a restart, [break]/[continue] out of the fn, or a call to a function whose type is [Never] — ends it before the call. A name the body binds itself (a parameter, a [let]) is not the function, so a body binding it is not looked at at all. Read over the AST after [collect], where the parameters are paired, a fn's arities are renamed apart and [infer_returns] has settled every callee's return type. *) let recursion_warnings : Loc.diag list ref = ref [] let unconditional_recursion env (decls : Ast.decl list) : Loc.diag list = let children (e : Ast.expr) = let acc = ref [] in ignore (Ast.map_children (fun c -> acc := c :: !acc; c) e); !acc in let rec binds n (e : Ast.expr) = let pat (a : Ast.arm) = match a.Ast.pat with Ast.Pctor (_, ns) -> List.mem n ns | _ -> false in (match e.Ast.e with | Ast.Let (bs, _) -> List.exists (fun (b : Ast.binding) -> b.Ast.bname = n) bs | Ast.Loop (bs, _) -> List.mem_assoc n bs | Ast.Fn (ps, _) -> List.mem n ps | Ast.Dotimes (_, v, _, _) | Ast.Chain (v, _, _) -> v = n | Ast.Match (_, arms) -> List.exists pat arms | Ast.IfLet (_, a, _) -> pat a | Ast.HandlerBind (cs, _) | Ast.HandlerCase (_, cs) -> List.exists (fun (c : Ast.hclause) -> c.Ast.hname = n) cs | Ast.RestartCase (_, cs) -> List.exists (fun (c : Ast.rclause) -> List.exists (fun (p : Ast.field) -> p.Ast.fname = n) c.Ast.rparams) cs | _ -> false) || List.exists (binds n) (children e) in let never n nargs = let ret n = match Hashtbl.find_opt env.fns n with | Some (_, r) -> Some r | None -> Option.map (fun (_, _, r) -> r) (Hashtbl.find_opt env.gsigs n) in let r = match Hashtbl.find_opt env.versions n with | Some vs -> Option.bind (List.assoc_opt nargs vs) ret | None -> ret n in r = Some Types.Never || ((n = "exit" || n = builtin_prefix ^ "exit") && r = None) in (* Whether [e] may leave the function, or reach a [break]/[continue] of a loop outside it. [loops] counts the loops of [e] itself around the node. *) let rec leaves loops (e : Ast.expr) = match e.Ast.e with | Ast.Fn _ | Ast.Defer _ -> false | Ast.Return _ | Ast.Unwrap _ | Ast.Signal _ | Ast.InvokeRestart _ | Ast.Recur _ -> true | Ast.Break l | Ast.Continue l -> loops = 0 || l <> None | Ast.Call ({ Ast.e = Ast.Var n; _ }, args) when never n (List.length args) -> true | Ast.While _ | Ast.Loop _ | Ast.Dotimes _ -> List.exists (leaves (loops + 1)) (children e) | _ -> List.exists (leaves loops) (children e) in let check_fn (d : Ast.decl) (fn : Ast.fn) = let name, arity = match version_of fn.Ast.name with | Some (b, k) when Hashtbl.mem env.versions b -> (b, k) | _ -> (fn.Ast.name, List.length fn.Ast.params) in (* The self-call every path reaches first, if there is one. *) let rec reaches (e : Ast.expr) = match e.Ast.e with | Ast.Call ({ Ast.e = Ast.Var n; _ }, args) when n = name && List.length args = arity -> (match seq args with | Some _ as c -> c | None -> if List.exists (leaves 0) args then None else Some e.Ast.loc) (* [??] evaluates its fallbacks only when what comes before is empty, so only its first operand is certain to run. Every other builtin evaluates all of its arguments. *) | Ast.Call ({ Ast.e = Ast.Var "??"; _ }, a :: _) -> seq [ a ] | Ast.Call (f, args) -> seq (f :: args) | Ast.Return (Some x) -> seq [ x ] | Ast.Do es -> seq es | Ast.Let (bs, es) -> seq (List.map (fun (b : Ast.binding) -> b.Ast.bval) bs @ es) | Ast.If (c, _, _) | Ast.Match (c, _) | Ast.IfLet (c, _, _) | Ast.Chain (_, c, _) -> seq [ c ] | Ast.Field (x, _) | Ast.The (_, x) | Ast.Unwrap (_, x) | Ast.Signal (_, x) | Ast.Narrow (_, x) | Ast.Alias (_, x) -> seq [ x ] | Ast.Set (Ast.Pvar _, v) -> seq [ v ] | Ast.Struct (_, fs) | Ast.Bare fs -> seq (List.map snd fs) | Ast.Arr es -> seq es | _ -> None and seq = function | [] -> None (* A loop that may never end: what follows it may never run. *) | { Ast.e = Ast.While (_, { Ast.e = Ast.Var "true"; _ }, _) | Ast.Loop _; _ } :: _ -> None | e :: rest -> (match reaches e with | Some _ as c -> c | None -> if leaves 0 e then None else seq rest) in if String.equal d.Ast.dloc.Loc.file Prelude.file || List.exists (fun (p : Ast.field) -> p.Ast.fname = name) fn.Ast.params || List.exists (binds name) fn.Ast.fbody then None else Option.map (fun (at : Loc.t) -> let fln = fln_source at in Loc.diag ~kind:"check/unconditional-recursion" at (Printf.sprintf "%s cannot return without first calling itself on line %d, \ so it never returns. If that call was meant to come after %s, it is %s \ by mistake; otherwise %s needs a base case, a path that \ returns without calling itself" name at.Loc.line (if fln then "the function" else "the defn") (if fln then "indented into the body" else "inside the defn's body") name)) (seq fn.Ast.fbody) in List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with Ast.Defn fn -> check_fn d fn | _ -> None) decls let build_program ~keep_going ?tolerate ?previous (decls : Ast.decl list) : Tast.program * env * string list = let env = new_env () in said_warnings := []; Hashtbl.reset arm_failed; (* ── A declaration left as it was compiled ─────────────────────────── A dev session installs a function whose signature changed, and a caller compiled against the old one is still in the running program and still in the declaration list. Its unchanged source may no longer check against the new signature — but it is not being recompiled, the process is running the body it was built with, and that body is what the break loop has to describe if the call stops. So [tolerate] may answer yes for a declaration whose body fails here, and the declaration is left out of the program rather than refused; the session puts the checked body it already had in its place. Everything the failed check registered on its way down — a lifted clause, a generic copy — is taken back, so nothing half-checked reaches the backend. Only a body. A signature is collected in pass one and nothing here excuses it, and with no [tolerate] this is the compiler it always was. *) let tolerated = ref [] in let tolerant name f = match tolerate with | None -> f () | Some ok -> (* Everything the failed body wrote into [env] goes with it ([snapshot_env]): a copy it asked for would otherwise stay cached, and the next body asking for it would be handed the name of a copy the program does not have. *) let undo, keep = snapshot_env env in (match f () with | x -> keep (); x | exception ((Loc.Error d | Loc.Errors (d :: _)) as e) -> if ok env name d then begin undo (); tolerated := name :: !tolerated; None end else (keep (); raise e) | exception e -> keep (); raise e) in let decls, prelude_warnings = shadow_prelude (Parse.program (Prelude.forms ())) decls in (* Before anything is collected: every (declare-c ...) becomes an ordinary flattened [declare] with a Flan [defn] over it, and the C that does the flattening comes back to be compiled into the build. Nothing below this line knows the form exists. *) List.iter (fun (n, t) -> Hashtbl.replace env.tracks n t) (Shim.resources decls); let decls, cshim = Shim.expand decls in (* And on the same line: every class and generic function becomes the [defn]s it stands for. It runs over the whole list because a method may be written anywhere in it, which is also what makes a reload rebuild every dispatch from the session's declarations — see lib/classes.ml. *) let decls = Classes.expand decls in (* And with the declaration list in its final shape — the classes expanded, the shims flattened, the imports already qualified by [Load] — the one warning this compiler prints unasked. Here rather than in [bin/main.ml] beside [print_memory_warnings] because every route into the compiler passes through this function: build, check, run, and the dev daemon's reload, which is where a defn is most likely to be written. Printed in the shape [Loc] gives an error, so a checker in an editor parses it the same way. *) say_warnings (shadowed_builtins decls @ prelude_warnings); (* Pass one, and it stops at the first thing it refuses. That is not laziness: every name, type and signature in the file comes from here, so a declaration this pass could not make sense of leaves a hole that pass two would report once per mention. A wrong signature is one error; the thirty "unknown name" lines under it are not errors, they are the same one. Pass two is where the volume is, and it is where collecting pays. By the 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 say_warnings (List.rev !pairing_warnings); check_finite env; check_union_members env; infer_returns ~keep_going ?tolerate ?previous env decls; recursion_warnings := unconditional_recursion env decls; say_warnings !recursion_warnings; (let late = !consts_after_infer in consts_after_infer := []; settle_consts env late); 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 has no equivalent of: Odin checks a polymorphic body only per instantiation, so [a + b] over a [$T] compiles there and fails only if nobody ever calls it at a numeric type. plan.org says the opposite — an unconstrained variable supports only what every type supports, and [=], [<], [+] and [hash] over one are *rejected, not silently instantiated*. Rejecting them means type-checking the body with nothing substituted, which is this, and it is a second pass over the same source. *) List.iter (fun (d : Ast.decl) -> match d.Ast.d with | Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name -> (match Loc.caught s (fun () -> tolerant fn.Ast.name (fun () -> with_recovery env ~on:keep_going (fun () -> Some (check_generic env fn)))) with | None -> Hashtbl.replace env.refused_generics fn.Ast.name () | Some _ -> ()) | _ -> ()) decls; let globals = List.filter_map (fun (d : Ast.decl) -> Option.join (Loc.caught s (fun () -> let checked () = with_recovery env ~on:keep_going (fun () -> check_global env d) in match Ast.declared_name d with | Some n -> tolerant n checked | None -> checked ()))) decls in let fns = List.filter_map (fun (d : Ast.decl) -> match d.Ast.d with (* A generic [defn] does not reach the typed IR at all. Only its instantiations do, and they are collected below. *) | Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name -> None | Ast.Defn fn -> Option.join (Loc.caught s (fun () -> tolerant fn.Ast.name (fun () -> with_recovery env ~on:keep_going (fun () -> Some (check_fn env fn))))) | _ -> None) decls in say_warnings (List.rev !grow_warnings); Loc.finish s; (* The placeholder a [_] body is read against is never a type anything downstream may see; a signature carrying it would be emitted as a struct named _. *) List.iter (fun (f : Tast.fn) -> if f.Tast.ret == infer_ret || List.exists (fun t -> t == infer_ret) f.Tast.params then fail f.Tast.floc "internal: %s left the checker with its return \ type unread" f.Tast.name) fns; (* The handler clauses lifted out along the way. They are ordinary functions from here down; nothing in the backend knows they were written inside something else. *) let fns = fns @ List.rev env.lifted in (* The copies generics turned into, in the order they were generated. Like a lifted clause they are ordinary functions from here down — but unlike one they are reached *by name* from arbitrary call sites, so they carry no [fparent] and a dev build gives each its own cell. *) let fns = fns @ List.rev env.instances in (* Which capturing fns outlive their frame; see [place_closures]. *) let fns = place_closures fns in (* And the order the computed initialisers run in, which needs the whole function list: what a global reads is transitive through what it calls. *) let globals = init_order globals fns in (* Sorted, so the emitted IR is reproducible build to build: a Hashtbl's fold order is not. *) let values name tbl = Hashtbl.fold (fun _ v acc -> v :: acc) tbl [] |> List.sort (fun a b -> String.compare (name a) (name b)) in let externs = Hashtbl.fold (fun name esym acc -> let eparams, eret = Hashtbl.find env.fns name in let eloc = match Hashtbl.find_opt env.extern_locs name with | Some l -> l | None -> Loc.unknown in { Tast.ename = name; esym; eparams; eret; eloc } :: acc) env.externs [] |> List.sort (fun (a : Tast.extern) b -> String.compare a.Tast.esym b.Tast.esym) in let p = { 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 } in (* Last, over the finished program: which dyn words a per-type descriptor can reach and which it cannot. It needs every declaration in hand, which is what makes it a pass here rather than a check at each one. *) dyn_descriptors p; (p, env, List.rev !tolerated) (** The program and the environment, stopping at the first refusal. What a session needs, and it raises [Loc.Error] and never [Loc.Errors]. *) let program_with_env (decls : Ast.decl list) : Tast.program * env = let p, env, _ = build_program ~keep_going:false decls in (p, env) (** The same, with [tolerate] deciding which body failures leave a declaration out rather than refuse it — see [build_program]. The names left out come back beside the program; nothing else about it changes. *) let program_tolerant ?(keep_going = false) ~tolerate ?previous (decls : Ast.decl list) = build_program ~keep_going ~tolerate ?previous decls let program (decls : Ast.decl list) : Tast.program = let p, _, _ = build_program ~keep_going:false decls in p (** The same, reporting every declaration whose body it refuses rather than the first. Raises [Loc.Errors], so only a caller prepared for a list should be calling it. *) let program_all (decls : Ast.decl list) : Tast.program = let p, _, _ = build_program ~keep_going:true decls in p (* ── What a session needs to know about instantiations ────────────────── A generic [defn] never reaches [Tast.fns] — only its copies do — so the editor's [C-c C-c], which installs the bodies named by the form it was sent, would install nothing at all for a generic. These are what [Session.eval] expands the name with. They are here rather than there because [env]'s tables are the only record that a symbol was ever generic: past this module an instantiation is an ordinary function and nothing knows it was written once. *) (* Is this name a generic definition rather than an ordinary one? *) let is_generic env n = Hashtbl.mem env.gsigs n (* Every copy of [gname] this check produced, by symbol. Transitivity needs no walk: a whole-program check has already generated every copy every call site asked for, including the ones a generic pulled in by calling another generic at its own variable. *) let instantiations env gname = match Hashtbl.find_opt env.insts gname with | None -> [] | Some l -> List.rev_map (fun (_, _, sym) -> sym) !l (* The generic a symbol came from, and the types it was asked for — [None] for an ordinary function. What a refusal about [sort-i32] needs in order to say which line the programmer should look at, since [sort-i32] appears nowhere in the source. *) let instantiation_origin env sym = Hashtbl.fold (fun gname l acc -> match acc with | Some _ -> acc | None -> (match List.find_opt (fun (_, _, s) -> String.equal s sym) !l with | Some (ps, _, _) -> Some (gname, ps) | None -> None)) env.insts None (* Checking one expression against a live session can *generate* a copy: the first [C-x C-e] of [(id 3)] instantiates [id] at [i32] and the copy is in [env.instances] and in no program anywhere. Without these two the module that gets built calls a symbol it never defined. A mark before and the difference after is the whole protocol. *) let instance_mark env = List.length env.instances let instances_since env mark = let fresh = List.length env.instances - mark in List.rev (List.filteri (fun i _ -> i < fresh) env.instances) (* The same protocol for a body an expression lifted — an [fn] literal or a handler clause — and the environment struct each one captured into. Both are in [env] and in no program, and a module that calls one or lays one out needs them. *) let lifted_mark env = List.length env.lifted 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)) fns (* Expressions checked against a program that is already running, all of them into *one* frame. It is empty to start with — a REPL expression has no parameters and no enclosing function — so the slots it ends up with are whatever their own [let]s allocate. One frame and not one each, which is what the inspector's write verb needs and what it must not assemble by hand. Two expressions checked separately both number their slots from zero, so splicing them into one thunk would have the second one's [let] reading and writing the first one's storage — a frame that is two frames wearing one frame's clothes. Sharing the [ctx] is the whole of the fix, and it is a fix because there is exactly one allocator of slot indices in this compiler and it is this record's counter. They are otherwise independent: none of them binds a name for the next, because the list is a list of values being stored and not a sequence. [want] is the write verb too, and [C-x C-e] passes none: a store into a slot of type [f32] has an expectation to offer and a typed expression does not. The whole value of passing it is that [3] arrives as an [f32] rather than as an [i32] the store would then have to be refused for. It flows through [check] the way an expectation flows anywhere — that is what bidirectional means — and [expect] at the end catches the arms that ignore it, so the refusal is the checker's own "expected f32, found string" rather than a second sentence written here that would drift from it. *) let expressions env (es : (Types.t option * Ast.expr) list) : Tast.expr list * Types.t array * string option array = let ctx = invented_ctx env Types.Unit in (* Folded rather than mapped, because [List.map]'s order is unspecified and every one of these calls has a side effect on [ctx] — the slot counter it shares. An order nobody chose is one that can differ between builds, and two frames laid out differently for the same edit is the kind of thing that is found by somebody else, much later. *) let ts = List.rev (List.fold_left (fun acc (want, (e : Ast.expr)) -> expect ctx e.Ast.loc ~want (check ctx ?want e) :: acc) [] es) in (ts, Array.of_list (List.rev ctx.slot_tys), Array.of_list (List.rev ctx.slot_names)) (* One expression checked with [scope]'s names already bound, in order, so a later entry shadows an earlier one of the same name: evaluating in a stopped frame, whose locals the expression may name. Each is bound to a slot of the expression's own frame, and which slot is answered beside the name, so the caller can point every use of it at the stopped frame's storage instead ([Tast.rewrite_locals]). *) let expression_in_scope env ~(scope : (string * Types.t * bool * bool) list) (e : Ast.expr) : Tast.expr * Types.t array * string option array * (string * int) list = let ctx = invented_ctx env Types.Unit in let bound = List.map (fun (name, ty, assignable, by_as) -> let what = if by_as then Some as_tag else None in (name, bind ctx ?what name ty ~assignable:(assignable && not by_as))) scope in let t = expect ctx e.Ast.loc ~want:None (check ctx e) in (t, Array.of_list (List.rev ctx.slot_tys), Array.of_list (List.rev ctx.slot_names), bound) (* The one-expression case, which is every caller but the write verb. *) let expression env ?want (e : Ast.expr) : Tast.expr * Types.t array * string option array = match expressions env [ (want, e) ] with | [ t ], tys, names -> (t, tys, names) | _ -> assert false (* ── --no-gc ──────────────────────────────────────────────────────────── The flag that says this program is to be compiled with no collector in it, and the way to keep that promise is to refuse every dyn rather than to emit a different program. A dyn value is a value the runtime allocates and the collector owns; there is no smaller version of it to fall back to, and quietly leaking instead would be a memory model nobody asked for. So this is a pass and not a flag. It runs between [Check] and [Emit], it answers unit or it refuses, and nothing downstream of it is told the flag exists — which is what makes a fully annotated program's output byte for byte identical with the flag and without it. Emit has no [no_gc] field to branch on, and that is deliberate: a field would be one more thing that could change a comment, a name or an ordering, and the identity is worth more than the branch would ever buy. Every site is named, the way the global cycle refusal names the whole ring rather than one member of it. A reader who has to annotate their program wants the list, not the first one and then another compile. *) let dyn_sites (p : Tast.program) : Loc.diag list = let found = ref [] in let add loc what = found := (loc, `Dyn what) :: !found in (* A type that *holds* a dyn and not only the type [dyn] itself. A struct with a dyn field is a collected value as much as a bare one is, and since the per-type descriptors it is a value a program can have without any expression in it ever having the type [dyn] — a zeroed one, never filled, whose dyn word the collector is still asked to mark. *) let holds t = dyn_anywhere p [] t in value_sites p (* The filter this pass has and the descriptor pass does not: a frame slot whose type is bare [dyn] is passed over here. A parameter or a global of that type is still named. *) (fun ~slot loc what t -> if holds t && not (slot && t = Types.Dyn) then add loc what) ~after_fn:(fun (fn : Tast.fn) -> (* The body's own dyn values, which are the ones a signature does not show: a let bound to a boxed literal, a (vec-new dyn) deep inside an expression. Reported at the node, because that is the character to change. *) List.iter (Tast.walk (fun (e : Tast.expr) -> match e.Tast.e with | Tast.Prim (Tast.Rt sym, _) when e.Tast.ty = Types.Dyn && String.length sym > 8 && String.sub sym 0 8 = "flan_dyn" -> add e.Tast.loc (Printf.sprintf "this value in %s" fn.Tast.name) (* A capturing fn: its environment is a collector allocation, which is a different sentence from a dyn and has a different fix. *) | Tast.Closure (_, env) when heap_env env -> found := (e.Tast.loc, `Closure) :: !found | _ -> ())) fn.Tast.body); List.rev_map (fun (loc, site) -> Loc.diag ~kind:"check/no-gc" loc (match site with | `Dyn what -> Printf.sprintf "%s holds a dyn, and --no-gc says this program carries no \ collector. A \ dyn value is one the runtime allocates and the collector owns, \ so there is nothing smaller to compile it to — write the type" what | `Closure -> "this fn captures and outlives the frame it was made in, and \ --no-gc says this program carries no collector. The copies of an \ fn that outlives its frame live in an environment the collector \ allocates — call it or pass it down instead of keeping it, or \ pass what it names in as parameters")) !found let no_gc (p : Tast.program) = match dyn_sites p with [] -> () | ds -> raise (Loc.Errors ds) (* ── Memory diagnostics ───────────────────────────────────────────────── "Which of these lines allocates?", answered on demand. Clojure's [*warn-on-boxed*] crossed with Rider's heap-allocation squiggles, and the same shape [dyn_sites] above has: a pass over the finished program, off unless somebody asks, and nothing downstream is told it exists. Asking for it cannot change what compiles. Two classes, because the two heaps are not the same heap and a reader wants to know which one a line is spending. [kind] carries it — ["memory/gc"] is the dyn runtime's collected heap, ["memory/native"] is an allocator the program named — so the CLI and the daemon dispatch on one field and neither has to parse a message. **Precision over completeness.** A site named here allocates, and a site that only *might* says so in the first two words. That rule is what decides the table below, and it decided it against the obvious guesses more than once — every claim here was read out of runtime/flan_rt.c and runtime/flan_dyn.c rather than assumed: - [(vec-new T)] does not allocate. The lowering passes a capacity of zero (see the [flan_vec_init] call in the ["vec-new"] arm) and [flan_vec_init]'s body returns before [flan_vec_grow] when [cap <= 0]. The block arrives at the first push. [(map-new K V)] is the same: its [flan_map_init] leaves [data] NULL and says so on its own line. [(vec-new dyn)] and [(map-new dyn)] are the *other* answer — those are the dyn runtime's own objects and [gc_alloc] runs at the call. - A dyn immediate does not allocate: nil, a bool, an f64, a keyword, and an int inside the payload. The payload is 48 bits ([DYN_PAYMASK]/[DYN_INT_MAX] in flan_dyn.c), so only an i64 that can leave ±2^47 is a "may allocate", and a value widened from a narrower integer type provably cannot. - A keyword is interned and immortal — [flan_dyn_kw]'s entry is not a GC object and the collector never traces one — so it is not named here. - A dyn container growing itself is not named, and this one is a judgement rather than a fact about the runtime: [flan_dyn_push] and [flan_dyn_map_set] provably may [gc_alloc], and they are still left out. The unit this pass reports is a line the programmer can act on — crossing into dyn is a choice, pushing onto an allocator's Vec is a choice — and a dyn vector taking a block to hold what was just put in it is the only thing it could do. Marking it would squiggle every [(push dv x)] in a program that chose dyn. Written down in TODO.org, "Memory diagnostics on demand", because it is the one row here that the precision rule alone does not decide. - Dyn arithmetic is not named. [flan_dyn_add] and its siblings end in [flan_dyn_from_i64], so a wide enough result spills, but nothing static knows the operands and a squiggle on every [(+ a b)] over dyn is the false positive this pass exists not to have. *) (* The payload's range, restated from [DYN_INT_MAX]/[DYN_INT_MIN] in runtime/flan_dyn.c: 2^47-1 and its negation less one. Restated rather than read, the way every other number this compiler shares with the runtime is, and wrong only in the direction of a missing warning if the runtime ever widens it. *) let dyn_payload_max = 140737488355327L let dyn_payload_min = -140737488355328L (* An integer type that cannot reach the payload's edge whatever its value. *) let narrower_than_payload (t : Types.t) = match t with | Types.Int (Types.I8 | Types.I16 | Types.I32 | Types.U8 | Types.U16 | Types.U32) -> true | _ -> false (* Can this argument to [flan_dyn_from_i64] spill onto the heap? One level of unwrapping and no more: [box] widens with a single [Cast i64], and peeling further would walk through a *narrowing* cast the programmer wrote and report a range the value cannot have. *) let int_may_spill (e : Tast.expr) = let e = match e.Tast.e with | Tast.Prim (Tast.Cast (Types.Int Types.I64), [ inner ]) when narrower_than_payload inner.Tast.ty -> inner | _ -> e in match e.Tast.e with | Tast.Int (n, _) -> n > dyn_payload_max || n < dyn_payload_min | _ -> not (narrower_than_payload e.Tast.ty) (* A [flan_vec_init] whose capacity is a literal zero takes no block. That is every [(vec-new T)]; [slurp] passes the file's size and is the caller that makes this a test rather than a constant. *) let vec_init_allocates (args : Tast.expr list) = match args with | _ :: _ :: cap :: _ -> (match cap.Tast.e with Tast.Int (n, _) -> n > 0L | _ -> true) | _ -> true (* The classifier. [Some (kind, message)] for a site that allocates or may, [None] for everything else — and [None] is the answer for every symbol not named here, which is what keeps a new runtime entry point silent rather than guessed at. *) let memory_class (sym : string) (args : Tast.expr list) = let gc m = Some ("memory/gc", m) and native m = Some ("memory/native", m) in match sym with (* ── The collected heap ── *) | "flan_dyn_from_bytes" -> gc "allocates: a string crossing into dyn is copied onto the \ collector's heap" | "flan_dyn_vec_new" -> gc "allocates: a dyn vector is an object on the collector's heap" | "flan_dyn_map_new" -> gc "allocates: a dyn map is an object on the collector's heap" | "flan_dyn_map_new_class" -> gc "allocates: a class instance is a dyn map on the collector's heap, \ with the class's name in its header" | "flan_dyn_view_slice" | "flan_dyn_view_at" -> gc "allocates: a typed container crossing into dyn takes a view record \ on the collector's heap — the elements are not copied, the record is" | "flan_dyn_from_i64" when (match args with [ x ] -> int_may_spill x | _ -> true) -> gc "may allocate: an i64 outside ±2^47 does not fit a dyn's payload and \ spills onto the collector's heap" | "flan_dyn_from_u64" when (match args with x :: _ -> int_may_spill x | [] -> true) -> gc "may allocate: a u64 above 2^47 does not fit a dyn's payload and \ spills onto the collector's heap" (* ── An allocator the program named ── *) | "flan_arena_new" -> native "allocates: an arena takes its whole region from the host here" | "flan_vec_init" when vec_init_allocates args -> native "allocates: the Vec is sized up front and takes its block from \ its allocator here" | "flan_vec_push" -> native "may allocate: a push past the Vec's capacity grows it through \ its allocator" | "flan_vec_reserve" -> native "may allocate: a reserve past the Vec's capacity grows it through \ its allocator" | "flan_map_put" -> native "may allocate: a put past the map's load factor grows its block \ through its allocator" | "flan_map_reserve" -> native "may allocate: a reserve past the map's load factor grows its \ block through its allocator" | "flan_vec_clone" -> native "may allocate: cloning a non-empty Vec takes a new block from its \ allocator" | "flan_map_clone" -> native "may allocate: cloning a non-empty map takes a new block from its \ allocator" | _ -> None (** Every site in the program that allocates, or may. Ordered by source position, one diagnostic per location and class — a lowering emits several runtime calls at one location and a reader wants the line named once. [?file] narrows it to one source file, which is what a command that was handed a path wants: the prelude pushes onto Vecs on a dozen lines and an import has its own, and neither is a line the person who asked can do anything about. Left out, everything the program holds is reported — which is what a client that does its own filtering, the editor among them, should ask for. *) let memory_sites ?file (p : Tast.program) : Loc.diag list = let found = ref [] in let seen = Hashtbl.create 64 in let look (e : Tast.expr) = let cls = match e.Tast.e with | Tast.Prim (Tast.Rt sym, args) -> memory_class sym args | Tast.Closure (_, env) when heap_env env -> Some ("memory/gc", "allocates: an fn that captures and outlives its frame keeps its \ copies in an environment on the collector's heap") | _ -> None in match cls with | None -> () | Some (kind, msg) -> let loc = e.Tast.loc in let key = (loc.Loc.file, loc.Loc.line, loc.Loc.col, kind) in if (match file with None -> true | Some f -> String.equal f loc.Loc.file) && not (Hashtbl.mem seen key) then begin Hashtbl.replace seen key (); found := Loc.diag ~kind loc msg :: !found end in (* A global's initialiser runs at startup and allocates there as much as a body does — [(defonce names (vec-new dyn))] is a heap object before main has a line of its own — so the globals are walked and not only the functions. *) List.iter (fun (g : Tast.global) -> Tast.walk look g.Tast.ginit) p.Tast.globals; List.iter (fun (fn : Tast.fn) -> List.iter (Tast.walk look) fn.Tast.body) p.Tast.fns; let placed (d : Loc.diag) = d.Loc.dloc.Loc.line > 0 in List.stable_sort (fun a b -> match (placed a, placed b) with | true, false -> -1 | false, true -> 1 | _ -> Loc.before a.Loc.dloc b.Loc.dloc) (List.rev !found) (* The form that decided an inferred return type, for a name whose return slot was [_]; [None] for one whose type was written. *) let inferred_cause env name = Hashtbl.find_opt env.inferred name