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
pointer — [declared_note]'s rule. *)
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 *)
(* 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
@ -167,6 +171,7 @@ let new_env () = {
extern_locs = Hashtbl.create 32;
fns = Hashtbl.create 32;
fparams = Hashtbl.create 32;
fn_locs = Hashtbl.create 32;
globals = Hashtbl.create 16;
global_locs = Hashtbl.create 16;
lifted = [];
@ -3955,7 +3960,37 @@ and check_if ctx ?(tail = false) ?want loc c t e =
| Some _ -> want
| None -> if t.Tast.ty = Types.Never then None else Some t.Tast.ty
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 =
if t.Tast.ty = Types.Never then e.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"
(Types.to_string other)
and arity loc name n args =
if List.length args <> n then
fail loc "%s takes %d argument%s, given %d" name n
(if n = 1 then "" else "s") (List.length args)
(* A builtin's arity, and the one thing the caret cannot show: whether the
count being measured against is the builtin's or a defn of the same name.
A defn does not shadow a builtin — the dispatch above reaches every builtin
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
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
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
if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then
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.Le | ">" -> Tast.Gt | _ -> Tast.Ge
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
(* 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
@ -5151,7 +5211,7 @@ and named_call ctx ~want loc name args =
prim p Types.Bool [ a; b ]
end
| "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.
everything else, not narrowed to a strict bool first. *)
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. *)
| "<<" | ">>" ->
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
(match a.Tast.ty with
| 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,
so it only means anything where a type is expected of it. *)
| "zeroed" ->
arity loc name 0 args;
arity ctx loc name 0 args;
(match want with
| Some ty when ty <> Types.Never ->
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 \
allocator that does exist"
| "heap-allocator" ->
arity loc name 0 args;
arity ctx loc name 0 args;
expect ctx loc ~want
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_heap_allocator", [])))
(* 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
reach on purpose. *)
| "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
expect ctx loc ~want
(mk loc Types.Alloc (Tast.Prim (Tast.Rt "flan_arena_new", [ cap ])))
(* Hands the pages back, which [free-all] deliberately does not — see
docs/BUILT.md, "free-all is retain-capacity". *)
| "arena-destroy" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want
(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
rather than the runtime. *)
| "free-all" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want
(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
answer without the round trip, which is NEXT.md's call. *)
| "can-free?" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want
(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 ]));
mk loc (Types.Int Types.I8) (Tast.Int (0L, Types.I8)) ])))
| "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
expect ctx loc ~want
(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
saw. *)
| "alloc-epoch" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want
(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
which one ran out. *)
| "alloc-id" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want
(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
program exhausts an allocator on purpose. *)
| "alloc-budget" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let a = check ctx ~want:Types.Alloc (List.hd args) in
expect ctx loc ~want
(mk loc (Types.Int Types.I64)
(Tast.Prim (Tast.Rt "flan_alloc_budget", [ a ])))
| "set-alloc-budget" ->
arity loc name 2 args;
arity ctx loc name 2 args;
(match args with
| [ a; n ] ->
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
tier answering it — spec-memory.md, "Leaking is defined behaviour". *)
| "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
expect ctx loc ~want
(mk loc (Types.Int Types.I64)
@ -5489,7 +5549,7 @@ and named_call ctx ~want loc name args =
end
(* Unit, not a Result and not an ignorable error code: see [alloc_guard]. *)
| "push" ->
arity loc name 2 args;
arity ctx loc name 2 args;
(match args with
| [ target; x ] ->
let target = check ctx target in
@ -5528,7 +5588,7 @@ and named_call ctx ~want loc name args =
end
| _ -> assert false)
| "reserve" ->
arity loc name 2 args;
arity ctx loc name 2 args;
(match args with
| [ target; n ] ->
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
is a thing you write, and writing it twice is yours to not do. *)
| "free" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let target = check ctx (List.hd args) in
(* A container of owning elements is refused here, and a reader will
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
inserts or replaces, and that (set (get m k) v) is not map syntax. *)
| "put" ->
arity loc name 3 args;
arity ctx loc name 3 args;
(match args with
| [ target; k; v ] ->
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
nothing is an answer, not a failure. *)
| "get" ->
arity loc name 2 args;
arity ctx loc name 2 args;
(match args with
| [ target; k ] ->
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
token's text. A literal :foo never comes through here. *)
| "keyword" ->
arity loc name 1 args;
arity ctx loc name 1 args;
(match args with
| [ s ] ->
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
absent key. *)
| "class-of" ->
arity loc name 1 args;
arity ctx loc name 1 args;
(match args with
| [ v ] ->
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
one. Nothing is freed per entry because nothing was allocated per entry. *)
| "map-remove" ->
arity loc name 2 args;
arity ctx loc name 2 args;
(match args with
| [ target; k ] ->
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,
and the sizes are still needed because the runtime is type-erased. *)
| "map-next" ->
arity loc name 4 args;
arity ctx loc name 4 args;
(match args with
| [ target; cur; k; v ] ->
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,
and it copies no value. *)
| "has-key?" ->
arity loc name 2 args;
arity ctx loc name 2 args;
(match args with
| [ target; k ] ->
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
this point in a compile to compute a string from. *)
| "compile-error" ->
arity loc name 1 args;
arity ctx loc name 1 args;
(match (List.hd args).Ast.e with
| 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 \
and puts it in the form")
| "embed-dir" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let arg = List.hd args in
let entries = read_embed_dir (embed_path loc arg) arg.Ast.loc in
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
already implemented twice. *)
| "barf" ->
arity loc name 2 args;
arity ctx loc name 2 args;
(match args with
| [ path; data ] ->
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
[file-op-delete] and friends, not on a literal. *)
| "delete-file" | "make-directory" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let sym, op =
if String.equal name "delete-file" then "flan_file_delete", 2
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
computed where to. *)
| "rename-file" ->
arity loc name 2 args;
arity ctx loc name 2 args;
(match args with
| [ from_; to_ ] ->
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
and not a Vec question. *)
| "len" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let target = List.hd args in
let a = check ctx target in
(match a.Tast.ty with
@ -6341,7 +6401,7 @@ and named_call ctx ~want loc name args =
prim Tast.At ty (target :: idx))
| _ -> fail loc "%s is (%s collection index ...)" name name)
| "slice" ->
arity loc name 3 args;
arity ctx loc name 3 args;
(match args with
| [ target; lo; hi ] ->
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
container"). *)
| "slice-from-ptr" ->
arity loc name 2 args;
arity ctx loc name 2 args;
(match args with
| [ target; n ] ->
let target = check ctx target in
@ -6428,7 +6488,7 @@ and named_call ctx ~want loc name args =
(* ── pointers ──────────────────────────────────────────────────── *)
| "addr" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let a = List.hd args in
(match place_of_expr a with
| None ->
@ -6439,7 +6499,7 @@ and named_call ctx ~want loc name args =
let p, ty = check_place ctx a.Ast.loc p in
expect ctx loc ~want (mk loc (Types.Ptr ty) (Tast.Addr p)))
| "deref" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let a = check ctx (List.hd args) in
(match a.Tast.ty with
| 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
does. *)
| "Some" ->
arity loc name 1 args;
arity ctx loc name 1 args;
let arg = List.hd args 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
@ -6481,7 +6541,7 @@ and named_call ctx ~want loc name args =
(* ── the milestone-2 host primitives (plan.org) ────────────────── *)
| "bytes" ->
arity loc name 1 args;
arity ctx loc name 1 args;
prim Tast.Bytes (Types.Slice (Types.Int Types.U8))
[ 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
of storage that has been reused. Copy the bytes for that. *)
| "string" ->
arity loc name 1 args;
arity ctx loc name 1 args;
prim Tast.StrOfBytes Types.String [ byte_slice ctx (List.hd args) ]
| "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) ]
| "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) ]
| "f64->bytes" ->
arity loc name 1 args;
arity ctx loc name 1 args;
expect ctx loc ~want
(to_bytes ctx loc Tast.F64ToBytes
(check ctx ~want:(Types.Float Types.F64) (List.hd args)))
| "i64->bytes" ->
arity loc name 1 args;
arity ctx loc name 1 args;
expect ctx loc ~want
(to_bytes ctx loc Tast.I64ToBytes
(check ctx ~want:(Types.Int Types.I64) (List.hd args)))
| "write-stdout" ->
arity loc name 1 args;
arity ctx loc name 1 args;
prim Tast.WriteStdout Types.Unit [ byte_slice ctx (List.hd args) ]
(* (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
nested, which is why it lives here and not in the walk. *)
| "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
nothing. Without this, (println v) would consume a Vec and every
printing of one would be its last. *)
@ -6671,10 +6731,10 @@ and named_call ctx ~want loc name args =
in
expect ctx loc ~want (mk loc Types.Unit (Tast.Do (parts @ nl)))
| "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) ]
| "argv" ->
arity loc name 0 args;
arity ctx loc name 0 args;
prim Tast.Argv (Types.Slice Types.String) []
(* ── 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
(i32 x) so that both ends are written down. *)
| _ 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 a = check ctx (List.hd args) in
(match a.Tast.ty with
@ -7730,7 +7790,8 @@ let collect env (decls : Ast.decl list) =
env.tvpreds <- [];
if vars = [] then begin
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
else begin
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 =
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. *)
let decl (f : Form.t) : Ast.decl =
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,
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. *)
Loc.fail f.loc "expanding this declaration produced %d of them"
(List.length fs)
Loc.failk "parse/expansion-arity" f.loc
"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
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
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. *)
Loc.fail f.loc "expanding this expression produced %d forms, and an \
expression is one" (List.length fs)
Loc.failk "parse/expansion-arity" f.loc
"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)))"
~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
and the end of input is the note, because the fix goes at the first and
the surprise is at the second. *)