From dd719766eef9db3233e34c05c7adf5da671743c3 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 17:35:18 +0700 Subject: [PATCH] A fn's arities are one form, fn f with a (params) -> R line per arity, and evaluating it replaces every arity at once. --- TODO.org | 11 +-- emacs/flan-fln-mode.el | 30 +++++- emacs/test-flan-fln.el | 29 ++++++ lib/check.ml | 175 +++++++++++++++++---------------- lib/dev.ml | 44 +++++++-- lib/indent_printer.ml | 96 ++++++++++++------ lib/indent_reader.ml | 41 +++++++- lib/paren_printer.ml | 9 +- lib/parse.ml | 21 ++++ lib/session.ml | 166 ++++++++++++++++++------------- spec-syntax.md | 32 ++++-- test/programs/dev-versions.fln | 13 ++- test/programs/versions.fln | 82 ++++++++------- test/test_acceptance.ml | 4 +- test/test_dev.ml | 45 +++++---- test/test_flan.ml | 55 +++++++---- test/test_session.ml | 174 +++++++++++++++++++++----------- 17 files changed, 664 insertions(+), 363 deletions(-) diff --git a/TODO.org b/TODO.org index b14b2bd3..2dccb023 100644 --- a/TODO.org +++ b/TODO.org @@ -56,13 +56,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 A name has one version per arity (decision 135a) +** DONE One fn form holds every arity of a name (decision 139, replacing 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. +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/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index 03be0160..fc421a14 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) @@ -1854,8 +1877,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/lib/check.ml b/lib/check.ml index 19a3130e..4c02681b 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -223,10 +223,10 @@ 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. *) + (* 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]. *) @@ -7050,29 +7050,41 @@ and var ctx ?(qualified = false) loc ~want name = 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)) + | wanted -> + let arities = + String.concat "\n" + (List.map (fun (_, v) -> " " ^ version_text ctx.env loc v) vs) 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)) + (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 @@ -16092,7 +16104,7 @@ and ordinary_call ctx ~want loc name 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" + "%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))) @@ -17790,11 +17802,15 @@ 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 @@ -17936,42 +17952,24 @@ 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~]. +(* ── 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 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) + 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 @@ -17980,28 +17978,37 @@ let split_versions env (decls : Ast.decl list) : Ast.decl list = | 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" -> + | (_, _, group) :: _ when group <> d.Ast.dloc -> + let fln = fln_source d.Ast.dloc in 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" + ~notes:[ Loc.note group (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.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 "") + (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, d.Ast.dloc) ]) + Hashtbl.replace arities n (seen @ [ (k, fn.Ast.nloc, d.Ast.dloc) ]) | _ -> ()) decls; Hashtbl.iter @@ -18009,7 +18016,7 @@ let split_versions env (decls : Ast.decl list) : Ast.decl list = if List.length seen > 1 then Hashtbl.replace env.versions n (List.sort compare - (List.map (fun (k, _) -> (k, version_name n k)) seen))) + (List.map (fun (k, _, _) -> (k, version_name n k)) seen))) arities; if Hashtbl.length env.versions = 0 then decls else @@ -18088,10 +18095,10 @@ let collect env (decls : Ast.decl list) = | None -> () | Some n -> (match Hashtbl.find_opt claimed n with - (* 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]. *) + (* 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; diff --git a/lib/dev.ml b/lib/dev.ml index e4ca28c5..f9e0c45e 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -687,6 +687,19 @@ let version_fns t 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 @@ -2615,7 +2628,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = (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 @@ -2717,7 +2730,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 @@ -2764,7 +2777,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 @@ -2949,7 +2962,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. *) @@ -3069,7 +3082,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 " @@ -3489,7 +3502,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 \ @@ -4483,14 +4496,25 @@ let disassemble t ~name ~form = (* 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 fields + | Ok fields -> + Wire.list + (own + @ List.filter + (fun fl -> not (String.starts_with ~prefix:":name " fl)) + fields) | Error m -> Wire.list - [ ":name " ^ Wire.quote f.Tast.name; - ":signature " ^ Wire.quote (signature_of_fn f); - ":refused " ^ Wire.quote m ] + (own + @ [ ":signature " ^ Wire.quote (signature_of_fn f); + ":refused " ^ Wire.quote m ]) in ok [ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form; 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 092df315..386620c1 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -2497,7 +2497,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 [_] @@ -2564,8 +2567,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 757f8803..94753910 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -2277,6 +2277,27 @@ 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. They keep the + whole form's location as theirs, which is what tells [Check] they were + written as one definition and not as two of one name; each name carries + its own arity's location, where a message about that arity points. *) + | 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 -> + List.map + (fun (c : Form.t) -> + match c.Form.v with + | Form.List items -> + { f with Form.v = Form.List (head :: { 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 16ed882f..2822a673 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 @@ -964,55 +985,44 @@ 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. *) + (* 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 - | Ast.Defn fn -> - Option.map (Check.version_name fn.Ast.name) (arity_of d) - | _ -> None) + match d.Ast.d with Ast.Defmethod m -> Some m.Ast.mgen | _ -> None) incoming in - 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 + 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. 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 + 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.filter_map + List.concat_map (fun (d : Ast.decl) -> - 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) + match Ast.declared_name d with + | Some n when List.mem n !replaced -> [] + | Some n -> + (match incoming_named n with + | [] -> [ d ] + | nds -> replaced := n :: !replaced; nds) + | None -> [ d ]) t.decls in let added = List.filter (fun (d : Ast.decl) -> - Ast.declared_name d <> None && not (List.memq d !used)) + match Ast.declared_name d with + | Some n -> not (List.mem n !replaced) + | None -> false) incoming in let decls = kept @ added in @@ -1049,9 +1059,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 @@ -1138,14 +1151,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 — @@ -1214,7 +1238,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 @@ -1272,44 +1296,46 @@ 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. *) + (* 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. *) let versions_moved = - let has n = - List.exists (fun (f : Tast.fn) -> String.equal f.Tast.name n) - program.Tast.fns + (* Only a form that gives a name several arities, or had one that had + them, renames anything, so only then is there anything to look for. *) + let touched = + List.exists + (fun n -> + Hashtbl.mem env.Check.versions n || Hashtbl.mem t.env.Check.versions n) + names in - let fresh = - List.filter_map + if not touched then [] + else + let has n = Hashtbl.mem in_program n in + let written = Hashtbl.create 256 in + List.iter (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 = + Hashtbl.replace written (Check.written_name f.Tast.name) ()) + program.Tast.fns; + let still_named n = Hashtbl.mem written (Check.written_name n) in SM.fold (fun fname (b : built) acc -> if has fname - && List.exists (fun (st : site) -> not (has st.callee)) b.sites + && not (List.mem b.owner tolerated) + && List.exists + (fun (st : site) -> not (has st.callee) && still_named 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 + (* 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 - if fresh = [] then [] else fresh @ callers in let fns = List.sort_uniq String.compare diff --git a/spec-syntax.md b/spec-syntax.md index 337b7dd5..e0704ee8 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -422,16 +422,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 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 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-versions.fln b/test/programs/dev-versions.fln index e18ff084..0490a32c 100644 --- a/test/programs/dev-versions.fln +++ b/test/programs/dev-versions.fln @@ -1,12 +1,11 @@ -;; A name with two versions in a running program: redefining one version -;; from the editor replaces it alone, and the other keeps running. +;; 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 - -fn area(w: i32, h: i32) -> i32 - w * h +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") diff --git a/test/programs/versions.fln b/test/programs/versions.fln index 9cf839c0..47abd0ed 100644 --- a/test/programs/versions.fln +++ b/test/programs/versions.fln @@ -1,53 +1,51 @@ -;; One name, several versions: the number of arguments picks one (decision 135a). +;; One fn, several arities: the number of arguments picks one (decision 139). struct Grain kind: i32 -fn is-empty-cell(g: Grain) -> bool - g.kind == 0 +;; 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 version calling another. -fn is-empty-cell(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 -fn area(w: i32) -> i32 - w * w +;; 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) -fn area(w: i32, h: i32) -> i32 - w * h +;; 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) -fn area(w: i32, h: i32, d: i32) -> i32 - area(w, h) * d +;; 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 -;; 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 +;; 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) @@ -62,7 +60,7 @@ fn main() println(area(3, 4, 5)) println(pick(7)) println(pick(1.5, 2.5, false)) - println(pick("a", "b", true)) + println(pick(3, 9, true)) println(count(10)) println(noisy(1)) println(noisy(1, 2)) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index aea28a7f..b741dd49 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2248,9 +2248,9 @@ 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. *) + (* One fn, several arities, picked by the number of arguments. *) let versions_out = - "true\nfalse\ntrue\nfalse\n9\n12\n60\n7\n2.5\na\n55\n\ + "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; diff --git a/test/test_dev.ml b/test/test_dev.ml index 95f815dd..c36e4ee3 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 [] f64 1.25)" in + let r = ev "(defn helper [x i64] i64 x)" 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 (i64 (* (helper) 4.0)))"; "(defn step [] i64 (user))" ]; + [ "(defn user [] i64 (helper 5))"; "(defn step [] i64 (user))" ]; Buffer.clear seen; let r = ask "(:op \"rerun\")" in if status r <> "ok" then @@ -7540,9 +7540,9 @@ 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 + (* ── 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 -> @@ -7583,23 +7583,34 @@ let () = 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"; + 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(w: i32, h: i32) -> i32\n w * h + 100") + (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: redefining one version: %s" backend + fail "--%s: evaluating the fn form again: %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 + 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 versions of area: %s" backend text + 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 _ -> ()); @@ -8451,7 +8462,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 f64] i64 (i64 (* x 3.0)))" in + let r = eval "(defn scale [x i64 k i64] i64 (* x k))" in if status r <> "ok" then fail "--%s: a signature change was refused: %s" backend (said r) else begin @@ -8483,7 +8494,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"; "[f64] i64" ]; + [ "scale"; "[i64] i64"; "[i64 i64] 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 @@ -8492,7 +8503,7 @@ let () = let r = eval "(defn step [] i64 (set ticks (+ ticks 1)) \ - (set seen (scale (f64 ticks))) seen)" + (set seen (scale ticks 3)) 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 ad6bc76e..2b50ad7a 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1507,37 +1507,44 @@ 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" + (* ── 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 version that takes 3 arguments. It has these:\n f(a: i32)\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) (defn f [a i32 b i32] i32 (+ a b)) \ - (defn h [] i32 (f))" + "(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 versions, one per number of arguments, so the name alone \ + "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 several versions"; + "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"; - 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" + 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"; rejects_check "popcount of a float" "(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64"; @@ -6207,11 +6214,19 @@ let () = 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))" + "(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)\n(defn f [a i32] i32 a)\n(defn g [] i32 (let [h f] 0))" + "(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 87783cca..64e0a995 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -54,15 +54,14 @@ 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 ?(fn = "outer") ?(stale = []) name src = + let installs name src = let t, _ = Session.create ~file:"programs/reload.flan" () in match Session.eval t src with | c -> - if not (List.mem fn c.Session.fns) then + if not (List.mem "outer" c.Session.fns) then fail "%s installed %s" name (String.concat " " c.Session.fns); - if List.map (fun (x : Session.stale) -> x.Session.caller) c.Session.stale - <> stale - then fail "%s left the wrong callers behind" name + if c.Session.stale <> [] then + fail "%s left a caller behind that nothing has" 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 @@ -78,51 +77,112 @@ 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); - (* 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 parameter type" "(defn outer [x i64] i64 (bump))"; 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 ~fn:"helper" ~stale:[ "bump" ] "a parameter that became dyn" - "(defn helper [x] i64 7)"; + installs "a parameter that became dyn" "(defn outer [x] i64 (bump))"; - (* 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. *) + (* 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 - 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 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); + 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))")); + + (* [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 - | 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"); + (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" @@ -134,7 +194,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 f64] i64 (i64 (* x 2.0)))" with + match Session.eval t "(defn scale [x i64 k i64] i64 (* x k))" with | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a signature change with compiled callers was refused: %s" m | c -> @@ -148,12 +208,12 @@ let () = c.Session.stale in let want = - [ ("step", "scale", "[i64] i64", "[f64] i64", 23); - ("pick", "scale", "[i64] i64", "[f64] i64", 26); + [ ("step", "scale", "[i64] i64", "[i64 i64] i64", 23); + ("pick", "scale", "[i64] i64", "[i64 i64] 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", "[f64] i64", 45); - ("guarded", "scale", "[i64] i64", "[f64] i64", 46) ] + ("guarded", "scale", "[i64] i64", "[i64 i64] i64", 45); + ("guarded", "scale", "[i64] i64", "[i64 i64] i64", 46) ] in if named <> want then fail "the stale callers were %s" @@ -164,7 +224,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 (f64 ticks))) seen)" + "(defn step [] i64 (set ticks (+ ticks 1)) (set seen (scale ticks 3)) seen)" with | c -> (match c.Session.stale with @@ -216,9 +276,9 @@ let () = in let main_src = "(defn main [] i32 (agent/start \"/tmp/x.sock\") \ - (dotimes [i 6000] (agent/wait 5) (restart-case (step) (skip-frame [] 0))) 0)" + (dotimes [i 6000] (agent/wait 5) (restart-case (step 1) (skip-frame [] 0))) 0)" in - (match Session.eval t "(defn step [] i32 (set seen (scale ticks)) (i32 seen))" with + (match Session.eval t "(defn step [x i64] i64 (set seen (scale x)) 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); @@ -233,10 +293,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 [] i32 (set seen (scale ticks)) (i32 seen))"); + (Session.eval ~running:false t "(defn step [x i64] i64 (set seen (scale x)) seen)"); match Session.eval ~running:false t - "(defn main [] i32 (dotimes [i 3] (restart-case (step) (skip-frame [] 0))) 0)" + "(defn main [] i32 (dotimes [i 3] (restart-case (step 1) (skip-frame [] 0))) 0)" with | c -> if List.exists (fun (x : Session.stale) -> x.Session.caller = "main") @@ -266,7 +326,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 f64] i64 (i64 x)) (defn twice [] i64 (scale ticks))" + "(defn scale [x i64 k i64] i64 (* x k)) (defn twice [] i64 (scale 1))" "scale"; (* The storage exists and has a shape: reusing it reads at the wrong offsets, @@ -964,7 +1024,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 i64] i32 (mix a (i32 b)))" + "(defn- combine [a i32 b i32 c i32] i32 (mix a (+ b c)))" with | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a package function's signature change was refused: %s" m @@ -982,7 +1042,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)) 0)" + "(defn main [] i32 (print (secret/combine 1 2 3)) 0)" with | _ -> fail "a stale caller recompiled past a defn- was accepted" | exception Loc.Error { Loc.dmsg = m; _ } -> @@ -991,7 +1051,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 i64] i32 (+ (* a 10) (i32 b)))" + "(defn- mix [a i32 b i32 c i32] i32 (+ (* a 10) (+ b c)))" with | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a private package function's signature change was refused: %s" m