JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

One fn form holds all of a name's arities, and evaluating it replaces them all.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 18:30:11 +07:00
commit 5274f83f88
25 changed files with 1366 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
TODO.org
View File

@ -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

2
bin/main.ml
View File

@ -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

30
emacs/flan-fln-mode.el
View File

@ -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(){},;\":]+\\|\\_<C?[fF]n\\)"
(line-beginning-position)))))))))))))
(or (looking-back "\\(?:^[ \t]*fn-?[ \t]+[^][ \t\n(){},;\":]+\\|\\_<C?[fF]n\\)"
(line-beginning-position))
;; An arity under `fn f'.
(and (looking-back "^[ \t]*" (line-beginning-position))
(flan-fln--arity-line-p (point)))))))))))))))
found))
(defvar flan-fln-font-lock-keywords

29
emacs/test-flan-fln.el
View File

@ -907,6 +907,35 @@ defconst(k, 3)
(test-flan-fln--tabs "let colors =\n|" 1) 2)
(test-flan-fln--is "but not after a one-line fn"
(test-flan-fln--tabs "fn f() -> 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"

12
emacs/test-flan.el
View File

@ -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

5
lib/ast.ml
View File

@ -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 }

265
lib/check.ml
View File

@ -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)

2
lib/cimport.ml
View File

@ -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)

4
lib/classes.ml
View File

@ -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

124
lib/dev.ml
View File

@ -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 ->

46
lib/emit.ml
View File

@ -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));

96
lib/indent_printer.ml
View File

@ -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 ->

41
lib/indent_reader.ml
View File

@ -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

9
lib/paren_printer.ml
View File

@ -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

75
lib/parse.ml
View File

@ -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 =

174
lib/session.ml
View File

@ -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 = "<eval>") ?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 = "<eval>") ?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 = "<eval>") ?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 = "<eval>") ?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 = "<eval>") ?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 <> "<thick>" && 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 = "<eval>") ?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

22
lib/x86.ml
View File

@ -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

22
spec-syntax.md
View File

@ -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

16
test/programs/dev-arities.fln Normal file
View File

@ -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

14
test/programs/dev-versions.fln Normal file
View File

@ -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

71
test/programs/versions.fln Normal file
View File

@ -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))

8
test/test_acceptance.ml
View File

@ -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;

198
test/test_dev.ml
View File

@ -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,

70
test/test_flan.ml
View File

@ -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. *)

145
test/test_session.ml
View File

@ -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"