diff --git a/TODO.org b/TODO.org index 9d9e232d..cd7817b8 100644 --- a/TODO.org +++ b/TODO.org @@ -71,6 +71,12 @@ 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 One fn form holds every arity of a name (decision 139, replacing 135a) +CLOSED: [2026-09-26] +Clojure's model: the grouped =fn f= is the unit of definition, a call's argument count picks +the arity, and each is renamed =f~N= only when there are two or more. Rules out adding an +arity from a separate definition (a second =fn f= is defined twice), overloading by type at +one arity, rest parameters on =fn=, and more than one =main=. ** 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/bin/main.ml b/bin/main.ml index 82fa4866..8256f9c0 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -888,7 +888,7 @@ let () = (* [as] where the other path has [llc], which is the number the whole backend exists to move. Named for what ran. *) Printf.eprintf "%s %s %s %.1fms ld %.1fms\n" out - (String.concat " " c.Flan.Session.fns) + (String.concat " " (Flan.Session.shown_fns c)) (if x86 then "as " else "llc") timing.Flan.Build.llc_ms timing.Flan.Build.link_ms) (* [run] builds and execs. A .wasm is not executable, and picking a runtime diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index b8dbb240..a227ec71 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -1291,6 +1291,23 @@ Before it at the same level, else out to the line that owns this block." ;; shifts rigidly and only when the first line is at no valid column, and a ;; yank moves its lines together. +(defun flan-fln--arity-line-p (pos) + "Non-nil if POS's line is an arity of a fn with several: it starts with +`(' and the line it is indented under is `fn NAME' with nothing after it." + (save-excursion + (goto-char pos) + (back-to-indentation) + (and (eq (char-after) ?\() + (let ((col (current-column)) (p (flan-fln--prev-code (point))) found) + (while (and p (not found)) + (if (< (flan-fln--indent-at p) col) + (setq found p) + (setq p (flan-fln--prev-code p)))) + (and found + (progn + (goto-char (flan-fln--first-char found)) + (looking-at "fn-?[ \t]+[^][ \t\n(){},;\":]+[ \t]*\\(?:;.*\\)?$"))))))) + (defun flan-fln--opener-p (start last) "Non-nil if the joined line START..LAST opens a block on the lines under it." (or (save-excursion @@ -1314,6 +1331,12 @@ Before it at the same level, else out to the line that owns this block." (looking-at "[ \t]+[^][ \t\n(){},;\":]+(")))) ((member w '("if" "when" "elif")) (not (flan-fln--then start))) (t t))))) + ;; An arity under `fn f', `(a: i32) -> i32', opens its block unless + ;; it is the one-line `(a: i32) -> i32 = a'. + (and (flan-fln--arity-line-p start) + (save-excursion + (goto-char (flan-fln--first-char start)) + (not (re-search-forward "[ \t]=[ \t]" (flan-fln--code-end last) t)))) ;; `let r = match n', `x = if c', `fn f(x) = match x', a lambda ;; header: the value goes on under the line. (flan-fln--value-opens-p start) @@ -1867,8 +1890,11 @@ lambda or a `Fn(...)' type, and not after a match arm's." (and open (progn (goto-char open) - (looking-back "\\(?:^[ \t]*fn-?[ \t]+[^][ \t\n(){},;\":]+\\|\\_ i32 = 1\n|" 1) 0) +;; A fn with several arities: `fn f' alone, a `(params) -> R' line per arity +;; under it, and each arity's block under that. +(test-flan-fln--is "after fn f alone, its arities go one level deeper" + (test-flan-fln--tabs "fn area\n|" 1) 2) +(test-flan-fln--is "after an arity, its block one level deeper again" + (test-flan-fln--tabs "fn area\n (w: i32) -> i32\n|" 1) 4) +(test-flan-fln--is "and after an untyped arity" + (test-flan-fln--tabs "fn scale\n (x, y)\n|" 1) 4) +(test-flan-fln--is "but not after a one-line arity" + (test-flan-fln--tabs "fn area\n (w: i32) -> i32 = w * w\n|" 1) 2) +(test-flan-fln--is "the next arity steps out to the arities' column" + (test-flan-fln--tabs "fn area\n (w: i32) -> i32\n w * w\n|" 2) 2) +(test-flan-fln--is "a parenthesised line in a plain fn's body is no arity" + (test-flan-fln--tabs "fn f() -> ()\n (a)\n|" 1) 2) +(test-flan-fln--in "fn area\n (w: i32) -> Area\n w * w\n (w: i32, h: i32) -> Area = w * h\n" + (font-lock-ensure) + (let ((case-fold-search nil) + (face (lambda (needle) + (save-excursion (goto-char (point-min)) (search-forward needle) + (get-text-property (match-beginning 0) 'face))))) + (test-flan-fln--is "a grouped fn's name is a function name" + (funcall face "area") 'font-lock-function-name-face) + (test-flan-fln--is "and fn is a keyword" (funcall face "fn") 'font-lock-keyword-face) + (test-flan-fln--is "an arity's return type is a type" + (funcall face "Area") 'font-lock-type-face) + (test-flan-fln--is "and the one-line arity's" + (save-excursion (goto-char (point-min)) (search-forward "Area =") + (get-text-property (match-beginning 0) 'face)) + 'font-lock-type-face))) (test-flan-fln--is "after if let, one level deeper" (test-flan-fln--tabs "fn f() -> ()\n if let Some(g) = o\n|" 1) 4) (test-flan-fln--is "and after a when with a block" diff --git a/emacs/test-flan.el b/emacs/test-flan.el index f1bf3f6f..6021b4dd 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -1920,6 +1920,18 @@ already rely on it — so nothing here is a stand-in for the real thing." (user-error (setq raised (error-message-string err)))) (and raised (string-match-p "not a function" raised)))) + ;; A fn with several arities is compiled under a name per arity, and the + ;; install is said with the name written, once. + (let* ((file (concat socket3 "-arities.flan")) + (r (flan--request + (list :op "eval" :file file + :code "(defn grp ([a i64] i64 a) ([a i64 b i64] i64 (+ a b)))"))) + (said (test-flan--said (flan--report r "form")))) + (test-flan--check "a fn with two arities is installed under the name written, once" + (and said + (string-match-p "\\`flan: grp installed in" said) + (not (string-match-p "~\\|(also" said))))) + ;; A generic has no code under its own name, only a copy per type it is ;; called at, so its name is answered with those: refused while there are ;; none, and one listing per copy, each headed by its types, once there diff --git a/lib/ast.ml b/lib/ast.ml index a494b837..e6884f76 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -282,6 +282,11 @@ type fn = { fbody : expr list; nloc : Loc.t; fprivate : privacy; + (* The fn form this is one arity of, when the form has several — an id + [Parse.splice] mints per form, so two arities are one definition exactly + when they carry the same one (decision 139). [None] is a fn written on + its own, which shares its name with nothing. *) + fgroup : int option; } type decl = { d : decl_kind; dloc : Loc.t } diff --git a/lib/check.ml b/lib/check.ml index f0c7a1e5..3170bebc 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 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; @@ -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 @@ -4038,6 +4044,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 @@ -7158,6 +7193,55 @@ 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) + | 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; @@ -7179,7 +7263,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 @@ -11493,12 +11577,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 = @@ -16464,6 +16549,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 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 @@ -16771,6 +16869,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 \ @@ -16779,10 +16878,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 -> @@ -16813,7 +16944,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 @@ -16970,7 +17101,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; @@ -16980,14 +17111,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 @@ -17004,7 +17135,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 @@ -17021,7 +17152,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 @@ -17075,7 +17206,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)) @@ -17119,7 +17250,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 @@ -17152,13 +17283,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); @@ -17210,8 +17341,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 @@ -18142,15 +18273,21 @@ let () = 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" fn.Ast.nloc + (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" @@ -18288,6 +18425,85 @@ 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 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) @@ -18347,21 +18563,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 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) + | 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) = @@ -18500,6 +18721,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 @@ -19070,7 +19292,7 @@ let rec check_fn ?sign env (fn : Ast.fn) : Tast.fn = 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" fn.Ast.name + 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, @@ -20589,6 +20811,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/cimport.ml b/lib/cimport.ml index b0f786c3..35a4d72b 100644 --- a/lib/cimport.ml +++ b/lib/cimport.ml @@ -856,7 +856,7 @@ let of_dump ~env ~taken ~bound_syms ~config (d : dump) : imported = decls := { Ast.d = Ast.DeclareC - ({ Ast.name = flan; params; praw = None; ret; fwhere = []; fbody = []; nloc = f.cloc; fprivate = Ast.Exported }, + ({ Ast.name = flan; params; praw = None; ret; fwhere = []; fbody = []; nloc = f.cloc; fprivate = Ast.Exported; fgroup = None }, f.csym); dloc = f.cloc } :: !decls) diff --git a/lib/classes.ml b/lib/classes.ml index 2f3685aa..9d75fa62 100644 --- a/lib/classes.ml +++ b/lib/classes.ml @@ -80,7 +80,7 @@ let migrate_decls loc : Ast.decl list = { Ast.name = migrate_generic; params = [ p "instance"; p "added"; p "discarded" ]; praw = None; ret = Some (dyn_at loc); fwhere = []; fbody = body; nloc = loc; - fprivate = Ast.Exported } + fprivate = Ast.Exported; fgroup = None } in [ { Ast.d = Ast.Defgeneric (fn []); dloc = loc }; { Ast.d = @@ -224,7 +224,7 @@ let constructor n (slots : Ast.field list) loc : Ast.decl = Ast.Defn { Ast.name = n; params; praw = None; ret = Some (dyn_at loc); fwhere = []; fbody = [ ex loc (Ast.MapLit (Some n, pairs)) ]; - nloc = loc; fprivate = Ast.Exported }; + nloc = loc; fprivate = Ast.Exported; fgroup = None }; dloc = loc } (* The dispatch value a method answers for, as an expression to compare diff --git a/lib/dev.ml b/lib/dev.ml index a3070c48..505eaeb5 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -676,6 +676,30 @@ 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 + +(* The body a stack frame is running, by the name it was compiled under. A + frame can outlive its name: a fn given a second arity has its first + compiled under a new one, and the frame still running the old body names + the old — the process's own, which is what it was built with. *) +let frame_fn t name = + match find_fn t name with + | Some f -> Some f + | None -> + List.find_opt + (fun (f : Tast.fn) -> + String.equal f.Tast.name name && f.Tast.fparent = None) + t.session.Session.host.Tast.fns + let fn_loc t name = match find_fn t name with | Some f -> Loc.to_string f.Tast.floc @@ -1024,7 +1048,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 "") @@ -1155,7 +1180,7 @@ let eval ?forms ?base ?(extra = []) ?(step = false) t ~code ~origin ~pause = c.Session.fns; ok ([ ":names " ^ Wire.strings c.Session.names; - ":fns " ^ Wire.strings c.Session.fns; + ":fns " ^ Wire.strings (Session.shown_fns c); Printf.sprintf ":ms %.1f" (timing.Build.llc_ms +. timing.Build.link_ms) ] @ stale_field c.Session.stale @@ -1651,8 +1676,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 +1722,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 +1805,40 @@ 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 + (* Where the fn form starts, which is where M-. should land: the + arities' own locations are their lines under it. *) + let form_loc = + List.find_map + (fun (d : Ast.decl) -> + match d.Ast.d with + | Ast.Defn fn when String.equal fn.Ast.name base -> Some d.Ast.dloc + | _ -> None) + t.session.Session.decls + 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 (Option.value ~default:f.Tast.floc form_loc)) + ()) + | _ -> 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 = @@ -2577,13 +2636,13 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = | Some (name, _, mine, nslots, sig_, _rsig) -> if not mine then Error - (name + (Check.shown_name name ^ " is a frame of the expression this break is inside, not of the program, so there is no record of what its slots are called") else - match find_fn t name with + match frame_fn t name with | None -> Error - (name + (Check.shown_name name ^ " is not a function this session holds; a lifted handler clause has no declaration of its own to read slot names from") | Some fn -> (* The two body checks come first, including for a frame @@ -2595,7 +2654,8 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = Error (Printf.sprintf "%s on the stack has %d slots and the %s this session holds has %d — the frame is running a body that has been redefined since" - name nslots name (Emit.recorded_slots fn)) + (Check.shown_name name) nslots (Check.shown_name name) + (Emit.recorded_slots fn)) else if sig_ <> Emit.slot_fingerprint fn then (* The count matching is not the same as the body matching. A redefinition that renames a local, or changes its type @@ -2608,7 +2668,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = Error (Printf.sprintf "%s on the stack was compiled from a different body than the %s this session holds — it was redefined after this frame was entered, so its names no longer describe its values" - name name) + (Check.shown_name name) (Check.shown_name name)) else Ok (name, fn))) (* [:frame N] on [eval-expr] is SLIME's eval-in-frame: the expression sees @@ -2682,7 +2742,7 @@ let locals t ~frame = | Ok (name, fn) -> if Emit.recorded_slots fn = 0 then ok - [ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()"; + [ ":frame " ^ Wire.quote (Check.shown_name name); ":locals ()"; ":refused ()"; ":note " ^ Wire.quote "this frame has no named locals" ] else (match bound_slots t ~frame with @@ -2729,7 +2789,7 @@ let locals t ~frame = | Error m -> error m | Ok (entries, refused) -> ok - [ ":frame " ^ Wire.quote name; + [ ":frame " ^ Wire.quote (Check.shown_name name); ":locals " ^ Wire.list entries; ":refused " ^ Wire.list @@ -2914,7 +2974,7 @@ let inspect t ~frame ~slot ~path = | Error why -> error why | Ok (label, ty, v, addr) -> ok - ([ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label; + ([ ":frame " ^ Wire.quote (Check.shown_name name); ":name " ^ Wire.quote label; ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ] @ (match addr with (* Unsigned, as an address is. *) @@ -3034,7 +3094,7 @@ let set_slot t ~frame ~slot ~path ~edits ~expect_stop = the program's truth, which is the only reason it is worth redrawing. *) ok - [ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label; + [ ":frame " ^ Wire.quote (Check.shown_name name); ":name " ^ Wire.quote label; ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v; ":wrote " ^ string_of_int (List.length edits); ":at-stop " @@ -3446,7 +3506,9 @@ let globals_op t = List.iteri (fun i (name, _, mine, nslots, sig_, rsig) -> let skip why = - skipped := (Printf.sprintf "%d: %s" i name, why) :: !skipped + skipped := + (Printf.sprintf "%d: %s" i (Check.shown_name name), why) + :: !skipped in if not mine then skip @@ -3454,7 +3516,7 @@ let globals_op t = program; its thunk is not part of the session, so there is no \ record of what it refers to" else - match find_fn t name with + match frame_fn t name with | None -> skip "not a function this session holds; a lifted handler clause \ @@ -4445,6 +4507,32 @@ 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 <> [] -> + (* Each arity under the name written, with its count beside it: the + name it is compiled under is nobody's to read. *) + let entry (f : Tast.fn) = + let own = + [ ":name " ^ Wire.quote name; + ":arity " ^ string_of_int (List.length f.Tast.params) ] + in + match disassemble_fn t ~name:f.Tast.name ~form f with + | Ok fields -> + Wire.list + (own + @ List.filter + (fun fl -> not (String.starts_with ~prefix:":name " fl)) + fields) + | Error m -> + Wire.list + (own + @ [ ":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 73c595aa..6578ef16 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -106,6 +106,10 @@ let sig_text (params : Types.t list) (ret : Types.t) = (String.concat " " (List.map Types.to_string params)) (Types.to_string ret) +(* The word a retired body's cell holds, which no call site's compare + matches: a signature hashing to zero is a one in 2^64 chance. *) +let retired_word = 0L + let sig_word params ret = let s = sig_text params ret in let h = ref 0xcbf29ce484222325L in @@ -3154,7 +3158,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"; @@ -5968,7 +5973,8 @@ let thunk_makes_fn_values (p : Tast.program) name = let redefinition ?(checks = true) ?(dev = false) ?(debug = false) ?(known = fun _ -> true) ?(retains = true) - ?call ?(consts = []) ?(annotate = false) (p : Tast.program) ~fns + ?call ?(consts = []) ?(retire = []) ?(annotate = false) + (p : Tast.program) ~fns : string = (* A dev build places closures under the dev rule: a named callee can be replaced by a redefinition that keeps what it was handed. See @@ -6087,7 +6093,16 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) Printf.sprintf "%s = internal global ptr null\n" (cellptr f.Tast.name))) lifted_targets; - if new_fns <> [] || new_globals <> [] then + (* A retired body's cell: the host's, or the registry's for a name the + host never had. *) + List.iter + (fun (n, _) -> + if known n then + Buffer.add_string m.out + (Printf.sprintf "%s = external global %s\n" (cellname n) cell_ty)) + retire; + if new_fns <> [] || new_globals <> [] + || List.exists (fun (n, _) -> not (known n)) retire then Buffer.add_string m.out "\ndeclare ptr @flan_dev_cell(ptr)\n\ declare ptr @flan_dev_global(ptr, i64, ptr)\n"; @@ -6200,6 +6215,31 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false) publish t f end) targets; + (* A body the program no longer has, which a caller not compiled again + may still reach: its cell keeps the body and takes a word no signature + hashes to, so every call site's compare fails and the call stops on + StaleCall, with the text of what the name is now. *) + List.iter + (fun (n, now) -> + let cell = + if known n then cellname n + else begin + let t = fresh () in + Buffer.add_string b + (Printf.sprintf " %s = call ptr @flan_dev_cell(ptr %s)\n" t + (fi_cstring m (Mangle.sym n))); + t + end + in + let wp = fresh () and tp = fresh () in + Buffer.add_string b + (Printf.sprintf + " %s = getelementptr inbounds i8, ptr %s, i64 8\n \ + store i64 %Ld, ptr %s\n \ + %s = getelementptr inbounds i8, ptr %s, i64 16\n \ + store ptr %s, ptr %s\n" + wp cell retired_word wp tp cell (cstring m now) tp)) + retire; Buffer.add_string m.out (Printf.sprintf "\ndefine void @flan_reload_install() {\nentry:\n%s ret void\n}\n" (Buffer.contents b)); diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index 8a8dbdb2..c5e974ff 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -1088,6 +1088,45 @@ and label_of = function | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest) | rest -> ("", rest) +(* One arity of a [defn] at indent [n]: [pre] and its parenthesised + parameters, the arrow and where clause, then the body as [= x] on the line + or as a block under it. [pre] is [fn name] for a one-arity fn and empty for + an arity line under a grouped one. *) +and arity_lines (f : Form.t) n pre ps (ret : Form.t) body = + let i = ind n in + match params_text ~shaped:true ps with + | None -> None + | Some pt -> + let where_, body = + match body with + | { Form.v = Form.Map [ { Form.v = Form.Kw "where"; _ }; x ]; _ } :: rest -> + let preds = + match x.v with + | Form.Vec (_ :: _ :: _ as xs) -> commas xs + | _ -> at 0 x + in + (" where " ^ preds, rest) + | _ -> ("", body) + in + let head = + i ^ pre ^ "(" ^ pt ^ ")" + (* [_] is what the reader makes of no arrow at all. *) + ^ (match ret.v with Form.Sym "_" -> "" | _ -> " -> " ^ ty ret) + ^ where_ + in + (match body with + | [] -> Some [ head ] + | [ x ] when (match x.v with + | Form.List (({ v = Form.Sym h; _ } as hf) :: args) -> + (* A call that takes a block is a statement, not a value. *) + not (List.mem h sugar_heads) && body_split hf args = None + && lambda_value (n + 2) "" x = None + | _ -> lambda_value (n + 2) "" x = None) + && String.length head + 3 + String.length (at 0 x) <= width + && not (!inside f) -> + Some [ head ^ " = " ^ unit_text x ] + | _ -> Some (head :: block (n + 2) body)) + and sugar n (f : Form.t) : string list option = let i = ind n in match f.v with @@ -1289,41 +1328,34 @@ and sugar n (f : Form.t) : string list option = | _ when (match lambda_parts f with Some (_, body) -> wants_block f body | None -> false) -> let head, body = Option.get (lambda_parts f) in Some ((i ^ head ^ " =>") :: lambda_block n body) + (* Several arities, Clojure's [(defn f ([a] ...) ([a b] ...))]: [fn f] and + a line per arity under it (decision 139). *) + | Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ } + :: (_ :: _ as clauses)) + when def_name name + && List.for_all + (fun (c : Form.t) -> + match c.v with + | Form.List ({ v = Form.Vec _; _ } :: _ :: _) -> true + | _ -> false) + clauses -> + let arities = + List.map + (fun (c : Form.t) -> + match c.v with + | Form.List ({ v = Form.Vec ps; _ } :: ret :: body) -> + arity_lines f (n + 2) "" ps ret body + | _ -> None) + clauses + in + if List.mem None arities then None + else + Some ((i ^ (if d = "defn" then "fn " else "fn- ") ^ name) + :: List.concat_map Option.get arities) | Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ } :: { v = Form.Vec ps; _ } :: ret :: body) when def_name name -> - (match params_text ~shaped:true ps with - | None -> None - | Some pt -> - let where_, body = - match body with - | { v = Form.Map [ { v = Form.Kw "where"; _ }; x ]; _ } :: rest -> - let preds = - match x.v with - | Form.Vec (_ :: _ :: _ as xs) -> commas xs - | _ -> at 0 x - in - (" where " ^ preds, rest) - | _ -> ("", body) - in - let head = - i ^ (if d = "defn" then "fn " else "fn- ") ^ name ^ "(" ^ pt ^ ")" - (* [_] is what the reader makes of no arrow at all. *) - ^ (match ret.v with Form.Sym "_" -> "" | _ -> " -> " ^ ty ret) - ^ where_ - in - (match body with - | [] -> Some [ head ] - | [ x ] when (match x.v with - | Form.List (({ v = Form.Sym h; _ } as hf) :: args) -> - (* A call that takes a block is a statement, not a value. *) - not (List.mem h sugar_heads) && body_split hf args = None - && lambda_value (n + 2) "" x = None - | _ -> lambda_value (n + 2) "" x = None) - && String.length head + 3 + String.length (at 0 x) <= width - && not (!inside f) -> - Some [ head ^ " = " ^ unit_text x ] - | _ -> Some (head :: block (n + 2) body))) + arity_lines f n ((if d = "defn" then "fn " else "fn- ") ^ name) ps ret body | Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ } :: { v = Form.Sym name; _ } :: rest) when def_name name -> diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index c2e39c01..57ab2e27 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -2535,7 +2535,10 @@ and header (s : st) w : Form.t = match w with | "fn" | "fn-" -> let name = name_tok p ~what:"the function's name" in - let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in + let head = if w = "fn" then "defn" else "defn-" in + (* One arity: the parameters, from their open paren on, through the end + of the body. *) + let arity (lp : token) = let ps = params p lp in let rp = last p in (* No arrow reads the return type off the body: the paren syntax's [_] @@ -2602,8 +2605,40 @@ and header (s : st) w : Form.t = if (peek p).tok = INDENT then block s ~after:"fn" else [] | _ -> stray p ~after:ret_text in - named (if w = "fn" then "defn" else "defn-") - (name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body)) + Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body) + in + (match (peek p).tok with + (* [fn f] with its arities under it, one [(params) -> R] line each + (decision 139). Reads [(defn f ([a T] R body) ([a T b T] R body))], + Clojure's multi-arity defn. *) + | NEWLINE when (peek_at p 1).tok = INDENT -> + ignore (advance p); + ignore (advance p); + let rec arities acc = + match (peek p).tok with + | DEDENT -> ignore (advance p); List.rev acc + | EOF -> List.rev acc + | NEWLINE -> ignore (advance p); arities acc + | LP -> + let lp = advance p in + let items = arity lp in + arities (mk p lp.loc (Form.List items) :: acc) + | tk -> + failk "fn-arity" (where_ p) + "under fn %s each line is one arity, its parameters in \ + parentheses and its block under it, as in (a: i32) -> i32. \ + Found %s" + (text_of name) (show tk) + in + (match arities [] with + | [] -> + failk "fn-arity" l0 "fn %s has no arities under it" (text_of name) + | cs -> named head (name :: cs)) + | _ -> + let lp = + glued_lp p ~what:"the parameters, in parentheses glued to the name" + in + named head (name :: arity lp)) | "def" | "once" | "const" -> def_form s w t l0 | "struct" | "union" -> let name = name_tok p ~what:"the type's name" in diff --git a/lib/paren_printer.ml b/lib/paren_printer.ml index d977ad87..c8a9b608 100644 --- a/lib/paren_printer.ml +++ b/lib/paren_printer.ml @@ -304,8 +304,15 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list = in go 0 rest in + (* A defn with several arities keeps only its name on the head's + line, and each arity goes on a line of its own. *) + let k = + match h, rest with + | ("defn" | "defn-"), _ :: { Form.v = Form.List ({ Form.v = Form.Vec _; _ } :: _); _ } :: _ -> 1 + | _ -> kept h + in bracket "(" ")" items - ~keep:(1 + label + max (min lead (n - 1)) (min (kept h) (n - label))) + ~keep:(1 + label + max (min lead (n - 1)) (min k (n - label))) else fill items | Form.List items -> bracket "(" ")" items ~keep:0 | Form.Vec items -> bracket "[" "]" items ~keep:0 diff --git a/lib/parse.ml b/lib/parse.ml index ca461c4f..bf3c2568 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1674,9 +1674,21 @@ let rec decl (f : Form.t) : Ast.decl = way for a signature to change with nothing redefined. *) (* [defn-] is a [defn] in every respect but one: [Check.private_ref] refuses a use of it from outside the package that declares it. *) - | List ({ v = Sym ("defn" | "defn-" as head); _ } :: args) -> + | List ({ v = Sym ("defn" | "defn-" | "defn~arity" | "defn-~arity" as head); _ } + :: args) -> let fprivate = - if String.equal head "defn-" then Ast.Private_to_package else Ast.Exported + if String.equal head "defn-" || String.equal head "defn-~arity" then + Ast.Private_to_package + else Ast.Exported + in + (* One arity of a fn with several, as [splice] wrote it: the form's id + comes first. No reader can spell the head, since [~] ends a symbol. *) + let head, fgroup, args = + match head, args with + | ("defn~arity" | "defn-~arity"), { v = Int id; _ } :: rest -> + ((if head = "defn~arity" then "defn" else "defn-"), + Some (Int64.to_int id), rest) + | _ -> (head, None, args) in (match args with | n :: { v = Vec ps; _ } :: ret :: body -> @@ -1713,7 +1725,7 @@ let rec decl (f : Form.t) : Ast.decl = let fwhere, body = constraints body in mk (Ast.Defn { Ast.name = dname n; params = []; praw = Some (pitems ps); ret = Some rty; fwhere; fbody = body_of body; - nloc = n.loc; fprivate }) + nloc = n.loc; fprivate; fgroup }) | _ -> fail f "%s is (%s name [param Type ...] ReturnType body ...). The return \ @@ -1789,7 +1801,7 @@ let rec decl (f : Form.t) : Ast.decl = else fun fn -> Ast.Defmulti fn) { Ast.name = dname n; params = dyn_params which ps; praw = None; ret = Some (texpr ret); fwhere = []; fbody = body_of body; - nloc = n.loc; fprivate = Ast.Exported }) + nloc = n.loc; fprivate = Ast.Exported; fgroup = None }) | _ -> fail f "%s" usage) | List ({ v = Sym "defmethod"; _ } :: args) -> @@ -1803,7 +1815,7 @@ let rec decl (f : Form.t) : Ast.decl = mfn = { Ast.name = gen ^ "@" ^ Ast.dispatch_text k; params = dyn_params "defmethod" ps; praw = None; ret = None; fwhere = []; fbody = body_of body; - nloc = n.loc; fprivate = Ast.Exported } }) + nloc = n.loc; fprivate = Ast.Exported; fgroup = None } }) | _ -> fail f "defmethod is (defmethod generic dispatch [param ...] body ...). \ @@ -1835,11 +1847,11 @@ let rec decl (f : Form.t) : Ast.decl = | [ n; { v = Form.Vec ps; _ } ] -> mk (mkd { Ast.name = dname n; params = fields f ps; praw = None; ret = None; fwhere = []; fbody = []; nloc = n.loc; - fprivate = Ast.Exported } csym) + fprivate = Ast.Exported; fgroup = None } csym) | [ n; { v = Form.Vec ps; _ }; r ] -> mk (mkd { Ast.name = dname n; params = fields f ps; praw = None; ret = Some (texpr r); fwhere = []; fbody = []; - nloc = n.loc; fprivate = Ast.Exported } csym) + nloc = n.loc; fprivate = Ast.Exported; fgroup = None } csym) | _ -> fail f "%s" usage) | _ -> fail f "%s" usage) @@ -2112,7 +2124,7 @@ let rec decl (f : Form.t) : Ast.decl = leave off. *) praw = None; ret = Some form_t; fwhere = []; fbody = macro_body sg body; - nloc = n.loc; fprivate = Ast.Exported }) + nloc = n.loc; fprivate = Ast.Exported; fgroup = None }) | _ -> fail f "defmacro is (defmacro name [param ...] body ...)") @@ -2302,10 +2314,57 @@ let with_imported ?(decls = []) ?(fns = []) (ms : Form.t list) It is spliced *after* expansion and before the declaration walk, so what is spliced is already fully expanded — a [do] holding a call to another macro settled before it got here. *) +(* Mints the id each fn form with several arities gives its arities. Never + reset: a session holds declarations from many parses, and two forms must + never share one. *) +let groups = ref 0 + let rec splice (f : Form.t) : Form.t list = match f.Form.v with | Form.List ({ Form.v = Form.Sym "do"; _ } :: items) -> List.concat_map splice items + (* A defn with several arities, Clojure's [(defn f ([a] ...) ([a b] ...))] + (decision 139), is one [defn] per arity from here on, each carrying the + id this form is given, which is what tells [Check] they were written as + one definition and not as two of one name. An id and not a location: a + macro's expansion puts the call's location on every form it writes. The + arities keep the whole form's location, which a message about the fn as + a whole points at, and each name carries its own arity's. *) + | Form.List + ({ Form.v = Form.Sym ("defn" | "defn-"); _ } as head + :: ({ Form.v = Form.Sym _; _ } as n) :: (_ :: _ as clauses)) + when List.for_all + (fun (c : Form.t) -> + match c.Form.v with + | Form.List ({ Form.v = Form.Vec _; _ } :: _) -> true + | _ -> false) + clauses -> + incr groups; + let id = { f with Form.v = Form.Int (Int64.of_int !groups) } in + let head = + match head.Form.v with + | Form.Sym h -> { head with Form.v = Form.Sym (h ^ "~arity") } + | _ -> head + in + List.map + (fun (c : Form.t) -> + match c.Form.v with + | Form.List ({ Form.v = Form.Vec ps; _ } :: _ as items) -> + (* A rest parameter would take every count from its own up, and + an arity is one count. *) + List.iter + (fun (q : Form.t) -> + if q.Form.v = Form.Sym "&" then + Loc.failk "parse/arity-rest" q.Form.loc + "an arity takes a fixed number of parameters, and & would \ + take any number from here up. Take the rest as one \ + parameter, a slice") + ps; + { f with Form.v = + Form.List (head :: id :: { n with Form.loc = c.Form.loc } + :: items) } + | _ -> assert false) + clauses | _ -> [ f ] let parse_forms ~keep_going (forms : Form.t list) : Ast.decl list = diff --git a/lib/session.ml b/lib/session.ml index 18d7ad5a..c514bc67 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -187,6 +187,14 @@ let stale_sites ?(live = SM.empty) ?(running = false) else " of " ^ Filename.basename l.Loc.file)) | _ -> None in + let arities n = + List.filter_map + (fun (f : Tast.fn) -> + if f.Tast.fparent = None && String.equal (Check.written_name f.Tast.name) n + then Some (Emit.sig_text f.Tast.params f.Tast.ret) + else None) + p.Tast.fns + in (* Named by the declaration a body belongs to: a clause lifted out of [step] is [step]'s call, and a generic's copy is the generic's. *) let from ~kept m acc = @@ -200,7 +208,20 @@ let stale_sites ?(live = SM.empty) ?(running = false) { caller = b.owner; target = st.callee; compiled = st.csig; current = now; at = st.sloc; running; cause = cause st } :: acc - | _ -> acc) + | Some _ -> acc + | None -> + (* The callee's name is still a function, under other arities + than the one this site was compiled for: that arity was + removed, or the name's arities were renamed around it. A + caller that still checked was compiled again, so what is + left here is one that no longer can. *) + (match arities (Check.written_name st.callee) with + | [] -> acc + | now -> + { caller = b.owner; target = st.callee; compiled = st.csig; + current = String.concat " or " now; at = st.sloc; running; + cause = None } + :: acc)) acc b.sites) m acc in @@ -669,6 +690,18 @@ type change = { stale : stale list; } +(* The bodies a change installed, as whoever reads the reply wrote them: a + fn with several arities is compiled under a name per arity, and is one + name to the person who sent it. [fns] itself stays by symbol — the + daemon's module ownership is keyed on it. *) +let shown_fns (c : change) = + List.fold_left + (fun acc f -> + let n = Check.written_name f in + if List.mem n acc then acc else n :: acc) + [] c.fns + |> List.rev + (* [pause] is [C-u C-c C-c]: the position, in the source just sent, of the form the program should stop at — TODO.org, "A breakpoint is marked from the editor, without editing the buffer". It arrives as a separate field @@ -690,14 +723,15 @@ type change = { which is the crossed pair [flan.abi.x86] exists to refuse at [dlopen]. A refusal a user can read is the right answer; a segfault three frames later is not. *) -let redefinition (t : t) ?retains ?call ?(consts = []) program ~fns = +let redefinition (t : t) ?retains ?call ?(consts = []) ?(retire = []) program + ~fns = if not t.x86 then Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t) ?retains - ~consts ?call ~annotate:true program ~fns + ~consts ~retire ?call ~annotate:true program ~fns else match X86.redefinition ~checks:true ~dev:true ~known:(known t) ?retains ~consts - ?call ~annotate:true program ~fns + ~retire ?call ~annotate:true program ~fns with | asm -> asm (* The dev backend covers a subset of the IR and refuses the rest by name, @@ -964,38 +998,46 @@ 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 fn form is every arity of its name (decision 139), so it replaces all + of them: an arity the new form lacks is gone, and its compiled callers + are stale. The names here are the names written; the bodies of a fn + with several arities are compiled under names of their own, which only + the check knows ([arity_syms] below). *) 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) incoming + (* Once each: the arities of one fn are one declaration apiece. *) + |> List.fold_left (fun acc n -> if List.mem n acc then acc else n :: acc) [] + |> List.rev in - let replacement n = - List.find_opt - (fun (d : Ast.decl) -> Ast.declared_name d = Some n) - incoming + let incoming_named n = + List.filter (fun (d : Ast.decl) -> Ast.declared_name d = Some n) incoming 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. *) + evaluation. The first declaration of a name takes everything the form + declares under it, and any later one of that name goes. *) let replaced = ref [] in let kept = - List.map + List.concat_map (fun (d : Ast.decl) -> match Ast.declared_name d with + | Some n when List.mem n !replaced -> [] | Some n -> - (match replacement n with - | Some nd -> replaced := n :: !replaced; nd - | None -> d) - | None -> d) + (match incoming_named n with + | [] -> [ d ] + | nds -> replaced := n :: !replaced; nds) + | None -> [ 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) + | Some n -> not (List.mem n !replaced) | None -> false) incoming in @@ -1033,9 +1075,12 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr let stale_site (st : site) = match now st.callee with | Some n -> not (String.equal n st.csig) - | None -> false + (* An arity the name's new fn form lacks: the name is still there. *) + | None -> + let w = Check.written_name st.callee in + Hashtbl.mem env.Check.versions w || Hashtbl.mem env.Check.fns w in - (not (List.mem name names)) + (not (List.mem (Check.written_name name) names)) && SM.exists (fun fname b -> (String.equal b.owner name || String.equal fname name @@ -1122,14 +1167,25 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr it has to be found by being an instantiation that the running process lacks. [Emit.redefinition] then writes it as a new by-name cell, which is the same path a [defn] the process was never built with already takes. *) - let declared_fns = - List.filter + (* Every function the program has, by name, for the lookups below: a + session's program can hold thousands. *) + let in_program = Hashtbl.create 256 in + List.iter + (fun (f : Tast.fn) -> Hashtbl.replace in_program f.Tast.name f) + program.Tast.fns; + (* A name the form declared with several arities is compiled under one name + per arity. *) + let arity_syms = + List.concat_map (fun n -> - List.exists - (fun (f : Tast.fn) -> String.equal f.Tast.name n) - program.Tast.fns) + match Hashtbl.find_opt env.Check.versions n with + | Some vs -> List.map snd vs + | None -> []) names in + let declared_fns = + List.filter (Hashtbl.mem in_program) (names @ arity_syms) + in (* ── What evaluating a [def] does to the value ──────────────────────── [def] is Common Lisp's [defparameter], and evaluating a defparameter assigns. That is the whole difference from [defvar] — [defonce] here — @@ -1198,7 +1254,7 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr program.Tast.fns) (Check.instantiations env n) else []) - names + (names @ arity_syms) in let new_instances = List.filter_map @@ -1256,9 +1312,75 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr | _ -> None) program.Tast.fns in + (* A fn form that changes how many arities its name has renames them + ([Check.split_versions]: [f] alone, [f~1] and [f~2] beside each other), so + a compiled call can name a body the program no longer has under that + name. The caller is compiled again when its source still checks — it + then calls whichever arity its arguments pick — and is a stale caller, + tolerated above and listed by [stale_sites], when it does not. *) + (* Asked of every compiled body and not only of the names this form + touched: a caller left stale when an arity went away is still compiled + against it forms later, when the name has a body its call checks against + again — and it is then that it has to be compiled again. Hash lookups, + because a session's program can hold thousands of bodies. *) + let written = Hashtbl.create 256 in + List.iter + (fun (f : Tast.fn) -> + Hashtbl.replace written (Check.written_name f.Tast.name) ()) + program.Tast.fns; + let still_named n = + (not (Check.internal_name n)) && Hashtbl.mem written (Check.written_name n) + in + let versions_moved = + let has n = Hashtbl.mem in_program n in + SM.fold + (fun fname (b : built) acc -> + if has fname + && not (List.mem b.owner tolerated) + && List.exists + (fun (st : site) -> not (has st.callee) && still_named st.callee) + b.sites + then + (* A lifted body is compiled with the function it came from; a + global's initialiser has no such function, and is itself. *) + match Hashtbl.find_opt in_program fname with + | Some { Tast.fparent = Some p; _ } when p <> "" && has p -> + p :: acc + | _ -> fname :: acc + else acc) + t.built [] + 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 + (* The bodies an arity was compiled under that the program no longer has — + the arity was removed, or the name's arities were renamed around it. A + caller compiled against one and not compiled again (its source no longer + checks) must stop at the call rather than run the old body, so its cell + is given a signature word no body has, and the text of what the name is + now, which the StaleCall reads out. *) + let retire = + List.filter_map + (fun (f : Tast.fn) -> + let n = f.Tast.name in + if f.Tast.fparent = None && not (Hashtbl.mem in_program n) + && still_named n + then + let w = Check.written_name n in + let now = + List.filter_map + (fun (g : Tast.fn) -> + if g.Tast.fparent = None + && String.equal (Check.written_name g.Tast.name) w + then Some (Emit.sig_text g.Tast.params g.Tast.ret) + else None) + program.Tast.fns + in + Some (n, String.concat " or " now) + else None) + t.program.Tast.fns 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 @@ -1375,9 +1497,9 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr in let ir = match run_thunk with - | None -> redefinition t ~consts program ~fns + | None -> redefinition t ~consts ~retire program ~fns | Some th -> - redefinition t ~consts ~call:th.Tast.name + redefinition t ~consts ~retire ~call:th.Tast.name { program with Tast.fns = program.Tast.fns @ [ th ] } ~fns:(fns @ [ th.Tast.name ]) in diff --git a/lib/x86.ml b/lib/x86.ml index f6dbf3f3..157931d5 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)); @@ -5386,7 +5386,7 @@ let program ~checks ?(dev = false) ?(debug = false) ?(annotate = false) class-registration thunk a redefined [defclass] carries go through it, and [flan dev] takes this backend unasked. *) let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) - ?(retains = true) ?(consts = []) ?call ?(annotate = false) + ?(retains = true) ?(consts = []) ?(retire = []) ?call ?(annotate = false) (p : Tast.program) ~fns : string = (* A dev build places closures under the dev rule: a named callee can be replaced by a redefinition that keeps what it was handed. See @@ -5614,6 +5614,24 @@ let redefinition ~checks ?(dev = true) ?(known = fun _ -> true) store_int f.b ~src:r11 ~mm:(Reg (rax, 0)) ~size:8 end) targets; + (* A body the program no longer has: its cell takes a word no signature + hashes to, so a caller not compiled again stops on StaleCall, as + [Emit.redefinition] has it. *) + List.iter + (fun (n, now) -> + if known n then + load_int f.b ~dst:rax ~mm:(Got (csym n)) ~size:8 ~signed:false + else begin + cstr (Mangle.sym n); + xor_rr f.b ~dst:rax ~src:rax; + call_sym f.b "flan_dev_cell" + end; + movabs f.b ~dst:r11 Emit.retired_word; + store_int f.b ~src:r11 ~mm:(Reg (rax, 8)) ~size:8; + let tl = string_const f now in + lea f.b ~dst:r11 ~mm:(Sym (tl, 0)); + store_int f.b ~src:r11 ~mm:(Reg (rax, 16)) ~size:8) + retire; (* Nothing a constant initialiser can do transfers, so this exit is unreachable and is emitted only when something claims to aim at it. *) if f.unwound then begin diff --git a/spec-syntax.md b/spec-syntax.md index 0d760e48..dae23c98 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -456,6 +456,28 @@ 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 fn with several arities is one definition: `fn area` alone on its line, + and under it one line per arity, its parameters in parentheses, with its + block under that or `= expr` on the line: + + ``` + fn area + (w: i32) -> i32 = w * w + (w: i32, h: i32) -> i32 + w * h + ``` + + It reads `(defn area ([w i32] i32 (* w w)) ([w i32 h i32] i32 (* w h)))`, + Clojure's multi-arity `defn`. A call picks the arity by how many arguments it + passes; types play no part, so two arities of one count are refused. An arity + may be generic, carry its own `where`, and call the others. The arities are + closed: a second `fn area` anywhere is `area` defined twice, whatever its + arity, and extension is `generic`/`method`'s. `main` has one arity. 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 the form replaces every arity + at once: one it no longer has is gone, and its compiled callers are listed + as stale. **Built** (decision 139). - 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-arities.fln b/test/programs/dev-arities.fln new file mode 100644 index 00000000..b9fd89bf --- /dev/null +++ b/test/programs/dev-arities.fln @@ -0,0 +1,16 @@ +;; Arities taken away and given back in a running program: a caller of a +;; removed arity stops on StaleCall, and one compiled against it is compiled +;; again once the name has an arity its call checks against. +import agent "vendor:agent" + +fn helper(a: i32) -> i32 = a + 1 + +let n: i32 = helper(4) + +fn use1() -> i32 = helper(2) + +fn main() -> i32 + agent/start("/tmp/flan-dev-arities-fallback.sock") + for i in range(4000) + agent/wait(5) + 0 diff --git a/test/programs/dev-versions.fln b/test/programs/dev-versions.fln new file mode 100644 index 00000000..0490a32c --- /dev/null +++ b/test/programs/dev-versions.fln @@ -0,0 +1,14 @@ +;; A fn with two arities in a running program: evaluating the fn form again +;; from the editor replaces its arities, and a call to each reaches the new +;; bodies. +import agent "vendor:agent" + +fn area + (w: i32) -> i32 = w * w + (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..47abd0ed --- /dev/null +++ b/test/programs/versions.fln @@ -0,0 +1,71 @@ +;; One fn, several arities: the number of arguments picks one (decision 139). + +struct Grain + kind: i32 + +;; One arity calling another. +fn is-empty-cell + (g: Grain) -> bool + g.kind == 0 + (r: i32, c: i32) -> bool + is-empty-cell(Grain{.kind r * c}) + +;; One-line arities. +fn area + (w: i32) -> i32 = w * w + (w: i32, h: i32) -> i32 = w * h + (w: i32, h: i32, d: i32) -> i32 + area(w, h) * d + +;; A generic arity beside another, each with its own where clause. +fn pick + (x: $t) -> $t + x + (x: $t, y: $t, first: bool) -> $t where is-ordered($t) + if first then min(x, y) else max(x, y) + +;; An arity that recurses on itself and one that calls it. +fn count + (n: i32) -> i32 + count(n, 0) + (n: i32, acc: i32) -> i32 + if n == 0 then acc else count(n - 1, acc + n) + +;; defer runs per arity. +fn noisy + (a: i32) -> i32 + defer println("leaving noisy/1") + a + (a: i32, b: i32) -> i32 + defer println("leaving noisy/2") + a + b + +;; Untyped arities take dyn arguments, and the count still picks. +fn scale + (x) + x * 10 + (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(3, 9, 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 babd6eb5..5f74d5ce 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2242,6 +2242,14 @@ let () = "1\n4\nnone\n6\nnone\n9\n2\nnone\n3\nnone\n4\nnone\nnone\n4\nsome none\nnone\n\ 3\nnone\nnone\n5\nnil\n7\n" in + (* One fn, several arities, picked by the number of arguments. *) + let versions_out = + "true\nfalse\ntrue\nfalse\n9\n12\n60\n7\n2.5\n3\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 0c2f6537..8c5b6b66 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -7638,6 +7638,204 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ fsock; fout ]) [ "x86"; "llvm" ]; + (* ── One fn, two arities (decision 139) ───────────────────────────── + Evaluating a running program's fn form again from a .fln buffer + replaces its arities: a call to each reaches the new body, 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 arity" "area(3)" "9"; + is "the two-argument arity" "area(3, 4)" "12"; + let r = + request c + (Printf.sprintf "(:op \"eval\" :code %s :file %s)" + (Wire.quote + "fn area\n (w: i32) -> i32 = w * w + 1\n \ + (w: i32, h: i32) -> i32 = w * h + 100") + (Wire.quote file)) + in + if status r <> "ok" then + fail "--%s: evaluating the fn form again: %s" backend + (Option.value ~default:(status r) (Wire.string_field r "message")); + is "the new two-argument arity" "area(3, 4)" "112"; + is "the new one-argument arity" "area(3)" "10"; + let text = Form.to_string (request c "(:op \"defs\")") in + if not (contains_sub text "area [i32] i32 | area [i32 i32] i32") then + fail "--%s: defs did not list both arities of area: %s" backend text; + (* Each arity's code, under the name written and its count. *) + let d = + request c "(:op \"disassemble\" :name \"area\" :form \"ir\")" + in + let text = Form.to_string d in + if status d <> "ok" || not (contains_sub text ":arity 2") + || contains_sub text ":name \"area~" + then + fail "--%s: disassembling area answered %s" backend + (String.sub text 0 (min 300 (String.length 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" ]; + + (* ── Arities taken away and given back ─────────────────────────────── + [use1] and [n] call [helper] with one argument. Taking that arity away + leaves them stale, and a call to [use1] stops on StaleCall rather than + running the removed body; giving [helper] a one-argument body again, + by any road, compiles them again, and nothing is stale after. *) + List.iter + (fun backend -> + let asock = tmp ("arities" ^ backend ^ ".sock") + and aout = tmp ("arities" ^ backend ^ ".out") in + (try Sys.remove asock with Sys_error _ -> ()); + let afd = + Unix.openfile aout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let apid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-arities.fln"; "-s"; asock; + "--" ^ backend |] + Unix.stdin afd Unix.stderr + in + Unix.close afd; + if not (listening ~pid:apid asock) then begin + fail "the arities daemon (--%s) %s" backend !listen_why; + (try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect asock in + let file = "programs/dev-arities.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 + let stale_callers r = + match Wire.field r "stale" with + | Some { Form.v = Form.List l; _ } -> + List.filter_map (fun (e : Form.t) -> Wire.string_field e "caller") l + |> List.sort_uniq compare + | _ -> [] + in + let eval what code = + let r = + request c + (Printf.sprintf "(:op \"eval\" :code %s :file %s)" + (Wire.quote code) (Wire.quote file)) + in + if status r <> "ok" then + fail "--%s: %s: %s" backend what + (Option.value ~default:(status r) (Wire.string_field r "message")); + r + in + let stopped () = + match Wire.field (request c "(:op \"describe\")") "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let three = + "fn helper\n (a: i32) -> i32 = a + 100\n \ + (a: i32, b: i32) -> i32 = a + b\n \ + (a: i32, b: i32, c: i32) -> i32 = a + b + c" + and two = + "fn helper\n (a: i32, b: i32) -> i32 = a * b\n \ + (a: i32, b: i32, c: i32) -> i32 = a + b + c" + in + if not (await ~ms:20000 (fun () -> status (ask "1") = "ok")) then + fail "--%s: the arities program never took an expression" backend + else begin + ignore (eval "three arities" three); + is "use1 over three arities" "use1()" "102"; + let r = eval "the one-argument arity taken away" two in + if stale_callers r <> [ "n"; "use1" ] then + fail "--%s: a removed arity's stale callers were %s" backend + (String.concat ", " (stale_callers r)); + let r = ask "use1()" in + if status r <> "error" then + fail "--%s: a caller of a removed arity answered %s" backend + (answer r) + else if not (await ~ms:20000 stopped) then + fail "--%s: a caller of a removed arity never stopped" backend + else begin + (match + Wire.string_field (request c "(:op \"describe\")") "condition" + with + | Some "StaleCall" -> () + | k -> + fail "--%s: a caller of a removed arity stopped on %S" backend + (Option.value ~default:"" k)); + ignore (request c "(:op \"restart\" :name \"abandon-evaluation\")"); + if not (await ~ms:20000 (fun () -> not (stopped ()))) then + fail "--%s: the abandoned evaluation never let go" backend + end; + ignore (eval "a plain two-argument helper" + "fn helper(a: i32, b: i32) -> i32 = a * b"); + let r = eval "a plain one-argument helper again" + "fn helper(a: i32) -> i32 = a + 1000" in + if stale_callers r <> [] then + fail "--%s: once helper takes one argument again, %s stayed stale" + backend (String.concat ", " (stale_callers r)); + is "use1 compiled again" "use1()" "1002"; + let r = eval "an unrelated fn" "fn other() -> i32 = 1" in + if stale_callers r <> [] then + fail "--%s: a later evaluation still listed %s as stale" backend + (String.concat ", " (stale_callers r)) + end; + (try Unix.close c with Unix.Unix_error _ -> ()); + (try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] apid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ asock; aout ]) + [ "x86"; "llvm" ]; + (* ── The dyn globals a park holds ─────────────────────────────────── *) (* The banner a finished run prints says the globals are as it left them, diff --git a/test/test_flan.ml b/test/test_flan.ml index 23763995..4a25b1e6 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1508,6 +1508,62 @@ 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 fn, several arities (decision 139) ─────────────────────── *) + let two = "fn f\n (a: i32) -> i32 = a\n (a: i32, b: i32) -> i32 = a + b\n\n" in + refuses_all ~fln:true "a second fn of one name is defined twice, whatever its arity" + "fn f(a: i32) -> i32\n a\n\nfn f(a: i32, b: i32) -> i32\n a + b\n" + "f is defined twice. A function with several arities is one definition, \ + each arity under it:\n\n fn f\n (a: T) -> R"; + refuses_all "and in parens, the grouped defn" + "(defn f [a i32] i32 a) (defn f [a i32 b i32] i32 (+ a b))" + "(defn f ([a T] R ...) ([a T b T] R ...))"; + refuses_all ~fln:true "a second fn beside a grouped one is defined twice" + (two ^ "fn f(x: i64, y: i64, z: i64) -> i64\n x\n") "f is defined twice"; + refuses_all ~fln:true "two arities of one count" + "fn g\n (a: i32) -> i32 = a\n (b: bool) -> i32 = 0\n" + "g has two arities with 1 parameter"; + refuses_all ~fln:true "main has one arity" + "fn main\n () = 0\n (x: i32) = 0\n" "main has one arity"; + refuses_all ~fln:true "a line under fn f that is not an arity" + "fn f\n (a: i32) -> i32 = a\n x = 3\n" "under fn f each line is one arity"; + refuses_all ~fln:true "a call no arity takes lists the arities" + (two ^ "fn h() -> i32\n f(1, 2, 3)\n") + "f has no arity 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) ([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 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 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 no arity that takes 3 arguments, which the function type wanted here does"; + 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"; + (* A macro's expansion puts its call's location on every form it writes, + so what makes two defns one fn has to be the form they came from and + not where they appear to be. *) + refuses_all ~fln:true "a macro that defines one name twice" + "macro two-fs()\n quote\n fn f(a: i32) -> i32 = a * 2\n \ + fn f(a: i32, b: i32) -> i32 = a + b\n\ntwo-fs()\n" + "f is defined twice"; + refuses_all ~fln:true "a macro that writes two fns of one name, each with arities" + "macro two-gs()\n quote\n fn g\n (a: i32) -> i32 = a\n \ + (a: i32, b: i32) -> i32 = b\n fn g\n (a: i32, b: i32, c: i32) -> i32 = c\n\n\ + two-gs()\n" + "g is defined twice"; + refuses_all "a rest parameter beside a fixed arity" + "(defn g ([a i32] i32 a) ([a i32 & r] i32 a))" + "an arity takes a fixed number of parameters"; + refuses_all ~fln:true "an arity with no body names the fn as written" + "fn f\n () -> i32\n (a: i32) -> i32 = a\n" "f returns i32 but has no body"; + refuses_all ~fln:true "an arity takes no rest parameter" + "fn f\n (a: i32) -> i32 = a\n (a: i32, & xs) -> i32 = a\n" + "& (a rest parameter) is not one"; (* A name an as bound is read-only, and says so as itself, not as a parameter (decision 136). *) refuses_all ~fln:true "assigning an as name" @@ -6264,6 +6320,20 @@ 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) ([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) ([a i32] i32 a))\n(defn g [] i32 (let [h f] 0))" + "check/several-versions"; + check "a fn with several arities over a builtin is warned about once" + (List.length + (Check.shadowed_builtins + (Parse.program (read "(defn get ([a i32] i32 a) ([a i32 b i32] i32 b))"))) + = 1); + check "an arity's compiled name is shown as the name written" + (Check.shown_name "helper~2" = "helper" + && Check.written_name "gen~1-i32" = "gen-i32"); (* 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 b7cfd123..e2f259e8 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -78,6 +78,151 @@ let () = 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))"; + + (* A fn form with several arities (decision 139) is every arity of its name: + each is compiled under a name of its own, evaluating the form again + replaces all of them, and an arity it no longer has is gone. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + let names () = + List.map (fun (f : Tast.fn) -> f.Tast.name) t.Session.program.Tast.fns + in + let eval what src = + match Session.eval t src with + | c -> Some c + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" what m; None + in + (match eval "two arities" "(defn outer ([] i64 (bump)) ([a i64 b i64] i64 (+ a b)))" with + | Some c -> + if List.sort compare c.Session.fns <> [ "outer~0"; "outer~2" ] then + fail "two arities installed %s" (String.concat " " c.Session.fns); + (* The reply's :fns, which the editor says: the name written, once. *) + if Session.shown_fns c <> [ "outer" ] then + fail "two arities were shown as %s" (String.concat " " (Session.shown_fns c)); + if c.Session.stale <> [] then fail "two arities left a caller behind" + | None -> ()); + (match eval "the form again" "(defn outer ([] i64 (bump)) ([a i64 b i64] i64 (* a b)))" with + | Some c -> + if List.sort compare c.Session.fns <> [ "outer~0"; "outer~2" ] then + fail "the form again installed %s" (String.concat " " c.Session.fns) + | None -> ()); + (match eval "one arity left" "(defn outer [a i64 b i64] i64 (* a b))" with + | Some c -> + if c.Session.fns <> [ "outer" ] then + fail "one arity left installed %s" (String.concat " " c.Session.fns); + if List.mem "outer~0" (names ()) || List.mem "outer~2" (names ()) then + fail "a removed arity is still in the program" + | None -> ())); + (* The arities' renaming reaches every kind of caller. A global whose + initialiser calls the name, or holds it as a value, is compiled again as + the initialiser it is and not as a function of its name; a caller of a + generic's copy calls the renamed copy; and a type declared in the same + form as a signature that names it is no reason to refuse the form. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + let eval what src = + match Session.eval t src with + | c -> Some c + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" what m; None + in + ignore (eval "a global calling helper" "(def n i64 (helper 4))"); + ignore + (eval "a global holding helper" + "(defstruct Box [f (CFn [i64] i64)]) (def bx Box (Box {.f helper}))"); + ignore (eval "a generic" "(defn gen [x $t] $t x)"); + ignore (eval "its caller" "(defn gen-user [] i32 (gen 5))"); + (match eval "helper's second arity past the globals" + "(defn helper ([x i64] i64 (* x 3)) ([x i64 y i64] i64 (+ x y)))" with + | Some c -> + List.iter + (fun n -> + if List.mem n c.Session.fns then + fail "helper's second arity installed the global %s as a function" n) + [ "n"; "bx" ] + | None -> ()); + (match eval "gen's second arity" "(defn gen ([x $t] $t x) ([x $t y $t] $t y))" with + | Some c -> + List.iter + (fun n -> + if not (List.mem n c.Session.fns) then + fail "gen's second arity did not install %s: %s" n + (String.concat " " c.Session.fns)) + [ "gen~1-i32"; "gen-user" ] + | None -> ()); + ignore + (eval "a same-arity helper over a type the form declares" + "(defstruct Fresh [a i64]) (defn helper [x Fresh] i64 (.a x))")); + + (* An arity taken away and, forms later, given back by another road: the + caller left stale is compiled again then, and nothing stays stale. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + let eval what src = + match Session.eval t src with + | c -> Some c + | exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" what m; None + in + let callers (c : Session.change) = + List.sort_uniq compare + (List.map (fun (x : Session.stale) -> x.Session.caller) c.Session.stale) + in + ignore + (eval "three arities" + "(defn helper ([x i64] i64 (+ x 100)) ([x i64 y i64] i64 (+ x y)) \ + ([x i64 y i64 z i64] i64 z))"); + (match eval "the one-argument arity taken away" + "(defn helper ([x i64 y i64] i64 (* x y)) ([x i64 y i64 z i64] i64 z))" with + | Some c -> + if callers c <> [ "bump" ] then + fail "a removed arity left %s stale" (String.concat ", " (callers c)) + | None -> ()); + ignore (eval "a plain two-argument helper" "(defn helper [x i64 y i64] i64 (* x y))"); + (match eval "a plain one-argument helper again" "(defn helper [x i64] i64 (+ x 1000))" with + | Some c -> + if not (List.mem "bump" c.Session.fns) then + fail "the stale caller was not compiled again: %s" + (String.concat " " c.Session.fns); + if c.Session.stale <> [] then + fail "once helper takes one argument again, %s stayed stale" + (String.concat ", " (callers c)); + if List.length (List.filter (String.equal "helper") c.Session.names) <> 1 then + fail "the reply named helper %d times" + (List.length (List.filter (String.equal "helper") c.Session.names)) + | None -> ()); + match eval "a later form" "(defn lonely-too [] i64 1)" with + | Some c -> + if c.Session.stale <> [] then + fail "a later form still listed %s as stale" (String.concat ", " (callers c)) + | None -> ()); + + (* [bump] calls [helper] with one argument. Giving [helper] a second arity + compiles [bump] again, to call the arity its argument picks; taking the + one-argument arity away leaves [bump] a stale caller. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + (match + Session.eval t "(defn helper ([x i64] i64 (* x 3)) ([x i64 y i64] i64 (+ x y)))" + with + | c -> + if List.sort compare c.Session.fns <> [ "bump"; "helper~1"; "helper~2" ] then + fail "a second arity of a called function installed %s" + (String.concat " " c.Session.fns); + if c.Session.stale <> [] then + fail "a second arity of a called function left a caller behind" + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "a second arity of a called function was refused: %s" m); + match Session.eval t "(defn helper [x i64 y i64] i64 (+ x y))" with + | c -> + (match c.Session.stale with + | [ x ] when x.Session.caller = "bump" && x.Session.target = "helper~1" + && x.Session.compiled = "[i64] i64" + && x.Session.current = "[i64 i64] i64" -> () + | l -> + fail "a removed arity's stale callers were %s" + (String.concat ", " + (List.map + (fun (x : Session.stale) -> + x.Session.caller ^ "->" ^ x.Session.target ^ " " + ^ x.Session.current) + l))) + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "removing an arity was refused: %s" m); (* [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"