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

A diagnostic is for someone who has only this compiler, and says what to write

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-21 09:44:37 +07:00
parent af714598b8
commit 3672da28be
20 changed files with 523 additions and 615 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
FIX.org
View File

@ -5468,3 +5468,77 @@ that is a session of its own.
The four-green result is measured against that base. dev-loop has moved since
— runtime/flan_rt.c, vendor/agent/flan_agent.c and lib/dev.ml among others —
and those belong to the next batch, not to this one.
* Diagnostics reworded, 2026-09-21
The author, on a message that ran three lines to explain a naming decision:
#+begin_quote
go through all compiler messages and rewrite them plainly to state what they
mean, I don't need this verbosity, it's too much
#+end_quote
And, correcting the example he gave for it:
#+begin_quote
it should say that defvar doesn't exist. You shouldn't write compiler errors
that report design decisions we've made, but should report errors to use[rs]
who have never used this language and have no idea that defvar even existed
#+end_quote
So the standard is two rules, not one. A message says what is wrong and what
to write, and stops. And it says it to someone holding this compiler and
nothing else: no prior spelling, no milestone number, no plan.org, no
rename framed as a rename. defunion's refusal now states what defunion is and
what to write for a tagged sum, rather than announcing that the tagged sum
"is defdata now".
The headline case is the one the author quoted. It said defvar was renamed
and then explained the choice of name; it now says:
there is no defvar.
Did you mean defonce? (defonce gravity float 0.1) initialises once and
keeps its value. (def gravity float 0.1) re-initialises on every re-run.
Both spellings in it compile as written, which is the standing rule for a
suggestion and was checked by building them.
About 130 messages rewritten across lib/check.ml, lib/parse.ml,
lib/session.ml, lib/load.ml, lib/shim.ml, lib/macro.ml, lib/expand.ml,
lib/cimport.ml, lib/dev.ml, lib/render.ml, lib/build.ml, lib/emit.ml,
lib/x86.ml, runtime/flan_rt.c and vendor/agent/flan_agent.c. lib/reader.ml
was already right and was not touched, nor were parse.ml's "X is (X ...)"
usage lines, which are the shape everything else was moved towards.
emit.ml's thirty assertions are not diagnostics — each one says the checker
admitted something it refuses, so no program text reaches one. They now go
through [Emit.internal], which prefixes "internal:" and says the message is a
compiler bug, so the one person who ever sees one is told what it is instead
of reading "no layout for t" as a statement about their own code. x86.ml's
[unsupported] strings stay as they are: they name the missing feature and
session.ml already wraps them in the sentence with the fix in it.
Review follow-ups. One rewrite had turned descriptive prose into an
imperative that does not compile: the Map-into-dyn refusal said "Write
(map-new dyn) for a dyn map", and there is no such call — map-new wants a key
and a value, and dyn is refused as a key. A dyn map is the map literal, so
that is what it names now. Two more of the same class: shim.ml offered
(as-slice v), a spelling this branch retired in favour of (slice v), and the
defvar refusal echoed the old form's arguments back inside the new spelling
even when there were too few to make a valid one — (defvar x) was answered
with (defonce x), which does not compile. Fewer than two arguments now gets
the shapes rather than an echo.
Trimming went one word too far in one place: the defer refusal ended "or in a
let that is", whose antecedent had been inside the parenthetical that was
cut. And view_not_yet was missed by the sweep entirely — it still carried
five lines about what the collector does and does not scan.
Test needles followed the wording, each one picked to stay specific to the
message it is about. Two rows had to be re-pinned after review: both asserted
"uninit on one is refused", which matches the container-global arm and the
data-type arm alike, so each now names something only its own arm says. One
test was asserting the wrong thing: "a dyn in a
condition's payload" reached the struct-field refusal that fired first, never
the condition arm it was named for. The struct refusal is gone since the
descriptors landed, so the row is an [accepts] now and a new [rejects_check]
signals a dyn directly to reach the arm that is still there.

2
lib/build.ml
View File

@ -747,7 +747,7 @@ let executable ?(opts = default) ?(csrcs = []) ?(lflags = []) ?(pnames = [])
if opts.sanitize then
failwith "js: --sanitize is native only";
if opts.x86 then
failwith "js: --x86 and --target=js are two different backends";
failwith "js: --x86 and --target=js are two different backends — pick one";
write out (Js.program ~checks:opts.checks p);
out
end

545
lib/check.ml
View File

File diff suppressed because it is too large Load Diff

3
lib/cimport.ml
View File

@ -192,8 +192,7 @@ let run_clang ~loc ~header ~flags =
with Unix.Unix_error _ ->
List.iter Unix.close [ out_r; out_w; err_r; err_w ];
fail loc
"clang is not on PATH, and reading a C header is done by running it \
(%s)"
"clang is not on PATH, and reading a C header runs it (%s)"
(String.concat " " argv)
in
Unix.close out_w;

15
lib/dev.ml
View File

@ -1515,7 +1515,7 @@ let layout t ~ty =
`C-x C-e' with its case and that case's fields. *)
error
(ty
^ " is a data type, not a struct; a data type is a tag and one payload per case, so it has no single field list for this op to answer with. Its value renders with its case and fields in a frame's locals and at C-x C-e")
^ " is a data type, not a struct, so it has no one field list to answer with. Its value renders with its case and fields in a frame's locals and at C-x C-e")
else
let suffix = "/" ^ ty in
let candidates =
@ -1901,7 +1901,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
if not mine then
Error
(name
^ " is a frame of the expression this break is inside, not of the program; its thunk is not part of the session, so there is no record of what its slots are called")
^ " is a frame of the expression this break is inside, not of the program, so there is no record of what its slots are called")
else
match find_fn t name with
| None ->
@ -1917,7 +1917,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
if nslots <> Array.length fn.Tast.slots then
Error
(Printf.sprintf
"%s on the stack has %d slots and the %s this session holds has %d: the frame is running a body that has been redefined since, so every slot index here would be a guess"
"%s on the stack has %d slots and the %s this session holds has %d — the frame is running a body that has been redefined since"
name nslots name (Array.length fn.Tast.slots))
else if sig_ <> Emit.slot_fingerprint fn then
(* The count matching is not the same as the body matching.
@ -1930,7 +1930,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
cannot be trusted are different facts. *)
Error
(Printf.sprintf
"%s on the stack was compiled from a different body than the %s this session holds: this frame's body was redefined since it was entered, so its names no longer describe its values"
"%s on the stack was compiled from a different body than the %s this session holds — it was redefined after this frame was entered, so its names no longer describe its values"
name name)
else Ok (name, fn)))
@ -5086,10 +5086,9 @@ let start ?(debug = false) ?(merged = true) ?(x86 = true) ~file ~sock () =
and it is still refused. *)
if x86 && debug then
failwith
"flan dev --x86 --debug: the dev backend emits DWARF for a whole program \
but not yet for a redefinition module, so a breakpoint set on a line \
would stop firing at the first C-c C-c. Drop --x86 and --debug will \
build this session with LLVM, which has both.";
"flan dev --x86 --debug: the dev backend emits no DWARF for a \
redefinition module, so a breakpoint would stop firing at the first \
C-c C-c. Drop --x86 to build this session with LLVM.";
(* The merged daemon used to be refused here for [--x86] and no longer is,
and what made the combination safe is worth stating where the refusal
stood. A merged build is the program and the compiler in one process, and

88
lib/emit.ml
View File

@ -37,6 +37,19 @@
let fail = Loc.fail
(* The assertions below this line are not diagnostics. Every one of them says
the checker admitted something it refuses — a type with no layout, a case
that is not a case of its data type, arithmetic on a struct — so no program
text reaches one and there is no fix to name. They are still worded for a
reader, because the one way to see one is a compiler bug and the person who
sees it should be told that rather than left reading "no layout for t" as a
statement about their own code. [internal] is the whole of the treatment
they get: the prefix check.ml already uses, and the sentence that says who
the message is for. *)
let internal fmt =
Printf.ksprintf
(fun m -> failwith ("internal: " ^ m ^ " — this is a compiler bug")) fmt
(* [List.map]'s evaluation order is unspecified, and so is [let ... and ...].
Emission is all side effect — instructions, calls, branches to a [ret] — so
left-to-right is required, not a preference. Same rule as in Check. *)
@ -163,13 +176,13 @@ module Rt = struct
let field s n =
match List.assoc_opt n (snd (layout s)) with
| Some o -> o
| None -> failwith (Printf.sprintf "no field %s in %%%s" n s.sname)
| None -> internal "no field %s in %%%s" n s.sname
(* The [getelementptr] index of a field, which is this backend's handle on
it — LLVM counts fields where the assembler counts bytes. *)
let index s n =
let rec go i = function
| [] -> failwith (Printf.sprintf "no field %s in %%%s" n s.sname)
| [] -> internal "no field %s in %%%s" n s.sname
| (f, _) :: rest -> if String.equal f n then i else go (i + 1) rest
in
go 0 s.fields
@ -260,7 +273,7 @@ let rec ll (t : Types.t) =
| Types.Dyn -> "i64"
| Types.Var _ ->
(* The checker rejects it by name — nothing reaches here. *)
failwith ("no layout for " ^ Types.to_string t)
internal "no layout for %s" (Types.to_string t)
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
@ -472,9 +485,9 @@ let rec lay m (t : Types.t) : int * int =
| None ->
match Hashtbl.find_opt m.unions n with
| Some u -> union_lay m u
| None -> failwith ("no layout for struct " ^ n))
| None -> internal "no layout for struct %s" n)
| Types.Dyn -> 8, 8
| Types.Var _ -> failwith ("no layout for " ^ Types.to_string t)
| Types.Var _ -> internal "no layout for %s" (Types.to_string t)
(* Size, alignment, and the offset of every member. *)
and lay_fields m tys =
@ -527,7 +540,7 @@ and payload_lay m (u : Tast.data) : int * int =
(* The integer kind of a given width, for the payload blob's element type. *)
and int_kind = function
| 8 -> Types.I8 | 16 -> Types.I16 | 32 -> Types.I32 | 64 -> Types.I64
| n -> failwith ("no integer type of " ^ string_of_int n ^ " bits")
| n -> internal "no integer type of %d bits" n
(* ── Per-type dyn descriptors ────────────────────────────────────────
*
@ -774,7 +787,7 @@ let rec dty m d (t : Types.t) : int =
(String.concat ", "
(List.map (fun i -> Printf.sprintf "!%d" i) ms)));
id
| None -> failwith ("no debug type for struct " ^ sn))
| None -> internal "no debug type for struct %s" sn)
(* An opaque pointer under lldb, which is the truth: the allocator's
fields are the runtime's C and lldb already has that type from
flan_rt.c's own debug info. *)
@ -820,7 +833,7 @@ let rec dty m d (t : Types.t) : int =
runtime's own printer. *)
| Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned"
| Types.Var _ ->
failwith ("no debug type for " ^ Types.to_string t)
internal "no debug type for %s" (Types.to_string t)
in
Hashtbl.replace d.dtys key n;
n
@ -2006,7 +2019,7 @@ and field_addr f (target : Tast.expr) i =
let sty = match target.Tast.ty with
| Types.Named n -> sname n
| Types.Option _ as t -> ll t
| t -> failwith ("field of " ^ Types.to_string t)
| t -> internal "field of %s" (Types.to_string t)
in
let p = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" p sty base i;
@ -2044,7 +2057,7 @@ and element_addr f (target : Tast.expr) idx =
let p = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) base i64;
go p elem rest
| t -> failwith ("index into " ^ Types.to_string t))
| t -> internal "index into %s" (Types.to_string t))
in
go (addr f target) target.Tast.ty idx
@ -2054,13 +2067,13 @@ and place f (p : Tast.place) : string * Types.t =
| Tast.Pglobal n -> global_addr f n, Hashtbl.find f.md.globals n
| Tast.Pfield (target, i) ->
let sn = match target.Tast.ty with
| Types.Named n -> n | t -> failwith ("field of " ^ Types.to_string t)
| Types.Named n -> n | t -> internal "field of %s" (Types.to_string t)
in
field_addr f target i, field_ty f.md sn i
| Tast.Pindex (target, idx) -> element_addr f target idx
| Tast.Pderef target ->
let t = match target.Tast.ty with
| Types.Ptr t -> t | t -> failwith ("deref of " ^ Types.to_string t)
| Types.Ptr t -> t | t -> internal "deref of %s" (Types.to_string t)
in
value f target, t
@ -2077,7 +2090,7 @@ and emit_make_case f dname case fields =
let u = Hashtbl.find f.md.datas dname in
let tag = match Tast.case_index u case with
| Some (i, _) -> i
| None -> failwith ("no case " ^ case ^ " of " ^ dname)
| None -> internal "no case %s of %s" case dname
in
let tmp = alloca f ty in
ins f "store %s zeroinitializer, ptr %s" (ll ty) tmp;
@ -2110,7 +2123,7 @@ and payload_addr f dname base =
and case_field_addr f (target : Tast.expr) case i =
let dname = match target.Tast.ty with
| Types.Named n -> n
| t -> failwith ("case field of " ^ Types.to_string t)
| t -> internal "case field of %s" (Types.to_string t)
in
let base = addr f target in
let pp = payload_addr f dname base in
@ -2579,7 +2592,7 @@ and emit_match f ty scrut arms =
match scrut.Tast.ty with
| Types.Named n when Hashtbl.mem f.md.datas n -> Some n
| Types.Option _ -> None
| t -> failwith ("match on " ^ Types.to_string t)
| t -> internal "match on %s" (Types.to_string t)
in
let tag, read_tag, bind_of =
match dname with
@ -2587,7 +2600,7 @@ and emit_match f ty scrut arms =
let sv = value f scrut in
let sty = ll scrut.Tast.ty in
let payload_ty = match scrut.Tast.ty with
| Types.Option t -> t | t -> failwith ("match on " ^ Types.to_string t)
| Types.Option t -> t | t -> internal "match on %s" (Types.to_string t)
in
let tag = fresh f in
ins f "%s = extractvalue %s %s, 0" tag sty sv;
@ -2610,7 +2623,7 @@ and emit_match f ty scrut arms =
(fun c ->
match Tast.case_index u c with
| Some (i, _) -> ("i32", i)
| None -> failwith ("no case " ^ c ^ " of " ^ n)),
| None -> internal "no case %s of %s" c n),
fun case i slot ->
let pp = payload_addr f n base in
let fp = fresh f in
@ -2619,7 +2632,7 @@ and emit_match f ty scrut arms =
let fty =
match Tast.case_index u case with
| Some (_, c) -> (List.nth c.Tast.vfields i).Tast.fty
| None -> failwith ("no case " ^ case ^ " of " ^ n)
| None -> internal "no case %s of %s" case n
in
let v = load f fp fty in
ins f "store %s %s, ptr %s" (ll fty) v f.slots.(slot);
@ -2694,7 +2707,7 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
| Types.Int _, Tast.Mul -> "mul"
| Types.Int k, Tast.Div -> if Types.signed k then "sdiv" else "udiv"
| Types.Int k, _ -> if Types.signed k then "srem" else "urem"
| t, _ -> failwith ("arithmetic on " ^ Types.to_string t)
| t, _ -> internal "arithmetic on %s" (Types.to_string t)
in
(* A divide or a remainder by zero, and the one division that overflows,
signal ArithError. Integers only: IEEE says x / 0.0 is an infinity and
@ -2735,7 +2748,7 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
(runtime/flan_rt.c), bytewise with a length and a same-pointer fast
path. [check.ml] only ever builds [Eq]/[Ne] here: [<] and friends are
refused on a string before a Tast node exists (Types.is_comparable
says no), so the [failwith] below is unreachable except as a checker
says no), so the [internal] below is unreachable except as a checker
bug, and stays as the same tripwire the Enum case above already is. *)
| Types.String ->
let ap = fresh f in
@ -2751,10 +2764,10 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
r ap al bp bl;
let cc = match p with
| Tast.Eq -> "ne" | Tast.Ne -> "eq"
| _ -> failwith ("comparison on " ^ Types.to_string x.Tast.ty)
| _ -> internal "comparison on %s" (Types.to_string x.Tast.ty)
in
ins f "%s = icmp %s i8 %s, 0" t cc r
| t' -> failwith ("comparison on " ^ Types.to_string t'));
| t' -> internal "comparison on %s" (Types.to_string t'));
t
| (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ] ->
let a = value f x in
@ -2763,7 +2776,7 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
| _, Tast.BitAnd -> "and" | _, Tast.BitOr -> "or"
| _, Tast.BitXor -> "xor" | _, Tast.Shl -> "shl"
| Types.Int k, _ -> if Types.signed k then "ashr" else "lshr"
| t, _ -> failwith ("bitwise on " ^ Types.to_string t)
| t, _ -> internal "bitwise on %s" (Types.to_string t)
in
(* The count is masked to the operand's width. LLVM makes an over-wide
shift poison, and a poison return at -O2 is a function that returns
@ -2840,7 +2853,7 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
let p = fresh f in
ins f "%s = getelementptr inbounds i8, ptr %s, i64 %s" p q lo64;
p
| t -> failwith ("slice of " ^ Types.to_string t)
| t -> internal "slice of %s" (Types.to_string t)
in
let d = fresh f in
ins f "%s = sub i64 %s, %s" d hi64 lo64;
@ -3010,7 +3023,7 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
| Tast.AlignOf t, [] -> Printf.sprintf "%d" (snd (lay f.md t))
| Tast.AddrOf, [ x ] -> addr_rooted f x
| Tast.Cast target, [ x ] -> cast f ~guard:(fun () -> guard f) x target
| _ -> failwith "malformed primitive"
| _ -> internal "malformed primitive"
(* A slice argument crosses to C as ptr+len, never as a struct by value. *)
and explode f (x : Tast.expr) =
@ -3096,7 +3109,7 @@ and cast f ~guard (x : Tast.expr) target =
decided the value was a bool, so the discarded bits are zero. *)
| Types.Bool, Types.Int _ -> "zext"
| Types.Int _, Types.Bool -> "trunc"
| _ -> failwith "unsupported cast"
| _ -> internal "unsupported cast"
in
if op = "bitcast" then v
else begin
@ -3510,9 +3523,8 @@ let rec const m (e : Tast.expr) =
diagnostic, and it fires only if that refusal and [Tast.const_init] stop
agreeing about the same set. *)
| _ ->
failwith
("no constant image for " ^ Types.to_string e.Tast.ty ^ " at "
^ Loc.to_string e.Tast.loc)
internal "no constant image for %s at %s"
(Types.to_string e.Tast.ty) (Loc.to_string e.Tast.loc)
(* A dev build emits a [defconst] as a mutable [global]. Two things follow, and
both are wanted: LLVM can no longer fold a read of it, and a redefinition
@ -3845,9 +3857,9 @@ declare i64 @flan_dyn_map_get(i64, i64)
declare void @flan_dyn_map_set(i64, i64, i64)
declare i64 @flan_dyn_map_contains(i64, i64)
; The nine that trap carry the site as ptr+len, the way the bounds and
; arithmetic traps in flan_rt.c do: a dyn type error IS the type error in a
; dynamic program, and it used to print with no file and no line. [eq] never
; traps, so it has nowhere to put one.
; arithmetic traps do: a dyn type error IS the type error in a dynamic
; program, and it used to print with no file and no line. [eq] never traps,
; so it has nowhere to put one.
declare i64 @flan_dyn_add(i64, i64, ptr, i64)
declare i64 @flan_dyn_sub(i64, i64, ptr, i64)
declare i64 @flan_dyn_mul(i64, i64, ptr, i64)
@ -4363,11 +4375,9 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
that links, runs, and silently installs nothing. There is no such thing as
a reloadable macro module, so nothing is lost by saying so out loud. *)
if hidden && dev then
failwith
"Emit.program ~hidden ~dev: a dev build exports its cells so that a \
redefinition module can reach them, and hiding them would break every \
reload. [hidden] is the macro module's flag and a macro module is not a \
dev build.";
internal
"Emit.program was given ~hidden and ~dev together, and a dev build has \
to export its cells";
let m = new_module ~checks ~dev ~known:(fun _ -> true) ~debug ~sanitize p in
(* One cell per function, initialised to the function this build compiled.
Nothing has been redefined yet, so a dev build starts out behaving exactly
@ -4470,7 +4480,7 @@ let program ?(checks = true) ?(dev = false) ?(debug = false) ?(pnames = [])
(fun n ->
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = n) p.Tast.fns with
| Some fn -> macro_thunk m fn
| None -> failwith ("no such macro: " ^ n))
| None -> internal "no such macro %s" n)
macros;
finish m
@ -4505,7 +4515,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
let target name =
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
| Some f -> f
| None -> failwith (Printf.sprintf "no such function: %s" name)
| None -> internal "no such function %s" name
in
let targets = List.map target fns in
(* A clause lifted out of one of these comes with it: its body may have

5
lib/expand.ml
View File

@ -192,9 +192,8 @@ let rec quote (f : Form.t) : Form.t =
match f.Form.v with
| Form.List ({ Form.v = Form.Sym "quasiquote"; _ } :: _) ->
Loc.fail loc
"a quasiquote inside a quasiquote is not implemented: the reader does \
not count nesting levels and neither does this, so the inner one has \
no meaning to give. Build the inner form with form-cons"
"a quasiquote inside a quasiquote is not implemented — build the \
inner form with form-cons"
| Form.Sym s -> node loc "Sym" "s" (Form.Str s)
| Form.Kw s -> node loc "Kw" "s" (Form.Str s)
| Form.Int i -> node loc "Int" "i" (Form.Int i)

9
lib/load.ml
View File

@ -1113,9 +1113,8 @@ let rec import ~seen ~open_ ~loc alias dir =
List.map (fun (_, a) -> a) ring @ [ alias ]
in
fail loc
"%s imports itself round a ring: %s. Imports have to be acyclic — a \
definite package order is what lets a package be compiled before the \
ones that use it — so one of these imports has to go"
"%s imports itself round a ring: %s. Imports have to be acyclic, so \
one of these has to go"
(snd (List.nth open_ i)) (String.concat " -> " names)
| None -> ());
match Hashtbl.find_opt seen dir' with
@ -1130,8 +1129,8 @@ let rec import ~seen ~open_ ~loc alias dir =
{ decls = []; csrcs = []; lflags = []; pkgs = []; macros }
| Some (previous, _) ->
fail loc
"%s is imported as %s here and as %s elsewhere; one directory is one set \
of names, so the two cannot both be true" dir alias previous
"%s is imported as %s here and as %s elsewhere — one directory takes \
one alias" dir alias previous
| None ->
Hashtbl.replace seen dir' (alias, []);
let open_ = open_ @ [ (dir', alias) ] in

15
lib/macro.ml
View File

@ -180,10 +180,8 @@ let reduce (forms : Form.t list) : Form.t list =
match head_name f with
| Some ("defmacro", n) when names_macro macros f ->
Loc.fail f.Form.loc
"the prelude macro %s calls a macro, and a prelude macro may not: \
the module that expands it is compiled from the prelude, so the \
call would have to be expanded by a module that does not exist \
yet. Call a function instead"
"the prelude macro %s calls a macro, and a prelude macro may not. \
Call a function instead"
n
| _ -> ())
forms;
@ -412,8 +410,7 @@ and settle l first loc (f : Form.t) left =
if left <= 0 then
Loc.fail loc
"expanding %s did not settle after %d rounds — a macro that expands \
into a call to a macro has to get smaller each time, and this one is \
not"
into a macro call has to get smaller each time"
first fuel
else begin
let args = List.map (expand_form l) args in
@ -450,10 +447,8 @@ let rounds ~(prelude : string list) (pending : (string * Form.t) list)
in
if now = [] then
Loc.fail (snd (List.hd pending)).Form.loc
"these macros call each other and none can be compiled first: %s. A \
defmacro has to be compiled before the call it expands, so a ring \
has no order to be compiled in — one of them has to call a function \
instead"
"these macros call each other and none can be compiled first: %s. \
One of them has to call a function instead"
(String.concat ", " waiting)
else
let taken = taken @ now in

103
lib/parse.ml
View File

@ -50,9 +50,8 @@ let no_pattern (f : Form.t) =
match f.v with
| Map _ | Vec _ ->
fail f
"%s is a destructuring pattern, and a pattern binds only in let — this \
position takes a plain name. Take the value under a name and \
destructure it in the body"
"%s is a destructuring pattern, and this position takes a plain name. \
Take the value under a name and destructure it in the body"
(Form.to_string f)
| _ -> ()
@ -96,8 +95,7 @@ let rec texpr (f : Form.t) : Ast.texpr =
and with braces gone from type position there is nothing for it to be
confused with. *)
| Map _ ->
fail f "a map type is written (Map K V), not in braces — braces in type \
position are not a type"
fail f "a map type is written (Map K V), not in braces"
| List ({ v = Sym "Fn"; _ } :: rest) ->
(match rest with
| [ { v = Vec params; _ }; ret ] ->
@ -163,10 +161,8 @@ and dyn_params which (items : Form.t list) : Ast.field list =
floc = it.loc }
| _ ->
fail it
"a %s's parameter is a bare name, and found %s. Every parameter of \
a generic function is dyn — there is no type to write, and a \
method that wanted one could not be reached by a dispatch that \
does not know types either"
"a %s's parameter is a bare name, and found %s. Every parameter \
here is dyn, so there is no type to write"
which (Form.to_string it))
items
@ -189,8 +185,7 @@ and dispatch (f : Form.t) : Ast.dispatch =
fail f
"a method's dispatch value is a class's name, a keyword, a string, an \
integer, true, false, or :else for the one that answers when no other \
does — and found %s. It is matched at compile time as well as at run \
time, so it is written out rather than computed"
does — and found %s. It is written out, not computed"
(Form.to_string f)
(* ── The constraint map at the head of a defn body ──────────────────────
@ -256,9 +251,8 @@ let constraints (body : Form.t list) : Ast.pred list * Form.t list =
| _ -> rest <> []) ->
if kvs = [] then
Loc.fail loc
"an empty map literal here is discarded — the body has more after \
it, and its value going unused is almost always a typo for \
{:where ...}; write (do {} ...) if the empty map is deliberate"
"an empty map literal here is discarded — did you mean {:where ...}? \
Write (do {} ...) if the empty map is deliberate"
else
let pred (p : Form.t) =
match p.Form.v with
@ -530,9 +524,7 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
(match args with
| { v = Kw k; _ } :: _ ->
fail f
":%s — loop takes no label. break and continue may not leave a loop, \
because a loop answers with the value of its body; there is nothing \
for a label to name" k
":%s — loop takes no label; break and continue may not leave a loop" k
| { v = Vec bs; _ } :: body -> mk (Ast.Loop (loop_bindings f bs, body_of body))
| _ -> fail f "loop is (loop [name value ...] body ...)")
@ -691,9 +683,8 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
| "defdata" | "defunion" | "defclass" | "defgeneric" | "defmulti"
| "defmethod" | "defenum" | "defalias" | "import" as name) ->
fail f
"%s is a top-level declaration, not an expression. A quasiquoted one is \
a value and a macro may answer with it; an evaluated one is not a thing \
anything can do" name
"%s defines a name at the top level, so it cannot be used as an \
expression here" name
(* Recognised, deliberately unimplemented. Rejected rather than left to fall
through to Call, where they would parse and mean nothing. *)
@ -702,7 +693,7 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
| Sym ("find-restart" | "compute-restarts"
| "errdefer"
| "await" as name) ->
fail f "%s is not implemented yet (see the build sequence in plan.org)" name
fail f "%s is not implemented yet" name
(* ── field access: (.pos c) ────────────────────────────────────── *)
| Sym s when String.length s > 1 && s.[0] = '.' ->
@ -1190,9 +1181,8 @@ and pattern (f : Form.t) : Ast.pattern =
spelled as a constructor it is not. *)
| Kw member ->
fail f
":%s is not implemented as a pattern — match is over an Option here, \
and an enum member cannot be one until Ast.pattern can hold a keyword. \
Use cond with (= k :%s)" member member
":%s is not implemented as a pattern — use cond with (= k :%s)"
member member
| List ({ v = Sym ctor; _ } :: binds) ->
List.iter no_pattern binds;
Ast.Pctor (ctor, List.map sym binds)
@ -1315,11 +1305,9 @@ let rec decl (f : Form.t) : Ast.decl =
in
if looks_tagged then
Loc.failk "parse/defunion-renamed" f.loc
"the tagged sum is defdata now — (defdata Name [(Case [field \
Type ...]) ...]) — and defunion is C's untagged union, whose \
members overlay one storage: (defunion Name [member Type \
...]). This reads as the tagged one, so it is refused rather \
than quietly given the other meaning")
"defunion is C's untagged union, written (defunion Name \
[member Type ...]). This reads as a tagged sum — write \
(defdata Name [(Case [field Type ...]) ...])")
ms;
mk (Ast.Defunion (sym n, fields f ms))
| _ -> fail f "defunion is (defunion Name [member Type ...])")
@ -1442,9 +1430,8 @@ let rec decl (f : Form.t) : Ast.decl =
| Sym name -> (name, s.loc)
| _ ->
fail s
"a class slot is a name. Its value is dyn and there is \
no type to write: an instance is a dyn map with a \
shape tag on it, and (get p :%s) is how a slot is read"
"a class slot is a name — its value is dyn, so there \
is no type to write. Read one with (get p :%s)"
(Form.to_string s))
slots))
| _ -> fail f "defclass is (defclass Name [slot ...])")
@ -1569,16 +1556,15 @@ let rec decl (f : Form.t) : Ast.decl =
else if explicit then
Loc.failk "parse/enum-value-out-of-range" loc
"the member %s of %s is %Ld, which does not fit i32 — an enum's \
discriminant is an i32, so its members run from -2147483648 to \
2147483647. Give %s a value in that range, or a defconst of a \
wider type if the number itself is what matters"
members run from -2147483648 to 2147483647. Give %s a value in \
that range, or use a defconst"
m ename v m
else
Loc.failk "parse/enum-value-out-of-range" loc
"the member %s of %s has no value of its own, so it \
autoincrements to %Ld, which does not fit i32 — an enum's \
discriminant is an i32, so its members run from -2147483648 to \
2147483647. Write %s's value out, or lower the member above it"
members run from -2147483648 to 2147483647. Write %s's value \
out, or lower the member above it"
m ename v m
in
(* Each member becomes its name, its value, whether that value was
@ -1674,30 +1660,34 @@ let rec decl (f : Form.t) : Ast.decl =
that is not a type is the value of a dyn global"
form form form)
(* The old name of [defonce], refused by name rather than left to fall
through to "unknown function": every program written before the rename
spells it, and the message is the migration. *)
(* [defvar] is caught by name rather than left to fall through to "unknown
function", because two forms answer it and a did-you-mean over one name
could only ever offer one of them.
It says there is no defvar, not that defvar was renamed. The reader has
this compiler and nothing else: a rename is a fact about our history, and
what they need is the name that exists and what it does. *)
| List ({ v = Sym "defvar"; _ } :: args) ->
(* The rest of the form is echoed back inside the two spellings, so the
answer is a line that can be pasted. A form with nothing after the
keyword has nothing to paste, and echoing it would offer
[(defonce )] as the fix for [(defvar )] — a malformed old form
answered with a malformed new one. The names alone then, which is what
there is to say about a form that named nothing. *)
answer is a line that can be pasted. That only holds for a form long
enough to make a valid one: the shortest defonce is [(defonce name
value)], so an old form with fewer than two arguments has nothing to
paste and echoing it would answer [(defvar x)] with [(defonce x)] —
a malformed old form given a malformed new one, which is the standing
rule against a suggestion that does not compile. The shapes alone
then, which is what there is to say about a form that named too
little. *)
(match args with
| [] ->
| [] | [ _ ] ->
Loc.failk "parse/defvar-renamed" f.loc
"defvar is now called defonce — the name says what it does: it \
initialises once and keeps its value across re-runs. It is \
(defonce name Type value?), or (def name Type value?) if the value \
should follow the source on every re-run"
"there is no defvar. Did you mean defonce? \
(defonce name Type value?) initialises once and keeps its value; \
(def name Type value?) re-initialises on every re-run"
| _ ->
let rest = String.concat " " (List.map Form.to_string args) in
Loc.failk "parse/defvar-renamed" f.loc
"defvar is now called defonce — the name says what it does: it \
initialises once and keeps its value across re-runs. Write (defonce \
%s), or (def %s) if the value should follow the source on every \
re-run"
"there is no defvar. Did you mean defonce? (defonce %s) initialises \
once and keeps its value; (def %s) re-initialises on every re-run"
rest rest)
| List ({ v = Sym "defconst"; _ } :: args) ->
@ -1756,9 +1746,8 @@ let rec decl (f : Form.t) : Ast.decl =
fault to guess at. *)
| List ({ v = Sym "do"; _ } :: _) ->
fail f
"a top-level (do ...) is several declarations spliced in place, and this \
is a position that takes exactly one — a macro answering several is a \
file's form, not an expression's"
"a top-level (do ...) is several declarations, and this position takes \
exactly one"
| List ({ v = Sym s; _ } :: _) -> fail f "unknown top-level form (%s ...)" s
| _ -> fail f "expected a top-level declaration, found %s" (Form.to_string f)

6
lib/render.ml
View File

@ -389,5 +389,9 @@ let rec render c depth (e : Tast.expr) : Tast.expr list =
is not milestone 1's. *)
| Types.Dyn ->
[ unit_ (Tast.Prim (Tast.Rt "flan_dyn_print", [ e ])) ]
(* Reachable: [(println m)] on a Map. Everything else in [Types.t] has an
arm above, and a [Var] never reaches a backend. So this names the fix
rather than only the refusal. *)
| t ->
fail loc "no printer for %s" (Types.to_string t)
fail loc "no printer for %s — print the values you want out of it"
(Types.to_string t)

21
lib/session.ml
View File

@ -283,9 +283,8 @@ let compatible ?(origin = fun _ -> None) ?(relaxed = []) ~loc
gname )
in
fail loc
"%s changes signature, from (Fn [%s] %s) to (Fn [%s] %s); \
the calls already compiled into the running program pass the old \
one.%s Restart to change it."
"%s changes signature, from (Fn [%s] %s) to (Fn [%s] %s).%s \
Restart to change it."
what
(String.concat " " (List.map Types.to_string g.Tast.params))
(Types.to_string g.Tast.ret)
@ -318,17 +317,15 @@ let compatible ?(origin = fun _ -> None) ?(relaxed = []) ~loc
&& Types.equal g.Tast.gty h.Tast.gty
&& not (same_const g.Tast.ginit h.Tast.ginit) ->
fail loc
"%s is used at compile time — an array length or a type — so the \
running program has its old value in its shape, where a reload \
cannot reach it. Restart to change it."
"%s is used at compile time, in an array length or a type. \
Restart to change it."
g.Tast.gname
| Some h when not (Types.equal g.Tast.gty h.Tast.gty) ->
(* The storage exists and has a shape. Reusing it for another one
reads fields at the wrong offsets; allocating fresh storage would
silently discard the state the reload exists to preserve. *)
fail loc
"%s changes type, from %s to %s; the running program already laid \
that storage out. Restart to change it."
"%s changes type, from %s to %s. Restart to change it."
g.Tast.gname (Types.to_string h.Tast.gty) (Types.to_string g.Tast.gty)
(* Which form declared a global is not in the storage, it is in the
code the process was *built* with: [Emit.startup_plan] wrote the
@ -396,8 +393,7 @@ let compatible ?(origin = fun _ -> None) ?(relaxed = []) ~loc
including ones held in globals that the reload is preserving. *)
if not same then
fail loc
"%s changes layout; the values the running program is holding have \
the old one. Restart to change it."
"%s changes layout. Restart to change it."
s.Tast.sname
| None -> ())
new_.Tast.structs
@ -420,8 +416,7 @@ let compatible_enums ~loc old_ new_ =
match List.assoc_opt n before with
| Some old_ms when old_ms <> ms ->
fail loc
"%s changes its members; the running program folded the old values \
into every call site that names one. Restart to change it."
"%s changes its members. Restart to change it."
n
| _ -> ())
(members new_)
@ -504,7 +499,7 @@ let redefinition (t : t) ?retains ?call ?(consts = []) program ~fns =
refusal it belongs to, and reaches [flan reload] too. *)
fail loc
"the x86 dev backend cannot compile this: %s. Restart the daemon with \
flan dev --llvm, which compiles every form this one refuses" m
flan dev --llvm" m
(* ── Undoing an acceptance ─────────────────────────────────────────── *)

27
lib/shim.ml
View File

@ -195,8 +195,7 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
"int32_t"
else if Hashtbl.mem env.datas n then
fail loc
"%s is %s, a data type, and a Flan data type has no C layout — the shim \
cannot be generated for it"
"%s is %s, a data type, which has no C layout"
what n
(* A union is the one refusal here that is not about the type. It has a
C layout — it *is* a C layout, which is the whole reason it exists —
@ -206,14 +205,12 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
way through is the way every other aggregate crosses. *)
else if Hashtbl.mem env.unions n then
fail loc
"%s is %s, a union, and the shim generator writes structs only — a \
union has a C layout but nothing here emits the declaration for \
it yet. Pass (Ptr %s) and let the C side read it"
"%s is %s, a union, and the shim generator writes structs only. \
Pass (Ptr %s) and let the C side read it"
what n n
else if String.equal n "string" then
fail loc
"%s is a string, and a string only crosses as a parameter — a C \
function that *returns* one returns something Flan has no owner for"
"%s is a string, and a string only crosses as a parameter"
what
else if String.equal n "Unit" || String.equal n "Never" then
fail loc "%s is %s, which is not a value C can carry" what n
@ -222,15 +219,14 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
| Ast.Tapp ("Ptr", [ e ]) -> cty env ~needed ~loc ~what e ^ " *"
| Ast.Tapp ("Option", _) ->
fail loc
"%s is an Option, which is a Flan shape and not a C one — declare what C \
returns and build the Option in Flan"
"%s is an Option, which C has no shape for — declare what C returns and \
build the Option in Flan"
what
| Ast.Tslice _ ->
fail loc
"%s is a slice, which crosses as ptr+len with an i64 length, and the \
count parameter the C function actually takes has a type this \
declaration does not say — declare (Ptr T) with an explicit count and \
pass (addr (at s 0)) and (len s) from Flan"
"%s is a slice, and nothing here says what type the C count parameter \
is — declare (Ptr T) with an explicit count, and pass \
(addr (at s 0)) and (len s) from Flan"
what
| Ast.Tarray _ ->
fail loc
@ -247,9 +243,8 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
elements cross the way any other run of elements does. *)
| Ast.Tapp ("Vec", _) ->
fail loc
"%s is a Vec, which owns its storage — handing its header to C hands out \
an owner. Pass (slice v) as (Ptr T) and (len v), the same shape a \
slice crosses in"
"%s is a Vec, which owns its storage. Pass (slice v) as (Ptr T) and \
(len v)"
what
| Ast.Tfn _ ->
fail loc "%s is a function type, and a C callback is not implemented" what

19
lib/x86.ml
View File

@ -965,8 +965,8 @@ let store_scalar_at f ~reg ~base ~disp (t : Types.t) =
let blockcopy f n =
if n > 0 then begin
note f (Printf.sprintf
"rep movsb: %d bytes from rsi to rdi. An aggregate is copied rather than \
aliased — spec-memory.md's assignment rule" n);
"rep movsb: %d bytes from rsi to rdi. An aggregate is copied \
rather than aliased." n);
movabs f.b ~dst:rcx (Int64.of_int n);
rep_movsb f.b
end
@ -2413,8 +2413,9 @@ and bounds_call f sym (loc : Loc.t) (extra : int list) =
call_sym f.b sym;
guard f;
note f
"ud2, where emit.ml writes unreachable. Nothing answered the signal, so the runtime \
already died inside that call and nothing falls through to here.";
"ud2, where the LLVM backend writes unreachable. Nothing answered the \
signal, so the runtime already died inside that call and nothing falls \
through to here.";
ud2 f.b
(* The length an index is checked against, or [None] for the one form
@ -3684,9 +3685,9 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
| Some fr ->
if ann then set_ind f.b "";
note f
"The shadow stack's push — runtime/flan_dev.c. Dev builds only, and it is what \
lets a stopped program say where it is. The pop is the first thing in the \
epilogue, so a transfer out of this frame pops it too.";
"The shadow stack's push. Dev builds only, and it is what lets a stopped \
program say where it is. The pop is the first thing in the epilogue, so \
a transfer out of this frame pops it too.";
(* Every entry, not only the named ones: "null means not bound" has to
hold at every index, or a reader has to know which indices it may
trust, and that is a second thing to keep in step. *)
@ -3746,8 +3747,8 @@ let emit_fn (md : Emit.m) ~externs ~fns ?(ext = fun _ -> false)
jmp_lbl f.b f.retlbl;
if ann then set_ind f.b "";
note f
"The transfer exit — spec-conditions.md §5. A transfer that found no restart-case \
in this frame leaves the way a return does, which is what runs the defers.";
"The transfer exit. A transfer that found no restart-case in this frame \
leaves the way a return does, which is what runs the defers.";
lbl f.b f.xfer_lbl;
(* [emit.ml] leaves here with [ret zeroinitializer]. The value is
meaningless to a caller — its guard sees the channel set and never looks

41
runtime/flan_rt.c
View File

@ -753,9 +753,8 @@ _Noreturn void flan_restart_unarmed(const uint8_t *loc, int64_t loclen,
const uint8_t *want, int64_t wantlen) {
rt_flush_out();
fprintf(stderr,
"%.*s: restart %.*s takes %.*s, and whatever took it supplied no "
"arguments — a restart with parameters cannot be taken from the "
"break loop yet\n",
"%.*s: restart %.*s takes %.*s, and none was supplied — a restart "
"with parameters cannot be taken from the break loop yet\n",
(int)loclen, (const char *)loc, (int)namelen, (const char *)name,
(int)wantlen, (const char *)want);
rt_trap((const uint8_t *)"RestartUnarmed", 14);
@ -769,8 +768,7 @@ _Noreturn void flan_restart_unarmed(const uint8_t *loc, int64_t loclen,
_Noreturn void flan_transfer_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out();
fprintf(stderr,
"%.*s: a defer invoked a restart, which a defer may not do — it is "
"the cleanup a transfer runs on its way out\n",
"%.*s: a defer invoked a restart, which a defer may not do\n",
(int)loclen, (const char *)loc);
rt_trap((const uint8_t *)"TransferFromDefer", 17);
}
@ -905,13 +903,9 @@ _Noreturn void flan_slice_promise_fail(const uint8_t *loc, int64_t loclen,
int64_t n) {
rt_flush_out();
fprintf(stderr,
"%.*s: slice-from-ptr was promised %lld elements behind the pointer, "
"and a count of elements is never negative\n",
"%.*s: slice-from-ptr was promised %lld elements behind the "
"pointer, and a count is never negative\n",
(int)loclen, (const char *)loc, (long long)n);
fprintf(stderr,
" the caller promises the pointer addresses n elements and nothing "
"else can know it, so the sign of n is the whole of what this check "
"can see\n");
rt_die();
}
@ -994,9 +988,8 @@ static void flan_arith_fail(const uint8_t *loc, int64_t loclen, int32_t op,
case FLAN_ARITH_DIV_OVERFLOW:
case FLAN_ARITH_REM_OVERFLOW:
fprintf(stderr,
"%.*s: (%s %lld %lld) overflows: the quotient is one past the "
"largest value the type holds, and this is the only pair of "
"operands for which that is true\n",
"%.*s: (%s %lld %lld) overflows — the quotient is one past the "
"largest value the type holds\n",
(int)loclen, (const char *)loc,
op == FLAN_ARITH_DIV_OVERFLOW ? "/" : "%", (long long)lhs,
(long long)rhs);
@ -1491,9 +1484,8 @@ _Noreturn void flan_null_alloc_fail(const uint8_t *loc, int64_t loclen) {
_Noreturn void flan_free_all_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out();
fprintf(stderr,
"%.*s: this allocator does not offer free-all — it has no region to "
"release, and releasing nothing is not the same as releasing "
"everything\n",
"%.*s: this allocator does not offer free-all — it has no region "
"to release\n",
(int)loclen, (const char *)loc);
rt_trap((const uint8_t *)"NoFreeAll", 9);
}
@ -1547,12 +1539,10 @@ void flan_alloc_region_only(flan_allocator *a, const uint8_t *loc,
_Noreturn void flan_region_only_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out();
fprintf(stderr,
"%.*s: this container's elements own storage, and this allocator can "
"free one block — so a free here would release the slots and leak "
"everything inside them, and nothing type-erased can walk them. "
"Build it against a region allocator, whose free-all takes the "
"inner blocks too: (with-allocator context/temp ...) or an "
"(arena-new n)\n",
"%.*s: this container's elements own storage, and this allocator "
"frees one block at a time, so freeing it here would leak what the "
"elements hold. Build it against a region allocator: "
"(with-allocator context/temp ...) or an (arena-new n)\n",
(int)loclen, (const char *)loc);
rt_die();
}
@ -2885,9 +2875,8 @@ int64_t flan_file_fail_reason(void) { return flan_file_fail; }
_Noreturn void flan_shim_nul_fail(const char *site) {
rt_flush_out();
fprintf(stderr,
"%s: a string passed to C contains a NUL byte — C reads to the "
"first one, so the value this function would act on is a prefix of "
"the one passed. Remove the NUL before the call.\n",
"%s: a string passed to C contains a NUL byte — C reads only up "
"to it. Remove the NUL before the call.\n",
site);
rt_die();
}

38
test/test_acceptance.ml
View File

@ -1052,7 +1052,7 @@ let () =
spellings, not one form that changes type with its context. *)
refuses_src "embed asked for a type it cannot read a file as"
"(defn main [] i32 (len (embed \"no-such-asset.bin\" i32)))"
"`string` is the only one";
"embed's second argument is string";
(* Allocators, spec-memory.md. The tier on its own, with no container
above it, so that a failure here is not read as a Vec bug. What is
@ -1356,7 +1356,7 @@ let () =
one branch per container, where the allocator is still a value the
site is holding. *)
traps "a container of owning elements against the heap" "1"
"this allocator can free one block";
"this allocator frees one block at a time";
(* A different mechanism, pinned separately: the epoch, and specifically
an inner header copied *out* of its container before the release. It
traps because an Allocator is a pointer — a copied-by-value one would
@ -1368,7 +1368,7 @@ let () =
first push is what adopts the context. Pinned from both sides — run 0
above grows the same zeroed field in a region and must not trap. *)
traps "a zeroed field of owning elements grown against the heap" "3"
"this allocator can free one block";
"this allocator frees one block at a time";
(try Sys.remove exe with Sys_error _ -> ())
in
region ();
@ -2938,7 +2938,7 @@ let () =
and cannot change. *)
refuses "a package generic's bound, refused at the call"
"programs/pkg-generic-reject.flan"
"string does not answer ordered?";
"string is not ordered?";
refuses "and the refusal quotes the clause the package wrote"
"programs/pkg-generic-reject.flan" "{:where (ordered? $t)}";
@ -2971,7 +2971,7 @@ let () =
chain of instantiations and not a depth it gave up at. *)
refuses "an unconstrained operator in a generic body"
"programs/generic-reject.flan"
"only what it is declared to support";
"nothing declares t numeric?";
refuses "an unconstrained operator names the way out"
"programs/generic-reject.flan" "{:where (numeric? $t)}";
refuses "a runaway instantiation" "programs/generic-runaway.flan"
@ -2999,7 +2999,7 @@ let () =
requirement the author wrote down. What is asserted is that it names
the type passed and the predicate it failed, and not the body. *)
refuses "a generic over maps, instantiated at a key that cannot be hashed"
"programs/generic-map-reject.flan" "does not answer hashable?";
"programs/generic-map-reject.flan" "f64 is not hashable?";
refuses "and it names the type the call site asked for"
"programs/generic-map-reject.flan" "at $t = f64";
@ -3010,7 +3010,7 @@ let () =
refuses "a package's main is not visible" "programs/pkg-hidden-main.flan"
"sand/main is not a name";
refuses "one directory under two aliases" "programs/pkg-two-aliases.flan"
"one directory is one set of names";
"one directory takes one alias";
(* A ring is refused and the ring is named. The needle is the chain, not
the word "cycle": what a person needs is which three imports, and the
refusal that says only "there is a cycle" leaves them to find it. The
@ -3025,7 +3025,7 @@ let () =
is that the clash is caught at all when the two halves are a page and a
directory apart, rather than side by side as in the case above. *)
refuses "one directory under two aliases, through a package"
"programs/pkg-alias-clash.flan" "one directory is one set of names";
"programs/pkg-alias-clash.flan" "one directory takes one alias";
(* A ring is refused and the ring is named. The needle is the chain, not
the word "cycle": what a person needs is which three imports, and the
refusal that says only "there is a cycle" leaves them to find it. The
@ -3063,7 +3063,7 @@ let () =
one — or anywhere to put the flan_allocator, Allocator being opaque and
pointer-width. Two reasons, both named, neither a function value. *)
refuses "a user-written allocator" "programs/user-allocator.flan"
"is no longer what is missing";
"a user-written allocator is not implemented yet";
(* Move-only, spec-memory.md, since the repeal: the three fixtures that
were refused here — a use after a pass, a double free, a move inside a
loop — now compile, and what they do at run time is the allocator's and
@ -3087,7 +3087,7 @@ let () =
storage. Refused by the shim generator, where the message can say what
to pass instead. *)
refuses "a Vec crossing to C" "programs/vec-to-c.flan"
"handing its header to C hands out an owner";
"is a Vec, which owns its storage";
(* ── wasm32 (NEXT.md, deferred item 6) ──────────────────────────────
The second target, and the reason sand-headless imports no raylib. What
@ -3584,14 +3584,14 @@ level "1"
shim_refuses "declare-c: a slice parameter, by name and reason"
(v2 ^ "(declare-c poly [pts [Vector2]] bool \"Poly\")")
"the count parameter the C function actually takes";
"what type the C count parameter is";
shim_refuses "declare-c: an Option"
(v2 ^ "(declare-c maybe [] (Option Vector2) \"Maybe\")")
"which is a Flan shape and not a C one";
"an Option, which C has no shape for";
shim_refuses "declare-c: a data type"
("(defdata Shape [(Circle [r f32]) (Square [s f32])])\n\
(declare-c area [s Shape] f32 \"Area\")")
"a data type, and a Flan data type has no C layout";
"a data type, which has no C layout";
shim_refuses "declare-c: a fixed array"
"(declare-c takes [xs [4 f32]] \"Takes\")"
"which C passes as a pointer and Flan as a value";
@ -3757,7 +3757,7 @@ level "1"
refuses_src "a float is not a map key"
"(defn f [m (Map f32 i32)] () 0)" "is not a map key";
refuses_src "a Ptr is not a map key"
"(defn f [m (Map (Ptr i32) i32)] () 0)" "hash an address";
"(defn f [m (Map (Ptr i32) i32)] () 0)" "is not a map key. A key is an integer";
(* A map value that owns storage is no longer refused at the type: that
refusal was about teardown, and which tier the map will meet is not
knowable where its type is written. What it became is a branch on the
@ -4740,7 +4740,7 @@ level "1"
"A is a case of the data type U";
refuses_src "a data type type used as a constructor"
"(defdata U [(A [x i32])])\n(defn main [] i32 (let [v (U {.x 1})] 0))"
"a data type value names the case as well as the type";
"so a value of it names a case";
refuses_src "a case with fields written bare"
"(defdata U [(A [x i32])])\n(defn main [] i32 (let [v U.A] 0))"
"has fields, so it needs them";
@ -4789,7 +4789,7 @@ level "1"
refuses_src "a data type is not a map key"
"(defdata U [A B])\n\
(defn f [m (Map U i32) k U] () (put m k 1))"
"the payload past the case in hand is indeterminate";
"a data type is not a map key";
(* A *constant* cannot hold a case, because writing one at link time means
serialising the fields into the payload blob and a string field is a
relocation a byte array has nowhere to put. Refused in the checker since
@ -4811,7 +4811,7 @@ level "1"
incr failures;
Printf.printf "FAIL %s\n it was accepted\n" name
| exception Loc.Error { Loc.dmsg = m; _ } ->
if not (contains m "needs a byte-level encoder that does not exist")
if not (contains m "a constant cannot be U.B")
then begin
incr failures;
Printf.printf "FAIL %s\n said: %S\n" name m
@ -4862,12 +4862,12 @@ level "1"
assume cannot be reached. *)
refuses_src "uninit on a data type global"
"(defdata U [A B])\n(defonce g U uninit)\n(defn main [] i32 0)"
"its tag steers every match";
"Drop the uninit — a zeroed U is U.A";
(* A data type's fields belong to a case, so .field is not a read anyone can
do without having read the tag first. match is how one is opened. *)
refuses_src "reading a field of a data type directly"
"(defdata U [(A [x i32])])\n(defn f [u U] i32 (.x u))"
"reached by (match ...)";
"its fields belong to a case";
(* And a zeroed one is fine, which is the other half of the same rule: it
is the first declared case, all bytes zero, and needs no encoder. *)
(let name = "a zeroed data type global" in

113
test/test_flan.ml
View File

@ -524,15 +524,15 @@ let () =
(match (parse_decl "(def counter i64 (start))").d with
| Defvar ("counter", Some { t = Tname "i64"; _ }, Init _, Every) -> ()
| _ -> check "a typed def with an initialiser" false);
(* The old name, refused with the migration in the message: what it is
called now, why the name, and both new spellings — each of which
compiles as written. *)
(* The old name, refused as a name that does not exist rather than as a
rename: the reader has this compiler and nothing else, so what they need
is the name that does exist, what it does, and the other one beside it.
Both spellings compile as written. *)
parse_rejects "the old defvar spelling names defonce"
"(defvar counter i64 7)"
~needle:"defvar is now called defonce — the name says what it does: it \
initialises once and keeps its value across re-runs. Write \
(defonce counter i64 7), or (def counter i64 7) if the value \
should follow the source on every re-run";
~needle:"there is no defvar. Did you mean defonce? (defonce counter i64 \
7) initialises once and keeps its value; (def counter i64 7) \
re-initialises on every re-run";
(match read "(defvar counter i64 7)" |> Parse.program with
| _ -> check "the old defvar spelling has a kind" false
| exception Loc.Error { Loc.kind; _ } ->
@ -542,8 +542,8 @@ let () =
malformed new one as its fix. *)
parse_rejects "the old spelling with no arguments names the shapes"
"(defvar)"
~needle:"It is (defonce name Type value?), or (def name Type value?) if \
the value should follow the source on every re-run";
~needle:"(defonce name Type value?) initialises once and keeps its \
value; (def name Type value?) re-initialises on every re-run";
(match (parse_decl "(import rl \"vendor:raylib\")").d with
| Import ("rl", "vendor:raylib") -> () | _ -> check "import" false);
@ -598,7 +598,7 @@ let () =
parse_rejects "defmacro with a non-name param" "(defmacro m [1] x)"
~needle:"a macro's parameter is a name or a [ ] pattern";
parse_rejects "defmacro in expression position" "(defn f [] () (defmacro m [] 1))"
~needle:"top-level declaration";
~needle:"cannot be used as an expression here";
(* The tagged sum is [defdata] now. The old spelling is refused by name
rather than aliased, because the name is reserved for a type with
@ -606,13 +606,13 @@ let () =
which of the two it means instead of being quietly given one of them. *)
parse_rejects "the old defunion spelling"
"(defunion Shape [(Circle [r f32]) (Square [s f32])])"
~needle:"the tagged sum is defdata now";
~needle:"This reads as a tagged sum";
(* The shape that would otherwise parse: two bare case names read as one
member of a type. Same refusal, and this is the one that matters — it
would have compiled. *)
parse_rejects "the old defunion spelling with payload-less cases"
"(defunion U [A B])"
~needle:"the tagged sum is defdata now";
~needle:"This reads as a tagged sum";
(match read "(defunion U [A B])" |> Parse.program with
| _ -> check "the old spelling has a kind" false
| exception Loc.Error { Loc.kind; _ } ->
@ -730,7 +730,7 @@ let () =
~needle:"the member B of E is 4294967296, which does not fit i32";
parse_rejects "the out-of-range refusal says what the range is"
"(defenum E [A 0 B 4294967296])"
~needle:"its members run from -2147483648 to 2147483647";
~needle:"an enum's members run from -2147483648 to 2147483647";
(* Nothing in the source wrote 2147483648, so the sentence has to say where
it came from before it can say it is wrong. *)
parse_rejects "an autoincrement off the top of i32"
@ -1347,7 +1347,7 @@ let () =
accepts "all-distinct over a type variable"
"(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))";
rejects_check "a chain still wants the right predicate"
~needle:"nothing here says t is ordered?"
~needle:"nothing declares t ordered?"
"(defn between [a $t b $t c $t] bool {:where (equal? $t)} (< a b c))";
(* One operand and none. Both would have to be [true] whatever they were
handed, which is a typo carrying a value. *)
@ -1564,6 +1564,15 @@ let () =
accepts "a dyn in a condition's payload"
"(defstruct Boom [what dyn])\n\
(defn main [] () (signal (Boom {.what 1})))";
(* What a condition may still not *be*. A handler matches on the condition's
type, and a dyn has no type until it runs, so the dyn itself is refused
where the struct it holds would have been fine. This is the arm the
"a dyn in a condition's payload" row above used to reach by accident, by
way of the struct-field refusal that fired first and is now gone: a dyn
value has to be signalled directly to get here at all. *)
rejects_check "a dyn signalled as the condition itself"
"(defn f [d dyn] () (signal d))"
~needle:"a condition is matched by its type and dyn is not one";
(* Nested by value, which is the case the flattening is for: the inner
struct's dyn word appears in the outer's table at the sum of the two
offsets, and there is no second descriptor to follow at run time. *)
@ -2117,10 +2126,10 @@ let () =
written in, which is what the acceptance program sorts. *)
rejects_check "slice of a returned array"
"(defn mk [] [3 i32] [7 8 9]) (defn f [] [i32] (slice (mk)))"
~needle:"a returned array is a temporary";
~needle:"a temporary the slice would outlive";
rejects_check "slice of a returned array, three arguments"
"(defn mk [] [3 i32] [7 8 9]) (defn f [] [i32] (slice (mk) 0 3))"
~needle:"a returned array is a temporary";
~needle:"a temporary the slice would outlive";
accepts "slice of an array literal"
"(defn f [] [i32] (slice [7 8 9]))";
(* One builtin, one answer about a bound. A slice bound is a subscript and
@ -2166,7 +2175,7 @@ let () =
store. *)
rejects_check "the address of a string's byte"
"(defn f [s string] (Ptr u8) (addr (at s 0)))"
~needle:"take the address of";
~needle:"(at s i) is a value and not a place";
(* And a string is still not a [u8]: slicing one does not smuggle a byte
slice out of it. *)
rejects_check "a string slice is not a byte slice"
@ -2325,11 +2334,10 @@ let () =
accepts "a local is assignable"
"(defn f [] i32 (let [x 1] (set x 2) x))";
rejects_check "a parameter is not assignable"
"(defn f [x i32] () (set x 2))" ~needle:"a parameter is not a place you can assign to";
"(defn f [x i32] () (set x 2))" ~needle:"a parameter is not assignable";
rejects_check "a constant is not assignable"
"(defconst k 1) (defn f [] () (set k 2))"
~needle:"k is a constant, and a constant is not assignable — it is \
written into the image and there is nothing to assign to. \
~needle:"k is a constant, and a constant is not assignable. \
Declare it with defonce if it has to change";
accepts "addr of a local gives a pointer"
(cursor ^ "(defn g [c (Ptr Cursor)] i32 (.pos c)) \
@ -2651,7 +2659,7 @@ let () =
rejects_check "a dispatch value is written out, not computed"
"(defmulti d [x] dyn x)\n(defmethod d (f 1) [x] 1)\n\
(defn main [] i32 0)"
~needle:"is written out rather than computed";
~needle:"It is written out, not computed";
(* A method has no return slot: the generic states the type once, for all
of them. What that means for anyone writing the defn spelling by habit
is that the slot they would have written is read as the first form of
@ -2695,7 +2703,7 @@ let () =
rejects_check "Map takes two types" "(defn f [x (Map i32)] ())"
~needle:"exactly two types";
rejects_check "Result is milestone 6" "(defn f [] (Result i32 i32) None)"
~needle:"milestone 6";
~needle:"(Result T E) is not implemented";
(* ── The region rule, spec-memory.md's arena rule ────────────────────
The compile-time half of it, which is the only half a checker row can
@ -2723,7 +2731,7 @@ let () =
rejects_check "free on a container of owning elements"
"(defdata V [Nil (L [xs (Vec V)])])\n\
(defn f [v (Vec V)] () (free v))"
~needle:"(free-all a) takes it";
~needle:"Write (free-all a) on the region";
(* clone is refused for a reason the region does *not* dissolve: it promises
an independent copy and a bytewise one is an alias. *)
rejects_check "clone on a container of owning elements"
@ -2747,12 +2755,12 @@ let () =
"(defonce g (Vec u8) (slurp \"game-data.edn\")) (defn f [] ())";
rejects_check "a move-only global as a defconst"
"(defconst g (Vec u8) (slurp \"game-data.edn\")) (defn f [] ())"
~needle:"a defonce and not a defconst";
~needle:"is a defonce, not a defconst";
(* uninit is the one initialiser a container still refuses, and it is a
different rule: a garbage block pointer is not a garbage number. *)
rejects_check "a global Vec declared uninit"
"(defonce g (Vec u8) uninit) (defn f [] ())"
~needle:"steers every read of it";
~needle:"Write (defonce g (Vec u8)) with no initialiser";
(* ── What may be filled with raw bytes ─────────────────────────────
[(filled b)] and [(dead-beef)] are [zeroed]'s siblings, and the
@ -3161,7 +3169,7 @@ let () =
~needle:"with no handler-bind or restart-case around it";
rejects_check "an invoke-restart in a global initialiser"
"(defonce w i64 (do (invoke-restart 'retry) 1))\n(defn f [] i64 w)"
~needle:"an initialiser runs at startup";
~needle:"with no handler-bind or restart-case around it";
(* And what is *inside* one runs like any other code: the frames a
restart-case pushes it also pops, before the initialiser returns. This is
[slurp]'s shape, which is why a global loaded from a file works at all. *)
@ -3177,7 +3185,7 @@ let () =
(defn f [] () (set g (vec-new u8)) (push g 1) (set (at g 0) 2) \
(println (len (slice g))) (let [c (clone g)] (free c)))";
rejects_check "try is milestone 6" "(defn f [] i32 (try 1))"
~needle:"milestone 6";
~needle:"try (Result) is not implemented";
(* dotimes and defer are implemented, and a defer in a [let] is now one of
the places it may be written: a let at the top level of a function body
has exactly the function's extent (see test/programs/defer-let.flan). What
@ -3278,7 +3286,7 @@ let () =
(* Where the "refuse mutual recursion by name" answer lives: there are no
tail calls, so a function cannot recur into itself either. *)
rejects_check "recur outside a loop"
"(defn f [] () (recur))" ~needle:"no tail calls";
"(defn f [] () (recur))" ~needle:"only allowed inside a (loop ...)";
rejects_check "recur with the wrong number of values"
"(defn f [] i32 (loop [i 0 j 1] (recur 1)))"
~needle:"binds 2 names and this recur passes 1";
@ -3293,10 +3301,10 @@ let () =
accepts "a while inside a loop keeps its own break"
"(defn f [] () (loop [i 0] (while true (break))))";
rejects_check "break may not leave a loop"
"(defn f [] () (loop [i 0] (break)))" ~needle:"no value to give";
"(defn f [] () (loop [i 0] (break)))" ~needle:"break cannot leave a (loop ...)";
rejects_check "a labelled break may not leave a loop"
"(defn f [] () (while :o true (loop [i 0] (break :o))))"
~needle:"no value to give";
~needle:"would leave a (loop ...)";
accepts "a while condition is an ordinary expression"
"(defn f [] () (let [v (vec-new i32) n 0] \
(while (and (< n 10) (> (len v) 0)) (set n (+ n 1))) (free v)))";
@ -3578,7 +3586,7 @@ let () =
rejects_check "a data type case nested in a constant struct"
"(defdata U [A (B [x i32])]) (defstruct S [u U]) \
(defconst g S (S {.u (U.B {.x 1})}))"
~needle:"needs a byte-level encoder that does not exist";
~needle:"a constant cannot be U.B";
accepts "a constant written as a literal"
"(defconst x u64 0xcbf29ce484222325)";
accepts "a constant written as arithmetic over other constants"
@ -3717,7 +3725,7 @@ let () =
(boom ^ "(defn f [] i32 (let [n 1] (handler-case 0 [(Boom [c] n)])))");
rejects_check "a handler-bind clause still cannot"
(boom ^ "(defn f [] i32 (let [n 1] (handler-bind [(Boom [c] (set n 2))] 0)))")
~needle:"a handler cannot see n: it is a local of the enclosing function";
~needle:"a handler cannot see n — it is a local of the enclosing function";
(* Nothing static refuses a condition no clause lists: it installs no frame
that matches, so it goes past untouched and the body carries on. *)
accepts "a condition no clause lists"
@ -3933,10 +3941,10 @@ let () =
be one that kills the program instead. *)
rejects_check "an array pattern over a slice"
"(defn f [s [i32]] i32 (let [[a b] s] (+ a b)))"
~needle:"a slice's length is a runtime value";
~needle:"a slice's length is not known until the program runs";
rejects_check "an array pattern over a slice, even with & rest"
"(defn f [s [i32]] i32 (let [[a & r] s] (+ a (len r))))"
~needle:"a slice's length is a runtime value";
~needle:"a slice's length is not known until the program runs";
rejects_check "an array pattern over something with no elements at all"
"(defn f [n i32] i32 (let [[a b] n] (+ a b)))"
~needle:"i32 is not a fixed array";
@ -3966,7 +3974,7 @@ let () =
List.iter
(fun (what, src) ->
rejects_check ("a pattern in " ^ what) src
~needle:"a pattern binds only in let")
~needle:"this position takes a plain name")
[ "a defn parameter", pt ^ "(defn f [{:keys [x]} Point] i32 x)";
"a defstruct field", "(defstruct S [[a b] i32])";
"an fn parameter", "(defn f [] i32 (let [g (fn [[a b]] a)] 0))";
@ -3996,7 +4004,7 @@ let () =
rejects_check "a pattern inside a match arm's binds"
"(defstruct P [x i32])\n\
(defn f [o (Option P)] i32 (match o (Some {:keys [x]}) x None 0))"
~needle:"a pattern binds only in let";
~needle:"this position takes a plain name";
(* The desugaring's own machinery is unspellable: the reader makes [~] a
delimiter, so the name never reaches the parser as one symbol. *)
@ -4054,11 +4062,11 @@ let () =
rejects_check "a data type member"
"(defdata D [A (B [x i32])])\n\
(defunion U [d D n i64])\n(defn f [u U] i32 0)"
~needle:"a data type's tag steers every match";
~needle:"a data type, and a union may not hold one";
rejects_check "a data type inside a struct member"
"(defdata D [A B])\n(defstruct S [d D n i32])\n\
(defunion U [s S n i64])\n(defn f [u U] i32 0)"
~needle:"a data type's tag steers every match";
~needle:"a data type, and a union may not hold one";
(* An Option is not on that list, and the difference is the lowering: its
match is a test of the tag byte and a branch, so a scribbled tag reads as
a Some with a payload nobody stored — which is what this language says a
@ -4081,7 +4089,7 @@ let () =
rejects_check "a union literal giving two members"
"(defunion U [i i32 f f32])\n\
(defn f [] i32 (let [u (U {.i 1 .f 2.0})] (.i u)))"
~needle:"only one of them can be written";
~needle:"only one member can be written";
rejects_check "a union literal giving a member it does not have"
"(defunion U [i i32])\n(defn f [] i32 (let [u (U {.z 1})] (.i u)))"
~needle:"U has no member z";
@ -4091,7 +4099,7 @@ let () =
rejects_check "match on a union"
"(defunion U [i i32 f f32])\n\
(defn f [u U] i32 (match u _ 0))"
~needle:"there is nothing in one to match on";
~needle:"nothing in one records which member was written";
(* A member narrower than the union leaves the rest indeterminate, so two
values that agree about everything anybody wrote would hash apart. *)
rejects_check "a union as a map key"
@ -5348,9 +5356,8 @@ let () =
(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")
"an and answers false or its last operand, 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
@ -5461,7 +5468,7 @@ let () =
accepts "numeric? admits +"
"(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))";
rejects_check "equal? does not admit <"
~needle:"nothing here says t is ordered?"
~needle:"nothing declares t ordered?"
"(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))";
(* The entailments, which are the reason a signature is one predicate long
rather than two. Every type the language orders is a number or an enum,
@ -5489,10 +5496,10 @@ let () =
accepts "integer? admits the shifts"
"(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))";
rejects_check "numeric? does not admit bit-and"
~needle:"nothing here says t is integer?"
~needle:"nothing declares t integer?"
"(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))";
rejects_check "nor the shifts"
~needle:"nothing here says t is integer?"
~needle:"nothing declares t integer?"
"(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))";
(* An integer?-bounded caller satisfies a numeric?-bounded callee: the
entailment carries across generic calls exactly as ordered?-over-equal?
@ -5508,13 +5515,13 @@ let () =
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 300))";
(* A float at integer?, refused at the call that asked, naming the bound. *)
rejects_check "a float does not instantiate an integer?-bounded variable"
~needle:"f64 does not answer integer?"
~needle:"f64 is not integer?"
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 1))\n\
(defn main [] () (println (bump 1.5)))";
(* And dyn is refused by the bound too — the clause's own refusal, the more
specific of the two answers, exactly as at numeric?. *)
rejects_check "dyn does not instantiate an integer?-bounded variable"
~needle:"dyn does not answer integer?"
~needle:"dyn is not integer?"
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 1))\n\
(defonce d dyn 5)\n\
(defn main [] () (println (bump d)))";
@ -5623,7 +5630,7 @@ let () =
"(defn same [a $t b $t] bool {:where (equal? $t)} (= a b)) \
(defn f [] bool (same \"a\" \"b\"))";
rejects_check "ordered? $t instantiated at string"
~needle:"does not answer ordered?"
~needle:"is not ordered?"
"(defn less [a $t b $t] bool {:where (ordered? $t)} (< a b)) \
(defn f [] bool (less \"a\" \"b\"))";
@ -5675,7 +5682,7 @@ let () =
it and the call site, or the refusal moves into code the caller did not
write. *)
rejects_check "a predicate is not carried through a generic call"
~needle:"has to be carried by every signature"
~needle:"Add {:where (ordered? $t)} to this function's own clause"
"(defn outer [s [$t]] () {:where (equal? $t)} (sort s))";
accepts "and is accepted when it is"
"(defn outer [s [$t]] () {:where (ordered? $t)} (sort s))";
@ -5801,7 +5808,7 @@ let () =
nor i64 holds every value of the other, and inventing a third type
would be picking one neither argument was written at. *)
rejects_check "u64 and i64 meet at no type"
~needle:"the two meet at no type"
~needle:"neither holds every value of the other"
"(defn eq2? [a $t b $t] bool {:where (equal? $t)} (= a b))\n\
(defonce u u64 3)\n(defonce i i64 3)\n\
(defn main [] () (println (eq2? u i)))";
@ -5882,10 +5889,10 @@ let () =
instantiation at which it means nothing — and the refusal below is what
stops that reaching the call site. *)
rejects_check "an unconstrained type variable admits no literal"
~needle:"may be instantiated at a type that holds no number"
~needle:"nothing declares $t numeric"
"(defn f [x $t] bool (> x 0))";
rejects_check "and ordered? is not the bound that admits one"
~needle:"Declare the bound"
~needle:"Write {:where (numeric? $t)}"
"(defn f [x $t] bool {:where (ordered? $t)} (> x 0))";
(* The asymmetry, and it is the concrete arms' asymmetry rather than a new
one: an untyped integer constant is usable where a float is wanted, and

6
test/test_repl.ml
View File

@ -145,9 +145,9 @@ let () =
name defonce", which is why the reason asserted here was empty; now
that an expression expands, a macro can produce one, and the head
says what it is wherever it appears. *)
refuses "a declaration" "(defonce nope i64)" "top-level declaration";
refuses "a declaration" "(defonce nope i64)" "cannot be used as an expression here";
refuses "a declaration inside an expression" "(do 1 (defn f [] i32 1))"
"top-level declaration";
"cannot be used as an expression here";
refuses "an unknown name" "no-such-name" "unknown name";
(* [defmacro] is in that same head list, and it is the shape that stays
refused now that a [defmacro] typed at the editor means something: a
@ -156,7 +156,7 @@ let () =
about an unknown function. C-c C-c is where a declaration goes, which
is the case below. *)
refuses "a defmacro at C-x C-e" "(defmacro m [& args] args)"
"top-level declaration";
"cannot be used as an expression here";
(* And the session is untouched by all of it: an evaluation is not a
declaration, so nothing named eval/N accumulates in the program. *)

4
test/test_session.ml
View File

@ -712,12 +712,12 @@ let () =
(match Session.eval_expr ~origin:"programs/pkg-macro.flan" tm "(defn f [] i32 1)" with
| _ -> fail "a declaration was accepted as an expression"
| exception Loc.Error { Loc.dmsg = m; _ } ->
if not (has m "top-level declaration") then
if not (has m "cannot be used as an expression here") then
fail "a declaration as an expression said %S" m);
(match Session.eval_expr ~origin:"programs/pkg-macro.flan" tm "(do 1 (defonce g i64))" with
| _ -> fail "a nested declaration was accepted as an expression"
| exception Loc.Error { Loc.dmsg = m; _ } ->
if not (has m "top-level declaration") then
if not (has m "cannot be used as an expression here") then
fail "a nested declaration as an expression said %S" m);
(* The two non-termination refusals. They matter more here than in a build:

4
vendor/agent/flan_agent.c vendored
View File

@ -843,8 +843,8 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
* describing two different programs. */
if (!s->resumable)
fprintf(stderr,
" this trap has no transfer channel, so nothing here can be "
"resumed into; read the frame, then fix and reload, or abort\n");
" nothing here can be resumed into; read the frame, then fix "
"and reload, or abort\n");
else if (s->n == 0)
fprintf(stderr, " no restarts are active; abort, or fix and reload\n");
for (int32_t i = 0; i < s->n; i++)