From 179156b1059345ad3512a61b2ee3386794c32dda Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 17:08:15 +0700 Subject: [PATCH] A function name has one version per arity, and a call picks the version by its number of arguments. --- TODO.org | 7 + lib/check.ml | 250 ++++++++++++++++++++++++++++++--- lib/dev.ml | 62 +++++++- lib/emit.ml | 3 +- lib/session.ml | 92 +++++++++--- lib/x86.ml | 2 +- spec-syntax.md | 10 ++ test/programs/dev-versions.fln | 15 ++ test/programs/versions.fln | 73 ++++++++++ test/test_acceptance.ml | 8 ++ test/test_dev.ml | 78 +++++++++- test/test_flan.ml | 38 +++++ test/test_session.ml | 83 ++++++++--- 13 files changed, 650 insertions(+), 71 deletions(-) create mode 100644 test/programs/dev-versions.fln create mode 100644 test/programs/versions.fln diff --git a/TODO.org b/TODO.org index c54bcdc7..a92cca24 100644 --- a/TODO.org +++ b/TODO.org @@ -45,6 +45,13 @@ Decided 2026-09-26 (128) to pause: dyn vectors are mutable, so taking from the f shifts every element. Options were a linked list (cons/first/rest) or storing the dyn vector as a ring buffer with a cheap read-only rest view; the ring buffer was recommended. Waits on a program that needs it. +** DONE A name has one version per arity (decision 135a) +CLOSED: [2026-09-26] +The call's argument count picks the version at compile time; each is renamed =f~N= only +when a name has two or more. Rules out overloading by type at one arity, rest parameters +on =fn= (refused already), and more than one =main=. In the dev loop another arity adds a +version rather than replacing, so an arity change is no longer a stale-call signature +change: only a same-arity one is. ** DONE if let CLOSED: [2026-09-26] =(if-let [P v] then else)= in paren syntax; an elif chain is the else. With no else it diff --git a/lib/check.ml b/lib/check.ml index 48360e96..19a3130e 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -223,6 +223,11 @@ type env = { 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 name with several versions, one per arity (decision 135a): the name as + written, to each version's arity and the name it was renamed to + ([version_name]). A name with one version 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; @@ -389,6 +394,7 @@ and new_env_record () = { 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; @@ -445,7 +451,7 @@ let snapshot_env env : (unit -> unit) * (unit -> unit) = datas = _; unions = _; cases = _; aliases = _; consts = _; enums = _; parents = _; externs = _; extern_locs = _; fparams = _; fn_locs = _; - privates = _; globals = _; global_locs = _; + versions = _; privates = _; globals = _; global_locs = _; generics = _; gsigs = _; refused_generics = _; gstructs = _; broken = _; glens = _; classes = _; tracks = _; inferred = _; infer_failed = _ } = env in @@ -4011,6 +4017,35 @@ let rec view_desc ?(into = false) structs (t : Types.t) 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 @@ -7005,6 +7040,43 @@ and var ctx ?(qualified = false) loc ~want name = 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) + | _ -> + 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 versions, 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 versions 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)) + (String.concat "\n" + (List.map (fun (_, v) -> " " ^ version_text ctx.env loc v) + vs)) + 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; @@ -7026,7 +7098,7 @@ and var ctx ?(qualified = false) loc ~want name = 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 name) + | 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 @@ -11082,12 +11154,13 @@ and check_arg ctx name i (want : Types.t) (a : Ast.expr) = let p = List.nth ps i in [ Loc.note p.Ast.floc (Printf.sprintf "%s's %s parameter %s is declared %s" - name which p.Ast.fname (tyname p.Ast.floc want)) ] + (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 name)) + (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 = @@ -16010,6 +16083,19 @@ and ordinary_call ctx ~want loc name args = | 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 version 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 @@ -16317,6 +16403,7 @@ and private_ref ctx loc name = | 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 \ @@ -16325,10 +16412,42 @@ and private_ref ctx loc name = 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 -> @@ -16359,7 +16478,7 @@ and shadows_builtin ctx loc name = [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" name (List.length pats) + 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 @@ -16516,7 +16635,7 @@ and generic_call ctx ~want loc name vars pats pret args = exactly — the pair cannot join at the wider type there. \ Write the conversion — (%s x) — or pass the arguments at \ one type" - name v (tyname loc p) (tyname loc a.Tast.ty) v + (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; @@ -16526,14 +16645,14 @@ and generic_call ctx ~want loc name vars pats pret args = (* [~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" name + 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" - name (tyname loc a.Tast.ty) + (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 @@ -16550,7 +16669,7 @@ and generic_call ctx ~want loc name vars pats pret args = (fun v -> if not (List.mem_assoc v !subst) then fail loc - "%s's type variable $%s is not determined by any argument" name v) + "%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 @@ -16567,7 +16686,7 @@ and generic_call ctx ~want loc name vars pats pret args = "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" - name v (tyname loc t1) (tyname loc t2)) + (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 @@ -16615,7 +16734,7 @@ and generic_call ctx ~want loc name vars pats pret args = 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" name + 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)) @@ -16659,7 +16778,7 @@ and generic_call ctx ~want loc name vars pats pret args = "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" - name v (tyname loc t)) + (written_name name) v (tyname loc t)) !subst; let cparams = List.map (subst_ty !subst) pats in let cret = subst_ty !subst pret in @@ -16692,13 +16811,13 @@ and generic_call ctx ~want loc name vars pats pret args = "%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" - name (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)) v + (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" - name (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)) (tyname loc t) + (written_name name) (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)) (tyname loc t) (pred_word p.Ast.pname) | _ -> ()) gfn.Ast.fwhere); @@ -16750,8 +16869,8 @@ and instantiate env loc gname vars subst cparams cret = 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" - gname p.Ast.pvar (tyname loc t) (tyname loc t) - (pred_word p.Ast.pname) gname + (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 @@ -17817,6 +17936,92 @@ let check_parents env = 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 name, several arities (decision 135a) ───────────────────────── + [fn f(g: Grain)] and [fn f(r: i32, c: i32)] are two versions of [f], and a + call picks one by how many arguments it passes. Nothing past the checker + knows: each version 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 name written once keeps its name, so its symbol does not move when a file + gains or loses an unrelated version elsewhere; only a name with two or more + versions is renamed, all of its versions alike, so no version is the + plain name's by accident of order. + + Types play no part: two versions of one arity are one function defined + twice, whatever their parameter types. *) +(* How many parameters a [defn] takes, paired against [env]'s types: what a + session asks of a form it is about to merge, to tell a new version of a + name from a redefinition of one it has. A vector that does not pair against + [env] — it names a type the same form declares — is counted as pairing + would count it once the type exists: a capitalised name is a type. *) +let defn_arity env (fn : Ast.fn) = + match fn.Ast.praw with + | None -> List.length fn.Ast.params + | Some items -> + (try List.length (pair_params env items) + with Loc.Error _ | Loc.Errors _ -> + let rec go = function + | [] -> 0 + | Ast.Pname _ :: Ast.Ptype _ :: rest -> 1 + go rest + | Ast.Pname _ :: Ast.Pname (t, _) :: rest + when t <> "" && Char.uppercase_ascii t.[0] = t.[0] + && Char.lowercase_ascii t.[0] <> t.[0] -> 1 + go rest + | _ :: rest -> 1 + go rest + in + go items) + +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 + (* [main] is called by the startup code, by its own name, so it has + one version. *) + (match seen with + | (_, first) :: _ when String.equal n "main" -> + Loc.failk "check/defined-twice" d.Ast.dloc + ~notes:[ Loc.note first "main is already defined here" ] + "main is defined twice. The program starts at main, so it has \ + one version" + | _ -> ()); + (match List.assoc_opt k seen with + | Some (first : Loc.t) -> + let others = List.exists (fun (j, _) -> j <> k) seen in + Loc.failk "check/defined-twice" d.Ast.dloc + ~notes:[ Loc.note first (n ^ " is already defined here") ] + "%s is defined twice%s" n + (if others then + Printf.sprintf " with %d parameter%s. Each version of a \ + function takes a different number of \ + arguments" k (if k = 1 then "" else "s") + else "") + | None -> ()); + Hashtbl.replace arities n (seen @ [ (k, 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) @@ -17876,21 +18081,26 @@ let collect env (decls : Ast.decl list) = | _ -> ()) 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 - | Some first -> + (* Two [defn]s of one name may be two versions of it, and whether + they are is a question about their arities, which are known only + once the parameter vectors are paired — [split_versions], below + [pair_decls]. *) + | 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) + | 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) = @@ -18029,6 +18239,7 @@ let collect env (decls : Ast.decl list) = 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 @@ -20113,6 +20324,7 @@ let print_warnings = ref true 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) diff --git a/lib/dev.ml b/lib/dev.ml index 6897d2a8..e4ca28c5 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -676,6 +676,17 @@ let find_fn t name = String.equal f.Tast.name name && f.Tast.fparent = None) t.session.Session.program.Tast.fns +(* The versions of a name that has several, each under the name it was + compiled as ([Check.split_versions]). *) +let version_fns t name = + List.filter + (fun (f : Tast.fn) -> + f.Tast.fparent = None + && (match Check.version_of f.Tast.name with + | Some (b, _) -> String.equal b name + | None -> false)) + t.session.Session.program.Tast.fns + let fn_loc t name = match find_fn t name with | Some f -> Loc.to_string f.Tast.floc @@ -1024,7 +1035,8 @@ let stale_field (ss : Session.stale list) = Printf.sprintf "(:loc %s :caller %s :callee %s :compiled %s :current %s%s%s)" (Wire.quote (Loc.to_string x.Session.at)) - (Wire.quote x.Session.caller) (Wire.quote x.Session.target) + (Wire.quote (Check.written_name x.Session.caller)) + (Wire.quote (Check.written_name x.Session.target)) (Wire.quote x.Session.compiled) (Wire.quote x.Session.current) (if x.Session.running then " :running t" else "") @@ -1651,8 +1663,12 @@ let describe t = (List.filter_map (fun (f : Tast.fn) -> if Check.internal_name f.Tast.name then None - else Some f.Tast.name) - t.session.Session.program.Tast.fns); + else Some (Check.written_name f.Tast.name)) + t.session.Session.program.Tast.fns + (* A name with several versions is listed once. *) + |> List.fold_left + (fun acc n -> if List.mem n acc then acc else n :: acc) [] + |> List.rev); ":globals " ^ Wire.strings (List.map (fun (g : Tast.global) -> g.Tast.gname) @@ -1693,7 +1709,7 @@ let describe t = Parameter *names* are not in the Tast, so a signature shows types only. *) let signature_of_fn (f : Tast.fn) = - Printf.sprintf "%s [%s] %s" f.Tast.name + Printf.sprintf "%s [%s] %s" (Check.written_name f.Tast.name) (String.concat " " (List.map Types.to_string f.Tast.params)) (Types.to_string f.Tast.ret) @@ -1776,10 +1792,29 @@ let defs t = None | None when List.mem f.Tast.name class_names -> None | None when Check.internal_name f.Tast.name -> None + (* A name with several versions is one row, as it is one name to + complete and to jump to, carrying every version's signature. *) + | None when Check.version_of f.Tast.name <> None -> + let base = Check.written_name f.Tast.name in + let versions = + List.filter + (fun (g : Tast.fn) -> + g.Tast.fparent = None + && Check.version_of g.Tast.name <> None + && String.equal (Check.written_name g.Tast.name) base) + p.Tast.fns + in + (match versions with + | first :: _ when first == f -> + Some + (entry ~name:base ~kind:"fn" + ~sign:(String.concat " | " (List.map signature_of_fn versions)) + ~loc:(Loc.to_string f.Tast.floc) ()) + | _ -> None) | None -> Some - (entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f) - ~loc:(Loc.to_string f.Tast.floc) ())) + (entry ~name:(Check.written_name f.Tast.name) ~kind:"fn" + ~sign:(signature_of_fn f) ~loc:(Loc.to_string f.Tast.floc) ())) p.Tast.fns in let globals = @@ -4445,6 +4480,21 @@ let disassemble t ~name ~form = ":generic " ^ Wire.quote name; ":signature " ^ Wire.quote sign; ":copies " ^ Wire.list (List.map entry cs) ]) + (* A name with several versions answers with each, as a generic with + several copies does. *) + | None when version_fns t name <> [] -> + let entry (f : Tast.fn) = + match disassemble_fn t ~name:f.Tast.name ~form f with + | Ok fields -> Wire.list fields + | Error m -> + Wire.list + [ ":name " ^ Wire.quote f.Tast.name; + ":signature " ^ Wire.quote (signature_of_fn f); + ":refused " ^ Wire.quote m ] + in + ok + [ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form; + ":versions " ^ Wire.list (List.map entry (version_fns t name)) ] | None -> (match kind_of t name with | Some k -> diff --git a/lib/emit.ml b/lib/emit.ml index 12bf55ca..1a855c4a 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -3154,7 +3154,8 @@ and stale_check f loc flan cell ps r = label f bad; let cstr s = fst (fi_bytes f.md (s ^ "\000")) in ins f "call void @flan_stale_call(ptr %s, ptr %s, ptr %s, ptr %s, ptr %s)" - (cstr (Loc.to_string loc)) (cstr flan) (cstr (sig_text ps r)) cell + (cstr (Loc.to_string loc)) (cstr (Check.written_name flan)) + (cstr (sig_text ps r)) cell xfer_param; guard f; term f "unreachable"; diff --git a/lib/session.ml b/lib/session.ml index 30f426b2..16ed882f 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -964,39 +964,55 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr *generic's*. Naming it here is what makes [C-c C-c] on a defmethod reach a call site compiled before the method existed, which is the whole of why this feature is usable in the loop the project exists for. *) + (* A [defn] is one version of its name, the one with its number of + parameters (decision 135a): it replaces that version and leaves the + others alone, and a number the name had no version for adds one. *) + let arity_of (d : Ast.decl) = + match d.Ast.d with + | Ast.Defn fn -> Some (Check.defn_arity t.env fn) + | _ -> None + in + (* The bodies a version is compiled under are named for it when the name + has several; which of the two a check makes is decided there, so both + are named and whichever the program has is the one installed. *) let names = List.filter_map Ast.declared_name incoming @ List.filter_map (fun (d : Ast.decl) -> - match d.Ast.d with Ast.Defmethod m -> Some m.Ast.mgen | _ -> None) + match d.Ast.d with + | Ast.Defmethod m -> Some m.Ast.mgen + | Ast.Defn fn -> + Option.map (Check.version_name fn.Ast.name) (arity_of d) + | _ -> None) incoming in - let replacement n = - List.find_opt - (fun (d : Ast.decl) -> Ast.declared_name d = Some n) - incoming + let replaces (old_ : Ast.decl) (nd : Ast.decl) = + match Ast.declared_name old_, Ast.declared_name nd with + | Some a, Some b when String.equal a b -> + (match arity_of old_, arity_of nd with + | Some i, Some j -> i = j + | _ -> true) + | _ -> false in (* Replaced in place and appended only when genuinely new, so declaration order — which is emission order for globals — does not shuffle on every - evaluation. *) - let replaced = ref [] in + evaluation. A declaration that replaces several — a defonce sent over a + name that had two versions — takes the place of the first and the rest + go. *) + let used = ref [] in let kept = - List.map + List.filter_map (fun (d : Ast.decl) -> - match Ast.declared_name d with - | Some n -> - (match replacement n with - | Some nd -> replaced := n :: !replaced; nd - | None -> d) - | None -> d) + match List.find_opt (replaces d) incoming with + | Some nd when List.memq nd !used -> None + | Some nd -> used := nd :: !used; Some nd + | None -> Some d) t.decls in let added = List.filter (fun (d : Ast.decl) -> - match Ast.declared_name d with - | Some n -> not (List.exists (String.equal n) !replaced) - | None -> false) + Ast.declared_name d <> None && not (List.memq d !used)) incoming in let decls = kept @ added in @@ -1256,9 +1272,49 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr | _ -> None) program.Tast.fns in + (* A name that gains a second version in the loop is renamed, all of its + versions alike ([Check.split_versions]), so the body the process has + under the plain name is no longer the program's: the version it became + is a new symbol and is installed, and every compiled body that called the + plain name is compiled again, to call the version its arguments pick. + Asked of any callee the program no longer has, which is the same fact + seen from the call site: nothing else takes a function out of a program + whose callers still check. *) + let versions_moved = + let has n = + List.exists (fun (f : Tast.fn) -> String.equal f.Tast.name n) + program.Tast.fns + in + let fresh = + List.filter_map + (fun (f : Tast.fn) -> + if Check.version_of f.Tast.name <> None + && not (known t f.Tast.name || SM.mem f.Tast.name t.built) + then Some f.Tast.name + else None) + program.Tast.fns + in + let callers = + SM.fold + (fun fname (b : built) acc -> + if has fname + && List.exists (fun (st : site) -> not (has st.callee)) b.sites + then + match + List.find_opt (fun (f : Tast.fn) -> String.equal f.Tast.name fname) + program.Tast.fns + with + | Some { Tast.fparent = Some p; _ } when p <> "" -> p :: acc + | _ -> fname :: acc + else acc) + t.built [] + in + if fresh = [] then [] else fresh @ callers + in let fns = List.sort_uniq String.compare - (declared_fns @ def_inits @ from_generics @ new_instances @ prelude_moved) + (declared_fns @ def_inits @ from_generics @ new_instances @ prelude_moved + @ versions_moved) in (* A constant that changed and can be published: known to the host, not consumed by the checker. The module stores its new value at the frame diff --git a/lib/x86.ml b/lib/x86.ml index f6dbf3f3..c3bb4e57 100644 --- a/lib/x86.ml +++ b/lib/x86.ml @@ -1516,7 +1516,7 @@ let stale_check f ~(loc : Loc.t) name = l in let site = cstr (Loc.to_string loc) - and callee = cstr name + and callee = cstr (Check.written_name name) and want = cstr (Emit.sig_text ps r) in mov_rr f.b ~dst:rcx ~src:r11; lea f.b ~dst:rdi ~mm:(Sym (site, 0)); diff --git a/spec-syntax.md b/spec-syntax.md index d6b13f7d..75872b2b 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -395,6 +395,16 @@ Each item: the proposal, then the reason in one line. becomes `where is-ordered($t)` after the return type. **Built**; with no `-> R` the return is `_`, read off the body. Several predicates are `where p, q`. +- A name may have several versions, one per number of parameters: + `fn area(w: i32)` and `fn area(w: i32, h: i32)`. A call picks the version by + how many arguments it passes; types play no part, so two versions with the + same number of parameters are one function defined twice. A version may be + generic, and may call the others. `main` has one version. The name alone is + a value only where the wanted `Fn` type says how many parameters, as in + `apply(area, 6)` against `f: Fn(i32) -> i32`; anywhere else write a lambda, + `fn(w) => area(w, 2)`. In the dev loop a definition replaces the version with + its number of parameters and leaves the others; another number adds a + version. **Built** (decision 135a). - A `let` at the top level is a global: `let x = v`, `let x: T = v`, `let scratch: [4 u8] = uninit` read `(def x dyn v)`, `(def x T v)`; `once x: T`, `once x = v`, `const n = 3`. **Built.** `let x = v` and diff --git a/test/programs/dev-versions.fln b/test/programs/dev-versions.fln new file mode 100644 index 00000000..e18ff084 --- /dev/null +++ b/test/programs/dev-versions.fln @@ -0,0 +1,15 @@ +;; A name with two versions in a running program: redefining one version +;; from the editor replaces it alone, and the other keeps running. +import agent "vendor:agent" + +fn area(w: i32) -> i32 + w * w + +fn area(w: i32, h: i32) -> i32 + w * h + +fn main() -> i32 + agent/start("/tmp/flan-dev-versions-fallback.sock") + for i in range(4000) + agent/wait(5) + 0 diff --git a/test/programs/versions.fln b/test/programs/versions.fln new file mode 100644 index 00000000..9cf839c0 --- /dev/null +++ b/test/programs/versions.fln @@ -0,0 +1,73 @@ +;; One name, several versions: the number of arguments picks one (decision 135a). + +struct Grain + kind: i32 + +fn is-empty-cell(g: Grain) -> bool + g.kind == 0 + +;; One version calling another. +fn is-empty-cell(r: i32, c: i32) -> bool + is-empty-cell(Grain{.kind r * c}) + +fn area(w: i32) -> i32 + w * w + +fn area(w: i32, h: i32) -> i32 + w * h + +fn area(w: i32, h: i32, d: i32) -> i32 + area(w, h) * d + +;; A generic version beside a plain one. +fn pick(x: $t) -> $t + x + +fn pick(x: $t, y: $t, first: bool) -> $t + if first then x else y + +;; A version that recurses on itself and calls the other. +fn count(n: i32) -> i32 + count(n, 0) + +fn count(n: i32, acc: i32) -> i32 + if n == 0 then acc else count(n - 1, acc + n) + +;; defer runs per version. +fn noisy(a: i32) -> i32 + defer println("leaving noisy/1") + a + +fn noisy(a: i32, b: i32) -> i32 + defer println("leaving noisy/2") + a + b + +;; Untyped versions take dyn arguments, and the count still picks. +fn scale(x) + x * 10 + +fn scale(x, y) + x * y + +fn apply(f: Fn(i32) -> i32, x: i32) -> i32 + f(x) + +fn main() + println(is-empty-cell(Grain{.kind 0})) + println(is-empty-cell(Grain{.kind 2})) + println(is-empty-cell(3, 0)) + println(is-empty-cell(3, 4)) + println(area(3)) + println(area(3, 4)) + println(area(3, 4, 5)) + println(pick(7)) + println(pick(1.5, 2.5, false)) + println(pick("a", "b", true)) + println(count(10)) + println(noisy(1)) + println(noisy(1, 2)) + println(scale(4)) + println(scale(2.5, 2)) + ;; A wanted Fn type names the arity, so the name picks that version. + println(apply(area, 6)) + println(apply(fn(x) => area(x, 2), 6)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 1233fb1c..10b0e684 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2248,6 +2248,14 @@ let () = let if_let_kept_out = "1\n4\nnone\n6\nnone\n9\n2\nnone\n3\nnone\n5\nnil\n7\n" in + (* One name, several versions, picked by the number of arguments. *) + let versions_out = + "true\nfalse\ntrue\nfalse\n9\n12\n60\n7\n2.5\na\n55\n\ + leaving noisy/1\n1\nleaving noisy/2\n3\n40\n5\n36\n12\n" + in + outputs "versions by arity" "programs/versions.fln" versions_out; + outputs ~opt:"-O0" "versions by arity, -O0" "programs/versions.fln" versions_out; + outputs ~x86:true "versions by arity, --x86" "programs/versions.fln" versions_out; outputs "a kept if let chain" "programs/if-let-kept.fln" if_let_kept_out; outputs ~opt:"-O0" "a kept if let chain, -O0" "programs/if-let-kept.fln" if_let_kept_out; outputs ~x86:true "a kept if let chain, --x86" "programs/if-let-kept.fln" if_let_kept_out; diff --git a/test/test_dev.ml b/test/test_dev.ml index e7940991..95f815dd 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -5551,7 +5551,7 @@ let () = if not (await ~ms:10000 (fun () -> not (alive ()))) then fail "--two-process: the new child did not finish" else begin - let r = ev "(defn helper [x i64] i64 x)" in + let r = ev "(defn helper [] f64 1.25)" in if status r <> "ok" then fail "--two-process: a change while the child has ended: %s" (Option.value ~default:"" (Wire.string_field r "message")); @@ -5568,7 +5568,7 @@ let () = (fun code -> if status (ev code) <> "ok" then fail "--two-process: %s was refused" code) - [ "(defn user [] i64 (helper 5))"; "(defn step [] i64 (user))" ]; + [ "(defn user [] i64 (i64 (* (helper) 4.0)))"; "(defn step [] i64 (user))" ]; Buffer.clear seen; let r = ask "(:op \"rerun\")" in if status r <> "ok" then @@ -7540,6 +7540,74 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ fsock; fout ]) [ "x86"; "llvm" ]; + (* ── One name, two versions (decision 135a) ────────────────────────── + Redefining one version of a running program's function from a .fln + buffer replaces that version alone: the other still answers, and the + listing shows the name once with both signatures. *) + List.iter + (fun backend -> + let vsock = tmp ("versions" ^ backend ^ ".sock") + and vout = tmp ("versions" ^ backend ^ ".out") in + (try Sys.remove vsock with Sys_error _ -> ()); + let vfd = + Unix.openfile vout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let vpid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-versions.fln"; "-s"; vsock; + "--" ^ backend |] + Unix.stdin vfd Unix.stderr + in + Unix.close vfd; + if not (listening ~pid:vpid vsock) then begin + fail "the versions daemon (--%s) %s" backend !listen_why; + (try Unix.kill vpid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect vsock in + let file = "programs/dev-versions.fln" in + let ask code = + request c + (Printf.sprintf "(:op \"eval-expr\" :code %s :file %s)" + (Wire.quote code) (Wire.quote file)) + in + let answer r = + match Wire.string_field r "value" with + | Some v -> v + | None -> Option.value ~default:(status r) (Wire.string_field r "message") + in + let is what code want = + let a = answer (ask code) in + if a <> want then fail "--%s: %s answered %S, not %S" backend what a want + in + if not (await ~ms:20000 (fun () -> status (ask "1") = "ok")) then + fail "--%s: the versions program never took an expression" backend + else begin + is "the one-argument version" "area(3)" "9"; + is "the two-argument version" "area(3, 4)" "12"; + let r = + request c + (Printf.sprintf "(:op \"eval\" :code %s :file %s)" + (Wire.quote "fn area(w: i32, h: i32) -> i32\n w * h + 100") + (Wire.quote file)) + in + if status r <> "ok" then + fail "--%s: redefining one version: %s" backend + (Option.value ~default:(status r) (Wire.string_field r "message")); + is "the redefined version" "area(3, 4)" "112"; + is "the version left alone" "area(3)" "9"; + let defs = request c "(:op \"defs\")" in + let text = Form.to_string defs in + if not (contains_sub text "area [i32] i32 | area [i32 i32] i32") then + fail "--%s: defs did not list both versions of area: %s" backend text + end; + (try Unix.close c with Unix.Unix_error _ -> ()); + (try Unix.kill vpid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] vpid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ vsock; vout ]) + [ "x86"; "llvm" ]; + (* ── The dyn globals a park holds ─────────────────────────────────── *) (* The banner a finished run prints says the globals are as it left them, @@ -8383,7 +8451,7 @@ let () = | v -> fail "--%s: a capturing fn at the prompt answered %s" backend (Option.value ~default:"nothing" v)); - let r = eval "(defn scale [x i64 k i64] i64 (* x k))" in + let r = eval "(defn scale [x f64] i64 (i64 (* x 3.0)))" in if status r <> "ok" then fail "--%s: a signature change was refused: %s" backend (said r) else begin @@ -8415,7 +8483,7 @@ let () = if not (contains_sub fields want) then fail "--%s: StaleCall's fields do not show %S: %s" backend want fields) - [ "scale"; "[i64] i64"; "[i64 i64] i64" ]; + [ "scale"; "[i64] i64"; "[f64] i64" ]; (match Wire.string_field (request c "(:op \"break\")") "site" with | Some site when contains_sub site "dev-stale.flan:23:" -> () | Some site -> fail "--%s: the stale call's site is %s" backend site @@ -8424,7 +8492,7 @@ let () = let r = eval "(defn step [] i64 (set ticks (+ ticks 1)) \ - (set seen (scale ticks 3)) seen)" + (set seen (scale (f64 ticks))) seen)" in if status r <> "ok" then fail "--%s: recompiling the stale caller: %s" backend (said r) diff --git a/test/test_flan.ml b/test/test_flan.ml index 59b8221e..ad6bc76e 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1507,6 +1507,38 @@ let () = refuses_all ~fln:true "~~ in .fln" "fn f(a: bool) -> i32\n ~~a\n" "~~ works on the bits"; refuses_all ~fln:true "^^ in .fln" "fn f(a: bool, b: bool) -> bool\n a ^^ b == 0\n" "write a != b"; + (* ── One name, several versions (decision 135a) ─────────────────── *) + let two = "fn f(a: i32) -> i32\n a\n\nfn f(a: i32, b: i32) -> i32\n a + b\n\n" in + refuses_all ~fln:true "two versions of one arity are defined twice" + (two ^ "fn f(x: i64, y: i64) -> i64\n x\n") + "f is defined twice with 2 parameters"; + refuses_all ~fln:true "one arity written twice is defined twice" + "fn g(a: i32) -> i32\n a\n\nfn g(b: bool) -> i32\n 0\n" + "g is defined twice"; + refuses_all ~fln:true "main has one version" + "fn main()\n 0\n\nfn main(x: i32)\n 0\n" "main is defined twice"; + refuses_all ~fln:true "a call no version takes lists the versions" + (two ^ "fn h() -> i32\n f(1, 2, 3)\n") + "f has no version that takes 3 arguments. It has these:\n f(a: i32)\n \ + f(a: i32, b: i32)"; + refuses_all "and in parens, in the file's own spelling" + "(defn f [a i32] i32 a) (defn f [a i32 b i32] i32 (+ a b)) \ + (defn h [] i32 (f))" + "It has these:\n (f [a i32])\n (f [a i32 b i32])"; + refuses_all ~fln:true "the name alone is not a value" + (two ^ "fn h() -> i32\n let g = f\n 0\n") + "f has several versions, 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 fn(a) => f(a)"; + refuses_all ~fln:true "a wanted Fn type of another arity picks nothing" + (two ^ "fn h() -> i32\n let g: Fn(i32, i32, i32) -> i32 = f\n 0\n") + "f has several versions"; + refuses_all ~fln:true "an argument's refusal names the function as written" + (two ^ "fn h() -> i32\n f(true)\n") + "this is the 1st argument of f"; + refuses_all ~fln:true "fn takes no rest parameter to overlap a version" + "fn f(a: i32) -> i32\n a\n\nfn f(a: i32, & xs) -> i32\n a\n" + "& (a rest parameter) is not one"; rejects_check "popcount of a float" "(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64"; rejects_check "a rotation's count does not widen the value" @@ -6174,6 +6206,12 @@ let () = "(defstruct S [a i32])\n(defn f [s S] i32 (.b s))" "check/unknown-field"; kind_is "a name defined twice has a kind" "(defn f [] i32 1)\n(defn f [] i32 2)" "check/defined-twice"; + kind_is "a call no version takes has a kind" + "(defn f [] i32 1)\n(defn f [a i32] i32 a)\n(defn g [] i32 (f 1 2))" + "check/no-version"; + kind_is "a name with versions as a value has a kind" + "(defn f [] i32 1)\n(defn f [a i32] i32 a)\n(defn g [] i32 (let [h f] 0))" + "check/several-versions"; (* The note is the half a location and a string could never carry: the *other* place, with its own span and its own explanation. *) diff --git a/test/test_session.ml b/test/test_session.ml index f7bbcc17..87783cca 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -54,14 +54,15 @@ let () = each of these installs and names no stale caller. Dyn-ness is part of a signature like anything else; the last two are the changes the source does not spell out as a type. *) - let installs name src = + let installs ?(fn = "outer") ?(stale = []) name src = let t, _ = Session.create ~file:"programs/reload.flan" () in match Session.eval t src with | c -> - if not (List.mem "outer" c.Session.fns) then + if not (List.mem fn c.Session.fns) then fail "%s installed %s" name (String.concat " " c.Session.fns); - if c.Session.stale <> [] then - fail "%s left a caller behind that nothing has" name + if List.map (fun (x : Session.stale) -> x.Session.caller) c.Session.stale + <> stale + then fail "%s left the wrong callers behind" name | exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" name m in (* A session's defn named as a prelude macro shadows it for a later form @@ -77,11 +78,51 @@ let () = (String.concat " " c.Session.fns) | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a call to a session's clamp was expanded as the macro: %s" m); - installs "a changed parameter type" "(defn outer [x i64] i64 (bump))"; + (* A changed parameter keeps the number of them: another number is another + version of the name (decision 135a), below. [helper] is called from + [bump], which is left compiled against the old signature. *) + installs ~fn:"helper" ~stale:[ "bump" ] "a changed parameter type" + "(defn helper [x f64] i64 (i64 x))"; installs "a changed return type" "(defn outer [] i32 (i32 (bump)))"; - installs "a changed arity" "(defn outer [a i64 b i64] i64 (bump))"; installs "a return type that became dyn" "(defn outer [] dyn (bump))"; - installs "a parameter that became dyn" "(defn outer [x] i64 (bump))"; + installs ~fn:"helper" ~stale:[ "bump" ] "a parameter that became dyn" + "(defn helper [x] i64 7)"; + + (* Another number of parameters is another version of the name. Both + versions are renamed for their arities, so the one the process had under + the plain name is installed again under its new one; redefining one + version then replaces it alone and leaves the other in the program. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + match Session.eval t "(defn outer [a i64 b i64] i64 (+ a b (bump)))" with + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a second version was refused: %s" m + | c -> + if List.sort compare c.Session.fns <> [ "outer~0"; "outer~2" ] then + fail "a second version installed %s" (String.concat " " c.Session.fns); + if c.Session.stale <> [] then fail "a second version left a caller behind"; + (match Session.eval t "(defn outer [a i64 b i64] i64 (* a b))" with + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "redefining one version was refused: %s" m + | c -> + if c.Session.fns <> [ "outer~2" ] then + fail "redefining one version installed %s" + (String.concat " " c.Session.fns); + let names = + List.map (fun (f : Tast.fn) -> f.Tast.name) t.Session.program.Tast.fns + in + if not (List.mem "outer~0" names && List.mem "outer~2" names) then + fail "redefining one version lost the other")); + (* A compiled caller of the plain name is compiled again, to call the + version its arguments pick: [bump] calls [helper] with one argument. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + match Session.eval t "(defn helper [x i64 y i64] i64 (+ x y))" with + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a second version of a called function was refused: %s" m + | c -> + if List.sort compare c.Session.fns <> [ "bump"; "helper~1"; "helper~2" ] then + fail "a second version of a called function installed %s" + (String.concat " " c.Session.fns); + if c.Session.stale <> [] then + fail "a second version of a called function left a caller behind"); (* [main] is the exception: the startup code calls it, and that call was compiled into the program when it started. *) refuses ~file:"programs/dev-stale.flan" "a changed main" @@ -93,7 +134,7 @@ let () = with both signatures. [step]'s source no longer checks against the new arity, and that is not a reason to refuse: it is not being recompiled. *) (let t, _ = Session.create ~file:"programs/dev-stale.flan" () in - match Session.eval t "(defn scale [x i64 k i64] i64 (* x k))" with + match Session.eval t "(defn scale [x f64] i64 (i64 (* x 2.0)))" with | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a signature change with compiled callers was refused: %s" m | c -> @@ -107,12 +148,12 @@ let () = c.Session.stale in let want = - [ ("step", "scale", "[i64] i64", "[i64 i64] i64", 23); - ("pick", "scale", "[i64] i64", "[i64 i64] i64", 26); + [ ("step", "scale", "[i64] i64", "[f64] i64", 23); + ("pick", "scale", "[i64] i64", "[f64] i64", 26); (* The clause's call is named for the function it is written in, not for the lifted function it became. *) - ("guarded", "scale", "[i64] i64", "[i64 i64] i64", 45); - ("guarded", "scale", "[i64] i64", "[i64 i64] i64", 46) ] + ("guarded", "scale", "[i64] i64", "[f64] i64", 45); + ("guarded", "scale", "[i64] i64", "[f64] i64", 46) ] in if named <> want then fail "the stale callers were %s" @@ -123,7 +164,7 @@ let () = (* Recompiling a stale caller clears it, and only it. *) (match Session.eval t - "(defn step [] i64 (set ticks (+ ticks 1)) (set seen (scale ticks 3)) seen)" + "(defn step [] i64 (set ticks (+ ticks 1)) (set seen (scale (f64 ticks))) seen)" with | c -> (match c.Session.stale with @@ -175,9 +216,9 @@ let () = in let main_src = "(defn main [] i32 (agent/start \"/tmp/x.sock\") \ - (dotimes [i 6000] (agent/wait 5) (restart-case (step 1) (skip-frame [] 0))) 0)" + (dotimes [i 6000] (agent/wait 5) (restart-case (step) (skip-frame [] 0))) 0)" in - (match Session.eval t "(defn step [x i64] i64 (set seen (scale x)) seen)" with + (match Session.eval t "(defn step [] i32 (set seen (scale ticks)) (i32 seen))" with | c -> if mains c <> [ true ] then fail "a stale call in main was not flagged as running" | exception Loc.Error { Loc.dmsg = m; _ } -> fail "changing step: %s" m); @@ -192,10 +233,10 @@ let () = | exception Loc.Error { Loc.dmsg = m; _ } -> fail "after a re-run: %s" m)); (let t, _ = Session.create ~file:"programs/dev-stale.flan" () in ignore - (Session.eval ~running:false t "(defn step [x i64] i64 (set seen (scale x)) seen)"); + (Session.eval ~running:false t "(defn step [] i32 (set seen (scale ticks)) (i32 seen))"); match Session.eval ~running:false t - "(defn main [] i32 (dotimes [i 3] (restart-case (step 1) (skip-frame [] 0))) 0)" + "(defn main [] i32 (dotimes [i 3] (restart-case (step) (skip-frame [] 0))) 0)" with | c -> if List.exists (fun (x : Session.stale) -> x.Session.caller = "main") @@ -225,7 +266,7 @@ let () = tolerance is for a body compiled against a signature that changed, and [twice] here is new, in the form, and wrong. *) refuses ~file:"programs/dev-stale.flan" "a form that is wrong on its own" - "(defn scale [x i64 k i64] i64 (* x k)) (defn twice [] i64 (scale 1))" + "(defn scale [x f64] i64 (i64 x)) (defn twice [] i64 (scale ticks))" "scale"; (* The storage exists and has a shape: reusing it reads at the wrong offsets, @@ -923,7 +964,7 @@ let () = (let tp, _ = Session.create ~file:"programs/pkg-private.flan" () in match Session.eval ~origin:"programs/pkgs/secret/secret.flan" tp - "(defn- combine [a i32 b i32 c i32] i32 (mix a (+ b c)))" + "(defn- combine [a i32 b i64] i32 (mix a (i32 b)))" with | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a package function's signature change was refused: %s" m @@ -941,7 +982,7 @@ let () = (List.map (fun (n, f, l) -> Printf.sprintf "%s %s:%d" n f l) where)); (match Session.eval ~origin:"programs/pkg-private.flan" tp - "(defn main [] i32 (print (secret/combine 1 2 3)) 0)" + "(defn main [] i32 (print (secret/combine 1 2)) 0)" with | _ -> fail "a stale caller recompiled past a defn- was accepted" | exception Loc.Error { Loc.dmsg = m; _ } -> @@ -950,7 +991,7 @@ let () = (let tp, _ = Session.create ~file:"programs/pkg-private.flan" () in match Session.eval ~origin:"programs/pkgs/secret/secret.flan" tp - "(defn- mix [a i32 b i32 c i32] i32 (+ (* a 10) (+ b c)))" + "(defn- mix [a i32 b i64] i32 (+ (* a 10) (i32 b)))" with | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a private package function's signature change was refused: %s" m