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

The shadowed builtin, and's misdirected caret, and the expansion count

Browse Source 
Ranks 7, 10 and 19.

A defn whose name is a builtin's is silently unreachable — the dispatch
reaches every builtin arm before it looks in the function table — and the
arity refusal that followed measured the call against the builtin while
pointing at a call the reader had written for their own. The count stays the
builtin's, because the builtin is what runs; the message says so and notes
the definition that is not being reached. The shadowing itself is not
refused: that is a language decision and not a fix pass's to make.

FIX.org recorded and's misdirected caret with three rejected fixes and one
accepted — check_if preferring the arm that is not a compiler temp — and said
it was a check.ml change nobody owned. and's last operand is its then arm and
the sentinel carrying the previous operand's location is its else arm, so the
mismatch landed one operand early. Only and needs it: in an or the chain is
already in the else arm, and with an expectation in hand neither arm is
checked against the other.

'expanding this declaration produced 2 of them' had no antecedent once read
cold. The head of the expanded form is the macro's name and says what
expanded, and the expression form names (do ...).
This commit is contained in:
Joseph Ferano 2026-09-20 18:11:16 +07:00
parent ea84394dd0
commit 859e3aa7f4
3 changed files with 166 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

169
lib/check.ml
View File

@ -96,6 +96,10 @@ type env = {
missing entry degrades to the message alone rather than to a wrong missing entry degrades to the message alone rather than to a wrong
pointer — [declared_note]'s rule. *) pointer — [declared_note]'s rule. *)
fparams : (string, Ast.field list) Hashtbl.t; fparams : (string, Ast.field list) Hashtbl.t;
(* And where the defn was written, for the same reason: a refusal about a
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;
globals : (string, Types.t * bool) Hashtbl.t; (* type, is a constant *) globals : (string, Types.t * bool) Hashtbl.t; (* type, is a constant *)
(* Where each global was declared, so a refusal about one can show it. A (* Where each global was declared, so a refusal about one can show it. A
second table rather than a third field, because every other reader of second table rather than a third field, because every other reader of
@ -167,6 +171,7 @@ let new_env () = {
extern_locs = Hashtbl.create 32; extern_locs = Hashtbl.create 32;
fns = Hashtbl.create 32; fns = Hashtbl.create 32;
fparams = Hashtbl.create 32; fparams = Hashtbl.create 32;
fn_locs = Hashtbl.create 32;
globals = Hashtbl.create 16; globals = Hashtbl.create 16;
global_locs = Hashtbl.create 16; global_locs = Hashtbl.create 16;
lifted = []; lifted = [];
@ -3955,7 +3960,37 @@ and check_if ctx ?(tail = false) ?want loc c t e =
| Some _ -> want | Some _ -> want
| None -> if t.Tast.ty = Types.Never then None else Some t.Tast.ty | None -> if t.Tast.ty = Types.Never then None else Some t.Tast.ty
in in
let e = branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) in (* [(and a b c)] is [(let [t a] (if t (let [u b] (if u c u)) t))], so the
*last* operand of an [and] is the then arm and the sentinel that carries
the previous operand's location is the else arm. With no expectation
the then arm supplies one, the sentinel is checked against it, and the
mismatch was reported at the sentinel — which is a caret on the operand
before the one that is wrong. FIX.org records three fixes for this that
were rejected and one that was not: prefer the arm that is not a
compiler temp when deciding which to blame. That is this.
Only [and] needs it. In an [or] the chain sits in the else arm and the
sentinel in the then arm, so every operand is already blamed at its own
location; and with an expectation in hand both arms are checked against
it rather than against each other, so nothing here runs. *)
let and_sentinel (x : Ast.expr) =
match x.Ast.e with
| Ast.Var n ->
String.length n > 4 && String.sub n 0 4 = "and~"
| _ -> false
in
let e =
match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with
| v -> v
| exception Loc.Error d
when want = None && and_sentinel e
&& String.equal d.Loc.kind "check/type-mismatch" ->
Loc.failk "check/shortcircuit-operand" t.Tast.loc
"an and answers false when it stops early and its last operand \
otherwise, so the two have to be one type — this operand is %s, \
and false is a bool"
(Types.to_string t.Tast.ty)
in
let ty = let ty =
if t.Tast.ty = Types.Never then e.Tast.ty if t.Tast.ty = Types.Never then e.Tast.ty
else if e.Tast.ty = Types.Never then t.Tast.ty else if e.Tast.ty = Types.Never then t.Tast.ty
@ -4664,10 +4699,35 @@ and call_value ctx ~want loc (callee : Tast.expr) args =
fail loc "this is a %s and not a function, so it cannot be called" fail loc "this is a %s and not a function, so it cannot be called"
(Types.to_string other) (Types.to_string other)
and arity loc name n args = (* A builtin's arity, and the one thing the caret cannot show: whether the
if List.length args <> n then count being measured against is the builtin's or a defn of the same name.
fail loc "%s takes %d argument%s, given %d" name n A defn does not shadow a builtin — the dispatch above reaches every builtin
(if n = 1 then "" else "s") (List.length args) arm before it ever looks in [fns] — so a user function called [get] is
silently unreachable, and the refusal that followed measured the call
against the builtin while pointing at a call the reader had written for
their own. Said outright, with the definition alongside. *)
and arity ctx loc name n args =
if List.length args <> n then begin
let notes =
if Hashtbl.mem ctx.env.fns name then
match Hashtbl.find_opt ctx.env.fn_locs name with
| Some at ->
[ Loc.note at
(name ^ " is also defined here, and this call is not reaching \
it — rename it to call it") ]
| None -> []
else []
in
let shadowed = notes <> [] in
if shadowed then
Loc.failk "check/builtin-arity" loc ~notes
"%s takes %d argument%s, given %d — this is the builtin %s, which a \
defn of the same name does not replace"
name n (if n = 1 then "" else "s") (List.length args) name
else
fail loc "%s takes %d argument%s, given %d" name n
(if n = 1 then "" else "s") (List.length args)
end
(* The operators that fold: [+ - * /], [min]/[max] and the three bitwise (* The operators that fold: [+ - * /], [min]/[max] and the three bitwise
combining operators all take two operands or more, and mean the same thing combining operators all take two operands or more, and mean the same thing
@ -5068,7 +5128,7 @@ and named_call ctx ~want loc name args =
(* Remainder stays at two: (% a b c) is (% (% a b) c), which is a thing (* Remainder stays at two: (% a b c) is (% (% a b) c), which is a thing
nobody writes on purpose. *) nobody writes on purpose. *)
| "%" -> | "%" ->
arity loc name 2 args; arity ctx loc name 2 args;
let a, b = binary ctx ~dyn_ok:true name loc ~want:(numeric_want want) args in let a, b = binary ctx ~dyn_ok:true name loc ~want:(numeric_want want) args in
if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then
dyn_fold ctx ~want loc name [ a; b ] [] dyn_fold ctx ~want loc name [ a; b ] []
@ -5083,7 +5143,7 @@ and named_call ctx ~want loc name args =
| "=" -> Tast.Eq | "!=" -> Tast.Ne | "<" -> Tast.Lt | "=" -> Tast.Eq | "!=" -> Tast.Ne | "<" -> Tast.Lt
| "<=" -> Tast.Le | ">" -> Tast.Gt | _ -> Tast.Ge | "<=" -> Tast.Le | ">" -> Tast.Gt | _ -> Tast.Ge
in in
arity loc name 2 args; arity ctx loc name 2 args;
let a, b = binary ctx ~dyn_ok:true name loc ~want:None args in let a, b = binary ctx ~dyn_ok:true name loc ~want:None args in
(* A comparison with a dyn operand answers a *bool*, not a dyn, even though (* A comparison with a dyn operand answers a *bool*, not a dyn, even though
the runtime's own entry point answers a dyn holding one. The reason is the runtime's own entry point answers a dyn holding one. The reason is
@ -5151,7 +5211,7 @@ and named_call ctx ~want loc name args =
prim p Types.Bool [ a; b ] prim p Types.Bool [ a; b ]
end end
| "not" -> | "not" ->
arity loc name 1 args; arity ctx loc name 1 args;
(* Same truthiness as [if]: a dyn argument is negated on nil/false vs. (* Same truthiness as [if]: a dyn argument is negated on nil/false vs.
everything else, not narrowed to a strict bool first. *) everything else, not narrowed to a strict bool first. *)
prim Tast.Not Types.Bool [ check_truthy ctx (List.hd args) ] prim Tast.Not Types.Bool [ check_truthy ctx (List.hd args) ]
@ -5170,7 +5230,7 @@ and named_call ctx ~want loc name args =
would pass two legal shifts and still shift the value away entirely. *) would pass two legal shifts and still shift the value away entirely. *)
| "<<" | ">>" -> | "<<" | ">>" ->
let p = if String.equal name "<<" then Tast.Shl else Tast.Shr in let p = if String.equal name "<<" then Tast.Shl else Tast.Shr in
arity loc name 2 args; arity ctx loc name 2 args;
let a, b = binary ctx name loc ~want:(numeric_want want) args in let a, b = binary ctx name loc ~want:(numeric_want want) args in
(match a.Tast.ty with (match a.Tast.ty with
| Types.Int _ -> () | Types.Int _ -> ()
@ -5225,7 +5285,7 @@ and named_call ctx ~want loc name args =
(* (zeroed) is the all-bytes-zero value of whatever it is being stored into, (* (zeroed) is the all-bytes-zero value of whatever it is being stored into,
so it only means anything where a type is expected of it. *) so it only means anything where a type is expected of it. *)
| "zeroed" -> | "zeroed" ->
arity loc name 0 args; arity ctx loc name 0 args;
(match want with (match want with
| Some ty when ty <> Types.Never -> | Some ty when ty <> Types.Never ->
no_zeroed_fn loc "this" ty; no_zeroed_fn loc "this" ty;
@ -5313,7 +5373,7 @@ and named_call ctx ~want loc name args =
(arena-new ...) with a backing buffer, which is the parameterised \ (arena-new ...) with a backing buffer, which is the parameterised \
allocator that does exist" allocator that does exist"
| "heap-allocator" -> | "heap-allocator" ->
arity loc name 0 args; arity ctx loc name 0 args;
expect ctx loc ~want expect ctx loc ~want
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_heap_allocator", []))) (mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_heap_allocator", [])))
(* The capacity is explicit and there is no growing backing store: an arena (* The capacity is explicit and there is no growing backing store: an arena
@ -5321,14 +5381,14 @@ and named_call ctx ~want loc name args =
and it is the only shape under which "exhausted" is a state a test can and it is the only shape under which "exhausted" is a state a test can
reach on purpose. *) reach on purpose. *)
| "arena-new" -> | "arena-new" ->
arity loc name 1 args; arity ctx loc name 1 args;
let cap = check ctx ~want:(Types.Int Types.I64) (List.hd args) in let cap = check ctx ~want:(Types.Int Types.I64) (List.hd args) in
expect ctx loc ~want expect ctx loc ~want
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_arena_new", [ cap ]))) (mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_arena_new", [ cap ])))
(* Hands the pages back, which [free-all] deliberately does not — see (* Hands the pages back, which [free-all] deliberately does not — see
docs/BUILT.md, "free-all is retain-capacity". *) docs/BUILT.md, "free-all is retain-capacity". *)
| "arena-destroy" -> | "arena-destroy" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want expect ctx loc ~want
(mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_arena_destroy", [ a ]))) (mk loc Types.Unit (Tast.Prim (Tast.Rt "flan_arena_destroy", [ a ])))
@ -5336,7 +5396,7 @@ and named_call ctx ~want loc name args =
as a string so that an allocator with no region to release names the site as a string so that an allocator with no region to release names the site
rather than the runtime. *) rather than the runtime. *)
| "free-all" -> | "free-all" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want expect ctx loc ~want
(mk loc Types.Unit (mk loc Types.Unit
@ -5345,7 +5405,7 @@ and named_call ctx ~want loc name args =
(Query_Features returning an Allocator_Mode_Set); a field is the same (Query_Features returning an Allocator_Mode_Set); a field is the same
answer without the round trip, which is NEXT.md's call. *) answer without the round trip, which is NEXT.md's call. *)
| "can-free?" -> | "can-free?" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want expect ctx loc ~want
(mk loc Types.Bool (mk loc Types.Bool
@ -5354,7 +5414,7 @@ and named_call ctx ~want loc name args =
(Tast.Prim (Tast.Rt "flan_alloc_can_free", [ a ])); (Tast.Prim (Tast.Rt "flan_alloc_can_free", [ a ]));
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ]))) mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])))
| "can-free-all?" -> | "can-free-all?" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want expect ctx loc ~want
(mk loc Types.Bool (mk loc Types.Bool
@ -5366,7 +5426,7 @@ and named_call ctx ~want loc name args =
moved; this is the same number, readable, so a program can say what it moved; this is the same number, readable, so a program can say what it
saw. *) saw. *)
| "alloc-epoch" -> | "alloc-epoch" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want expect ctx loc ~want
(mk loc (Types.Int Types.I64) (mk loc (Types.Int Types.I64)
@ -5375,7 +5435,7 @@ and named_call ctx ~want loc name args =
:allocator field carries, so a handler holding several regions can tell :allocator field carries, so a handler holding several regions can tell
which one ran out. *) which one ran out. *)
| "alloc-id" -> | "alloc-id" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want expect ctx loc ~want
(mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_id", [ a ]))) (mk loc (Types.Int Types.I64) (Tast.Prim (Tast.Rt "flan_alloc_id", [ a ])))
@ -5387,13 +5447,13 @@ and named_call ctx ~want loc name args =
invokes retry" needs a ceiling to raise, and this is it. It is also how a invokes retry" needs a ceiling to raise, and this is it. It is also how a
program exhausts an allocator on purpose. *) program exhausts an allocator on purpose. *)
| "alloc-budget" -> | "alloc-budget" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want expect ctx loc ~want
(mk loc (Types.Int Types.I64) (mk loc (Types.Int Types.I64)
(Tast.Prim (Tast.Rt "flan_alloc_budget", [ a ]))) (Tast.Prim (Tast.Rt "flan_alloc_budget", [ a ])))
| "set-alloc-budget" -> | "set-alloc-budget" ->
arity loc name 2 args; arity ctx loc name 2 args;
(match args with (match args with
| [ a; n ] -> | [ a; n ] ->
let a = check ctx ~want:Types.Alloc a in let a = check ctx ~want:Types.Alloc a in
@ -5404,7 +5464,7 @@ and named_call ctx ~want loc name args =
(* "Did you forget to free" is an allocator-tier question and this is the (* "Did you forget to free" is an allocator-tier question and this is the
tier answering it — spec-memory.md, "Leaking is defined behaviour". *) tier answering it — spec-memory.md, "Leaking is defined behaviour". *)
| "alloc-live-blocks" -> | "alloc-live-blocks" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want expect ctx loc ~want
(mk loc (Types.Int Types.I64) (mk loc (Types.Int Types.I64)
@ -5489,7 +5549,7 @@ and named_call ctx ~want loc name args =
end end
(* Unit, not a Result and not an ignorable error code: see [alloc_guard]. *) (* Unit, not a Result and not an ignorable error code: see [alloc_guard]. *)
| "push" -> | "push" ->
arity loc name 2 args; arity ctx loc name 2 args;
(match args with (match args with
| [ target; x ] -> | [ target; x ] ->
let target = check ctx target in let target = check ctx target in
@ -5528,7 +5588,7 @@ and named_call ctx ~want loc name args =
end end
| _ -> assert false) | _ -> assert false)
| "reserve" -> | "reserve" ->
arity loc name 2 args; arity ctx loc name 2 args;
(match args with (match args with
| [ target; n ] -> | [ target; n ] ->
let target = check ctx target in let target = check ctx target in
@ -5604,7 +5664,7 @@ and named_call ctx ~want loc name args =
traps a read through a released region. That is the Odin contract: free traps a read through a released region. That is the Odin contract: free
is a thing you write, and writing it twice is yours to not do. *) is a thing you write, and writing it twice is yours to not do. *)
| "free" -> | "free" ->
arity loc name 1 args; arity ctx loc name 1 args;
let target = check ctx (List.hd args) in let target = check ctx (List.hd args) in
(* A container of owning elements is refused here, and a reader will (* A container of owning elements is refused here, and a reader will
assume the opposite — that [free] recurses — so this says why it does assume the opposite — that [free] recurses — so this says why it does
@ -5779,7 +5839,7 @@ and named_call ctx ~want loc name args =
code: see [alloc_guard]. spec-memory.md is explicit that it either code: see [alloc_guard]. spec-memory.md is explicit that it either
inserts or replaces, and that (set (get m k) v) is not map syntax. *) inserts or replaces, and that (set (get m k) v) is not map syntax. *)
| "put" -> | "put" ->
arity loc name 3 args; arity ctx loc name 3 args;
(match args with (match args with
| [ target; k; v ] -> | [ target; k; v ] ->
let target = check ctx target in let target = check ctx target in
@ -5829,7 +5889,7 @@ and named_call ctx ~want loc name args =
There is no allocation here and therefore no guard: a lookup that finds There is no allocation here and therefore no guard: a lookup that finds
nothing is an answer, not a failure. *) nothing is an answer, not a failure. *)
| "get" -> | "get" ->
arity loc name 2 args; arity ctx loc name 2 args;
(match args with (match args with
| [ target; k ] -> | [ target; k ] ->
let target = check ctx target in let target = check ctx target in
@ -5859,7 +5919,7 @@ and named_call ctx ~want loc name args =
that only exists at run time — a reader building :texture-path out of a that only exists at run time — a reader building :texture-path out of a
token's text. A literal :foo never comes through here. *) token's text. A literal :foo never comes through here. *)
| "keyword" -> | "keyword" ->
arity loc name 1 args; arity ctx loc name 1 args;
(match args with (match args with
| [ s ] -> | [ s ] ->
let s = check ctx s in let s = check ctx s in
@ -5883,7 +5943,7 @@ and named_call ctx ~want loc name args =
question is askable of every value — the same line [get] takes about an question is askable of every value — the same line [get] takes about an
absent key. *) absent key. *)
| "class-of" -> | "class-of" ->
arity loc name 1 args; arity ctx loc name 1 args;
(match args with (match args with
| [ v ] -> | [ v ] ->
expect ctx loc ~want expect ctx loc ~want
@ -5904,7 +5964,7 @@ and named_call ctx ~want loc name args =
arena — or by any allocator that refuses can-free — as on a heap-backed arena — or by any allocator that refuses can-free — as on a heap-backed
one. Nothing is freed per entry because nothing was allocated per entry. *) one. Nothing is freed per entry because nothing was allocated per entry. *)
| "map-remove" -> | "map-remove" ->
arity loc name 2 args; arity ctx loc name 2 args;
(match args with (match args with
| [ target; k ] -> | [ target; k ] ->
let target = check ctx target in let target = check ctx target in
@ -5941,7 +6001,7 @@ and named_call ctx ~want loc name args =
key — so this is the one map entry point whose signature carries neither, key — so this is the one map entry point whose signature carries neither,
and the sizes are still needed because the runtime is type-erased. *) and the sizes are still needed because the runtime is type-erased. *)
| "map-next" -> | "map-next" ->
arity loc name 4 args; arity ctx loc name 4 args;
(match args with (match args with
| [ target; cur; k; v ] -> | [ target; cur; k; v ] ->
let target = check ctx target in let target = check ctx target in
@ -5965,7 +6025,7 @@ and named_call ctx ~want loc name args =
Option the caller then has to match; this is the form a condition wants, Option the caller then has to match; this is the form a condition wants,
and it copies no value. *) and it copies no value. *)
| "has-key?" -> | "has-key?" ->
arity loc name 2 args; arity ctx loc name 2 args;
(match args with (match args with
| [ target; k ] -> | [ target; k ] ->
let target = check ctx target in let target = check ctx target in
@ -6098,7 +6158,7 @@ and named_call ctx ~want loc name args =
literal for the same reason [embed]'s path is one — there is nothing at literal for the same reason [embed]'s path is one — there is nothing at
this point in a compile to compute a string from. *) this point in a compile to compute a string from. *)
| "compile-error" -> | "compile-error" ->
arity loc name 1 args; arity ctx loc name 1 args;
(match (List.hd args).Ast.e with (match (List.hd args).Ast.e with
| Ast.Str s -> fail loc "%s" s | Ast.Str s -> fail loc "%s" s
| _ -> | _ ->
@ -6108,7 +6168,7 @@ and named_call ctx ~want loc name args =
from. A macro that has to refuse builds the sentence as it expands \ from. A macro that has to refuse builds the sentence as it expands \
and puts it in the form") and puts it in the form")
| "embed-dir" -> | "embed-dir" ->
arity loc name 1 args; arity ctx loc name 1 args;
let arg = List.hd args in let arg = List.hd args in
let entries = read_embed_dir (embed_path loc arg) arg.Ast.loc in let entries = read_embed_dir (embed_path loc arg) arg.Ast.loc in
if not (Hashtbl.mem ctx.env.structs "EmbedFile") then if not (Hashtbl.mem ctx.env.structs "EmbedFile") then
@ -6197,7 +6257,7 @@ and named_call ctx ~want loc name args =
#ifdef in the host layer, which is exactly where the two targets are #ifdef in the host layer, which is exactly where the two targets are
already implemented twice. *) already implemented twice. *)
| "barf" -> | "barf" ->
arity loc name 2 args; arity ctx loc name 2 args;
(match args with (match args with
| [ path; data ] -> | [ path; data ] ->
let path = check ctx ~want:Types.String path in let path = check ctx ~want:Types.String path in
@ -6238,7 +6298,7 @@ and named_call ctx ~want loc name args =
and 2, 3, 4 here. A handler matching on it is matching on the prelude's and 2, 3, 4 here. A handler matching on it is matching on the prelude's
[file-op-delete] and friends, not on a literal. *) [file-op-delete] and friends, not on a literal. *)
| "delete-file" | "make-directory" -> | "delete-file" | "make-directory" ->
arity loc name 1 args; arity ctx loc name 1 args;
let sym, op = let sym, op =
if String.equal name "delete-file" then "flan_file_delete", 2 if String.equal name "delete-file" then "flan_file_delete", 2
else "flan_file_mkdir", 4 else "flan_file_mkdir", 4
@ -6264,7 +6324,7 @@ and named_call ctx ~want loc name args =
data, so a retry re-attempts the rename and not the expression that data, so a retry re-attempts the rename and not the expression that
computed where to. *) computed where to. *)
| "rename-file" -> | "rename-file" ->
arity loc name 2 args; arity ctx loc name 2 args;
(match args with (match args with
| [ from_; to_ ] -> | [ from_; to_ ] ->
let from_ = check ctx ~want:Types.String from_ in let from_ = check ctx ~want:Types.String from_ in
@ -6289,7 +6349,7 @@ and named_call ctx ~want loc name args =
length here (index_ty): widening indices is one change across all of them length here (index_ty): widening indices is one change across all of them
and not a Vec question. *) and not a Vec question. *)
| "len" -> | "len" ->
arity loc name 1 args; arity ctx loc name 1 args;
let target = List.hd args in let target = List.hd args in
let a = check ctx target in let a = check ctx target in
(match a.Tast.ty with (match a.Tast.ty with
@ -6341,7 +6401,7 @@ and named_call ctx ~want loc name args =
prim Tast.At ty (target :: idx)) prim Tast.At ty (target :: idx))
| _ -> fail loc "%s is (%s collection index ...)" name name) | _ -> fail loc "%s is (%s collection index ...)" name name)
| "slice" -> | "slice" ->
arity loc name 3 args; arity ctx loc name 3 args;
(match args with (match args with
| [ target; lo; hi ] -> | [ target; lo; hi ] ->
let target = check ctx target in let target = check ctx target in
@ -6398,7 +6458,7 @@ and named_call ctx ~want loc name args =
[free] refuses it by the rule it already had ("free takes an owning [free] refuses it by the rule it already had ("free takes an owning
container"). *) container"). *)
| "slice-from-ptr" -> | "slice-from-ptr" ->
arity loc name 2 args; arity ctx loc name 2 args;
(match args with (match args with
| [ target; n ] -> | [ target; n ] ->
let target = check ctx target in let target = check ctx target in
@ -6428,7 +6488,7 @@ and named_call ctx ~want loc name args =
(* ── pointers ──────────────────────────────────────────────────── *) (* ── pointers ──────────────────────────────────────────────────── *)
| "addr" -> | "addr" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = List.hd args in let a = List.hd args in
(match place_of_expr a with (match place_of_expr a with
| None -> | None ->
@ -6439,7 +6499,7 @@ and named_call ctx ~want loc name args =
let p, ty = check_place ctx a.Ast.loc p in let p, ty = check_place ctx a.Ast.loc p in
expect ctx loc ~want (mk loc (Types.Ptr ty) (Tast.Addr p))) expect ctx loc ~want (mk loc (Types.Ptr ty) (Tast.Addr p)))
| "deref" -> | "deref" ->
arity loc name 1 args; arity ctx loc name 1 args;
let a = check ctx (List.hd args) in let a = check ctx (List.hd args) in
(match a.Tast.ty with (match a.Tast.ty with
| Types.Ptr t -> expect ctx loc ~want (mk loc t (Tast.Deref a)) | Types.Ptr t -> expect ctx loc ~want (mk loc t (Tast.Deref a))
@ -6456,7 +6516,7 @@ and named_call ctx ~want loc name args =
the value instead, named for what it refuses rather than just that it the value instead, named for what it refuses rather than just that it
does. *) does. *)
| "Some" -> | "Some" ->
arity loc name 1 args; arity ctx loc name 1 args;
let arg = List.hd args in let arg = List.hd args in
let inner = match want with Some (Types.Option t) -> Some t | _ -> None in let inner = match want with Some (Types.Option t) -> Some t | _ -> None in
(* A literal [nil] is refused by this form's own message below, not by (* A literal [nil] is refused by this form's own message below, not by
@ -6481,7 +6541,7 @@ and named_call ctx ~want loc name args =
(* ── the milestone-2 host primitives (plan.org) ────────────────── *) (* ── the milestone-2 host primitives (plan.org) ────────────────── *)
| "bytes" -> | "bytes" ->
arity loc name 1 args; arity ctx loc name 1 args;
prim Tast.Bytes (Types.Slice (Types.Int Types.U8)) prim Tast.Bytes (Types.Slice (Types.Int Types.U8))
[ check ctx ~want:Types.String (List.hd args) ] [ check ctx ~want:Types.String (List.hd args) ]
@ -6526,26 +6586,26 @@ and named_call ctx ~want loc name args =
copy it, so storing one in a container or returning it hands back a view copy it, so storing one in a container or returning it hands back a view
of storage that has been reused. Copy the bytes for that. *) of storage that has been reused. Copy the bytes for that. *)
| "string" -> | "string" ->
arity loc name 1 args; arity ctx loc name 1 args;
prim Tast.StrOfBytes Types.String [ byte_slice ctx (List.hd args) ] prim Tast.StrOfBytes Types.String [ byte_slice ctx (List.hd args) ]
| "bytes->f64" -> | "bytes->f64" ->
arity loc name 1 args; arity ctx loc name 1 args;
prim Tast.BytesToF64 (Types.Float Types.F64) [ byte_slice ctx (List.hd args) ] prim Tast.BytesToF64 (Types.Float Types.F64) [ byte_slice ctx (List.hd args) ]
| "bytes->i64" -> | "bytes->i64" ->
arity loc name 1 args; arity ctx loc name 1 args;
prim Tast.BytesToI64 (Types.Int Types.I64) [ byte_slice ctx (List.hd args) ] prim Tast.BytesToI64 (Types.Int Types.I64) [ byte_slice ctx (List.hd args) ]
| "f64->bytes" -> | "f64->bytes" ->
arity loc name 1 args; arity ctx loc name 1 args;
expect ctx loc ~want expect ctx loc ~want
(to_bytes ctx loc Tast.F64ToBytes (to_bytes ctx loc Tast.F64ToBytes
(check ctx ~want:(Types.Float Types.F64) (List.hd args))) (check ctx ~want:(Types.Float Types.F64) (List.hd args)))
| "i64->bytes" -> | "i64->bytes" ->
arity loc name 1 args; arity ctx loc name 1 args;
expect ctx loc ~want expect ctx loc ~want
(to_bytes ctx loc Tast.I64ToBytes (to_bytes ctx loc Tast.I64ToBytes
(check ctx ~want:(Types.Int Types.I64) (List.hd args))) (check ctx ~want:(Types.Int Types.I64) (List.hd args)))
| "write-stdout" -> | "write-stdout" ->
arity loc name 1 args; arity ctx loc name 1 args;
prim Tast.WriteStdout Types.Unit [ byte_slice ctx (List.hd args) ] prim Tast.WriteStdout Types.Unit [ byte_slice ctx (List.hd args) ]
(* (println x) and (print x): the structural printer, selected on the type (* (println x) and (print x): the structural printer, selected on the type
@ -6566,7 +6626,7 @@ and named_call ctx ~want loc name args =
cannot be told from the punctuation. The split is exactly top level vs cannot be told from the punctuation. The split is exactly top level vs
nested, which is why it lives here and not in the walk. *) nested, which is why it lives here and not in the walk. *)
| "print" | "println" -> | "print" | "println" ->
arity loc name 1 args; arity ctx loc name 1 args;
(* Printing is a read, not a move: the walk goes over the value and keeps (* Printing is a read, not a move: the walk goes over the value and keeps
nothing. Without this, (println v) would consume a Vec and every nothing. Without this, (println v) would consume a Vec and every
printing of one would be its last. *) printing of one would be its last. *)
@ -6671,10 +6731,10 @@ and named_call ctx ~want loc name args =
in in
expect ctx loc ~want (mk loc Types.Unit (Tast.Do (parts @ nl))) expect ctx loc ~want (mk loc Types.Unit (Tast.Do (parts @ nl)))
| "exit" -> | "exit" ->
arity loc name 1 args; arity ctx loc name 1 args;
prim Tast.Exit Types.Never [ check ctx ~want:index_ty (List.hd args) ] prim Tast.Exit Types.Never [ check ctx ~want:index_ty (List.hd args) ]
| "argv" -> | "argv" ->
arity loc name 0 args; arity ctx loc name 0 args;
prim Tast.Argv (Types.Slice Types.String) [] prim Tast.Argv (Types.Slice Types.String) []
(* ── casts: (i32 x), (f64 x), and an enum both ways ──────────────── (* ── casts: (i32 x), (f64 x), and an enum both ways ────────────────
@ -6714,7 +6774,7 @@ and named_call ctx ~want loc name args =
meaning here, and not another enum: an enum-to-enum hop goes through meaning here, and not another enum: an enum-to-enum hop goes through
(i32 x) so that both ends are written down. *) (i32 x) so that both ends are written down. *)
| _ when Hashtbl.mem ctx.env.enums name -> | _ when Hashtbl.mem ctx.env.enums name ->
arity loc name 1 args; arity ctx loc name 1 args;
let target = resolve_name ctx.env ~seen:[] loc name in let target = resolve_name ctx.env ~seen:[] loc name in
let a = check ctx (List.hd args) in let a = check ctx (List.hd args) in
(match a.Tast.ty with (match a.Tast.ty with
@ -7730,7 +7790,8 @@ let collect env (decls : Ast.decl list) =
env.tvpreds <- []; env.tvpreds <- [];
if vars = [] then begin if vars = [] then begin
Hashtbl.replace env.fns fn.Ast.name (params, ret); Hashtbl.replace env.fns fn.Ast.name (params, ret);
Hashtbl.replace env.fparams fn.Ast.name fn.Ast.params Hashtbl.replace env.fparams fn.Ast.name fn.Ast.params;
Hashtbl.replace env.fn_locs fn.Ast.name fn.Ast.nloc
end end
else begin else begin
Hashtbl.replace env.generics fn.Ast.name fn; Hashtbl.replace env.generics fn.Ast.name fn;

20
lib/parse.ml
View File

@ -1756,6 +1756,14 @@ let program (forms : Form.t list) : Ast.decl list =
let program_all (forms : Form.t list) : Ast.decl list = let program_all (forms : Form.t list) : Ast.decl list =
parse_forms ~keep_going:true forms parse_forms ~keep_going:true forms
(* The head of the form that was expanded, which is the macro's name wherever
there was a macro. "%d of them" had no antecedent once the message was read
cold; this says what expanded. *)
let expanded_head (f : Form.t) =
match f.Form.v with
| Form.List ({ v = Form.Sym h; _ } :: _) -> h
| _ -> Form.to_string f
(* Single-declaration entry point, for tests and the REPL. *) (* Single-declaration entry point, for tests and the REPL. *)
let decl (f : Form.t) : Ast.decl = let decl (f : Form.t) : Ast.decl =
temps := 0; temps := 0;
@ -1765,8 +1773,10 @@ let decl (f : Form.t) : Ast.decl =
(* One declaration in, one out. A macro at the top level would break that, (* One declaration in, one out. A macro at the top level would break that,
and there is no top-level macro call: [decl] dispatches on the head and and there is no top-level macro call: [decl] dispatches on the head and
a macro name is not one of the heads it knows. *) a macro name is not one of the heads it knows. *)
Loc.fail f.loc "expanding this declaration produced %d of them" Loc.failk "parse/expansion-arity" f.loc
(List.length fs) "expanding %s produced %d declarations, and one was expected here — a \
top-level form is one declaration. Nothing joins several into one"
(expanded_head f) (List.length fs)
(* Single-expression entry point: C-x C-e, and the tests that parse one (* Single-expression entry point: C-x C-e, and the tests that parse one
expression. It expands, which [Parse.expr] above does not and never did — expression. It expands, which [Parse.expr] above does not and never did —
@ -1793,5 +1803,7 @@ let expr (f : Form.t) : Ast.expr =
(* One expression in, one out. [Macro.program] is a [List.map], so it (* One expression in, one out. [Macro.program] is a [List.map], so it
cannot answer with anything else — this is here because the invariant is cannot answer with anything else — this is here because the invariant is
worth stating where it is relied on, not because it has been seen. *) worth stating where it is relied on, not because it has been seen. *)
Loc.fail f.loc "expanding this expression produced %d forms, and an \ Loc.failk "parse/expansion-arity" f.loc
expression is one" (List.length fs) "expanding %s produced %d forms, and an expression is one — wrap them \
in (do ...) if they are meant to run in order"
(expanded_head f) (List.length fs)

35
test/test_flan.ml
View File

@ -3876,6 +3876,41 @@ let () =
"(defn f [] i32 (let [x 1] (.r x)))" "(defn f [] i32 (let [x 1] (.r x)))"
~needle:"i32 is not a struct, so it has no fields"; ~needle:"i32 is not a struct, so it has no fields";
(* A defn whose name is a builtin's is silently unreachable — the dispatch
reaches every builtin arm before it looks in the function table — and the
arity refusal was measured against the builtin while pointing at a call
the reader had written for their own. *)
(match diag_of "(defstruct P [x i32])\n(defn get [p P] i32 (.x p))\n (defn f [] i32 (let [p (P {.x 1})] (get p)))" with
| Some d ->
check "a shadowed builtin's arity has a kind"
(d.Loc.kind = "check/builtin-arity");
check "and says whose count it is"
(contains d.Loc.dmsg
"this is the builtin get, which a defn of the same name does not \
replace");
(match d.Loc.notes with
| [ n ] ->
check "and notes the definition that is not being reached"
(n.Loc.nloc.Loc.line = 2
&& contains n.Loc.nmsg "this call is not reaching it")
| _ -> check "a shadowed builtin has one note" false)
| None -> check "a shadowed builtin's call is refused" false);
(* and's last operand is the then arm and the sentinel carrying the previous
operand's location is the else arm, so with no expectation in hand the
mismatch was reported one operand early. FIX.org's accepted fix: blame
the arm that is not a compiler temp. *)
(match diag_of "(defn f [] () (println (and true true (vec-new i32))))" with
| Some d ->
check "and blames its last operand, not the one before it"
(d.Loc.kind = "check/shortcircuit-operand" && d.Loc.dloc.Loc.col = 39);
check "and states what the two answers are"
(contains d.Loc.dmsg
"an and answers false when it stops early and its last operand \
otherwise, so the two have to be one type — this operand is (Vec \
i32), and false is a bool")
| None -> check "a mistyped and operand is refused" false);
(* The reader's own two-place error. The bracket that is open is the error (* The reader's own two-place error. The bracket that is open is the error
and the end of input is the note, because the fix goes at the first and and the end of input is the note, because the fix goes at the first and
the surprise is at the second. *) the surprise is at the second. *)