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 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 — — 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. 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 if opts.sanitize then
failwith "js: --sanitize is native only"; failwith "js: --sanitize is native only";
if opts.x86 then 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); write out (Js.program ~checks:opts.checks p);
out out
end 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 _ -> with Unix.Unix_error _ ->
List.iter Unix.close [ out_r; out_w; err_r; err_w ]; List.iter Unix.close [ out_r; out_w; err_r; err_w ];
fail loc fail loc
"clang is not on PATH, and reading a C header is done by running it \ "clang is not on PATH, and reading a C header runs it (%s)"
(%s)"
(String.concat " " argv) (String.concat " " argv)
in in
Unix.close out_w; 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. *) `C-x C-e' with its case and that case's fields. *)
error error
(ty (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 else
let suffix = "/" ^ ty in let suffix = "/" ^ ty in
let candidates = let candidates =
@ -1901,7 +1901,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
if not mine then if not mine then
Error Error
(name (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 else
match find_fn t name with match find_fn t name with
| None -> | None ->
@ -1917,7 +1917,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
if nslots <> Array.length fn.Tast.slots then if nslots <> Array.length fn.Tast.slots then
Error Error
(Printf.sprintf (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)) name nslots name (Array.length fn.Tast.slots))
else if sig_ <> Emit.slot_fingerprint fn then else if sig_ <> Emit.slot_fingerprint fn then
(* The count matching is not the same as the body matching. (* 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. *) cannot be trusted are different facts. *)
Error Error
(Printf.sprintf (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) name name)
else Ok (name, fn))) else Ok (name, fn)))
@ -5086,10 +5086,9 @@ let start ?(debug = false) ?(merged = true) ?(x86 = true) ~file ~sock () =
and it is still refused. *) and it is still refused. *)
if x86 && debug then if x86 && debug then
failwith failwith
"flan dev --x86 --debug: the dev backend emits DWARF for a whole program \ "flan dev --x86 --debug: the dev backend emits no DWARF for a \
but not yet for a redefinition module, so a breakpoint set on a line \ redefinition module, so a breakpoint would stop firing at the first \
would stop firing at the first C-c C-c. Drop --x86 and --debug will \ C-c C-c. Drop --x86 to build this session with LLVM.";
build this session with LLVM, which has both.";
(* The merged daemon used to be refused here for [--x86] and no longer is, (* 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 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 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 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 ...]. (* [List.map]'s evaluation order is unspecified, and so is [let ... and ...].
Emission is all side effect — instructions, calls, branches to a [ret] — so 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. *) left-to-right is required, not a preference. Same rule as in Check. *)
@ -163,13 +176,13 @@ module Rt = struct
let field s n = let field s n =
match List.assoc_opt n (snd (layout s)) with match List.assoc_opt n (snd (layout s)) with
| Some o -> o | 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 (* The [getelementptr] index of a field, which is this backend's handle on
it — LLVM counts fields where the assembler counts bytes. *) it — LLVM counts fields where the assembler counts bytes. *)
let index s n = let index s n =
let rec go i = function 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 | (f, _) :: rest -> if String.equal f n then i else go (i + 1) rest
in in
go 0 s.fields go 0 s.fields
@ -260,7 +273,7 @@ let rec ll (t : Types.t) =
| Types.Dyn -> "i64" | Types.Dyn -> "i64"
| Types.Var _ -> | Types.Var _ ->
(* The checker rejects it by name — nothing reaches here. *) (* 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 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 -> | None ->
match Hashtbl.find_opt m.unions n with match Hashtbl.find_opt m.unions n with
| Some u -> union_lay m u | 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.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. *) (* Size, alignment, and the offset of every member. *)
and lay_fields m tys = 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. *) (* The integer kind of a given width, for the payload blob's element type. *)
and int_kind = function and int_kind = function
| 8 -> Types.I8 | 16 -> Types.I16 | 32 -> Types.I32 | 64 -> Types.I64 | 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 ──────────────────────────────────────── (* ── Per-type dyn descriptors ────────────────────────────────────────
* *
@ -774,7 +787,7 @@ let rec dty m d (t : Types.t) : int =
(String.concat ", " (String.concat ", "
(List.map (fun i -> Printf.sprintf "!%d" i) ms))); (List.map (fun i -> Printf.sprintf "!%d" i) ms)));
id 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 (* 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 fields are the runtime's C and lldb already has that type from
flan_rt.c's own debug info. *) flan_rt.c's own debug info. *)
@ -820,7 +833,7 @@ let rec dty m d (t : Types.t) : int =
runtime's own printer. *) runtime's own printer. *)
| Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned" | Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned"
| Types.Var _ -> | Types.Var _ ->
failwith ("no debug type for " ^ Types.to_string t) internal "no debug type for %s" (Types.to_string t)
in in
Hashtbl.replace d.dtys key n; Hashtbl.replace d.dtys key n;
n n
@ -2006,7 +2019,7 @@ and field_addr f (target : Tast.expr) i =
let sty = match target.Tast.ty with let sty = match target.Tast.ty with
| Types.Named n -> sname n | Types.Named n -> sname n
| Types.Option _ as t -> ll t | Types.Option _ as t -> ll t
| t -> failwith ("field of " ^ Types.to_string t) | t -> internal "field of %s" (Types.to_string t)
in in
let p = fresh f in let p = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i32 0, i32 %d" p sty base i; 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 let p = fresh f in
ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) base i64; ins f "%s = getelementptr inbounds %s, ptr %s, i64 %s" p (ll elem) base i64;
go p elem rest go p elem rest
| t -> failwith ("index into " ^ Types.to_string t)) | t -> internal "index into %s" (Types.to_string t))
in in
go (addr f target) target.Tast.ty idx 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.Pglobal n -> global_addr f n, Hashtbl.find f.md.globals n
| Tast.Pfield (target, i) -> | Tast.Pfield (target, i) ->
let sn = match target.Tast.ty with 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 in
field_addr f target i, field_ty f.md sn i field_addr f target i, field_ty f.md sn i
| Tast.Pindex (target, idx) -> element_addr f target idx | Tast.Pindex (target, idx) -> element_addr f target idx
| Tast.Pderef target -> | Tast.Pderef target ->
let t = match target.Tast.ty with 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 in
value f target, t 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 u = Hashtbl.find f.md.datas dname in
let tag = match Tast.case_index u case with let tag = match Tast.case_index u case with
| Some (i, _) -> i | Some (i, _) -> i
| None -> failwith ("no case " ^ case ^ " of " ^ dname) | None -> internal "no case %s of %s" case dname
in in
let tmp = alloca f ty in let tmp = alloca f ty in
ins f "store %s zeroinitializer, ptr %s" (ll ty) tmp; 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 = and case_field_addr f (target : Tast.expr) case i =
let dname = match target.Tast.ty with let dname = match target.Tast.ty with
| Types.Named n -> n | Types.Named n -> n
| t -> failwith ("case field of " ^ Types.to_string t) | t -> internal "case field of %s" (Types.to_string t)
in in
let base = addr f target in let base = addr f target in
let pp = payload_addr f dname base 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 match scrut.Tast.ty with
| Types.Named n when Hashtbl.mem f.md.datas n -> Some n | Types.Named n when Hashtbl.mem f.md.datas n -> Some n
| Types.Option _ -> None | Types.Option _ -> None
| t -> failwith ("match on " ^ Types.to_string t) | t -> internal "match on %s" (Types.to_string t)
in in
let tag, read_tag, bind_of = let tag, read_tag, bind_of =
match dname with match dname with
@ -2587,7 +2600,7 @@ and emit_match f ty scrut arms =
let sv = value f scrut in let sv = value f scrut in
let sty = ll scrut.Tast.ty in let sty = ll scrut.Tast.ty in
let payload_ty = match scrut.Tast.ty with 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 in
let tag = fresh f in let tag = fresh f in
ins f "%s = extractvalue %s %s, 0" tag sty sv; ins f "%s = extractvalue %s %s, 0" tag sty sv;
@ -2610,7 +2623,7 @@ and emit_match f ty scrut arms =
(fun c -> (fun c ->
match Tast.case_index u c with match Tast.case_index u c with
| Some (i, _) -> ("i32", i) | Some (i, _) -> ("i32", i)
| None -> failwith ("no case " ^ c ^ " of " ^ n)), | None -> internal "no case %s of %s" c n),
fun case i slot -> fun case i slot ->
let pp = payload_addr f n base in let pp = payload_addr f n base in
let fp = fresh f in let fp = fresh f in
@ -2619,7 +2632,7 @@ and emit_match f ty scrut arms =
let fty = let fty =
match Tast.case_index u case with match Tast.case_index u case with
| Some (_, c) -> (List.nth c.Tast.vfields i).Tast.fty | 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 in
let v = load f fp fty in let v = load f fp fty in
ins f "store %s %s, ptr %s" (ll fty) v f.slots.(slot); 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 _, Tast.Mul -> "mul"
| Types.Int k, Tast.Div -> if Types.signed k then "sdiv" else "udiv" | Types.Int k, Tast.Div -> if Types.signed k then "sdiv" else "udiv"
| Types.Int k, _ -> if Types.signed k then "srem" else "urem" | 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 in
(* A divide or a remainder by zero, and the one division that overflows, (* 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 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 (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 path. [check.ml] only ever builds [Eq]/[Ne] here: [<] and friends are
refused on a string before a Tast node exists (Types.is_comparable 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. *) bug, and stays as the same tripwire the Enum case above already is. *)
| Types.String -> | Types.String ->
let ap = fresh f in 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; r ap al bp bl;
let cc = match p with let cc = match p with
| Tast.Eq -> "ne" | Tast.Ne -> "eq" | 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 in
ins f "%s = icmp %s i8 %s, 0" t cc r 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 t
| (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ] -> | (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ] ->
let a = value f x in 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.BitAnd -> "and" | _, Tast.BitOr -> "or"
| _, Tast.BitXor -> "xor" | _, Tast.Shl -> "shl" | _, Tast.BitXor -> "xor" | _, Tast.Shl -> "shl"
| Types.Int k, _ -> if Types.signed k then "ashr" else "lshr" | 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 in
(* The count is masked to the operand's width. LLVM makes an over-wide (* 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 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 let p = fresh f in
ins f "%s = getelementptr inbounds i8, ptr %s, i64 %s" p q lo64; ins f "%s = getelementptr inbounds i8, ptr %s, i64 %s" p q lo64;
p p
| t -> failwith ("slice of " ^ Types.to_string t) | t -> internal "slice of %s" (Types.to_string t)
in in
let d = fresh f in let d = fresh f in
ins f "%s = sub i64 %s, %s" d hi64 lo64; 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.AlignOf t, [] -> Printf.sprintf "%d" (snd (lay f.md t))
| Tast.AddrOf, [ x ] -> addr_rooted f x | Tast.AddrOf, [ x ] -> addr_rooted f x
| Tast.Cast target, [ x ] -> cast f ~guard:(fun () -> guard f) x target | 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. *) (* A slice argument crosses to C as ptr+len, never as a struct by value. *)
and explode f (x : Tast.expr) = 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. *) decided the value was a bool, so the discarded bits are zero. *)
| Types.Bool, Types.Int _ -> "zext" | Types.Bool, Types.Int _ -> "zext"
| Types.Int _, Types.Bool -> "trunc" | Types.Int _, Types.Bool -> "trunc"
| _ -> failwith "unsupported cast" | _ -> internal "unsupported cast"
in in
if op = "bitcast" then v if op = "bitcast" then v
else begin 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 diagnostic, and it fires only if that refusal and [Tast.const_init] stop
agreeing about the same set. *) agreeing about the same set. *)
| _ -> | _ ->
failwith internal "no constant image for %s at %s"
("no constant image for " ^ Types.to_string e.Tast.ty ^ " at " (Types.to_string e.Tast.ty) (Loc.to_string e.Tast.loc)
^ Loc.to_string e.Tast.loc)
(* A dev build emits a [defconst] as a mutable [global]. Two things follow, and (* 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 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 void @flan_dyn_map_set(i64, i64, i64)
declare i64 @flan_dyn_map_contains(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 ; 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 ; arithmetic traps do: a dyn type error IS the type error in a dynamic
; dynamic program, and it used to print with no file and no line. [eq] never ; program, and it used to print with no file and no line. [eq] never traps,
; traps, so it has nowhere to put one. ; so it has nowhere to put one.
declare i64 @flan_dyn_add(i64, i64, ptr, i64) declare i64 @flan_dyn_add(i64, i64, ptr, i64)
declare i64 @flan_dyn_sub(i64, i64, ptr, i64) declare i64 @flan_dyn_sub(i64, i64, ptr, i64)
declare i64 @flan_dyn_mul(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 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. *) a reloadable macro module, so nothing is lost by saying so out loud. *)
if hidden && dev then if hidden && dev then
failwith internal
"Emit.program ~hidden ~dev: a dev build exports its cells so that a \ "Emit.program was given ~hidden and ~dev together, and a dev build has \
redefinition module can reach them, and hiding them would break every \ to export its cells";
reload. [hidden] is the macro module's flag and a macro module is not a \
dev build.";
let m = new_module ~checks ~dev ~known:(fun _ -> true) ~debug ~sanitize p in let m = new_module ~checks ~dev ~known:(fun _ -> true) ~debug ~sanitize p in
(* One cell per function, initialised to the function this build compiled. (* One cell per function, initialised to the function this build compiled.
Nothing has been redefined yet, so a dev build starts out behaving exactly 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 -> (fun n ->
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = n) p.Tast.fns with match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = n) p.Tast.fns with
| Some fn -> macro_thunk m fn | Some fn -> macro_thunk m fn
| None -> failwith ("no such macro: " ^ n)) | None -> internal "no such macro %s" n)
macros; macros;
finish m finish m
@ -4505,7 +4515,7 @@ let redefinition ?(checks = true) ?(dev = false) ?(debug = false)
let target name = let target name =
match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
| Some f -> f | Some f -> f
| None -> failwith (Printf.sprintf "no such function: %s" name) | None -> internal "no such function %s" name
in in
let targets = List.map target fns in let targets = List.map target fns in
(* A clause lifted out of one of these comes with it: its body may have (* 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 match f.Form.v with
| Form.List ({ Form.v = Form.Sym "quasiquote"; _ } :: _) -> | Form.List ({ Form.v = Form.Sym "quasiquote"; _ } :: _) ->
Loc.fail loc Loc.fail loc
"a quasiquote inside a quasiquote is not implemented: the reader does \ "a quasiquote inside a quasiquote is not implemented — build the \
not count nesting levels and neither does this, so the inner one has \ inner form with form-cons"
no meaning to give. Build the inner form with form-cons"
| Form.Sym s -> node loc "Sym" "s" (Form.Str s) | Form.Sym s -> node loc "Sym" "s" (Form.Str s)
| Form.Kw s -> node loc "Kw" "s" (Form.Str s) | Form.Kw s -> node loc "Kw" "s" (Form.Str s)
| Form.Int i -> node loc "Int" "i" (Form.Int i) | 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 ] List.map (fun (_, a) -> a) ring @ [ alias ]
in in
fail loc fail loc
"%s imports itself round a ring: %s. Imports have to be acyclic — a \ "%s imports itself round a ring: %s. Imports have to be acyclic, so \
definite package order is what lets a package be compiled before the \ one of these has to go"
ones that use it — so one of these imports has to go"
(snd (List.nth open_ i)) (String.concat " -> " names) (snd (List.nth open_ i)) (String.concat " -> " names)
| None -> ()); | None -> ());
match Hashtbl.find_opt seen dir' with match Hashtbl.find_opt seen dir' with
@ -1130,8 +1129,8 @@ let rec import ~seen ~open_ ~loc alias dir =
{ decls = []; csrcs = []; lflags = []; pkgs = []; macros } { decls = []; csrcs = []; lflags = []; pkgs = []; macros }
| Some (previous, _) -> | Some (previous, _) ->
fail loc fail loc
"%s is imported as %s here and as %s elsewhere; one directory is one set \ "%s is imported as %s here and as %s elsewhere — one directory takes \
of names, so the two cannot both be true" dir alias previous one alias" dir alias previous
| None -> | None ->
Hashtbl.replace seen dir' (alias, []); Hashtbl.replace seen dir' (alias, []);
let open_ = open_ @ [ (dir', alias) ] in 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 match head_name f with
| Some ("defmacro", n) when names_macro macros f -> | Some ("defmacro", n) when names_macro macros f ->
Loc.fail f.Form.loc Loc.fail f.Form.loc
"the prelude macro %s calls a macro, and a prelude macro may not: \ "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 a function instead"
call would have to be expanded by a module that does not exist \
yet. Call a function instead"
n n
| _ -> ()) | _ -> ())
forms; forms;
@ -412,8 +410,7 @@ and settle l first loc (f : Form.t) left =
if left <= 0 then if left <= 0 then
Loc.fail loc Loc.fail loc
"expanding %s did not settle after %d rounds — a macro that expands \ "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 \ into a macro call has to get smaller each time"
not"
first fuel first fuel
else begin else begin
let args = List.map (expand_form l) args in let args = List.map (expand_form l) args in
@ -450,10 +447,8 @@ let rounds ~(prelude : string list) (pending : (string * Form.t) list)
in in
if now = [] then if now = [] then
Loc.fail (snd (List.hd pending)).Form.loc Loc.fail (snd (List.hd pending)).Form.loc
"these macros call each other and none can be compiled first: %s. A \ "these macros call each other and none can be compiled first: %s. \
defmacro has to be compiled before the call it expands, so a ring \ One of them has to call a function instead"
has no order to be compiled in — one of them has to call a function \
instead"
(String.concat ", " waiting) (String.concat ", " waiting)
else else
let taken = taken @ now in 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 match f.v with
| Map _ | Vec _ -> | Map _ | Vec _ ->
fail f fail f
"%s is a destructuring pattern, and a pattern binds only in let — this \ "%s is a destructuring pattern, and this position takes a plain name. \
position takes a plain name. Take the value under a name and \ Take the value under a name and destructure it in the body"
destructure it in the body"
(Form.to_string f) (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 and with braces gone from type position there is nothing for it to be
confused with. *) confused with. *)
| Map _ -> | Map _ ->
fail f "a map type is written (Map K V), not in braces — braces in type \ fail f "a map type is written (Map K V), not in braces"
position are not a type"
| List ({ v = Sym "Fn"; _ } :: rest) -> | List ({ v = Sym "Fn"; _ } :: rest) ->
(match rest with (match rest with
| [ { v = Vec params; _ }; ret ] -> | [ { v = Vec params; _ }; ret ] ->
@ -163,10 +161,8 @@ and dyn_params which (items : Form.t list) : Ast.field list =
floc = it.loc } floc = it.loc }
| _ -> | _ ->
fail it fail it
"a %s's parameter is a bare name, and found %s. Every parameter of \ "a %s's parameter is a bare name, and found %s. Every parameter \
a generic function is dyn — there is no type to write, and a \ here is dyn, so there is no type to write"
method that wanted one could not be reached by a dispatch that \
does not know types either"
which (Form.to_string it)) which (Form.to_string it))
items items
@ -189,8 +185,7 @@ and dispatch (f : Form.t) : Ast.dispatch =
fail f fail f
"a method's dispatch value is a class's name, a keyword, a string, an \ "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 \ 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 \ does — and found %s. It is written out, not computed"
time, so it is written out rather than computed"
(Form.to_string f) (Form.to_string f)
(* ── The constraint map at the head of a defn body ────────────────────── (* ── 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 <> []) -> | _ -> rest <> []) ->
if kvs = [] then if kvs = [] then
Loc.fail loc Loc.fail loc
"an empty map literal here is discarded — the body has more after \ "an empty map literal here is discarded — did you mean {:where ...}? \
it, and its value going unused is almost always a typo for \ Write (do {} ...) if the empty map is deliberate"
{:where ...}; write (do {} ...) if the empty map is deliberate"
else else
let pred (p : Form.t) = let pred (p : Form.t) =
match p.Form.v with 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 (match args with
| { v = Kw k; _ } :: _ -> | { v = Kw k; _ } :: _ ->
fail f fail f
":%s — loop takes no label. break and continue may not leave a loop, \ ":%s — loop takes no label; break and continue may not leave a loop" k
because a loop answers with the value of its body; there is nothing \
for a label to name" k
| { v = Vec bs; _ } :: body -> mk (Ast.Loop (loop_bindings f bs, body_of body)) | { v = Vec bs; _ } :: body -> mk (Ast.Loop (loop_bindings f bs, body_of body))
| _ -> fail f "loop is (loop [name value ...] 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" | "defdata" | "defunion" | "defclass" | "defgeneric" | "defmulti"
| "defmethod" | "defenum" | "defalias" | "import" as name) -> | "defmethod" | "defenum" | "defalias" | "import" as name) ->
fail f fail f
"%s is a top-level declaration, not an expression. A quasiquoted one is \ "%s defines a name at the top level, so it cannot be used as an \
a value and a macro may answer with it; an evaluated one is not a thing \ expression here" name
anything can do" name
(* Recognised, deliberately unimplemented. Rejected rather than left to fall (* Recognised, deliberately unimplemented. Rejected rather than left to fall
through to Call, where they would parse and mean nothing. *) 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" | Sym ("find-restart" | "compute-restarts"
| "errdefer" | "errdefer"
| "await" as name) -> | "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) ────────────────────────────────────── *) (* ── field access: (.pos c) ────────────────────────────────────── *)
| Sym s when String.length s > 1 && s.[0] = '.' -> | 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. *) spelled as a constructor it is not. *)
| Kw member -> | Kw member ->
fail f fail f
":%s is not implemented as a pattern — match is over an Option here, \ ":%s is not implemented as a pattern — use cond with (= k :%s)"
and an enum member cannot be one until Ast.pattern can hold a keyword. \ member member
Use cond with (= k :%s)" member member
| List ({ v = Sym ctor; _ } :: binds) -> | List ({ v = Sym ctor; _ } :: binds) ->
List.iter no_pattern binds; List.iter no_pattern binds;
Ast.Pctor (ctor, List.map sym binds) Ast.Pctor (ctor, List.map sym binds)
@ -1315,11 +1305,9 @@ let rec decl (f : Form.t) : Ast.decl =
in in
if looks_tagged then if looks_tagged then
Loc.failk "parse/defunion-renamed" f.loc Loc.failk "parse/defunion-renamed" f.loc
"the tagged sum is defdata now — (defdata Name [(Case [field \ "defunion is C's untagged union, written (defunion Name \
Type ...]) ...]) — and defunion is C's untagged union, whose \ [member Type ...]). This reads as a tagged sum — write \
members overlay one storage: (defunion Name [member Type \ (defdata Name [(Case [field Type ...]) ...])")
...]). This reads as the tagged one, so it is refused rather \
than quietly given the other meaning")
ms; ms;
mk (Ast.Defunion (sym n, fields f ms)) mk (Ast.Defunion (sym n, fields f ms))
| _ -> fail f "defunion is (defunion Name [member Type ...])") | _ -> 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) | Sym name -> (name, s.loc)
| _ -> | _ ->
fail s fail s
"a class slot is a name. Its value is dyn and there is \ "a class slot is a name — its value is dyn, so there \
no type to write: an instance is a dyn map with a \ is no type to write. Read one with (get p :%s)"
shape tag on it, and (get p :%s) is how a slot is read"
(Form.to_string s)) (Form.to_string s))
slots)) slots))
| _ -> fail f "defclass is (defclass Name [slot ...])") | _ -> fail f "defclass is (defclass Name [slot ...])")
@ -1569,16 +1556,15 @@ let rec decl (f : Form.t) : Ast.decl =
else if explicit then else if explicit then
Loc.failk "parse/enum-value-out-of-range" loc Loc.failk "parse/enum-value-out-of-range" loc
"the member %s of %s is %Ld, which does not fit i32 — an enum's \ "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 \ members run from -2147483648 to 2147483647. Give %s a value in \
2147483647. Give %s a value in that range, or a defconst of a \ that range, or use a defconst"
wider type if the number itself is what matters"
m ename v m m ename v m
else else
Loc.failk "parse/enum-value-out-of-range" loc Loc.failk "parse/enum-value-out-of-range" loc
"the member %s of %s has no value of its own, so it \ "the member %s of %s has no value of its own, so it \
autoincrements to %Ld, which does not fit i32 — an enum's \ autoincrements to %Ld, which does not fit i32 — an enum's \
discriminant is an i32, so its members run from -2147483648 to \ members run from -2147483648 to 2147483647. Write %s's value \
2147483647. Write %s's value out, or lower the member above it" out, or lower the member above it"
m ename v m m ename v m
in in
(* Each member becomes its name, its value, whether that value was (* 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" that is not a type is the value of a dyn global"
form form form) form form form)
(* The old name of [defonce], refused by name rather than left to fall (* [defvar] is caught by name rather than left to fall through to "unknown
through to "unknown function": every program written before the rename function", because two forms answer it and a did-you-mean over one name
spells it, and the message is the migration. *) 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) -> | List ({ v = Sym "defvar"; _ } :: args) ->
(* The rest of the form is echoed back inside the two spellings, so the (* 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 answer is a line that can be pasted. That only holds for a form long
keyword has nothing to paste, and echoing it would offer enough to make a valid one: the shortest defonce is [(defonce name
[(defonce )] as the fix for [(defvar )] — a malformed old form value)], so an old form with fewer than two arguments has nothing to
answered with a malformed new one. The names alone then, which is what paste and echoing it would answer [(defvar x)] with [(defonce x)] —
there is to say about a form that named nothing. *) 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 (match args with
| [] -> | [] | [ _ ] ->
Loc.failk "parse/defvar-renamed" f.loc Loc.failk "parse/defvar-renamed" f.loc
"defvar is now called defonce — the name says what it does: it \ "there is no defvar. Did you mean defonce? \
initialises once and keeps its value across re-runs. It is \ (defonce name Type value?) initialises once and keeps its value; \
(defonce name Type value?), or (def name Type value?) if the value \ (def name Type value?) re-initialises on every re-run"
should follow the source on every re-run"
| _ -> | _ ->
let rest = String.concat " " (List.map Form.to_string args) in let rest = String.concat " " (List.map Form.to_string args) in
Loc.failk "parse/defvar-renamed" f.loc Loc.failk "parse/defvar-renamed" f.loc
"defvar is now called defonce — the name says what it does: it \ "there is no defvar. Did you mean defonce? (defonce %s) initialises \
initialises once and keeps its value across re-runs. Write (defonce \ once and keeps its value; (def %s) re-initialises on every re-run"
%s), or (def %s) if the value should follow the source on every \
re-run"
rest rest) rest rest)
| List ({ v = Sym "defconst"; _ } :: args) -> | List ({ v = Sym "defconst"; _ } :: args) ->
@ -1756,9 +1746,8 @@ let rec decl (f : Form.t) : Ast.decl =
fault to guess at. *) fault to guess at. *)
| List ({ v = Sym "do"; _ } :: _) -> | List ({ v = Sym "do"; _ } :: _) ->
fail f fail f
"a top-level (do ...) is several declarations spliced in place, and this \ "a top-level (do ...) is several declarations, and this position takes \
is a position that takes exactly one — a macro answering several is a \ exactly one"
file's form, not an expression's"
| List ({ v = Sym s; _ } :: _) -> fail f "unknown top-level form (%s ...)" s | 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) | _ -> 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. *) is not milestone 1's. *)
| Types.Dyn -> | Types.Dyn ->
[ unit_ (Tast.Prim (Tast.Rt "flan_dyn_print", [ e ])) ] [ 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 -> | 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 ) gname )
in in
fail loc fail loc
"%s changes signature, from (Fn [%s] %s) to (Fn [%s] %s); \ "%s changes signature, from (Fn [%s] %s) to (Fn [%s] %s).%s \
the calls already compiled into the running program pass the old \ Restart to change it."
one.%s Restart to change it."
what what
(String.concat " " (List.map Types.to_string g.Tast.params)) (String.concat " " (List.map Types.to_string g.Tast.params))
(Types.to_string g.Tast.ret) (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 && Types.equal g.Tast.gty h.Tast.gty
&& not (same_const g.Tast.ginit h.Tast.ginit) -> && not (same_const g.Tast.ginit h.Tast.ginit) ->
fail loc fail loc
"%s is used at compile time — an array length or a type — so the \ "%s is used at compile time, in an array length or a type. \
running program has its old value in its shape, where a reload \ Restart to change it."
cannot reach it. Restart to change it."
g.Tast.gname g.Tast.gname
| Some h when not (Types.equal g.Tast.gty h.Tast.gty) -> | Some h when not (Types.equal g.Tast.gty h.Tast.gty) ->
(* The storage exists and has a shape. Reusing it for another one (* The storage exists and has a shape. Reusing it for another one
reads fields at the wrong offsets; allocating fresh storage would reads fields at the wrong offsets; allocating fresh storage would
silently discard the state the reload exists to preserve. *) silently discard the state the reload exists to preserve. *)
fail loc fail loc
"%s changes type, from %s to %s; the running program already laid \ "%s changes type, from %s to %s. Restart to change it."
that storage out. Restart to change it."
g.Tast.gname (Types.to_string h.Tast.gty) (Types.to_string g.Tast.gty) 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 (* 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 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. *) including ones held in globals that the reload is preserving. *)
if not same then if not same then
fail loc fail loc
"%s changes layout; the values the running program is holding have \ "%s changes layout. Restart to change it."
the old one. Restart to change it."
s.Tast.sname s.Tast.sname
| None -> ()) | None -> ())
new_.Tast.structs new_.Tast.structs
@ -420,8 +416,7 @@ let compatible_enums ~loc old_ new_ =
match List.assoc_opt n before with match List.assoc_opt n before with
| Some old_ms when old_ms <> ms -> | Some old_ms when old_ms <> ms ->
fail loc fail loc
"%s changes its members; the running program folded the old values \ "%s changes its members. Restart to change it."
into every call site that names one. Restart to change it."
n n
| _ -> ()) | _ -> ())
(members new_) (members new_)
@ -504,7 +499,7 @@ let redefinition (t : t) ?retains ?call ?(consts = []) program ~fns =
refusal it belongs to, and reaches [flan reload] too. *) refusal it belongs to, and reaches [flan reload] too. *)
fail loc fail loc
"the x86 dev backend cannot compile this: %s. Restart the daemon with \ "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 ─────────────────────────────────────────── *) (* ── 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" "int32_t"
else if Hashtbl.mem env.datas n then else if Hashtbl.mem env.datas n then
fail loc fail loc
"%s is %s, a data type, and a Flan data type has no C layout — the shim \ "%s is %s, a data type, which has no C layout"
cannot be generated for it"
what n what n
(* A union is the one refusal here that is not about the type. It has a (* 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 — 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. *) way through is the way every other aggregate crosses. *)
else if Hashtbl.mem env.unions n then else if Hashtbl.mem env.unions n then
fail loc fail loc
"%s is %s, a union, and the shim generator writes structs only — a \ "%s is %s, a union, and the shim generator writes structs only. \
union has a C layout but nothing here emits the declaration for \ Pass (Ptr %s) and let the C side read it"
it yet. Pass (Ptr %s) and let the C side read it"
what n n what n n
else if String.equal n "string" then else if String.equal n "string" then
fail loc fail loc
"%s is a string, and a string only crosses as a parameter — a C \ "%s is a string, and a string only crosses as a parameter"
function that *returns* one returns something Flan has no owner for"
what what
else if String.equal n "Unit" || String.equal n "Never" then 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 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 ("Ptr", [ e ]) -> cty env ~needed ~loc ~what e ^ " *"
| Ast.Tapp ("Option", _) -> | Ast.Tapp ("Option", _) ->
fail loc fail loc
"%s is an Option, which is a Flan shape and not a C one — declare what C \ "%s is an Option, which C has no shape for — declare what C returns and \
returns and build the Option in Flan" build the Option in Flan"
what what
| Ast.Tslice _ -> | Ast.Tslice _ ->
fail loc fail loc
"%s is a slice, which crosses as ptr+len with an i64 length, and the \ "%s is a slice, and nothing here says what type the C count parameter \
count parameter the C function actually takes has a type this \ is — declare (Ptr T) with an explicit count, and pass \
declaration does not say — declare (Ptr T) with an explicit count and \ (addr (at s 0)) and (len s) from Flan"
pass (addr (at s 0)) and (len s) from Flan"
what what
| Ast.Tarray _ -> | Ast.Tarray _ ->
fail loc 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. *) elements cross the way any other run of elements does. *)
| Ast.Tapp ("Vec", _) -> | Ast.Tapp ("Vec", _) ->
fail loc fail loc
"%s is a Vec, which owns its storage — handing its header to C hands out \ "%s is a Vec, which owns its storage. Pass (slice v) as (Ptr T) and \
an owner. Pass (slice v) as (Ptr T) and (len v), the same shape a \ (len v)"
slice crosses in"
what what
| Ast.Tfn _ -> | Ast.Tfn _ ->
fail loc "%s is a function type, and a C callback is not implemented" what 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 = let blockcopy f n =
if n > 0 then begin if n > 0 then begin
note f (Printf.sprintf note f (Printf.sprintf
"rep movsb: %d bytes from rsi to rdi. An aggregate is copied rather than \ "rep movsb: %d bytes from rsi to rdi. An aggregate is copied \
aliased — spec-memory.md's assignment rule" n); rather than aliased." n);
movabs f.b ~dst:rcx (Int64.of_int n); movabs f.b ~dst:rcx (Int64.of_int n);
rep_movsb f.b rep_movsb f.b
end end
@ -2413,8 +2413,9 @@ and bounds_call f sym (loc : Loc.t) (extra : int list) =
call_sym f.b sym; call_sym f.b sym;
guard f; guard f;
note f note f
"ud2, where emit.ml writes unreachable. Nothing answered the signal, so the runtime \ "ud2, where the LLVM backend writes unreachable. Nothing answered the \
already died inside that call and nothing falls through to here."; signal, so the runtime already died inside that call and nothing falls \
through to here.";
ud2 f.b ud2 f.b
(* The length an index is checked against, or [None] for the one form (* 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 -> | Some fr ->
if ann then set_ind f.b ""; if ann then set_ind f.b "";
note f note f
"The shadow stack's push — runtime/flan_dev.c. Dev builds only, and it is what \ "The shadow stack's push. Dev builds only, and it is what lets a stopped \
lets a stopped program say where it is. The pop is the first thing in the \ program say where it is. The pop is the first thing in the epilogue, so \
epilogue, so a transfer out of this frame pops it too."; a transfer out of this frame pops it too.";
(* Every entry, not only the named ones: "null means not bound" has to (* 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 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. *) 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; jmp_lbl f.b f.retlbl;
if ann then set_ind f.b ""; if ann then set_ind f.b "";
note f note f
"The transfer exit — spec-conditions.md §5. A transfer that found no restart-case \ "The transfer exit. A transfer that found no restart-case in this frame \
in this frame leaves the way a return does, which is what runs the defers."; leaves the way a return does, which is what runs the defers.";
lbl f.b f.xfer_lbl; lbl f.b f.xfer_lbl;
(* [emit.ml] leaves here with [ret zeroinitializer]. The value is (* [emit.ml] leaves here with [ret zeroinitializer]. The value is
meaningless to a caller — its guard sees the channel set and never looks 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) { const uint8_t *want, int64_t wantlen) {
rt_flush_out(); rt_flush_out();
fprintf(stderr, fprintf(stderr,
"%.*s: restart %.*s takes %.*s, and whatever took it supplied no " "%.*s: restart %.*s takes %.*s, and none was supplied — a restart "
"arguments — a restart with parameters cannot be taken from the " "with parameters cannot be taken from the break loop yet\n",
"break loop yet\n",
(int)loclen, (const char *)loc, (int)namelen, (const char *)name, (int)loclen, (const char *)loc, (int)namelen, (const char *)name,
(int)wantlen, (const char *)want); (int)wantlen, (const char *)want);
rt_trap((const uint8_t *)"RestartUnarmed", 14); 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) { _Noreturn void flan_transfer_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out(); rt_flush_out();
fprintf(stderr, fprintf(stderr,
"%.*s: a defer invoked a restart, which a defer may not do — it is " "%.*s: a defer invoked a restart, which a defer may not do\n",
"the cleanup a transfer runs on its way out\n",
(int)loclen, (const char *)loc); (int)loclen, (const char *)loc);
rt_trap((const uint8_t *)"TransferFromDefer", 17); 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) { int64_t n) {
rt_flush_out(); rt_flush_out();
fprintf(stderr, fprintf(stderr,
"%.*s: slice-from-ptr was promised %lld elements behind the pointer, " "%.*s: slice-from-ptr was promised %lld elements behind the "
"and a count of elements is never negative\n", "pointer, and a count is never negative\n",
(int)loclen, (const char *)loc, (long long)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(); 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_DIV_OVERFLOW:
case FLAN_ARITH_REM_OVERFLOW: case FLAN_ARITH_REM_OVERFLOW:
fprintf(stderr, fprintf(stderr,
"%.*s: (%s %lld %lld) overflows: the quotient is one past the " "%.*s: (%s %lld %lld) overflows — the quotient is one past the "
"largest value the type holds, and this is the only pair of " "largest value the type holds\n",
"operands for which that is true\n",
(int)loclen, (const char *)loc, (int)loclen, (const char *)loc,
op == FLAN_ARITH_DIV_OVERFLOW ? "/" : "%", (long long)lhs, op == FLAN_ARITH_DIV_OVERFLOW ? "/" : "%", (long long)lhs,
(long long)rhs); (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) { _Noreturn void flan_free_all_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out(); rt_flush_out();
fprintf(stderr, fprintf(stderr,
"%.*s: this allocator does not offer free-all — it has no region to " "%.*s: this allocator does not offer free-all — it has no region "
"release, and releasing nothing is not the same as releasing " "to release\n",
"everything\n",
(int)loclen, (const char *)loc); (int)loclen, (const char *)loc);
rt_trap((const uint8_t *)"NoFreeAll", 9); 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) { _Noreturn void flan_region_only_fail(const uint8_t *loc, int64_t loclen) {
rt_flush_out(); rt_flush_out();
fprintf(stderr, fprintf(stderr,
"%.*s: this container's elements own storage, and this allocator can " "%.*s: this container's elements own storage, and this allocator "
"free one block — so a free here would release the slots and leak " "frees one block at a time, so freeing it here would leak what the "
"everything inside them, and nothing type-erased can walk them. " "elements hold. Build it against a region allocator: "
"Build it against a region allocator, whose free-all takes the " "(with-allocator context/temp ...) or an (arena-new n)\n",
"inner blocks too: (with-allocator context/temp ...) or an "
"(arena-new n)\n",
(int)loclen, (const char *)loc); (int)loclen, (const char *)loc);
rt_die(); 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) { _Noreturn void flan_shim_nul_fail(const char *site) {
rt_flush_out(); rt_flush_out();
fprintf(stderr, fprintf(stderr,
"%s: a string passed to C contains a NUL byte — C reads to the " "%s: a string passed to C contains a NUL byte — C reads only up "
"first one, so the value this function would act on is a prefix of " "to it. Remove the NUL before the call.\n",
"the one passed. Remove the NUL before the call.\n",
site); site);
rt_die(); rt_die();
} }

38
test/test_acceptance.ml
View File

@ -1052,7 +1052,7 @@ let () =
spellings, not one form that changes type with its context. *) spellings, not one form that changes type with its context. *)
refuses_src "embed asked for a type it cannot read a file as" refuses_src "embed asked for a type it cannot read a file as"
"(defn main [] i32 (len (embed \"no-such-asset.bin\" i32)))" "(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 (* 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 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 one branch per container, where the allocator is still a value the
site is holding. *) site is holding. *)
traps "a container of owning elements against the heap" "1" 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 (* A different mechanism, pinned separately: the epoch, and specifically
an inner header copied *out* of its container before the release. It 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 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 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. *) 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" 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 _ -> ()) (try Sys.remove exe with Sys_error _ -> ())
in in
region (); region ();
@ -2938,7 +2938,7 @@ let () =
and cannot change. *) and cannot change. *)
refuses "a package generic's bound, refused at the call" refuses "a package generic's bound, refused at the call"
"programs/pkg-generic-reject.flan" "programs/pkg-generic-reject.flan"
"string does not answer ordered?"; "string is not ordered?";
refuses "and the refusal quotes the clause the package wrote" refuses "and the refusal quotes the clause the package wrote"
"programs/pkg-generic-reject.flan" "{:where (ordered? $t)}"; "programs/pkg-generic-reject.flan" "{:where (ordered? $t)}";
@ -2971,7 +2971,7 @@ let () =
chain of instantiations and not a depth it gave up at. *) chain of instantiations and not a depth it gave up at. *)
refuses "an unconstrained operator in a generic body" refuses "an unconstrained operator in a generic body"
"programs/generic-reject.flan" "programs/generic-reject.flan"
"only what it is declared to support"; "nothing declares t numeric?";
refuses "an unconstrained operator names the way out" refuses "an unconstrained operator names the way out"
"programs/generic-reject.flan" "{:where (numeric? $t)}"; "programs/generic-reject.flan" "{:where (numeric? $t)}";
refuses "a runaway instantiation" "programs/generic-runaway.flan" 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 requirement the author wrote down. What is asserted is that it names
the type passed and the predicate it failed, and not the body. *) 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" 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" refuses "and it names the type the call site asked for"
"programs/generic-map-reject.flan" "at $t = f64"; "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" refuses "a package's main is not visible" "programs/pkg-hidden-main.flan"
"sand/main is not a name"; "sand/main is not a name";
refuses "one directory under two aliases" "programs/pkg-two-aliases.flan" 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 (* 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 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 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 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. *) directory apart, rather than side by side as in the case above. *)
refuses "one directory under two aliases, through a package" 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 (* 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 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 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 one — or anywhere to put the flan_allocator, Allocator being opaque and
pointer-width. Two reasons, both named, neither a function value. *) pointer-width. Two reasons, both named, neither a function value. *)
refuses "a user-written allocator" "programs/user-allocator.flan" 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 (* 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 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 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 storage. Refused by the shim generator, where the message can say what
to pass instead. *) to pass instead. *)
refuses "a Vec crossing to C" "programs/vec-to-c.flan" 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) ────────────────────────────── (* ── wasm32 (NEXT.md, deferred item 6) ──────────────────────────────
The second target, and the reason sand-headless imports no raylib. What 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" shim_refuses "declare-c: a slice parameter, by name and reason"
(v2 ^ "(declare-c poly [pts [Vector2]] bool \"Poly\")") (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" shim_refuses "declare-c: an Option"
(v2 ^ "(declare-c maybe [] (Option Vector2) \"Maybe\")") (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" shim_refuses "declare-c: a data type"
("(defdata Shape [(Circle [r f32]) (Square [s f32])])\n\ ("(defdata Shape [(Circle [r f32]) (Square [s f32])])\n\
(declare-c area [s Shape] f32 \"Area\")") (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" shim_refuses "declare-c: a fixed array"
"(declare-c takes [xs [4 f32]] \"Takes\")" "(declare-c takes [xs [4 f32]] \"Takes\")"
"which C passes as a pointer and Flan as a value"; "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" refuses_src "a float is not a map key"
"(defn f [m (Map f32 i32)] () 0)" "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" 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 (* 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 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 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"; "A is a case of the data type U";
refuses_src "a data type type used as a constructor" 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))" "(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" refuses_src "a case with fields written bare"
"(defdata U [(A [x i32])])\n(defn main [] i32 (let [v U.A] 0))" "(defdata U [(A [x i32])])\n(defn main [] i32 (let [v U.A] 0))"
"has fields, so it needs them"; "has fields, so it needs them";
@ -4789,7 +4789,7 @@ level "1"
refuses_src "a data type is not a map key" refuses_src "a data type is not a map key"
"(defdata U [A B])\n\ "(defdata U [A B])\n\
(defn f [m (Map U i32) k U] () (put m k 1))" (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 (* 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 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 relocation a byte array has nowhere to put. Refused in the checker since
@ -4811,7 +4811,7 @@ level "1"
incr failures; incr failures;
Printf.printf "FAIL %s\n it was accepted\n" name Printf.printf "FAIL %s\n it was accepted\n" name
| exception Loc.Error { Loc.dmsg = m; _ } -> | 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 then begin
incr failures; incr failures;
Printf.printf "FAIL %s\n said: %S\n" name m Printf.printf "FAIL %s\n said: %S\n" name m
@ -4862,12 +4862,12 @@ level "1"
assume cannot be reached. *) assume cannot be reached. *)
refuses_src "uninit on a data type global" refuses_src "uninit on a data type global"
"(defdata U [A B])\n(defonce g U uninit)\n(defn main [] i32 0)" "(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 (* 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. *) do without having read the tag first. match is how one is opened. *)
refuses_src "reading a field of a data type directly" refuses_src "reading a field of a data type directly"
"(defdata U [(A [x i32])])\n(defn f [u U] i32 (.x u))" "(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 (* 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. *) is the first declared case, all bytes zero, and needs no encoder. *)
(let name = "a zeroed data type global" in (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 (match (parse_decl "(def counter i64 (start))").d with
| Defvar ("counter", Some { t = Tname "i64"; _ }, Init _, Every) -> () | Defvar ("counter", Some { t = Tname "i64"; _ }, Init _, Every) -> ()
| _ -> check "a typed def with an initialiser" false); | _ -> check "a typed def with an initialiser" false);
(* The old name, refused with the migration in the message: what it is (* The old name, refused as a name that does not exist rather than as a
called now, why the name, and both new spellings — each of which rename: the reader has this compiler and nothing else, so what they need
compiles as written. *) 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" parse_rejects "the old defvar spelling names defonce"
"(defvar counter i64 7)" "(defvar counter i64 7)"
~needle:"defvar is now called defonce — the name says what it does: it \ ~needle:"there is no defvar. Did you mean defonce? (defonce counter i64 \
initialises once and keeps its value across re-runs. Write \ 7) initialises once and keeps its value; (def counter i64 7) \
(defonce counter i64 7), or (def counter i64 7) if the value \ re-initialises on every re-run";
should follow the source on every re-run";
(match read "(defvar counter i64 7)" |> Parse.program with (match read "(defvar counter i64 7)" |> Parse.program with
| _ -> check "the old defvar spelling has a kind" false | _ -> check "the old defvar spelling has a kind" false
| exception Loc.Error { Loc.kind; _ } -> | exception Loc.Error { Loc.kind; _ } ->
@ -542,8 +542,8 @@ let () =
malformed new one as its fix. *) malformed new one as its fix. *)
parse_rejects "the old spelling with no arguments names the shapes" parse_rejects "the old spelling with no arguments names the shapes"
"(defvar)" "(defvar)"
~needle:"It is (defonce name Type value?), or (def name Type value?) if \ ~needle:"(defonce name Type value?) initialises once and keeps its \
the value should follow the source on every re-run"; value; (def name Type value?) re-initialises on every re-run";
(match (parse_decl "(import rl \"vendor:raylib\")").d with (match (parse_decl "(import rl \"vendor:raylib\")").d with
| Import ("rl", "vendor:raylib") -> () | _ -> check "import" false); | Import ("rl", "vendor:raylib") -> () | _ -> check "import" false);
@ -598,7 +598,7 @@ let () =
parse_rejects "defmacro with a non-name param" "(defmacro m [1] x)" parse_rejects "defmacro with a non-name param" "(defmacro m [1] x)"
~needle:"a macro's parameter is a name or a [ ] pattern"; ~needle:"a macro's parameter is a name or a [ ] pattern";
parse_rejects "defmacro in expression position" "(defn f [] () (defmacro m [] 1))" 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 (* 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 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. *) which of the two it means instead of being quietly given one of them. *)
parse_rejects "the old defunion spelling" parse_rejects "the old defunion spelling"
"(defunion Shape [(Circle [r f32]) (Square [s f32])])" "(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 (* 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 member of a type. Same refusal, and this is the one that matters — it
would have compiled. *) would have compiled. *)
parse_rejects "the old defunion spelling with payload-less cases" parse_rejects "the old defunion spelling with payload-less cases"
"(defunion U [A B])" "(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 (match read "(defunion U [A B])" |> Parse.program with
| _ -> check "the old spelling has a kind" false | _ -> check "the old spelling has a kind" false
| exception Loc.Error { Loc.kind; _ } -> | exception Loc.Error { Loc.kind; _ } ->
@ -730,7 +730,7 @@ let () =
~needle:"the member B of E is 4294967296, which does not fit i32"; ~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" parse_rejects "the out-of-range refusal says what the range is"
"(defenum E [A 0 B 4294967296])" "(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 (* Nothing in the source wrote 2147483648, so the sentence has to say where
it came from before it can say it is wrong. *) it came from before it can say it is wrong. *)
parse_rejects "an autoincrement off the top of i32" parse_rejects "an autoincrement off the top of i32"
@ -1347,7 +1347,7 @@ let () =
accepts "all-distinct over a type variable" accepts "all-distinct over a type variable"
"(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))"; "(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))";
rejects_check "a chain still wants the right predicate" 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))"; "(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 (* One operand and none. Both would have to be [true] whatever they were
handed, which is a typo carrying a value. *) handed, which is a typo carrying a value. *)
@ -1564,6 +1564,15 @@ let () =
accepts "a dyn in a condition's payload" accepts "a dyn in a condition's payload"
"(defstruct Boom [what dyn])\n\ "(defstruct Boom [what dyn])\n\
(defn main [] () (signal (Boom {.what 1})))"; (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 (* 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 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. *) 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. *) written in, which is what the acceptance program sorts. *)
rejects_check "slice of a returned array" rejects_check "slice of a returned array"
"(defn mk [] [3 i32] [7 8 9]) (defn f [] [i32] (slice (mk)))" "(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" rejects_check "slice of a returned array, three arguments"
"(defn mk [] [3 i32] [7 8 9]) (defn f [] [i32] (slice (mk) 0 3))" "(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" accepts "slice of an array literal"
"(defn f [] [i32] (slice [7 8 9]))"; "(defn f [] [i32] (slice [7 8 9]))";
(* One builtin, one answer about a bound. A slice bound is a subscript and (* One builtin, one answer about a bound. A slice bound is a subscript and
@ -2166,7 +2175,7 @@ let () =
store. *) store. *)
rejects_check "the address of a string's byte" rejects_check "the address of a string's byte"
"(defn f [s string] (Ptr u8) (addr (at s 0)))" "(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 (* And a string is still not a [u8]: slicing one does not smuggle a byte
slice out of it. *) slice out of it. *)
rejects_check "a string slice is not a byte slice" rejects_check "a string slice is not a byte slice"
@ -2325,11 +2334,10 @@ let () =
accepts "a local is assignable" accepts "a local is assignable"
"(defn f [] i32 (let [x 1] (set x 2) x))"; "(defn f [] i32 (let [x 1] (set x 2) x))";
rejects_check "a parameter is not assignable" 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" rejects_check "a constant is not assignable"
"(defconst k 1) (defn f [] () (set k 2))" "(defconst k 1) (defn f [] () (set k 2))"
~needle:"k is a constant, and a constant is not assignable — it is \ ~needle:"k is a constant, and a constant is not assignable. \
written into the image and there is nothing to assign to. \
Declare it with defonce if it has to change"; Declare it with defonce if it has to change";
accepts "addr of a local gives a pointer" accepts "addr of a local gives a pointer"
(cursor ^ "(defn g [c (Ptr Cursor)] i32 (.pos c)) \ (cursor ^ "(defn g [c (Ptr Cursor)] i32 (.pos c)) \
@ -2651,7 +2659,7 @@ let () =
rejects_check "a dispatch value is written out, not computed" rejects_check "a dispatch value is written out, not computed"
"(defmulti d [x] dyn x)\n(defmethod d (f 1) [x] 1)\n\ "(defmulti d [x] dyn x)\n(defmethod d (f 1) [x] 1)\n\
(defn main [] i32 0)" (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 (* 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 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 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)] ())" rejects_check "Map takes two types" "(defn f [x (Map i32)] ())"
~needle:"exactly two types"; ~needle:"exactly two types";
rejects_check "Result is milestone 6" "(defn f [] (Result i32 i32) None)" 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 region rule, spec-memory.md's arena rule ────────────────────
The compile-time half of it, which is the only half a checker row can 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" rejects_check "free on a container of owning elements"
"(defdata V [Nil (L [xs (Vec V)])])\n\ "(defdata V [Nil (L [xs (Vec V)])])\n\
(defn f [v (Vec V)] () (free v))" (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 (* clone is refused for a reason the region does *not* dissolve: it promises
an independent copy and a bytewise one is an alias. *) an independent copy and a bytewise one is an alias. *)
rejects_check "clone on a container of owning elements" rejects_check "clone on a container of owning elements"
@ -2747,12 +2755,12 @@ let () =
"(defonce g (Vec u8) (slurp \"game-data.edn\")) (defn f [] ())"; "(defonce g (Vec u8) (slurp \"game-data.edn\")) (defn f [] ())";
rejects_check "a move-only global as a defconst" rejects_check "a move-only global as a defconst"
"(defconst g (Vec u8) (slurp \"game-data.edn\")) (defn f [] ())" "(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 (* uninit is the one initialiser a container still refuses, and it is a
different rule: a garbage block pointer is not a garbage number. *) different rule: a garbage block pointer is not a garbage number. *)
rejects_check "a global Vec declared uninit" rejects_check "a global Vec declared uninit"
"(defonce g (Vec u8) uninit) (defn f [] ())" "(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 ───────────────────────────── (* ── What may be filled with raw bytes ─────────────────────────────
[(filled b)] and [(dead-beef)] are [zeroed]'s siblings, and the [(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"; ~needle:"with no handler-bind or restart-case around it";
rejects_check "an invoke-restart in a global initialiser" rejects_check "an invoke-restart in a global initialiser"
"(defonce w i64 (do (invoke-restart 'retry) 1))\n(defn f [] i64 w)" "(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 (* 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 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. *) [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) \ (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)))"; (println (len (slice g))) (let [c (clone g)] (free c)))";
rejects_check "try is milestone 6" "(defn f [] i32 (try 1))" 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 (* 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 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 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 (* Where the "refuse mutual recursion by name" answer lives: there are no
tail calls, so a function cannot recur into itself either. *) tail calls, so a function cannot recur into itself either. *)
rejects_check "recur outside a loop" 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" rejects_check "recur with the wrong number of values"
"(defn f [] i32 (loop [i 0 j 1] (recur 1)))" "(defn f [] i32 (loop [i 0 j 1] (recur 1)))"
~needle:"binds 2 names and this recur passes 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" accepts "a while inside a loop keeps its own break"
"(defn f [] () (loop [i 0] (while true (break))))"; "(defn f [] () (loop [i 0] (while true (break))))";
rejects_check "break may not leave a loop" 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" rejects_check "a labelled break may not leave a loop"
"(defn f [] () (while :o true (loop [i 0] (break :o))))" "(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" accepts "a while condition is an ordinary expression"
"(defn f [] () (let [v (vec-new i32) n 0] \ "(defn f [] () (let [v (vec-new i32) n 0] \
(while (and (< n 10) (> (len v) 0)) (set n (+ n 1))) (free v)))"; (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" rejects_check "a data type case nested in a constant struct"
"(defdata U [A (B [x i32])]) (defstruct S [u U]) \ "(defdata U [A (B [x i32])]) (defstruct S [u U]) \
(defconst g S (S {.u (U.B {.x 1})}))" (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" accepts "a constant written as a literal"
"(defconst x u64 0xcbf29ce484222325)"; "(defconst x u64 0xcbf29ce484222325)";
accepts "a constant written as arithmetic over other constants" 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)])))"); (boom ^ "(defn f [] i32 (let [n 1] (handler-case 0 [(Boom [c] n)])))");
rejects_check "a handler-bind clause still cannot" rejects_check "a handler-bind clause still cannot"
(boom ^ "(defn f [] i32 (let [n 1] (handler-bind [(Boom [c] (set n 2))] 0)))") (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 (* Nothing static refuses a condition no clause lists: it installs no frame
that matches, so it goes past untouched and the body carries on. *) that matches, so it goes past untouched and the body carries on. *)
accepts "a condition no clause lists" accepts "a condition no clause lists"
@ -3933,10 +3941,10 @@ let () =
be one that kills the program instead. *) be one that kills the program instead. *)
rejects_check "an array pattern over a slice" rejects_check "an array pattern over a slice"
"(defn f [s [i32]] i32 (let [[a b] s] (+ a b)))" "(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" rejects_check "an array pattern over a slice, even with & rest"
"(defn f [s [i32]] i32 (let [[a & r] s] (+ a (len r))))" "(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" rejects_check "an array pattern over something with no elements at all"
"(defn f [n i32] i32 (let [[a b] n] (+ a b)))" "(defn f [n i32] i32 (let [[a b] n] (+ a b)))"
~needle:"i32 is not a fixed array"; ~needle:"i32 is not a fixed array";
@ -3966,7 +3974,7 @@ let () =
List.iter List.iter
(fun (what, src) -> (fun (what, src) ->
rejects_check ("a pattern in " ^ 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 defn parameter", pt ^ "(defn f [{:keys [x]} Point] i32 x)";
"a defstruct field", "(defstruct S [[a b] i32])"; "a defstruct field", "(defstruct S [[a b] i32])";
"an fn parameter", "(defn f [] i32 (let [g (fn [[a b]] a)] 0))"; "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" rejects_check "a pattern inside a match arm's binds"
"(defstruct P [x i32])\n\ "(defstruct P [x i32])\n\
(defn f [o (Option P)] i32 (match o (Some {:keys [x]}) x None 0))" (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 (* The desugaring's own machinery is unspellable: the reader makes [~] a
delimiter, so the name never reaches the parser as one symbol. *) delimiter, so the name never reaches the parser as one symbol. *)
@ -4054,11 +4062,11 @@ let () =
rejects_check "a data type member" rejects_check "a data type member"
"(defdata D [A (B [x i32])])\n\ "(defdata D [A (B [x i32])])\n\
(defunion U [d D n i64])\n(defn f [u U] i32 0)" (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" rejects_check "a data type inside a struct member"
"(defdata D [A B])\n(defstruct S [d D n i32])\n\ "(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)" (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 (* 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 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 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" rejects_check "a union literal giving two members"
"(defunion U [i i32 f f32])\n\ "(defunion U [i i32 f f32])\n\
(defn f [] i32 (let [u (U {.i 1 .f 2.0})] (.i u)))" (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" 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)))" "(defunion U [i i32])\n(defn f [] i32 (let [u (U {.z 1})] (.i u)))"
~needle:"U has no member z"; ~needle:"U has no member z";
@ -4091,7 +4099,7 @@ let () =
rejects_check "match on a union" rejects_check "match on a union"
"(defunion U [i i32 f f32])\n\ "(defunion U [i i32 f f32])\n\
(defn f [u U] i32 (match u _ 0))" (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 (* A member narrower than the union leaves the rest indeterminate, so two
values that agree about everything anybody wrote would hash apart. *) values that agree about everything anybody wrote would hash apart. *)
rejects_check "a union as a map key" 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); (d.Loc.kind = "check/shortcircuit-operand" && d.Loc.dloc.Loc.col = 39);
check "and states what the two answers are" check "and states what the two answers are"
(contains d.Loc.dmsg (contains d.Loc.dmsg
"an and answers false when it stops early and its last operand \ "an and answers false or its last operand, so the two have to \
otherwise, so the two have to be one type — this operand is (Vec \ be one type — this operand is (Vec i32), and false is a bool")
i32), and false is a bool")
| None -> check "a mistyped and operand is refused" false); | None -> check "a mistyped and operand is refused" false);
(* The reader's own two-place error. The bracket that is open is the error (* The reader's own two-place error. The bracket that is open is the error
@ -5461,7 +5468,7 @@ let () =
accepts "numeric? admits +" accepts "numeric? admits +"
"(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))"; "(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))";
rejects_check "equal? does not admit <" 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))"; "(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))";
(* The entailments, which are the reason a signature is one predicate long (* 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, rather than two. Every type the language orders is a number or an enum,
@ -5489,10 +5496,10 @@ let () =
accepts "integer? admits the shifts" accepts "integer? admits the shifts"
"(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))"; "(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))";
rejects_check "numeric? does not admit bit-and" 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))"; "(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))";
rejects_check "nor the shifts" 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))"; "(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))";
(* An integer?-bounded caller satisfies a numeric?-bounded callee: the (* An integer?-bounded caller satisfies a numeric?-bounded callee: the
entailment carries across generic calls exactly as ordered?-over-equal? 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))"; "(defn bump [x $t] $t {:where (integer? $t)} (+ x 300))";
(* A float at integer?, refused at the call that asked, naming the bound. *) (* A float at integer?, refused at the call that asked, naming the bound. *)
rejects_check "a float does not instantiate an integer?-bounded variable" 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 bump [x $t] $t {:where (integer? $t)} (+ x 1))\n\
(defn main [] () (println (bump 1.5)))"; (defn main [] () (println (bump 1.5)))";
(* And dyn is refused by the bound too — the clause's own refusal, the more (* And dyn is refused by the bound too — the clause's own refusal, the more
specific of the two answers, exactly as at numeric?. *) specific of the two answers, exactly as at numeric?. *)
rejects_check "dyn does not instantiate an integer?-bounded variable" 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\ "(defn bump [x $t] $t {:where (integer? $t)} (+ x 1))\n\
(defonce d dyn 5)\n\ (defonce d dyn 5)\n\
(defn main [] () (println (bump d)))"; (defn main [] () (println (bump d)))";
@ -5623,7 +5630,7 @@ let () =
"(defn same [a $t b $t] bool {:where (equal? $t)} (= a b)) \ "(defn same [a $t b $t] bool {:where (equal? $t)} (= a b)) \
(defn f [] bool (same \"a\" \"b\"))"; (defn f [] bool (same \"a\" \"b\"))";
rejects_check "ordered? $t instantiated at string" 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 less [a $t b $t] bool {:where (ordered? $t)} (< a b)) \
(defn f [] bool (less \"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 it and the call site, or the refusal moves into code the caller did not
write. *) write. *)
rejects_check "a predicate is not carried through a generic call" 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))"; "(defn outer [s [$t]] () {:where (equal? $t)} (sort s))";
accepts "and is accepted when it is" accepts "and is accepted when it is"
"(defn outer [s [$t]] () {:where (ordered? $t)} (sort s))"; "(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 nor i64 holds every value of the other, and inventing a third type
would be picking one neither argument was written at. *) would be picking one neither argument was written at. *)
rejects_check "u64 and i64 meet at no type" 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\ "(defn eq2? [a $t b $t] bool {:where (equal? $t)} (= a b))\n\
(defonce u u64 3)\n(defonce i i64 3)\n\ (defonce u u64 3)\n(defonce i i64 3)\n\
(defn main [] () (println (eq2? u i)))"; (defn main [] () (println (eq2? u i)))";
@ -5882,10 +5889,10 @@ let () =
instantiation at which it means nothing — and the refusal below is what instantiation at which it means nothing — and the refusal below is what
stops that reaching the call site. *) stops that reaching the call site. *)
rejects_check "an unconstrained type variable admits no literal" 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))"; "(defn f [x $t] bool (> x 0))";
rejects_check "and ordered? is not the bound that admits one" 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))"; "(defn f [x $t] bool {:where (ordered? $t)} (> x 0))";
(* The asymmetry, and it is the concrete arms' asymmetry rather than a new (* 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 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 name defonce", which is why the reason asserted here was empty; now
that an expression expands, a macro can produce one, and the head that an expression expands, a macro can produce one, and the head
says what it is wherever it appears. *) 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))" 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"; refuses "an unknown name" "no-such-name" "unknown name";
(* [defmacro] is in that same head list, and it is the shape that stays (* [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 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 about an unknown function. C-c C-c is where a declaration goes, which
is the case below. *) is the case below. *)
refuses "a defmacro at C-x C-e" "(defmacro m [& args] args)" 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 (* And the session is untouched by all of it: an evaluation is not a
declaration, so nothing named eval/N accumulates in the program. *) 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 (match Session.eval_expr ~origin:"programs/pkg-macro.flan" tm "(defn f [] i32 1)" with
| _ -> fail "a declaration was accepted as an expression" | _ -> fail "a declaration was accepted as an expression"
| exception Loc.Error { Loc.dmsg = m; _ } -> | 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); 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 (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" | _ -> fail "a nested declaration was accepted as an expression"
| exception Loc.Error { Loc.dmsg = m; _ } -> | 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); fail "a nested declaration as an expression said %S" m);
(* The two non-termination refusals. They matter more here than in a build: (* 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. */ * describing two different programs. */
if (!s->resumable) if (!s->resumable)
fprintf(stderr, fprintf(stderr,
" this trap has no transfer channel, so nothing here can be " " nothing here can be resumed into; read the frame, then fix "
"resumed into; read the frame, then fix and reload, or abort\n"); "and reload, or abort\n");
else if (s->n == 0) else if (s->n == 0)
fprintf(stderr, " no restarts are active; abort, or fix and reload\n"); fprintf(stderr, " no restarts are active; abort, or fix and reload\n");
for (int32_t i = 0; i < s->n; i++) for (int32_t i = 0; i < s->n; i++)