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

A fn's arities are one form, fn f with a (params) -> R line per arity, and evaluating it replaces every arity at once.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 17:35:18 +07:00
parent 3f59c18257
commit dd719766ee
17 changed files with 664 additions and 363 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
TODO.org
View File

@ -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 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 vector as a ring buffer with a cheap read-only rest view; the ring buffer was
recommended. Waits on a program that needs it. 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] CLOSED: [2026-09-26]
The call's argument count picks the version at compile time; each is renamed =f~N= only Clojure's model: the grouped =fn f= is the unit of definition, a call's argument count picks
when a name has two or more. Rules out overloading by type at one arity, rest parameters the arity, and each is renamed =f~N= only when there are two or more. Rules out adding an
on =fn= (refused already), and more than one =main=. In the dev loop another arity adds a arity from a separate definition (a second =fn f= is defined twice), overloading by type at
version rather than replacing, so an arity change is no longer a stale-call signature one arity, rest parameters on =fn=, and more than one =main=.
change: only a same-arity one is.
** DONE if let ** DONE if let
CLOSED: [2026-09-26] CLOSED: [2026-09-26]
=(if-let [P v] then else)= in paren syntax; an elif chain is the else. With no else it =(if-let [P v] then else)= in paren syntax; an elif chain is the else. With no else it

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 ;; shifts rigidly and only when the first line is at no valid column, and a
;; yank moves its lines together. ;; 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) (defun flan-fln--opener-p (start last)
"Non-nil if the joined line START..LAST opens a block on the lines under it." "Non-nil if the joined line START..LAST opens a block on the lines under it."
(or (save-excursion (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(){},;\":]+(")))) (looking-at "[ \t]+[^][ \t\n(){},;\":]+("))))
((member w '("if" "when" "elif")) (not (flan-fln--then start))) ((member w '("if" "when" "elif")) (not (flan-fln--then start)))
(t t))))) (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 ;; `let r = match n', `x = if c', `fn f(x) = match x', a lambda
;; header: the value goes on under the line. ;; header: the value goes on under the line.
(flan-fln--value-opens-p start) (flan-fln--value-opens-p start)
@ -1854,8 +1877,11 @@ lambda or a `Fn(...)' type, and not after a match arm's."
(and open (and open
(progn (progn
(goto-char open) (goto-char open)
(looking-back "\\(?:^[ \t]*fn-?[ \t]+[^][ \t\n(){},;\":]+\\|\\_<C?[fF]n\\)" (or (looking-back "\\(?:^[ \t]*fn-?[ \t]+[^][ \t\n(){},;\":]+\\|\\_<C?[fF]n\\)"
(line-beginning-position))))))))))))) (line-beginning-position))
;; An arity under `fn f'.
(and (looking-back "^[ \t]*" (line-beginning-position))
(flan-fln--arity-line-p (point)))))))))))))))
found)) found))
(defvar flan-fln-font-lock-keywords (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--tabs "let colors =\n|" 1) 2)
(test-flan-fln--is "but not after a one-line fn" (test-flan-fln--is "but not after a one-line fn"
(test-flan-fln--tabs "fn f() -> i32 = 1\n|" 1) 0) (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--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--tabs "fn f() -> ()\n if let Some(g) = o\n|" 1) 4)
(test-flan-fln--is "and after a when with a block" (test-flan-fln--is "and after a when with a block"

175
lib/check.ml
View File

@ -223,10 +223,10 @@ type env = {
function can show it. Kept apart from [fparams] because a foreign function can show it. Kept apart from [fparams] because a foreign
[declare] has a location and no parameter vector worth showing. *) [declare] has a location and no parameter vector worth showing. *)
fn_locs : (string, Loc.t) Hashtbl.t; fn_locs : (string, Loc.t) Hashtbl.t;
(* A name with several versions, one per arity (decision 135a): the name as (* A fn with several arities (decision 139): the name as written, to each
written, to each version's arity and the name it was renamed to arity and the name it was renamed to ([version_name]). A fn with one
([version_name]). A name with one version is not in here and keeps its arity is not in here and keeps its own name, so its symbol does not
own name, so its symbol does not change. *) change. *)
versions : (string, (int * string) list) Hashtbl.t; versions : (string, (int * string) list) Hashtbl.t;
(* Every [defn-], by name, with where it was written and how far it is (* Every [defn-], by name, with where it was written and how far it is
visible. See [private_ref]. *) visible. See [private_ref]. *)
@ -7050,29 +7050,41 @@ and var ctx ?(qualified = false) loc ~want name =
match Option.bind want fn_sig with match Option.bind want fn_sig with
| Some (ps, _) when List.mem_assoc (List.length ps) vs -> | Some (ps, _) when List.mem_assoc (List.length ps) vs ->
Some (List.assoc (List.length ps) vs) Some (List.assoc (List.length ps) vs)
| _ -> | wanted ->
let fln = fln_source loc in let arities =
let k, v0 = List.hd vs in String.concat "\n"
let xs = (List.map (fun (_, v) -> " " ^ version_text ctx.env loc v) vs)
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 in
Loc.failk "check/several-versions" loc (match wanted with
"%s has several versions, one per number of arguments, so \ (* The function type wanted here takes a count none of them
the name alone does not say which function this is. Wrap \ does, and no wrapping changes that. *)
it in a function that calls the one you mean, as in %s. \ | Some (ps, _) ->
Its versions are:\n%s" let k = List.length ps in
name Loc.failk "check/several-versions" loc
(if fln then "%s has no arity that takes %d argument%s, which the \
Printf.sprintf "fn(%s) => %s(%s)" (String.concat ", " xs) function type wanted here does. Its arities are:\n%s"
name (String.concat ", " xs) name k (if k = 1 then "" else "s") arities
else | None ->
Printf.sprintf "(fn [%s] (%s %s))" (String.concat " " xs) let fln = fln_source loc in
name (String.concat " " xs)) let k, v0 = List.hd vs in
(String.concat "\n" let xs =
(List.map (fun (_, v) -> " " ^ version_text ctx.env loc v) match Hashtbl.find_opt ctx.env.fparams v0 with
vs)) | 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 in
let name = let name =
match wanted_version () with Some v -> v | None -> name match wanted_version () with Some v -> v | None -> name
@ -16092,7 +16104,7 @@ and ordinary_call ctx ~want loc name args =
| None -> | None ->
let n = List.length args in let n = List.length args in
Loc.failk "check/no-version" loc 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") name n (if n = 1 then "" else "s")
(String.concat "\n" (String.concat "\n"
(List.map (fun (_, v) -> " " ^ version_text ctx.env loc v) vs))) (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 — qualified names, for the reason [shadows_builtin]'s [visible] gives —
[rl/get] is not [get] and shadows nothing. *) [rl/get] is not [get] and shadows nothing. *)
let shadowed_builtins (decls : Ast.decl list) : Loc.diag list = 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 List.filter_map
(fun (d : Ast.decl) -> (fun (d : Ast.decl) ->
match d.Ast.d with match d.Ast.d with
| Ast.Defn fn | Ast.Defn fn
when Hashtbl.mem builtin_set fn.Ast.name 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.contains fn.Ast.name '/')
&& not (String.equal fn.Ast.nloc.Loc.file Prelude.file) -> && not (String.equal fn.Ast.nloc.Loc.file Prelude.file) ->
Some Some
@ -17936,42 +17952,24 @@ let check_parents env =
constant may be defined in terms of another declared after it. A constant 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 that still does not check once no progress is left has a real error, so
the last round is run without swallowing it. *) the last round is run without swallowing it. *)
(* ── One name, several arities (decision 135a) ───────────────────────── (* ── One fn, several arities (decision 139) ─────────────────────────────
[fn f(g: Grain)] and [fn f(r: i32, c: i32)] are two versions of [f], and a [fn f] with [(g: Grain) -> bool] and [(r: i32, c: i32) -> bool] under it
call picks one by how many arguments it passes. Nothing past the checker is one function with two arities, and a call picks one by how many
knows: each version is renamed here to a name of its own, and from then on arguments it passes. [Parse.splice] made one [defn] per arity, all at the
it is an ordinary function with an ordinary symbol, cell and stale-call form's location; nothing past the checker knows either: each arity is
word. The [~] is what keeps the renamed name out of a program's reach — it renamed here to a name of its own, and from then on it is an ordinary
ends a symbol in both readers — as it does for [prelude~]. 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 A fn with one arity keeps its name, so its symbol is what it always was;
gains or loses an unrelated version elsewhere; only a name with two or more only a name with two or more is renamed, all of its arities alike, so no
versions is renamed, all of its versions alike, so no version is the arity is the plain name's by accident of order.
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)
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 split_versions env (decls : Ast.decl list) : Ast.decl list =
let arities = Hashtbl.create 16 in let arities = Hashtbl.create 16 in
List.iter List.iter
@ -17980,28 +17978,37 @@ let split_versions env (decls : Ast.decl list) : Ast.decl list =
| Ast.Defn fn -> | Ast.Defn fn ->
let n = fn.Ast.name and k = List.length fn.Ast.params in let n = fn.Ast.name and k = List.length fn.Ast.params in
let seen = Option.value ~default:[] (Hashtbl.find_opt arities n) 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 (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 Loc.failk "check/defined-twice" d.Ast.dloc
~notes:[ Loc.note first "main is already defined here" ] ~notes:[ Loc.note group (n ^ " is already defined here") ]
"main is defined twice. The program starts at main, so it has \ "%s is defined twice. A function with several arities is one \
one version" 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 (match List.find_opt (fun (j, _, _) -> j = k) seen with
| Some (first : Loc.t) -> | Some (_, first, _) ->
let others = List.exists (fun (j, _) -> j <> k) seen in Loc.failk "check/defined-twice" fn.Ast.nloc
Loc.failk "check/defined-twice" d.Ast.dloc ~notes:[ Loc.note first "the other one is here" ]
~notes:[ Loc.note first (n ^ " is already defined here") ] "%s has two arities with %d parameter%s. Each arity takes a \
"%s is defined twice%s" n different number of arguments, which is how a call picks one"
(if others then n k (if k = 1 then "" else "s")
Printf.sprintf " with %d parameter%s. Each version of a \
function takes a different number of \
arguments" k (if k = 1 then "" else "s")
else "")
| None -> ()); | None -> ());
Hashtbl.replace arities n (seen @ [ (k, d.Ast.dloc) ]) Hashtbl.replace arities n (seen @ [ (k, fn.Ast.nloc, d.Ast.dloc) ])
| _ -> ()) | _ -> ())
decls; decls;
Hashtbl.iter Hashtbl.iter
@ -18009,7 +18016,7 @@ let split_versions env (decls : Ast.decl list) : Ast.decl list =
if List.length seen > 1 then if List.length seen > 1 then
Hashtbl.replace env.versions n Hashtbl.replace env.versions n
(List.sort compare (List.sort compare
(List.map (fun (k, _) -> (k, version_name n k)) seen))) (List.map (fun (k, _, _) -> (k, version_name n k)) seen)))
arities; arities;
if Hashtbl.length env.versions = 0 then decls if Hashtbl.length env.versions = 0 then decls
else else
@ -18088,10 +18095,10 @@ let collect env (decls : Ast.decl list) =
| None -> () | None -> ()
| Some n -> | Some n ->
(match Hashtbl.find_opt claimed n with (match Hashtbl.find_opt claimed n with
(* Two [defn]s of one name may be two versions of it, and whether (* Two [defn]s of one name are either the arities of one fn or one
they are is a question about their arities, which are known only name defined twice, and the arities are known only once the
once the parameter vectors are paired — [split_versions], below parameter vectors are paired — [split_versions], below
[pair_decls]. *) [pair_decls], says which. *)
| Some (_, true) when is_defn d -> () | Some (_, true) when is_defn d -> ()
| Some (first, _) -> | Some (first, _) ->
(* The second one is the error, because it is the one to delete; (* The second one is the error, because it is the one to delete;

44
lib/dev.ml
View File

@ -687,6 +687,19 @@ let version_fns t name =
| None -> false)) | None -> false))
t.session.Session.program.Tast.fns 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 = let fn_loc t name =
match find_fn t name with match find_fn t name with
| Some f -> Loc.to_string f.Tast.floc | Some f -> Loc.to_string f.Tast.floc
@ -2615,7 +2628,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
(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") ^ " 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 else
match find_fn t name with match frame_fn t name with
| None -> | None ->
Error Error
(name (name
@ -2717,7 +2730,7 @@ let locals t ~frame =
| Ok (name, fn) -> | Ok (name, fn) ->
if Emit.recorded_slots fn = 0 then if Emit.recorded_slots fn = 0 then
ok 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" ] ":note " ^ Wire.quote "this frame has no named locals" ]
else else
(match bound_slots t ~frame with (match bound_slots t ~frame with
@ -2764,7 +2777,7 @@ let locals t ~frame =
| Error m -> error m | Error m -> error m
| Ok (entries, refused) -> | Ok (entries, refused) ->
ok ok
[ ":frame " ^ Wire.quote name; [ ":frame " ^ Wire.quote (Check.shown_name name);
":locals " ^ Wire.list entries; ":locals " ^ Wire.list entries;
":refused " ":refused "
^ Wire.list ^ Wire.list
@ -2949,7 +2962,7 @@ let inspect t ~frame ~slot ~path =
| Error why -> error why | Error why -> error why
| Ok (label, ty, v, addr) -> | Ok (label, ty, v, addr) ->
ok 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 ] ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ]
@ (match addr with @ (match addr with
(* Unsigned, as an address is. *) (* 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 the program's truth, which is the only reason it is
worth redrawing. *) worth redrawing. *)
ok 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; ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v;
":wrote " ^ string_of_int (List.length edits); ":wrote " ^ string_of_int (List.length edits);
":at-stop " ":at-stop "
@ -3489,7 +3502,7 @@ let globals_op t =
program; its thunk is not part of the session, so there is no \ program; its thunk is not part of the session, so there is no \
record of what it refers to" record of what it refers to"
else else
match find_fn t name with match frame_fn t name with
| None -> | None ->
skip skip
"not a function this session holds; a lifted handler clause \ "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 (* A name with several versions answers with each, as a generic with
several copies does. *) several copies does. *)
| None when version_fns t name <> [] -> | 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 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 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 -> | Error m ->
Wire.list Wire.list
[ ":name " ^ Wire.quote f.Tast.name; (own
":signature " ^ Wire.quote (signature_of_fn f); @ [ ":signature " ^ Wire.quote (signature_of_fn f);
":refused " ^ Wire.quote m ] ":refused " ^ Wire.quote m ])
in in
ok ok
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form; [ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;

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) | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
| rest -> ("", 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 = and sugar n (f : Form.t) : string list option =
let i = ind n in let i = ind n in
match f.v with 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) -> | _ when (match lambda_parts f with Some (_, body) -> wants_block f body | None -> false) ->
let head, body = Option.get (lambda_parts f) in let head, body = Option.get (lambda_parts f) in
Some ((i ^ head ^ " =>") :: lambda_block n body) 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; _ } | Form.List ({ v = Form.Sym (("defn" | "defn-") as d); _ } :: { v = Form.Sym name; _ }
:: { v = Form.Vec ps; _ } :: ret :: body) :: { v = Form.Vec ps; _ } :: ret :: body)
when def_name name -> when def_name name ->
(match params_text ~shaped:true ps with arity_lines f n ((if d = "defn" then "fn " else "fn- ") ^ name) ps ret body
| 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)))
| Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ } | Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ }
:: { v = Form.Sym name; _ } :: rest) :: { v = Form.Sym name; _ } :: rest)
when def_name name -> when def_name name ->

41
lib/indent_reader.ml
View File

@ -2497,7 +2497,10 @@ and header (s : st) w : Form.t =
match w with match w with
| "fn" | "fn-" -> | "fn" | "fn-" ->
let name = name_tok p ~what:"the function's name" in 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 ps = params p lp in
let rp = last p in let rp = last p in
(* No arrow reads the return type off the body: the paren syntax's [_] (* 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 [] if (peek p).tok = INDENT then block s ~after:"fn" else []
| _ -> stray p ~after:ret_text | _ -> stray p ~after:ret_text
in in
named (if w = "fn" then "defn" else "defn-") Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body)
(name :: 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 | "def" | "once" | "const" -> def_form s w t l0
| "struct" | "union" -> | "struct" | "union" ->
let name = name_tok p ~what:"the type's name" in 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 in
go 0 rest go 0 rest
in 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 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 else fill items
| Form.List items -> bracket "(" ")" items ~keep:0 | Form.List items -> bracket "(" ")" items ~keep:0
| Form.Vec items -> bracket "[" "]" items ~keep:0 | Form.Vec items -> bracket "[" "]" items ~keep:0

21
lib/parse.ml
View File

@ -2277,6 +2277,27 @@ let rec splice (f : Form.t) : Form.t list =
match f.Form.v with match f.Form.v with
| Form.List ({ Form.v = Form.Sym "do"; _ } :: items) -> | Form.List ({ Form.v = Form.Sym "do"; _ } :: items) ->
List.concat_map splice 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 ] | _ -> [ f ]
let parse_forms ~keep_going (forms : Form.t list) : Ast.decl list = let parse_forms ~keep_going (forms : Form.t list) : Ast.decl list =

166
lib/session.ml
View File

@ -187,6 +187,14 @@ let stale_sites ?(live = SM.empty) ?(running = false)
else " of " ^ Filename.basename l.Loc.file)) else " of " ^ Filename.basename l.Loc.file))
| _ -> None | _ -> None
in 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 (* 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. *) [step] is [step]'s call, and a generic's copy is the generic's. *)
let from ~kept m acc = 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; { caller = b.owner; target = st.callee; compiled = st.csig;
current = now; at = st.sloc; running; cause = cause st } current = now; at = st.sloc; running; cause = cause st }
:: acc :: 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) acc b.sites)
m acc m acc
in in
@ -964,55 +985,44 @@ 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 *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 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. *) 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 (* A fn form is every arity of its name (decision 139), so it replaces all
parameters (decision 135a): it replaces that version and leaves the of them: an arity the new form lacks is gone, and its compiled callers
others alone, and a number the name had no version for adds one. *) are stale. The names here are the names written; the bodies of a fn
let arity_of (d : Ast.decl) = with several arities are compiled under names of their own, which only
match d.Ast.d with the check knows ([arity_syms] below). *)
| Ast.Defn fn -> Some (Check.defn_arity t.env fn)
| _ -> None
in
(* The bodies a version is compiled under are named for it when the name
has several; which of the two a check makes is decided there, so both
are named and whichever the program has is the one installed. *)
let names = let names =
List.filter_map Ast.declared_name incoming List.filter_map Ast.declared_name incoming
@ List.filter_map @ List.filter_map
(fun (d : Ast.decl) -> (fun (d : Ast.decl) ->
match d.Ast.d with match d.Ast.d with Ast.Defmethod m -> Some m.Ast.mgen | _ -> None)
| Ast.Defmethod m -> Some m.Ast.mgen
| Ast.Defn fn ->
Option.map (Check.version_name fn.Ast.name) (arity_of d)
| _ -> None)
incoming incoming
in in
let replaces (old_ : Ast.decl) (nd : Ast.decl) = let incoming_named n =
match Ast.declared_name old_, Ast.declared_name nd with List.filter (fun (d : Ast.decl) -> Ast.declared_name d = Some n) incoming
| Some a, Some b when String.equal a b ->
(match arity_of old_, arity_of nd with
| Some i, Some j -> i = j
| _ -> true)
| _ -> false
in in
(* Replaced in place and appended only when genuinely new, so declaration (* Replaced in place and appended only when genuinely new, so declaration
order — which is emission order for globals — does not shuffle on every order — which is emission order for globals — does not shuffle on every
evaluation. A declaration that replaces several — a defonce sent over a evaluation. The first declaration of a name takes everything the form
name that had two versions — takes the place of the first and the rest declares under it, and any later one of that name goes. *)
go. *) let replaced = ref [] in
let used = ref [] in
let kept = let kept =
List.filter_map List.concat_map
(fun (d : Ast.decl) -> (fun (d : Ast.decl) ->
match List.find_opt (replaces d) incoming with match Ast.declared_name d with
| Some nd when List.memq nd !used -> None | Some n when List.mem n !replaced -> []
| Some nd -> used := nd :: !used; Some nd | Some n ->
| None -> Some d) (match incoming_named n with
| [] -> [ d ]
| nds -> replaced := n :: !replaced; nds)
| None -> [ d ])
t.decls t.decls
in in
let added = let added =
List.filter List.filter
(fun (d : Ast.decl) -> (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 incoming
in in
let decls = kept @ added in let decls = kept @ added in
@ -1049,9 +1059,12 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
let stale_site (st : site) = let stale_site (st : site) =
match now st.callee with match now st.callee with
| Some n -> not (String.equal n st.csig) | 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 in
(not (List.mem name names)) (not (List.mem (Check.written_name name) names))
&& SM.exists && SM.exists
(fun fname b -> (fun fname b ->
(String.equal b.owner name || String.equal fname name (String.equal b.owner name || String.equal fname name
@ -1138,14 +1151,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 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 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. *) the same path a [defn] the process was never built with already takes. *)
let declared_fns = (* Every function the program has, by name, for the lookups below: a
List.filter 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 -> (fun n ->
List.exists match Hashtbl.find_opt env.Check.versions n with
(fun (f : Tast.fn) -> String.equal f.Tast.name n) | Some vs -> List.map snd vs
program.Tast.fns) | None -> [])
names names
in in
let declared_fns =
List.filter (Hashtbl.mem in_program) (names @ arity_syms)
in
(* ── What evaluating a [def] does to the value ──────────────────────── (* ── What evaluating a [def] does to the value ────────────────────────
[def] is Common Lisp's [defparameter], and evaluating a defparameter [def] is Common Lisp's [defparameter], and evaluating a defparameter
assigns. That is the whole difference from [defvar] — [defonce] here — assigns. That is the whole difference from [defvar] — [defonce] here —
@ -1214,7 +1238,7 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
program.Tast.fns) program.Tast.fns)
(Check.instantiations env n) (Check.instantiations env n)
else []) else [])
names (names @ arity_syms)
in in
let new_instances = let new_instances =
List.filter_map List.filter_map
@ -1272,44 +1296,46 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
| _ -> None) | _ -> None)
program.Tast.fns program.Tast.fns
in in
(* A name that gains a second version in the loop is renamed, all of its (* A fn form that changes how many arities its name has renames them
versions alike ([Check.split_versions]), so the body the process has ([Check.split_versions]: [f] alone, [f~1] and [f~2] beside each other), so
under the plain name is no longer the program's: the version it became a compiled call can name a body the program no longer has under that
is a new symbol and is installed, and every compiled body that called the name. The caller is compiled again when its source still checks — it
plain name is compiled again, to call the version its arguments pick. then calls whichever arity its arguments pick — and is a stale caller,
Asked of any callee the program no longer has, which is the same fact tolerated above and listed by [stale_sites], when it does not. *)
seen from the call site: nothing else takes a function out of a program
whose callers still check. *)
let versions_moved = let versions_moved =
let has n = (* Only a form that gives a name several arities, or had one that had
List.exists (fun (f : Tast.fn) -> String.equal f.Tast.name n) them, renames anything, so only then is there anything to look for. *)
program.Tast.fns let touched =
List.exists
(fun n ->
Hashtbl.mem env.Check.versions n || Hashtbl.mem t.env.Check.versions n)
names
in in
let fresh = if not touched then []
List.filter_map else
let has n = Hashtbl.mem in_program n in
let written = Hashtbl.create 256 in
List.iter
(fun (f : Tast.fn) -> (fun (f : Tast.fn) ->
if Check.version_of f.Tast.name <> None Hashtbl.replace written (Check.written_name f.Tast.name) ())
&& not (known t f.Tast.name || SM.mem f.Tast.name t.built) program.Tast.fns;
then Some f.Tast.name let still_named n = Hashtbl.mem written (Check.written_name n) in
else None)
program.Tast.fns
in
let callers =
SM.fold SM.fold
(fun fname (b : built) acc -> (fun fname (b : built) acc ->
if has fname 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 then
match (* A lifted body is compiled with the function it came from; a
List.find_opt (fun (f : Tast.fn) -> String.equal f.Tast.name fname) global's initialiser has no such function, and is itself. *)
program.Tast.fns match Hashtbl.find_opt in_program fname with
with | Some { Tast.fparent = Some p; _ } when p <> "<thick>" && has p ->
| Some { Tast.fparent = Some p; _ } when p <> "<thick>" -> p :: acc p :: acc
| _ -> fname :: acc | _ -> fname :: acc
else acc) else acc)
t.built [] t.built []
in
if fresh = [] then [] else fresh @ callers
in in
let fns = let fns =
List.sort_uniq String.compare List.sort_uniq String.compare

32
spec-syntax.md
View File

@ -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 becomes `where is-ordered($t)` after the return type. **Built**; with no
`-> R` the return is `_`, read off the body. Several predicates are `-> R` the return is `_`, read off the body. Several predicates are
`where p, q`. `where p, q`.
- A name may have several versions, one per number of parameters: - A fn with several arities is one definition: `fn area` alone on its line,
`fn area(w: i32)` and `fn area(w: i32, h: i32)`. A call picks the version by and under it one line per arity, its parameters in parentheses, with its
how many arguments it passes; types play no part, so two versions with the block under that or `= expr` on the line:
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 fn area
`apply(area, 6)` against `f: Fn(i32) -> i32`; anywhere else write a lambda, (w: i32) -> i32 = w * w
`fn(w) => area(w, 2)`. In the dev loop a definition replaces the version with (w: i32, h: i32) -> i32
its number of parameters and leaves the others; another number adds a w * h
version. **Built** (decision 135a). ```
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`, - 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)`; `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 `once x: T`, `once x = v`, `const n = 3`. **Built.** `let x = v` and

13
test/programs/dev-versions.fln
View File

@ -1,12 +1,11 @@
;; A name with two versions in a running program: redefining one version ;; A fn with two arities in a running program: evaluating the fn form again
;; from the editor replaces it alone, and the other keeps running. ;; from the editor replaces its arities, and a call to each reaches the new
;; bodies.
import agent "vendor:agent" import agent "vendor:agent"
fn area(w: i32) -> i32 fn area
w * w (w: i32) -> i32 = w * w
(w: i32, h: i32) -> i32 = w * h
fn area(w: i32, h: i32) -> i32
w * h
fn main() -> i32 fn main() -> i32
agent/start("/tmp/flan-dev-versions-fallback.sock") agent/start("/tmp/flan-dev-versions-fallback.sock")

82
test/programs/versions.fln
View File

@ -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 struct Grain
kind: i32 kind: i32
fn is-empty-cell(g: Grain) -> bool ;; One arity calling another.
g.kind == 0 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. ;; One-line arities.
fn is-empty-cell(r: i32, c: i32) -> bool fn area
is-empty-cell(Grain{.kind r * c}) (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 ;; A generic arity beside another, each with its own where clause.
w * w 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 ;; An arity that recurses on itself and one that calls it.
w * h 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 ;; defer runs per arity.
area(w, h) * d 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. ;; Untyped arities take dyn arguments, and the count still picks.
fn pick(x: $t) -> $t fn scale
x (x)
x * 10
fn pick(x: $t, y: $t, first: bool) -> $t (x, y)
if first then x else y x * y
;; A version that recurses on itself and calls the other.
fn count(n: i32) -> i32
count(n, 0)
fn count(n: i32, acc: i32) -> i32
if n == 0 then acc else count(n - 1, acc + n)
;; defer runs per version.
fn noisy(a: i32) -> i32
defer println("leaving noisy/1")
a
fn noisy(a: i32, b: i32) -> i32
defer println("leaving noisy/2")
a + b
;; Untyped versions take dyn arguments, and the count still picks.
fn scale(x)
x * 10
fn scale(x, y)
x * y
fn apply(f: Fn(i32) -> i32, x: i32) -> i32 fn apply(f: Fn(i32) -> i32, x: i32) -> i32
f(x) f(x)
@ -62,7 +60,7 @@ fn main()
println(area(3, 4, 5)) println(area(3, 4, 5))
println(pick(7)) println(pick(7))
println(pick(1.5, 2.5, false)) println(pick(1.5, 2.5, false))
println(pick("a", "b", true)) println(pick(3, 9, true))
println(count(10)) println(count(10))
println(noisy(1)) println(noisy(1))
println(noisy(1, 2)) println(noisy(1, 2))

4
test/test_acceptance.ml
View File

@ -2248,9 +2248,9 @@ let () =
let if_let_kept_out = let if_let_kept_out =
"1\n4\nnone\n6\nnone\n9\n2\nnone\n3\nnone\n5\nnil\n7\n" "1\n4\nnone\n6\nnone\n9\n2\nnone\n3\nnone\n5\nnil\n7\n"
in in
(* One name, several versions, picked by the number of arguments. *) (* One fn, several arities, picked by the number of arguments. *)
let versions_out = 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" leaving noisy/1\n1\nleaving noisy/2\n3\n40\n5\n36\n12\n"
in in
outputs "versions by arity" "programs/versions.fln" versions_out; outputs "versions by arity" "programs/versions.fln" versions_out;

45
test/test_dev.ml
View File

@ -5551,7 +5551,7 @@ let () =
if not (await ~ms:10000 (fun () -> not (alive ()))) then if not (await ~ms:10000 (fun () -> not (alive ()))) then
fail "--two-process: the new child did not finish" fail "--two-process: the new child did not finish"
else begin 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 if status r <> "ok" then
fail "--two-process: a change while the child has ended: %s" fail "--two-process: a change while the child has ended: %s"
(Option.value ~default:"" (Wire.string_field r "message")); (Option.value ~default:"" (Wire.string_field r "message"));
@ -5568,7 +5568,7 @@ let () =
(fun code -> (fun code ->
if status (ev code) <> "ok" then if status (ev code) <> "ok" then
fail "--two-process: %s was refused" code) 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; Buffer.clear seen;
let r = ask "(:op \"rerun\")" in let r = ask "(:op \"rerun\")" in
if status r <> "ok" then if status r <> "ok" then
@ -7540,9 +7540,9 @@ let () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ fsock; fout ]) List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ fsock; fout ])
[ "x86"; "llvm" ]; [ "x86"; "llvm" ];
(* ── One name, two versions (decision 135a) ────────────────────────── (* ── One fn, two arities (decision 139) ─────────────────────────────
Redefining one version of a running program's function from a .fln Evaluating a running program's fn form again from a .fln buffer
buffer replaces that version alone: the other still answers, and the replaces its arities: a call to each reaches the new body, and the
listing shows the name once with both signatures. *) listing shows the name once with both signatures. *)
List.iter List.iter
(fun backend -> (fun backend ->
@ -7583,23 +7583,34 @@ let () =
if not (await ~ms:20000 (fun () -> status (ask "1") = "ok")) then if not (await ~ms:20000 (fun () -> status (ask "1") = "ok")) then
fail "--%s: the versions program never took an expression" backend fail "--%s: the versions program never took an expression" backend
else begin else begin
is "the one-argument version" "area(3)" "9"; is "the one-argument arity" "area(3)" "9";
is "the two-argument version" "area(3, 4)" "12"; is "the two-argument arity" "area(3, 4)" "12";
let r = let r =
request c request c
(Printf.sprintf "(:op \"eval\" :code %s :file %s)" (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)) (Wire.quote file))
in in
if status r <> "ok" then 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")); (Option.value ~default:(status r) (Wire.string_field r "message"));
is "the redefined version" "area(3, 4)" "112"; is "the new two-argument arity" "area(3, 4)" "112";
is "the version left alone" "area(3)" "9"; is "the new one-argument arity" "area(3)" "10";
let defs = request c "(:op \"defs\")" in let text = Form.to_string (request c "(:op \"defs\")") in
let text = Form.to_string defs in
if not (contains_sub text "area [i32] i32 | area [i32 i32] i32") then 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; end;
(try Unix.close c with Unix.Unix_error _ -> ()); (try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill vpid Sys.sigkill with Unix.Unix_error _ -> ()); (try Unix.kill vpid Sys.sigkill with Unix.Unix_error _ -> ());
@ -8451,7 +8462,7 @@ let () =
| v -> | v ->
fail "--%s: a capturing fn at the prompt answered %s" backend fail "--%s: a capturing fn at the prompt answered %s" backend
(Option.value ~default:"nothing" v)); (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 if status r <> "ok" then
fail "--%s: a signature change was refused: %s" backend (said r) fail "--%s: a signature change was refused: %s" backend (said r)
else begin else begin
@ -8483,7 +8494,7 @@ let () =
if not (contains_sub fields want) then if not (contains_sub fields want) then
fail "--%s: StaleCall's fields do not show %S: %s" fail "--%s: StaleCall's fields do not show %S: %s"
backend want fields) backend want fields)
[ "scale"; "[i64] i64"; "[f64] i64" ]; [ "scale"; "[i64] i64"; "[i64 i64] i64" ];
(match Wire.string_field (request c "(:op \"break\")") "site" with (match Wire.string_field (request c "(:op \"break\")") "site" with
| Some site when contains_sub site "dev-stale.flan:23:" -> () | Some site when contains_sub site "dev-stale.flan:23:" -> ()
| Some site -> fail "--%s: the stale call's site is %s" backend site | Some site -> fail "--%s: the stale call's site is %s" backend site
@ -8492,7 +8503,7 @@ let () =
let r = let r =
eval eval
"(defn step [] i64 (set ticks (+ ticks 1)) \ "(defn step [] i64 (set ticks (+ ticks 1)) \
(set seen (scale (f64 ticks))) seen)" (set seen (scale ticks 3)) seen)"
in in
if status r <> "ok" then if status r <> "ok" then
fail "--%s: recompiling the stale caller: %s" backend (said r) fail "--%s: recompiling the stale caller: %s" backend (said r)

55
test/test_flan.ml
View File

@ -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) -> 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" refuses_all ~fln:true "^^ in .fln" "fn f(a: bool, b: bool) -> bool\n a ^^ b == 0\n"
"write a != b"; "write a != b";
(* ── One name, several versions (decision 135a) ─────────────────── *) (* ── One fn, several arities (decision 139) ─────────────────────── *)
let two = "fn f(a: i32) -> i32\n a\n\nfn f(a: i32, b: i32) -> i32\n a + b\n\n" in let two = "fn f\n (a: i32) -> i32 = a\n (a: i32, b: i32) -> i32 = a + b\n\n" in
refuses_all ~fln:true "two versions of one arity are defined twice" refuses_all ~fln:true "a second fn of one name is defined twice, whatever its arity"
(two ^ "fn f(x: i64, y: i64) -> i64\n x\n") "fn f(a: i32) -> i32\n a\n\nfn f(a: i32, b: i32) -> i32\n a + b\n"
"f is defined twice with 2 parameters"; "f is defined twice. A function with several arities is one definition, \
refuses_all ~fln:true "one arity written twice is defined twice" each arity under it:\n\n fn f\n (a: T) -> R";
"fn g(a: i32) -> i32\n a\n\nfn g(b: bool) -> i32\n 0\n" refuses_all "and in parens, the grouped defn"
"g is defined twice"; "(defn f [a i32] i32 a) (defn f [a i32 b i32] i32 (+ a b))"
refuses_all ~fln:true "main has one version" "(defn f ([a T] R ...) ([a T b T] R ...))";
"fn main()\n 0\n\nfn main(x: i32)\n 0\n" "main is defined twice"; refuses_all ~fln:true "a second fn beside a grouped one is defined twice"
refuses_all ~fln:true "a call no version takes lists the versions" (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") (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)"; f(a: i32, b: i32)";
refuses_all "and in parens, in the file's own spelling" 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 f ([a i32] i32 a) ([a i32 b i32] i32 (+ a b))) (defn h [] i32 (f))"
(defn h [] i32 (f))"
"It has these:\n (f [a i32])\n (f [a i32 b i32])"; "It has these:\n (f [a i32])\n (f [a i32 b i32])";
refuses_all ~fln:true "the name alone is not a value" refuses_all ~fln:true "the name alone is not a value"
(two ^ "fn h() -> i32\n let g = f\n 0\n") (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 \ does not say which function this is. Wrap it in a function that calls \
the one you mean, as in fn(a) => f(a)"; the one you mean, as in fn(a) => f(a)";
refuses_all ~fln:true "a wanted Fn type of another arity picks nothing" 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") (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" refuses_all ~fln:true "an argument's refusal names the function as written"
(two ^ "fn h() -> i32\n f(true)\n") (two ^ "fn h() -> i32\n f(true)\n")
"this is the 1st argument of f"; "this is the 1st argument of f";
refuses_all ~fln:true "fn takes no rest parameter to overlap a version" refuses_all ~fln:true "an arity takes no rest parameter"
"fn f(a: i32) -> i32\n a\n\nfn f(a: i32, & xs) -> i32\n a\n" "fn f\n (a: i32) -> i32 = a\n (a: i32, & xs) -> i32 = a\n"
"& (a rest parameter) is not one"; "& (a rest parameter) is not one";
rejects_check "popcount of a float" rejects_check "popcount of a float"
"(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64"; "(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" kind_is "a name defined twice has a kind"
"(defn f [] i32 1)\n(defn f [] i32 2)" "check/defined-twice"; "(defn f [] i32 1)\n(defn f [] i32 2)" "check/defined-twice";
kind_is "a call no version takes has a kind" 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"; "check/no-version";
kind_is "a name with versions as a value has a kind" 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/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 (* The note is the half a location and a string could never carry: the
*other* place, with its own span and its own explanation. *) *other* place, with its own span and its own explanation. *)

174
test/test_session.ml
View File

@ -54,15 +54,14 @@ let () =
each of these installs and names no stale caller. Dyn-ness is part of a 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 signature like anything else; the last two are the changes the source
does not spell out as a type. *) 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 let t, _ = Session.create ~file:"programs/reload.flan" () in
match Session.eval t src with match Session.eval t src with
| c -> | 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); fail "%s installed %s" name (String.concat " " c.Session.fns);
if List.map (fun (x : Session.stale) -> x.Session.caller) c.Session.stale if c.Session.stale <> [] then
<> stale fail "%s left a caller behind that nothing has" name
then fail "%s left the wrong callers behind" name
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" name m | exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" name m
in in
(* A session's defn named as a prelude macro shadows it for a later form (* 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) (String.concat " " c.Session.fns)
| exception Loc.Error { Loc.dmsg = m; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a call to a session's clamp was expanded as the macro: %s" 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 installs "a changed parameter type" "(defn outer [x i64] i64 (bump))";
version of the name (decision 135a), below. [helper] is called from
[bump], which is left compiled against the old signature. *)
installs ~fn:"helper" ~stale:[ "bump" ] "a changed parameter type"
"(defn helper [x f64] i64 (i64 x))";
installs "a changed return type" "(defn outer [] i32 (i32 (bump)))"; installs "a changed return type" "(defn outer [] i32 (i32 (bump)))";
installs "a changed arity" "(defn outer [a i64 b i64] i64 (bump))";
installs "a return type that became dyn" "(defn outer [] dyn (bump))"; installs "a return type that became dyn" "(defn outer [] dyn (bump))";
installs ~fn:"helper" ~stale:[ "bump" ] "a parameter that became dyn" installs "a parameter that became dyn" "(defn outer [x] i64 (bump))";
"(defn helper [x] i64 7)";
(* Another number of parameters is another version of the name. Both (* A fn form with several arities (decision 139) is every arity of its name:
versions are renamed for their arities, so the one the process had under each is compiled under a name of its own, evaluating the form again
the plain name is installed again under its new one; redefining one replaces all of them, and an arity it no longer has is gone. *)
version then replaces it alone and leaves the other in the program. *)
(let t, _ = Session.create ~file:"programs/reload.flan" () in (let t, _ = Session.create ~file:"programs/reload.flan" () in
match Session.eval t "(defn outer [a i64 b i64] i64 (+ a b (bump)))" with let names () =
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "a second version was refused: %s" m List.map (fun (f : Tast.fn) -> f.Tast.name) t.Session.program.Tast.fns
| c -> in
if List.sort compare c.Session.fns <> [ "outer~0"; "outer~2" ] then let eval what src =
fail "a second version installed %s" (String.concat " " c.Session.fns); match Session.eval t src with
if c.Session.stale <> [] then fail "a second version left a caller behind"; | c -> Some c
(match Session.eval t "(defn outer [a i64 b i64] i64 (* a b))" with | exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" what m; None
| exception Loc.Error { Loc.dmsg = m; _ } -> in
fail "redefining one version was refused: %s" m (match eval "two arities" "(defn outer ([] i64 (bump)) ([a i64 b i64] i64 (+ a b)))" with
| c -> | Some c ->
if c.Session.fns <> [ "outer~2" ] then if List.sort compare c.Session.fns <> [ "outer~0"; "outer~2" ] then
fail "redefining one version installed %s" fail "two arities installed %s" (String.concat " " c.Session.fns);
(String.concat " " c.Session.fns); if c.Session.stale <> [] then fail "two arities left a caller behind"
let names = | None -> ());
List.map (fun (f : Tast.fn) -> f.Tast.name) t.Session.program.Tast.fns (match eval "the form again" "(defn outer ([] i64 (bump)) ([a i64 b i64] i64 (* a b)))" with
in | Some c ->
if not (List.mem "outer~0" names && List.mem "outer~2" names) then if List.sort compare c.Session.fns <> [ "outer~0"; "outer~2" ] then
fail "redefining one version lost the other")); fail "the form again installed %s" (String.concat " " c.Session.fns)
(* A compiled caller of the plain name is compiled again, to call the | None -> ());
version its arguments pick: [bump] calls [helper] with one argument. *) (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 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 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 -> | c ->
if List.sort compare c.Session.fns <> [ "bump"; "helper~1"; "helper~2" ] then (match c.Session.stale with
fail "a second version of a called function installed %s" | [ x ] when x.Session.caller = "bump" && x.Session.target = "helper~1"
(String.concat " " c.Session.fns); && x.Session.compiled = "[i64] i64"
if c.Session.stale <> [] then && x.Session.current = "[i64 i64] i64" -> ()
fail "a second version of a called function left a caller behind"); | 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 (* [main] is the exception: the startup code calls it, and that call was
compiled into the program when it started. *) compiled into the program when it started. *)
refuses ~file:"programs/dev-stale.flan" "a changed main" 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 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. *) arity, and that is not a reason to refuse: it is not being recompiled. *)
(let t, _ = Session.create ~file:"programs/dev-stale.flan" () in (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; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a signature change with compiled callers was refused: %s" m fail "a signature change with compiled callers was refused: %s" m
| c -> | c ->
@ -148,12 +208,12 @@ let () =
c.Session.stale c.Session.stale
in in
let want = let want =
[ ("step", "scale", "[i64] i64", "[f64] i64", 23); [ ("step", "scale", "[i64] i64", "[i64 i64] i64", 23);
("pick", "scale", "[i64] i64", "[f64] i64", 26); ("pick", "scale", "[i64] i64", "[i64 i64] i64", 26);
(* The clause's call is named for the function it is written in, (* The clause's call is named for the function it is written in,
not for the lifted function it became. *) not for the lifted function it became. *)
("guarded", "scale", "[i64] i64", "[f64] i64", 45); ("guarded", "scale", "[i64] i64", "[i64 i64] i64", 45);
("guarded", "scale", "[i64] i64", "[f64] i64", 46) ] ("guarded", "scale", "[i64] i64", "[i64 i64] i64", 46) ]
in in
if named <> want then if named <> want then
fail "the stale callers were %s" fail "the stale callers were %s"
@ -164,7 +224,7 @@ let () =
(* Recompiling a stale caller clears it, and only it. *) (* Recompiling a stale caller clears it, and only it. *)
(match (match
Session.eval t 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 with
| c -> | c ->
(match c.Session.stale with (match c.Session.stale with
@ -216,9 +276,9 @@ let () =
in in
let main_src = let main_src =
"(defn main [] i32 (agent/start \"/tmp/x.sock\") \ "(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 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 -> | c ->
if mains c <> [ true ] then fail "a stale call in main was not flagged as running" 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); | 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)); | exception Loc.Error { Loc.dmsg = m; _ } -> fail "after a re-run: %s" m));
(let t, _ = Session.create ~file:"programs/dev-stale.flan" () in (let t, _ = Session.create ~file:"programs/dev-stale.flan" () in
ignore 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 match
Session.eval ~running:false t 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 with
| c -> | c ->
if List.exists (fun (x : Session.stale) -> x.Session.caller = "main") 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 tolerance is for a body compiled against a signature that changed, and
[twice] here is new, in the form, and wrong. *) [twice] here is new, in the form, and wrong. *)
refuses ~file:"programs/dev-stale.flan" "a form that is wrong on its own" 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"; "scale";
(* The storage exists and has a shape: reusing it reads at the wrong offsets, (* 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 (let tp, _ = Session.create ~file:"programs/pkg-private.flan" () in
match match
Session.eval ~origin:"programs/pkgs/secret/secret.flan" tp 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 with
| exception Loc.Error { Loc.dmsg = m; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a package function's signature change was refused: %s" 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)); (List.map (fun (n, f, l) -> Printf.sprintf "%s %s:%d" n f l) where));
(match (match
Session.eval ~origin:"programs/pkg-private.flan" tp 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 with
| _ -> fail "a stale caller recompiled past a defn- was accepted" | _ -> fail "a stale caller recompiled past a defn- was accepted"
| exception Loc.Error { Loc.dmsg = m; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
@ -991,7 +1051,7 @@ let () =
(let tp, _ = Session.create ~file:"programs/pkg-private.flan" () in (let tp, _ = Session.create ~file:"programs/pkg-private.flan" () in
match match
Session.eval ~origin:"programs/pkgs/secret/secret.flan" tp 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 with
| exception Loc.Error { Loc.dmsg = m; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a private package function's signature change was refused: %s" m fail "a private package function's signature change was refused: %s" m