A function name has one version per arity, and a call picks the version by its number of arguments.
This commit is contained in:
parent
15ff547e52
commit
179156b105
7
TODO.org
7
TODO.org
@ -45,6 +45,13 @@ Decided 2026-09-26 (128) to pause: dyn vectors are mutable, so taking from the f
|
||||
shifts every element. Options were a linked list (cons/first/rest) or storing the dyn
|
||||
vector as a ring buffer with a cheap read-only rest view; the ring buffer was
|
||||
recommended. Waits on a program that needs it.
|
||||
** DONE A name has one version per arity (decision 135a)
|
||||
CLOSED: [2026-09-26]
|
||||
The call's argument count picks the version at compile time; each is renamed =f~N= only
|
||||
when a name has two or more. Rules out overloading by type at one arity, rest parameters
|
||||
on =fn= (refused already), and more than one =main=. In the dev loop another arity adds a
|
||||
version rather than replacing, so an arity change is no longer a stale-call signature
|
||||
change: only a same-arity one is.
|
||||
** DONE if let
|
||||
CLOSED: [2026-09-26]
|
||||
=(if-let [P v] then else)= in paren syntax; an elif chain is the else. With no else it
|
||||
|
||||
250
lib/check.ml
250
lib/check.ml
@ -223,6 +223,11 @@ type env = {
|
||||
function can show it. Kept apart from [fparams] because a foreign
|
||||
[declare] has a location and no parameter vector worth showing. *)
|
||||
fn_locs : (string, Loc.t) Hashtbl.t;
|
||||
(* A name with several versions, one per arity (decision 135a): the name as
|
||||
written, to each version's arity and the name it was renamed to
|
||||
([version_name]). A name with one version is not in here and keeps its
|
||||
own name, so its symbol does not change. *)
|
||||
versions : (string, (int * string) list) Hashtbl.t;
|
||||
(* Every [defn-], by name, with where it was written and how far it is
|
||||
visible. See [private_ref]. *)
|
||||
privates : (string, Loc.t * Ast.privacy) Hashtbl.t;
|
||||
@ -389,6 +394,7 @@ and new_env_record () = {
|
||||
fns = Hashtbl.create 32;
|
||||
fparams = Hashtbl.create 32;
|
||||
fn_locs = Hashtbl.create 32;
|
||||
versions = Hashtbl.create 4;
|
||||
privates = Hashtbl.create 8;
|
||||
globals = Hashtbl.create 16;
|
||||
global_locs = Hashtbl.create 16;
|
||||
@ -445,7 +451,7 @@ let snapshot_env env : (unit -> unit) * (unit -> unit) =
|
||||
datas = _; unions = _; cases = _; aliases = _;
|
||||
consts = _; enums = _; parents = _; externs = _;
|
||||
extern_locs = _; fparams = _; fn_locs = _;
|
||||
privates = _; globals = _; global_locs = _;
|
||||
versions = _; privates = _; globals = _; global_locs = _;
|
||||
generics = _; gsigs = _; refused_generics = _;
|
||||
gstructs = _; broken = _; glens = _; classes = _;
|
||||
tracks = _; inferred = _; infer_failed = _ } = env in
|
||||
@ -4011,6 +4017,35 @@ let rec view_desc ?(into = false) structs (t : Types.t)
|
||||
says which one the reader is looking at. *)
|
||||
let fln_source (loc : Loc.t) = Source.indented_at loc
|
||||
|
||||
(* A version's own name: see [split_versions]. *)
|
||||
let version_name base arity = base ^ "~" ^ string_of_int arity
|
||||
|
||||
(* The name as written and the arity, for a name [version_name] made. *)
|
||||
let version_of n =
|
||||
match String.rindex_opt n '~' with
|
||||
| Some i when i > 0 && i < String.length n - 1 ->
|
||||
let tail = String.sub n (i + 1) (String.length n - i - 1) in
|
||||
if String.for_all (fun c -> c >= '0' && c <= '9') tail then
|
||||
Some (String.sub n 0 i, int_of_string tail)
|
||||
else None
|
||||
| _ -> None
|
||||
|
||||
(* A name as its reader wrote it: a version's is the name it is a version of,
|
||||
which is what every message about it says. *)
|
||||
let written_name n =
|
||||
match version_of n with
|
||||
| Some (b, _) -> b
|
||||
| None ->
|
||||
(* A generic version's copy, [pick~3-f64], is the copy [pick-f64]. *)
|
||||
match String.rindex_opt n '~' with
|
||||
| Some i when i > 0 ->
|
||||
let j = ref (i + 1) in
|
||||
while !j < String.length n && n.[!j] >= '0' && n.[!j] <= '9' do incr j done;
|
||||
if !j > i + 1 && !j < String.length n && n.[!j] = '-' then
|
||||
String.sub n 0 i ^ String.sub n !j (String.length n - !j)
|
||||
else n
|
||||
| _ -> n
|
||||
|
||||
(* Which form defined each mutable global, [defonce] or [def], so a fix that
|
||||
rewrites the definition keeps the form the programmer chose. Filled where
|
||||
globals are collected; a name missing from it (a defconst) is given
|
||||
@ -7005,6 +7040,43 @@ and var ctx ?(qualified = false) loc ~want name =
|
||||
read: there is no second binding of [double] for it to have meant
|
||||
instead, so Common Lisp's #'double would be punctuation answering
|
||||
a question this language does not ask. *)
|
||||
(* A name with several versions is several functions, so the name
|
||||
alone is not a value. A wanted function type with a count of
|
||||
parameters says which one was meant. *)
|
||||
let wanted_version () =
|
||||
match Hashtbl.find_opt ctx.env.versions name with
|
||||
| None -> None
|
||||
| Some vs ->
|
||||
match Option.bind want fn_sig with
|
||||
| Some (ps, _) when List.mem_assoc (List.length ps) vs ->
|
||||
Some (List.assoc (List.length ps) vs)
|
||||
| _ ->
|
||||
let fln = fln_source loc in
|
||||
let k, v0 = List.hd vs in
|
||||
let xs =
|
||||
match Hashtbl.find_opt ctx.env.fparams v0 with
|
||||
| Some fs -> List.map (fun (f : Ast.field) -> f.Ast.fname) fs
|
||||
| None -> List.init k (fun i -> Printf.sprintf "x%d" (i + 1))
|
||||
in
|
||||
Loc.failk "check/several-versions" loc
|
||||
"%s has several versions, one per number of arguments, so \
|
||||
the name alone does not say which function this is. Wrap \
|
||||
it in a function that calls the one you mean, as in %s. \
|
||||
Its versions are:\n%s"
|
||||
name
|
||||
(if fln then
|
||||
Printf.sprintf "fn(%s) => %s(%s)" (String.concat ", " xs)
|
||||
name (String.concat ", " xs)
|
||||
else
|
||||
Printf.sprintf "(fn [%s] (%s %s))" (String.concat " " xs)
|
||||
name (String.concat " " xs))
|
||||
(String.concat "\n"
|
||||
(List.map (fun (_, v) -> " " ^ version_text ctx.env loc v)
|
||||
vs))
|
||||
in
|
||||
let name =
|
||||
match wanted_version () with Some v -> v | None -> name
|
||||
in
|
||||
(match Hashtbl.find_opt ctx.env.fns name with
|
||||
| Some (params, ret) ->
|
||||
private_ref ctx loc name;
|
||||
@ -7026,7 +7098,7 @@ and var ctx ?(qualified = false) loc ~want name =
|
||||
match special_float name with
|
||||
| Some (x, k) ->
|
||||
expect ctx loc ~want (mk loc (Types.Float k) (Tast.Float (x, k)))
|
||||
| None -> unknown_name ctx loc name)
|
||||
| None -> unknown_name ctx loc (written_name name))
|
||||
|
||||
(* What remains of spec-memory.md's ownership section after the repeals of
|
||||
2026-09-18 is the allocator's side alone: the region rule decides where a
|
||||
@ -11082,12 +11154,13 @@ and check_arg ctx name i (want : Types.t) (a : Ast.expr) =
|
||||
let p = List.nth ps i in
|
||||
[ Loc.note p.Ast.floc
|
||||
(Printf.sprintf "%s's %s parameter %s is declared %s"
|
||||
name which p.Ast.fname (tyname p.Ast.floc want)) ]
|
||||
(written_name name) which p.Ast.fname (tyname p.Ast.floc want)) ]
|
||||
| _ -> []
|
||||
in
|
||||
refuse_or_poison ctx.env a.Ast.loc
|
||||
(Loc.diag ~kind:"check/argument-type" ~notes a.Ast.loc
|
||||
(Printf.sprintf "%s — this is the %s argument of %s" d.Loc.dmsg which name))
|
||||
(Printf.sprintf "%s — this is the %s argument of %s" d.Loc.dmsg which
|
||||
(written_name name)))
|
||||
| exception Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d
|
||||
|
||||
and fields_named env n : Tast.structure option =
|
||||
@ -16010,6 +16083,19 @@ and ordinary_call ctx ~want loc name args =
|
||||
| None -> false) ->
|
||||
let ty, _ = Hashtbl.find ctx.env.globals name in
|
||||
call_value ctx ~want loc (mk loc ty (Tast.Global name)) args
|
||||
(* A name with several versions: the number of arguments picks one, and
|
||||
the call is then a call to that version by its own name. *)
|
||||
| _ when Hashtbl.mem ctx.env.versions name ->
|
||||
let vs = Hashtbl.find ctx.env.versions name in
|
||||
(match List.assoc_opt (List.length args) vs with
|
||||
| Some v -> ordinary_call ctx ~want loc v args
|
||||
| None ->
|
||||
let n = List.length args in
|
||||
Loc.failk "check/no-version" loc
|
||||
"%s has no version that takes %d argument%s. It has these:\n%s"
|
||||
name n (if n = 1 then "" else "s")
|
||||
(String.concat "\n"
|
||||
(List.map (fun (_, v) -> " " ^ version_text ctx.env loc v) vs)))
|
||||
| _ when Hashtbl.mem ctx.env.gsigs name ->
|
||||
private_ref ctx loc name;
|
||||
let vars, params, ret = Hashtbl.find ctx.env.gsigs name in
|
||||
@ -16317,6 +16403,7 @@ and private_ref ctx loc name =
|
||||
| Ast.Private_to_file -> real at.Loc.file
|
||||
| _ -> "the files in " ^ Filename.dirname (real at.Loc.file)
|
||||
in
|
||||
let name = written_name name in
|
||||
Loc.failk "check/private" loc
|
||||
~notes:[ Loc.note at (Printf.sprintf "%s is declared here" name) ]
|
||||
"%s is private to its package: it is declared with defn-, so only %s \
|
||||
@ -16325,10 +16412,42 @@ and private_ref ctx loc name =
|
||||
end
|
||||
| _ -> ()
|
||||
|
||||
(* One version of a name, as a line in a message: its parameters, named and
|
||||
typed, spelled the way the file around [loc] writes a function. *)
|
||||
and version_text env loc v =
|
||||
let base = match version_of v with Some (b, _) -> b | None -> v in
|
||||
let names, tys =
|
||||
match Hashtbl.find_opt env.fns v, Hashtbl.find_opt env.gsigs v with
|
||||
| Some (ps, _), _ ->
|
||||
( (match Hashtbl.find_opt env.fparams v with
|
||||
| Some fs -> List.map (fun (f : Ast.field) -> f.Ast.fname) fs
|
||||
| None -> []),
|
||||
ps )
|
||||
| None, Some (_, ps, _) ->
|
||||
( (match Hashtbl.find_opt env.generics v with
|
||||
| Some fn -> List.map (fun (f : Ast.field) -> f.Ast.fname) fn.Ast.params
|
||||
| None -> []),
|
||||
ps )
|
||||
| None, None -> ([], [])
|
||||
in
|
||||
let param i t =
|
||||
let n = match List.nth_opt names i with Some n -> n | None -> "_" in
|
||||
if fln_source loc then n ^ ": " ^ tyname loc t
|
||||
else n ^ " " ^ tyname loc t
|
||||
in
|
||||
let ps = List.mapi param tys in
|
||||
if fln_source loc then base ^ "(" ^ String.concat ", " ps ^ ")"
|
||||
else "(" ^ base ^ " [" ^ String.concat " " ps ^ "])"
|
||||
|
||||
and shadows_builtin ctx loc name =
|
||||
(* Where the definition was written, if this name has one. A generic is in
|
||||
[generics] and nowhere near [fn_locs], so both tables are asked. *)
|
||||
let declared_in () =
|
||||
let name =
|
||||
match Hashtbl.find_opt ctx.env.versions name with
|
||||
| Some ((_, v) :: _) -> v
|
||||
| _ -> name
|
||||
in
|
||||
match Hashtbl.find_opt ctx.env.fn_locs name with
|
||||
| Some at -> Some at.Loc.file
|
||||
| None ->
|
||||
@ -16359,7 +16478,7 @@ and shadows_builtin ctx loc name =
|
||||
[Entity] only on a miss. *)
|
||||
and generic_call ctx ~want loc name vars pats pret args =
|
||||
if List.length args <> List.length pats then
|
||||
fail loc "%s takes %d argument%s, given %d" name (List.length pats)
|
||||
fail loc "%s takes %d argument%s, given %d" (written_name name) (List.length pats)
|
||||
(if List.length pats = 1 then "" else "s") (List.length args);
|
||||
(* Arguments first, and with no expectation where the parameter's type still
|
||||
mentions a variable — there is nothing to expect until the argument has
|
||||
@ -16516,7 +16635,7 @@ and generic_call ctx ~want loc name vars pats pret args =
|
||||
exactly — the pair cannot join at the wider type there. \
|
||||
Write the conversion — (%s x) — or pass the arguments at \
|
||||
one type"
|
||||
name v (tyname loc p) (tyname loc a.Tast.ty) v
|
||||
(written_name name) v (tyname loc p) (tyname loc a.Tast.ty) v
|
||||
(tyname loc p)
|
||||
| None ->
|
||||
pending := (v, p, a.Tast.ty, a.Tast.loc) :: !pending;
|
||||
@ -16526,14 +16645,14 @@ and generic_call ctx ~want loc name vars pats pret args =
|
||||
(* [~widen]: this is the top of an argument's type, which is the one
|
||||
place a widening thunk can be built around it. See [bind_ty]. *)
|
||||
if (not handled) && not (bind_ty ~widen:true subst p a.Tast.ty) then
|
||||
fail a.Tast.loc "%s expects %s here, found %s%s" name
|
||||
fail a.Tast.loc "%s expects %s here, found %s%s" (written_name name)
|
||||
(tyname loc p) (tyname loc a.Tast.ty)
|
||||
(match p, a.Tast.ty with
|
||||
| Types.Slice (Types.Mut, _), Types.Slice (Types.Const, e) ->
|
||||
Printf.sprintf
|
||||
" — %s takes a slice it may write through, and a %s can \
|
||||
only be read%s"
|
||||
name (tyname loc a.Tast.ty)
|
||||
(written_name name) (tyname loc a.Tast.ty)
|
||||
(match const_copy ctx.env e with
|
||||
| Some c ->
|
||||
Printf.sprintf ". %s copies v into one that can be written" c
|
||||
@ -16550,7 +16669,7 @@ and generic_call ctx ~want loc name vars pats pret args =
|
||||
(fun v ->
|
||||
if not (List.mem_assoc v !subst) then
|
||||
fail loc
|
||||
"%s's type variable $%s is not determined by any argument" name v)
|
||||
"%s's type variable $%s is not determined by any argument" (written_name name) v)
|
||||
vars;
|
||||
(* The pairs that met no join, re-asked now that every argument has spoken.
|
||||
A later, wider argument dissolves one — u32 and i32 both widen into an
|
||||
@ -16567,7 +16686,7 @@ and generic_call ctx ~want loc name vars pats pret args =
|
||||
"this call binds %s's $%s to both %s and %s, and neither holds \
|
||||
every value of the other. Write the conversion you mean at one \
|
||||
of the arguments, or pass them at one type"
|
||||
name v (tyname loc t1) (tyname loc t2))
|
||||
(written_name name) v (tyname loc t1) (tyname loc t2))
|
||||
!pending;
|
||||
(* The binding is final; the arguments it out-widened catch up. Only a bare
|
||||
[$t] parameter can be here — [bound_exactly] kept every container-bound
|
||||
@ -16615,7 +16734,7 @@ and generic_call ctx ~want loc name vars pats pret args =
|
||||
mk a.Tast.loc (Types.Fn (ps, r))
|
||||
(Tast.Thicken (thick_thunk ctx.env a.Tast.loc ps r, a))
|
||||
else
|
||||
fail a.Tast.loc "%s expects %s here, found %s" name
|
||||
fail a.Tast.loc "%s expects %s here, found %s" (written_name name)
|
||||
(tyname loc (Types.Fn (ps, r)))
|
||||
(tyname loc a.Tast.ty)
|
||||
| _ -> a))
|
||||
@ -16659,7 +16778,7 @@ and generic_call ctx ~want loc name vars pats pret args =
|
||||
"this call would instantiate %s at $%s = %s, and a type variable \
|
||||
is not instantiated at dyn. Write the type the value has, or use \
|
||||
a defgeneric with a defmethod per class"
|
||||
name v (tyname loc t))
|
||||
(written_name name) v (tyname loc t))
|
||||
!subst;
|
||||
let cparams = List.map (subst_ty !subst) pats in
|
||||
let cret = subst_ty !subst pret in
|
||||
@ -16692,13 +16811,13 @@ and generic_call ctx ~want loc name vars pats pret args =
|
||||
"%s is written %s, and this call passes the \
|
||||
type variable $%s, which nothing here declares %s. Add \
|
||||
%s to this function's own clause"
|
||||
name (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)) v
|
||||
(written_name name) (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)) v
|
||||
(pred_word p.Ast.pname) (where_text loc p.Ast.pname ("$" ^ v))
|
||||
| Some t when not (open_ty t) && not (pred_holds p.Ast.pname t) ->
|
||||
Loc.failk "check/predicate-unsatisfied" loc
|
||||
"%s is written %s, and this call passes %s, \
|
||||
which is not %s"
|
||||
name (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)) (tyname loc t)
|
||||
(written_name name) (where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)) (tyname loc t)
|
||||
(pred_word p.Ast.pname)
|
||||
| _ -> ())
|
||||
gfn.Ast.fwhere);
|
||||
@ -16750,8 +16869,8 @@ and instantiate env loc gname vars subst cparams cret =
|
||||
Loc.failk "check/predicate-unsatisfied" loc
|
||||
"this call instantiates %s at $%s = %s, and %s is not %s. %s is \
|
||||
written %s — pass a type the predicate admits"
|
||||
gname p.Ast.pvar (tyname loc t) (tyname loc t)
|
||||
(pred_word p.Ast.pname) gname
|
||||
(written_name gname) p.Ast.pvar (tyname loc t) (tyname loc t)
|
||||
(pred_word p.Ast.pname) (written_name gname)
|
||||
(where_text loc p.Ast.pname ("$" ^ p.Ast.pvar)))
|
||||
fn.Ast.fwhere;
|
||||
if Hashtbl.mem env.fns sym then
|
||||
@ -17817,6 +17936,92 @@ let check_parents env =
|
||||
constant may be defined in terms of another declared after it. A constant
|
||||
that still does not check once no progress is left has a real error, so
|
||||
the last round is run without swallowing it. *)
|
||||
(* ── One name, several arities (decision 135a) ─────────────────────────
|
||||
[fn f(g: Grain)] and [fn f(r: i32, c: i32)] are two versions of [f], and a
|
||||
call picks one by how many arguments it passes. Nothing past the checker
|
||||
knows: each version is renamed here to a name of its own, and from then on
|
||||
it is an ordinary function with an ordinary symbol, cell and stale-call
|
||||
word. The [~] is what keeps the renamed name out of a program's reach — it
|
||||
ends a symbol in both readers — as it does for [prelude~].
|
||||
|
||||
A name written once keeps its name, so its symbol does not move when a file
|
||||
gains or loses an unrelated version elsewhere; only a name with two or more
|
||||
versions is renamed, all of its versions alike, so no version is the
|
||||
plain name's by accident of order.
|
||||
|
||||
Types play no part: two versions of one arity are one function defined
|
||||
twice, whatever their parameter types. *)
|
||||
(* How many parameters a [defn] takes, paired against [env]'s types: what a
|
||||
session asks of a form it is about to merge, to tell a new version of a
|
||||
name from a redefinition of one it has. A vector that does not pair against
|
||||
[env] — it names a type the same form declares — is counted as pairing
|
||||
would count it once the type exists: a capitalised name is a type. *)
|
||||
let defn_arity env (fn : Ast.fn) =
|
||||
match fn.Ast.praw with
|
||||
| None -> List.length fn.Ast.params
|
||||
| Some items ->
|
||||
(try List.length (pair_params env items)
|
||||
with Loc.Error _ | Loc.Errors _ ->
|
||||
let rec go = function
|
||||
| [] -> 0
|
||||
| Ast.Pname _ :: Ast.Ptype _ :: rest -> 1 + go rest
|
||||
| Ast.Pname _ :: Ast.Pname (t, _) :: rest
|
||||
when t <> "" && Char.uppercase_ascii t.[0] = t.[0]
|
||||
&& Char.lowercase_ascii t.[0] <> t.[0] -> 1 + go rest
|
||||
| _ :: rest -> 1 + go rest
|
||||
in
|
||||
go items)
|
||||
|
||||
let split_versions env (decls : Ast.decl list) : Ast.decl list =
|
||||
let arities = Hashtbl.create 16 in
|
||||
List.iter
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.Defn fn ->
|
||||
let n = fn.Ast.name and k = List.length fn.Ast.params in
|
||||
let seen = Option.value ~default:[] (Hashtbl.find_opt arities n) in
|
||||
(* [main] is called by the startup code, by its own name, so it has
|
||||
one version. *)
|
||||
(match seen with
|
||||
| (_, first) :: _ when String.equal n "main" ->
|
||||
Loc.failk "check/defined-twice" d.Ast.dloc
|
||||
~notes:[ Loc.note first "main is already defined here" ]
|
||||
"main is defined twice. The program starts at main, so it has \
|
||||
one version"
|
||||
| _ -> ());
|
||||
(match List.assoc_opt k seen with
|
||||
| Some (first : Loc.t) ->
|
||||
let others = List.exists (fun (j, _) -> j <> k) seen in
|
||||
Loc.failk "check/defined-twice" d.Ast.dloc
|
||||
~notes:[ Loc.note first (n ^ " is already defined here") ]
|
||||
"%s is defined twice%s" n
|
||||
(if others then
|
||||
Printf.sprintf " with %d parameter%s. Each version of a \
|
||||
function takes a different number of \
|
||||
arguments" k (if k = 1 then "" else "s")
|
||||
else "")
|
||||
| None -> ());
|
||||
Hashtbl.replace arities n (seen @ [ (k, d.Ast.dloc) ])
|
||||
| _ -> ())
|
||||
decls;
|
||||
Hashtbl.iter
|
||||
(fun n seen ->
|
||||
if List.length seen > 1 then
|
||||
Hashtbl.replace env.versions n
|
||||
(List.sort compare
|
||||
(List.map (fun (k, _) -> (k, version_name n k)) seen)))
|
||||
arities;
|
||||
if Hashtbl.length env.versions = 0 then decls
|
||||
else
|
||||
List.map
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with
|
||||
| Ast.Defn fn when Hashtbl.mem env.versions fn.Ast.name ->
|
||||
let v = version_name fn.Ast.name (List.length fn.Ast.params) in
|
||||
{ d with Ast.d = Ast.Defn { fn with Ast.name = v } }
|
||||
| _ -> d)
|
||||
decls
|
||||
|
||||
let settle_consts env consts =
|
||||
let infer (_, v) =
|
||||
with_typed_literals (fun () -> (check (invented_ctx env Types.Unit) v).Tast.ty)
|
||||
@ -17876,21 +18081,26 @@ let collect env (decls : Ast.decl list) =
|
||||
| _ -> ())
|
||||
decls;
|
||||
let claimed = Hashtbl.create 64 in
|
||||
let is_defn (d : Ast.decl) = match d.Ast.d with Ast.Defn _ -> true | _ -> false in
|
||||
List.iter
|
||||
(fun (d : Ast.decl) ->
|
||||
match Ast.declared_name d with
|
||||
| None -> ()
|
||||
| Some n ->
|
||||
(match Hashtbl.find_opt claimed n with
|
||||
| Some first ->
|
||||
(* Two [defn]s of one name may be two versions of it, and whether
|
||||
they are is a question about their arities, which are known only
|
||||
once the parameter vectors are paired — [split_versions], below
|
||||
[pair_decls]. *)
|
||||
| Some (_, true) when is_defn d -> ()
|
||||
| Some (first, _) ->
|
||||
(* The second one is the error, because it is the one to delete;
|
||||
the first is the note, because without it the message is a
|
||||
claim the reader has to go and verify. *)
|
||||
Loc.failk "check/defined-twice" d.Ast.dloc
|
||||
~notes:[ Loc.note first (n ^ " is already defined here") ]
|
||||
"%s is defined twice" n
|
||||
| None -> ());
|
||||
Hashtbl.add claimed n d.Ast.dloc)
|
||||
| None -> Hashtbl.add claimed n (d.Ast.dloc, is_defn d)))
|
||||
decls;
|
||||
(* A defstruct whose fields introduce a variable is a template. *)
|
||||
let generic_fields (fs : Ast.field list) =
|
||||
@ -18029,6 +18239,7 @@ let collect env (decls : Ast.decl list) =
|
||||
signature may name a type declared further down and pairing must not depend
|
||||
on the order the file was written in. *)
|
||||
let decls = pair_decls env decls in
|
||||
let decls = split_versions env decls in
|
||||
(* And for the same reason, at the same point: a three-element defonce is a
|
||||
type or a value by name, and every type name is registered by here. *)
|
||||
let decls = settle_defvars env decls in
|
||||
@ -20113,6 +20324,7 @@ let print_warnings = ref true
|
||||
let internal_name n = String.starts_with ~prefix:(prelude_alias ^ "/") n
|
||||
|
||||
let shown_name n =
|
||||
let n = written_name n in
|
||||
if internal_name n then
|
||||
let p = String.length prelude_alias + 1 in
|
||||
"the prelude's " ^ String.sub n p (String.length n - p)
|
||||
|
||||
62
lib/dev.ml
62
lib/dev.ml
@ -676,6 +676,17 @@ let find_fn t name =
|
||||
String.equal f.Tast.name name && f.Tast.fparent = None)
|
||||
t.session.Session.program.Tast.fns
|
||||
|
||||
(* The versions of a name that has several, each under the name it was
|
||||
compiled as ([Check.split_versions]). *)
|
||||
let version_fns t name =
|
||||
List.filter
|
||||
(fun (f : Tast.fn) ->
|
||||
f.Tast.fparent = None
|
||||
&& (match Check.version_of f.Tast.name with
|
||||
| Some (b, _) -> String.equal b name
|
||||
| None -> false))
|
||||
t.session.Session.program.Tast.fns
|
||||
|
||||
let fn_loc t name =
|
||||
match find_fn t name with
|
||||
| Some f -> Loc.to_string f.Tast.floc
|
||||
@ -1024,7 +1035,8 @@ let stale_field (ss : Session.stale list) =
|
||||
Printf.sprintf
|
||||
"(:loc %s :caller %s :callee %s :compiled %s :current %s%s%s)"
|
||||
(Wire.quote (Loc.to_string x.Session.at))
|
||||
(Wire.quote x.Session.caller) (Wire.quote x.Session.target)
|
||||
(Wire.quote (Check.written_name x.Session.caller))
|
||||
(Wire.quote (Check.written_name x.Session.target))
|
||||
(Wire.quote x.Session.compiled)
|
||||
(Wire.quote x.Session.current)
|
||||
(if x.Session.running then " :running t" else "")
|
||||
@ -1651,8 +1663,12 @@ let describe t =
|
||||
(List.filter_map
|
||||
(fun (f : Tast.fn) ->
|
||||
if Check.internal_name f.Tast.name then None
|
||||
else Some f.Tast.name)
|
||||
t.session.Session.program.Tast.fns);
|
||||
else Some (Check.written_name f.Tast.name))
|
||||
t.session.Session.program.Tast.fns
|
||||
(* A name with several versions is listed once. *)
|
||||
|> List.fold_left
|
||||
(fun acc n -> if List.mem n acc then acc else n :: acc) []
|
||||
|> List.rev);
|
||||
":globals "
|
||||
^ Wire.strings
|
||||
(List.map (fun (g : Tast.global) -> g.Tast.gname)
|
||||
@ -1693,7 +1709,7 @@ let describe t =
|
||||
|
||||
Parameter *names* are not in the Tast, so a signature shows types only. *)
|
||||
let signature_of_fn (f : Tast.fn) =
|
||||
Printf.sprintf "%s [%s] %s" f.Tast.name
|
||||
Printf.sprintf "%s [%s] %s" (Check.written_name f.Tast.name)
|
||||
(String.concat " " (List.map Types.to_string f.Tast.params))
|
||||
(Types.to_string f.Tast.ret)
|
||||
|
||||
@ -1776,10 +1792,29 @@ let defs t =
|
||||
None
|
||||
| None when List.mem f.Tast.name class_names -> None
|
||||
| None when Check.internal_name f.Tast.name -> None
|
||||
(* A name with several versions is one row, as it is one name to
|
||||
complete and to jump to, carrying every version's signature. *)
|
||||
| None when Check.version_of f.Tast.name <> None ->
|
||||
let base = Check.written_name f.Tast.name in
|
||||
let versions =
|
||||
List.filter
|
||||
(fun (g : Tast.fn) ->
|
||||
g.Tast.fparent = None
|
||||
&& Check.version_of g.Tast.name <> None
|
||||
&& String.equal (Check.written_name g.Tast.name) base)
|
||||
p.Tast.fns
|
||||
in
|
||||
(match versions with
|
||||
| first :: _ when first == f ->
|
||||
Some
|
||||
(entry ~name:base ~kind:"fn"
|
||||
~sign:(String.concat " | " (List.map signature_of_fn versions))
|
||||
~loc:(Loc.to_string f.Tast.floc) ())
|
||||
| _ -> None)
|
||||
| None ->
|
||||
Some
|
||||
(entry ~name:f.Tast.name ~kind:"fn" ~sign:(signature_of_fn f)
|
||||
~loc:(Loc.to_string f.Tast.floc) ()))
|
||||
(entry ~name:(Check.written_name f.Tast.name) ~kind:"fn"
|
||||
~sign:(signature_of_fn f) ~loc:(Loc.to_string f.Tast.floc) ()))
|
||||
p.Tast.fns
|
||||
in
|
||||
let globals =
|
||||
@ -4445,6 +4480,21 @@ let disassemble t ~name ~form =
|
||||
":generic " ^ Wire.quote name;
|
||||
":signature " ^ Wire.quote sign;
|
||||
":copies " ^ Wire.list (List.map entry cs) ])
|
||||
(* A name with several versions answers with each, as a generic with
|
||||
several copies does. *)
|
||||
| None when version_fns t name <> [] ->
|
||||
let entry (f : Tast.fn) =
|
||||
match disassemble_fn t ~name:f.Tast.name ~form f with
|
||||
| Ok fields -> Wire.list fields
|
||||
| Error m ->
|
||||
Wire.list
|
||||
[ ":name " ^ Wire.quote f.Tast.name;
|
||||
":signature " ^ Wire.quote (signature_of_fn f);
|
||||
":refused " ^ Wire.quote m ]
|
||||
in
|
||||
ok
|
||||
[ ":name " ^ Wire.quote name; ":form " ^ Wire.quote form;
|
||||
":versions " ^ Wire.list (List.map entry (version_fns t name)) ]
|
||||
| None ->
|
||||
(match kind_of t name with
|
||||
| Some k ->
|
||||
|
||||
@ -3154,7 +3154,8 @@ and stale_check f loc flan cell ps r =
|
||||
label f bad;
|
||||
let cstr s = fst (fi_bytes f.md (s ^ "\000")) in
|
||||
ins f "call void @flan_stale_call(ptr %s, ptr %s, ptr %s, ptr %s, ptr %s)"
|
||||
(cstr (Loc.to_string loc)) (cstr flan) (cstr (sig_text ps r)) cell
|
||||
(cstr (Loc.to_string loc)) (cstr (Check.written_name flan))
|
||||
(cstr (sig_text ps r)) cell
|
||||
xfer_param;
|
||||
guard f;
|
||||
term f "unreachable";
|
||||
|
||||
@ -964,39 +964,55 @@ 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 [defn] is one version of its name, the one with its number of
|
||||
parameters (decision 135a): it replaces that version and leaves the
|
||||
others alone, and a number the name had no version for adds one. *)
|
||||
let arity_of (d : Ast.decl) =
|
||||
match d.Ast.d with
|
||||
| Ast.Defn fn -> Some (Check.defn_arity t.env fn)
|
||||
| _ -> None
|
||||
in
|
||||
(* The bodies a version is compiled under are named for it when the name
|
||||
has several; which of the two a check makes is decided there, so both
|
||||
are named and whichever the program has is the one installed. *)
|
||||
let names =
|
||||
List.filter_map Ast.declared_name incoming
|
||||
@ List.filter_map
|
||||
(fun (d : Ast.decl) ->
|
||||
match d.Ast.d with Ast.Defmethod m -> Some m.Ast.mgen | _ -> None)
|
||||
match d.Ast.d with
|
||||
| Ast.Defmethod m -> Some m.Ast.mgen
|
||||
| Ast.Defn fn ->
|
||||
Option.map (Check.version_name fn.Ast.name) (arity_of d)
|
||||
| _ -> None)
|
||||
incoming
|
||||
in
|
||||
let replacement n =
|
||||
List.find_opt
|
||||
(fun (d : Ast.decl) -> Ast.declared_name d = Some n)
|
||||
incoming
|
||||
let replaces (old_ : Ast.decl) (nd : Ast.decl) =
|
||||
match Ast.declared_name old_, Ast.declared_name nd with
|
||||
| Some a, Some b when String.equal a b ->
|
||||
(match arity_of old_, arity_of nd with
|
||||
| Some i, Some j -> i = j
|
||||
| _ -> true)
|
||||
| _ -> false
|
||||
in
|
||||
(* Replaced in place and appended only when genuinely new, so declaration
|
||||
order — which is emission order for globals — does not shuffle on every
|
||||
evaluation. *)
|
||||
let replaced = ref [] in
|
||||
evaluation. A declaration that replaces several — a defonce sent over a
|
||||
name that had two versions — takes the place of the first and the rest
|
||||
go. *)
|
||||
let used = ref [] in
|
||||
let kept =
|
||||
List.map
|
||||
List.filter_map
|
||||
(fun (d : Ast.decl) ->
|
||||
match Ast.declared_name d with
|
||||
| Some n ->
|
||||
(match replacement n with
|
||||
| Some nd -> replaced := n :: !replaced; nd
|
||||
| None -> d)
|
||||
| None -> d)
|
||||
match List.find_opt (replaces d) incoming with
|
||||
| Some nd when List.memq nd !used -> None
|
||||
| Some nd -> used := nd :: !used; Some nd
|
||||
| None -> Some d)
|
||||
t.decls
|
||||
in
|
||||
let added =
|
||||
List.filter
|
||||
(fun (d : Ast.decl) ->
|
||||
match Ast.declared_name d with
|
||||
| Some n -> not (List.exists (String.equal n) !replaced)
|
||||
| None -> false)
|
||||
Ast.declared_name d <> None && not (List.memq d !used))
|
||||
incoming
|
||||
in
|
||||
let decls = kept @ added in
|
||||
@ -1256,9 +1272,49 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
|
||||
| _ -> None)
|
||||
program.Tast.fns
|
||||
in
|
||||
(* A name that gains a second version in the loop is renamed, all of its
|
||||
versions alike ([Check.split_versions]), so the body the process has
|
||||
under the plain name is no longer the program's: the version it became
|
||||
is a new symbol and is installed, and every compiled body that called the
|
||||
plain name is compiled again, to call the version its arguments pick.
|
||||
Asked of any callee the program no longer has, which is the same fact
|
||||
seen from the call site: nothing else takes a function out of a program
|
||||
whose callers still check. *)
|
||||
let versions_moved =
|
||||
let has n =
|
||||
List.exists (fun (f : Tast.fn) -> String.equal f.Tast.name n)
|
||||
program.Tast.fns
|
||||
in
|
||||
let fresh =
|
||||
List.filter_map
|
||||
(fun (f : Tast.fn) ->
|
||||
if Check.version_of f.Tast.name <> None
|
||||
&& not (known t f.Tast.name || SM.mem f.Tast.name t.built)
|
||||
then Some f.Tast.name
|
||||
else None)
|
||||
program.Tast.fns
|
||||
in
|
||||
let callers =
|
||||
SM.fold
|
||||
(fun fname (b : built) acc ->
|
||||
if has fname
|
||||
&& List.exists (fun (st : site) -> not (has st.callee)) b.sites
|
||||
then
|
||||
match
|
||||
List.find_opt (fun (f : Tast.fn) -> String.equal f.Tast.name fname)
|
||||
program.Tast.fns
|
||||
with
|
||||
| Some { Tast.fparent = Some p; _ } when p <> "<thick>" -> p :: acc
|
||||
| _ -> fname :: acc
|
||||
else acc)
|
||||
t.built []
|
||||
in
|
||||
if fresh = [] then [] else fresh @ callers
|
||||
in
|
||||
let fns =
|
||||
List.sort_uniq String.compare
|
||||
(declared_fns @ def_inits @ from_generics @ new_instances @ prelude_moved)
|
||||
(declared_fns @ def_inits @ from_generics @ new_instances @ prelude_moved
|
||||
@ versions_moved)
|
||||
in
|
||||
(* A constant that changed and can be published: known to the host, not
|
||||
consumed by the checker. The module stores its new value at the frame
|
||||
|
||||
@ -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));
|
||||
|
||||
@ -395,6 +395,16 @@ Each item: the proposal, then the reason in one line.
|
||||
becomes `where is-ordered($t)` after the return type. **Built**; with no
|
||||
`-> R` the return is `_`, read off the body. Several predicates are
|
||||
`where p, q`.
|
||||
- A name may have several versions, one per number of parameters:
|
||||
`fn area(w: i32)` and `fn area(w: i32, h: i32)`. A call picks the version by
|
||||
how many arguments it passes; types play no part, so two versions with the
|
||||
same number of parameters are one function defined twice. A version may be
|
||||
generic, and may call the others. `main` has one version. The name alone is
|
||||
a value only where the wanted `Fn` type says how many parameters, as in
|
||||
`apply(area, 6)` against `f: Fn(i32) -> i32`; anywhere else write a lambda,
|
||||
`fn(w) => area(w, 2)`. In the dev loop a definition replaces the version with
|
||||
its number of parameters and leaves the others; another number adds a
|
||||
version. **Built** (decision 135a).
|
||||
- A `let` at the top level is a global: `let x = v`, `let x: T = v`,
|
||||
`let scratch: [4 u8] = uninit` read `(def x dyn v)`, `(def x T v)`;
|
||||
`once x: T`, `once x = v`, `const n = 3`. **Built.** `let x = v` and
|
||||
|
||||
15
test/programs/dev-versions.fln
Normal file
15
test/programs/dev-versions.fln
Normal file
@ -0,0 +1,15 @@
|
||||
;; A name with two versions in a running program: redefining one version
|
||||
;; from the editor replaces it alone, and the other keeps running.
|
||||
import agent "vendor:agent"
|
||||
|
||||
fn area(w: i32) -> i32
|
||||
w * w
|
||||
|
||||
fn area(w: i32, h: i32) -> i32
|
||||
w * h
|
||||
|
||||
fn main() -> i32
|
||||
agent/start("/tmp/flan-dev-versions-fallback.sock")
|
||||
for i in range(4000)
|
||||
agent/wait(5)
|
||||
0
|
||||
73
test/programs/versions.fln
Normal file
73
test/programs/versions.fln
Normal file
@ -0,0 +1,73 @@
|
||||
;; One name, several versions: the number of arguments picks one (decision 135a).
|
||||
|
||||
struct Grain
|
||||
kind: i32
|
||||
|
||||
fn is-empty-cell(g: Grain) -> bool
|
||||
g.kind == 0
|
||||
|
||||
;; One version calling another.
|
||||
fn is-empty-cell(r: i32, c: i32) -> bool
|
||||
is-empty-cell(Grain{.kind r * c})
|
||||
|
||||
fn area(w: i32) -> i32
|
||||
w * w
|
||||
|
||||
fn area(w: i32, h: i32) -> i32
|
||||
w * h
|
||||
|
||||
fn area(w: i32, h: i32, d: i32) -> i32
|
||||
area(w, h) * d
|
||||
|
||||
;; A generic version beside a plain one.
|
||||
fn pick(x: $t) -> $t
|
||||
x
|
||||
|
||||
fn pick(x: $t, y: $t, first: bool) -> $t
|
||||
if first then x else y
|
||||
|
||||
;; A version that recurses on itself and calls the other.
|
||||
fn count(n: i32) -> i32
|
||||
count(n, 0)
|
||||
|
||||
fn count(n: i32, acc: i32) -> i32
|
||||
if n == 0 then acc else count(n - 1, acc + n)
|
||||
|
||||
;; defer runs per version.
|
||||
fn noisy(a: i32) -> i32
|
||||
defer println("leaving noisy/1")
|
||||
a
|
||||
|
||||
fn noisy(a: i32, b: i32) -> i32
|
||||
defer println("leaving noisy/2")
|
||||
a + b
|
||||
|
||||
;; Untyped versions take dyn arguments, and the count still picks.
|
||||
fn scale(x)
|
||||
x * 10
|
||||
|
||||
fn scale(x, y)
|
||||
x * y
|
||||
|
||||
fn apply(f: Fn(i32) -> i32, x: i32) -> i32
|
||||
f(x)
|
||||
|
||||
fn main()
|
||||
println(is-empty-cell(Grain{.kind 0}))
|
||||
println(is-empty-cell(Grain{.kind 2}))
|
||||
println(is-empty-cell(3, 0))
|
||||
println(is-empty-cell(3, 4))
|
||||
println(area(3))
|
||||
println(area(3, 4))
|
||||
println(area(3, 4, 5))
|
||||
println(pick(7))
|
||||
println(pick(1.5, 2.5, false))
|
||||
println(pick("a", "b", true))
|
||||
println(count(10))
|
||||
println(noisy(1))
|
||||
println(noisy(1, 2))
|
||||
println(scale(4))
|
||||
println(scale(2.5, 2))
|
||||
;; A wanted Fn type names the arity, so the name picks that version.
|
||||
println(apply(area, 6))
|
||||
println(apply(fn(x) => area(x, 2), 6))
|
||||
@ -2248,6 +2248,14 @@ let () =
|
||||
let if_let_kept_out =
|
||||
"1\n4\nnone\n6\nnone\n9\n2\nnone\n3\nnone\n5\nnil\n7\n"
|
||||
in
|
||||
(* One name, several versions, picked by the number of arguments. *)
|
||||
let versions_out =
|
||||
"true\nfalse\ntrue\nfalse\n9\n12\n60\n7\n2.5\na\n55\n\
|
||||
leaving noisy/1\n1\nleaving noisy/2\n3\n40\n5\n36\n12\n"
|
||||
in
|
||||
outputs "versions by arity" "programs/versions.fln" versions_out;
|
||||
outputs ~opt:"-O0" "versions by arity, -O0" "programs/versions.fln" versions_out;
|
||||
outputs ~x86:true "versions by arity, --x86" "programs/versions.fln" versions_out;
|
||||
outputs "a kept if let chain" "programs/if-let-kept.fln" if_let_kept_out;
|
||||
outputs ~opt:"-O0" "a kept if let chain, -O0" "programs/if-let-kept.fln" if_let_kept_out;
|
||||
outputs ~x86:true "a kept if let chain, --x86" "programs/if-let-kept.fln" if_let_kept_out;
|
||||
|
||||
@ -5551,7 +5551,7 @@ let () =
|
||||
if not (await ~ms:10000 (fun () -> not (alive ()))) then
|
||||
fail "--two-process: the new child did not finish"
|
||||
else begin
|
||||
let r = ev "(defn helper [x i64] i64 x)" in
|
||||
let r = ev "(defn helper [] f64 1.25)" in
|
||||
if status r <> "ok" then
|
||||
fail "--two-process: a change while the child has ended: %s"
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
@ -5568,7 +5568,7 @@ let () =
|
||||
(fun code ->
|
||||
if status (ev code) <> "ok" then
|
||||
fail "--two-process: %s was refused" code)
|
||||
[ "(defn user [] i64 (helper 5))"; "(defn step [] i64 (user))" ];
|
||||
[ "(defn user [] i64 (i64 (* (helper) 4.0)))"; "(defn step [] i64 (user))" ];
|
||||
Buffer.clear seen;
|
||||
let r = ask "(:op \"rerun\")" in
|
||||
if status r <> "ok" then
|
||||
@ -7540,6 +7540,74 @@ let () =
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ fsock; fout ])
|
||||
[ "x86"; "llvm" ];
|
||||
|
||||
(* ── One name, two versions (decision 135a) ──────────────────────────
|
||||
Redefining one version of a running program's function from a .fln
|
||||
buffer replaces that version alone: the other still answers, and the
|
||||
listing shows the name once with both signatures. *)
|
||||
List.iter
|
||||
(fun backend ->
|
||||
let vsock = tmp ("versions" ^ backend ^ ".sock")
|
||||
and vout = tmp ("versions" ^ backend ^ ".out") in
|
||||
(try Sys.remove vsock with Sys_error _ -> ());
|
||||
let vfd =
|
||||
Unix.openfile vout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
|
||||
in
|
||||
let vpid =
|
||||
Unix.create_process flan
|
||||
[| flan; "dev"; "programs/dev-versions.fln"; "-s"; vsock;
|
||||
"--" ^ backend |]
|
||||
Unix.stdin vfd Unix.stderr
|
||||
in
|
||||
Unix.close vfd;
|
||||
if not (listening ~pid:vpid vsock) then begin
|
||||
fail "the versions daemon (--%s) %s" backend !listen_why;
|
||||
(try Unix.kill vpid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
end
|
||||
else begin
|
||||
let c = connect vsock in
|
||||
let file = "programs/dev-versions.fln" in
|
||||
let ask code =
|
||||
request c
|
||||
(Printf.sprintf "(:op \"eval-expr\" :code %s :file %s)"
|
||||
(Wire.quote code) (Wire.quote file))
|
||||
in
|
||||
let answer r =
|
||||
match Wire.string_field r "value" with
|
||||
| Some v -> v
|
||||
| None -> Option.value ~default:(status r) (Wire.string_field r "message")
|
||||
in
|
||||
let is what code want =
|
||||
let a = answer (ask code) in
|
||||
if a <> want then fail "--%s: %s answered %S, not %S" backend what a want
|
||||
in
|
||||
if not (await ~ms:20000 (fun () -> status (ask "1") = "ok")) then
|
||||
fail "--%s: the versions program never took an expression" backend
|
||||
else begin
|
||||
is "the one-argument version" "area(3)" "9";
|
||||
is "the two-argument version" "area(3, 4)" "12";
|
||||
let r =
|
||||
request c
|
||||
(Printf.sprintf "(:op \"eval\" :code %s :file %s)"
|
||||
(Wire.quote "fn area(w: i32, h: i32) -> i32\n w * h + 100")
|
||||
(Wire.quote file))
|
||||
in
|
||||
if status r <> "ok" then
|
||||
fail "--%s: redefining one version: %s" backend
|
||||
(Option.value ~default:(status r) (Wire.string_field r "message"));
|
||||
is "the redefined version" "area(3, 4)" "112";
|
||||
is "the version left alone" "area(3)" "9";
|
||||
let defs = request c "(:op \"defs\")" in
|
||||
let text = Form.to_string defs in
|
||||
if not (contains_sub text "area [i32] i32 | area [i32 i32] i32") then
|
||||
fail "--%s: defs did not list both versions of area: %s" backend text
|
||||
end;
|
||||
(try Unix.close c with Unix.Unix_error _ -> ());
|
||||
(try Unix.kill vpid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
(try ignore (Unix.waitpid [] vpid) with Unix.Unix_error _ -> ())
|
||||
end;
|
||||
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ vsock; vout ])
|
||||
[ "x86"; "llvm" ];
|
||||
|
||||
(* ── The dyn globals a park holds ─────────────────────────────────── *)
|
||||
|
||||
(* The banner a finished run prints says the globals are as it left them,
|
||||
@ -8383,7 +8451,7 @@ let () =
|
||||
| v ->
|
||||
fail "--%s: a capturing fn at the prompt answered %s" backend
|
||||
(Option.value ~default:"nothing" v));
|
||||
let r = eval "(defn scale [x i64 k i64] i64 (* x k))" in
|
||||
let r = eval "(defn scale [x f64] i64 (i64 (* x 3.0)))" in
|
||||
if status r <> "ok" then
|
||||
fail "--%s: a signature change was refused: %s" backend (said r)
|
||||
else begin
|
||||
@ -8415,7 +8483,7 @@ let () =
|
||||
if not (contains_sub fields want) then
|
||||
fail "--%s: StaleCall's fields do not show %S: %s"
|
||||
backend want fields)
|
||||
[ "scale"; "[i64] i64"; "[i64 i64] i64" ];
|
||||
[ "scale"; "[i64] i64"; "[f64] i64" ];
|
||||
(match Wire.string_field (request c "(:op \"break\")") "site" with
|
||||
| Some site when contains_sub site "dev-stale.flan:23:" -> ()
|
||||
| Some site -> fail "--%s: the stale call's site is %s" backend site
|
||||
@ -8424,7 +8492,7 @@ let () =
|
||||
let r =
|
||||
eval
|
||||
"(defn step [] i64 (set ticks (+ ticks 1)) \
|
||||
(set seen (scale ticks 3)) seen)"
|
||||
(set seen (scale (f64 ticks))) seen)"
|
||||
in
|
||||
if status r <> "ok" then
|
||||
fail "--%s: recompiling the stale caller: %s" backend (said r)
|
||||
|
||||
@ -1507,6 +1507,38 @@ let () =
|
||||
refuses_all ~fln:true "~~ in .fln" "fn f(a: bool) -> i32\n ~~a\n" "~~ works on the bits";
|
||||
refuses_all ~fln:true "^^ in .fln" "fn f(a: bool, b: bool) -> bool\n a ^^ b == 0\n"
|
||||
"write a != b";
|
||||
(* ── One name, several versions (decision 135a) ─────────────────── *)
|
||||
let two = "fn f(a: i32) -> i32\n a\n\nfn f(a: i32, b: i32) -> i32\n a + b\n\n" in
|
||||
refuses_all ~fln:true "two versions of one arity are defined twice"
|
||||
(two ^ "fn f(x: i64, y: i64) -> i64\n x\n")
|
||||
"f is defined twice with 2 parameters";
|
||||
refuses_all ~fln:true "one arity written twice is defined twice"
|
||||
"fn g(a: i32) -> i32\n a\n\nfn g(b: bool) -> i32\n 0\n"
|
||||
"g is defined twice";
|
||||
refuses_all ~fln:true "main has one version"
|
||||
"fn main()\n 0\n\nfn main(x: i32)\n 0\n" "main is defined twice";
|
||||
refuses_all ~fln:true "a call no version takes lists the versions"
|
||||
(two ^ "fn h() -> i32\n f(1, 2, 3)\n")
|
||||
"f has no version that takes 3 arguments. It has these:\n f(a: i32)\n \
|
||||
f(a: i32, b: i32)";
|
||||
refuses_all "and in parens, in the file's own spelling"
|
||||
"(defn f [a i32] i32 a) (defn f [a i32 b i32] i32 (+ a b)) \
|
||||
(defn h [] i32 (f))"
|
||||
"It has these:\n (f [a i32])\n (f [a i32 b i32])";
|
||||
refuses_all ~fln:true "the name alone is not a value"
|
||||
(two ^ "fn h() -> i32\n let g = f\n 0\n")
|
||||
"f has several versions, one per number of arguments, so the name alone \
|
||||
does not say which function this is. Wrap it in a function that calls \
|
||||
the one you mean, as in fn(a) => f(a)";
|
||||
refuses_all ~fln:true "a wanted Fn type of another arity picks nothing"
|
||||
(two ^ "fn h() -> i32\n let g: Fn(i32, i32, i32) -> i32 = f\n 0\n")
|
||||
"f has several versions";
|
||||
refuses_all ~fln:true "an argument's refusal names the function as written"
|
||||
(two ^ "fn h() -> i32\n f(true)\n")
|
||||
"this is the 1st argument of f";
|
||||
refuses_all ~fln:true "fn takes no rest parameter to overlap a version"
|
||||
"fn f(a: i32) -> i32\n a\n\nfn f(a: i32, & xs) -> i32\n a\n"
|
||||
"& (a rest parameter) is not one";
|
||||
rejects_check "popcount of a float"
|
||||
"(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64";
|
||||
rejects_check "a rotation's count does not widen the value"
|
||||
@ -6174,6 +6206,12 @@ let () =
|
||||
"(defstruct S [a i32])\n(defn f [s S] i32 (.b s))" "check/unknown-field";
|
||||
kind_is "a name defined twice has a kind"
|
||||
"(defn f [] i32 1)\n(defn f [] i32 2)" "check/defined-twice";
|
||||
kind_is "a call no version takes has a kind"
|
||||
"(defn f [] i32 1)\n(defn f [a i32] i32 a)\n(defn g [] i32 (f 1 2))"
|
||||
"check/no-version";
|
||||
kind_is "a name with versions as a value has a kind"
|
||||
"(defn f [] i32 1)\n(defn f [a i32] i32 a)\n(defn g [] i32 (let [h f] 0))"
|
||||
"check/several-versions";
|
||||
|
||||
(* The note is the half a location and a string could never carry: the
|
||||
*other* place, with its own span and its own explanation. *)
|
||||
|
||||
@ -54,14 +54,15 @@ let () =
|
||||
each of these installs and names no stale caller. Dyn-ness is part of a
|
||||
signature like anything else; the last two are the changes the source
|
||||
does not spell out as a type. *)
|
||||
let installs name src =
|
||||
let installs ?(fn = "outer") ?(stale = []) name src =
|
||||
let t, _ = Session.create ~file:"programs/reload.flan" () in
|
||||
match Session.eval t src with
|
||||
| c ->
|
||||
if not (List.mem "outer" c.Session.fns) then
|
||||
if not (List.mem fn c.Session.fns) then
|
||||
fail "%s installed %s" name (String.concat " " c.Session.fns);
|
||||
if c.Session.stale <> [] then
|
||||
fail "%s left a caller behind that nothing has" name
|
||||
if List.map (fun (x : Session.stale) -> x.Session.caller) c.Session.stale
|
||||
<> stale
|
||||
then fail "%s left the wrong callers behind" name
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "%s was refused: %s" name m
|
||||
in
|
||||
(* A session's defn named as a prelude macro shadows it for a later form
|
||||
@ -77,11 +78,51 @@ let () =
|
||||
(String.concat " " c.Session.fns)
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "a call to a session's clamp was expanded as the macro: %s" m);
|
||||
installs "a changed parameter type" "(defn outer [x i64] i64 (bump))";
|
||||
(* A changed parameter keeps the number of them: another number is another
|
||||
version of the name (decision 135a), below. [helper] is called from
|
||||
[bump], which is left compiled against the old signature. *)
|
||||
installs ~fn:"helper" ~stale:[ "bump" ] "a changed parameter type"
|
||||
"(defn helper [x f64] i64 (i64 x))";
|
||||
installs "a changed return type" "(defn outer [] i32 (i32 (bump)))";
|
||||
installs "a changed arity" "(defn outer [a i64 b i64] i64 (bump))";
|
||||
installs "a return type that became dyn" "(defn outer [] dyn (bump))";
|
||||
installs "a parameter that became dyn" "(defn outer [x] i64 (bump))";
|
||||
installs ~fn:"helper" ~stale:[ "bump" ] "a parameter that became dyn"
|
||||
"(defn helper [x] i64 7)";
|
||||
|
||||
(* Another number of parameters is another version of the name. Both
|
||||
versions are renamed for their arities, so the one the process had under
|
||||
the plain name is installed again under its new one; redefining one
|
||||
version then replaces it alone and leaves the other in the program. *)
|
||||
(let t, _ = Session.create ~file:"programs/reload.flan" () in
|
||||
match Session.eval t "(defn outer [a i64 b i64] i64 (+ a b (bump)))" with
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "a second version was refused: %s" m
|
||||
| c ->
|
||||
if List.sort compare c.Session.fns <> [ "outer~0"; "outer~2" ] then
|
||||
fail "a second version installed %s" (String.concat " " c.Session.fns);
|
||||
if c.Session.stale <> [] then fail "a second version left a caller behind";
|
||||
(match Session.eval t "(defn outer [a i64 b i64] i64 (* a b))" with
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "redefining one version was refused: %s" m
|
||||
| c ->
|
||||
if c.Session.fns <> [ "outer~2" ] then
|
||||
fail "redefining one version installed %s"
|
||||
(String.concat " " c.Session.fns);
|
||||
let names =
|
||||
List.map (fun (f : Tast.fn) -> f.Tast.name) t.Session.program.Tast.fns
|
||||
in
|
||||
if not (List.mem "outer~0" names && List.mem "outer~2" names) then
|
||||
fail "redefining one version lost the other"));
|
||||
(* A compiled caller of the plain name is compiled again, to call the
|
||||
version its arguments pick: [bump] calls [helper] with one argument. *)
|
||||
(let t, _ = Session.create ~file:"programs/reload.flan" () in
|
||||
match Session.eval t "(defn helper [x i64 y i64] i64 (+ x y))" with
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "a second version of a called function was refused: %s" m
|
||||
| c ->
|
||||
if List.sort compare c.Session.fns <> [ "bump"; "helper~1"; "helper~2" ] then
|
||||
fail "a second version of a called function installed %s"
|
||||
(String.concat " " c.Session.fns);
|
||||
if c.Session.stale <> [] then
|
||||
fail "a second version of a called function left a caller behind");
|
||||
(* [main] is the exception: the startup code calls it, and that call was
|
||||
compiled into the program when it started. *)
|
||||
refuses ~file:"programs/dev-stale.flan" "a changed main"
|
||||
@ -93,7 +134,7 @@ let () =
|
||||
with both signatures. [step]'s source no longer checks against the new
|
||||
arity, and that is not a reason to refuse: it is not being recompiled. *)
|
||||
(let t, _ = Session.create ~file:"programs/dev-stale.flan" () in
|
||||
match Session.eval t "(defn scale [x i64 k i64] i64 (* x k))" with
|
||||
match Session.eval t "(defn scale [x f64] i64 (i64 (* x 2.0)))" with
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "a signature change with compiled callers was refused: %s" m
|
||||
| c ->
|
||||
@ -107,12 +148,12 @@ let () =
|
||||
c.Session.stale
|
||||
in
|
||||
let want =
|
||||
[ ("step", "scale", "[i64] i64", "[i64 i64] i64", 23);
|
||||
("pick", "scale", "[i64] i64", "[i64 i64] i64", 26);
|
||||
[ ("step", "scale", "[i64] i64", "[f64] i64", 23);
|
||||
("pick", "scale", "[i64] i64", "[f64] i64", 26);
|
||||
(* The clause's call is named for the function it is written in,
|
||||
not for the lifted function it became. *)
|
||||
("guarded", "scale", "[i64] i64", "[i64 i64] i64", 45);
|
||||
("guarded", "scale", "[i64] i64", "[i64 i64] i64", 46) ]
|
||||
("guarded", "scale", "[i64] i64", "[f64] i64", 45);
|
||||
("guarded", "scale", "[i64] i64", "[f64] i64", 46) ]
|
||||
in
|
||||
if named <> want then
|
||||
fail "the stale callers were %s"
|
||||
@ -123,7 +164,7 @@ let () =
|
||||
(* Recompiling a stale caller clears it, and only it. *)
|
||||
(match
|
||||
Session.eval t
|
||||
"(defn step [] i64 (set ticks (+ ticks 1)) (set seen (scale ticks 3)) seen)"
|
||||
"(defn step [] i64 (set ticks (+ ticks 1)) (set seen (scale (f64 ticks))) seen)"
|
||||
with
|
||||
| c ->
|
||||
(match c.Session.stale with
|
||||
@ -175,9 +216,9 @@ let () =
|
||||
in
|
||||
let main_src =
|
||||
"(defn main [] i32 (agent/start \"/tmp/x.sock\") \
|
||||
(dotimes [i 6000] (agent/wait 5) (restart-case (step 1) (skip-frame [] 0))) 0)"
|
||||
(dotimes [i 6000] (agent/wait 5) (restart-case (step) (skip-frame [] 0))) 0)"
|
||||
in
|
||||
(match Session.eval t "(defn step [x i64] i64 (set seen (scale x)) seen)" with
|
||||
(match Session.eval t "(defn step [] i32 (set seen (scale ticks)) (i32 seen))" with
|
||||
| c ->
|
||||
if mains c <> [ true ] then fail "a stale call in main was not flagged as running"
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "changing step: %s" m);
|
||||
@ -192,10 +233,10 @@ let () =
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "after a re-run: %s" m));
|
||||
(let t, _ = Session.create ~file:"programs/dev-stale.flan" () in
|
||||
ignore
|
||||
(Session.eval ~running:false t "(defn step [x i64] i64 (set seen (scale x)) seen)");
|
||||
(Session.eval ~running:false t "(defn step [] i32 (set seen (scale ticks)) (i32 seen))");
|
||||
match
|
||||
Session.eval ~running:false t
|
||||
"(defn main [] i32 (dotimes [i 3] (restart-case (step 1) (skip-frame [] 0))) 0)"
|
||||
"(defn main [] i32 (dotimes [i 3] (restart-case (step) (skip-frame [] 0))) 0)"
|
||||
with
|
||||
| c ->
|
||||
if List.exists (fun (x : Session.stale) -> x.Session.caller = "main")
|
||||
@ -225,7 +266,7 @@ let () =
|
||||
tolerance is for a body compiled against a signature that changed, and
|
||||
[twice] here is new, in the form, and wrong. *)
|
||||
refuses ~file:"programs/dev-stale.flan" "a form that is wrong on its own"
|
||||
"(defn scale [x i64 k i64] i64 (* x k)) (defn twice [] i64 (scale 1))"
|
||||
"(defn scale [x f64] i64 (i64 x)) (defn twice [] i64 (scale ticks))"
|
||||
"scale";
|
||||
|
||||
(* The storage exists and has a shape: reusing it reads at the wrong offsets,
|
||||
@ -923,7 +964,7 @@ let () =
|
||||
(let tp, _ = Session.create ~file:"programs/pkg-private.flan" () in
|
||||
match
|
||||
Session.eval ~origin:"programs/pkgs/secret/secret.flan" tp
|
||||
"(defn- combine [a i32 b i32 c i32] i32 (mix a (+ b c)))"
|
||||
"(defn- combine [a i32 b i64] i32 (mix a (i32 b)))"
|
||||
with
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "a package function's signature change was refused: %s" m
|
||||
@ -941,7 +982,7 @@ let () =
|
||||
(List.map (fun (n, f, l) -> Printf.sprintf "%s %s:%d" n f l) where));
|
||||
(match
|
||||
Session.eval ~origin:"programs/pkg-private.flan" tp
|
||||
"(defn main [] i32 (print (secret/combine 1 2 3)) 0)"
|
||||
"(defn main [] i32 (print (secret/combine 1 2)) 0)"
|
||||
with
|
||||
| _ -> fail "a stale caller recompiled past a defn- was accepted"
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
@ -950,7 +991,7 @@ let () =
|
||||
(let tp, _ = Session.create ~file:"programs/pkg-private.flan" () in
|
||||
match
|
||||
Session.eval ~origin:"programs/pkgs/secret/secret.flan" tp
|
||||
"(defn- mix [a i32 b i32 c i32] i32 (+ (* a 10) (+ b c)))"
|
||||
"(defn- mix [a i32 b i64] i32 (+ (* a 10) (i32 b)))"
|
||||
with
|
||||
| exception Loc.Error { Loc.dmsg = m; _ } ->
|
||||
fail "a private package function's signature change was refused: %s" m
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user