JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/test/test_flan.ml

8289 lines
442 KiB
OCaml
Raw Blame History

(* Reader tests. Plain assertions, no test framework — another dependency that
would have to be reimplemented if the compiler is ever self-hosted. *)
open Flan
(* The watchdog first: a hang is the one failure mode that reports
nothing at all. See watchdog.ml. *)
let () = Watchdog.arm ~seconds:600 "test_flan"
let failures = Test_support.failures
let check name cond =
if not cond then begin
incr failures;
Printf.printf "FAIL %s\n" name
end
let contains = Test_support.contains
(* Every read in this table runs under a five-second alarm. The reader is the
one part of the compiler whose mistakes loop rather than raise — a branch
that forgets to advance reads the same character for ever — and a hanging
case reports nothing at all. Five seconds is thousands of times what any
row here needs; what it buys is that a loop becomes a named failing row and
the rest of the table still runs. *)
(* Once one read has not returned, the reader is looping and every row after
it would spend the same five seconds proving the same thing — a hundred
rows is eight minutes of that. So the first timeout wedges the rest: they
fail immediately and the binary still reports, which is the whole point of
the alarm. *)
let wedged = ref false
let guarded seconds f =
if !wedged then raise Watchdog.Timeout
else
match Watchdog.within seconds f with
| x -> x
| exception Watchdog.Timeout -> wedged := true; raise Watchdog.Timeout
let read ?(file = "<test>") src =
guarded 5 (fun () -> Reader.read_all ~file src)
(* The corpus files, which are larger and are read from disk. *)
let read_file path = guarded 30 (fun () -> Reader.read_file path)
let reads name src expected =
match read src with
| forms ->
let got = String.concat " " (List.map Form.to_string forms) in
if got <> expected then begin
incr failures;
Printf.printf "FAIL %s\n src: %s\n got: %s\n wanted: %s\n"
name src got expected
end
| exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
incr failures;
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
name src (Loc.to_string loc) msg
| exception Watchdog.Timeout ->
incr failures;
Printf.printf "FAIL %s\n src: %s\n the reader did not return\n"
name src
(* [needle] is the point: a read error that fires for the wrong reason is not
the test passing. Without it "backtick at end of input" would be green even
if the backtick were still an ordinary symbol character. *)
let rejects ?needle name src =
match read src with
| _ -> incr failures; Printf.printf "FAIL %s: expected a read error\n" name
| exception Watchdog.Timeout ->
incr failures;
Printf.printf "FAIL %s: the reader did not return\n" name
| exception Loc.Error { Loc.dmsg = msg; _ } ->
(match needle with
| Some n when not (contains msg n) ->
incr failures;
Printf.printf "FAIL %s\n error: %s\n wanted: ...%s...\n" name msg n
| _ -> ())
let () =
(* ── Atoms ─────────────────────────────────────────────────────── *)
reads "integer" "42" "42";
reads "negative" "-1" "-1";
(* A sign is part of the number, both ways. [+5] is the one that reads as a
symbol the moment the '+' case is dropped from the dispatch, and a symbol
named "+5" is an unknown name much later and somewhere else. *)
reads "leading plus" "+5" "5";
reads "plus float" "+0.5" "0.5";
reads "plus in a call" "(f +5 -5)" "(f 5 -5)";
(* And the operator is still itself: [+] alone is the addition symbol, and
[(+ 1 2)] must not read its head as a number. *)
reads "bare plus" "+" "+";
reads "float" "0.05" "0.05";
reads "hex" "0xE6B800FF" "3870818559";
(* A decimal between 2^63 and 2^64 is its bit pattern, as hex is; one past
2^64, or a negative one past the smallest i64, is still malformed. *)
reads "u64 decimal" "18446744073709551615" "18446744073709551615";
reads "hex top bit" "0xFFFFFFFFFFFFFFFF" "0xFFFFFFFFFFFFFFFF";
rejects "decimal past 2^64" "18446744073709551616"
~needle:"malformed integer literal";
rejects "negative decimal past i64" "-9223372036854775809"
~needle:"malformed integer literal";
reads "string" "\"SAND\"" "\"SAND\"";
reads "symbol" "empty-at?" "empty-at?";
reads "qualified" "rl/draw-fps" "rl/draw-fps";
reads "field access" ".pos" ".pos";
reads "operator" "->>" "->>";
reads "bare minus" "-" "-";
reads "keyword" ":space" ":space";
reads "else keyword" ":else" ":else";
(* Byte literals, as used by calc-me's tokenizer. *)
reads "byte named" "\\space" "\\space";
reads "byte digit" "\\0" "\\0";
reads "byte paren" "\\(" "\\(";
reads "char by \\uXXXX" "\\u0041" "\\A";
reads "control char" "\\u0007" "\\u0007";
reads "char named" "\\backspace" "\\backspace";
reads "non-ASCII char" "\\日" "\\日";
reads "byte dot" "\\." "\\.";
(* ── Sequences ─────────────────────────────────────────────────── *)
reads "list" "(+ 1 2)" "(+ 1 2)";
reads "vector" "[1 2 3]" "[1 2 3]";
reads "map literal" "{.src src .pos 0}" "{.src src .pos 0}";
reads "type notation" "[4 f32]" "[4 f32]";
reads "nested type" "[rows [cols u32]]" "[rows [cols u32]]";
reads "commas as space" "[1, 2, 3]" "[1 2 3]";
reads "nested" "(a (b [c {.d e}]))" "(a (b [c {.d e}]))";
(* ── Trivia ────────────────────────────────────────────────────── *)
reads "line comment" "; nope\n42" "42";
reads "trailing comment" "42 ; nope" "42";
reads "banner comment" ";;;; header\n(f)" "(f)";
reads "multiple forms" "(a) (b)" "(a) (b)";
reads "empty source" "" "";
reads "only comments" "; nothing here" "";
(* ── Quote ─────────────────────────────────────────────────────── *)
(* Restart names are quoted symbols. Before this existed, 'skip-form read as
a symbol *named* "'skip-form", which is silently a different symbol from
skip-form and nothing would ever have reported it. *)
reads "quote symbol" "'skip-form" "(quote skip-form)";
reads "quote in call" "(invoke-restart 'use-placeholder)"
"(invoke-restart (quote use-placeholder))";
reads "quote list" "'(a b)" "(quote (a b))";
(* ── Quasiquote ────────────────────────────────────────────────── *)
(* The bug this closes: a backtick was an ordinary symbol character, so
`(a b) came back as the unknown name "`" — the apostrophe's old failure
mode, still open one sigil over. Clojure's ` ~ ~@ rather than Common
Lisp's ` , ,@ because a comma is whitespace here and every binding vector
depends on that. *)
reads "quasiquote list" "`(a b)" "(quasiquote (a b))";
reads "unquote" "`(a ~b)" "(quasiquote (a (unquote b)))";
reads "unquote-splicing" "`(a ~@bs)" "(quasiquote (a (unquote-splicing bs)))";
reads "unquote a call" "`(+ ~(f x) 1)"
"(quasiquote (+ (unquote (f x)) 1))";
(* Nesting: the reader does not count levels, it just wraps again. Which
level an unquote belongs to is the expander's problem, not the reader's. *)
reads "nested quasiquote" "`(a `(b ~c))"
"(quasiquote (a (quasiquote (b (unquote c)))))";
(* An unquote outside any quasiquote still reads. It has to: the reader is
dumb and has no idea where it is. Parse refuses it — see the parse tests. *)
reads "unquote alone" "~x" "(unquote x)";
reads "splice alone" "~@x" "(unquote-splicing x)";
(* A quote inside a quasiquote stays a quote; the two sigils do not merge. *)
reads "quote in quasi" "`(a 'b)" "(quasiquote (a (quote b)))";
(* The delimiter half of the fix: without it ~x is one symbol named "~x". *)
reads "tilde ends a name" "(f a~b)" "(f a (unquote b))";
reads "backtick ends a name" "(f a`b)" "(f a (quasiquote b))";
reads "backtick in vec" "[`a ~b]" "[(quasiquote a) (unquote b)]";
(* ── Discard ───────────────────────────────────────────────────── *)
(* [#_] reads the next form and throws it away, so commenting out a form does
not mean counting its closing parens. Clojure's spelling and Clojure's
semantics, including the repeated form. *)
reads "discard in a call" "(f #_a b)" "(f b)";
reads "discard the last" "(f a #_b)" "(f a)";
reads "discard the first" "(#_f g a)" "(g a)";
reads "discard a list" "(f #_(g x) b)" "(f b)";
reads "discard in a vector" "[a #_b c]" "[a c]";
reads "discard in a map" "{:a 1 #_:b #_2 :c 3}" "{:a 1 :c 3}";
(* Two discards drop two forms, and that is the recursion rather than a
count: the outer discard reads one form, and the form it reads is itself a
discard that returns the one after. *)
reads "two discards" "(f #_#_a b c)" "(f c)";
reads "three discards" "(f #_#_#_a b c d)" "(f d)";
(* Every position a form can appear in. *)
reads "discard at top level" "#_(defn a [] () 1) (defn b [] () 2)" "(defn b [] () 2)";
reads "discard a whole file" "#_(defn a [] () 1)" "";
reads "discard before quote" "(f #_a 'b)" "(f (quote b))";
reads "discard of a quote" "(f #_'a b)" "(f b)";
(* Nested, which the recursive read gives for free. *)
reads "discard inside a discarded form" "(f #_(g #_h i) j)" "(f j)";
(* A name may still contain '#' — it is only a discard at the start of a
form, after trivia. *)
reads "hash inside a name" "(f a#_b)" "(f a#_b)";
(* Nothing to discard is an error, not a silent nothing. *)
rejects ~needle:"end of input" "discard at end of input" "(f a #_";
rejects ~needle:"unbalanced" "discard of a closing paren" "(f a #_)";
(* The whole class: no reader-significant character may end up inside a name. *)
let rec bad_names f =
let open Form in
match f.v with
| Sym s | Kw s ->
if String.exists (fun c -> c = '\'' || c = '^' || c = '`' || c = '~') s
then [ s ] else []
| List l | Vec l | Map l -> List.concat_map bad_names l
| _ -> []
in
let corpus =
"(invoke-restart 'skip-form) (a 'b [c 'd] {.e 'f}) '(g 'h) \
`(i ~j ~@k) `(l `(m ~n)) [`o ~p] {.q `r} (f a~b x`y)"
in
check "no sigils leak into names"
(bad_names (Form.make (Form.List (read corpus))
Loc.unknown) = []);
(* ── Errors ────────────────────────────────────────────────────── *)
rejects "unclosed list" "(f x";
rejects "unbalanced close" ")";
rejects "mismatched" "(f x]";
rejects "unterminated str" "\"abc";
rejects "empty keyword" ":";
rejects "unknown char" "\\bogus";
(* An escape the reader does not know is a typo, not a character: accepting
\q as 'q' silently reads a different string than the one that was
written, and nothing downstream can tell. *)
rejects "unknown string escape" "\"a\\qb\"" ~needle:"unknown string escape";
(* The escapes it does know still decode, which is what says the rejection
above rejects the unknown one and not escaping itself. Asserted on the
string's bytes rather than through [Form.to_string], which escapes them
again and would compare the source with itself. *)
(match read "\"a\\nb\\tc\\\\d\\\"e\\0f\"" with
| [ { Form.v = Form.Str s; _ } ] ->
check "known escapes" (s = "a\nb\tc\\d\"e\000f")
| _ -> check "known escapes: one string" false);
rejects "metadata" "^:async";
rejects "dangling quote" "'";
(* Each of these asserts the reason, not merely that something failed. *)
rejects "backtick at end" "`" ~needle:"unexpected end of input";
rejects "tilde at end" "~" ~needle:"unexpected end of input";
rejects "splice at end" "~@" ~needle:"unexpected end of input";
rejects "quasiquote unclosed" "`(a b" ~needle:"unclosed";
(* ── Locations ─────────────────────────────────────────────────── *)
(match read ~file:"f.flan" "(a)\n (b)" with
| [ a; b ] ->
check "loc line 1" (a.loc.line = 1 && a.loc.col = 1);
check "loc line 2" (b.loc.line = 2 && b.loc.col = 3);
check "loc file" (a.loc.file = "f.flan")
| _ -> check "loc: two forms" false);
(match read ~file:"f.flan" "(f\n bad" with
| _ -> check "unclosed reports opening loc" false
| exception Loc.Error { Loc.dloc = loc; _ } ->
check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1));
(* ── Spans ─────────────────────────────────────────────────────
A location ends where the form ends, which is what an underline needs
and what a column number cannot give. Asserted on the width rather than
on the end column alone: a span that never got widened is zero wide, and
that is the failure mode worth catching — the field would exist, nothing
would fill it, and every squiggle would be one character long. *)
(match read ~file:"f.flan" "(foo bar)" with
| [ l ] ->
check "span covers the list" (Loc.width l.loc = Some 9);
(match l.Form.v with
| Form.List [ head; arg ] ->
check "span covers the head symbol" (Loc.width head.loc = Some 3);
check "span covers the argument" (Loc.width arg.loc = Some 3);
check "span starts at the symbol" (arg.loc.col = 6)
| _ -> check "span: two elements" false)
| _ -> check "span: one form" false);
(match read ~file:"f.flan" "\"hi\" 42 :kw" with
| [ s; n; k ] ->
check "span covers a string with its quotes" (Loc.width s.loc = Some 4);
check "span covers a number" (Loc.width n.loc = Some 2);
check "span covers a keyword with its colon" (Loc.width k.loc = Some 3)
| _ -> check "span: three atoms" false);
(* A form that runs over a line end has no width on its first line, and says
so rather than reporting a negative one. *)
(match read ~file:"f.flan" "(a\n b)" with
| [ l ] ->
check "multi-line span is flagged" (Loc.multiline l.loc);
check "multi-line span has no single-line width" (Loc.width l.loc = None)
| _ -> check "span: one multi-line form" false);
Test_support.report ~label:"reader" ()
(* ═══ Parse: forms → AST ═══════════════════════════════════════════ *)
let parse1 src =
match read src with
| [ f ] -> Parse.expr f
| _ -> failwith "test source must be exactly one form"
let parse_decl src =
match read src with
| [ f ] -> Parse.decl f
| _ -> failwith "test source must be exactly one form"
(* [needle] again: the house rule is that an unimplemented form is refused by
name with the reason, so a test that only proves *something* failed does not
observe the rule it is there for. *)
let parse_rejects ?needle name src =
match read src |> Parse.program with
| _ -> incr failures; Printf.printf "FAIL %s: expected a parse error\n" name
| exception Loc.Error { Loc.dmsg = msg; _ } ->
(match needle with
| Some n when not (contains msg n) ->
incr failures;
Printf.printf "FAIL %s: wrong reason\n wanted: %s\n got: %s\n"
name n msg
| _ -> ())
let () =
let open Ast in
(* ── Sugar is desugared, not preserved ─────────────────────────── *)
(match (parse1 "(when c a b)").e with
| If (_, { e = Do [ _; _ ]; _ }, None) -> ()
| _ -> check "when -> if+do" false);
(* An empty body is the same [Do []] that [(do)] already is, and not a
refusal. (when test) is a guard whose consequent has not been written yet
-- a state a program passes through while it is being written -- and
refusing it bought nothing that the empty [do] does not already allow.
[unless] in the prelude took the same change; it is a macro now, so it is
asserted in programs/prelude-macros.flan instead of here. *)
(match (parse1 "(when c)").e with
| If (_, { e = Do []; _ }, None) -> ()
| _ -> check "(when test) with no body -> if+(do)" false);
(* The test is still required, because there is nothing to branch on
without one. *)
parse_rejects "when with no test at all" "(defn f [] () (when))"
~needle:"when is (when test body ...)";
(* The same rule for a function with nothing in it. A [defn] whose declared
return type is () and whose body is empty has always been legal -- there
is a unit to answer and no forms needed to reach it -- and [Check] refuses
the case where the declaration disagrees, "returns i32 but has no body".
An [fn] now parses the same way; it declares no return type, so the
position it sits in is what decides, and the two rows below check.ml's
arms are in the checker section further down. *)
(match (parse1 "(fn [])").e with
| Fn ([], []) -> ()
| _ -> check "(fn []) parses with an empty body" false);
parse_rejects "fn with no parameter vector" "(defn f [] () (fn))"
~needle:"fn is (fn [param ...] body ...)";
(* unless was here, and is not any more: it is a defmacro in the prelude,
and the parser has nothing to say about it. What it expands to is the
same if-over-(not) this used to assert, and it is asserted where it can
be now -- test/programs/macro-unless.flan, through a compiler that has to
run the macro to get there. *)
(* The label is peeled off the head, and [break] carries the name it was
given rather than anything resolved — resolving it is the checker's job,
which is what makes it not a goto. *)
(match (parse1 "(while :outer c a)").e with
| While (Some "outer", _, [ _ ]) -> ()
| _ -> check "while takes a label" false);
(match (parse1 "(break :outer)").e with
| Break (Some "outer") -> ()
| _ -> check "break takes a label" false);
(match (parse1 "(continue)").e with
| Continue None -> ()
| _ -> check "bare continue" false);
(match (parse1 "(until c a)").e with
| While (None, { e = Call ({ e = Var "not"; _ }, [ _ ]); _ }, [ _ ]) -> ()
| _ -> check "until -> while(not)" false);
(match (parse1 "(cond a 1 b 2 :else 3)").e with
| If (_, _, Some { e = If (_, _, Some { e = Int 3L; _ }); _ }) -> ()
| _ -> check "cond -> nested if with :else last" false);
(* and/or short-circuit, so they must not become calls. Both bind the test
to a temp and answer the temp on the deciding path -- Clojure's own
expansion, (let [t a] (if t b t)) for and and (let [t a] (if t t b))
for or -- which is what hands back the actual deciding operand rather
than a bare bool, and what evaluates the test exactly once (M2 queue
item 7 and its review pass).
The bound name, the bound value and the arm are all pinned, not just
the shape: a desugaring that dropped the temp and wrote the operand
into the arm twice, (if a b a), would still match a pattern that left
the binding as [_]. *)
(match (parse1 "(and a b)").e with
| Let ([ { bname; bval = { e = Var "a"; _ }; _ } ],
[ { e = If ({ e = Var t1; _ },
{ e = Var "b"; _ },
Some { e = Var t2; _ }); _ } ])
when bname = t1 && t1 = t2 -> ()
| _ -> check "and short-circuits" false);
(match (parse1 "(or a b)").e with
| Let ([ { bname; bval = { e = Var "a"; _ }; _ } ],
[ { e = If ({ e = Var t1; _ },
{ e = Var t2; _ },
Some { e = Var "b"; _ }); _ } ])
when bname = t1 && t1 = t2 -> ()
| _ -> check "or short-circuits" false);
(* ── Forms that bind or alter control are never calls ──────────── *)
(* This is the class that silently misparses: it reads fine as a call and
means something entirely different. *)
(match (parse1 "(dotimes [i 10] (f i))").e with
| Dotimes (None, "i",
{ dstart = None; dstop = { e = Int 10L; _ }; dstep = None },
[ _ ]) -> ()
| _ -> check "dotimes binds" false);
(* The written bound is always the *stop*, so the shorter forms are the
longer one with its defaults left off. *)
(match (parse1 "(dotimes [i 9 -1 -1] (f i))").e with
| Dotimes (None, "i",
{ dstart = Some { e = Int 9L; _ };
dstop = { e = Int (-1L); _ };
dstep = Some { e = Int (-1L); _ } },
[ _ ]) -> ()
| _ -> check "dotimes takes start, stop and step" false);
(match (parse1 "(fn [x y] x)").e with
| Fn ([ "x"; "y" ], [ _ ]) -> ()
| _ -> check "fn binds" false);
(match (parse1 "(defer (close f))").e with
| Defer [ _ ] -> ()
| _ -> check "defer is not a call" false);
(match (parse1 "(some (find x))").e with
| Unwrap (Usome, _) -> ()
| _ -> check "some is not a call" false);
(match (parse1 "(try (read x))").e with
| Unwrap (Utry, _) -> ()
| _ -> check "try is not a call" false);
(* ── Places: the fixed assignable list, not setf ───────────────── *)
(match (parse1 "(set x 1)").e with
| Set (Pvar "x", _) -> () | _ -> check "set local" false);
(match (parse1 "(set (.hp e) 1)").e with
| Set (Pfield (_, "hp"), _) -> () | _ -> check "set field" false);
(match (parse1 "(set (at g r c) 1)").e with
| Set (Pindex (_, [ _; _ ]), _) -> () | _ -> check "set index" false);
(match (parse1 "(set (deref p) 1)").e with
| Set (Pderef _, _) -> () | _ -> check "set deref" false);
parse_rejects "set on a call" "(set (foo x) 1)";
(* ── Field access and struct literals ──────────────────────────── *)
(match (parse1 "(.pos c)").e with
| Field ({ e = Var "c"; _ }, "pos") -> ()
| _ -> check "field access" false);
(match (parse1 "(Cursor {.src s .pos 0})").e with
| Struct ("Cursor", [ ("src", _); ("pos", _) ]) -> ()
| _ -> check "struct literal" false);
(match (parse1 "[1 2 3]").e with
| Arr [ _; _; _ ] -> () | _ -> check "array literal" false);
(* ── Types: brackets mean different things by position ─────────── *)
(* Read out of [praw], not [params]: a defn's parameter vector is carried
undecided until Check pairs it, so the parser no longer fills [params] at
all. Every type spelled here is one the parser still resolves on sight —
brackets and lists are types by their shape whatever the environment says
— so [Ptype] is the shape under test and a [Pname] here would mean the
spelling stopped being recognised as a type. *)
let ty src =
match parse_decl (Printf.sprintf "(defn f [x %s] ())" src) with
| { d = Defn { praw = Some [ Pname ("x", _); Ptype t ]; _ }; _ } -> t.t
| _ -> failwith "bad type test"
in
(match ty "[u8]" with
| Tslice (false, _) -> () | _ -> check "[T] is a slice" false);
(* [const] is reserved, so this is never [n T] with a length named const. *)
(match ty "[const u8]" with
| Tslice (true, { t = Tname "u8"; _ }) -> ()
| _ -> check "[const T] is a read-only slice" false);
(match ty "[const [const u8]]" with
| Tslice (true, { t = Tslice (true, _); _ }) -> ()
| _ -> check "[const [const T]] nests" false);
(match ty "[const]" with
| exception Loc.Error { Loc.dmsg; _ }
when contains dmsg "[const] names no element type" -> ()
| _ -> check "[const] alone is refused" false);
(match ty "[const 4 u8]" with
| exception Loc.Error { Loc.dmsg; _ }
when contains dmsg "has no read-only form" -> ()
| _ -> check "[const 4 u8] is refused" false);
(match ty "[4 f32]" with
| Tarray (Lint 4L, _) -> () | _ -> check "[n T] is an array" false);
(match ty "[rows [cols u32]]" with
| Tarray (Lname "rows", { t = Tarray (Lname "cols", _); _ }) -> ()
| _ -> check "nested array with named lengths" false);
(match ty "(Ptr Cursor)" with
| Tapp ("Ptr", [ _ ]) -> () | _ -> check "(Ptr T)" false);
(* A map type is an application like (Ptr T) and (Vec T) now that the brace
spelling is gone: [Ast.Tmap] survives only as what [Cimport] builds. *)
(match ty "(Map str i32)" with
| Tapp ("Map", [ _; _ ]) -> () | _ -> check "(Map K V) is a map type" false);
(match ty "(Fn [a a] bool)" with
| Tfn (_, [ _; _ ], _) -> () | _ -> check "(Fn [T] R)" false);
(* ── Declarations ──────────────────────────────────────────────── *)
(match (parse_decl "(defn f [x i32] bool x)").d with
| Defn { ret = Some _; praw = Some [ _; _ ]; fbody = [ _ ]; _ } -> ()
| _ -> check "defn with return type" false);
(* () is the unit return type, and the body is what follows it. *)
(match (parse_decl "(defn f [x i32] () (g x))").d with
| Defn { ret = Some { t = Tname "Unit"; _ }; fbody = [ _ ]; _ } -> ()
| _ -> check "defn returning ()" false);
(* A lone () is the return type and an empty body, not a body of one form. *)
(match (parse_decl "(defn f [x i32] ())").d with
| Defn { ret = Some { t = Tname "Unit"; _ }; fbody = []; _ } -> ()
| _ -> check "defn returning () with no body" false);
(match (parse_decl "(defonce grid [4 u32])").d with
| Defvar ("grid", Some _, Zeroed, Once) -> ()
| _ -> check "defonce is ZII" false);
(match (parse_decl "(defonce buf [4 u8] uninit)").d with
| Defvar (_, _, Uninit, Once) -> ()
| _ -> check "defonce uninit opts out" false);
(* A three-element defonce whose third element cannot be a type is settled
here, by its shape, and comes out as the dyn global it means. *)
(match (parse_decl "(defonce score 0)").d with
| Defvar ("score", Some { t = Tname "dyn"; _ }, Init _, Once) -> ()
| _ -> check "a literal third element parses as a dyn initialiser" false);
(* A bare symbol could be either and parse does not know any names, so both
readings are carried out of here for [Check] to pick between. *)
(match (parse_decl "(defonce total foo)").d with
| Defvar ("total", Some { t = Tname "foo"; _ }, Ambiguous _, Once) -> ()
| _ -> check "a symbol third element parses undecided" false);
(match (parse_decl "(defonce v (Vec i32))").d with
| Defvar ("v", Some { t = Tapp ("Vec", _); _ }, Ambiguous _, Once) -> ()
| _ -> check "a parenthesised third element parses undecided" false);
(* [def] takes exactly the spellings [defonce] takes — the same parse arm
reads both — and differs in the one field that says what a re-run does.
One row per spelling, each asserting the [Every]. *)
(match (parse_decl "(def grid [4 u32])").d with
| Defvar ("grid", Some _, Zeroed, Every) -> ()
| _ -> check "def is ZII" false);
(match (parse_decl "(def buf [4 u8] uninit)").d with
| Defvar (_, _, Uninit, Every) -> ()
| _ -> check "def uninit opts out" false);
(match (parse_decl "(def score 0)").d with
| Defvar ("score", Some { t = Tname "dyn"; _ }, Init _, Every) -> ()
| _ -> check "a literal third element of def is a dyn initialiser" false);
(match (parse_decl "(def total foo)").d with
| Defvar ("total", Some { t = Tname "foo"; _ }, Ambiguous _, Every) -> ()
| _ -> check "a symbol third element of def parses undecided" false);
(match (parse_decl "(def counter i64 (start))").d with
| Defvar ("counter", Some { t = Tname "i64"; _ }, Init _, Every) -> ()
| _ -> check "a typed def with an initialiser" false);
(* The old name, refused as a name that does not exist rather than as a
rename: the reader has this compiler and nothing else, so what they need
is the name that does exist, what it does, and the other one beside it.
Both spellings compile as written. *)
parse_rejects "the old defvar spelling names defonce"
"(defvar counter i64 7)"
~needle:"there is no defvar. Did you mean defonce? (defonce counter i64 \
7) initialises once and keeps its value; (def counter i64 7) \
re-initialises on every re-run";
(match read "(defvar counter i64 7)" |> Parse.program with
| _ -> check "the old defvar spelling has a kind" false
| exception Loc.Error { Loc.kind; _ } ->
check "the old defvar spelling has a kind" (kind = "parse/defvar-renamed"));
(* A form with nothing after the keyword has nothing to echo, and the
answer must not be "(defonce )" — a malformed old form getting a
malformed new one as its fix. *)
parse_rejects "the old spelling with no arguments names the shapes"
"(defvar)"
~needle:"(defonce name Type value?) initialises once and keeps its \
value; (def name Type value?) re-initialises on every re-run";
(match (parse_decl "(import rl \"vendor:raylib\")").d with
| Import ("rl", "vendor:raylib") -> () | _ -> check "import" false);
(* ── Unimplemented forms are rejected, not silently called ─────── *)
parse_rejects "handler-bind" "(handler-bind [E h] body)";
parse_rejects "restart-case" "(restart-case body (r [] 1))";
parse_rejects "loop/recur" "(loop [x 1] (recur x))";
(* ── Macros ─────────────────────────────────────────────────────── *)
(* A defmacro is a defn. There is no Ast.Defmacro and there is not going to
be one: a macro is [Form] -> Form, compiled by the same backend as
everything else, and what makes it a macro is that the expander calls it
at compile time rather than the program calling it at run time. *)
(match (parse_decl "(defmacro m [& args] (at args 0))").d with
| Defn { name = "m"; params = [ p ]; ret = Some r; _ } ->
(match p.fty.t, r.t with
| Tslice (false, { t = Tname "Form"; _ }), Tname "Form" -> ()
| _ -> check "defmacro is [Form] -> Form" false)
| _ -> check "defmacro parses as a defn" false);
(* The declared type is the same whatever the author wrote as a parameter
list: the list is bindings over the one slice, opened by [macro_body], and
nothing below the parser learns there was a list at all. *)
(match (parse_decl "(defmacro m [[a b] c & rest] (at rest 0))").d with
| Defn { name = "m"; params = [ p ]; ret = Some r; _ } ->
(match p.fty.t, r.t with
| Tslice (false, { t = Tname "Form"; _ }), Tname "Form" -> ()
| _ -> check "a parameter list is still [Form] -> Form" false)
| _ -> check "a macro with a parameter list parses as a defn" false);
(* Several parameters is the feature now. What is still refused is a list
that cannot be read: [&] with nothing or too much after it, a pattern that
binds nothing, a name bound twice, and a map pattern — which is a
deliberate absence rather than unimplemented by accident, see TODO.org,
"Map destructuring in a macro's parameter list". *)
parse_rejects "defmacro with a dangling &" "(defmacro m [a &] a)"
~needle:"& needs a name after it";
parse_rejects "defmacro with two names after &" "(defmacro m [& a b] a)"
~needle:"& takes one name and it is the last thing";
parse_rejects "defmacro with a pattern after &" "(defmacro m [& [a b]] a)"
~needle:"& binds one name for the rest of the arguments";
parse_rejects "defmacro with an empty pattern" "(defmacro m [a []] a)"
~needle:"binds nothing";
parse_rejects "defmacro binding a name twice" "(defmacro m [a [b a]] a)"
~needle:"a is bound twice in this parameter list";
parse_rejects "defmacro with a map pattern" "(defmacro m [{:keys [a]}] a)"
~needle:"map destructuring is not implemented in a macro's parameter list";
(* Shape and feature were separate mistakes and stay separate reasons. *)
parse_rejects "defmacro with no body" "(defmacro m [x])"
~needle:"defmacro is (defmacro name [param ...] body ...)";
parse_rejects "defmacro with no params" "(defmacro m x)"
~needle:"defmacro is (defmacro name [param ...] body ...)";
parse_rejects "defmacro with a non-name param" "(defmacro m [1] x)"
~needle:"a macro's parameter is a name or a [ ] pattern";
parse_rejects "defmacro in expression position" "(defn f [] () (defmacro m [] 1))"
~needle:"cannot be used as an expression here";
(* The tagged sum is [defdata] now. The old spelling is refused by name
rather than aliased, because the name is reserved for a type with
different semantics — a file that kept [defunion] must be made to say
which of the two it means instead of being quietly given one of them. *)
parse_rejects "the old defunion spelling"
"(defunion Shape [(Circle [r f32]) (Square [s f32])])"
~needle:"This reads as a tagged sum";
(* The shape that would otherwise parse: two bare case names read as one
member of a type. Same refusal, and this is the one that matters — it
would have compiled. *)
parse_rejects "the old defunion spelling with payload-less cases"
"(defunion U [A B])"
~needle:"This reads as a tagged sum";
(match read "(defunion U [A B])" |> Parse.program with
| _ -> check "the old spelling has a kind" false
| exception Loc.Error { Loc.kind; _ } ->
check "the old spelling has a kind" (kind = "parse/defunion-renamed"));
(* The return type is not optional. A void function writes (), and the
refusal says so rather than leaving someone to find it in a grammar. *)
parse_rejects "defn with no return type" "(defn f [] (g))"
~needle:"a function that returns nothing writes ()";
parse_rejects "defn with nothing after the parameters" "(defn f [])"
~needle:"The return type is not optional";
(* One spelling for unit, and the old one names the new one. *)
parse_rejects "the old Unit spelling in return position" "(defn f [] Unit (g))"
~needle:"unit is written (), not Unit";
parse_rejects "the old Unit spelling anywhere else"
"(defn f [g (Fn [i32] Unit)] () (g 1))"
~needle:"unit is written (), not Unit";
(* Quasiquote is a desugaring over Form, and it has already run by the time
the parser sees anything, so what is written here is what a macro body
actually compiles to: the prelude's three form-building functions and
nothing else. Spelled out rather than described, because the desugaring
*is* the contract with the prelude. *)
let desugars name src want =
match read src with
| [ f ] ->
let got = Form.to_string (Expand.quasiquote f) in
if got <> want then begin
incr failures;
Printf.printf "FAIL %s\n got: %s\n wanted: %s\n"
name got want
end
| _ -> check (name ^ ": one form") false
in
desugars "a quasiquoted list is form-cons over Form nodes" "`(a ~b)"
"(Form.List {.xs (form-cons (Form.Sym {.s \"a\"}) (form-cons b (form-nil)))})";
desugars "a splice is form-append" "`(a ~@bs)"
"(Form.List {.xs (form-cons (Form.Sym {.s \"a\"}) (form-append bs (form-nil)))})";
(* A vector keeps its bracket through the desugaring: a binding vector is the
commonest thing a macro builds and Form.Vec is not Form.List. *)
desugars "a quasiquoted vector stays a vector" "`[~x 1]"
"(Form.Vec {.xs (form-cons x (form-cons (Form.Int {.i 1}) (form-nil)))})";
(* Levels are counted here, SBCL's way. The inner quasiquote is data, an
unquote belongs to the innermost quasiquote around it, and only the
unquotes at depth 1 are evaluated -- everything deeper comes back as the
(unquote x) it was read as, for the macro the output defines to desugar. *)
let q s = "(Form.Sym {.s \"" ^ s ^ "\"})" in
let wrap h x = "(Form.List {.xs (form-cons " ^ q h ^ " (form-cons " ^ x ^ " (form-nil)))})" in
let list1 x = "(Form.List {.xs (form-cons " ^ x ^ " (form-nil))})" in
desugars "a quasiquote inside a quasiquote is data" "``(b)"
(wrap "quasiquote" (list1 (q "b")));
desugars "an unquote at depth 2 is data" "``~x"
(wrap "quasiquote" (wrap "unquote" (q "x")));
desugars "~~x reaches the outer quasiquote" "``~~x"
(wrap "quasiquote" (wrap "unquote" "x"));
desugars "a splice at depth 2 is one item of data" "``(~@xs)"
(wrap "quasiquote" (list1 (wrap "unquote-splicing" (q "xs"))));
desugars "~@~xs splices at the inner level what the outer evaluates" "``(~@~xs)"
(wrap "quasiquote" (list1 (wrap "unquote-splicing" "xs")));
(* Three deep: ~~x under three quasiquotes is still data, one level short. *)
desugars "~~x under three quasiquotes is data" "```~~x"
(wrap "quasiquote" (wrap "quasiquote" (wrap "unquote" (wrap "unquote" (q "x")))));
(* ~~@xs inside a bracket splices one (unquote x) per element, SBCL's
unquote*, in a list and in a vector alike. *)
let each = "(form-append (form-wrap-each \"unquote\" xs) (form-nil))" in
desugars "~~@xs in a list splices an unquote per element" "``(~~@xs)"
(wrap "quasiquote" ("(Form.List {.xs " ^ each ^ "})"));
desugars "~~@xs in a vector splices an unquote per element" "``[~~@xs]"
(wrap "quasiquote" ("(Form.Vec {.xs " ^ each ^ "})"));
(* Outside a bracket there is still nothing for it to splice into. *)
parse_rejects "~~@x outside a bracket" "(defn f [] Form ``~~@xs)"
~needle:"nothing here for it to splice into";
(* Not a missing feature — an unquote outside a quasiquote is a mistake, and
the reader cannot catch it because it does not track where it is. *)
parse_rejects "unquote outside a quasiquote" "(defn f [] () ~x)"
~needle:"means nothing outside a quasiquote";
parse_rejects "splice where a splice makes no sense" "(defn f [] () (+ 1 ~@xs))"
~needle:"splices only into a list or a vector";
(* A splice with no bracket around it. The quasiquote is real here, so this
one is the desugaring's refusal and not the parser's. *)
parse_rejects "splice not inside a bracket" "(defn f [] Form `~@xs)"
~needle:"nothing here for it to splice into";
(* ── defenum: a value is optional, and autoincrements ──────────── *)
(* The numbers are the whole of what the form means, so they are what is
asserted on -- the parser has resolved them by the time a decl exists, and
nothing downstream can tell an implicit value from a written one. *)
let enum_values name src want =
match (parse_decl src).d with
| Defenum (_, ms) ->
let show vs = String.concat " " (List.map Int64.to_string vs) in
let got = List.map snd ms in
if got <> want then begin
incr failures;
Printf.printf "FAIL %s\n wanted: [%s]\n got: [%s]\n"
name (show want) (show got)
end
| _ -> check (name ^ ": parses as a defenum") false
in
enum_values "every member implicit" "(defenum E [A B C])" [ 0L; 1L; 2L ];
enum_values "every member explicit" "(defenum E [A 3 B 9 C -1])"
[ 3L; 9L; -1L ];
(* The mixed case is the point of the feature: an explicit value resets the
count, and the members below it carry on from there. *)
enum_values "an implicit member follows the explicit one above it"
"(defenum E [A B C 10 D])" [ 0L; 1L; 10L; 11L ];
(* The C idiom the explicit-duplicate rule exists for. *)
enum_values "a written duplicate is an alias and is kept"
"(defenum E [First 0 Second 1 Last 1])" [ 0L; 1L; 1L ];
enum_values "an enum with no members at all" "(defenum E [])" [];
(* A value autoincrement walked into is refused, because nothing in the
source chose it -- and the refusal has to name the *other* member, which
is the half a reader cannot see from the line that failed. Three needles
for one source: the message is only doing its job if both names, the
number, and the way out are all in it. *)
parse_rejects "an autoincrement onto a value already taken"
"(defenum E [A 0 B 1 C 0 D])"
~needle:"D has no value of its own, so it autoincrements to 1";
parse_rejects "the refusal names the member already holding the value"
"(defenum E [A 0 B 1 C 0 D])"
~needle:"which is the value B already has";
parse_rejects "the refusal says how to say the alias was meant"
"(defenum E [A 0 B 1 C 0 D])"
~needle:"Give D its value explicitly";
(* The member collided with is as often below as above: here it is [A], the
implicit one, that is refused, and a left-to-right check would pass it. *)
parse_rejects "an autoincrement onto a value written further down"
"(defenum E [A B 0])"
~needle:"A has no value of its own, so it autoincrements to 0";
(* A member is an i32 at run time, so a value outside i32 is refused where it
is resolved -- and the first of these is why the check has to happen
*before* the collision scan above rather than after it. 0 and 2^32 are
different int64s and the same i32, so the scan compares them, finds them
unequal, and passes a program in which both members are 0; the range
refusal is what stops it ever reaching that comparison. *)
parse_rejects "an explicit member too large for i32"
"(defenum E [A 0 B 4294967296])"
~needle:"the member B of E is 4294967296, which does not fit i32";
parse_rejects "the out-of-range refusal says what the range is"
"(defenum E [A 0 B 4294967296])"
~needle:"an enum's members run from -2147483648 to 2147483647";
(* Nothing in the source wrote 2147483648, so the sentence has to say where
it came from before it can say it is wrong. *)
parse_rejects "an autoincrement off the top of i32"
"(defenum E [A 2147483647 B])"
~needle:"B of E has no value of its own, so it autoincrements to 2147483648";
(* The int64 end of the same problem. The member refused is [A], the one
whose value is actually wrong: were the range check to run after the
recursive call rather than before it, [Int64.add] would wrap past max_int
and the refusal would name B and the number min_int, which appears nowhere
in the program. This needle is the pin on that ordering. *)
parse_rejects "an explicit member at the top of i64 does not wrap"
"(defenum E [A 9223372036854775807 B])"
~needle:"the member A of E is 9223372036854775807, which does not fit i32";
(* Genuinely malformed input still says what a member is, in the grammar the
form now has. *)
parse_rejects "an enum member that is not a name" "(defenum E [1 A])"
~needle:"an enum member is a name, optionally followed by an integer";
parse_rejects "a defenum with no member vector" "(defenum E)"
~needle:"defenum is (defenum Name [member value? ...])";
(* :else is match's catch-all, so a member named else could never be
matched. *)
parse_rejects "an enum member named else" "(defenum E [foo else])"
~needle:"E cannot have a member named else: :else is the catch-all arm";
parse_rejects "an enum member named else, with a value" "(defenum E [else 3])"
~needle:"cannot have a member named else";
(* ── Malformed syntax is caught with a location ────────────────── *)
parse_rejects "odd let bindings" "(let [a])";
parse_rejects "odd field pairs" "(defstruct S [a])";
parse_rejects "cond without body" "(cond a)";
parse_rejects "unknown top form" "(nope x)";
parse_rejects "break takes only a label" "(defn f [] () (break 1))"
~needle:"break is (break) or (break :label)";
parse_rejects "continue takes only a label" "(defn f [] () (continue x))"
~needle:"continue is (continue) or (continue :label)";
parse_rejects "a labelled while still needs a test" "(defn f [] () (while :o))"
~needle:"(while :label test body ...)";
parse_rejects "array with no type" "(defn f [] () (array 4))"
~needle:"array is (array COUNT TYPE)";
parse_rejects "array given a value, not a type" "(defn f [] () (array 4 5))"
~needle:"expected a type";
parse_rejects "array with a non-constant count" "(defn f [] () (array (+ 1 1) f32))"
~needle:"an array length is an integer or a constant's name";
(* The dimensions are read in [Parse], and this is the whole reason: without
the bracket being read here it would arrive as an ordinary argument, and
an [Arr] of two names is a perfectly good array literal wherever those
names are constants. So the bracket is required and its contents are
[len]s, refused by the same message [4 f32] gets. *)
parse_rejects "array-fill wants its dimensions in brackets"
"(defn f [] () (array-fill 3 0))"
~needle:"array-fill is (array-fill [n ...] value)";
parse_rejects "array-fill wants a fill value"
"(defn f [] () (array-fill [3]))"
~needle:"array-fill is (array-fill [n ...] value)";
parse_rejects "array-fill has no rank zero"
"(defn f [] () (array-fill [] 0))"
~needle:"array-fill is (array-fill [n ...] value)";
parse_rejects "an array-fill dimension is a length, not an expression"
"(defn f [] () (array-fill [(+ 1 1)] 0))"
~needle:"an array length is an integer or a constant's name";
parse_rejects "array-gen says its own name in its usage"
"(defn f [] () (array-gen 3 g))"
~needle:"array-gen is (array-gen [n ...] f)";
(* ── The corpus parses ─────────────────────────────────────────── *)
List.iter
(fun path ->
match read_file path |> Parse.program with
| _ -> ()
| exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
incr failures;
Printf.printf "FAIL %s does not parse: %s: %s\n"
path (Loc.to_string loc) msg)
(* dune runs tests in _build/default/test/; the corpus is declared as a
dep in test/dune and lands at the build root. *)
[ "../calc-me.flan"; "../sand.flan" ];
Test_support.report ~label:"parse" ()
(* ═══ The return type is the slot, not a guess ══════════════ *)
(* (Option f64) and (Some 1) are the same s-expression shape, and the parser
used to tell them apart by looking the head up in a set of the file's type
names. The set had to be complete, it twice was not, and the failure was a
body form silently eaten as a return type. The slot is mandatory now, so
there is nothing to look up: whatever is written there is a type, and
whatever follows is the body. These pin that down from both sides. *)
(* Through [read], so the parser and checker tables are under the reader's
alarm too: their sources go through the same reader. *)
let program src = read src |> Parse.program
let () =
let open Ast in
(* Pick the defn out; some sources also declare a struct. *)
let ret_and_body name src =
match
List.find_map
(fun (d : decl) ->
match d.d with Defn fn -> Some fn | _ -> None)
(program src)
with
| Some { ret; fbody; _ } -> (ret <> None, List.length fbody)
| None -> check (name ^ ": has a defn") false; (false, 0)
in
check "the slot is the return type"
(ret_and_body "option" "(defn f [] (Option f64) (g))" = (true, 1));
(* The two that used to be decided by the table, and are decided by position
now: a constructor call and a prelude struct literal are body forms
because they are not in the slot, not because anything knows what they
are. [(Rune {.code 65})] is the one that was misparsed in every file in
the language. *)
check "a ctor after the slot is a body form"
(ret_and_body "some" "(defn f [] () (Some 1) (bar))" = (true, 2));
check "a prelude struct literal after the slot is a body form"
(ret_and_body "preludelit" "(defn f [] () (Rune {.code 65}) (bar))"
= (true, 2));
(* And what is *in* the slot is a type whether or not the parser could know
it: a struct declared further down the file, a package's type behind an
alias the parser has not resolved, a prelude type. None of these needed a
pre-pass any more. *)
check "a type declared later is still the return type"
(ret_and_body "later"
"(defn f [] Cursor (g)) (defstruct Cursor [pos i32])" = (true, 1));
check "a prelude type is the return type"
(ret_and_body "prelude" "(defn f [] Form (g))" = (true, 1));
check "an unknown name in the slot is still the return type"
(ret_and_body "unknown" "(defn f [] Nope (bar))" = (true, 1));
(* The body may be empty, which is the shape the old optional slot could not
produce: [(defn f [])] had nowhere to put the type. *)
check "a function with a return type and no body"
(ret_and_body "nobody" "(defn f [] ())" = (true, 0));
()
(* ── Checker: AST → typed IR ───────────────────────────────────────── *)
let checked src = program src |> Check.program
(* The environment a bare expression is checked against: the prelude and
nothing else, built once because building it is the expensive half and no
probe below declares anything. *)
let probe_env = lazy (snd (Check.program_with_env []))
(* The type an expression infers to, as the checker prints it. Enough to pin
down literal defaulting and every primitive's result.
Checked as an expression, the way a session checks one sent from the editor.
It used to be the type of [(defconst probe <src>)], which stopped working on
2026-09-20: a defconst's initialiser has to be a compile-time constant now
and most of the probes below are calls — (cast ...), (length ...), a
comparison. A defonce would not do either, since only the defconst form
takes no type. This asks [check] the question the wrapper was only ever a
way of asking. *)
let infers name src expected =
match
let form = List.hd (read src) in
let e = Parse.with_imported [] (fun () -> Parse.expr form) in
let t, _, _ = Check.expression (Lazy.force probe_env) e in
Types.to_string t.Tast.ty
with
| got ->
if got <> expected then begin
incr failures;
Printf.printf "FAIL %s\n src: %s\n got: %s\n wanted: %s\n"
name src got expected
end
| exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
incr failures;
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
name src (Loc.to_string loc) msg
| exception Watchdog.Timeout ->
incr failures;
Printf.printf "FAIL %s\n src: %s\n the reader did not return\n"
name src
let accepts name src =
match checked src with
| _ -> ()
| exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
incr failures;
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
name src (Loc.to_string loc) msg
| exception Watchdog.Timeout ->
incr failures;
Printf.printf "FAIL %s\n src: %s\n the reader did not return\n"
name src
(* [needle] pins the *reason* down: a rejection for the wrong reason is not a
passing test, and the unimplemented-feature errors are the whole point. *)
let rejects_check name ?needle src =
match checked src with
| _ ->
incr failures;
Printf.printf "FAIL %s: expected a type error\n src: %s\n" name src
| exception Loc.Error { Loc.dmsg = msg; _ } ->
(match needle with
| Some n
when not
(List.exists
(fun i -> String.length msg - i >= String.length n
&& String.sub msg i (String.length n) = n)
(List.init (max 1 (String.length msg)) Fun.id)) ->
incr failures;
Printf.printf "FAIL %s: wrong reason\n wanted: %s\n got: %s\n"
name n msg
| _ -> ())
(* Which reading a three-element [defonce] got, pinned by what the global came
out as rather than by what compiled: the two readings differ in the type and
in whether anything runs at startup, and a test that only asked "does this
check" would pass on either one. [zeroed] is the static reading — the
all-bytes-zero initialiser the linker writes — and its negation is the dyn
one, whose initialiser is an expression [Emit] lifts into the startup
function. *)
let defvar_reading name src gname ~ty ~zeroed =
match checked src with
| p ->
(match List.find_opt (fun (g : Tast.global) -> g.gname = gname) p.globals with
| Some g ->
let got = Types.to_string g.gty in
let got_zeroed =
match g.Tast.ginit.Tast.e with Tast.Zero _ -> true | _ -> false
in
if got <> ty || got_zeroed <> zeroed then begin
incr failures;
Printf.printf
"FAIL %s\n src: %s\n got: %s, %s\n wanted: %s, %s\n"
name src got (if got_zeroed then "zeroed" else "initialised")
ty (if zeroed then "zeroed" else "initialised")
end
| None ->
incr failures;
Printf.printf "FAIL %s: no global named %s\n src: %s\n"
name gname src)
| exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
incr failures;
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
name src (Loc.to_string loc) msg
(* What a [def] came out as: the type, the [grerun] that makes the startup
store unguarded, and the lifted initialiser. The last is a property
[defonce] has only when its initialiser is computed and [def] has always —
zero and literal included — because it is what a re-evaluation swaps: the
host's startup calls [global/<n>] through its cell, so the lifted function
is the one place an edited initialiser can land. An [uninit] def is the
documented exception and is not asked this. *)
let def_reading name src gname ~ty =
match checked src with
| p ->
(match List.find_opt (fun (g : Tast.global) -> g.gname = gname) p.globals with
| Some g ->
let got = Types.to_string g.gty in
let lifted =
match g.Tast.ginit.Tast.e with
| Tast.Call (f, []) -> f = "global/" ^ gname
| _ -> false
in
if got <> ty then begin
incr failures;
Printf.printf "FAIL %s: the type is %s, wanted %s\n src: %s\n"
name got ty src
end;
if not g.Tast.grerun then begin
incr failures;
Printf.printf "FAIL %s: not marked for re-run\n src: %s\n"
name src
end;
if not lifted then begin
incr failures;
Printf.printf
"FAIL %s: the initialiser is not the lifted global/%s\n src: %s\n"
name gname src
end
| None ->
incr failures;
Printf.printf "FAIL %s: no global named %s\n src: %s\n"
name gname src)
| exception Loc.Error { Loc.dloc = loc; dmsg = msg; _ } ->
incr failures;
Printf.printf "FAIL %s\n src: %s\n error: %s: %s\n"
name src (Loc.to_string loc) msg
let () =
(* ── Literal defaulting and inference ──────────────────────────── *)
infers "int defaults to i32" "42" "i32";
infers "float defaults to f64" "0.5" "f64";
infers "byte is u8" "\\space" "u8";
infers "string" "\"hi\"" "str";
infers "bool" "true" "bool";
infers "arithmetic keeps kind" "(+ 1 2)" "i32";
infers "comparison is bool" "(< 1 2)" "bool";
infers "cast" "(f64 3)" "f64";
infers "array literal" "[1 2 3]" "[3 i32]";
infers "nested array" "[[1 2] [3 4]]" "[2 [2 i32]]";
(* (array COUNT TYPE): the constructor a [let] binding needs, because a let
has no type slot and [4 P] there is a two-element literal whose second
element is a name nothing declares. The type spelling is unchanged — the
two [infers] above still hold — and this is the position that had no way
to say it. *)
infers "array constructor" "(array 4 f32)" "[4 f32]";
(* A literal bound by a let takes its type from its uses in the function,
and two uses no one type satisfies are refused with the annotation. *)
accepts "a literal local takes the type set into it"
"(defn f [x i64] i64 (let [t 0] (set t (+ t x)) t))";
accepts "a literal local takes an operand's type"
"(defn f [x f64] f64 (let [s 0.0] (set s (+ s x)) s))";
accepts "recur rebinds a literal local at the type it brings"
"(defn f [n i64] i64 (loop [i 0 acc 0] (if (< i n) (recur (+ i 1) (+ acc n)) acc)))";
accepts "a set links two literal locals"
"(defn f [] i64 (let [a 0 b 0] (set b 3000000000) (set a b) a))";
accepts "a float literal local takes the f32 typed code wants"
"(defn f [x f32] f32 (let [s 0.0] (set s (+ s x)) s))";
rejects_check "a literal past f32's range where f32 is wanted"
~needle:"1e+39 does not fit in f32, whose largest value is about 3.4e38"
"(defn f [] f32 1e39)";
rejects_check "a literal f32 rounds to 0 where f32 is wanted"
~needle:"1e-50 is too small for f32, which rounds it to 0"
"(defn f [] f32 1e-50)";
infers "a literal past f32's range is an f64 like any other" "(+ 1.0 1e300)" "f64";
(* Chains through a second round, and through do, let and if arms that
merge without one. *)
accepts "a literal local fed through do, however long the chain"
"(defn f [x i64] i64 (let [a0 0 a1 0 a2 0 a3 0 a4 0 a5 0 a6 0 a7 0 a8 0 a9 0 a10 0 \
a11 0 a12 0] (set a0 x) (set a1 (do a0)) (set a2 (do a1)) (set a3 (do a2)) \
(set a4 (do a3)) (set a5 (do a4)) (set a6 (do a5)) (set a7 (do a6)) \
(set a8 (do a7)) (set a9 (do a8)) (set a10 (do a9)) (set a11 (do a10)) \
(set a12 (do a11)) a12))";
accepts "a literal local fed through a let"
"(defn f [x i64] i64 (let [a0 0 a1 0 a2 0] (set a0 x) (set a1 (let [t a0] t)) \
(set a2 (let [t a1] t)) a2))";
accepts "a literal local fed through both arms of an if"
"(defn f [x i64] i64 (let [a0 0 a1 0] (set a0 x) (set a1 (if true a0 a0)) a1))";
accepts "a literal local fed through a generic call settles in rounds"
"(defn same [x $t] $t x) (defn f [x i64] i64 (let [a0 0 a1 0 a2 0] (set a0 x) \
(set a1 (same a0)) (set a2 (same a1)) a2))";
rejects_check "a chain the rounds cannot follow names the local to annotate"
~needle:"the type of a7 depends on too long a chain of the values stored into \
it to be read off them. Write the type it should have: (i64 0)"
"(defn same [x $t] $t x) (defn f [x i64] i64 (let [a0 0 a1 0 a2 0 a3 0 a4 0 a5 0 \
a6 0 a7 0 a8 0 a9 0 a10 0] (set a0 x) (set a1 (same a0)) (set a2 (same a1)) \
(set a3 (same a2)) (set a4 (same a3)) (set a5 (same a4)) (set a6 (same a5)) \
(set a7 (same a6)) (set a8 (same a7)) (set a9 (same a8)) (set a10 (same a9)) a10))";
rejects_check "two uses of a literal local disagree"
~needle:"x is used as u32 and as i32, and 0 can have only one type. \
Write the one it should have: (u32 0)"
"(defn u [x u32] u32 x) (defn i [x i32] i32 x) \
(defn f [] i32 (let [x 0] (u x) (i x)) 0)";
infers "array of a struct" "(array 2 i32)" "[2 i32]";
infers "array of an array" "(array 2 [3 u8])" "[2 [3 u8]]";
(* (array-fill [r c] v): the same type at any rank, with the element type
taken from the fill value. Unlike [array] above this one is a value and
not a zero, which is what lets it be a defonce's initialiser — see
programs/array-fill.flan for what it puts in the elements. *)
infers "array-fill, rank 1" "(array-fill [5] 7)" "[5 i32]";
infers "array-fill, rank 2" "(array-fill [2 3] 0.5)" "[2 [3 f64]]";
infers "array-fill, rank 3" "(array-fill [2 3 4] true)" "[2 [3 [4 bool]]]";
(* A zero dimension is a legal array with no elements, and the fill loop
runs no passes over it. *)
infers "array-fill of nothing" "(array-fill [0] 1)" "[0 i32]";
infers "bytes of a string" "(bytes \"hi\")" "[u8]";
infers "bytes-view of a string" "(bytes-view \"hi\")" "[const u8]";
infers "length is i32" "(length (bytes \"hi\"))" "i32";
infers "slice of a slice" "(slice (bytes \"hi\") 0 1)" "[u8]";
infers "slice of the whole" "(slice (bytes \"hi\"))" "[u8]";
infers "slice from n" "(slice (bytes \"hi\") 1)" "[u8]";
(* A string slices to a string and indexes to a byte. Not to a [u8]: the
result views bytes the program does not own, and a byte slice is
writable-looking. *)
infers "slice of a string" "(slice \"hi\" 0 1)" "str";
infers "whole of a string" "(slice \"hi\")" "str";
infers "string index is a u8" "(at \"hi\" 0)" "u8";
infers "parse text to f64" "(bytes->f64 (bytes \"1.5\"))" "f64";
(* An untyped integer constant is usable where a float is wanted, as in
Odin; the reverse is not. *)
infers "int literal into a float" "(+ 1 0.5)" "f64";
rejects_check "float literal into an int"
"(defn f [] i32 (+ 1 0.5))" ~needle:"expected i32";
(* ── Implicit widening ─────────────────────────────────────────────
TODO.org, "Implicit numeric widening is legal; narrowing stays a hard
error".
The lattice, pinned at its edges rather than row by row: what is in, what
is out, and the two boundaries that were a judgement call and could be
argued the other way — int-into-float admitting only the exact ones, and
equal-width cross-signedness admitting nothing.
[programs/widening.flan] is the other half and asserts the bits; these
assert which programs exist. *)
accepts "same signedness widens"
"(defonce a i32) (defn g [x i64] ()) (defn f [] () (g a))";
accepts "unsigned widens into a wider signed"
"(defonce a u32) (defn g [x i64] ()) (defn f [] () (g a))";
accepts "u8 widens into i16"
"(defonce a u8) (defn g [x i16] ()) (defn f [] () (g a))";
accepts "f32 widens into f64"
"(defonce a f32) (defn g [x f64] ()) (defn f [] () (g a))";
(* Narrowing is the thing that did not change, and the message has to say
narrowing rather than "these are different types" — it also names the
direction that needs nothing, because that is the half a reader coming
from the old rule will not expect. *)
rejects_check "narrowing is still refused, and says so"
"(defonce a i64) (defn g [x i32] ()) (defn f [] () (g a))"
~needle:"i64 into i32 can lose";
rejects_check "and says the other direction is free"
"(defonce a i64) (defn g [x i32] ()) (defn f [] () (g a))"
~needle:"i32 widens into i64 by itself";
rejects_check "float narrowing is refused too"
"(defonce a f64) (defn g [x f32] ()) (defn f [] () (g a))"
~needle:"f64 into f32 can lose";
(* Equal width across signedness: each holds values the other cannot, so
there is no direction at all and the message says that instead. *)
rejects_check "signed does not reach the same-width unsigned"
"(defonce a i32) (defn g [x u32] ()) (defn f [] () (g a))"
~needle:"neither widens into the other";
rejects_check "and a signed value never reaches an unsigned, wider or not"
"(defonce a i32) (defn g [x u64] ()) (defn f [] () (g a))"
~needle:"neither widens into the other";
(* Int into float, exact only. This is where the rule is tighter than
Odin's, which admits any integer into any float; i64 has values no f64
holds, so it is out, and the cast is written. *)
accepts "i32 reaches f64 exactly"
"(defonce a i32) (defn g [x f64] ()) (defn f [] () (g a))";
accepts "u32 reaches f64 exactly"
"(defonce a u32) (defn g [x f64] ()) (defn f [] () (g a))";
accepts "i16 reaches f32 exactly"
"(defonce a i16) (defn g [x f32] ()) (defn f [] () (g a))";
rejects_check "i64 does not reach f64 — above 2^53 it would round"
"(defonce a i64) (defn g [x f64] ()) (defn f [] () (g a))"
~needle:"(f64 x)";
rejects_check "i32 does not reach f32 — above 2^24 it would round"
"(defonce a i32) (defn g [x f32] ()) (defn f [] () (g a))"
~needle:"(f32 x)";
(* Containers are invariant: widening rewrites a value with a cast, and
there is no value to rewrite in a slice that does not own its bytes. *)
rejects_check "a slice of i32 is not a slice of i64"
"(defn g [s [i64]] ()) (defn f [t [i32]] () (g t))"
~needle:"expected [i64]";
(* The binary join. The wider operand decides, in either written order, and
an equal-width cross-signed pair still has nothing to decide on. *)
accepts "the wider operand decides, wider written first"
"(defonce a i64) (defonce b i32) (defn f [] i64 (+ a b))";
accepts "and decides when it is written second"
"(defonce a i64) (defonce b i32) (defn f [] i64 (+ b a))";
accepts "min and max join the same way"
"(defonce a i8) (defonce b i16) (defn f [] i16 (max a b))";
rejects_check "i32 and u32 have no join"
"(defonce a i32) (defonce b u32) (defn f [] i32 (+ a b))"
~needle:"neither widens into the other";
(* The literal rule is untouched, which is what keeps a u64 constant's
arithmetic at u64 rather than defaulting the 1 to an i32. *)
accepts "a literal still takes the other operand's type"
"(defconst fnv u64 0xcbf29ce484222325) (defn f [] u64 (+ fnv 1))";
(* The form TODO.org, "A let binding takes no type annotation", names: an
unannotated let of a u64 constant.
It binds a u64 and nothing about widening reaches it — a let with no type
has no expectation to widen against, and the constant is what it says. *)
accepts "an unannotated let of a u64 constant still binds a u64"
"(defconst fnv u64 0xcbf29ce484222325) \
(defn f [] u64 (let [h fnv] (* h 2)))";
(* A literal that does not fit is the program's mistake, not a pair of types
that failed to meet, so the join must not reconsider it — the operand it
would reconsider against is the one the literal was supposed to take its
width *from*. Both spellings: the literal written as the operand, and the
literal buried in one. *)
rejects_check "a literal that does not fit is still refused"
"(defonce m u8) (defn f [] u8 (+ m 300))" ~needle:"300 does not fit in u8";
rejects_check "and is refused inside an operand too"
"(defonce m u8) (defn f [] u8 (+ m (+ 300 1)))"
~needle:"300 does not fit in u8";
rejects_check "a float literal still cannot stand where an int is wanted"
"(defonce n i32) (defn f [] i32 (+ n 1.5))"
~needle:"found the float literal 1.5";
accepts "a literal that does fit still takes the operand's type"
"(defonce m u8) (defn f [] u8 (+ m 200))";
(* The join reconsiders a refused operand, and a reconsidered pass must leave
nothing behind. [scoped] cannot see to that — it puts the scope back on
the way out, which an exception does not take — so [binary] snapshots and
restores around each trial. Both symptoms of not doing it: a binding that
outlives the pass that made it, and the same binding *shadowing* a live
one, which is an uninitialised read in a program the compiler accepted. *)
(* The other half, and the one that bites harder: a form that opens a window
and closes it on the way out leaves it *open* when a trial inside it is
abandoned, and then refuses a program that is fine. Both windows — the
frames [handler-bind] establishes, and the loop [loop] pushes — with the
refusal each would wrongly produce written as the second half of the
test, so a regression shows up as the message coming back rather than as
a silent accept. *)
accepts "an abandoned trial inside handler-bind does not leave its frames up"
"(defonce n i32) (defonce w i64) \
(defn f [] i32 (println (+ n (handler-bind [] w))) (return 0))";
accepts "nor does one inside a loop leave the loop up"
"(defonce n i32) (defonce w i64) \
(defn f [] i32 (println (+ n (loop [i 0] w))) (defer (println 1)) 0)";
rejects_check "and a break outside every loop still says so plainly"
"(defonce n i32) (defonce w i64) \
(defn f [] i32 (println (+ n (loop [i 0] w))) (break) 0)"
~needle:"break is only allowed inside a loop";
rejects_check "an abandoned trial leaves no binding behind"
"(defonce n i32) (defonce w i64) \
(defn f [] i32 (println (+ n (let [q w] q))) (println q) 0)"
~needle:"unknown name q";
accepts "and does not shadow the binding it was nested in"
"(defonce n i32) (defonce w i64) \
(defn f [] i32 (let [t n] (println (+ n (let [t w] t))) (println t)) 0)";
(* Shifts are the carve-out: the value's type decides and the count widens
to it, never the reverse, because the result's width and the poison check
both belong to the value. *)
accepts "a narrower count widens to the value"
"(defonce v i64) (defonce n u8) (defn f [] i64 (<< v n))";
rejects_check "a wider count does not drag the value up with it"
"(defonce v u8) (defonce n i32) (defn f [] u8 (<< v n))"
~needle:"expected u8";
(* ── Bidirectional flow ────────────────────────────────────────── *)
accepts "return type types the literal" "(defn f [] u8 0)";
accepts "return type types None" "(defn f [] (Option f64) None)";
rejects_check "bare None has no type" "(defconst x None)"
~needle:"(the (Option i32) None)";
accepts "param types the literal"
"(defn g [x u8] ()) (defn f [] () (g 3))";
rejects_check "wrong argument type"
"(defn g [x u8] ()) (defn f [] () (g 0.5))" ~needle:"expected u8";
rejects_check "wrong arity"
"(defn g [x u8] ()) (defn f [] () (g 1 2))" ~needle:"takes 1 argument";
rejects_check "wrong return type"
"(defn f [] bool 1)" ~needle:"expected bool";
(* What the mandatory slot bought: a mistyped type in return position is a
mistyped type. It used to be parsed as the first form of the body and
reported as an unknown *name*, which points at the wrong mistake. *)
rejects_check "a mistyped return type says which type was meant"
"(defn f [] f65 0.0)" ~needle:"did you mean f64";
rejects_check "if branches disagree"
"(defn f [] i32 (if true 1 true))" ~needle:"expected i32";
(* M2 queue item 7: a dyn if's scrutinee is truthiness-tested (Clojure's
rule -- nil and false are the only falsey values); a typed if keeps
needing a strict bool, exactly as before. The runtime survey is
programs/dyn-if-truthy.flan; these three pin the checker's own half. *)
accepts "typed if still takes a bare bool" "(defn f [] i32 (if true 1 2))";
rejects_check "typed if still refuses a non-bool scrutinee"
"(defn f [] i32 (if 1 1 2))"
~needle:"expected bool, found the integer literal 1";
(* Not just refused -- refused with the exact sentence a typed if has
always given here. check_truthy's dyn-or-bool check runs first, but a
value that is neither is re-checked with the old want:Bool so the
message a literal gets is the one it names itself with, not the type
it silently defaulted to along the way. *)
rejects_check "typed if still refuses None with its own message"
"(defn f [] i32 (if None 1 2))" ~needle:"expected bool, found None";
(* None is the other shape of "asked the wrong question first": checked
with no expectation at all it has no answer -- "nothing here says what
None is an Option of" -- rather than a wrong one, so check_truthy's
first attempt *raises* here instead of returning some non-bool,
non-dyn type. The re-check has to run on that path too. *)
accepts "dyn if accepts a non-bool dyn scrutinee"
"(defn f [x] dyn (if x 1 2))";
(* not, while: not [if] under the hood, so check_truthy is reached at
their own call sites (check.ml) rather than for free through
desugaring -- both take a non-bool dyn condition too. *)
accepts "dyn not accepts a non-bool dyn argument"
"(defn f [x] dyn (not x))";
accepts "dyn while accepts a non-bool dyn condition"
"(defn f [x] () (let [y x] (while y (set y false))))";
(* when, cond, and, or: sugar built out of [Ast.If] in parse.ml, so a
non-bool dyn condition reaches them with no separate check.ml case --
confirmed here rather than assumed. *)
accepts "dyn when accepts a non-bool dyn condition"
"(defn f [x] () (when x 0))";
accepts "dyn cond accepts a non-bool dyn condition"
"(defn f [x] dyn (cond x 1 :else 2))";
(* until is a prelude macro, and its refusal is a compile-error call in the
expansion. *)
rejects_check "until with no test" "(defn f [] () (until :outer))"
~needle:"until is (until test body ...)";
accepts "until keeps its label for break"
"(defn f [] () (let [i 0] (until :outer (> i 3) (set i (+ i 1)) (break :outer))))";
accepts "dyn and accepts a non-bool dyn operand"
"(defn f [x] i32 (let [y x] (if (and y true) 0 1)))";
accepts "dyn or accepts a non-bool dyn operand"
"(defn f [x] i32 (let [y x] (if (or y true) 0 1)))";
(* A bare keyword condition used to be checked with want:Bool from the
start, landing on the keyword arm's enum-or-refuse case and refusing
by name -- ":kw is an enum member where an enum is expected ... but
bool is expected here", since there was no enum in play. Checked with
no expectation first, as every scrutinee now is, it resolves as the
dyn keyword instead, and a dyn keyword is unconditionally truthy: a
typed if with a bare keyword condition now compiles, and always takes
the then branch. The author's call, recorded at check_truthy: lispy
truthiness wins here, the lost diagnostic is not brought back, and
this pins the new answer down so it does not regress by accident. *)
accepts "a typed if with a bare keyword condition now compiles"
"(defn f [] i32 (if :kw 1 2))";
(* ── Two operands or more, and the two counts below it ─────────── *)
(* The operators that take a run of operands, each at three and at four, so
the floor and the arms above it are both pinned. The comparisons are the
block after this one. *)
infers "+ at three" "(+ 1 2 3)" "i32";
infers "+ at four" "(+ 1 2 3 4)" "i32";
infers "- at four" "(- 10 1 2 3)" "i32";
infers "* at four" "(* 1 2 3 4)" "i32";
infers "/ at three" "(/ 100 5 2)" "i32";
infers "/ at four" "(/ 1000 5 2 2)" "i32";
infers "bit-and at three" "(bit-and 7 6 4)" "i32";
infers "bit-or at four" "(bit-or 1 2 4 8)" "i32";
infers "bit-xor at three" "(bit-xor 1 2 4)" "i32";
infers "min at four" "(min 4 1 3 2)" "i32";
infers "max at four" "(max 4 1 3 2)" "i32";
(* And the two counts below the floor. Zero would have to mean an identity
element, and one is refused for every operator but -, whose one-operand
form negates. *)
rejects_check "a sum with no terms"
"(defn f [] i32 (+))" ~needle:"+ takes two arguments or more, given 0";
rejects_check "a product with no factors"
"(defn f [] i32 (*))" ~needle:"* takes two arguments or more, given 0";
infers "a negated literal" "(- 1)" "i32";
infers "a negated literal takes its type from the site" "(i64 (- 1))" "i64";
rejects_check "unary minus over a string names the operand"
"(defn f [s str] () (println (- s)))" ~needle:"- takes numbers";
rejects_check "unary minus at an unsigned literal is out of range"
"(defn f [] u8 (- 1))" ~needle:"does not fit in u8";
rejects_check "there is no reciprocal"
"(defn f [] f64 (/ 2.0))" ~needle:"there is no reciprocal";
rejects_check "one operand is not a bitwise and"
"(defn f [] i32 (bit-and 7))"
~needle:"bit-and takes two arguments or more, given 1";
rejects_check "no operands are not a bitwise or"
"(defn f [] i32 (bit-or))"
~needle:"bit-or takes two arguments or more, given 0";
rejects_check "one operand is not a min"
"(defn f [] i32 (min 7))" ~needle:"min takes two arguments or more, given 1";
(* The bit operators take integers, and a bool is answered with the logical
operator a C programmer meant. *)
infers "bit-not keeps its operand's type" "(bit-not (u16 5))" "u16";
infers "popcount keeps its operand's type" "(popcount (i64 5))" "i64";
infers "a rotation takes the value's type" "(rotate-left (u8 5) (u8 1))" "u8";
infers "&& is bit-and" "(&& 6 3)" "i32";
infers "a bit operation with a dyn operand is dyn"
"(bit-and (the dyn 6) (i32 3))" "dyn";
infers "a shift with a dyn operand is dyn" "(<< (the dyn 1) 3)" "dyn";
(* Through the whole-file check [flan check] and the editor run, which
records a refusal and goes on rather than raising at the first: a hint
that only a raised refusal could give would be lost there. [.fln] text is
checked from a file, since the operator's spelling follows the syntax. *)
let refuses_all name ?(fln = false) src needle =
let diags =
match
if fln then begin
let path = Test_support.tmp "bits-" (string_of_int (Hashtbl.hash name) ^ ".fln") in
Out_channel.with_open_bin path (fun oc -> output_string oc src);
let r = snd (Front.checked ~all:true path) in
Sys.remove path; r
end
else Check.program_all (Parse.program_all (read src))
with
| _ -> []
| exception Loc.Errors ds -> List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds
| exception Loc.Error d -> [ d.Loc.dmsg ]
in
if not (List.exists (fun m -> contains m needle) diags) then begin
incr failures;
Printf.printf "FAIL %s\n wanted: %s\n got: %s\n" name needle
(String.concat " | " diags)
end
in
refuses_all "bit-and over bools points at and"
"(defn f [a bool b bool] bool (= (bit-and a b) 0))"
"bit-and works on the bits of an integer, and this is a bool. \
For true and false, write (and a b)";
refuses_all "bit-not over a bool points at not"
"(defn f [a bool] i32 (bit-not a) 0)" "write (not a)";
refuses_all "bit-xor over bools points at !="
"(defn f [a bool b bool] i32 (bit-xor a b) 0)" "write (!= a b)";
refuses_all "a typed bool beside a dyn is refused before it runs"
"(defn f [a bool d dyn] dyn (bit-or a d))" "write (or a b)";
refuses_all "a shift of a bool"
"(defn f [a bool] i32 (<< a 1) 0)" "combined with and, or and not";
refuses_all "a bool shift count" "(defn f [flag bool] i32 (<< 1 flag))"
"combined with and, or and not";
refuses_all "a bool beside an integer, an integer wanted"
"(defn f [flag bool x i32] i32 (bit-and flag x))" "write (and a b)";
refuses_all "a bool beside a literal, an integer wanted"
"(defn f [flag bool] i32 (bit-or flag 1))" "write (or a b)";
refuses_all "a literal beside a bool" "(defn f [flag bool] i32 (bit-or 1 flag))"
"write (or a b)";
refuses_all "a bool third" "(defn f [x i32 flag bool] i32 (bit-and x x flag))"
"write (and a b)";
refuses_all "a comparison as an operand"
"(defn f [x i32 y i32] i32 (bit-and x (= x y)))" "write (and a b)";
refuses_all "a bool field" "(defstruct S [on bool]) (defn f [s S] i32 (bit-or 1 (.on s)))"
"write (or a b)";
refuses_all "a call that answers a bool"
"(defn p? [x i32] bool (> x 0)) (defn f [x i32] i32 (bit-and x (p? x)))"
"write (and a b)";
refuses_all "an if whose type is bool"
"(defn f [x i32 c bool] i32 (bit-or 1 (if c true false)))" "write (or a b)";
refuses_all "a dyn function's typed bool result"
"(defn p? [x] bool (> x 0)) (defn f [d dyn] i32 (<< 1 (p? d)))"
"combined with and, or and not";
refuses_all "a bool inside a nest of bit operations"
"(defn p? [x i32] bool (> x 0)) \
(defn f [x i32] i32 (bit-and x (bit-or x (bit-xor x (p? x)))))"
"write (!= a b)";
refuses_all ~fln:true "&& in .fln, the bool first"
"fn f(flag: bool, x: i32) -> i32\n flag && x\n" "For true and false, write a and b";
refuses_all ~fln:true "&& in .fln, a literal first"
"fn f(flag: bool) -> i32\n 1 && flag\n" "write a and b";
refuses_all ~fln:true "&& in .fln, the bool last of three"
"fn f(flag: bool, x: i32) -> i32\n x && x && flag\n" "write a and b";
refuses_all ~fln:true "~~ in .fln" "fn f(a: bool) -> i32\n ~~a\n" "~~ works on the bits";
refuses_all ~fln:true "^^ in .fln" "fn f(a: bool, b: bool) -> bool\n a ^^ b == 0\n"
"write a != b";
rejects_check "popcount of a float"
"(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64";
rejects_check "a rotation's count does not widen the value"
"(defn f [a u8 n i32] u8 (rotate-left a n))" ~needle:"i32";
(* ── Chained comparisons ───────────────────────────────────────── *)
(* (< a b c) is a < b and b < c. The left fold — ((a < b) < c) — would be
comparing a bool against a number, so there is one reading and this is
it. What the run-time half means is asserted in programs/chain.flan. *)
infers "a three-way comparison is still bool" "(< 1 2 3)" "bool";
infers "a four-way comparison is still bool" "(< 1 2 3 4)" "bool";
accepts "every comparison takes three"
"(defn f [] bool (and (= 1 1 1) (!= 1 2 3) (<= 1 2 2) (> 3 2 1) \
(>= 3 3 2)))";
(* [!=] is the one that does not chain. "Is this sequence increasing" and
"are these all different" are different questions, and only the first is
about neighbours: under chaining (!= 1 2 1) would be true. It asks about
every pair instead. The answers themselves are asserted where they can
be run, in programs/chain.flan. *)
infers "all-distinct is still bool" "(!= 1 2 1)" "bool";
accepts "!= at four operands" "(defn f [] bool (!= 1 2 3 4))";
(* Strings, which = and != admit and the orderings do not. The slots a
comparison binds are slots of the operands' own type, so this is the one
row that is not about machine words. *)
infers "= over strings at three" "(= \"a\" \"a\" \"a\")" "bool";
infers "!= over strings at three" "(!= \"a\" \"b\" \"c\")" "bool";
rejects_check "the orderings still refuse strings at three"
"(defn f [] bool (< \"a\" \"b\" \"c\"))" ~needle:"orders machine numbers";
(* The operands after the first pair are checked against the type that pair
decided, and nothing widens on the way — the same rule two operands have
had all along, applied one more time. *)
accepts "a chain over one width" "(defn f [x u8 y u8 z u8] bool (< x y z))";
rejects_check "a chain does not widen its third operand"
"(defn f [x u8 y u8 z i64] bool (< x y z))" ~needle:"expected u8";
rejects_check "a chain does not widen its fourth operand"
"(defn f [x i32 y i32 z i32 w f64] bool (< x y z w))"
~needle:"expected i32";
(* A generic operand is admitted by the predicate its signature carries, at
three operands as at two. *)
rejects_check "all-distinct does not widen its third operand either"
"(defn f [x u8 y u8 z i64] bool (!= x y z))" ~needle:"expected u8";
accepts "a chain over a type variable"
"(defn between [a $t b $t c $t] bool {:where (ordered? $t)} (< a b c))";
accepts "all-distinct over a type variable"
"(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))";
rejects_check "a chain still wants the right predicate"
~needle:"nothing declares $t ordered?"
"(defn between [a $t b $t c $t] bool {:where (equal? $t)} (< a b c))";
(* One operand and none. Both would have to be [true] whatever they were
handed, which is a typo carrying a value. *)
rejects_check "one operand is not a comparison"
"(defn f [] bool (< 1))" ~needle:"needs a second value to compare against";
rejects_check "no operands are not a comparison"
"(defn f [] bool (<))" ~needle:"< takes two arguments or more, given 0";
rejects_check "the same for equality"
"(defn f [] bool (= 1))" ~needle:"needs a second value to compare against";
rejects_check "one value is distinct from nothing"
"(defn f [] bool (!= 1))" ~needle:"needs something to be distinct from";
rejects_check "no values are not a distinctness test"
"(defn f [] bool (!=))" ~needle:"!= takes two arguments or more, given 0";
(* Chaining does not reach the operators that are not comparisons. *)
rejects_check "a chain of remainders is still refused"
"(defn f [] i32 (% 10 3 2))" ~needle:"% takes 2 arguments";
rejects_check "a chain of shifts is still refused"
"(defn f [] i32 (<< 1 2 3))" ~needle:"<< takes 2 arguments";
(* ── Unknown types ─────────────────────────────────────────────── *)
(* A lowercase name is a type variable (plan.org, Types), so a mistyped
primitive would otherwise be reported as unimplemented generics and send
you to plan.org instead of to the character you mistyped. *)
rejects_check "a mistyped primitive" "(defn f [x f65] ())"
~needle:"did you mean f64?";
rejects_check "a transposed primitive" "(defn f [x i23] ())"
~needle:"did you mean i32?";
rejects_check "a mistyped struct"
"(defstruct Cursor [x i32]) (defn f [c Curser] ())"
~needle:"did you mean Cursor?";
(* [(defn f [x t] ())] used to be one parameter of an unimplemented generic
type and is now two parameters of type dyn — a lowercase name resembling
no type is a parameter, which is the whole of dynamic-by-default. The
milestone-5 reading is still reachable, by writing the type variable with
the sigil the signature binds it with. *)
(match checked "(defn f [x t] ())" with
| p ->
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "f") p.Tast.fns with
| Some { Tast.params = [ Types.Dyn; Types.Dyn ]; _ } -> ()
| _ -> check "an unannotated pair is two dyn parameters" false)
| exception _ -> check "an unannotated pair is two dyn parameters" false);
(* A bare lowercase name where a type is the only thing a slot can hold. It
used to be reported as unimplemented generics; generics are implemented,
and a lowercase name is a type variable only where a defn signature
introduced one with the sigil — a struct field is not such a place and
never will be, since only a signature binds. The message used to tell a
field to "write $elem in the parameter vector", and a field has no
parameter vector — the suggestion could not be followed where it was
printed. A field now gets its own sentence, naming the two things that
can actually be written there; the parameter-vector suggestion survives
where it works, which the return-type pin further down exercises. *)
rejects_check "a real type variable at a field" "(defstruct Holder [x elem])"
~needle:"in a defstruct's fields that makes the struct generic over it";
rejects_check "and the field message offers what a field can hold"
"(defstruct Holder [x elem])"
~needle:"Write $elem, a concrete type, or dyn to hold any value";
rejects_check "an unknown concrete type" "(defn f [x Widget] ())"
~needle:"unknown type Widget";
(* ── dyn, and what it does not do yet ──────────────────────────── *)
(* The pairing rule's own refusal. A type-named parameter with no type after
it is a dyn parameter or a pair the wrong way round; the message names
both fixes. With a type after it there is one reading. *)
rejects_check "a parameter named after a type" "(defn f [i64 x] ())"
~needle:"no type follows this parameter called i64";
rejects_check "a last parameter named after a type" "(defn f [a i32 str] ())"
~needle:"Give it one, as [str str]";
accepts "a parameter named str with a type" "(defn f [str str] i32 (length str))";
accepts "a parameter named str of another type"
"(defn f [str [u8]] i32 (length str))";
accepts "a local named str" "(defn f [b [u8]] str (let [str (str b)] str))";
accepts "a field named str" "(defstruct P [str str]) (defn f [p P] str (.str p))";
rejects_check "a local named str is not the type at vec-new"
"(defn f [] i32 (let [str 1 v (vec-new str)] 0))"
~needle:"str here is the value named str and not the type";
(* M2 item 3 lifted the container-into-dyn refusal: a [(Vec T)], a slice or
a fixed array with an i64/f64/bool element now crosses as a VIEW rather
than refusing — but only when its storage is permanent, a global's,
which review added after the first landing: a view's descriptor chases
the container's own address on every operation, and a container whose
address dies with a frame is exactly the dangling dyn value the dynamic
side refuses to hand back. Every accepting row below views a global. A
[(Map K V)] still refuses regardless of storage — it rides a
representation this milestone does not give a view — and so does any
container whose element is outside the three the view can hold. *)
accepts "a typed Vec boxed into dyn is a view, not a refusal"
"(defonce v (Vec i64) (vec-new i64))\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take v))";
accepts "a slice boxed into dyn is a view"
"(defonce xs [3 i64])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take (slice xs 0 3)))";
accepts "a fixed array boxed into dyn is a view"
"(defonce a [4 i64])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take a))";
accepts "a bool Vec's view"
"(defonce v (Vec bool) (vec-new bool))\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take v))";
accepts "an f64 Vec's view"
"(defonce v (Vec f64) (vec-new f64))\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take v))";
(* Every element a view can describe crosses: every number, bool, str,
struct, and arrays, slices and Vecs of those. What cannot be described
is refused by name — a pointer, an Option, a function, a map, an enum
or a data type inside the container. *)
accepts "a Vec of strings views into dyn, read-only"
"(defonce v (Vec str) (vec-new str))\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take v))";
accepts "an i32 element views into dyn"
"(defonce v (Vec i32) (vec-new i32))\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take v))";
rejects_check "a Vec of pointers does not view into dyn"
"(defonce v (Vec (Ptr i64)) (vec-new (Ptr i64)))\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take v))"
~needle:"a (Ptr i64) is none of these";
rejects_check "a struct with an Option field names the field's type"
"(defstruct Maybe [x (Option i64)])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take (Maybe {.x None})))"
~needle:"a (Option i64) is none of these";
(* A typed (Map K V) is unrelated to item 3 and keeps its own refusal. *)
rejects_check "a typed Map still refuses into dyn"
"(defonce m (Map i64 i64) (map-new i64 i64))\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take m))"
~needle:"does not cross into dyn yet";
(* Any storage: a local, a parameter, a temporary, a slice bound to a
local, an element of a global slice, and a container behind a pointer.
A dev build checks each against its frame or its block at run time
(test_acceptance.ml, dyn-view-any.flan); nothing is refused here. *)
accepts "a local Vec views into dyn"
"(defn take [d dyn] i32 1)\n\
(defn main [] i32 (let [v (vec-new i64)] (take v)))";
accepts "a Vec parameter views into dyn"
"(defn take [d dyn] i32 1)\n\
(defn give [v (Vec i64)] i32 (take v))\n\
(defn main [] i32 0)";
accepts "a fixed array local views into dyn"
"(defn take [d dyn] i32 1)\n\
(defn main [] i32 (let [a (array 4 i64)] (take a)))";
accepts "a slice cut from a global inline views into dyn"
"(defonce xs [3 i64])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take (slice xs 0 3)))";
accepts "a slice bound to a local views into dyn"
"(defonce xs [3 i64])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (let [s (slice xs 0 3)] (take s)))";
accepts "an element of a global array views into dyn"
"(defonce rows [2 (Vec i64)])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take (at rows 0)))";
accepts "an element of a global slice views into dyn"
"(defonce sv [(Vec i64)])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take (at sv 0)))";
accepts "an element of a global array of arrays views into dyn"
"(defonce rows [2 [3 (Vec i64)]])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take (at rows 0 1)))";
accepts "an element reached through a slice level views into dyn"
"(defonce g [2 [[3 i64]]])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take (at g 0 1)))";
accepts "a Vec behind a Ptr views into dyn"
"(defn take [d dyn] i32 1)\n\
(defn use [p (Ptr (Vec i64))] i32 (take (deref p)))\n\
(defn main [] i32 0)";
accepts "a struct views into dyn"
"(defstruct P [x f32 y u8])\n\
(defn take [d dyn] i32 1)\n\
(defn main [] i32 (let [p (P {.x 1.0 .y 2})] (take p)))";
(* A bracket *literal* is not a typed container yet, and where a dyn is
wanted it builds the runtime's own vec instead — the lowering the map
literal's values ride on, and what makes {:xs [1 2]} mean what it
reads as. *)
accepts "a bracket literal where a dyn is wanted is a dyn vec"
"(defn take [d dyn] i32 1)\n\
(defn main [] i32 (take [1 2 3]))";
(* ── Per-type descriptors — M2 item 2 ──────────────────────────
Both of these were refusals until the descriptors landed, and for one
reason: the collector's roots were frames, so a struct's dyn field was a
live value reachable only through memory the marker never walked. A type
that holds dyn words at static offsets now has a descriptor naming them,
and every slot, global and temporary holding one goes on the root stack
with that descriptor beside it — so the instance never has to carry a
pointer to its own type, which is what would have cost a header word. *)
accepts "a dyn field in a struct"
"(defstruct S [x dyn])\n(defn main [] i32 0)";
accepts "a dyn in a condition's payload"
"(defstruct Boom [what dyn])\n\
(defn main [] () (signal (Boom {.what 1})))";
(* What a condition may still not *be*. A handler matches on the condition's
type, and a dyn has no type until it runs, so the dyn itself is refused
where the struct it holds would have been fine. This is the arm the
"a dyn in a condition's payload" row above used to reach by accident, by
way of the struct-field refusal that fired first and is now gone: a dyn
value has to be signalled directly to get here at all. *)
rejects_check "a dyn signalled as the condition itself"
"(defn f [d dyn] () (signal d))"
~needle:"a condition is matched by its type and dyn is not one";
(* Nested by value, which is the case the flattening is for: the inner
struct's dyn word appears in the outer's table at the sum of the two
offsets, and there is no second descriptor to follow at run time. *)
accepts "a dyn inside a struct inside a struct"
"(defstruct Inner [x dyn])\n\
(defstruct Outer [n i32 in Inner])\n\
(defn main [] i32 (let [o (Outer {.n 1 .in (Inner {.x 2})})] (.n o)))";
(* And a fixed array of them, which is the same flattening once per
element — an array is a value and its storage is the slot's. *)
accepts "a fixed array of structs with dyn fields"
"(defstruct S [x dyn])\n\
(defn main [] i32 (let [a (array 4 S)] (set (.x (at a 0)) 7) 0))";
(* A global, rooted before the startup function runs and never popped. *)
accepts "a global struct with a dyn field"
"(defstruct S [x dyn])\n(defonce s S)\n(defn main [] i32 0)";
(* What the descriptor still cannot reach, each by name. A typed container
owns storage of a length nothing static knows, so the dyn words of one
are not a list of offsets — that is the M2 queue's item 3, and it is a
different shape of descriptor on purpose. *)
rejects_check "a dyn field under a typed container"
"(defstruct S [x dyn])\n\
(defn main [] i32 (let [v (vec-new S)] 0))"
~needle:"no descriptor can find";
(* A data type's cases overlay one another, so which words are dyn depends
on the tag, which is a run-time question a static table cannot answer. *)
rejects_check "a dyn field in a data type's payload"
"(defdata D [(A [x dyn]) (B [n i32])])\n\
(defn main [] i32 (let [d (D.B {.n 1})] 0))"
~needle:"no descriptor can find";
(* An Option's payload exists only under the tag. A None's words are zero
and marking them would be harmless, but that is how this compiler happens
to build one and not something the type says. *)
(* And the one cap, which is arithmetic rather than representation: an
array's offsets are flattened one element at a time, so a big enough
array would be a megabyte of static table. The repeat form that avoids
it is the typed container view's machinery, so this says so. *)
rejects_check "an array too big for a flattened descriptor"
"(defstruct S [x dyn])\n\
(defn main [] i32 (let [a (array 5000 S)] 0))"
~needle:"the most this compiler will write out";
(* And the length that wrapped the multiplication rather than tripping the
cap: an honest product of this by one is negative, so the test read as
under the cap, the declaration was accepted, and the emitter then sat
building the offset list until something killed it. The count is
saturated now. *)
(* And the other end of the same arm: negative rather than enormous. It
reaches the multiplication as a small number, which is exactly what the
cap must not be handed. *)
rejects_check "a negative array length"
"(defstruct S [x dyn])\n\
(defonce neg [-1 S])\n\
(defn main [] i32 0)"
~needle:"the most this compiler will write out";
rejects_check "an array length that overflows the flattened count"
"(defstruct S [x dyn])\n\
(defonce big [4611686018427387904 S])\n\
(defn main [] i32 0)"
~needle:"the most this compiler will write out";
(* A pointer is not storage. A vector of pointers to structs that hold dyn
holds no dyn words of its own, and refusing it said the opposite. *)
accepts "a typed container of pointers to a dyn-bearing struct"
"(defstruct Cond [why dyn])\n\
(defn f [v (Vec (Ptr Cond))] i32 0)\n\
(defn main [] i32 0)";
(* The one honest hole, named at the boundary where it opens — and it is a
question about *ownership*, not about shape, so the two directions get
asked different things.
A return, and everything reachable from it however many pointers deep, is
C's storage. All three shapes, because a check that followed one pointer
and stopped let the other two through: each of them stores a dyn into C
memory and reads it back after a collection, and each is a
heap-use-after-free in flan_dyn_tag under ASan. *)
(* Each on the *type* it names and not on the shared half of the sentence:
three rows against one needle would all still pass if the message named
the wrong shape, which is the one thing these rows exist to tell apart. *)
rejects_check "a pointer to a dyn-bearing struct returned from C"
"(defstruct S [x dyn])\n\
(declare grab [] (Ptr S) \"c_grab\")\n\
(defn main [] i32 0)"
~needle:"the return type of grab (the C symbol c_grab) is (Ptr S)";
rejects_check "a pointer to a pointer to one, returned from C"
"(defstruct S [x dyn])\n\
(declare grab [] (Ptr (Ptr S)) \"c_grab\")\n\
(defn main [] i32 0)"
~needle:"is (Ptr (Ptr S)), and a dyn is reachable through it";
(* The shape shim.ml's own advice tells people to write for an aggregate
result, which is what made this one worth having a test of its own. *)
rejects_check "a pointer to a slice of them, returned from C"
"(defstruct S [x dyn])\n\
(declare grab [] (Ptr [S]) \"c_grab\")\n\
(defn main [] i32 0)"
~needle:"is (Ptr [S]), and a dyn is reachable through it";
(* And an out-parameter, which is a return wearing a parameter's clothes:
the cell is this compiler's, the pointer C writes into it is C's. *)
rejects_check "an out-parameter handing back a pointer to one"
"(defstruct S [x dyn])\n\
(declare out [p (Ptr (Ptr S))] () \"c_out\")\n\
(defn main [] i32 0)"
~needle:"what lies below it is C's";
(* The other direction stays writable, and this is the half a shape-only
rule got wrong. A foreign parameter receives the address of a *place* —
a frame slot, a global, an array inside one — and every one of those is
rooted with its descriptor and marked for the whole call. So the
read-only borrow and the slice argument are ordinary and allowed. *)
accepts "a pointer to a dyn-bearing struct passed to C"
"(defstruct S [x dyn])\n\
(declare inspect [p (Ptr S)] () \"c_inspect\")\n\
(defn main [] i32 0)";
accepts "a slice of them passed to C"
"(defstruct S [x dyn])\n\
(declare take [s [S]] () \"c_take\")\n\
(defn main [] i32 0)";
(* A pointer field back to the type's own name, which is the shape that had
no row and needed four passes to surface. The two walks at this boundary
ask different questions — one counts a direct dyn and the other does not
— and they shared a visited set, so [Node] was marked seen on the way
down and then pruned from the question below the pointer. It came out
accepted while the same thing written as two types came out refused,
which is the tell. C hung a malloc'd node off [next], put a dyn in it and
read it back after a hundred thousand allocations: heap-use-after-free in
flan_dyn_tag, freed by gc_sweep. *)
rejects_check "a struct with a pointer to itself and a dyn field"
"(defstruct Node [next (Ptr Node) x dyn])\n\
(declare walk [p (Ptr Node)] () \"c_walk\")\n\
(defn main [] i32 0)"
~needle:"is (Ptr Node), and a dyn is reachable through it";
(* And the same fact through a cycle of two, because a fix that only reset
the set for a self-reference would pass the row above and fail this. *)
rejects_check "two structs pointing at each other, with a dyn in one"
"(defstruct A [b (Ptr B) x dyn])\n\
(defstruct B [a (Ptr A)])\n\
(declare walk [p (Ptr A)] () \"c_walk\")\n\
(defn main [] i32 0)"
~needle:"is (Ptr A), and a dyn is reachable through it";
(* The other side of resetting the set: it must still terminate, and it must
not start refusing a recursive shape with no dyn anywhere under it. Both
of these walk a cycle and both are ordinary. *)
accepts "a self-referential struct with no dyn in it"
"(defstruct L [next (Ptr L) n i64])\n\
(declare walk [p (Ptr L)] () \"c_walk\")\n\
(defn main [] i32 0)";
accepts "a cycle of two with no dyn in either"
"(defstruct M [other (Ptr N) n i64])\n\
(defstruct N [back (Ptr M)])\n\
(declare walk [p (Ptr M)] () \"c_walk\")\n\
(defn main [] i32 0)";
rejects_check "a dyn field under an Option"
"(defstruct S [x dyn])\n\
(defn f [] (Option S) None)\n\
(defn main [] i32 0)"
~needle:"no descriptor can find";
(* And the C boundary, which is the one that would otherwise pass silently:
a dyn is one word and would cross as an integer, and nothing on the other
side can ask what the word means. *)
rejects_check "a dyn crossing to C"
"(declare c-take [d dyn] () \"c_take\")"
~needle:"does not cross to C";
(* ── dyn maps, keywords and nil — M2 item 1 ────────────────────── *)
(* The literal parses and checks: braces whose first form is not a .field
symbol are a dyn map, in binding position and as a call argument alike —
the argument spelling used to be swallowed by the struct-literal rule. *)
accepts "a map literal in a binding"
"(defn main [] i32 (let [m {:a 1 :b \"two\"}] (length m)))";
accepts "a map literal as an argument"
"(defn take [d dyn] i32 1)\n(defn main [] i32 (take {:a 1}))";
accepts "the empty braces are an empty map"
"(defn main [] i32 (let [m {}] (length m)))";
accepts "map literals nest, and brackets inside are dyn vecs"
"(defn main [] i32 (let [m {:xs [1 2] :inner {:c 2.5}}] (length m)))";
rejects_check "a map literal with an odd number of forms"
"(defn main [] i32 (let [m {:a 1 :b}] (length m)))"
~needle:"odd number of forms";
(* The struct spelling is untouched on both of its sides: bare braces
opening on a .field are still a struct field list and not a map, and
(Type {.field v}) still builds one. What changed is *where* the two
rows below are refused — at checking now, not at parsing, because a
.field-keyed brace with a type expected of it is a struct literal and
only the checker can see the expectation. Neither position has one: a
let binding takes its type from its value, and a form that is not a
body's last is not the return value. It is untouched at the head of a
defn body too, single-form or not — [constraints] (parse.ml) leaves a
[.field]-first map alone precisely so this dedicated message, not "a
constraint map is keyword/value pairs", is what a program gets there. *)
rejects_check "bare struct-shaped braces with nothing to infer from"
"(defn main [] i32 (let [m {.x 1}] 0))"
~needle:"does not say which struct it builds";
rejects_check "bare struct-shaped braces at a defn body's head, too"
"(defn main [] i32 {.x 1} 0)"
~needle:"does not say which struct it builds";
accepts "a struct literal still builds"
"(defstruct P [x i32])\n\
(defn main [] i32 (let [p (P {.x 1})] (.x p)))";
(* And the {:where ...} constraint map is still peeled off a defn body —
it opens on :where, which is what now tells it from a map literal
standing as the body's first form. *)
accepts "a where clause is still a constraint map"
"(defn biggest [a $t b $t] $t {:where (ordered? $t)} (if (> a b) a b))\n\
(defn main [] i32 (biggest 1 2))";
(* A where clause with nothing after it is what a moved closing paren
produces -- the body fell outside the defn. It stays a constraint map
even alone, so this is "no body", not the "unknown function ordered?"
it used to print from a stray predicate read as ordinary body code. *)
rejects_check "a where clause with no body after it"
"(defn ordered? [x] bool true)\n\
(defn mx [a $t b $t] $t {:where (ordered? $t)})"
~needle:"has no body";
(* A keyword-keyed map at the head of a multi-form body, other than
:where, is a typo almost every time -- its value is discarded, and a
map literal has no reason to sit somewhere its value goes unused. An
empty map there gets its own message, since it has no key for [keys]
to name. *)
rejects_check "a discarded keyword-keyed map at a defn body's head"
"(defn main [] i32 {:a 1} 0)"
~needle:"is not a key a defn's constraint map takes";
rejects_check "a discarded empty map at a defn body's head"
"(defn main [] i32 {} 0)"
~needle:"an empty map literal here is discarded";
rejects_check "a discarded string-keyed map at a defn body's head"
"(defn main [] i32 {\"a\" 1} 0)"
~needle:"keyword/value pairs — found";
(* Not discarded, because nothing follows it: the map IS the single-form
body, a real dyn value and not a mistake to flag. *)
accepts "a keyword-keyed map as a defn's whole body"
"(defn f [] dyn {:a 1})\n(defn main [] i32 0)";
accepts "an empty map as a defn's whole body"
"(defn f [] dyn {})\n(defn main [] i32 0)";
(* :where does not get the same exception :a and {} get above -- it is
peeled unconditionally, even as a defn's whole single-form body, so
{:where 1} here is read as a constraint map with a malformed predicate
and not as a dyn map with one key named :where. That does narrow the
language: a dyn map genuinely wanting :where as a key has no way to
write one at a defn body's head (it still can anywhere else -- (let
[m {:where 1}] m) is untouched, since [constraints] only ever looks at
a defn's own body). The trade is deliberate: :where is what catches a
moved closing paren leaving a stray predicate as ordinary body code
(see above), and that only works if :where means constraint map with no
exceptions, single-form body included. Pinned so the next edit to this
arm has to notice it is choosing to narrow the language again, rather
than finding out from a bug report. *)
rejects_check ":where is reserved at a defn body's head, even alone"
"(defn f [] dyn {:where 1})\n(defn main [] i32 0)"
~needle:"a where predicate is";
rejects_check "several where predicates joined with and"
"(defn f [x $t y $u] i32 {:where (and (ordered? $t) (equal? $u))} 0)\n\
(defn main [] i32 (f 1 2))"
~needle:"a where clause puts several predicates in a vector, not in an \
and — write {:where [(ordered? $t) (equal? $u)]}";
(* Keywords: dyn where nothing else is asked, still an enum member where an
enum is, and refused where a concrete non-dyn type is wanted. *)
accepts "a keyword is a dyn value"
"(defn main [] i32 (let [k :foo] (if (= k :foo) 0 1)))";
accepts "a keyword where an enum is expected still resolves"
"(defenum Axis [x y])\n\
(defn pick [a Axis] i32 1)\n\
(defn main [] i32 (pick :x))";
rejects_check "a keyword where an i32 is expected"
"(defn take [n i32] i32 n)\n(defn main [] i32 (take :foo))"
~needle:"but i32 is expected here";
accepts "keyword takes a string"
"(defn main [] i32 (let [k (keyword \"foo\")] (if (= k :foo) 0 1)))";
rejects_check "keyword takes bytes, not a number"
"(defn main [] i32 (let [k (keyword 3)] 0))"
~needle:"keyword takes a string";
(* nil is a literal now — the dyn absence value, and what (get m k) answers
for a key a map does not hold. It is always dyn. *)
accepts "nil is a dyn literal"
"(defn main [] i32 (let [n nil] (if (= n nil) 0 1)))";
(* Superseded by the M2 item 4 boundary below: a literal [nil] at a bare
typed want is now refused by name, at compile time, rather than by the
generic dyn-boundary message — see "nil at a bare T is refused at
compile time" further down. *)
(* ── nil <-> None at (Option T), M2 queue item 4 ──────────────────
nil and None are the same absence at the one boundary where both are
meaningful. The three sites a dyn can be unboxed at own nil's half of
it too: a parameter, a return type and a global's declared type. *)
accepts "nil becomes None at a return type"
"(defn f [] (Option i64) nil)\n\
(defn main [] i32 (match (f) (Some _) 1 None 0))";
accepts "nil becomes None at a parameter"
"(defn h [o (Option i64)] i32 (match o (Some _) 1 None 0))\n\
(defn main [] i32 (h nil))";
accepts "nil becomes None at a global's declared type"
"(defonce ov (Option i64) nil)\n\
(defn main [] i32 (match ov (Some _) 1 None 0))";
(* The other direction: None crossing into dyn is nil, and a program can
compare the result the same way it compares any other nil. *)
accepts "None becomes nil crossing into dyn"
"(defn g [] dyn None)\n\
(defn main [] i32 (if (= (g) nil) 0 1))";
(* A bare T has no None to become. This nil is the one the checker can see
— the literal, right where the mismatch is — so it is refused here
rather than waiting for the run-time trap the same mismatch reaches for
one call deeper (dyn-not-visibly-nil case, test_acceptance.ml). *)
rejects_check "nil at a bare T is refused at compile time"
"(defn take [n i32] i32 n)\n(defn main [] i32 (take nil))"
~needle:"nil has no None to become";
rejects_check "nil at a bare T is refused at compile time, return position"
"(defn f [] i64 nil)\n(defn main [] i32 0)"
~needle:"nil has no None to become";
(* (Some nil) would make nil and None the same case of an (Option dyn), so
it cannot be built — refused at compile time when the argument is the
literal nil, which is exactly what "the checker can see" means here. *)
rejects_check "(Some nil) is refused at compile time"
"(defn main [] i32 (let [o (Some nil)] 0))"
~needle:"(Some nil) cannot be built";
(* The same refusal where the argument's own want is already (Option T)'s
inner type — a function parameter typed (Option i64), say. [nil] checked
against that inner type directly would hit [expect]'s bare-T refusal
first ("wrap the type in Option"), which is nonsense here: the type
already is one. A regression for the review that found it. *)
rejects_check "(Some nil) at an already-Option want gets Some's message, \
not expect's bare-T one"
"(defn f [o (Option i64)] i64 (match o (Some v) v None -1))\n\
(defn main [] i32 (f (Some nil)))"
~needle:"(Some nil) cannot be built";
(* (Option (Option T)) is legal on the typed side — nothing above refuses
the type — but boxing its Some of an inner None would box that None as
nil, indistinguishable from the outer None, so the crossing into dyn
does not exist for it. *)
rejects_check "(Option (Option T)) does not cross into dyn"
"(defn f [] (Option (Option i64)) None)\n\
(defn g [] dyn (f))\n\
(defn main [] i32 0)"
~needle:"does not cross into dyn";
(* (Option dyn): the payload is already dyn, so [box_option]/[unbox_option]
treat it as the identity — no [box]/[unbox] call, just the tag test —
and the only thing that has to hold is that the payload is never nil,
which is (Some nil)'s refusal above and not this boundary's.
That is what the code does; it is not yet what a program can hold. A
value of type (Option dyn) is refused wherever it would need a GC root
— global, parameter, return or local slot — by the *separate*,
pre-existing per-type-descriptor pass (M2 item 2): the collector marks a
struct's dyn fields by their byte offsets, and (Option dyn)'s payload
has none, the same reason (Vec dyn) and (Map K dyn) are refused today.
Item 4 does not lift that gate; it only makes sure the boundary is
already correct for the day items 2/3 do. The refusal below is that
gate, not a nil-boundary message — proof the two are not tangled. *)
rejects_check "(Option dyn) is a legal type but not yet a storable value"
"(defn k [] (Option dyn) None)\n(defn main [] i32 0)"
~needle:"no descriptor can find";
(* A full round trip through the boundary: a typed i64 boxed into dyn at
one annotated site, then read back as an (Option i64) at another. *)
accepts "a value round-trips through dyn and (Option T)"
"(defn box-it [x i64] dyn x)\n\
(defn unbox-opt [d dyn] (Option i64) d)\n\
(defn main [] i32\n\
\ (match (unbox-opt (box-it 42)) (Some x) (if (= x 42) 0 1) None 1))";
(* A numeric cast opens a dyn box — TODO.org, "A numeric cast opens a dyn
box". The checker's half is small: every cast name the language has
admits a dyn operand now, and
that is what these rows are. What the cast then *does* is a run-time
question and lives in test_acceptance.ml's dyn-cast rows — the same split
as the typed boundary, whose refusal is here and whose trap is there. *)
accepts "every numeric cast takes a dyn"
"(defn d [] dyn 7)\n\
(defn main [] i32\n\
\ (do (i64 (d)) (i32 (d)) (i16 (d)) (i8 (d))\n\
\ (u64 (d)) (u32 (d)) (u16 (d)) (u8 (d))\n\
\ (f64 (d)) (f32 (d))\n\
\ 0))";
(* And a cast the checker could already see was wrong is wrong for the same
reason it was: dyn is admitted by name, not by the numeric test going
soft. A string is not a number and never reaches a runtime tag. *)
rejects_check "a cast still refuses a non-numeric typed operand"
"(defn main [] i32 (i64 \"hi\"))"
~needle:"converts a number";
(* The *generic* cast — [($t x)] in a body whose signature says
[{:where (numeric? $t)}] — is a separate arm in the checker and did not
grow a dyn case. It did not need one: the operand's type there is what
the bound admits, and [numeric?] does not admit dyn, so a dyn cannot
reach that arm to begin with. The refusal is the bound's, at the call
that would have instantiated it. *)
rejects_check "a generic cast's operand is still what its bound admits"
"(defn conv [x $t] $t {:where (numeric? $t)} (t x))\n\
(defn d [] dyn 7)\n\
(defn main [] i32 (i32 (conv (d))))"
~needle:"numeric?";
(* The map operations ride the words the typed map already owns: get, put,
length, has-key? — one question, one word, on both sides. has-key? on a
typed map still checks against its K. *)
accepts "get, put, length and has-key? over a dyn map"
"(defn main [] i32\n\
\ (let [m {:a 1}]\n\
\ (put m :b 2)\n\
\ (if (has-key? m :b) (length m) 0)))";
accepts "has-key? still serves the typed map"
"(defn main [] i32\n\
\ (let [m (map-new str i32 (heap-allocator))]\n\
\ (if (has-key? m \"a\") 1 0)))";
(* The x86 backend used to refuse dyn by name, and what was pinned here was
the sentence it refused with. It compiles it now, which is the thing this
row is for: that backend is the dev daemon's default and dyn is the
iteration feature, so a refusal there was the two of them never meeting.
The assertion is the same shape inverted — it lowers, and it emits the
root discipline while it does. The roots are asserted rather than only
the absence of an exception, because a build that emits the calls and
forgets the roots is exactly the failure that passes every output test:
the collector simply never hears about a value.
Which programs *agree* between the backends is the @x86 sweep's question
and all five dyn programs are in it; this one only has to know that the
lowering exists. *)
let dyn_asm =
X86.program ~checks:true
(Check.program_all
(program "(defn add [x y] dyn (+ x y))\n\
(defn main [] () (print (add 1 2)))"))
in
check "the x86 backend lowers dyn"
(contains dyn_asm "flan_dyn_add");
check "the x86 backend roots its dyn values"
(contains dyn_asm "flan_dyn_root_push"
&& contains dyn_asm "flan_dyn_root_pop");
(* The site travels with the operands, on this backend as on the other: a
dyn arithmetic trap is the type error of a dynamic program, and it used
to print with no file and no line. This backend writes a string constant
as [.byte] hex rather than as text, so the needle is the encoding of the
":1:21" that ends the site of the [(+ x y)] above — the path in front of
it is the test runner's temporary directory and is not pinnable. *)
check "the x86 backend hands the dyn operators their site"
(contains dyn_asm "0x3a,0x31,0x3a,0x32,0x31");
(* And a program with no dyn in it emits not one byte of any of it, which is
what lets the sweep's other MATCHes stand as a regression check on this
lane rather than being re-measured by it. *)
check "a dyn-free program pays nothing for the collector"
(let plain =
X86.program ~checks:true
(Check.program_all
(program "(defn add [x i32 y i32] i32 (+ x y))\n\
(defn main [] () (print (add 1 2)))"))
in
(not (contains plain "flan_dyn_root_push"))
&& not (contains plain "flan_gc_init"));
(* ── Static bounds ─────────────────────────────────────────────── *)
(* A literal index into a fixed array is known now, so it is an error now
rather than a trap later; everything else is the emitted bounds check's
job. A [defconst] is a global in the typed IR, not a folded constant, so
it deliberately stays a runtime trap. *)
let arr = "(defonce a [3 i32]) " in
accepts "last valid index" (arr ^ "(defn f [] i32 (at a 2))");
rejects_check "index past the end" (arr ^ "(defn f [] i32 (at a 3))")
~needle:"out of bounds for length 3";
rejects_check "negative index" (arr ^ "(defn f [] i32 (at a -1))")
~needle:"is negative";
rejects_check "index past the end of an inner dimension"
"(defonce g [2 [4 i32]]) (defn f [] i32 (at g 1 4))"
~needle:"out of bounds for length 4";
accepts "a variable index is checked at runtime, not here"
(arr ^ "(defn f [i i32] i32 (at a i))");
accepts "a defconst index is not folded"
("(defconst k 9) " ^ arr ^ "(defn f [] i32 (at a k))");
(* A slice bound may sit one past the end; an index may not. *)
accepts "slice ending at len" (arr ^ "(defn f [] [i32] (slice a 1 3))");
accepts "empty slice at len" (arr ^ "(defn f [] [i32] (slice a 3 3))");
rejects_check "slice bound past len" (arr ^ "(defn f [] [i32] (slice a 1 4))")
~needle:"out of bounds for length 3";
rejects_check "negative slice bound" (arr ^ "(defn f [] [i32] (slice a -1 2))")
~needle:"is negative";
rejects_check "reversed slice" (arr ^ "(defn f [] [i32] (slice a 2 1))")
~needle:"runs backwards";
(* A slice has no static length, so only the two target-independent rules
apply to one. *)
rejects_check "reversed slice of a slice"
"(defn f [s [u8]] [u8] (slice s 2 1))" ~needle:"runs backwards";
accepts "a slice's length is not known here"
"(defn f [s [u8]] [u8] (slice s 0 99))";
(* The short arities are the three-argument form written out, so they are
held to the same standard: the implicit hi on a fixed array is the same
literal (length a) folds to, and a lo past it is refused here and not
later.
A 1-argument slice cannot fail either check — 0 and the length are both
in range by construction — so what is pinned about it is that it is
accepted on each of the three things slice takes. *)
accepts "the whole of an array" (arr ^ "(defn f [] [i32] (slice a))");
accepts "the tail of an array" (arr ^ "(defn f [] [i32] (slice a 3))");
rejects_check "tail past len" (arr ^ "(defn f [] [i32] (slice a 4))")
~needle:"out of bounds for length 3";
rejects_check "negative tail" (arr ^ "(defn f [] [i32] (slice a -1))")
~needle:"is negative";
accepts "the whole of a slice" "(defn f [s [u8]] [u8] (slice s))";
accepts "the tail of a slice" "(defn f [s [u8]] [u8] (slice s 2))";
rejects_check "slice with no target" "(defn f [] i32 (slice))"
~needle:"(slice a lo hi)";
rejects_check "slice of four" (arr ^ "(defn f [] [i32] (slice a 0 1 2))")
~needle:"given 4 arguments";
rejects_check "slice of something with no elements"
"(defn f [n i32] [i32] (slice n))"
~needle:"slice takes an array, a slice, a string or a Vec";
(* A Vec is the fourth thing slice takes, and it is the one that borrows:
the view is of storage the Vec owns and a push may move it. That is a
rule about the push and is written down beside the push; here what is
pinned is that all three arities reach a Vec, the two-argument one
included — it had no spelling at all while the Vec had a name of its
own. There is no static length to check a bound against, so the only
refusal left is the literal pair that runs backwards. *)
let vec = "(defn f [v (Vec i32)] " in
accepts "the whole of a Vec" (vec ^ "[i32] (slice v))");
accepts "the tail of a Vec" (vec ^ "[i32] (slice v 2))");
accepts "a range of a Vec" (vec ^ "[i32] (slice v 1 3))");
accepts "a Vec bound is not known here" (vec ^ "[i32] (slice v 0 9999))");
rejects_check "reversed slice of a Vec" (vec ^ "[i32] (slice v 2 1))")
~needle:"runs backwards";
rejects_check "slice of a Vec of four"
(vec ^ "[i32] (slice v 0 1 2))") ~needle:"given 4 arguments";
(* A negative bound reads the same on a Vec as on an array, and it has to be
asked of what the reader wrote: the implicit hi the short forms pass *is*
a -1, so a check on the finished pair would refuse (slice v) itself. The
one-argument form is the case that proves it runs in the right place. *)
rejects_check "negative Vec tail" (vec ^ "[i32] (slice v -1))")
~needle:"is negative";
rejects_check "negative Vec lo" (vec ^ "[i32] (slice v -1 2))")
~needle:"is negative";
rejects_check "the sentinel is not a bound anybody may write"
(vec ^ "[i32] (slice v 0 -1))") ~needle:"is negative";
(* A Vec a call returned is *accepted*, where an array a call returned is
not. The array dangles; this does not — the storage outlives the
expression — and what it loses is the owner, which is a leak, which is
defined behaviour here. (length (mk)) and (at (mk) 0) lose the same owner
and compile, so refusing only the third would be a rule about a spelling
rather than about a hazard. *)
accepts "slice of a returned Vec"
"(defn mk [] (Vec i32) (vec-new i32)) (defn f [] [i32] (slice (mk)))";
accepts "slice of a returned Vec, three arguments"
"(defn mk [] (Vec i32) (vec-new i32)) (defn f [] [i32] (slice (mk) 0 1))";
(* There is no [as-slice]: one word takes the view and what it is given says
what the view is. The refusal names [slice] and writes the call back out,
because a reader meeting it has no reason to know there was ever a second
name. *)
rejects_check "as-slice is not a name"
(vec ^ "[i32] (as-slice v))") ~needle:"there is no as-slice";
rejects_check "as-slice suggests the call that replaces it"
(vec ^ "[i32] (as-slice v 1 3))") ~needle:"Write (slice v 1 3)";
rejects_check "as-slice over an expression suggests a form that compiles"
"(defn mk [] (Vec i32) (vec-new i32)) \
(defn f [] [i32] (as-slice (mk) 1 3))"
~needle:"Write (slice v 1 3)";
(* A program's own definition of the name still reaches its own. *)
accepts "a program may define as-slice"
"(defn as-slice [n i32] i32 n) (defn f [] i32 (as-slice 3))";
(* An array a call returned is a temporary the slice would outlive. It
dangled silently on both backends before, at the three-argument
spelling; (slice (mk)) is the spelling that would have made it
idiomatic, so it is refused rather than written more often. A literal
is not this case — the frame holds one for as long as the form it is
written in, which is what the acceptance program sorts. *)
rejects_check "slice of a returned array"
"(defn mk [] [3 i32] [7 8 9]) (defn f [] [i32] (slice (mk)))"
~needle:"a temporary the slice would outlive";
rejects_check "slice of a returned array, three arguments"
"(defn mk [] [3 i32] [7 8 9]) (defn f [] [i32] (slice (mk) 0 3))"
~needle:"a temporary the slice would outlive";
accepts "slice of an array literal"
"(defn f [] i32 (at (slice [7 8 9]) 0))";
rejects_check "returning a slice of an array literal"
"(defn f [] [i32] (slice [7 8 9]))"
~needle:"f returns a slice of a temporary array";
(* One builtin, one answer about a bound. A slice bound is a subscript and
goes through [index_expr] like every other one, so a u32 is admitted on
an array exactly as it always was on a Vec, and an i64 is refused by name
on both. The array path used to expect an i32 outright, which made
(at a c) compile and (slice a c) not. *)
accepts "a u32 bound over an array"
(arr ^ "(defn f [c u32] [i32] (slice a c))");
accepts "a u32 bound over a Vec"
"(defn f [v (Vec i32) c u32] [i32] (slice v c))";
rejects_check "an i64 bound over an array"
(arr ^ "(defn f [c i64] [i32] (slice a c))") ~needle:"an index is an i32";
rejects_check "an i64 bound over a Vec"
"(defn f [v (Vec i32) c i64] [i32] (slice v c))"
~needle:"an index is an i32";
(* A string indexes and slices, and neither is a place: it is a view of
bytes the program does not own — a literal's are in constant storage —
so there is no store through one to allow. *)
accepts "a string slices" "(defn f [s str] str (slice s 1))";
accepts "a string indexes" "(defn f [s str] u8 (at s 1))";
(* Both routes to a Pindex, because there are two and they do not share a
line of code: one index goes through the [set] arm that checks its own
target, two through [check_place]. The one-index spelling is the one a
person writes, and it is the one that would silently store into
constant data. *)
rejects_check "set through a string"
"(defn f [s str] () (set (at s 0) 65))" ~needle:"not a place";
rejects_check "set through a string, two indices"
"(defn f [s [2 str]] () (set (at s 0 0) 65))" ~needle:"not a place";
(* The mirror, and the one the walk could break by moving the question a
level up: the refusal is about the type being *indexed*, not about the
element that comes out. An array of strings has a string element and
indexes nothing but the array, so assigning a whole one stays legal. *)
accepts "set an array's string element"
"(defn f [s [2 str]] () (set (at s 0) \"world\"))";
rejects_check "set through a string's slice"
"(defn f [s str] () (set (at (slice s 1) 0) 65))"
~needle:"not a place";
(* The address of one is a (Ptr const u8), so it is not a (Ptr u8). *)
rejects_check "the address of a string's byte is read-only"
"(defn f [s str] (Ptr u8) (addr (at s 0)))"
~needle:"expected (Ptr u8), found (Ptr const u8)";
(* And a string is still not a [u8]: slicing one does not smuggle a byte
slice out of it. *)
rejects_check "a string slice is not a byte slice"
"(defn g [b [u8]] i32 (length b)) (defn f [s str] i32 (g (slice s)))"
~needle:"expected [u8], found str";
(* [const T]: a view that can only be read. Every route to a store through
one is refused, and none of the reads is. *)
infers "a const slice slices to a const slice"
"(slice (bytes-view \"hello\") 1 3)" "[const u8]";
infers "vec-new reads [const u8] as a type" "(vec-new [const u8])"
"(Vec [const u8])";
infers "map-new reads [const u8] as a type" "(map-new str [const u8])"
"(Map str [const u8])";
rejects_check "set through a const slice"
"(defn f [s [const u8]] () (set (at s 0) 65))"
~needle:"this writes through a [const u8]";
rejects_check "set through bytes-view"
"(defn f [] () (let [v (bytes-view \"Hi\")] (set (at v 0) \\h)))"
~needle:"this writes through a [const u8]";
rejects_check "set through a const slice, two indices"
"(defn f [s [const [2 i32]]] () (set (at s 0 1) 5))"
~needle:"this writes through a [const [2 i32]]";
rejects_check "set through an array element of a const slice"
"(defn f [s [const [2 i32]]] () (set (at (at s 0) 1) 5))"
~needle:"this writes through a [const [2 i32]]";
rejects_check "replace an array element of a const slice whole"
"(defn f [s [const [2 i32]]] () (set (at s 0) [1 2]))"
~needle:"this writes through a [const [2 i32]]";
rejects_check "set a field of a const slice's element"
"(defstruct P [x i32]) (defn f [s [const P]] () (set (.x (at s 0)) 5))"
~needle:"this writes through a [const P]";
rejects_check "a const slice is not a writable one"
"(defn g [b [u8]] () (set (at b 0) 1)) (defn f [s [const u8]] () (g s))"
~needle:"expected [u8], found [const u8]";
rejects_check "and the refusal names the copy"
"(defn g [b [u8]] () (set (at b 0) 1)) (defn f [s [const u8]] () (g s))"
~needle:"(clone v) copies v into a [u8] of its own";
accepts "and the copy it names compiles"
"(defn g [b [u8]] () (set (at b 0) 1)) (defn f [s [const u8]] () (g (clone s)))";
rejects_check "a store through a const slice names clone"
"(defstruct P [x i32]) (defn f [v [const P]] () (set (.x (at v 0)) 1))"
~needle:"(clone v) copies v's elements into one";
accepts "and that clone compiles"
"(defstruct P [x i32]) \
(defn f [v [const P]] () (let [w (clone v)] (set (.x (at w 0)) 1)))";
rejects_check "no clone named for elements clone refuses"
"(defn f [v [const dyn]] () (set (at v 0) 1))"
~needle:"take it as a [dyn] instead";
rejects_check "a generic writer does not take a const slice"
"(defn f [s [const i32]] () (sort s))"
~needle:"sort takes a slice it may write through";
rejects_check "a const slice does not cross into dyn"
"(defn f [s [const i64]] dyn s)"
~needle:"a [const i64] can only be read";
rejects_check "no conversion under a writable slice"
"(defn g [p [[const u8]]] i32 0) (defn f [p [[u8]]] i32 (g p))"
~needle:"expected [[const u8]], found [[u8]]";
rejects_check "push through a const slice of Vecs"
"(defn f [s [const (Vec i32)]] () (push (at s 0) 5))"
~needle:"reached through a [const (Vec i32)]";
rejects_check "put through a const slice of maps"
"(defn f [s [const (Map str i32)]] () (put (at s 0) \"a\" 5))"
~needle:"reached through a [const (Map str i32)]";
rejects_check "map-remove through a const slice of maps"
"(defn f [s [const (Map str i32)]] bool (map-remove (at s 0) \"a\"))"
~needle:"reached through a [const (Map str i32)]";
rejects_check "reserve through a const slice of Vecs"
"(defn f [s [const (Vec i32)]] () (reserve (at s 0) 10))"
~needle:"reached through a [const (Vec i32)]";
rejects_check "free through a const slice of Vecs"
"(defn f [s [const (Vec i32)]] () (free (at s 0)))"
~needle:"reached through a [const (Vec i32)]";
rejects_check "push into a field reached through a const slice"
"(defstruct P [v (Vec i32)]) (defn f [s [const P]] () (push (.v (at s 0)) 1))"
~needle:"reached through a [const P]";
accepts "a Vec's own buffer is not the const slice's storage"
"(defn f [s [const (Vec i32)]] () (set (at (at s 0) 0) 5))";
accepts "a reading function where a writing one is wanted"
"(defn rd [s [const u8]] i32 0) (defn c [f (Fn [[u8]] i32)] i32 0) \
(defn m [] i32 (c rd))";
rejects_check "not a writing function where a reading one is wanted"
"(defn wr [s [u8]] i32 0) (defn c [f (Fn [[const u8]] i32)] i32 0) \
(defn m [] i32 (c wr))"
~needle:"expected (Fn [[const u8]] i32), found (CFn [[u8]] i32)";
rejects_check "nor a read-only result where a writable one is wanted"
"(defn mk [] [const u8] (bytes-view \"a\")) \
(defn c [f (Fn [] [u8])] i32 0) (defn m [] i32 (c mk))"
~needle:"expected (Fn [] [u8]), found (CFn [] [const u8])";
(* (Ptr const T): the pointer beside [const T]. *)
infers "the address of a const element" "(addr (at (bytes-view \"hi\") 0))"
"(Ptr const u8)";
infers "the address of a string's byte" "(addr (at \"hi\" 0))"
"(Ptr const u8)";
infers "a const pointer slices to a const slice"
"(slice-from (addr (at (bytes-view \"hi\") 0)) 2)" "[const u8]";
rejects_check "a store through a const pointer"
"(defn f [p (Ptr const i32)] () (set (deref p) 1))"
~needle:"this writes through a (Ptr const i32)";
rejects_check "a store through the address of a const element"
"(defn f [v [const u8]] () (set (deref (addr (at v 0))) 1))"
~needle:"this writes through a (Ptr const u8)";
rejects_check "a store through the address of a string's byte"
"(defn f [s str] () (set (deref (addr (at s 0))) 1))"
~needle:"this writes through a (Ptr const u8)";
rejects_check "a field store through a const pointer"
"(defstruct P [x i32]) (defn f [p (Ptr const P)] () (set (.x p) 1))"
~needle:"this writes through a (Ptr const P)";
rejects_check "a push through a const pointer"
"(defn f [p (Ptr const (Vec i32))] () (push (deref p) 1))"
~needle:"this changes a (Vec i32) reached through a (Ptr const (Vec i32))";
rejects_check "a const pointer is not a writable one"
"(defn g [p (Ptr u8)] i32 0) (defn f [v [const u8]] i32 (g (addr (at v 0))))"
~needle:"expected (Ptr u8), found (Ptr const u8)";
rejects_check "slice-from keeps the const"
"(defn f [v [const u8]] [u8] (slice-from (addr (at v 0)) 1))"
~needle:"expected [u8], found [const u8]";
rejects_check "const alone is not a type" "(defn f [p (Ptr const)] i32 0)"
~needle:"const is not a type on its own";
rejects_check "no conversion under a writable pointer"
"(defn f [p (Ptr (Ptr i32))] (Ptr (Ptr const i32)) p)"
~needle:"expected (Ptr (Ptr const i32)), found (Ptr (Ptr i32))";
accepts "a writable pointer is a const one"
"(defn f [p (Ptr i32)] (Ptr const i32) p)";
accepts "and under a const pointer, one level down"
"(defn f [p (Ptr (Ptr i32))] (Ptr const (Ptr const i32)) p)";
accepts "a generic const pointer binds from a writable one"
"(defn f [p (Ptr const $t)] $t (deref p)) (defn g [q (Ptr i32)] i32 (f q))";
accepts "vec-new reads (Ptr const u8) as a type"
"(defn f [] i32 (let [v (vec-new (Ptr const u8))] (length v)))";
(* Decision 81: a value that owns storage, reached through read-only
storage, is used where it stands and never copied out. Every route a
copy could take is refused at the copy. *)
let copied = "this copies a (Vec i32) out of a [const (Vec i32)]" in
List.iter
(fun (name, src) -> rejects_check ("no copy out: " ^ name) src ~needle:copied)
[ "let", "(defn f [cs [const (Vec i32)]] () (let [v (at cs 0)] (push v 1)))";
"loop binding",
"(defn f [cs [const (Vec i32)]] () (loop [v (at cs 0)] (push v 1)))";
"if value",
"(defn f [c bool cs [const (Vec i32)]] () \
(let [v (if c (at cs 0) (at cs 1))] (push v 1)))";
"do value",
"(defn f [cs [const (Vec i32)]] () (let [v (do (at cs 0))] (push v 1)))";
"set into a local",
"(defn f [cs [const (Vec i32)]] () \
(let [v (vec-new i32)] (set v (at cs 0)) (push v 1)))";
"match binding",
"(defn f [cs [const (Vec i32)]] i32 \
(match (Some (at cs 0)) (Some v) (do (push v 1) 0) None 0))";
"array destructure",
"(defn f [cs [const (Vec i32)]] () \
(let [[a b] [(at cs 0) (at cs 1)]] (push a 1)))";
"closure capture",
"(defn app [g (Fn [] ())] () (g)) (defn f [cs [const (Vec i32)]] () \
(let [v (at cs 0)] (app (fn [] (push v 1)))))";
"passed by value",
"(defn pusher [v (Vec i32)] () (push v 1)) \
(defn f [cs [const (Vec i32)]] () (pusher (at cs 0)))";
"returned by value",
"(defn g [cs [const (Vec i32)]] (Vec i32) (at cs 0))";
"through a generic",
"(defn id [x $t] $t x) (defn f [cs [const (Vec i32)]] () (push (id (at cs 0)) 1))" ];
rejects_check "no copy out through a const pointer"
"(defn f [p (Ptr const (Vec i32))] () (let [v (deref p)] (push v 1)))"
~needle:"this copies a (Vec i32) out of a (Ptr const (Vec i32))";
rejects_check "and the copy that is allowed is named"
"(defn f [cs [const (Vec i32)]] (Vec i32) (at cs 0))"
~needle:"(clone v) copies it into a (Vec i32) of its own";
rejects_check "a struct holding a Vec is not copied out either"
"(defstruct P [v (Vec i32)]) (defn f [cs [const P]] P (at cs 0))"
~needle:"(addr v) gives a (Ptr const P) to read it through";
rejects_check "nor an array of them"
"(defn f [cs [const [2 (Vec i32)]]] [2 (Vec i32)] (at cs 0))"
~needle:"this copies a [2 (Vec i32)] out of a [const [2 (Vec i32)]]";
rejects_check "nor an Option of one"
"(defn f [cs [const (Option (Vec i32))]] (Option (Vec i32)) (at cs 0))"
~needle:"this copies a (Option (Vec i32)) out";
rejects_check "nor a field that owns storage"
"(defstruct P [v (Vec i32)]) (defn f [cs [const P]] (Vec i32) (.v (at cs 0)))"
~needle:"this copies a (Vec i32) out of a [const P]";
accepts "used where it stands"
"(defstruct P [v (Vec i32) n i32]) \
(defn f [cs [const (Vec i32)] ps [const P] p (Ptr const (Vec i32))] i32 \
(+ (at (at cs 0) 1) (length (at cs 0)) (length (slice (at cs 0))) \
(.n (at ps 0)) (length (.v (at ps 0))) (length (deref p)) \
(length (deref (addr (at cs 0)))) (length (clone (at cs 0)))))";
accepts "a copy of a scalar element is still a copy"
"(defn f [cs [const i32]] i32 (let [x (at cs 0)] (set x 5) x))";
(* The header copy is suggested only for elements that own nothing. *)
rejects_check "no header copy suggested for an array of Vecs"
"(defn f [cs [const [2 (Vec i32)]]] () (set (at cs 0) (at cs 1)))"
~needle:"take it as a [[2 (Vec i32)]] instead";
rejects_check "nor for an Option of a Vec"
"(defn f [cs [const (Option (Vec i32))]] () (set (at cs 0) None))"
~needle:"take it as a [(Option (Vec i32))] instead";
(* Two arguments at one type variable meet at const, either order. *)
accepts "a generic's arguments join at const"
"(defn pick [c bool a $t b $t] $t (if c a b)) \
(defn f [c bool cs [const u8] ms [u8]] i32 (+ (length (pick c ms cs)) \
(length (pick c cs ms))))";
rejects_check "and the join is read-only"
"(defn pick [c bool a $t b $t] $t (if c a b)) \
(defn f [c bool cs [const u8] ms [u8]] () (set (at (pick c ms cs) 0) 1))"
~needle:"this writes through a [const u8]";
rejects_check "no copy of Vec headers is suggested"
"(defn f [cs [const (Vec i32)]] () (set (at cs 0) (vec-new i32)))"
~needle:"take it as a [(Vec i32)] instead";
(* A fixed array reached through read-only storage slices to a read-only
view. *)
rejects_check "slice of an array element of a const slice"
"(defn f [cs [const [4 u8]]] () (let [s (slice (at cs 0))] (set (at s 0) 9)))"
~needle:"this writes through a [const u8]";
rejects_check "slice of an array behind a const pointer"
"(defn f [p (Ptr const [4 u8])] () (let [s (slice (deref p))] (set (at s 0) 9)))"
~needle:"this writes through a [const u8]";
rejects_check "slice of an array field reached through a const slice"
"(defstruct B [buf [4 u8]]) \
(defn f [cs [const B]] () (let [s (slice (.buf (at cs 0)))] (set (at s 0) 9)))"
~needle:"this writes through a [const u8]";
infers "a local array still slices to a writable slice"
"(let [a [1 2]] (slice a))" "[i32]";
(* The branches of an if meet at the read-only type, in either order. *)
accepts "if: writable then read-only"
"(defn f [c bool cs [const u8] ms [u8]] i32 (length (if c ms cs)))";
accepts "if: read-only then writable"
"(defn f [c bool cs [const u8] ms [u8]] i32 (length (if c cs ms)))";
rejects_check "and the join is read-only"
"(defn f [c bool cs [const u8] ms [u8]] () (set (at (if c ms cs) 0) 1))"
~needle:"this writes through a [const u8]";
accepts "if over pointers joins the same way"
"(defn f [c bool a (Ptr const i32) b (Ptr i32)] i32 (deref (if c b a)))";
rejects_check "const is not a name a constant can have"
"(defconst const 4)" ~needle:"const cannot be declared";
(* The const is shallow: an element of a [const [u8]] is a writable [u8]. *)
accepts "store through an element of a const slice of slices"
"(defn f [s [const [u8]]] () (set (at (at s 0) 1) 5))";
accepts "a writable slice is a const one"
"(defn g [b [const u8]] u8 (at b 0)) (defn f [s [u8]] u8 (g s))";
accepts "and so is a string's bytes, at a prelude reader"
"(defn f [s str] bool (bytes=? (bytes-view s) (bytes-view \"x\")))";
accepts "under a const slice the element converts too"
"(defn g [p [const [const u8]]] i32 0) (defn f [p [[u8]]] i32 (g p))";
accepts "the address of a const element, for C"
"(defn f [s [const u8]] (Ptr const u8) (addr (at s 0)))";
accepts "a generic reader takes both"
"(defn f [a [const i32] b [i32]] i64 (+ (sum-i32 a) (sum-i32 b)))";
(* (slice-from p n). The one form in the language whose central claim the
compiler cannot check — whether n is the truth about what p addresses — so
what it does check is worth pinning: the argument really is a pointer, the
length is not absurd on its face, and the result owns nothing. *)
accepts "a pointer plus a length is a slice"
"(defn f [p (Ptr i32) n i32] i32 (at (slice-from p n) 0))";
accepts "zero is a length"
"(defn f [p (Ptr i32)] i32 (length (slice-from p 0)))";
rejects_check "slice-from of something that is not a pointer"
"(defn f [s [i32]] i32 (length (slice-from s 3)))"
~needle:"takes a (Ptr T)";
rejects_check "slice-from with a negative literal length"
"(defn f [p (Ptr i32)] i32 (length (slice-from p -1)))"
~needle:"is negative";
accepts "slice-from counts with any integer type"
"(defn f [p (Ptr i32) a i64 b u64 c u8] i64 \
(+ (length (slice-from p a)) (length (slice-from p b)) \
(length (slice-from p c))))";
rejects_check "slice-from with a count that is not an integer"
"(defn f [p (Ptr i32) n f32] i32 (length (slice-from p n)))"
~needle:"Write (slice-from p (i64 n))";
(* ((Ptr T) p): the type is the head, as in (i32 x). It changes what the
pointer points at and checks nothing else, but it keeps const. *)
accepts "a pointer cast"
"(defn f [p (Ptr u8)] (Ptr i32) ((Ptr i32) p))";
accepts "a pointer cast may add const"
"(defn f [p (Ptr u8)] (Ptr const i32) ((Ptr const i32) p))";
accepts "a const pointer casts to a const pointer"
"(defn f [p (Ptr const u8)] [const i32] (slice-from ((Ptr const i32) p) 2))";
rejects_check "a pointer cast may not drop const"
"(defn f [p (Ptr const u8)] (Ptr i32) ((Ptr i32) p))"
~needle:"Write ((Ptr const i32) p)";
rejects_check "a pointer cast of a slice"
"(defn f [s [u8]] (Ptr i32) ((Ptr i32) s))"
~needle:"write ((Ptr i32) (addr (at s 0)))";
rejects_check "a pointer cast of an integer"
"(defn f [x i64] (Ptr i32) ((Ptr i32) x))"
~needle:"no conversion between an integer and a pointer";
rejects_check "slice-from-ptr names slice-from"
"(defn f [p (Ptr i32) n i32] i32 (length (slice-from-ptr p n)))"
~needle:"Write (slice-from p n)";
accepts "a pointer cast checks the outer const only"
"(defn f [q (Ptr (Ptr const u8))] (Ptr (Ptr u8)) ((Ptr (Ptr u8)) q))";
rejects_check "a pointer cast of a dyn"
"(defn f [x dyn] (Ptr i32) ((Ptr i32) x))"
~needle:"A dyn value never holds a pointer";
(* The storage stays C's, and a view made in place is refused at free
without running anything. *)
rejects_check "free of a slice made from a pointer"
"(defn f [p (Ptr i32)] () (free (slice-from p 3)))"
~needle:"is a view of storage something else owns";
rejects_check "free of a slice written in place"
"(defn f [v (Vec i32)] () (free (slice v)))"
~needle:"is a view of storage something else owns";
(* ── Structs, fields and auto-deref ────────────────────────────── *)
let cursor = "(defstruct Cursor [src [u8] pos i32]) " in
accepts "struct literal, omitted field zeroed"
(cursor ^ "(defn f [s [u8]] Cursor (Cursor {.src s}))");
rejects_check "unknown field"
(cursor ^ "(defn f [s [u8]] Cursor (Cursor {.nope s}))")
~needle:"has no field nope";
rejects_check "field given twice"
(cursor ^ "(defn f [s [u8]] Cursor (Cursor {.pos 0 .pos 1}))")
~needle:"given twice";
(* {:src s} is a dyn map literal now, not a struct field list with the
wrong punctuation — the colon is wanted for keys, and this is one. What
used to be caught as a mispunctuated struct is caught one level up
instead: (Cursor {:src s}) is a struct type applied to one argument, and
since positional construction landed that is a Cursor built from too few
arguments. The refusal still points at the struct spelling, which is why
the needle below did not have to move. *)
rejects_check "a struct type called with a colon-keyed map"
(cursor ^ "(defn f [s [u8]] Cursor (Cursor {:src s}))")
~needle:"a struct value is written (Cursor {.field value ...})";
(* ── A bare {.field v}, typed by its position ──────────────────── *)
(* The five positions that carry an expectation, and the three that do
not. Everything the named form checks — unknown field, duplicate
field, ZII for the ones left out — is checked here by *being* the
named form: [check_bare] reads the type name off the want and hands
the very same field list to [check_struct]. The two rows below the
accepts are what says so, since they are the named form's own kinds
and messages arriving at a literal with no name on it. *)
let cell = "(defstruct Cell [row i32 col i32]) " in
accepts "bare literal in a defn's return position"
(cell ^ "(defn f [] Cell {.row 1 .col 2})");
accepts "bare literal with a field omitted is ZII, as the named form is"
(cell ^ "(defn f [] Cell {.row 1})");
accepts "bare literal as the only argument of a call"
(cell ^ "(defn g [c Cell] i32 (.row c)) (defn f [] i32 (g {.row 1}))");
accepts "bare literal as a later argument of a call"
(cell ^ "(defn g [n i32 c Cell] i32 (+ n (.row c))) \
(defn f [] i32 (g 1 {.row 2}))");
accepts "bare literal as a field of another literal"
(cell ^ "(defstruct Grid [a Cell b Cell]) \
(defn f [] Grid (Grid {.a {.row 1} .b {.col 2}}))");
accepts "bare literal set into a typed place"
(cell ^ "(defn f [] i32 (let [c (Cell 0 0)] (set c {.row 7}) (.row c)))");
accepts "bare literal at a union want"
"(defunion U [i i32 f f32]) (defn f [] U {.i 5})";
rejects_check "bare literal with an unknown field"
(cell ^ "(defn f [] Cell {.nope 1})") ~needle:"Cell has no field nope";
rejects_check "bare literal with a field given twice"
(cell ^ "(defn f [] Cell {.row 1 .row 2})") ~needle:"given twice";
(* The three no-reading positions. The dyn one is the boundary that
matters most: braces at a dyn want are the dyn map literal and stay
it, so a .field-keyed brace is refused there rather than quietly
given a second meaning — and told which punctuation a map uses. *)
rejects_check "bare literal with no expectation to read"
(cell ^ "(defn f [] i32 (let [c {.row 1}] (.row c)))")
~needle:"does not say which struct it builds";
rejects_check "bare literal at a dyn want is not a dyn map"
(cell ^ "(defn f [] dyn {.row 1})")
~needle:"a dyn map's keys are keywords, as {:row value ...}";
rejects_check "bare literal at a want that is not a struct type"
(cell ^ "(defn f [] i32 {.row 1})")
~needle:"i32 is expected here, which is not a struct type";
(* A data type's name is an expectation, but not a specific enough one:
the want says D and a value of D is one of its cases. The existing
message for that already names them, so the bare path inherits it. *)
rejects_check "bare literal at a data type want names the cases"
"(defdata D [(A [x i32]) (B [y i32])]) (defn f [] D {.x 1})"
~needle:"write (D.A {.field value ...})";
(* Patterns are a separate parser ([dmap], not [expr]), so nothing here
reaches them: the struct pattern is still {name .field} and a bare
{.field v} is still not a pattern of any kind. Both rows answer the
same as they did before this feature — checked against the tip by
hand, not only asserted here. *)
accepts "a struct pattern still destructures in a let"
(cell ^ "(defn f [c Cell] i32 (let [{r .row} c] r))");
parse_rejects "braces are still not a pattern in a match arm"
(cell ^ "(defn f [c Cell] i32 (match c {r .row} r))")
~needle:"expected a pattern, found {r .row}";
(* The dyn map literal is untouched on every side of this. *)
accepts "a keyword-keyed literal is still a dyn map at a dyn want"
"(defn f [] dyn {:a 1 :b [2 3]})";
accepts "the empty braces are still an empty dyn map"
"(defn main [] i32 (let [m {}] (length m)))";
(* ── (Cell 1 2), positional ────────────────────────────────────── *)
accepts "positional struct construction"
(cell ^ "(defn f [] Cell (Cell 1 2))");
accepts "a zero-field struct called with no arguments"
"(defstruct E []) (defn f [] E (E))";
(* Exact arity, and the refusal names the first field it did not reach.
ZII is not withdrawn — it is what the designated form does, and the
message says so — but a positional list cannot say *which* field it
left out, so it is not allowed to leave one out. *)
rejects_check "positional with too few arguments names the missing field"
(cell ^ "(defn f [] Cell (Cell 1))")
~needle:".col has no value";
rejects_check "positional with too few also offers the designated form"
(cell ^ "(defn f [] Cell (Cell 1))")
~needle:"a struct value is written (Cell {.field value ...})";
rejects_check "positional with too many points at the extra argument"
(cell ^ "(defn f [] Cell (Cell 1 2 3))")
~needle:"Cell has 2 fields, and this is argument 3";
(* The mismatch is reported at the argument, in the words a call's
argument already gets; the note is what names the field, because a
positional call site is the one place the source does not show it. *)
rejects_check "positional argument of the wrong type"
"(defstruct Cell [row i32 col f32]) \
(defn f [] Cell (Cell 1 \"x\"))"
~needle:"expected f32, found str";
(* A struct type and a function cannot share a name — [collect]'s
[claimed] table spans every declaration kind — so the head of a call
resolves to exactly one of them and this refusal is what proves it. *)
rejects_check "a struct name and a function name cannot collide"
(cell ^ "(defn Cell [] i32 1)") ~needle:"Cell is defined twice";
(* Mixed spellings are not a thing: the struct-literal arm in [Parse]
takes the braces only as the *whole* argument list. *)
parse_rejects "a struct literal followed by more arguments"
(cell ^ "(defn f [] Cell (Cell {.row 1} 2))")
~needle:"a struct literal is (Cell {.field value ...})";
accepts "field through a pointer auto-derefs"
(cursor ^ "(defn f [c (Ptr Cursor)] i32 (.pos c))");
accepts "set through a pointer"
(cursor ^ "(defn f [c (Ptr Cursor)] () (set (.pos c) 1))");
rejects_check "field of a non-struct"
"(defn f [x i32] i32 (.pos x))" ~needle:"is not a struct";
(* ── Places ────────────────────────────────────────────────────── *)
accepts "a local is assignable"
"(defn f [] i32 (let [x 1] (set x 2) x))";
rejects_check "a parameter is not assignable"
"(defn f [x i32] () (set x 2))" ~needle:"a parameter is not assignable";
rejects_check "a constant is not assignable"
"(defconst k 1) (defn f [] () (set k 2))"
~needle:"k is a constant, and a constant is not assignable. \
Declare it with defonce if it has to change";
accepts "addr of a local gives a pointer"
(cursor ^ "(defn g [c (Ptr Cursor)] i32 (.pos c)) \
(defn f [s [u8]] i32 (let [c (Cursor {.src s})] (g (addr c))))");
rejects_check "addr of a non-place"
"(defn f [] () (addr (+ 1 2)))" ~needle:"addr takes the address of a place";
(* An Option's two fields exist in both backends' layouts — the tag and the
value — and the structural printer reads the tag through them. What has no
spelling in the source language is reaching one: [match] and [some] are
how an Option is opened, and a (.field o) that read the value of a None
would be reading storage the tag says is not there. [Addr (Pfield ...)]
on an Option was once recorded as a hole in both backends; this is the
pair of rows that says the hole has no door — the refusal is the field
access itself, so (addr ...) never gets a place to take the address of. *)
rejects_check "a field of an Option"
"(defstruct Point [x i32 y i32])\n\
(defn f [o (Option Point)] i32 (.x o))"
~needle:"(Option Point) is not a struct, so it has no fields";
rejects_check "the address of a field of an Option"
"(defstruct Point [x i32 y i32])\n\
(defn f [o (Option Point)] (Ptr i32) (addr (.x o)))"
~needle:"(Option Point) is not a struct, so it has no fields";
(* ── Option, some, match ───────────────────────────────────────── *)
accepts "some unwraps in an Option-returning function"
"(defn g [] (Option i32) None) (defn f [] (Option i32) (Some (some (g))))";
rejects_check "some outside an Option-returning function"
"(defn g [] (Option i32) None) (defn f [] i32 (some (g)))"
~needle:"must return an Option";
accepts "match on Option"
"(defn g [] (Option i32) None) \
(defn f [] i32 (match (g) (Some v) v None 0))";
rejects_check "match must be exhaustive"
"(defn g [] (Option i32) None) (defn f [] i32 (match (g) (Some v) v))"
~needle:"not exhaustive";
accepts "a wildcard arm is exhaustive"
"(defn g [] (Option i32) None) (defn f [] i32 (match (g) (Some v) v _ 0))";
rejects_check "match on a non-Option"
"(defn f [x [u8]] i32 (match x _ 0))" ~needle:"match works on an Option";
(* ── Names, order-independence, entry point ────────────────────── *)
accepts "mutually recursive, no forward declaration"
"(defn even? [n i32] bool (if (= n 0) true (odd? (- n 1)))) \
(defn odd? [n i32] bool (if (= n 0) false (even? (- n 1))))";
rejects_check "unknown name" "(defn f [] i32 nope)" ~needle:"unknown name";
rejects_check "unknown function" "(defn f [] i32 (nope 1))"
~needle:"unknown function";
(* ── len is a name, and length is the builtin ───────────────────────
[len] is short enough to want as a variable, so the builtin takes the
long word and the short one is left to programs. Shadowing had already
made a defn named after a builtin legal; what is new is that there is no
builtin here to shadow, so nothing warns and [builtin/] is not needed to
reach past anything. Four claims: the call is refused, the refusal says
what to write instead, the name binds in every position, and a defn under
it earns no shadowing warning. *)
(* ── Operators spelled as other languages spell them ─────────────── *)
rejects_check "not= names !="
"(defn f [a i32 b i32] bool (not= a b))"
~needle:"there is no not=. Not-equal is !=. Write (!= a b)";
accepts "and the call it writes compiles"
"(defn f [a i32 b i32] bool (!= a b))";
rejects_check "not= over calls says which name to change"
"(defn f [a i32 b i32] bool (not= (+ a 1) b))"
~needle:"Write != in its place";
rejects_check "/= is not a package call"
"(defn f [a i32 b i32] bool (/= a b))" ~needle:"Write (!= a b)";
rejects_check "=/= is not a package call"
"(defn f [a i32 b i32] bool (=/= a b))" ~needle:"Write (!= a b)";
rejects_check "== names ="
"(defn f [a i32 b i32] bool (== a b))" ~needle:"Write (= a b)";
rejects_check "&& over bools names and"
"(defn f [a bool b bool] bool (&& a b))" ~needle:"write (and a b)";
accepts "and that call compiles" "(defn f [a bool b bool] bool (and a b))";
rejects_check "|| over bools names or"
"(defn f [a bool b bool] bool (|| a b))" ~needle:"write (or a b)";
rejects_check "! names not"
"(defn f [a bool] bool (! a))" ~needle:"Write (not a)";
rejects_check "a ! at an arity not does not take gets not's shape"
"(defn f [a bool b bool] bool (! a b))" ~needle:"called as (not x)";
accepts "a bare and compiles" "(defn f [] bool (and))";
accepts "a program's own not= is its own"
"(defn not= [a i32 b i32] bool (!= a b)) \
(defn f [a i32 b i32] bool (not= a b))";
(* ── A defn with no return type ───────────────────────────────────
The body's first form lands in the return slot and parses as a type
application; the refusal names the missing return type rather than the
form's head. *)
rejects_check "a body form in the return slot is a missing return type"
"(defn f [s str] (dotimes [i (length s)] (println i)))"
~needle:"f has no return type: (dotimes ...) stands where the return type goes";
rejects_check "and says how a function returning nothing is written"
"(defn f [a i32 b i32] (+ a b))"
~needle:"a function that returns nothing writes () there";
accepts "the fix compiles"
"(defn f [s str] () (dotimes [i (length s)] (println i)))";
accepts "a type application in the slot is still a type"
"(defn f [] (Option i32) None)";
rejects_check "a misspelled constructor is a near miss"
"(defn f [] (Optoin i32) None)" ~needle:"unknown type Optoin — did you mean Option?";
rejects_check "a lowercase vec is Vec"
"(defn f [] (vec i32) (vec-new i32))" ~needle:"unknown type vec — did you mean Vec?";
rejects_check "a lowercase ptr is Ptr"
"(defn f [p (Ptr i32)] (ptr i32) p)" ~needle:"unknown type ptr — did you mean Ptr?";
rejects_check "a lowercase option is Option"
"(defn f [] (option i32) None)" ~needle:"unknown type option — did you mean Option?";
rejects_check "a lowercase map is Map"
"(defn f [] (map i32 i32) (map-new i32 i32))"
~needle:"unknown type map — did you mean Map?";
rejects_check "a map over values in the slot is a body form"
"(defn f [inc i32 xs i32] (map inc xs))" ~needle:"f has no return type";
rejects_check "an unknown capitalised head keeps the generics sentence"
"(defn f [] (Pair i32) 0)" ~needle:"Pair takes no type arguments";
rejects_check "a misspelled plain return type is still an unknown type"
"(defn f [] i3 0)" ~needle:"unknown type i3";
rejects_check "len is not a builtin"
"(defn f [s [i32]] i32 (len s))" ~needle:"there is no len";
rejects_check "and the refusal writes the call out"
"(defn f [s [i32]] i32 (len s))" ~needle:"Write (length s)";
(* What it suggests has to compile, and [length] takes exactly one argument.
So the reader's own argument is written back only when there is one of
it: at any other arity the shape is suggested instead, because a call
with three arguments in it would be refused a second time the moment it
was pasted. Three arities, because the failure was silent at all of
them. *)
rejects_check "a len at the wrong arity is not written back out"
"(defn f [s [i32]] i32 (len s 1))" ~needle:"Write (length v)";
rejects_check "and neither is a len with no arguments"
"(defn f [] i32 (len))" ~needle:"Write (length v)";
rejects_check "and neither is one with a great many"
"(defn f [s [i32]] i32 (len s s s s s))" ~needle:"Write (length v)";
(* An argument with structure inside it is the stand-in too, at the one
arity that does spell: a form written back half-quoted would not
compile. *)
rejects_check "an argument that is a call is stood in for"
"(defn f [s [i32]] i32 (len (slice s 0 1)))" ~needle:"Write (length v)";
accepts "len is an ordinary binding"
"(defn f [s [i32]] i32 (let [len (length s)] (+ len 1)))";
accepts "and an ordinary parameter"
"(defn f [len i32] i32 (+ len 1))";
accepts "and an ordinary global"
"(defonce len i32 0)\n(defn f [] i32 (do (set len 3) len))";
accepts "and a function a program defines and calls"
"(defn len [s [i32]] i32 (length s))\n\
(defn f [s [i32]] i32 (len s))";
check "and a defn called len shadows nothing, so it is not warned about"
(Check.shadowed_builtins
(program "(defn len [s [i32]] i32 (length s))") = []);
(* ── Did-you-mean, and the dot habit ───────────────────────────────
[near_miss] was written, tested and wired to the type tables alone, so a
mistyped *value* got the bare refusal. The candidate list at a value
position is the scope, the globals and the functions — and, at a call,
the builtin names, which live in no table the checker keeps. No type
names on either list: a symbol written where a value goes was not a
mistyped struct. *)
rejects_check "a mistyped local is a near miss"
"(defn f [] i32 (let [total 1] totl))" ~needle:"did you mean total?";
rejects_check "a mistyped defn is a near miss"
"(defn helper [x i32] i32 x) (defn f [] i32 (helpr 1))"
~needle:"unknown function helpr — did you mean helper?";
rejects_check "a mistyped builtin is a near miss"
"(defn f [] () (prinltn \"hi\"))"
~needle:"unknown function prinltn — did you mean println?";
(* [p.x] is the habit from C, Go and Odin, and the checker can see exactly
what the head is, so the refusal names the accessor rather than reporting
a name nobody wrote. The declaration comes along as a note, which is
[declared_note]'s shape. *)
rejects_check "dot-infix field access names the accessor"
"(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] p.x))"
~needle:"a field is read with an accessor, so write (.x p)";
rejects_check "and says so when the field is not there either"
"(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] p.z))"
~needle:"(.z p), and P has no field z";
rejects_check "and in a set it is the place that is spelled"
"(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] (set p.x 2) 0))"
~needle:"a field is assigned through an accessor, so write (set (.x p) ...)";
accepts "which is a real form"
"(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] (set (.x p) 2) (.x p)))";
rejects_check "a dotted head that is not a struct says what it is"
"(defn f [] i32 (let [n 1] n.x))" ~needle:"n is i32, which has no fields";
rejects_check "a dotted dyn head points to the accessor"
"(defn f [] i32 (let [s {:p 1}] (println s.p) 0))"
~needle:"s is dyn, and its :p is reached with (.p s)";
rejects_check "and to the place in a set"
"(defn f [] i32 (let [s {:p 1}] (set s.p 2) 0))"
~needle:"s is dyn, and its :p is reached with (set (.p s) ...)";
(* The fourth shape: nothing is bound under the head either, so the message
claims nothing about what q is — only that the dot is not the operator
the writer took it for. *)
rejects_check "and an unbound head claims nothing about it"
"(defn f [] i32 q.x)"
~needle:"unknown name q.x — nothing named q is in scope either. A field \
is reached through an accessor, (.x q), not with a dot";
(* A capitalised head keeps the case spelling it always had: [Shape.Circle]
is real here, so a typo in one is not the dot habit. *)
(* Both sides of the rule, because only the pair says what it is. A
capitalised head is a real spelling here — Shape.Circle — so a typo in
one is a mistyped case and gets none of the accessor advice; the same
text with a lowercase head does. The earlier spelling of this row used
(data ...), which is not a top-level form at all, so it refused as an
unknown top-level form and the needle "unknown" matched that instead of
anything this rule does. *)
(match (try ignore (checked "(defdata Shape [(Circle [r f64])]) \
(defn f [] Shape Shape.Crcle)"); None
with Loc.Error d -> Some d) with
| Some d ->
check "a capitalised dotted name gets no accessor advice"
(contains d.Loc.dmsg "unknown name Shape.Crcle"
&& not (contains d.Loc.dmsg "accessor"))
| None -> check "a mistyped case is refused" false);
(match (try ignore (checked "(defdata Shape [(Circle [r f64])]) \
(defn f [] Shape shape.Crcle)"); None
with Loc.Error d -> Some d) with
| Some d ->
check "and a lowercase one does"
(contains d.Loc.dmsg
"nothing named shape is in scope either. A field is reached through \
an accessor, (.Crcle shape), not with a dot")
| None -> check "a lowercase dotted name is refused" false);
(* [(Pair i32)] in a defonce falls down the value fork now that the third
element takes either reading, and the generics answer the type fork gave
it has to be reachable from here too. *)
(* A capitalised head with arguments is a *type* given type arguments; with
no such struct declared, the sentence says how one is. *)
rejects_check "a capitalised call with arguments is a generic type"
"(defonce x (Pair i32)) (defn f [] i32 0)"
~needle:"no struct or generic struct Pair is declared";
accepts "and the generic function it points at is"
"(defn pair-fst [a $t b $u] $t (do b a))\n\
(defn main [] () (println (pair-fst 1 true)))";
rejects_check "defined twice" "(defn f [] ()) (defn f [] ())"
~needle:"defined twice";
(* ── The randomness surface ────────────────────────────────────────
Four names the prelude does not have, each refused with the name it does
have. A reader who arrives at one of these has copied a line from
somewhere and needs the spelling that works, so the message is checked on
the name it hands back and every call it prints is compiled below. Both
positions, because a bare name and a call take different paths through
the checker and a Lisp-1 makes the bare one a real thing to write. *)
rejects_check "no rand-u32" "(defn f [] u64 (rand-u32))"
~needle:"there is no rand-u32 — a random integer is (rand-int)";
rejects_check "no rand-f32" "(defn f [] f64 (rand-f32))"
~needle:"there is no rand-f32 — a random float in [0, 1) is (rand)";
rejects_check "no rand-i32-range" "(defn f [] i64 (rand-i32-range 0 10))"
~needle:"there is no rand-i32-range";
rejects_check "no rand-f32-range" "(defn f [] f64 (rand-f32-range 0.0 1.0))"
~needle:"there is no rand-f32-range";
(* And the newer machinery is still in front of every name that is not one
of the four: a typo near one of them is a typo, and gets the did-you-mean
the checker has for typos rather than the sentence about a name nobody
wrote. A dotted head keeps the dot-access reading for the same reason. *)
rejects_check "a near miss of a rand name is still a near miss"
"(defn f [] i64 (rand-int-rang 0 10))" ~needle:"did you mean";
rejects_check "and a dotted name is still read as field access"
"(defstruct Point [x i32]) (defn f [p Point] i32 p.x)"
~needle:"accessor";
rejects_check "no rand-f32, named rather than called"
"(defn f [] i32 (let [g rand-f32] 0))" ~needle:"there is no rand-f32";
rejects_check "no rand-i32-range, named rather than called"
"(defn f [] i32 (let [g rand-i32-range] 0))"
~needle:"there is no rand-i32-range";
(* And the five names it does have, at the types it has them at, with every
call the four refusals print. A suggestion that does not compile is worse
than no suggestion, so each is here as well as in the message. *)
infers "rand-int is a u64" "(rand-int)" "u64";
infers "rand is an f64" "(rand)" "f64";
infers "rand-bool is a bool" "(rand-bool)" "bool";
infers "rand-int-range is an i64" "(rand-int-range 0 10)" "i64";
infers "rand-float-range is an f64" "(rand-float-range 0.0 1.0)" "f64";
accepts "the 32 bits a rand-u32 caller wanted"
"(defn f [] u32 (u32 (>> (rand-int) 32)))";
accepts "the f32 a rand-f32 caller wanted" "(defn f [] f32 (f32 (rand)))";
accepts "the i32 a rand-i32-range caller wanted"
"(defn f [] i32 (i32 (rand-int-range 0 10)))";
accepts "main with no parameters and no return" "(defn main [] ())";
accepts "main with argv and a status" "(defn main [args [str]] i32 0)";
rejects_check "main with a wrong parameter" "(defn main [n i32] ())"
~needle:"main takes no parameters";
rejects_check "main returning the wrong type" "(defn main [] bool true)"
~needle:"main returns i32";
(* And both of them point at the [main] that is wrong. They used to open with
<unknown>:0:0 — the checker's rule about the entry point is the one place
that had a name and no span, because [env.locs] records where a *type* was
declared and a function is not in it. The span is the whole difference
between a message you can act on and a message you have to go looking for,
so it is pinned here rather than left to the reader of a report. *)
let main_at name src =
match checked src with
| _ ->
incr failures;
Printf.printf "FAIL %s: expected a type error\n" name
| exception Loc.Error { Loc.dloc; _ } ->
let got = Loc.to_string dloc in
if got <> "<test>:1:7" then begin
incr failures;
Printf.printf "FAIL %s\n wanted: %s\n got: %s\n"
name "<test>:1:7" got
end
in
main_at "a wrong main parameter points at main" "(defn main [n i32] ())";
main_at "a wrong main return type points at main" "(defn main [] bool true)";
(* ── Classes and generic functions — M2 item 6 ─────────────────── *)
(* A class is a constructor and a shape tag. The constructor is the class's
own name, positional over the slots, and everything that reads or writes
an instance is the dyn map operation that was already there. *)
accepts "a class and its constructor"
"(defclass point [x y])\n\
(defn main [] i32 (let [p (point 1 2)] (if (= (get p :x) 1) 0 1)))";
accepts "a class with no slots"
"(defclass marker [])\n(defn main [] i32 (let [m (marker)] 0))";
accepts "class-of answers nil for anything that is not an instance"
"(defn main [] i32 (if (= (class-of 1) nil) 0 1))";
(* type-of answers a class instance's name, so a class may not take the
name of a kind: :map would mean a plain map and an instance at once.
bool, int and float are also built-in types; they get this sentence. *)
List.iter
(fun k ->
rejects_check ("a class may not be named " ^ k)
(Printf.sprintf "(defclass %s [a])\n(defn main [] i32 0)" k)
~needle:(Printf.sprintf "Name the class %s-value" k))
[ "nil"; "bool"; "int"; "float"; "text"; "vec"; "map"; "keyword"; "char" ];
accepts "the fix a class-named-kind refusal offers compiles"
"(defclass map-value [a])\n\
(defn main [] i32 (if (= (type-of (map-value 1)) :map-value) 0 1))";
(* A char literal past ASCII is not a byte: it is refused by its name at a
u8, whichever operand of = it is, and pushing it into bytes too. *)
rejects_check "a non-ASCII char is not a u8"
"(defn main [] i32 (let [b (the u8 1)] (if (= b \\é) 1 0)))"
~needle:"\\é is 2 bytes in UTF-8, not one, so it is not a u8";
rejects_check "and not on the left of = either"
"(defn main [] i32 (let [b (the u8 1)] (if (= \\日 b) 1 0)))"
~needle:"\\日 is 3 bytes in UTF-8";
rejects_check "nor pushed into bytes"
"(defn main [] i32 (let [v (vec-new u8)] (push v \\é) 0))"
~needle:"Write the str \"é\" for its bytes";
rejects_check "a code point past a u16"
"(defn main [] i32 (let [b (the u16 1)] (if (= b \\😀) 1 0)))"
~needle:"\\😀 is code point 128512, which does not fit in a u16";
accepts "an ASCII char is a u8"
"(defn main [] i32 (let [b (the u8 97)] (if (= b \\a) 0 1)))";
rejects_check "type-of takes one argument"
"(defn main [] i32 (let [k (type-of 1 2)] 0))" ~needle:"type-of";
(* The constructor is an ordinary function, so its arity is the ordinary
arity check and a wrong one names the class. *)
rejects_check "a constructor takes one argument per slot"
"(defclass point [x y])\n(defn main [] i32 (let [p (point 1)] 0))"
~needle:"point";
(* A slot vector is a defn's parameter vector: a name followed by a type
is a typed slot, a name followed by another name is an untyped one. The
type is what a stored dyn value is checked against, so it is one a dyn
value can be checked as, and nothing else. *)
accepts "typed slots, and untyped ones beside them"
"(defclass state [pause bool step bool n i32 tag])\n\
(defn main [] i32 (let [s (state false true 3 :x)] (if (= (get s :n) 3) 0 1)))";
accepts "a class and an Option as slot types"
"(defclass point [x f64])\n\
(defclass node [at point next (Option node) w (Option i32)])\n\
(defn main [] i32 (let [n (node (point 1) nil nil)] 0))";
rejects_check "an Option of dyn is not a slot type"
"(defclass point [x (Option dyn)])\n(defn main [] i32 0)"
~needle:"the slot x of point is declared (Option dyn)";
rejects_check "a slot's type is one a dyn value can be checked as"
"(defclass point [x (Ptr i64)])\n(defn main [] i32 0)"
~needle:"the slot x of point is declared (Ptr i64)";
rejects_check "a capitalised name in a slot vector is an unknown type"
"(defclass point [x Widget])\n(defn main [] i32 0)"
~needle:"unknown type Widget";
rejects_check "a slot's type is resolved like any other"
"(defclass point [x f65])\n(defn main [] i32 0)"
~needle:"did you mean f64";
(* The slot is a place: its class declares it, so it always exists. *)
accepts "set writes a class slot"
"(defclass state [pause bool])\n\
(defn main [] i32 (let [s (state false)] (set (get s :pause) true) \
(if (get s :pause) 0 1)))";
rejects_check "a class slot has no address"
"(defclass state [pause bool])\n\
(defn main [] i32 (let [s (state false)] (addr (get s :pause)) 0))"
~needle:"addr takes the address of a place";
rejects_check "a class does not name a slot twice"
"(defclass point [x x])\n(defn main [] i32 0)"
~needle:"names the slot x twice";
(* Both halves of the dispatch, and the fact that they are one mechanism:
a defgeneric is a defmulti whose dispatch is (class-of first-argument),
so a method written for a class is a method written for its keyword. *)
accepts "class dispatch"
"(defclass point [x y])\n\
(defgeneric area [self] dyn)\n\
(defmethod area point [p] (* (get p :x) (get p :y)))\n\
(defn main [] i32 (if (= (area (point 2 3)) 6) 0 1))";
accepts "arbitrary dispatch, with a fallback"
"(defmulti describe [x] dyn (get x :kind))\n\
(defmethod describe :square [s] 1)\n\
(defmethod describe :else [s] 2)\n\
(defn main [] i32 (if (= (describe {:kind :round}) 2) 0 1))";
accepts "a method may name its parameters whatever it likes"
"(defclass point [x y])\n\
(defgeneric area [self] dyn)\n\
(defmethod area point [whatever] (get whatever :x))\n\
(defn main [] i32 0)";
(* The rebinding that gives a method its own parameter names is parallel.
A [let] binds in sequence, so the pairwise spelling reads a name it has
just bound: these two type-check either way and the values are what is
wrong, which is why dyn-class.flan is where they are really pinned. What
is pinned here is that both shapes are legal at all. *)
accepts "a method may reverse its generic's parameter names"
"(defmulti g [a b] () (class-of a))\n\
(defmethod g :else [b a] (println b) (println a))\n\
(defn main [] i32 0)";
accepts "a method may shift its generic's parameter names along"
"(defmulti g [a b] () (class-of a))\n\
(defmethod g :else [b c] (println b) (println c))\n\
(defn main [] i32 0)";
accepts "a method may be written above its generic"
"(defclass point [x y])\n\
(defmethod area point [p] (get p :x))\n\
(defgeneric area [self] dyn)\n\
(defn main [] i32 0)";
(* A generic with no methods at all is legal and always misses; that is a
run-time answer (the NoMethod condition), not a compile-time refusal. *)
accepts "a generic with no methods"
"(defgeneric area [self] dyn)\n(defn main [] i32 0)";
rejects_check "a method needs a generic"
"(defclass point [x y])\n(defmethod area point [p] 1)\n\
(defn main [] i32 0)"
~needle:"no defgeneric or defmulti names area";
rejects_check "a method dispatching on an unknown class"
"(defgeneric area [self] dyn)\n(defmethod area square [p] 1)\n\
(defn main [] i32 0)"
~needle:"no defclass names square";
rejects_check "two methods for one dispatch value"
"(defclass point [x y])\n\
(defgeneric area [self] dyn)\n\
(defmethod area point [p] 1)\n\
(defmethod area point [p] 2)\n\
(defn main [] i32 0)"
~needle:"already has a method for point";
(* A class's name and its keyword are one value: a class stands for the
keyword its instances carry, so these two methods are the same method
written twice and the second would be dead code. *)
rejects_check "a class and its keyword are one dispatch value"
"(defclass point [x y])\n\
(defgeneric area [self] dyn)\n\
(defmethod area point [p] 1)\n\
(defmethod area :point [p] 2)\n\
(defn main [] i32 0)"
~needle:"already has a method for :point";
rejects_check "two :else methods for one generic"
"(defmulti d [x] dyn x)\n\
(defmethod d :else [x] 1)\n\
(defmethod d :else [x] 2)\n\
(defn main [] i32 0)"
~needle:"already has a method for :else";
rejects_check "a method's arity is its generic's"
"(defclass point [x y])\n\
(defgeneric area [self] dyn)\n\
(defmethod area point [p q] 1)\n\
(defn main [] i32 0)"
~needle:"and this method of it takes 2";
rejects_check "a generic's parameter is a bare name"
"(defgeneric area [self (Ptr i64)] dyn)\n(defn main [] i32 0)"
~needle:"parameter is a bare name";
rejects_check "a defgeneric has no body"
"(defgeneric area [self] dyn (class-of self))\n(defn main [] i32 0)"
~needle:"It has no body";
rejects_check "a defmulti has one"
"(defmulti describe [x] dyn)\n(defn main [] i32 0)"
~needle:"the body is the dispatch";
rejects_check "a defgeneric needs something to dispatch on"
"(defgeneric area [] dyn)\n(defn main [] i32 0)"
~needle:"dispatches on the class of its first";
rejects_check "a dispatch value is written out, not computed"
"(defmulti d [x] dyn x)\n(defmethod d (f 1) [x] 1)\n\
(defn main [] i32 0)"
~needle:"It is written out, not computed";
(* A method has no return slot: the generic states the type once, for all
of them. What that means for anyone writing the defn spelling by habit
is that the slot they would have written is read as the first form of
the body, and a lone type name there is an unknown name. *)
rejects_check "a method has no return slot"
"(defclass point [x y])\n\
(defgeneric area [self] dyn)\n\
(defmethod area point [p] dyn (get p :x))\n\
(defn main [] i32 0)"
~needle:"dyn";
(* A class and a function are one namespace, as a defn and a defonce are:
the constructor is a defn, so the collision is the ordinary one. *)
rejects_check "a class collides with a function of the same name"
"(defclass point [x y])\n(defn point [] i32 0)\n(defn main [] i32 0)"
~needle:"point";
(* ── Unconstrained operators, and everything past milestone 2 ──── *)
(* M2 queue item 5: typed = and != grow strings, bytewise. Ordering does
not — there is no collation the language has picked, so < stays
refused, on the grounds that a string is equatable but not ordered. *)
accepts "typed = on strings" "(defn f [] bool (= \"a\" \"b\"))";
accepts "typed != on strings" "(defn f [] bool (!= \"a\" \"b\"))";
rejects_check "no built-in < on strings"
"(defn f [] bool (< \"a\" \"b\"))" ~needle:"orders machine numbers and enums";
rejects_check "no built-in <= on strings"
"(defn f [] bool (<= \"a\" \"b\"))" ~needle:"orders machine numbers and enums";
rejects_check "no built-in > on strings"
"(defn f [] bool (> \"a\" \"b\"))" ~needle:"orders machine numbers and enums";
rejects_check "no built-in >= on strings"
"(defn f [] bool (>= \"a\" \"b\"))" ~needle:"orders machine numbers and enums";
(* (Vec T) is built. What is still refused is the arity: one element type,
and a near-miss there would otherwise resolve to a type variable and come
back as generics. *)
rejects_check "Vec takes one type" "(defn f [x (Vec i32 i32)] ())"
~needle:"exactly one type";
(* (Map K V) is the map type spelling, and now the only one: the brace form
is withdrawn from type position, so braces there are refused with the
surviving spelling named. What is refused here is the arity, for the same
reason Vec's is: a near-miss would otherwise resolve to a type variable
and come back as generics. *)
rejects_check "Map takes two types" "(defn f [x (Map i32)] ())"
~needle:"exactly two types";
rejects_check "Result is milestone 6" "(defn f [] (Result i32 i32) None)"
~needle:"(Result T E) is not implemented";
(* ── The region rule, spec-memory.md's arena rule ────────────────────
The compile-time half of it, which is the only half a checker row can
see: which declarations are admitted, and which are still refused. The
run-time half — the branch that decides whether a given construction site
met a region allocator — is programs/arena-region.flan, because it needs
a program that dies to say anything. *)
(* The recursive dynamic value, which is the whole point: a union naming
itself through a container. Admitted because such a container can only
have been built against a region, and one free-all takes the graph. *)
accepts "a data type case holding a Vec of itself"
"(defdata Value [Nil (List [items (Vec Value)])])";
accepts "a data type case holding a Map of itself"
"(defdata Value [Nil (Table [entries (Map str Value)])])";
(* Since the second repeal the plain case is admitted too: a struct or a
case holding a heap-backed Vec copies as bytes, the copies alias one
buffer, and a free through two copies is the program's bug — Odin's
contract exactly. These pin the admission. *)
accepts "a data type case holding a plain Vec"
"(defdata Value [Nil (Bytes [bs (Vec u8)])])";
accepts "a struct field holding a plain Vec"
"(defstruct B [buf (Vec u8)])";
(* free does not recurse and does not quietly release the outer block: it
names free-all, which is the operation that actually releases the graph. *)
rejects_check "free on a container of owning elements"
"(defdata V [Nil (L [xs (Vec V)])])\n\
(defn f [v (Vec V)] () (free v))"
~needle:"Write (free-all a) on the region";
(* clone is refused for a reason the region does *not* dissolve: it promises
an independent copy and a bytewise one is an alias. *)
rejects_check "clone on a container of owning elements"
"(defdata V [Nil (L [xs (Vec V)])])\n\
(defn f [v (Vec V)] () (let [c (clone v)] (free c)))"
~needle:"cannot be cloned";
rejects_check "clone on a slice of dyn, at the clone"
"(defonce pair [2 dyn])\n(defn make [] [dyn] (clone (slice pair)))"
~needle:"[dyn] cannot be cloned — its elements hold a dyn";
rejects_check "clone on a slice of structs holding a dyn"
"(defstruct B [d dyn])\n(defn make [xs [B]] [B] (clone xs))"
~needle:"[B] cannot be cloned — its elements hold a dyn";
rejects_check "clone on a slice of owning elements"
"(defn f [v [(Vec i32)]] i32 (length (clone v)))"
~needle:"[(Vec i32)] cannot be cloned";
(* into with no (map f) pushes the source's elements as they stand, which
for an owning element shares its block — pushing through the copy then
frees the source's. The fix it names is programs/into-owning.flan. *)
rejects_check "into copying owning elements, refused at the source"
"(defn f [a Allocator] i32\n\
\ (let [v (vec-new (Vec i32) a)\n\
\ w (into v (vec-new (Vec i32) a) (filter nonempty?))] (length w)))\n\
(defn nonempty? [x (Vec i32)] bool (> (length x) 0))"
~needle:"into copies each element of v as it stands, and an element of v \
is a (Vec i32), which owns storage — the copy would share each \
element's block with v, and growing either one frees the block \
the other points at. Add (map clone) to the chain, which copies \
what each element owns: (into v (vec-new (Vec i32) a) (filter \
nonempty?) (map clone))";
accepts "into with (map clone) over owning elements"
"(defn f [a Allocator] i32\n\
\ (let [v (vec-new (Vec i32) a)\n\
\ w (into v (vec-new (Vec i32) a) (map clone))] (length w)))";
accepts "into of plain elements is untouched"
"(defn f [v [i32]] () (let [w (into v (vec-new i32))] (free w)))";
rejects_check "into copying elements clone cannot copy, explained"
"(defstruct B [xs (Vec i32)])\n\
(defn f [v [B] a Allocator] i32 (let [w (into v (vec-new B a))] (length w)))"
~needle:"Nothing copies what a B owns, so no copy of v can stand on its \
own";
rejects_check "clone's refusal names a clone of each element"
"(defn f [v [(Vec i32)]] i32 (length (clone v)))"
~needle:"push a (clone x) of each element into it";
(* A program's names cannot change what the prelude means: a global or a
type spelled like a built-in type is refused where it is declared, and
the rest are programs/prelude-names.flan. *)
rejects_check "a global named like a built-in type"
"(defonce u8 i32)"
~needle:"u8 is a type, so it cannot also name a global";
rejects_check "a type named like a built-in type"
"(defstruct i32 [x i32])"
~needle:"i32 is a built-in type, so it cannot be declared again";
accepts "a global and a type named after the prelude's type variables"
"(defonce t [4 i32])\n(defstruct k [x i32])\n(defenum v [lo hi])";
accepts "clone on a slice, with and without an allocator"
"(defn f [v [f64] a Allocator] i32 (+ (length (clone v)) (length (clone v a))))";
(* ── A move-only global ─────────────────────────────────────────────
Legal, started zeroed, and since the repeal of the flow analysis it is
ownable like anything else: passing, binding and freeing one all
type-check, and the process-long lifetime is the program's to keep. The
accepted side is programs/vec-global.flan. What is still refused about
one is declaration-shaped, below. *)
(* And the two declaration shapes. The computed one is the half that changed:
there is an init-at-startup path now, on both backends, so a global Vec
loaded by its own initialiser is an ordinary program — which is what the
commented-out line in sand.flan was reaching for. The defconst is refused
as it always was, and for a reason the startup path does not touch: a
constant is not an assignable place, so nothing could ever load it. *)
accepts "a global Vec with a computed initialiser"
"(defonce g (Vec u8) (slurp \"game-data.edn\")) (defn f [] ())";
rejects_check "a move-only global as a defconst"
"(defconst g (Vec u8) (slurp \"game-data.edn\")) (defn f [] ())"
~needle:"is a defonce, not a defconst";
(* uninit is the one initialiser a container still refuses, and it is a
different rule: a garbage block pointer is not a garbage number. *)
rejects_check "a global Vec declared uninit"
"(defonce g (Vec u8) uninit) (defn f [] ())"
~needle:"Write (defonce g (Vec u8)) with no initialiser";
(* ── What may be filled with raw bytes ─────────────────────────────
[(filled b)] and [(dead-beef)] are [zeroed]'s siblings, and the
boundary is the whole of what is new about them: zero is a value every
type can have and 0xDE is not, so the checker says which types survive
arbitrary bytes. The accepting side is programs/fill.flan; what is here
is the catalogue of what it refuses and why each refusal is the runtime's
and not a matter of taste.
The dyn row is the one that would corrupt the collector: a struct holding
a dyn is rooted with a descriptor naming that word's offset, so a filled
one is a root pointing at nothing. *)
accepts "a fixed array of numbers may be filled"
"(defn f [] () (let [a (array 4 u8)] (set a (filled 0xFF))))";
accepts "a struct of numbers may be dead-beefed"
"(defstruct S [a i32 b f64]) \
(defn f [] () (let [s (S {})] (set s (dead-beef))))";
(* Both arities, and a pattern that is not a literal — the operand is an
ordinary u32 expression, which is the byte arm's rule at four times the
width. *)
accepts "dead-beef takes a pattern"
"(defn f [] () (let [a (array 4 u8)] (set a (dead-beef 0xBAADF00D))))";
accepts "dead-beef takes a computed pattern"
"(defn f [p u32] () (let [a (array 4 u8)] (set a (dead-beef p))))";
rejects_check "a struct holding a dyn cannot be filled"
"(defstruct S [a i32 d dyn]) \
(defn f [] () (let [s (S {})] (set s (dead-beef))))"
~needle:"a root pointing at nothing";
rejects_check "a Vec cannot be filled"
"(defn f [] () (let [v (vec-new i32)] (set v (filled 0xFF))))"
~needle:"frees a wild address";
rejects_check "a string cannot be filled"
"(defn f [] () (let [s \"hi\"] (set s (filled 0xFF))))"
~needle:"a length every bounds check believes";
accepts "a pointer field may be filled"
"(defstruct S [p (Ptr i32)]) \
(defn f [] () (let [s (S {})] (set s (filled 0xFF))))";
(* The one refusal that is about the two backends rather than the runtime:
LLVM reads a bool's low bit and x86 compares the whole byte, so 0xDE is
false on one and true on the other. Byte-identical behaviour across the
backends is what this feature is pinned on, so the divergence is refused
rather than documented. *)
rejects_check "a bool cannot be filled"
"(defn f [] () (let [b false] (set b (filled 0xFF))))"
~needle:"would not even agree with itself";
(* An untagged union is filled over its whole size when every member may be
filled, and refused for the member that may not. *)
accepts "a union of numbers may be filled"
"(defunion U [a i32 b f64]) \
(defn f [] () (let [u (U {})] (set u (dead-beef))))";
rejects_check "a union with a dyn member cannot be filled"
"(defunion U [a i32 d dyn]) \
(defn f [] () (let [u (U {})] (set u (dead-beef))))"
~needle:"a root pointing at nothing";
(* Each of the tagged and address-carrying types names its own reason, so
the reasons cannot quietly merge into one that is false for some. *)
rejects_check "a function value cannot be filled"
"(defn g [] ()) (defn f [] () (let [h g] (set h (dead-beef))))"
~needle:"it is a code address";
rejects_check "an enum cannot be filled"
"(defenum K [lo 0 hi 1]) \
(defn f [k K] () (let [e k] (set e (dead-beef))))"
~needle:"the members it declared";
rejects_check "an Option cannot be filled"
"(defn f [] () (let [o (Some 1)] (set o (dead-beef))))"
~needle:"whether the value is there";
(* A data type's tag is a case index, and no byte pattern names a real
case. The type itself is what the message names, because a data type
overlays its cases. *)
rejects_check "a data type cannot be filled"
"(defdata U [(A [x i32]) (B [y i32])]) \
(defn f [] () (let [u (U.A {.x 1})] (set u (filled 0xFF))))"
~needle:"names a case";
(* [zeroed]'s own refusal, worn by both siblings: a fill is the bytes of
whatever type is expected of it, and in a position that expects nothing
there is no type and nothing to fill. This is the shape's cost and it is
paid on purpose — the alternative was a second, place-taking spelling
for an operation [set] already expresses. *)
rejects_check "a fill in a position with no expected type"
"(defn f [] () (print (filled 0xFF)))"
~needle:"needs to know the type it is filling";
rejects_check "a dead-beef in a position with no expected type"
"(defn f [] () (print (dead-beef)))"
~needle:"(the [4 u32] (dead-beef))";
(* The byte is a u8 and the ordinary literal rule applies to it — there is
no range check of this builtin's own, and there does not need to be. *)
rejects_check "a fill byte out of range"
"(defn f [] () (let [a (array 4 u8)] (set a (filled 300))))"
~needle:"does not fit in u8";
rejects_check "filled takes exactly one byte"
"(defn f [] () (let [a (array 4 u8)] (set a (filled))))"
~needle:"takes 1 argument";
rejects_check "dead-beef takes at most one pattern"
"(defn f [] () (let [a (array 4 u8)] (set a (dead-beef 1 2))))"
~needle:"takes the pattern or nothing at all, given 2";
(* The pattern is four bytes, so a wider literal is a typo rather than
something to truncate. The refusal is [in_range]'s, located at the
literal — this builtin has no range check of its own and does not need
one, exactly as the byte arm does not. *)
rejects_check "a dead-beef pattern out of u32 range"
"(defn f [] () (let [a (array 4 u8)] (set a (dead-beef 0x1DEADBEEF))))"
~needle:"does not fit in u32";
(* A pointer or slice into the frame, handed out of it. *)
rejects_check "returning the address of a local"
"(defn mk [] (Ptr i32) (let [x (i32 42)] (addr x)))"
~needle:"mk returns the address of x";
rejects_check "returning the address of a local with return"
"(defn mk [] (Ptr i32) (let [x (i32 42)] (return (addr x))))"
~needle:"mk returns the address of x";
rejects_check "returning the address of a local under a defer"
"(defn mk [] (Ptr i32) (let [x (i32 42)] (defer (println 1)) \
(return (addr x))))"
~needle:"mk returns the address of x";
rejects_check "returning a slice of a local array"
"(defn mk [] [i32] (let [a [1 2 3 4]] (slice a)))"
~needle:"mk returns a slice of a";
rejects_check "returning a local bound to a slice of a local array"
"(defn mk [] [i32] (let [a [1 2 3 4] s (slice a 1 3)] s))"
~needle:"(clone (slice a 1 3))";
rejects_check "returning a slice of an array parameter"
"(defn mk [a [4 i32]] [i32] (slice a))"
~needle:"mk returns a slice of a";
rejects_check "returning the address of a local array's element"
"(defn mk [] (Ptr i32) (let [a [1 2 3 4]] (addr (at a 2))))"
~needle:"mk returns an address inside a";
rejects_check "returning the address of a local from one if arm"
"(defn mk [c bool] (Ptr i32) (let [x (i32 1)] (if c (addr x) (addr x))))"
~needle:"declare mk to return i32";
rejects_check "storing a slice of a local array into a global"
"(defonce g [i32]) (defn stash [] () (let [a [5 6 7]] (set g (slice a))))"
~needle:"stash stores a slice of a into the global g";
rejects_check "storing a local field's address into a global"
"(defstruct P [x i32 y i32]) (defonce g (Ptr i32)) \
(defn stash [] () (let [p (P 1 2)] (set g (addr (.y p)))))"
~needle:"declare g as i32";
(* And what is left alone: storage that outlives the frame, a slice of a
Vec, a pointer passed in, a stash the function restores, and main. *)
accepts "a slice of a Vec is returned"
"(defn mk [] [i32] (let [v (vec-new i32)] (push v 1) (slice v)))";
accepts "an element of a slice parameter is returned"
"(defn mk [s [i32]] (Ptr i32) (addr (at s 0)))";
accepts "a slice of a global array is returned"
"(defonce k [3 i32]) (defn mk [] [i32] (slice k))";
accepts "a local reassigned before it is returned"
"(defonce k [3 i32]) \
(defn mk [] [i32] (let [a [1 2 3] s (slice a)] (set s (slice k)) s))";
rejects_check "two slices of locals stored into one global"
"(defonce g [i32]) \
(defn f [] () (let [a [1 2 3] b [4 5]] (set g (slice a)) (set g (slice b))))"
~needle:"f stores a slice of a into the global g";
rejects_check "a local's address into a global array's element"
"(defonce gs [2 (Ptr i32)]) \
(defn f [] () (let [x (i32 1)] (set (at gs 0) (addr x))))"
~needle:"Store the value instead of its address";
rejects_check "a local's address into a global struct's field"
"(defstruct Q [p (Ptr i32)]) (defonce gq Q) \
(defn f [] () (let [x (i32 1)] (set (.p gq) (addr x))))"
~needle:"f stores the address of x into the global gq";
rejects_check "a local's address into a global Vec's element"
"(defonce gv (Vec (Ptr i32))) \
(defn f [] () (let [x (i32 1)] (set (at gv 0) (addr x))))"
~needle:"f stores the address of x into the global gv";
rejects_check "a local's address pushed onto a global Vec"
"(defonce gv (Vec (Ptr i32))) \
(defn f [] () (let [x (i32 1)] (push gv (addr x))))"
~needle:"f stores the address of x into the global gv";
rejects_check "a local's address put into a global Map"
"(defonce gm (Map i32 (Ptr i32))) \
(defn f [] () (let [x (i32 1)] (put gm 1 (addr x))))"
~needle:"f stores the address of x into the global gm";
accepts "a pointer parameter pushed onto a global Vec"
"(defonce gv (Vec (Ptr i32))) \
(defn f [p (Ptr i32)] () (push gv p))";
rejects_check "the fix keeps the slice's bounds"
"(defn mk [a [4 i32]] [i32] (slice a 1 3))"
~needle:"(clone (slice a 1 3))";
rejects_check "an fn returning the address of its own local"
"(defn call [f (Fn [] (Ptr i32))] (Ptr i32) (f)) \
(defn g [] (Ptr i32) (call (fn [] (let [x (i32 4)] (addr x)))))"
~needle:"This fn returns the address of x";
rejects_check "an fn returning a slice of its copy of a captured array"
"(defn call [f (Fn [] [i32])] [i32] (f)) \
(defn g [] i32 (let [a [1 2 3]] (at (call (fn [] (slice a))) 0)))"
~needle:"This fn returns a slice of a";
rejects_check "a handler storing a slice of its local into a global"
"(defstruct Oops [code i32]) (defonce g [i32]) \
(defn main [] i32 \
(handler-bind [(Oops [c] (let [a [1 2 3]] (set g (slice a))))] \
(signal (Oops {.code 1}))) 0)"
~needle:"This handler stores a slice of a into the global g";
rejects_check "a restart clause answering the address of a local"
"(defstruct Oops [code i32]) \
(defn mk [p (Ptr i32)] (Ptr i32) (let [x (i32 4)] \
(restart-case (do (signal (Oops {.code 1})) p) \
(use-it [] (addr x)))))"
~needle:"mk returns the address of x";
accepts "main stores its own local into a global"
"(defonce g (Ptr i32)) (defn main [] i32 (let [x (i32 5)] (set g (addr x))) 0)";
accepts "a unit function's last form is not returned"
"(defn f [] () (let [x (i32 4)] (addr x)))";
(* A fill is never a value the linker can write into the image, so a
defconst of one is refused by the constant rule rather than by anything
of this feature's own. A defonce is fine: its initialiser runs at
startup, which programs/fill.flan pins. *)
rejects_check "a defconst cannot be filled"
"(defconst g [4 u8] (filled 0xFF)) (defn f [] ())"
~needle:"defconst";
(* ── The third element of a defonce ─────────────────────────────────
The rule, 2026-09-20: a type there is the zeroed static global it has
always been, and anything else is a dyn global initialised from the
expression at startup. The four rows below are the four spellings, each
pinned with its meaning and not merely with the fact that it compiles. *)
defvar_reading "a primitive third element stays a zeroed static"
"(defonce current-color i32) (defn f [] i32 current-color)"
"current-color" ~ty:"i32" ~zeroed:true;
defvar_reading "a bracketed type stays a zeroed static array"
"(defonce grid [2 [3 u32]]) (defn f [] u32 (at grid 0 0))"
"grid" ~ty:"[2 [3 u32]]" ~zeroed:true;
(* The edge the rule turns on: [Point] is a type, so the type reading wins
and this is the zeroed struct it was before the rule existed. A value
named [Point] cannot exist to compete with it — [collect] refuses one
name declared twice, across every declaration kind there is. *)
defvar_reading "a struct's name stays a zeroed static struct"
"(defstruct Point [x i32 y i32]) (defonce p Point) (defn f [] i32 (.x p))"
"p" ~ty:"Point" ~zeroed:true;
rejects_check "a type's name and a value's name cannot collide"
"(defstruct Point [x i32 y i32]) (defonce Point i32 1) (defn f [] ())"
~needle:"defined twice";
(* A parenthesised type is still a type, so this is the zeroed Vec it was —
which is also why a malformed one stays a type error rather than turning
into a call to something named Vec. *)
defvar_reading "a parenthesised type stays a zeroed static"
"(defonce v (Vec i32)) (defn f [] i32 (length v))"
"v" ~ty:"(Vec i32)" ~zeroed:true;
rejects_check "a malformed parenthesised type stays a type error"
"(defonce v (Vec i32 i32)) (defn f [] ())"
~needle:"(Vec T) takes exactly one type";
(* And the new spelling, which is the explicit dyn form with the keyword
left out. *)
defvar_reading "a literal third element is a dyn global holding it"
"(defonce score 0) (defn f [] () (set score (+ score 1)))"
"score" ~ty:"dyn" ~zeroed:false;
defvar_reading "a call as the third element is a dyn global"
"(defn load [] dyn {:n 1}) (defonce game-data (load)) (defn f [] dyn game-data)"
"game-data" ~ty:"dyn" ~zeroed:false;
(* A bare symbol naming a value, which is the shape only a name can settle:
[seed] is not a type, so this is a dyn global initialised from it. *)
defvar_reading "a value's name as the third element is a dyn global"
"(defonce seed i64 3) (defonce score seed) (defn f [] dyn score)"
"score" ~ty:"dyn" ~zeroed:false;
(* The explicit spellings are untouched by all of it. *)
defvar_reading "the explicit dyn form with a value is unchanged"
"(defonce score dyn 0) (defn f [] dyn score)"
"score" ~ty:"dyn" ~zeroed:false;
defvar_reading "the explicit dyn form with no value is unchanged"
"(defonce config dyn) (defn f [] dyn config)"
"config" ~ty:"dyn" ~zeroed:true;
(* [def] through the same third-element rule, one row per spelling. Each
asserts what makes it a def: [grerun], and the initialiser lifted into
[global/<n>] whatever it is — the zero and the literal included, which
is what lets a re-evaluated form swap it through the cell. A defonce
keeps those constants inline; the [defvar_reading] rows above pin that
side (a zeroed one's ginit *is* the zero). *)
def_reading "a def with a type is the zeroed static, repainted"
"(def grid [2 u32]) (defn f [] i32 (i32 (at grid 0)))"
"grid" ~ty:"[2 u32]";
def_reading "a typed def with a constant initialiser still lifts it"
"(def speed i64 3) (defn f [] i64 speed)"
"speed" ~ty:"i64";
def_reading "a computed typed def"
"(defn start [] i64 40) (def counter i64 (start)) (defn f [] i64 counter)"
"counter" ~ty:"i64";
def_reading "a literal third element of a def is a dyn global"
"(def score 0) (defn f [] () (set score (+ score 1)))"
"score" ~ty:"dyn";
(* The defonce beside it stays unmarked: the pair is the whole feature. *)
(match checked "(defonce keep i64 3) (def fresh i64 4) (defn f [] i64 keep)" with
| p ->
let g n = List.find (fun (g : Tast.global) -> g.Tast.gname = n) p.globals in
check "a defonce is not marked for re-run" (not (g "keep").Tast.grerun);
check "and the def beside it is" (g "fresh").Tast.grerun
| exception Loc.Error _ ->
check "a defonce and a def can stand together" false);
(* Lisp-1, same as every other pair of declarations: [collect]'s claimed
table spans def too. *)
rejects_check "a def and a defn cannot share a name"
"(def step 0) (defn step [] i64 1)" ~needle:"step is defined twice";
rejects_check "a def and a defonce cannot share a name"
"(defonce total i64) (def total 0) (defn f [] ())"
~needle:"total is defined twice";
(* The teaching paragraph speaks the form's own name when the form is a
def. *)
rejects_check "a symbol that is neither, under def, says def"
"(def total foo) (defn f [] ())"
~needle:
"foo is neither a type nor a value, and the third element of a def \
has to be one or the other: a type there declares a zeroed global of \
that type — (def total i64) — and a value there declares a dyn \
global holding it — (def total 0)";
(* The symbol that is neither, which is the one position the rule made
ambiguous: before it there was a single reading and "unknown type" was
the whole story, and a message that still said only that would send a
reader looking for the wrong mistake. Both readings, both spellings, and
the near miss over the value names too. *)
rejects_check "a symbol that is neither a type nor a value"
"(defonce total foo) (defn f [] ())"
~needle:
"foo is neither a type nor a value, and the third element of a defonce \
has to be one or the other: a type there declares a zeroed global of \
that type — (defonce total i64) — and a value there declares a dyn \
global holding it — (defonce total 0). Nothing named foo is declared \
as either";
rejects_check "the near miss is over the value names as well as the types"
"(defonce score i64 1) (defonce total scor) (defn f [] ())"
~needle:"Nothing named scor is declared as either — did you mean score?";
(* Three things that know which of the two readings was meant, and get in
ahead of the paragraph rather than being buried under it. A paragraph
about a fork the reader is not standing at is worse than a line. *)
rejects_check "a plain type typo keeps the short answer"
"(defonce total i33) (defn f [] ())"
~needle:"unknown type i33 — did you mean i32?";
(* [int] used to be this row. It resolves now — it is a builtin alias for
[i32] — so the spelling that still teaches has to be one of the ones the
exception did not cover. *)
rejects_check "and another language's spelling is answered by name"
"(defonce total long) (defn f [] ())"
~needle:"unknown type long — Flan spells it i64";
rejects_check "a data case is not a type, and says what is"
"(defdata Shape [(Circle [r f64])]) (defonce g Circle) (defn f [] ())"
~needle:"Circle is a case of the data type Shape, and a case is not a \
type of its own — the global's type is the data type: (defonce g \
Shape). Assign the case you want, as (set g (Shape.Circle \
{.field value ...}))";
(* A bracket form never reaches that fork — the parser gives it the type
reading outright — so a value name inside one used to land in
[resolve_name] and come back as a lecture about generic code. Both
readings at the element that decided it, and the dyn spelling is the one
that works. *)
rejects_check "a bracket type whose element names a value says both readings"
"(defonce a i64 1) (defonce b i64 2) (defonce g [a b]) (defn f [] ())"
~needle:"b names a value, not a type, and the brackets around it were \
read as a type";
rejects_check "and names the dyn spelling that does work"
"(defonce a i64 1) (defonce b i64 2) (defonce g [a b]) (defn f [] ())"
~needle:"put dyn in front of the same brackets — (defonce g dyn ...)";
accepts "which is a real form"
"(defonce a i64 1) (defonce b i64 2) (defonce g dyn [a b]) (defn f [] ())";
(* defconst's two-element form has no type slot, so a type written in one
was read as a name in an array literal and reported as unknown. It is
unambiguous evidence: a type and a value cannot share a name here. *)
rejects_check "a type in a two-element defconst names defonce"
"(defconst rows 4) (defconst cols 4) (defconst grid [rows [cols u8]]) \
(defn f [] ())"
~needle:"u8 is a type, and this is a value: a two-element defconst has no \
type slot";
accepts "and the defonce it names is the form that works"
"(defconst rows 4) (defconst cols 4) (defonce grid [rows [cols u8]]) \
(defn f [] ())";
accepts "an ordinary array constant is untouched" "(defconst xs [1 2 3])";
(* A parameter name is not a mistyped type. This language sizes its machine
types in the name, so a typo in one keeps the digits and a parameter
called [i] or [n] has none — which is the whole of the rule that stopped
[(defn idx [v i] dyn ...)] being refused. *)
accepts "a short parameter name is not a mistyped type"
"(defn idx [v i] dyn v)";
rejects_check "but a mistyped machine type still is"
"(defn g [x f65] f64 x)" ~needle:"unknown type f65 — did you mean f64?";
(* ── (array-fill ...) and (array-gen ...) as initialisers ──────────
TODO.org, "A value-producing array constructor", wanted
[(defonce grid (array-fill [rows cols] 255))] — the grid filled as part of
its declaration rather than in a mutation step after it. What falls out of
the rules already settled, and it is not a carve-out either way:
The four-element spelling is the one that works. It is a typed global with
a computed initialiser, which is the startup-lifted path a defonce already
had, and the value it stores is an ordinary fixed array.
The three-element spelling does not mean this, and could not. A defonce
whose third element is not a type is a *dyn* global by the 2026-09-20
rule, and a typed fixed array crosses into dyn as a view of its
storage. A freshly built array is the initialiser's temporary, gone when
the initialiser returns, so a view of it is refused there by name with
the typed spelling as the fix. *)
defvar_reading "a typed array-fill global is computed, not zeroed"
"(defconst rows 2) (defconst cols 3)\n\
(defonce grid [rows [cols u8]] (array-fill [rows cols] 255))\n\
(defn f [] u8 (at grid 0 0))"
"grid" ~ty:"[2 [3 u8]]" ~zeroed:false;
rejects_check "a three-element array-fill defonce is the dyn reading"
"(defonce xs (array-fill [3] (i64 1))) (defn f [] ())"
~needle:"xs is a dyn global, and its initialiser builds a [3 i64] that is \
gone once the initialiser returns";
rejects_check "and the fix it names is the typed spelling"
"(defonce grid (array-fill [2 3] 255)) (defn f [] ())"
~needle:"as in (defonce grid [2 [3 i32]] ...)";
(* A defconst is not a second path to it: its value is what the linker
writes into the image, and a fill is a loop. *)
rejects_check "array-fill is not a constant's value"
"(defconst g [2 u8] (array-fill [2] (u8 1))) (defn f [] ())"
~needle:"a constant's value must be a compile-time constant";
(* The element type the annotation asks for is the one the fill value is
checked against, so the disagreement is reported at the value. *)
rejects_check "the annotation and the fill value must agree"
"(defonce g [2 [3 u8]] (array-fill [2 3] (f32 1.0))) (defn f [] ())"
~needle:"expected u8, found f32";
rejects_check "the annotation's shape has to be the fill's shape"
"(defonce g [2 u8] (array-fill [3] (u8 1))) (defn f [] ())"
~needle:"expected [2 u8], found [3 u8]";
(* A dimension is the same compile-time length [n T] takes, and a local is
not one. The refusal is [array_len]'s own, which is what "the same rule"
means here. *)
rejects_check "a dimension is a compile-time constant"
"(defn f [] i32 (let [n 3 a (array-fill [n] 0)] 0))"
~needle:"is not a compile-time integer constant";
(* The one condition this form has that the [n T] type spelling does not:
the fill counts in i32 like every other index, so a dimension no i32 can
reach has no loop that could end. Written as a literal, because a
[defconst] that big is refused as an i32 constant before it is ever a
dimension. *)
rejects_check "a dimension has to fit an i32 index"
"(defn f [] i32 (let [a (array-fill [3000000000] 0)] 0))"
~needle:"is not a dimension a fill can count to";
(* The generator. Its type decides the element type, its arity has to be the
rank, and its arguments are indices. *)
accepts "array-gen takes a named function"
"(defn cell [r i32 c i32] i32 (+ (* r 100) c))\n\
(defonce grid [2 [3 i32]] (array-gen [2 3] cell))\n\
(defn f [] i32 (at grid 1 2))";
rejects_check "array-gen's second element is a function"
"(defn f [] i32 (let [a (array-gen [3] 7)] 0))"
~needle:"array-gen's second element is a function value";
rejects_check "the generator takes one argument per dimension"
"(defn g [i i32 j i32] i32 0) (defn f [] i32 (let [a (array-gen [3] g)] 0))"
~needle:"this array-gen has 1 dimension, so its generator is called with \
1 index — and this one takes 2 arguments";
rejects_check "the generator's arguments are i32 indices"
"(defn g [i i64] i32 0) (defn f [] i32 (let [a (array-gen [3] g)] 0))"
~needle:"an index is an i32, and this generator's argument 1 is i64";
(* [resolve] refuses a fixed array of function values — a zeroed one would
be a null pointer — and the type these forms build never goes through
[resolve], so the guard is asked again where the type is built. *)
rejects_check "an array of function values is refused here too"
"(defn h [x i32] i32 x) (defn g [i i32] (Fn [i32] i32) h)\n\
(defn f [] i32 (let [a (array-gen [2] g)] 0))"
~needle:"a fixed array's element cannot be (Fn [i32] i32)";
(* A (CFn ...) is not refused in any of them: a call through one tests for
null and signals NullCall, so its zero is an empty slot. *)
accepts "a CFn struct field"
"(defstruct Ops [run (CFn [i32] i32)])\n\
(defn f [o Ops] i32 ((.run o) 1))";
accepts "a fixed array of CFn"
"(defonce tbl [4 (CFn [i32] i32)])\n(defn f [] i32 ((at tbl 0) 1))";
accepts "a CFn global with no initialiser"
"(defonce hook (CFn [] ()))\n(defn f [] () (hook))";
accepts "(zeroed) at a CFn"
"(defn f [] i32 (let [g (the (CFn [i32] i32) (zeroed))] (g 1)))";
accepts "an array-gen of CFn"
"(defn h [x i32] i32 x) (defn g [i i32] (CFn [i32] i32) h)\n\
(defn f [] i32 (let [a (array-gen [2] g)] ((at a 1) 3)))";
rejects_check "an Fn struct field is still refused"
"(defstruct Ops [run (Fn [i32] i32)])"
~needle:"the field run cannot be (Fn [i32] i32)";
(* The inline form, the design's canonical one. An fn normally takes its
types from a (Fn ...) want, and this position has none — the *form*
supplies them instead: one i32 index per dimension, and the annotated
element type as the return where there is one. With no annotation the
element type is the body's, the same inference the fill value gets. *)
infers "array-gen takes an inline fn, rank 1"
"(array-gen [5] (fn [i] (* i i)))" "[5 i32]";
infers "array-gen takes an inline fn, rank 2"
"(array-gen [2 3] (fn [i j] (+ (* i 100) j)))" "[2 [3 i32]]";
infers "an inline generator's element type is read off its body"
"(array-gen [3] (fn [i] (i64 i)))" "[3 i64]";
accepts "an annotated defonce takes an inline generator"
"(defonce grid [2 [3 u8]] (array-gen [2 3] (fn [i j] (u8 (+ i j)))))\n\
(defn f [] i32 (i32 (at grid 1 2)))";
(* The annotated element type is the want the body is checked against, so a
disagreement is reported at the generator's answer, in the ordinary
expected/found words — not as a whole-array mismatch a line up. *)
rejects_check "an inline generator's body has to answer the element type"
"(defonce grid [2 [3 u8]] (array-gen [2 3] (fn [i j] 1.5)))\n\
(defn f [] i32 0)"
~needle:"expected u8, found f64";
rejects_check "an inline generator takes one argument per dimension too"
"(defn f [] i32 (let [a (array-gen [2] (fn [i j] i))] 0))"
~needle:"this array-gen has 1 dimension, so its generator is called with \
1 index — and this one takes 2 arguments";
(* ── Computed global initialisers ──────────────────────────────────
The order they run in is the compiler's to choose, so a global written
above the one it reads is fine... *)
accepts "a global initialised from another, written above it"
"(defonce b i64 (+ a 10)) (defonce a i64 (+ 1 2)) (defn f [] i64 b)";
(* ...and a ring is refused with every name in it, because there is no
answer: whichever one started first would read the other's zero. *)
rejects_check "two globals that initialise each other"
"(defn fa [] i64 b) (defn fb [] i64 a)\n\
(defonce a i64 (fa)) (defonce b i64 (fb))\n(defn f [] i64 (+ a b))"
~needle:"initialise each other";
rejects_check "a global initialised from itself"
"(defn fa [] i64 a) (defonce a i64 (fa)) (defn f [] i64 a)"
~needle:"initialised from itself";
(* The dependency is through the call, not only through what the initialiser
names: [fa] reads [b] and nothing in [a]'s text mentions it. *)
accepts "a global that reads another through a function it calls"
"(defn fa [] i64 (+ b 1)) (defonce a i64 (fa)) (defonce b i64 (+ 1 2))\n\
(defn f [] i64 a)";
(* Nothing outside an initialiser can establish a handler or a restart, so an
unanswered signal is a no-op and an unanswered invoke-restart fails at the
invoke site. Both are refused by name. *)
rejects_check "a signal in a global initialiser"
"(defstruct Oops [id i32])\n\
(defonce w i64 (do (signal (Oops {.id 1})) 1))\n(defn f [] i64 w)"
~needle:"with no handler-bind or restart-case around it";
rejects_check "an invoke-restart in a global initialiser"
"(defonce w i64 (do (invoke-restart 'retry) 1))\n(defn f [] i64 w)"
~needle:"with no handler-bind or restart-case around it";
(* And what is *inside* one runs like any other code: the frames a
restart-case pushes it also pops, before the initialiser returns. This is
[slurp]'s shape, which is why a global loaded from a file works at all. *)
accepts "a restart-case inside a global initialiser"
"(defstruct Oops [id i32])\n\
(defonce w i64 (restart-case (do (signal (Oops {.id 1})) 7) (use-zero [] 0)))\n\
(defn f [] i64 w)";
(* The borrows, which are what is left once ownership is off the table: a
global Vec is read, mutated in place, viewed and copied, and the copy is
the one thing something else may own. *)
accepts "a global Vec is borrowed, mutated and cloned"
"(defonce g (Vec u8)) \
(defn f [] () (set g (vec-new u8)) (push g 1) (set (at g 0) 2) \
(println (length (slice g))) (let [c (clone g)] (free c)))";
rejects_check "try is milestone 6" "(defn f [] i32 (try 1))"
~needle:"try (Result) is not implemented";
(* dotimes and defer are implemented, and a defer in a [let] is now one of
the places it may be written: a let at the top level of a function body
has exactly the function's extent (see test/programs/defer-let.flan). What
is still rejected is a loop body and a branch, because a defer is copied
into every exit path — so a loop body's would fire once at function exit
rather than once per iteration, and a branch cannot say "maybe
registered". *)
rejects_check "defer is refused in a loop body"
"(defn g [] () 0) (defn f [] () (while true (defer (g))))"
~needle:"a loop body";
rejects_check "defer is refused in a branch"
"(defn g [] () 0) (defn f [] () (if true (defer (g)) 0))"
~needle:"a branch";
(* break and continue. The interesting half is the *relative* rule: a jump
may not cross a construct that has work to do on the way out, and the
refusal names which construct. That is what replaced the blanket refusal
[return] still carries, and the accepting cases below are the ones a
blanket rule would have got wrong. *)
accepts "break leaves the innermost loop"
"(defn f [] () (while true (break)))";
accepts "a labelled break leaves the named loop"
"(defn f [] () (while :o true (while true (break :o))))";
accepts "continue in a dotimes"
"(defn f [] () (dotimes [i 3] (continue)))";
(* And in the other two arities, counting either way. The output side of
this is test/programs/dotimes-range.flan; what is checked here is that
nothing about the longer forms disturbs the loop stack. *)
accepts "break and continue in a start/stop dotimes"
"(defn f [] () (dotimes [i 2 5] (when (= i 3) (continue)) (break)))";
accepts "break and continue in a down-counting dotimes"
"(defn f [] () (dotimes :o [i 9 -1 -1] (when (= i 3) (continue :o)) \
(break :o)))";
(* A step of 0 written as a literal is an infinite loop spelled as an
accident, so it is refused where it is written. A step that is only a
value cannot be refused here and runs no times at all — the sign test
that picks the direction leaves it with neither. *)
rejects_check "a literal step of 0"
"(defn f [] () (dotimes [i 0 10 0] (print i)))"
~needle:"a step of 0 never moves the counter";
accepts "a step whose sign is not known until run time"
"(defn f [] () (let [s 0] (dotimes [i 0 10 s] (print i))))";
(* Three bounds is the most there are. A fourth is refused by the parser,
which names all three arities. *)
rejects_check "a dotimes with four bounds"
"(defn f [] () (dotimes [i 0 10 2 1] (print i)))"
~needle:"(dotimes [name start stop step] body ...)";
rejects_check "a dotimes with no bound at all"
"(defn f [] () (dotimes [i] (print i)))"
~needle:"(dotimes [name stop] body ...)";
(* Every bound is an index, so it is i32 like the one bound always was.
There is no width to join: a wider one is the ordinary type error. *)
rejects_check "a dotimes bound of another width"
"(defn f [] () (let [n (i64 10)] (dotimes [i 0 n] (print i))))"
~needle:"expected i32, found i64";
rejects_check "break outside a loop"
"(defn f [] () (break))" ~needle:"only allowed inside a loop";
rejects_check "continue outside a loop"
"(defn f [] () (continue))" ~needle:"only allowed inside a loop";
rejects_check "a label naming no enclosing loop"
"(defn f [] () (while true (break :nope)))" ~needle:"no loop named :nope";
(* The rule the blanket one could not express, both ways round. A loop
wholly inside a restart-case body keeps its local break; a break that
would *leave* the restart-case is refused, and says so. *)
(* A condition's parent. A parent has exactly Error's two fields, because a
handler for it is handed the name and the sentence and not the fields. *)
accepts "a condition may name Error as its parent"
"(defstruct Oops :parent Error [n i32]) (defn f [] () (error (Oops {.n 1})))";
accepts "a category with no field vector gets Error's fields"
"(defstruct Io :parent Error) (defstruct Full :parent Io [n i32]) \
(defn f [e Io] str (.message e))";
accepts "the suggested category spelling compiles"
"(defstruct Category :parent Error)";
rejects_check "a parent with fields of its own is refused, fixed at the parent"
"(defstruct Oops :parent Error [n i32]) (defstruct Worse :parent Oops [m i32])"
~needle:"Oops has [n i32]. Declare it with no field vector, \
(defstruct Oops :parent Error)";
rejects_check "a parent with no fields at all is not said to have some"
"(defstruct E []) (defstruct Worse :parent E [m i32])"
~needle:"E has [none]. Declare it with no field vector, \
(defstruct E :parent Error)";
accepts "an empty field vector under a parent is a category"
"(defstruct Io :parent Error []) (defstruct Full :parent Io [n i32]) \
(defn f [e Io] str (.message e))";
rejects_check "a parent that is not a struct is refused"
"(defstruct Oops :parent i32 [n i32])"
~needle:"a parent is a condition struct";
rejects_check "a condition cannot be its own parent"
"(defstruct Oops :parent Oops)" ~needle:"cannot be its own parent";
rejects_check "a chain of parents that loops is refused"
"(defstruct A :parent B) (defstruct B :parent A)"
~needle:"a chain of parents has to end";
parse_rejects "a parent comes before the fields"
"(defstruct Oops [n i32] :parent Error)"
~needle:"(defstruct Name :parent Parent [field Type ...])";
(* SBCL's placement for a clause's report: after the parameters. *)
accepts "a restart clause may carry a :report sentence"
"(defn f [] i64 (restart-case 1 (retry [] :report \"Try again\" (do) 2)))";
accepts "the suggested :report spelling compiles"
"(defn f [] () (restart-case (do) (retry [] :report \"Try again\" (do))))";
parse_rejects "a :report that is not a string is refused"
"(defn f [] i64 (restart-case 1 (retry [] :report 5 2)))"
~needle:"a restart's :report is a string";
accepts "a loop inside a restart-case may break out of itself"
"(defn f [] () (restart-case (while true (break)) (go [] (println \"\"))))";
rejects_check "break may not leave a restart-case"
"(defn f [] () (while true (restart-case (break) (go [] (println \"\")))))"
~needle:"a restart-case";
(* A clause is a barrier for the same reason the body is: it runs after a
transfer landed, with the form's frames still to be popped. *)
rejects_check "break may not leave a restart-case from a clause"
"(defn f [] () (while true (restart-case (println \"\") (go [] (break)))))"
~needle:"a restart-case";
accepts "a loop inside a handler-bind may break out of itself"
"(defstruct C [n i32]) (defn f [] () (handler-bind [(C [c] 0)] (while true (break))))";
rejects_check "break may not leave a handler-bind"
"(defstruct C [n i32]) (defn f [] () (while true (handler-bind [(C [c] 0)] (break))))"
~needle:"a handler-bind";
(* loop and recur. The same stack, the same barriers, and one rule of its
own: a recur must be in the loop body's tail. That is what makes this
better than a silent TCO rather than only cheaper — the mistake is a
compile error here and would be a stack overflow there. *)
accepts "recur in the tail of the body"
"(defn f [] i32 (loop [i 0] (if (= i 3) i (recur (+ i 1)))))";
accepts "recur in the tail of a when"
"(defn f [] () (loop [i 0] (when (< i 3) (recur (+ i 1)))))";
accepts "recur in the tail of a nested let"
"(defn f [] i32 (loop [i 0] (let [n (+ i 1)] (if (= i 3) i (recur n)))))";
rejects_check "recur that is not in tail position"
"(defn f [] () (loop [i 0] (recur (+ i 1)) (println \"\")))"
~needle:"tail position";
rejects_check "recur under a call is not in tail position"
"(defn f [] i32 (loop [i 0] (+ 1 (recur (+ i 1)))))"
~needle:"tail position";
rejects_check "recur in a nested loop body is not in tail position"
"(defn f [] () (loop [i 0] (while true (recur (+ i 1)))))"
~needle:"tail position";
(* Where the "refuse mutual recursion by name" answer lives: there are no
tail calls, so a function cannot recur into itself either. *)
rejects_check "recur outside a loop"
"(defn f [] () (recur))" ~needle:"only allowed inside a (loop ...)";
rejects_check "recur with the wrong number of values"
"(defn f [] i32 (loop [i 0 j 1] (recur 1)))"
~needle:"binds 2 names and this recur passes 1";
(* The barrier, asked the same question break asks and given the same
answer, rather than a second mechanism. *)
rejects_check "recur may not leave a restart-case"
"(defn f [] () (loop [i 0] (restart-case (recur (+ i 1)) (go [] (println \"\")))))"
~needle:"a restart-case";
(* And the restriction this form adds: a loop answers with the value of its
body, so a jump out of one would have no value to give. A while written
inside a loop is untouched, which is the relative rule again. *)
accepts "a while inside a loop keeps its own break"
"(defn f [] () (loop [i 0] (while true (break))))";
rejects_check "break may not leave a loop"
"(defn f [] () (loop [i 0] (break)))" ~needle:"break cannot leave a (loop ...)";
rejects_check "a labelled break may not leave a loop"
"(defn f [] () (while :o true (loop [i 0] (break :o))))"
~needle:"would leave a (loop ...)";
accepts "a while condition is an ordinary expression"
"(defn f [] () (let [v (vec-new i32) n 0] \
(while (and (< n 10) (> (length v) 0)) (set n (+ n 1))) (free v)))";
rejects_check "loop takes no label"
"(defn f [] () (loop :o [i 0] (recur i)))" ~needle:"loop takes no label";
rejects_check "a loop binding is a plain name"
"(defn f [] () (loop [[a b] 0] (recur 0)))" ~needle:"destructuring pattern";
(* into. The expansion is asserted in programs/into.flan, where the values
coming out are the test; what belongs here is the three things it refuses,
each through the one facility a macro has — a name nothing defines. *)
rejects_check "into needs a source and a destination"
"(defn f [] () (free (into [1 2 3])))"
~needle:"into-takes-a-source-a-destination-and-transforms";
rejects_check "a transform is map or filter"
"(defn f [] () (free (into [1 2 3] (vec-new i32) (take 2))))"
~needle:"into-transform-is-map-or-filter";
rejects_check "a transform names one function"
"(defn f [] () (free (into [1 2 3] (vec-new i32) (map))))"
~needle:"into-transform-is-map-or-filter-of-one-function";
(* An import is resolved by [Load] before the checker runs, so one that
reaches [Check] means a driver skipped that step. *)
rejects_check "an unresolved import is a driver bug"
"(import rl \"vendor:raylib\")" ~needle:"not resolved";
(* Keywords resolve against an enum where one is expected, and everywhere
else are the dyn value from M2 — there is no third reading left to
refuse, so a call that wants a concrete non-dyn type still refuses, just
through the ordinary found-dyn sentence of that boundary rather than a
keyword-specific one. *)
rejects_check "a keyword needs an enum"
"(defn g [x i32] ()) (defn f [] () (g :space))" ~needle:"is expected here";
(* This row used to be a rejection, and the sentence it wanted was the cast
arm's "converts a number, found dyn". TODO.org, "A numeric cast opens a
dyn box", took that refusal away on purpose: a numeric cast opens a dyn
box, so [(i64 d)]
compiles for every dyn [d] and the question of what the box holds moved
to run time. A keyword's box holds no number and traps there —
[flan_dyn_cast_kind]'s sentence, the same one a bool's box gets, pinned
in test_acceptance.ml's dyn-cast rows. What is left here is that the
program is now well-typed, which is the change. *)
accepts "a keyword is dyn, and a numeric cast on it is a run-time question"
"(defn f [] () (print (i64 :space)))";
rejects_check "a keyword that is not a member"
"(defenum Key [space 32]) (defn g [k Key] ()) (defn f [] () (g :spcae))"
~needle:"has no member :spcae";
(* The near miss. A typo one edit away is suggested, and so is the bare
name of a member that carries a disambiguating prefix — raylib's Key
spells its members key-r, key-space, and :r is the natural mistake. *)
rejects_check "a member one edit away is suggested"
"(defenum Key [space 32]) (defn g [k Key] ()) (defn f [] () (g :spcae))"
~needle:"did you mean :space?";
rejects_check "a bare name suggests the prefixed member"
"(defenum Key [key-space 32 key-r 82]) (defn g [k Key] ()) \
(defn f [] () (g :r))"
~needle:"did you mean :key-r?";
accepts "a keyword that is a member"
"(defenum Key [space 32 r 82]) (defn g [k Key] ()) (defn f [] () (g :r))";
(* Converting an enum, explicitly, in both directions. The point of the
conversion is that it is written at the site: a bare integer still does
not fit an enum parameter, so the checked property — a typo is an error
here rather than a wrong number later — is untouched. *)
accepts "an enum converts to an integer"
"(defenum Key [space 32]) (defn f [k Key] i32 (i32 k))";
accepts "an enum converts to a float, through its i32"
"(defenum Key [space 32]) (defn f [k Key] f32 (f32 k))";
accepts "an integer converts to an enum"
"(defenum Key [space 32]) (defn g [k Key] ()) (defn f [i i32] () (g (Key i)))";
accepts "a value that is no declared member converts"
"(defenum Key [space 32]) (defn g [k Key] ()) (defn f [] () (g (Key 999)))";
rejects_check "an integer still does not fit an enum on its own"
"(defenum Key [space 32]) (defn g [k Key] ()) (defn f [i i32] () (g i))"
~needle:"expected Key";
rejects_check "an enum does not convert to another enum"
"(defenum A [x 1]) (defenum B [y 1]) (defn f [a A] B (B a))"
~needle:"converts an integer to an enum";
rejects_check "a float does not convert to an enum"
"(defenum Key [space 32]) (defn f [x f32] Key (Key x))"
~needle:"converts an integer to an enum";
(* An enum is a return type, which needed parse.ml to know enum names. It
knows them under a key of their own: (Key n) is a value now, so putting
Key in [types] would make a body starting with one be eaten as a return
type — the exact trap [is_type_form]'s comment is about. *)
accepts "an enum is a return type"
"(defenum Key [space 32]) (defn f [i i32] Key (Key i))";
accepts "an enum conversion at the head of a body is not a return type"
"(defenum Key [space 32]) (defn g [k Key] ()) \
(defn f [] () (Key 1) (g :space))";
rejects_check "an enum conversion takes one argument"
"(defenum Key [space 32]) (defn f [] Key (Key 1 2))"
~needle:"1 argument";
(* A folded constant skips [check], so its range check has to be its own. *)
rejects_check "a folded constant is still range-checked"
"(defconst c u8 300) (defn f [] u8 c)" ~needle:"does not fit in u8";
(* One top-level namespace, enforced across declaration kinds. Each of these
used to pass the checker — the tables are per-kind — and be caught by LLVM
as a redefinition of an emitted symbol, or not caught at all. *)
rejects_check "a global defined twice"
"(defonce x i32 1) (defonce x i32 2)" ~needle:"defined twice";
rejects_check "a constant shadowing a variable"
"(defconst c 1) (defonce c i32 2)" ~needle:"defined twice";
rejects_check "a function and a global"
"(defn item [] i32 1) (defonce item i32 2)" ~needle:"defined twice";
rejects_check "a struct and an alias"
"(defstruct P [x i32]) (defalias P i32)" ~needle:"defined twice";
rejects_check "an enum and a struct"
"(defenum E [a 1]) (defstruct E [x i32])" ~needle:"defined twice";
rejects_check "an extern and a constant"
"(declare cw [] \"flan_cw\") (defconst cw 1)" ~needle:"defined twice";
(* ── The two builtin aliases ────────────────────────────────────────
[int] is [i32] and [float] is [f32], as of 2026-09-20, and they are the
whole of the exception: every other foreign spelling still teaches. They
are entries in [Types.ikind_of_name] and [Types.fkind_of_name] rather
than prelude [defalias]es, so the claim under test is identity, not
resolution — the rows below are the positions where a merely-resolving
name and the machine type would part company.
The corpus half is test/programs/int-float.flan, which runs on both
backends; what cannot be a program is here, because it does not
compile. *)
accepts "int in a return type and a parameter"
"(defn f [a int] int a)";
accepts "float likewise"
"(defn f [a float] float a)";
(* The position a prelude alias could not have reached: [is_cast] asks the
two [*kind_of_name] functions and never the alias table. *)
accepts "int and float as cast heads"
"(defn f [] int (int (float 1)))";
accepts "int as a generic type argument"
"(defn f [] i64 (let [v (vec-new int) m (map-new int float)] 0))";
accepts "int as a struct field, and float beside it"
"(defstruct P [x int y float]) (defn f [] int (let [p (P {.x 1 .y 2.0})] (.x p)))";
(* The three-element defonce, whose third element is read as a type: a
zeroed static and not a dyn global holding a value called [int]. *)
accepts "a defonce whose type is int" "(defonce g int) (defn f [] int g)";
accepts "and one whose type is float" "(defonce g float) (defn f [] float g)";
accepts "a user alias over int" "(defalias Row (Vec int)) (defn f [] i64 0)";
(* Identity, stated where identity is the only thing that could make it
pass: the two spellings meet as one type with no conversion between
them. *)
accepts "int and i32 are one type"
"(defn g [x i32] i32 x) (defn f [a int] i32 (g a))";
accepts "float and f32 are one type"
"(defn g [x f32] f32 x) (defn f [a float] f32 (g a))";
(* Erasure: the compiler answers in the machine type's name whichever
spelling the source used, which is what the inspector and DWARF show
too — [ikind_name] and [fkind_name] have no [int] to give back. *)
rejects_check "a type error under int names i32"
"(defn f [] int 1.5)" ~needle:"expected i32";
rejects_check "and one under float names f32"
"(defn f [] float (f64 1.0))" ~needle:"expected f32";
(* Widening needs no entry for [int] because [int] *is* [i32], and this pin
says exactly that and nothing about what the widening table holds. It used
to read the other way round — the mixed arithmetic that i32 *refuses*,
int refuses identically — which was true when it was written and stopped
being true when implicit widening landed (TODO.org, "Implicit numeric
widening is legal; narrowing stays a hard error"): an i32 and
an i64 now meet at i64, so the same form under [int] has to be accepted,
and accepted at i64. Kept pointing at identity by pinning both directions:
the one that widens, and the one that still cannot. *)
accepts "int mixes with i64 exactly as i32 does"
"(defonce a int) (defonce b i64) (defn f [] i64 (+ a b))";
rejects_check "and refuses the narrowing exactly as i32 does"
"(defonce a int) (defonce b i64) (defn f [] int (+ a b))"
~needle:"expected i32, found i64";
(* A program that declared the alias itself — which this one's author did,
before it was builtin. True as written, it is the no-op it says it is;
pointed anywhere else it is refused, because the alias table is never
consulted for the name and the declaration would silently mean i32. *)
accepts "a defalias restating the builtin is a no-op"
"(defalias int i32) (defn f [] int 1)";
accepts "and so is the float one"
"(defalias float f32) (defn f [] float 1.0)";
rejects_check "a defalias redefining int is refused"
"(defalias int i64) (defn f [] int 1)"
~needle:"int is a builtin alias for i32 and cannot be redefined as i64";
rejects_check "and so is one redefining float"
"(defalias float f64) (defn f [] float 1.0)"
~needle:"float is a builtin alias for f32 and cannot be redefined as f64";
rejects_check "a defalias pointing int at a compound type"
"(defalias int (Vec i32)) (defn f [] i32 1)"
~needle:"int is a builtin alias for i32 and cannot be redefined";
(* The exception stops at two names. [integer] is [int]'s own sibling and
still teaches, which is the sharpest statement of where the line is. *)
rejects_check "integer still teaches"
"(defn f [] integer 1)" ~needle:"unknown type integer — Flan spells it i32";
rejects_check "double still teaches"
"(defn f [] double 1.0)" ~needle:"unknown type double — Flan spells it f64";
rejects_check "long still teaches"
"(defn f [] long 1)" ~needle:"unknown type long — Flan spells it i64";
rejects_check "string teaches str"
"(defn f [s string] i32 1)" ~needle:"unknown type string — Flan spells it str";
rejects_check "a string field teaches str"
"(defstruct P [name string]) (defn f [] i32 1)"
~needle:"unknown type string — Flan spells it str";
rejects_check "a string return teaches str"
"(defn f [] string \"a\")" ~needle:"unknown type string — Flan spells it str";
rejects_check "a string element type teaches str"
"(defn f [] i32 (let [v (vec-new string)] 0))"
~needle:"unknown type string — Flan spells it str";
rejects_check "a string key type teaches str"
"(defn f [] i32 (let [m (map-new string i32)] 0))"
~needle:"unknown type string — Flan spells it str";
rejects_check "the string conversion teaches str"
"(defn f [b [u8]] str (string b))"
~needle:"unknown function string — Flan spells it str";
accepts "a program may name its own function string"
"(defn string [b [u8]] str (str b)) (defn f [b [u8]] str (string b))";
(* A shift by the operand's own width or more is poison in LLVM, and at -O2
a poison return is a function that returns nothing at all. A literal count
is rejected; a computed one is masked in [emit]. *)
rejects_check "a shift past the operand's width"
"(defn f [] i32 (<< 1 32))" ~needle:"out of range";
rejects_check "a right shift past the operand's width"
"(defn f [] u8 (>> (u8 1) 8))" ~needle:"out of range";
accepts "a shift by the widest count in range"
"(defn f [] i32 (<< 1 31))";
(* An index converts from a narrower integer and never from a wider one. *)
accepts "a u32 index" "(defonce a [4 u32]) (defn f [] u32 (let [i 2] (at a (u32 i))))";
rejects_check "an i64 index"
"(defonce a [4 u32]) (defn f [] u32 (let [i 2] (at a (i64 i))))"
~needle:"is wider";
(* An aggregate cannot cross to C — the shim's job, in C, per target. *)
rejects_check "an extern may not take a struct"
"(defstruct V [x f32]) (declare f [v V] \"c_f\")" ~needle:"cannot cross to C";
rejects_check "an extern may not return a struct"
"(defstruct V [x f32]) (declare f [] V \"c_f\")" ~needle:"cannot cross to C";
(* Function values landed; what stayed refused is what they do not include.
An fn takes its parameter types from the position it is written in, and a
defn's body that just answers one says nothing about them. *)
rejects_check "an fn with nothing to say what it takes"
"(defn f [] () (fn [x] x))" ~needle:"nothing here says what this fn";
rejects_check "a lowercase return type no signature introduced"
"(defn f [] a 0)" ~needle:"write $a in the parameter vector";
(* The other half: a name in value position now *works*, and the arity is
checked against the function it names. *)
rejects_check "a function value at the wrong arity"
"(defn g [x i32] i32 x) (defn u [f (Fn [i32] i32)] i32 (f 1 2)) \
(defn f [] i32 (u g))"
~needle:"takes 1 argument, given 2";
rejects_check "a struct cannot contain itself by value"
"(defstruct Node [next Node])" ~needle:"contains itself by value";
rejects_check "nor through a fixed array"
"(defstruct Node [kids [2 Node]])" ~needle:"contains itself by value";
accepts "a pointer breaks the cycle"
"(defstruct Node [next (Ptr Node)])";
rejects_check "an integer literal must fit its type"
"(defn f [] u8 300)" ~needle:"does not fit in u8";
accepts "sequential let bindings"
"(defn f [] i32 (let [a 1 b (+ a 1)] b))";
(* An array literal is [n T] and does not satisfy a slice expectation:
the two are distinct in type and in ownership (spec-memory.md). *)
rejects_check "array literal is not a slice"
"(defn f [] [u8] [1 2 3])" ~needle:"expected [u8]";
rejects_check "array literal is not a struct"
"(defstruct C [pos i32]) (defn f [] C [1 2])" ~needle:"expected C";
rejects_check "wrong element count"
"(defonce xs [2 i32] [1 2 3])" ~needle:"expected 2 elements";
(* Top-level names are order-independent (plan.org, Modules) — including
constants used as array lengths and constants defined in terms of each
other. *)
accepts "a constant declared after its use as a length"
"(defonce grid [rows i32]) (defconst rows 8)";
accepts "constants defined out of order"
"(defconst a (+ b 1)) (defconst b 1)";
(* A typed [defonce] here and not an untyped [defconst], which it was until
2026-09-20: a computed initialiser belongs to a defonce now, and only the
defconst form takes no type. The order-independence being pinned is the
same one either way — [g] is resolved from a declaration further down the
file. *)
accepts "a global initialised from a later function"
"(defonce k u8 (g)) (defn g [] u8 1)";
rejects_check "a genuinely unknown constant still reports itself"
"(defconst a (+ nope 1))" ~needle:"unknown name nope";
(* ── What a defconst's value may be, decided 2026-09-20 ─────────── *)
(* The author's rule: a defconst is the equivalent of a compiler const, so
its value is what the linker writes and never something that runs. The
accepted set is [Tast.const_init]'s, which is [Emit.const]'s — and the
integer arithmetic below is in it because [collect]'s folding pass has
already turned it into its answer by the time the initialiser is looked
at, which is the same pass that makes (/ w cell) usable as an array
length. Both backends refuse the computed one here now, at the checker,
rather than one of them refusing and the other running it at startup. *)
rejects_check "a computed defconst"
"(defn seed [] i64 7) (defconst c i64 (seed))"
~needle:"a constant's value must be a compile-time constant";
rejects_check "a computed defconst names the way through"
"(defn seed [] i64 7) (defconst c i64 (seed))"
~needle:"Write (defonce c ...)";
(* The search for a case goes down through the aggregates, because a case
inside a struct literal is the same value the image cannot hold and the
general message's advice — make it a defonce, or write a literal — is not
followable for one. [Emit.const] recursed for the same reason. *)
rejects_check "a data type case nested in a constant struct"
"(defdata U [A (B [x i32])]) (defstruct S [u U]) \
(defconst g S (S {.u (U.B {.x 1})}))"
~needle:"a constant cannot be U.B";
accepts "a constant written as a literal"
"(defconst x u64 0xcbf29ce484222325)";
accepts "a constant written as arithmetic over other constants"
"(defconst w i64 640) (defconst cell i64 16) (defconst cols i64 (/ w cell))";
accepts "a constant aggregate of literals"
"(defstruct P [x i32 y i32]) (defconst origin P (P {.x 1 .y 2}))";
accepts "a constant array of literals"
"(defconst xs [3 i32] [1 2 3])";
accepts "a zeroed constant"
"(defstruct P [x i32 y i32]) (defconst origin P (P {}))";
(* The fold is over integers only, so the same shape in floats is computed
and refused — deliberately, because widening it would be a second folder
and this pins that there is not one. *)
rejects_check "float arithmetic is not folded into a constant"
"(defconst half f64 (/ 1.0 2.0))"
~needle:"a constant's value must be a compile-time constant";
(* ── Conditions, spec-conditions.md §1 and §2 ──────────────────── *)
accepts "handler-bind over a struct condition"
"(defstruct C [id i32]) (defonce n i64)\n\
(defn f [] () (handler-bind [(C [c] (set n 1))] (signal (C {.id 2}))))";
(* Matching is by type and there is no hierarchy, so a condition has to be a
struct — an integer would have nothing to match against. *)
rejects_check "signalling a non-struct"
"(defn f [] () (signal 1))" ~needle:"a condition is a struct";
rejects_check "erroring with a non-struct"
"(defn f [] () (error 1))" ~needle:"a condition is a struct";
(* §2: error is Never, so it unifies with anything — including the position
where a value of some other type was expected. That is what makes it
usable as a restart-case body's fall-through. *)
accepts "error in value position"
"(defstruct C [id i32])\n\
(defn f [] i32 (error (C {.id 1})))";
(* And signal is not: it is Unit, whatever it finds. *)
rejects_check "signal in value position"
"(defstruct C [id i32])\n\
(defn f [] i32 (signal (C {.id 1})))" ~needle:"expected i32";
(* A handler clause captures the establishing function's locals by value —
spec-memory.md's case 2 — so it can read one. A *store* is the thing that
is not there: the clause holds a copy, and writing to it would leave the
local it came from as it was, which is a silent disagreement and not a
feature. Refused for that reason, with the accumulation case pointed at a
global. *)
accepts "a handler reading a local"
"(defstruct C [id i32])\n\
(defonce seen i32)\n\
(defn f [] () (let [n 7] (handler-bind [(C [c] (set seen (+ n (.id c))))] \
(signal (C {.id 2})))))";
rejects_check "a handler assigning to a captured local"
"(defstruct C [id i32])\n\
(defn f [] () (let [n 0] (handler-bind [(C [c] (set n 1))] (signal (C {.id 2})))))"
~needle:"a handler cannot assign to n";
(* The frames are popped on the way out of the body, so an early exit would
leave them on the stack pointing into a function that has gone. *)
rejects_check "return inside handler-bind"
"(defstruct C [id i32])\n\
(defn f [] i32 (handler-bind [(C [c] (signal c))] (return 1)) 0)"
~needle:"return is not allowed inside handler-bind";
(* spec-memory.md gives a map an upsert of its own, so there is no store
into a lookup and no place form for one. Refused with that reason rather
than as a milestone that will never arrive. *)
rejects_check "a map entry as a place"
"(defn f [m (Map i64 i64)] () (set (get m 1) 2))"
~needle:"entries are written with put";
rejects_check "get with three arguments is not a place"
"(defn f [m dyn] () (set (get m 1 2) 2))"
~needle:"a map is written with (put m k v)";
(* ── restart-case and invoke-restart, §3 to §6 ─────────────────── *)
accepts "restart-case with a clause that transfers into it"
"(defstruct C [id i32])\n\
(defn g [] i32 (signal (C {.id 1})) 0)\n\
(defn f [] i32 (restart-case (g) (skip [] 7)))\n\
(defn h [] i32 (handler-bind [(C [c] (invoke-restart 'skip))] (f)))";
(* §3: the body and every clause yield the whole form, so they have to agree
— which is also what makes the fall-through path visible in the source.
With a type expected from outside they are each checked against it; with
none, as in a let binding, the first one that produces a value sets it. *)
rejects_check "a clause that disagrees with the body"
"(defn f [] i32 (restart-case 1 (skip [] \"no\")))"
~needle:"expected i32, found str";
rejects_check "two clauses that disagree, with nothing expected"
"(defn f [] i32 (let [x (restart-case (exit 1) (a [] 1) (b [] \"no\"))] 0))"
~needle:"expected i32, found str";
(* §4 finds the first frame offering a name. Two of one name in one frame
would make that a choice nothing in the source shows. *)
rejects_check "one restart-case offering a name twice"
"(defn f [] i32 (restart-case 1 (skip [] 2) (skip [] 3)))"
~needle:"offers skip twice";
(* Same rule as handler-bind: the restart frames are popped on the way out. *)
rejects_check "return inside restart-case"
"(defn f [] i32 (restart-case (return 1) (skip [] 2)))"
~needle:"return is not allowed inside restart-case";
(* §3's parameters. A clause binds them like a function's, so the body sees
them and nothing outside does; what they are is checked against the
invoke at run time, because the two ends meet on a dynamic stack. *)
accepts "a restart with parameters"
"(defn f [] i32 (restart-case 1 (skip [n i32] n)))";
accepts "invoke-restart with arguments"
"(defn f [] () (invoke-restart 'skip 1))";
rejects_check "a restart parameter outside its clause"
"(defn f [] i32 (+ (restart-case 1 (skip [n i32] n)) n))"
~needle:"unknown name n";
rejects_check "a restart argument that is not a value"
"(defn f [] () (invoke-restart 'skip (println \"\")))"
~needle:"a restart argument must be a value";
rejects_check "invoke-restart on an unquoted name"
"(defn f [] () (invoke-restart skip))"
~needle:"a quoted restart name and then its arguments";
(* §5 runs the defers on the way out, so a defer is already the cleanup path
a transfer uses. One that starts its own transfer has no answer. *)
rejects_check "invoke-restart inside a defer"
"(defn f [] i32 (defer (invoke-restart 'skip)) 0)"
~needle:"not allowed inside a defer";
(* Still unimplemented, and still says so by name — which is the point: an
operator the spec names and the compiler lacks must not fall through to a
call and come back as an unknown name. *)
List.iter
(fun (name, src) ->
rejects_check (name ^ " is still unimplemented") src
~needle:"not implemented yet")
[ "find-restart", "(defn f [] () (find-restart 'skip))";
"compute-restarts", "(defn f [] () (compute-restarts))" ];
(* ── handler-case ──────────────────────────────────────────────── *)
(* The unwinding handler. It is built out of a handler-bind and a
restart-case, so most of what could go wrong is already pinned where
those two are; what is asserted here is the surface it puts in front of
them and the one rule that is its own — every clause and the body agree
on a type, which is the type of the whole form. *)
let boom =
"(defstruct Boom [id i32])\n(defstruct Dud [id i32])\n"
in
accepts "handler-case"
(boom ^ "(defn f [] i32 (handler-case 1 [(Boom [c] (.id c))]))");
accepts "handler-case with several clauses"
(boom ^ "(defn f [] i32 (handler-case 1 [(Boom [c] (.id c)) \
(Dud [c] (+ 1 (.id c)))]))");
(* The difference from handler-bind is narrower than it was. Both see the
establishing function's locals now — a handler-case clause *is* that
function, and a handler-bind clause captures them by value. What only a
handler-case clause can do is *assign* to one, because it is not holding
a copy. *)
accepts "a handler-case clause sees the establishing function's locals"
(boom ^ "(defn f [] i32 (let [n 1] (handler-case 0 [(Boom [c] n)])))");
accepts "and may assign to one, which a handler-bind clause may not"
(boom ^ "(defn f [] i32 (let [n 1] (handler-case 0 [(Boom [c] (set n 2) n)])))");
rejects_check "a handler-bind clause still cannot"
(boom ^ "(defn f [] i32 (let [n 1] (handler-bind [(Boom [c] (set n 2))] 0)))")
~needle:"a handler cannot assign to n";
(* Nothing static refuses a condition no clause lists: it installs no frame
that matches, so it goes past untouched and the body carries on. *)
accepts "a condition no clause lists"
(boom ^ "(defn f [] i32 (handler-case (do (signal (Dud {.id 1})) 7) \
[(Boom [c] 0)]))");
(* The typing rule, and it fails where an [if] with disagreeing arms fails:
at the form that does not fit, saying what was wanted and what was
found. *)
rejects_check "a handler-case clause that disagrees with the body"
(boom ^ "(defn f [] i32 (handler-case 1 [(Boom [c] \"no\")]))")
~needle:"expected i32, found str";
rejects_check "two handler-case clauses that disagree"
(boom ^ "(defn f [] () (println (handler-case 1 [(Boom [c] 2) \
(Dud [c] \"no\")])))")
~needle:"expected i32, found str";
(* Two clauses for one condition type: the first would take every one of
them and the second could never run. *)
rejects_check "one condition type twice"
(boom ^ "(defn f [] i32 (handler-case 1 [(Boom [c] 2) (Boom [c] 3)]))")
~needle:"handles Boom twice";
rejects_check "a handler-case clause on something that is not a struct"
"(defn f [] i32 (handler-case 1 [(i32 [c] 2)]))"
~needle:"a handler matches a struct type";
(* The frames are established around the body and taken off after it, so an
early exit out of the middle would leave them on the stack — and the
refusal names the form the reader wrote rather than the handler-bind
underneath it. *)
rejects_check "return inside a handler-case body"
(boom ^ "(defn f [] i32 (handler-case (return 1) [(Boom [c] 2)]))")
~needle:"not allowed inside handler-case";
(* A clause is the other side of that rule and not an exception to it. It
runs at the form, in the function that wrote it, with the frames already
off the stack — so a [return] there is an ordinary return and there is
nothing left for it to strand. *)
accepts "return inside a handler-case clause"
(boom ^ "(defn f [] i32 (handler-case 1 [(Boom [c] (return 2))]))");
(* A defer is not, though, and for the reason every nested form is refused
one: it is copied onto every exit path of the *function*, so a defer
written where it looks scoped to the clause would run whether the clause
did or not. The same answer a restart-case clause gets. *)
rejects_check "defer inside a handler-case clause"
(boom ^ "(defn f [] i32 (handler-case 1 [(Boom [c] (defer (println \"\")) 2)]))")
~needle:"defer is not allowed inside a nested form";
(* The other way round works. A defer is the cleanup an unwind runs, so
establishing frames inside one is ordinary — what a defer may not do is
start a transfer that leaves it, and a handler-case begins and ends its
own. *)
accepts "handler-case inside a defer"
(boom ^ "(defn f [] i32 (defer (println (handler-case 1 [(Boom [c] 2)]))) 0)");
(* The shape. The clauses go in a vector after the body, which is the
opposite of handler-bind's order, so a form written the other way round
has to say so rather than parse as something else. *)
rejects_check "handler-case with no clauses"
(boom ^ "(defn f [] i32 (handler-case 1 []))")
~needle:"at least one clause";
rejects_check "handler-case written the handler-bind way round"
(boom ^ "(defn f [] i32 (handler-case [(Boom [c] 2)] 1))")
~needle:"handler-case is (handler-case body";
rejects_check "a handler-case clause that binds nothing"
(boom ^ "(defn f [] i32 (handler-case 1 [(Boom [] 2)]))")
~needle:"a handler-case clause is (Type [name] body ...)";
(* ── A function with nothing in it ─────────────────────────────── *)
(* The empty body, the other half of (when test) with no body: a function
that does nothing is a function, and the only question is whether it has
a value to answer. A declared () says it does not and the body may be
empty; a declared anything else says it does, and an empty body cannot
provide one. *)
accepts "a defn returning () with no body"
"(defn nothing [n i32] ())\n(defn f [] i32 (nothing 1) 0)";
rejects_check "a defn returning a value with no body"
"(defn nothing [n i32] i32)"
~needle:"returns i32 but has no body";
(* An fn declares no return type, so the position decides instead. Both arms
are asserted, because the refusal is the one that would otherwise let a
call read a return value nothing wrote. *)
accepts "an fn with no body where a (Fn [] ()) is wanted"
"(defn call [f (Fn [] ())] () (f))\n(defn f [] i32 (call (fn [])) 0)";
rejects_check "an fn with no body where a value is wanted"
"(defn call [f (Fn [] i32)] i32 (f))\n(defn f [] i32 (call (fn [])))"
~needle:"an fn with no body answers ()";
(* ── Destructuring ─────────────────────────────────────────────── *)
(* A pattern is desugared in [Parse] into the bindings and field accesses that
already existed, so what these assert is that the desugaring is *checked* —
the same errors an equivalent hand-written let would raise, pointing at the
pattern that stands in for it. *)
let pt = "(defstruct Point [x i32 y i32])\n" in
let line = pt ^ "(defstruct Line [a Point b Point])\n" in
accepts "struct pattern with :keys"
(pt ^ "(defn f [p Point] i32 (let [{:keys [x y]} p] (+ x y)))");
accepts "struct pattern with a name/:field pair"
(pt ^ "(defn f [p Point] i32 (let [{a .x b .y} p] (+ a b)))");
accepts "a nested struct pattern"
(line ^ "(defn f [l Line] i32 (let [{{:keys [x y]} .a} l] (+ x y)))");
(* A later binding sees an earlier pattern's names, as in any let. *)
accepts "a binding after a pattern sees its names"
(pt ^ "(defn f [p Point] i32 (let [{:keys [x]} p y (+ x 1)] y))");
(* Shadowing works because the value goes into a temporary first. *)
accepts "a pattern may shadow the name it destructures"
(line ^ "(defn f [a Line] i32 (let [{a .a} a] (.x a)))");
accepts "a pattern over a call"
(pt ^ "(defn mk [] Point (Point {.x 1 .y 2}))\n\
(defn f [] i32 (let [{:keys [x y]} (mk)] (+ x y)))");
(* The shorthand: a lone .field binds a local of the field's own name. It is
:keys said in the spelling the rest of the language uses for a field, and
it mixes with the pair form in one brace because the two are told apart
one item at a time -- a dot in head position is the shorthand, anything
else is a pattern expecting its .field next. *)
accepts "struct pattern with the .field shorthand"
(pt ^ "(defn f [p Point] i32 (let [{.x .y} p] (+ x y)))");
accepts "the shorthand mixed with a pair in one brace"
(pt ^ "(defn f [p Point] i32 (let [{.x b .y} p] (+ x b)))");
accepts "the shorthand inside a nested pattern"
(line ^ "(defn f [l Line] i32 (let [{{.x .y} .a} l] (+ x y)))");
(* The shorthand names a field, so an unknown one is the same refusal the
named form gets -- it is the same field access underneath. *)
rejects_check "the shorthand naming a field the struct does not have"
(pt ^ "(defn f [p Point] i32 (let [{.z} p] 0))")
~needle:"Point has no field z";
(* This used to be "{.x} has no .field": a lone dotted symbol was read as a
name to bind and the brace then wanted a field after it. An even number
of them was worse than a refusal -- {.x .y} parsed as "bind a local
called .x to field y" and the program failed later with "unknown name x",
several lines from the mistake. Both readings are gone. *)
accepts "a lone .field is the shorthand and not a missing pair"
(pt ^ "(defn f [p Point] i32 (let [{.x} p] x))");
(* And the arm that refusal came from is still there for the case it was
written for: a plain name with nothing after it. *)
rejects_check "a name with no field after it"
(pt ^ "(defn f [p Point] i32 (let [{a} p] 0))")
~needle:"has no .field";
(* And where the shorthand does *not* reach, which is not a limitation it
introduced: a struct pattern has never worked in a match arm, and the two
spellings are refused identically there. Pinned as a pair, because "the
shorthand works wherever {name .field} works" is the claim, and a row on
only one of them would not be saying it. *)
List.iter
(fun pat ->
rejects_check ("a struct pattern in a match arm: " ^ pat)
(pt ^ Printf.sprintf
"(defn f [p Point] i32 (match p %s 0))" pat)
~needle:"expected a pattern, found")
[ "{.x .y}"; "{a .x}" ];
rejects_check "a field the struct does not have"
(pt ^ "(defn f [p Point] i32 (let [{:keys [x z]} p] (+ x z)))")
~needle:"Point has no field z";
rejects_check "a struct pattern over something that is not a struct"
"(defn f [n i32] i32 (let [{:keys [x]} n] x))"
~needle:"i32 is not a struct, so it has no fields";
rejects_check "one pattern binding a name twice"
(pt ^ "(defn f [p Point] i32 (let [{:keys [x x]} p] x))")
~needle:"this pattern binds x twice";
rejects_check "an empty struct pattern"
(pt ^ "(defn f [p Point] i32 (let [{} p] 0))")
~needle:"an empty struct pattern {} binds nothing";
rejects_check "a pattern with no field name after it"
(pt ^ "(defn f [p Point] i32 (let [{a b} p] 0))")
~needle:"expected .field after a";
(* The same refusal on the destructuring side: a field is a field wherever it
is named, so the rule is not half-applied. :keys is the one that keeps its
colon, and the test below it says so. *)
rejects_check "a destructured field written with a colon"
(pt ^ "(defn f [p Point] i32 (let [{a :x} p] a))")
~needle:"a field label is written .x, not :x";
accepts ":keys keeps its colon, naming no field"
(pt ^ "(defn f [p Point] i32 (let [{:keys [x y]} p] (+ x y)))");
(* Clojure's other map-destructuring keys. Each is refused by its own name:
"unexpected form" would leave the author guessing which of the four they
wrote is the one this does not have. *)
List.iter
(fun k ->
rejects_check (k ^ " in a struct pattern")
(pt ^ Printf.sprintf
"(defn f [p Point] i32 (let [{:keys [x] %s q} p] x))" k)
~needle:(k ^ " is not implemented in a destructuring pattern"))
[ ":as"; ":or"; ":strs"; ":syms" ];
(* ── Sequential patterns, and the asymmetry ────────────────────── *)
(* A fixed array's length is in its type, so the arity is a claim the checker
can settle. *)
accepts "an array pattern naming every element"
"(defn f [] i32 (let [xs [1 2 3] [a b c] xs] (+ a (+ b c))))";
accepts "an array pattern with & rest"
"(defn f [] i32 (let [xs [1 2 3] [a & r] xs] (+ a (length r))))";
accepts "& rest taking an empty tail"
"(defn f [] i32 (let [xs [1 2] [a b & r] xs] (+ a (+ b (length r)))))";
accepts "a struct pattern nested in an array pattern"
(pt ^ "(defn f [ps [2 Point]] i32 \
(let [[{:keys [x]} {y .y}] ps] (+ x y)))");
rejects_check "an array pattern that names too few elements"
"(defn f [] i32 (let [xs [1 2 3] [a b] xs] (+ a b)))"
~needle:"this pattern binds 2 names, but [3 i32] has 3 elements";
rejects_check "an array pattern that names too many"
"(defn f [] i32 (let [xs [1 2] [a b c] xs] (+ a (+ b c))))"
~needle:"this pattern binds 3 names, but [2 i32] has 2 elements";
rejects_check "& rest with more names before it than there are elements"
"(defn f [] i32 (let [xs [1 2] [a b c & r] xs] a))"
~needle:"binds 3 names before the &, but [2 i32] has only 2 elements";
(* The asymmetry, and the reason this is refused rather than lowered to a
bounds-checked [at]: over a slice the arity is a claim about a number that
does not exist until the program runs, so a pattern that type checks would
be one that kills the program instead. *)
rejects_check "an array pattern over a slice"
"(defn f [s [i32]] i32 (let [[a b] s] (+ a b)))"
~needle:"a slice's length is not known until the program runs";
rejects_check "an array pattern over a slice, even with & rest"
"(defn f [s [i32]] i32 (let [[a & r] s] (+ a (length r))))"
~needle:"a slice's length is not known until the program runs";
rejects_check "an array pattern over something with no elements at all"
"(defn f [n i32] i32 (let [[a b] n] (+ a b)))"
~needle:"i32 is not a fixed array";
rejects_check "an empty array pattern"
"(defn f [] i32 (let [xs [1 2] [] xs] 0))"
~needle:"an empty array pattern [] binds nothing";
rejects_check "& with nothing after it"
"(defn f [] i32 (let [xs [1 2] [a &] xs] a))"
~needle:"& needs a name after it";
rejects_check "& with two names after it"
"(defn f [] i32 (let [xs [1 2] [a & r s] xs] a))"
~needle:"& takes one name";
rejects_check "a pattern that is only & rest"
"(defn f [] i32 (let [xs [1 2] [& r] xs] (length r)))"
~needle:"binds the whole value";
rejects_check "one array pattern binding a name twice"
"(defn f [] i32 (let [xs [1 2] [a a] xs] a))"
~needle:"this pattern binds a twice";
(* ── Where a pattern is not a binding form ─────────────────────── *)
(* Every other binding position takes a plain name. A parameter is the one
worth a reason: it is a name/type pair, and a pattern has no name for the
type to pair with. Refused where it is written, not left to fall out of
"expected a name". *)
List.iter
(fun (what, src) ->
rejects_check ("a pattern in " ^ what) src
~needle:"this position takes a plain name")
[ "a defn parameter", pt ^ "(defn f [{:keys [x]} Point] i32 x)";
"a defstruct field", "(defstruct S [[a b] i32])";
"an fn parameter", "(defn f [] i32 (let [g (fn [[a b]] a)] 0))";
"a dotimes counter", "(defn f [] () (dotimes [[a b] 3] 0))";
"a declare parameter", pt ^ "(declare g [{:keys [x]} Point] \"G\")" ];
(* ── match over an enum ────────────────────────────────────────── *)
(* The arms name members as keywords, and the lowering is a chain of [=]
over one temporary, so the exhaustiveness rule is the data type's:
refused, not defaulted. *)
let k = "(defenum K [lo 0 hi 1 mid 2])\n" in
accepts "match over an enum, every member named"
(k ^ "(defn f [k K] i32 (match k :lo 1 :hi 2 :mid 3))");
accepts "match over an enum, with _ for the rest"
(k ^ "(defn f [k K] i32 (match k :lo 1 _ 2))");
accepts "match over an enum, :else for the rest"
(k ^ "(defn f [k K] i32 (match k :lo 1 :else 2))");
(* A data type's case is matched by a symbol, not a keyword, so a case
named else does not collide with :else and is not refused. *)
accepts "a data case named else is matched by name"
"(defdata D [(else) (foo [x i32])])\n\
(defn f [d D] i32 (match d else 1 (foo x) x))";
rejects_check "match over an enum that misses a member"
(k ^ "(defn f [k K] i32 (match k :lo 1 :hi 2))")
~needle:"this match is not exhaustive — :mid has no arm";
rejects_check "a member the enum does not have"
(k ^ "(defn f [k K] i32 (match k :low 1 _ 2))")
~needle:"K has no member :low — did you mean :lo?";
rejects_check "a member named twice"
(k ^ "(defn f [k K] i32 (match k :lo 1 :lo 2 _ 3))")
~needle:"this match has two :lo arms";
rejects_check "match over an enum, members written as names"
(k ^ "(defn f [k K] i32 (match k lo 1 _ 2))")
~needle:"lo is not one of its members. An arm names a member as a keyword: :lo :hi :mid";
rejects_check "a keyword arm over an Option"
"(defn f [o (Option i32)] i32 (match o :lo 1 _ 2))"
~needle:"whose arms are (Some x) and None";
rejects_check "arms of different types"
(k ^ "(defn f [k K] i32 (match k :lo 1 _ \"x\"))")
~needle:"expected i32, found str";
rejects_check "match over something that is none of them"
"(defn f [n [u8]] i32 (match n _ 2))"
~needle:"match works on an Option, a data type, an enum, a bool, a \
number, a string or a dyn, not on [u8]";
(* ── match over literals ───────────────────────────────────────── *)
(* Each arm is (= t lit) with the literal built at the scrutinee's type, so
a literal that type cannot hold is refused rather than widened into an
arm that never matches. *)
accepts "match over an i16, a literal arm built at i16"
"(defn f [n i16] i32 (match n 5 1 -3 2 _ 0))";
accepts "match over a string" "(defn f [s str] i32 (match s \"go\" 1 _ 0))";
accepts "match over a dyn, arms of several kinds"
"(defn f [d dyn] i32 (match d 1 1 2.5 2 \"go\" 3 \\a 4 _ 0))";
accepts "match over a number, :else for the rest"
"(defn f [n i32] i32 (match n 5 1 :else 0))";
rejects_check "a literal arm the scrutinee cannot hold"
"(defn f [n i8] i32 (match n 300 1 _ 0))"
~needle:"this match is over i8, so each arm has to be an i8, and 300 does \
not fit in one. Change the arm to a value an i8 holds, or remove it";
rejects_check "a float arm over an integer"
"(defn f [n i32] i32 (match n 1.5 1 _ 0))"
~needle:"and 1.5 is not a whole number";
rejects_check "a string arm over a number"
"(defn f [n i32] i32 (match n \"a\" 1 _ 0))"
~needle:"and \"a\" is a string";
rejects_check "a number arm over a string"
"(defn f [s str] i32 (match s 5 1 _ 0))"
~needle:"so each arm has to be a str, and 5 is a number";
rejects_check "a literal match with no _ arm"
"(defn f [n i32] i32 (match n 5 1 6 2))"
~needle:"this match is not exhaustive — its arms are literals, and no list \
of them covers every i32. Add a _ arm for the rest, as in (match \
n 5 1 _ 0)";
rejects_check "a literal match over a dyn with no _ arm"
"(defn f [d dyn] i32 (match d 5 1))"
~needle:"covers every dyn value";
rejects_check "a literal named twice"
"(defn f [n i32] i32 (match n 5 1 5 2 _ 0))"
~needle:"this match has two 5 arms";
rejects_check "a char and a number that are one u8"
"(defn f [c u8] i32 (match c \\a 1 97 2 _ 0))"
~needle:"this match has two \\a arms — 97 equals it as a u8";
rejects_check "1 and 1.0 are one arm over a dyn, as dyn = says"
"(defn f [d dyn] i32 (match d 1 1 1.0 2 _ 0))"
~needle:"this match has two 1 arms — 1.0 equals it as a dyn";
rejects_check "two literals that round to one f32"
"(defn f [x f32] i32 (match x 0.1 1 0.10000000001 2 _ 0))"
~needle:"this match has two 0.1 arms — 0.10000000001 equals it as an f32";
rejects_check "two integers that round to one f32"
"(defn f [x f32] i32 (match x 16777216 1 16777217 2 _ 0))"
~needle:"two 16777216 arms — 16777217 equals it as an f32";
rejects_check "an integer and a float that are one f64"
"(defn f [x f64] i32 \
(match x 4611686018427387904 1 4611686018427387904.0 2 _ 0))"
~needle:"equals it as an f64";
accepts "two f64 literals that differ"
"(defn f [x f64] i32 (match x 0.1 1 0.10000000001 2 _ 0))";
rejects_check "a literal no dyn holds"
"(defn f [x dyn] i32 (match x 18446744073709551615 1 _ 0))"
~needle:"this match is over a dyn, which holds a number as an i64 or an \
f64, and 18446744073709551615 fits in neither. Change the arm to \
a value an i64 holds, or remove it";
rejects_check "a keyword arm among literal arms"
"(defn f [n i32] i32 (match n 5 1 :lo 2 _ 0))"
~needle:":lo is an enum member, and this match is over i32, whose arms are \
literals, as in (match n 5 1 _ 0)";
rejects_check "a case arm among literal arms"
"(defn f [n i32] i32 (match n 5 1 (Some x) 2 _ 0))"
~needle:"Some names a case, and this match is over i32";
rejects_check "a literal arm among keyword arms"
(k ^ "(defn f [k K] i32 (match k :lo 1 5 2 _ 0))")
~needle:"5 is a literal, and this match is over the enum K";
rejects_check "a literal arm over an Option"
"(defn f [o (Option i32)] i32 (match o 5 1 _ 0))"
~needle:"5 is a literal, and this match is over an Option";
rejects_check "a literal match over a byte slice, which = does not compare"
"(defn f [b [u8]] i32 (match b \"a\" 1 _ 0))"
~needle:"not on [u8]";
(* ── match over a bool, keyword arms over a dyn ────────────────── *)
accepts "a match over a bool naming both is exhaustive"
"(defn f [b bool] i32 (match b true 1 false 0))";
accepts "a match over a bool, one arm and _"
"(defn f [b bool] i32 (match b false 1 _ 0))";
rejects_check "a match over a bool naming one of them"
"(defn f [b bool] i32 (match b true 1))"
~needle:"this match is not exhaustive — false has no arm. Add it, or a _ \
arm for the rest";
rejects_check "true named twice"
"(defn f [b bool] i32 (match b true 1 true 2 _ 0))"
~needle:"this match has two true arms";
rejects_check "a number arm over a bool"
"(defn f [b bool] i32 (match b 1 1 _ 0))"
~needle:"1 is a literal, and this match is over a bool, whose arms are \
true and false, as in (match b true 1 false 0)";
rejects_check "a keyword arm over a bool"
"(defn f [b bool] i32 (match b :yes 1 _ 0))"
~needle:":yes is a keyword, and this match is over a bool";
accepts "keyword arms over a dyn, beside numbers, strings and bools"
"(defn f [d dyn] i32 (match d :north 1 :south 2 5 3 \"w\" 4 true 5 _ 0))";
rejects_check "keyword arms over a dyn need a _ arm"
"(defn f [d dyn] i32 (match d :north 1 :south 2))"
~needle:"covers every dyn value. Add a _ arm for the rest, as in (match d \
5 1 :go 2 _ 0)";
rejects_check "a keyword named twice over a dyn"
"(defn f [d dyn] i32 (match d :north 1 :north 2 _ 0))"
~needle:"this match has two :north arms";
rejects_check "true named twice over a dyn"
"(defn f [d dyn] i32 (match d true 1 true 2 _ 0))"
~needle:"this match has two true arms";
accepts "a keyword arm over an enum still names a member"
(k ^ "(defn f [k K] i32 (match k :lo 1 _ 0))");
(* = and != compare bools; ordering them stays refused. *)
accepts "= on bools" "(defn f [a bool b bool] bool (= a b))";
accepts "!= on bools, chained" "(defn f [a bool b bool] bool (!= a b true))";
rejects_check "< on bools"
"(defn f [a bool b bool] bool (< a b))"
~needle:"< orders machine numbers and enums, and bool is neither";
rejects_check "= on a struct names what it compares"
"(defstruct P [x i32])\n(defn f [a P b P] bool (= a b))"
~needle:"= compares numbers, enums, strings and bools, and P is none of \
those";
(* A destructuring pattern in an arm's binds is a name position like any
other. *)
rejects_check "a pattern inside a match arm's binds"
"(defstruct P [x i32])\n\
(defn f [o (Option P)] i32 (match o (Some {:keys [x]}) x None 0))"
~needle:"this position takes a plain name";
(* The desugaring's own machinery is unspellable: the reader makes [~] a
delimiter, so the name never reaches the parser as one symbol. *)
rejects_check "the desugaring's internal name cannot be written by hand"
"(defn f [] i32 (let [xs [1 2]] (destructure~nth xs 0 2 1)))"
~needle:"means nothing outside a quasiquote";
(* ── The untagged union ────────────────────────────────────────── *)
(* Every one of these is a rule the type would be unsound or useless
without, and each says so in its own words rather than falling through to
something generic. The layout itself is pinned where a layout can only be
pinned, against the backend that computes it — see the DWARF/LLVM oracle
in test_acceptance.ml — and what it *does* is pinned by a program that
writes one member and reads another, which is the whole point of the
type. What is here is the catalogue of what it refuses. *)
(match (parse_decl "(defunion U [i i32 f f32])").Ast.d with
| Ast.Defunion ("U", [ a; b ]) ->
check "defunion parses as a member list"
(a.Ast.fname = "i" && b.Ast.fname = "f")
| _ -> check "defunion parses as a member list" false);
(* Nothing to read out of, and no size. It parses; it is refused where the
message can name the shape. *)
rejects_check "a union with no members"
"(defunion U [])\n(defn f [u U] i32 0)"
~needle:"declares no members";
rejects_check "a union that declares a member twice"
"(defunion U [x i32 x f32])\n(defn f [u U] i32 0)"
~needle:"declares the same member twice";
(* The size is the largest member and the largest member is the whole type,
so this is the same infinite type a self-containing struct is. *)
rejects_check "a union that contains itself by value"
"(defunion U [a i32 b U])\n(defn f [u U] i32 0)"
~needle:"contains itself by value";
(* Nothing records which member is live, and since the second repeal that
is the program's fact to keep rather than a refusal: a union member may
own storage, C's way. *)
accepts "a union member that owns storage"
"(defunion U [n i64 v (Vec i32)])\n(defn f [u U] i32 0)";
(* And the one the optimiser would otherwise be handed: a byte that is
neither 0 nor 1 read as an i1. Refused at any depth, which is why the
second row goes through a struct. *)
rejects_check "a bool member"
"(defunion U [b bool n u8])\n(defn f [u U] i32 0)"
~needle:"a union may not hold one at any depth";
rejects_check "a bool inside a struct member"
"(defstruct S [flag bool n i32])\n\
(defunion U [s S n i64])\n(defn f [u U] i32 0)"
~needle:"a union may not hold one at any depth";
(* The same hazard as uninit on a data type, arriving the other way round: a
member written over the tag leaves a tag no case names, and a match on it
falls into a block the optimiser may treat as unreachable. Refused at any
depth for the reason bool is. *)
rejects_check "a data type member"
"(defdata D [A (B [x i32])])\n\
(defunion U [d D n i64])\n(defn f [u U] i32 0)"
~needle:"a data type, and a union may not hold one";
rejects_check "a data type inside a struct member"
"(defdata D [A B])\n(defstruct S [d D n i32])\n\
(defunion U [s S n i64])\n(defn f [u U] i32 0)"
~needle:"a data type, and a union may not hold one";
(* An Option is not on that list, and the difference is the lowering: its
match is a test of the tag byte and a branch, so a scribbled tag reads as
a Some with a payload nobody stored — which is what this language says a
union read is. *)
(match checked "(defunion U [o (Option i32) n i64])\n\
(defn f [u U] i32 (match (.o u) (Some x) x None 0))" with
| _ -> check "an Option member is allowed" true
| exception Loc.Error { Loc.dmsg = msg; _ } ->
incr failures;
Printf.printf "FAIL an Option member is allowed: %s\n" msg);
(* One member named twice is a different mistake from two members named, and
it gets the refusal the struct path already had. *)
rejects_check "a union literal naming one member twice"
"(defunion U [i i32])\n\
(defn f [] i32 (let [u (U {.i 1 .i 2})] (.i u)))"
~needle:"member i is given twice";
(* Two members is one storage written twice, and which one survived would be
whatever the compiler happened to do last. *)
rejects_check "a union literal giving two members"
"(defunion U [i i32 f f32])\n\
(defn f [] i32 (let [u (U {.i 1 .f 2.0})] (.i u)))"
~needle:"only one member can be written";
rejects_check "a union literal giving a member it does not have"
"(defunion U [i i32])\n(defn f [] i32 (let [u (U {.z 1})] (.i u)))"
~needle:"U has no member z";
(* There is no tag, so there is nothing for the arms to be alternatives
over. Said by name because the two kinds of union are one keyword apart
and somebody will write it. *)
rejects_check "match on a union"
"(defunion U [i i32 f f32])\n\
(defn f [u U] i32 (match u _ 0))"
~needle:"nothing in one records which member was written";
(* A member narrower than the union leaves the rest indeterminate, so two
values that agree about everything anybody wrote would hash apart. *)
rejects_check "a union as a map key"
"(defunion U [i i32 f f32])\n\
(defn f [m (Map U i32) k U] () (put m k 1))"
~needle:"a union is not a map key";
(* A constant is what the linker writes into the image and a union member is
a store, so a defconst is refused rather than coming back from the emitter
as "this one is computed". A defonce is not refused any more: its computed
initialiser is lifted into a function that runs at startup, and the member
is written by the same store that writes one in a body. *)
accepts "a global initialised with a union member"
"(defunion U [i i32])\n(defonce g U (U {.i 1}))\n(defn f [] i32 0)";
rejects_check "a constant initialised with a union member"
"(defunion U [i i32])\n(defconst c U (U {.i 1}))\n(defn f [] i32 0)"
~needle:"cannot be written into a constant";
(* The all-bytes-zero value is a constant and goes through, which is what
makes (U {}) and a declaration with no value the same thing. *)
(match checked "(defunion U [i i32])\n(defonce g U (U {}))\n\
(defn f [] i32 (.i g))" with
| _ -> check "a global zeroed through a literal is allowed" true
| exception Loc.Error { Loc.dmsg = msg; _ } ->
incr failures;
Printf.printf "FAIL a global zeroed through a literal is allowed: %s\n" msg);
(* uninit is refused on a data type because its tag steers a match into a
block LLVM may treat as unreachable. An untagged union steers nothing, so
the argument does not carry over and the answer is different. *)
(match checked "(defunion U [i i32 f f32])\n(defonce g U uninit)\n\
(defn f [] i32 (.i g))" with
| _ -> check "uninit on a union is allowed" true
| exception Loc.Error { Loc.dmsg = msg; _ } ->
incr failures;
Printf.printf "FAIL uninit on a union is allowed: %s\n" msg);
(* The shim writes structs and has no spelling for a union yet — a refusal
about the generator, not about the type, and it says so. *)
rejects_check "a union crossing to C by value"
"(defunion U [i i32])\n(declare-c take [u U] () \"take\")"
~needle:"the shim generator writes structs only";
(* ── Reading a C header (cimport.ml, cjson.ml) ─────────────────── *)
(* Against test/headers/sample.h, which is one function per decision the
importer makes and is committed so that it cannot move. The raylib case
is better evidence and worse coverage: it needs raylib installed, at the
version whose .so is linked, with FLAN_RAYLIB_H set, so as the only test
of this it would skip everywhere.
The assertions are on the *reasons*, not on the counts, for the reason the
acceptance table gives: a refusal that fires for the wrong cause still
refuses, and a count still matches. *)
let imported, dump, env, fixture_ds =
let fixture =
"(defstruct Pair [x f32 y f32])\n\
(defstruct Shade [r u8 g u8 b u8 a u8])\n\
(defenum Mood [calm 0 cross 1])\n\
(defunion Overlay [i i32 f f32])\n\
(defstruct Slot [kind i32 v Overlay])\n"
in
let ds = program fixture in
let taken = Hashtbl.create 16 in
List.iter
(fun d ->
match Ast.declared_name d with
| Some n -> Hashtbl.replace taken n ()
| None -> ())
ds;
let known_structs =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, _, _) -> Some n | _ -> None)
ds
and known_unions =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defunion (n, _) -> Some n | _ -> None)
ds
and known_enums =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defenum (n, _) -> Some n | _ -> None)
ds
in
let i, d, e =
Cimport.header ~loc:Loc.unknown ~header:"headers/sample.h" ~flags:[]
~known_structs ~known_unions ~known_enums ~taken ~bound_syms:[]
~config:Cimport.no_config
in
(i, d, e, ds)
in
(* What came out, as source, so a wrong type is visible as the line somebody
would otherwise have had to write by hand. *)
let produced = List.map Cimport.decl_source imported.Cimport.decls in
let emits name line =
check ("import-c emits " ^ name) (List.mem line produced)
in
emits "a scalar signature" "(declare-c set-seed [seed u32] \"set_seed\")";
emits "two scalars and a return"
"(declare-c add-ints [a i32 b i32] i32 \"add_ints\")";
(* An aggregate return is the flattening path: Shim turns it into an
out-pointer, and the declaration it starts from has to say the struct. *)
emits "an aggregate return"
"(declare-c make-pair [x f32 y f32] Pair \"make_pair\")";
emits "an aggregate parameter" "(declare-c pair-len [p Pair] f32 \"pair_len\")";
(* const char * is a string going in — the one C spelling that means
something different in a parameter than it does anywhere else. *)
emits "const char * as a string parameter"
"(declare-c name-length [text str] i32 \"name_length\")";
(* const int * is a pointer C promises not to write through. *)
emits "a const pointer parameter"
"(declare-c count-at [values (Ptr const i32) n i32] i32 \"count_at\")";
(* struct Pair is both Pair and Point in the header and the package
describes it once, so both names have to land on the one defstruct —
raylib does exactly this with Texture2D and TextureCubemap. *)
emits "a second typedef name for a described record"
"(declare-c point-of [p Pair] Pair \"point_of\")";
(* A C enum is an int, and so is a Flan defenum at the boundary; matching by
name is what keeps the nicer face. *)
emits "a C enum against a defenum of the same name"
"(declare-c mood-value [m Mood] i32 \"mood_value\")";
emits "a function of no arguments" "(declare-c take-nothing [] \"take_nothing\")";
(* And returned: text the caller only reads, which the shim copies. *)
emits "const char * as a string return"
"(declare-c name-of [which i32] str \"name_of\")";
(* And the refusals, each by its reason rather than by a count. *)
let refused name needle =
check
("import-c refuses " ^ name ^ ": " ^ needle)
(List.exists
(fun (n, why) -> n = name && contains why needle)
imported.Cimport.hidden)
in
refused "owned-text" "which the caller owns";
refused "fill-buffer" "C may write through";
refused "printf-like" "is variadic";
refused "on-event" "is a function pointer";
refused "file-time" "width that differs";
refused "make-undescribed" "the package does not describe";
(* The order-dependent one. Spin2D and spin2d both kebab to spin-2d, so
neither may have it: whichever won would depend on the order the header
declares them in, and moving two lines in somebody else's header would
rebind a name a program is already calling. *)
refused "spin-2d" "would depend on the order";
check "a colliding name is not imported after all"
(not (List.exists (fun l -> contains l "\"Spin2D\"") produced));
check "nor is the other half of the collision"
(not (List.exists (fun l -> contains l "\"spin2d\"") produced));
(* ── The config beside the header (Cimport.read_config) ────────── *)
(* Why there is a config at all: the generated declarations are committed, so
a hand-edit to them is destroyed by the next regeneration and the edit has
to live somewhere regeneration reads instead. These are the two things it
can say. *)
let with_config config =
let taken = Hashtbl.create 16 in
List.iter
(fun d ->
match Ast.declared_name d with
| Some n -> Hashtbl.replace taken n ()
| None -> ())
fixture_ds;
let known_structs =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, _, _) -> Some n | _ -> None)
fixture_ds
and known_unions =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defunion (n, _) -> Some n | _ -> None)
fixture_ds
and known_enums =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defenum (n, _) -> Some n | _ -> None)
fixture_ds
in
let i, _, _ =
Cimport.header ~loc:Loc.unknown ~header:"headers/sample.h" ~flags:[]
~known_structs ~known_unions ~known_enums ~taken ~bound_syms:[] ~config
in
(List.map Cimport.decl_source i.Cimport.decls, i.Cimport.hidden)
in
let lines, hidden =
with_config { Cimport.no_config with Cimport.excludes = [ "set_seed" ] }
in
check "an excluded symbol is not generated"
(not (List.exists (fun l -> contains l "\"set_seed\"") lines));
(* Not silently absent. "there is no such binding" and "the package decided
against this binding" are different answers and a reader gets the second,
which is what [hidden] is for. *)
check "and it says it was excluded rather than going quiet"
(List.exists
(fun (n, why) -> n = "set-seed" && contains why "excluded by the package")
hidden);
let lines, _ =
with_config { Cimport.no_config with Cimport.excludes = [ "add_*" ] }
in
check "an exclude pattern matches by prefix"
(not (List.exists (fun l -> contains l "\"add_ints\"") lines));
check "and leaves everything it does not match"
(List.exists (fun l -> contains l "\"set_seed\"") lines);
let lines, _ =
with_config
{ Cimport.no_config with Cimport.renames = [ ("set_seed", "seed") ] }
in
(* The C symbol is kept verbatim, so an override changes the Flan face and
nothing else — which is what makes it safe to spell a predicate the way
Lisp spells one. *)
check "a name override is the Flan name, and the C symbol is untouched"
(List.mem "(declare-c seed [seed u32] \"set_seed\")" lines);
(* The collision above is refused because neither Spin2D nor spin2d may take
[spin-2d] by an accident of header order. Naming one of them is the way
out, and it is the reason the kebab rule is consulted in exactly one
place: the groups are computed on the name a function will really take,
so the rename dissolves the group rather than leaving both refused. *)
let lines, hidden =
with_config
{ Cimport.no_config with Cimport.renames = [ ("Spin2D", "spin-2d-upper") ] }
in
check "a rename resolves a collision for both halves"
(List.exists (fun l -> contains l "\"Spin2D\"") lines
&& List.exists (fun l -> contains l "\"spin2d\"") lines);
check "and the collision is no longer refused"
(not (List.mem_assoc "spin-2d" hidden));
(* The file, since a typo in it would otherwise show up as a binding under
the wrong name. A line that is neither directive is an error rather than a
line quietly skipped. *)
let config_file text =
let f = Filename.temp_file "flan-bindings" "" in
let ch = open_out f in
output_string ch text;
close_out ch;
f
in
let c = Cimport.read_config (config_file "# a comment\n\nexclude Mem*\nname IsWindowReady window-ready?\n") in
check "read_config reads an exclude" (c.Cimport.excludes = [ "Mem*" ]);
check "read_config reads a name override"
(c.Cimport.renames = [ ("IsWindowReady", "window-ready?") ]);
check "a missing config is no exclusions and no overrides"
(Cimport.read_config "no-such-bindings-file" = Cimport.no_config);
check "a line that is neither directive is refused"
(match Cimport.read_config (config_file "rename Foo bar\n") with
| _ -> false
| exception Loc.Error { Loc.dmsg = m; _ } -> contains m "and this is neither");
(* The enum line's fourth column: the prefix the members carry on the Flan
side, so `key-r` is checked as KEY_R and not KEY_KEY_R. *)
let c = Cimport.read_config (config_file "enum Key KEY_ key-\n") in
check "read_config reads an enum line's Flan member prefix"
(c.Cimport.enum_prefixes = [ ("Key", "KEY_") ]
&& c.Cimport.enum_flan_prefixes = [ ("Key", "key-") ]);
check "a Flan member prefix on `enum Foo -` is refused"
(match Cimport.read_config (config_file "enum Foo - key-\n") with
| _ -> false
| exception Loc.Error { Loc.dmsg = m; _ } ->
contains m "nothing to check Foo against");
(* The package's own file, and the round trip the prefix exists for: a Flan
keyword a program writes, and the C name the rule reaches from it. All
eleven of raylib's enums declare a Flan prefix now — the uniformity is
the claim, so one member of each is pinned rather than a sample. The C
side of each row was read off vendor/raylib/raylib-5.5.h; `flan
generate-c vendor/raylib` is what re-checks that against the header, and
this is what keeps the *spellings* from drifting between times somebody
runs it.
The prefix is a reading choice and not a collision fix: a keyword
resolves against the expected type and nothing else, so :point at a
TextureFilter site was never ambiguous. What is pinned here is that the
bindings file still says so uniformly. *)
let rl = Cimport.read_config "../vendor/raylib/bindings" in
let c_name enum member =
match
( List.assoc_opt enum rl.Cimport.enum_prefixes,
List.assoc_opt enum rl.Cimport.enum_flan_prefixes )
with
| Some cp, Some fp ->
(match Cimport.strip_prefix fp member with
| Some stem -> Some (cp ^ Cimport.screaming stem)
| None -> None)
| _ -> None
in
List.iter
(fun (enum, member, cname) ->
check
(Printf.sprintf "%s/%s is %s" enum member cname)
(c_name enum member = Some cname))
[ ("Key", "key-left-shift", "KEY_LEFT_SHIFT");
("MouseButton", "mouse-left", "MOUSE_BUTTON_LEFT");
("TraceLogLevel", "log-warning", "LOG_WARNING");
("CameraProjection", "projection-perspective", "CAMERA_PERSPECTIVE");
("CameraMode", "camera-third-person", "CAMERA_THIRD_PERSON");
("GamepadButton", "button-left-face-up", "GAMEPAD_BUTTON_LEFT_FACE_UP");
("GamepadAxis", "axis-left-trigger", "GAMEPAD_AXIS_LEFT_TRIGGER");
("Gesture", "gesture-pinch-out", "GESTURE_PINCH_OUT");
("MouseCursor", "cursor-resize-nesw", "MOUSE_CURSOR_RESIZE_NESW");
("TextureFilter", "filter-bilinear", "TEXTURE_FILTER_BILINEAR");
("PixelFormat", "pixel-uncompressed-r8g8b8a8",
"PIXELFORMAT_UNCOMPRESSED_R8G8B8A8") ];
(* And the other half of the same claim: every enum the file maps declares
a Flan prefix. A twelfth enum added with two columns would otherwise
reintroduce the split this closed. `enum Foo -` is exempt and has to be
— a line that says the header has nothing to check cannot carry a third
column at all, which is pinned a few rows above. *)
check "every mapped raylib enum declares a Flan-side member prefix"
(List.for_all
(fun (e, cp) ->
String.equal cp "-" || List.mem_assoc e rl.Cimport.enum_flan_prefixes)
rl.Cimport.enum_prefixes);
(* A refused name is a name that exists and cannot be had — Zig's failDecl,
which Load.refuse_hidden already implements for main. Nothing may be in
both lists, or asking for a name that works would report that it does
not. *)
check "nothing is both imported and refused"
(not
(List.exists
(fun (d : Ast.decl) ->
match Ast.declared_name d with
| Some n -> List.mem_assoc n imported.Cimport.hidden
| None -> false)
imported.Cimport.decls));
(* The struct check, which is the point of reading a header the generator
does not otherwise need: the defstruct and the header's record have
different authors, so a disagreement is real information. A
_Static_assert was rejected in docs/BUILT.md as circular for want of exactly
that. *)
let structs_of ds =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defstruct (n, fs, _) -> Some (n, fs) | _ -> None)
ds
in
check "a defstruct that matches the header is not reported"
(Cimport.check_structs ~env ~structs:(structs_of fixture_ds) dump = []);
(* Permuted: the failure docs/BUILT.md says only a test can catch, because every
field still reads as a plausible number. *)
check "a permuted defstruct is reported"
(match
Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Pair [y f32 x f32])\n")) dump
with
| [ ("Pair", why) ] -> contains why "field order"
| _ -> false);
(* Widened: the other half of the same hazard and the one docs/BUILT.md names —
f64 where the library says float lays out eight bytes where there are
four, and every field after it moves. *)
check "a widened field is reported"
(match
Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Pair [x f32 y f64])\n")) dump
with
| [ ("Pair", why) ] -> contains why "f64" && contains why "f32"
| _ -> false);
(* A struct the header says nothing about is not a disagreement: a package
may describe something the library does not name. *)
check "a struct the header does not describe is left alone"
(Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Nowhere [q i32])\n")) dump
= []);
(* An enum field against the header's [int]. A Flan defenum lowers to
int32_t in a struct field exactly as it does in a parameter, so this is
the same four bytes with a better face on it and not a disagreement —
which is what let raylib's Camera3D.projection stop being an i32 with a
conversion function beside it. *)
check "an enum-typed field against the header's int is not reported"
(Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Mode [kind Mood scale f32])\n"))
dump
= []);
(* Symmetric: the header may be the side that names the enum. *)
check "an i32 field against the header's enum is not reported"
(Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Feel [mood i32 n i32])\n")) dump
= []);
(* And the whole point of the check survives it. The tolerance is for a
32-bit integer and nothing else, so the width hazard docs/BUILT.md names — f64
where the library says float — still fails, in the very struct whose
other field is an enum. *)
check "a widened field beside an enum field is still reported"
(match
Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Mode [kind Mood scale f64])\n"))
dump
with
| [ ("Mode", why) ] -> contains why "f64" && contains why "f32"
| _ -> false);
(* An enum is four bytes, so an enum against something that is not four
bytes is a real disagreement and stays one. *)
check "an enum against a field that is not 32 bits is still reported"
(match
Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Feel [mood i64 n i32])\n")) dump
with
| [ ("Feel", why) ] -> contains why "i64"
| _ -> false);
(* The same claim for a [defunion], and what it unlocked. A record holding a
union member used to be skipped entirely — not recorded, so the
[defstruct] beside it was unchecked too — because there was no Flan type
to compare the member against. There is one now, and [Slot] in the
fixture is checked member by member like any other struct. *)
let unions_of ds =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defunion (n, ms) -> Some (n, ms) | _ -> None)
ds
in
check "a defunion that matches the header is not reported"
(Cimport.check_unions ~env ~unions:(unions_of fixture_ds) dump = []);
check "and the struct holding it is checked rather than skipped"
(Cimport.check_structs ~env ~structs:(structs_of fixture_ds) dump = []);
check "a struct whose union member is given the wrong type is reported"
(match
Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Slot [kind i32 v Pair])\n"))
dump
with
| [ ("Slot", why) ] -> contains why "Overlay"
| _ -> false);
(* Order is the whole hazard for a struct and means nothing for a union:
every member is at offset zero, so a permuted defunion is the same type
and reporting it would be a finding that is not one. *)
check "a permuted defunion is not reported"
(Cimport.check_unions ~env
~unions:(unions_of (program "(defunion Overlay [f f32 i i32])\n")) dump
= []);
(* Missing is the one that changes the size, and a union embedded by value
puts every field after it in the wrong place. *)
check "a defunion missing a member is reported"
(match
Cimport.check_unions ~env
~unions:(unions_of (program "(defunion Overlay [i i32])\n")) dump
with
| [ ("Overlay", why) ] -> contains why "f" && contains why "widest"
| _ -> false);
check "a defunion with a member the header lacks is reported"
(match
Cimport.check_unions ~env
~unions:(unions_of
(program "(defunion Overlay [i i32 f f32 d f64])\n")) dump
with
| [ ("Overlay", why) ] -> contains why "d"
| _ -> false);
check "a defunion whose member is the wrong width is reported"
(match
Cimport.check_unions ~env
~unions:(unions_of (program "(defunion Overlay [i i32 f f64])\n")) dump
with
| [ ("Overlay", why) ] -> contains why "f64" && contains why "f32"
| _ -> false);
(* Two different layouts under one name, which is the same class of finding
a permuted struct is and has a one-keyword fix. *)
check "a defstruct against a union in the header is reported"
(match
Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Overlay [i i32 f f32])\n"))
dump
with
| [ ("Overlay", why) ] -> contains why "union in the header"
| _ -> false);
check "a defunion against a struct in the header is reported"
(match
Cimport.check_unions ~env
~unions:(unions_of (program "(defunion Pair [x f32 y f32])\n")) dump
with
| [ ("Pair", why) ] -> contains why "struct in the header"
| _ -> false);
check "a union the header does not describe is left alone"
(Cimport.check_unions ~env
~unions:(unions_of (program "(defunion Nowhere [q i32])\n")) dump
= []);
(* And the gap that remains, said out loud so it is a decision rather than
an oversight: an anonymous union member has no name and no Flan
spelling, so the record holding one is still not recorded and the
defstruct beside it is still unchecked rather than checked wrongly. *)
check "a record with an anonymous union member is still skipped"
(Cimport.check_structs ~env
~structs:(structs_of (program "(defstruct Anon [kind i32 junk i32])\n"))
dump
= []);
(* ── The constants (Cimport.check_constants) ───────────────────── *)
(* The half of generate-c's claim that used to be missing. A wrong flag bit
and a wrong enum member are the two errors here that are completely
silent — no link error, no type error — which is exactly the class the
header read exists to catch.
Shading is anonymous in sample.h and its typedef carries the name, which
is how raylib writes every one of its enums; SHADE_DARK has no
initialiser, so 6 is counted rather than read. *)
let const_fixture ?(mood = "[calm 0 cross 1]")
?(shading = "[light 4 mid 5 dark 6 half-dark 9]") ?(fancy = "4")
?(extra = "") () =
Printf.sprintf
"(defenum Mood %s)\n\
(defenum Shading %s)\n\
(defconst opt-loud u32 1)\n\
(defconst opt-fast u32 2)\n\
(defconst opt-fancy-mode u32 %s)\n\
(defconst lucky u32 7)\n\
%s"
mood shading fancy extra
in
let enums_of ds =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defenum (n, ms) -> Some (n, ms) | _ -> None)
ds
and pconsts_of ds =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.Defconst (n, _, e) -> Some (n, e) | _ -> None)
ds
in
let mapping =
{ Cimport.no_config with
Cimport.enum_prefixes = [ ("Mood", "MOOD_"); ("Shading", "SHADE_") ];
const_prefixes = [ ("opt-", "OPT_") ];
(* SHADE_HALFDARK is one word where its siblings are underscored, so the
prefix rule cannot reach it. The narrow exception, said once. *)
constants = [ ("Shading/half-dark", "SHADE_HALFDARK") ] }
in
let raw_constants ?(config = mapping) src =
Cimport.check_constants ~config ~enums:(enums_of (program src))
~consts:(pconsts_of (program src)) dump
in
let constants ?(config = mapping) src =
List.map
(fun (x : Cimport.const_diff) -> (x.Cimport.cname, x.Cimport.cwhy))
(raw_constants ~config src)
in
check "constants that agree with the header are not reported"
(constants (const_fixture ()) = []);
(* The value is compared, which is the whole point: 340 is KEY_LEFT_SHIFT
and 341 is a key that never fires. *)
check "a wrong enum member value is reported, by its C name"
(match constants (const_fixture ~mood:"[calm 0 cross 2]" ()) with
| [ ("Mood/cross", why) ] ->
contains why "MOOD_CROSS" && contains why "is 2 here"
| _ -> false);
(* An enumerator with no [= n] carries no value in clang's dump at all, so
it has to be counted the way C counts it. raylib's TraceLogLevel is eight
members with one initialiser between them. *)
check "an implicitly-numbered enumerator is counted, not skipped"
(match
constants
(const_fixture ~shading:"[light 4 mid 5 dark 7 half-dark 9]" ())
with
| [ ("Shading/dark", why) ] ->
contains why "SHADE_DARK" && contains why "is 6 in the header"
| _ -> false);
(* A name the rule builds and the header does not have is reported and not
skipped. A mapping that quietly matched nothing would read as coverage
and provide none, which would be worse than no check. *)
check "a member the header has no constant for is reported"
(match constants (const_fixture ~mood:"[calm 0 cross 1 murky 2]" ()) with
| [ ("Mood/murky", why) ] -> contains why "no constant named MOOD_MURKY"
| _ -> false);
(* The defconst half. These are raylib's 16 ConfigFlags bits. *)
check "a wrong defconst value is reported"
(match constants (const_fixture ~fancy:"8" ()) with
| [ ("opt-fancy-mode", why) ] ->
contains why "OPT_FANCY_MODE" && contains why "is 4 in the header"
| _ -> false);
(* And a defconst no rule reaches is not reported: a package's constants are
mostly its own, and raylib's 26 colours have no enumerator behind them. *)
check "a defconst no rule reaches is left alone"
(constants (const_fixture ~extra:"(defconst unmapped u32 99)\n" ()) = []);
(* The [constant] line is what reaches a name the prefix rule gets wrong. *)
check "without the constant line the odd name is reported"
(match
constants ~config:{ mapping with Cimport.constants = [] }
(const_fixture ())
with
| [ ("Shading/half-dark", why) ] ->
contains why "no constant named SHADE_HALF_DARK"
| _ -> false);
(* The Flan-side member prefix, declared as the enum line's fourth column.
raylib's Key spells its members key-r, key-space — a bare member name
collides across enums — and the C name is built by stripping that prefix
first, so key-r is KEY_R and not KEY_KEY_R. *)
let prefixed =
{ mapping with Cimport.enum_flan_prefixes = [ ("Mood", "mood-") ] }
in
check "a declared Flan member prefix is stripped before the C name is built"
(constants ~config:prefixed
(const_fixture ~mood:"[mood-calm 0 mood-cross 1]" ())
= []);
check "a wrong value is still caught through the stripped prefix"
(match
constants ~config:prefixed
(const_fixture ~mood:"[mood-calm 0 mood-cross 2]" ())
with
| [ ("Mood/mood-cross", why) ] ->
contains why "MOOD_CROSS" && contains why "is 2 here"
| _ -> false);
(* A member that does not carry the declared prefix is a finding, not a
member checked under a guessed name: `calm` beside a declared `mood-`
would otherwise build MOOD_CALM, which the header has, and the naming
rule the line declares would erode silently. *)
check "a member without the declared Flan prefix is a mapping finding"
(match raw_constants ~config:prefixed (const_fixture ()) with
| [ a; b ] ->
a.Cimport.cmapping && b.Cimport.cmapping
&& contains a.Cimport.cwhy "carry the prefix mood-"
&& contains b.Cimport.cwhy "carry the prefix mood-"
| _ -> false);
(* Coverage itself must not go quiet. A defenum nobody mapped would be
silently unchecked, which is the same hole one level up. *)
check "a defenum with no enum line is itself a finding"
(match constants (const_fixture ~extra:"(defenum Nobody [a 0])\n" ()) with
| [ ("Nobody", why) ] -> contains why "no `enum` line"
| _ -> false);
(* And the way to say so deliberately, for an enum the header cannot check. *)
check "enum - excuses an enum the header says nothing about"
(constants
~config:
{ mapping with
Cimport.enum_prefixes = ("Nobody", "-") :: mapping.Cimport.enum_prefixes }
(const_fixture ~extra:"(defenum Nobody [a 0])\n" ())
= []);
(* A rule that reaches nothing is a typo, and it would otherwise read as
coverage. *)
check "an enum rule naming no defenum is reported"
(match
constants
~config:
{ mapping with
Cimport.enum_prefixes =
("Ghost", "G_") :: mapping.Cimport.enum_prefixes }
(const_fixture ())
with
| [ ("Ghost", why) ] -> contains why "names no defenum"
| _ -> false);
check "a const rule matching no defconst is reported"
(match
constants
~config:
{ Cimport.no_config with Cimport.const_prefixes = [ ("zzz-", "ZZZ_") ] }
"(defconst lucky u32 7)\n"
with
| [ ("zzz-", why) ] -> contains why "matches no defconst"
| _ -> false);
check "a constant line naming nothing is reported"
(match
constants
~config:
{ Cimport.no_config with
Cimport.constants = [ ("Mood/nope", "MOOD_NOPE") ] }
"(defconst lucky u32 7)\n"
with
| [ ("Mood/nope", why) ] -> contains why "names no defconst"
| _ -> false);
(* The two kinds of finding are told apart, because they have different
dispositions: a value that disagrees with the library stops an ordinary
build, and an enum nobody wrote a line for is about the package's own
config and gates `generate-c` instead. *)
check "a value disagreement is not a mapping finding"
(match raw_constants (const_fixture ~fancy:"8" ()) with
| [ x ] -> not x.Cimport.cmapping
| _ -> false);
check "an unmapped defenum is a mapping finding"
(match raw_constants (const_fixture ~extra:"(defenum Nobody [a 0])\n" ()) with
| [ x ] -> x.Cimport.cmapping
| _ -> false);
(* The name rule, which is not an inverse of kebab and does not need to be:
a constant has no declaration to store its C spelling in. *)
List.iter
(fun (flan, c) ->
check
(Printf.sprintf "screaming %s -> %s" flan c)
(String.equal (Cimport.screaming flan) c))
[ ("left-shift", "LEFT_SHIFT"); ("msaa-4x-hint", "MSAA_4X_HINT");
("a", "A"); ("window-mouse-passthrough", "WINDOW_MOUSE_PASSTHROUGH") ];
(* diff_bound: a hand-written declare-c against the header's own signature.
This is the check with no other source — a wrong declare-c is wrong in the
generated prototype too, so the two halves agree with each other and only
the library knows better. *)
let bound_of src =
List.filter_map
(fun (d : Ast.decl) ->
match d.Ast.d with Ast.DeclareC (fn, sym) -> Some (fn, sym) | _ -> None)
(program src)
in
let differs name src needle =
check ("declare-c against the header: " ^ name)
(match Cimport.diff_bound ~env ~bound:(bound_of src) dump with
| [ d ] -> contains d.Cimport.dwhy needle
| _ -> false)
in
check "a declare-c that matches the header is not reported"
(Cimport.diff_bound ~env
~bound:(bound_of "(declare-c add [a i32 b i32] i32 \"add_ints\")") dump
= []);
differs "a wrong parameter width"
"(declare-c add [a f64 b i32] i32 \"add_ints\")" "parameter a is f64";
differs "a wrong arity" "(declare-c add [a i32] i32 \"add_ints\")"
"the header says 2";
differs "a wrong return type"
"(declare-c add [a i32 b i32] f32 \"add_ints\")" "returns f32";
(* A symbol the header does not have at all is the version-drift case, and
it is how a package pinned to the wrong release announces itself. *)
differs "a symbol the header does not declare"
"(declare-c gone [] \"no_such_function\")" "does not declare";
(* An enum face against a plain int is the expected difference and not a
finding: that is what a defenum is at the boundary. *)
check "an enum face against the header's int is not a difference"
(Cimport.diff_bound ~env
~bound:(bound_of "(declare-c mv [m Mood] i32 \"mood_value\")") dump
= []);
(* The pointer arm. The importer renders a C pointer into whichever Flan type
it thinks is the nicest face — [const char *] becomes [string], [void *]
becomes [(Ptr u8)] — and a hand-written line that wants the raw address
instead is disagreeing with that choice rather than with the header. These
say which of those disagreements are real. *)
let agreed name src =
check ("declare-c against the header: " ^ name)
(Cimport.diff_bound ~env ~bound:(bound_of src) dump = [])
in
(* The case docs/PORTING.md §A.1 could not write: GetCodepointPrevious reads
backwards from its pointer, so a Flan string — which crosses as a
NUL-terminated copy — is the one thing it must not be handed. *)
agreed "a (Ptr u8) where the header says const char *"
"(declare-c name-length [text (Ptr u8)] i32 \"name_length\")";
(* And the string face goes on being right, because this is an addition. *)
agreed "a string where the header says const char *"
"(declare-c name-length [text str] i32 \"name_length\")";
agreed "a pointer that matches the header exactly"
"(declare-c count-at [values (Ptr i32) n i32] i32 \"count_at\")";
agreed "a const pointer that matches the header exactly"
"(declare-c count-at [values (Ptr const i32) n i32] i32 \"count_at\")";
agreed "a const pointer where the header says const void *"
"(declare-c blit [dst (Ptr Pair) src (Ptr const Shade) n i32] \"blit\")";
(* void * is opaque about what it points at, so there is no element type in
the header to disagree with — §A.2's LoadImageColors → UpdateTexture. *)
agreed "any pointer where the header says void *"
"(declare-c blit [dst (Ptr Pair) src (Ptr Shade) n i32] \"blit\")";
agreed "any pointer where the header returns void *"
"(declare-c scratch [n i32] (Ptr Pair) \"scratch\")";
(* An enum through a pointer is the same four bytes an enum is beside one. *)
agreed "a (Ptr enum) where the header says a pointer to int"
"(declare-c count-at [values (Ptr Mood) n i32] i32 \"count_at\")";
(* And the refusals, which are the whole value of the arm: a binding that
lies about the header still has to be caught, and the message still has to
name the disagreement. *)
differs "a pointer to the wrong named type"
"(declare-c pair-len-p [p (Ptr Shade)] f32 \"pair_len_p\")"
"parameter p is (Ptr Shade) and the header says (Ptr const Pair)";
differs "a pointer to the wrong width"
"(declare-c count-at [values (Ptr f64) n i32] i32 \"count_at\")"
"parameter values is (Ptr f64)";
(* void * gives up the element type and nothing else. It is still a pointer,
and a scalar declared against one is still a finding. *)
(* A (Ptr const T) promises C will not write, and the header has to say so
too. *)
differs "a const pointer where the header may write"
"(declare-c blit [dst (Ptr const u8) src (Ptr u8) n i32] \"blit\")"
"parameter dst is (Ptr const u8)";
differs "a scalar where the header says void *"
"(declare-c blit [dst i64 src (Ptr u8) n i32] \"blit\")"
"parameter dst is i64";
differs "a scalar where the header says a pointer"
"(declare-c count-at [values i32 n i32] i32 \"count_at\")"
"parameter values is i32";
(* The byte tolerance is the pointee's and not the world's: inside a pointer
i8 and u8 are two spellings of one byte, and as a scalar they are not. *)
differs "a byte where the header says a wider integer"
"(declare-c add [a u8 b i32] i32 \"add_ints\")" "parameter a is u8";
(* A returned string is copied, so it has to be text the caller only reads.
Over a char * without const the copy would leave the library's buffer
with no owner; over a const char * it is the importer's own face. *)
agreed "a string returned where the header says const char *"
"(declare-c name-of [which i32] str \"name_of\")";
differs "a string returned where the header says char *"
"(declare-c owned-text [] str \"owned_text\")"
"which the caller owns";
agreed "a (Ptr u8) returned where the header says char *"
"(declare-c owned-text [] (Ptr u8) \"owned_text\")";
(* The name rule. Reversibility is by storage — the C symbol is kept verbatim
in the declaration — so what the rule has to be is injective over one
header, which the collision case above asserts. These pin its shape. *)
List.iter
(fun (c, flan) ->
check
(Printf.sprintf "kebab %s -> %s" c flan)
(String.equal (Cimport.kebab c) flan))
[ ("InitWindow", "init-window");
(* An acronym stays one word rather than becoming separate letters. *)
("SetTargetFPS", "set-target-fps");
("ColorToHSV", "color-to-hsv");
("UnloadUTF8", "unload-utf8");
(* A digit run takes the uppercase after it, so 2D is one word. *)
("BeginMode2D", "begin-mode-2d");
("GetScreenToWorld2D", "get-screen-to-world-2d");
("snake_case_already", "snake-case-already") ];
(* cjson.ml, on the shapes clang's dump actually contains. *)
check "json: an escaped string"
(match Cjson.parse "{\"a\":\"x\\ny\"}" with
| Cjson.Obj [ ("a", Cjson.Str "x\ny") ] -> true
| _ -> false);
check "json: nesting, numbers, booleans and null"
(match Cjson.parse "{\"i\":[1,-2,3.5e2],\"b\":true,\"n\":null}" with
| Cjson.Obj
[ ("i", Cjson.Arr [ _; _; _ ]); ("b", Cjson.Bool true);
("n", Cjson.Null) ] -> true
| _ -> false);
check "json: empty containers"
(match Cjson.parse "{\"a\":{},\"b\":[]}" with
| Cjson.Obj [ ("a", Cjson.Obj []); ("b", Cjson.Arr []) ] -> true
| _ -> false);
check "json: trailing bytes are refused"
(match Cjson.parse "{} x" with
| _ -> false
| exception Cjson.Bad _ -> true);
(* ── Lifted function names, and why they are counted per kind ────────
A handler clause and an fn literal are both lifted into functions of their
own, and both are numbered within the function they came out of. One
shared counter would mean that adding a handler-bind above an existing fn
renamed the fn — a rename for a body that did not change, in exactly the
names a dev redefinition module emits and matches on. These check that
each sequence is stable against the other. *)
let lifted_names src =
List.filter_map
(fun (f : Tast.fn) ->
match f.Tast.fparent with Some _ -> Some f.Tast.name | None -> None)
(Check.program (Parse.program (read src))).Tast.fns
in
let with_handler =
"(defstruct Boom [n i32]) (defonce hit i32) \
(defn u [f (Fn [i32] i32)] i32 (f 1)) \
(defn m [] i32 \
(handler-bind [(Boom [c] (set hit (.n c)))] (u (fn [x] x))) 0)"
in
let without_handler =
"(defstruct Boom [n i32]) (defonce hit i32) \
(defn u [f (Fn [i32] i32)] i32 (f 1)) \
(defn m [] i32 (u (fn [x] x)) 0)"
in
check "an fn keeps its number when a handler-bind is added beside it"
(List.mem "fn/m/0" (lifted_names with_handler)
&& List.mem "fn/m/0" (lifted_names without_handler));
check "and the handler clause has a sequence of its own"
(List.exists
(fun n -> contains n "handler/m/0/Boom") (lifted_names with_handler));
(* ── The prelude's own macro calls, and the bootstrap that allows them ──
A macro module is compiled *from* the prelude, so a prelude function that
calls a prelude macro cannot be in the module that would expand it. The
answer is [Macro.reduce]: for that one build the prelude loses every defn
depending on a macro, directly or transitively. These check the reduction
itself, since the thing it prevents is a cycle and a cycle does not show
up as a wrong answer — it shows up as a build that cannot start. *)
let names_of forms =
List.filter_map
(fun (f : Form.t) ->
match f.Form.v with
| Form.List ({ Form.v = Form.Sym ("defn" | "defmacro"); _ }
:: { Form.v = Form.Sym n; _ } :: _) -> Some n
| _ -> None)
forms
in
let reduced = names_of (Macro.reduce (Prelude.forms ())) in
let full = names_of (Prelude.forms ()) in
check "the reduced prelude drops a defn that calls a macro"
(List.mem "format-f64" full && not (List.mem "format-f64" reduced));
(* The macros survive — they are what the module is being built to export —
and so does everything that does not reach one, which is almost all of it. *)
check "the reduced prelude keeps the macros themselves"
(List.mem "clamp" reduced && List.mem "unless" reduced);
check "the reduced prelude keeps a defn that calls no macro"
(List.mem "join" reduced && List.mem "split" reduced);
(* Transitively: a caller of a dropped function is as unbuildable as the
function, so it goes too. Written against a synthetic prelude rather than
the real one, which has no such chain today. *)
let synth src = Reader.read_all ~file:"<synth>" src in
let chain =
synth
"(defmacro m [& args] `(do))\n\
(defn a [] () (m))\n\
(defn b [] () (a))\n\
(defn c [] () (do))\n"
in
check "the reduction is transitive"
(names_of (Macro.reduce chain) = [ "m"; "c" ]);
(* And the one rule that stays: a prelude macro may not call a macro. It used
to fail as an unknown name inside a clang build; it names itself now. *)
let ring = synth "(defmacro m [& args] `(do))\n(defmacro n [& args] (m args))\n" in
check "a prelude macro calling a macro is refused by name"
(match Macro.reduce ring with
| _ -> false
| exception Loc.Error { Loc.dmsg = m; _ } ->
contains m "the prelude macro n calls a macro");
(* ── Diagnostics: kind, notes, and more than one ───────────────
The house rule is that a test asserts the *reason* a thing is refused. A
kind is that assertion made stable: the message may be reworded and the
row still holds, and a row that matches on a kind is saying something a
substring match on prose could only approximate. The messages themselves
are unchanged, so every existing needle still means what it meant. *)
let diag_of src =
match checked src with
| _ -> None
| exception Loc.Error d -> Some d
in
let kind_is name src k =
check name (match diag_of src with Some d -> d.Loc.kind = k | None -> false)
in
kind_is "unknown name has a kind"
"(defn f [] i32 nope)" "check/unknown-name";
kind_is "unknown field has a kind"
"(defstruct S [a i32])\n(defn f [s S] i32 (.b s))" "check/unknown-field";
kind_is "a name defined twice has a kind"
"(defn f [] i32 1)\n(defn f [] i32 2)" "check/defined-twice";
(* The note is the half a location and a string could never carry: the
*other* place, with its own span and its own explanation. *)
(match diag_of "(defn f [] i32 1)\n(defn f [] i32 2)" with
| Some d ->
check "defined twice points at the second" (d.Loc.dloc.Loc.line = 2);
(match d.Loc.notes with
| [ n ] ->
check "and notes the first" (n.Loc.nloc.Loc.line = 1);
check "and says what it is" (contains n.Loc.nmsg "already defined")
| ns -> check "defined twice has one note" (ns = []))
| None -> check "defined twice is refused" false);
(match diag_of "(defstruct S [a i32])\n(defn f [s S] i32 (.b s))" with
| Some d ->
(match d.Loc.notes with
| [ n ] ->
check "an unknown field notes the declaration"
(n.Loc.nloc.Loc.line = 1);
check "and lists the fields there" (contains n.Loc.nmsg "with a")
| _ -> check "an unknown field has one note" false)
| None -> check "an unknown field is refused" false);
(* The call argument, which is the most-hit refusal in the compiler and was
the one that said least: the caret was right and the sentence never named
which argument of which function, nor pointed at the parameter that
wanted the other type. Both halves are asserted here, plus the rule that
keeps the claim honest — a mismatch *inside* an argument is not this
argument's, and is left as it was. *)
(match diag_of "(defn add [a i32 b i32] i32 (+ a b))\n (defn f [] i32 (add 1 \"two\"))" with
| Some d ->
check "a bad call argument has a kind" (d.Loc.kind = "check/argument-type");
check "and says which argument of which function"
(contains d.Loc.dmsg "this is the 2nd argument of add");
(match d.Loc.notes with
| [ n ] ->
check "and notes the parameter's declaration" (n.Loc.nloc.Loc.line = 1);
check "and names the parameter"
(contains n.Loc.nmsg "add's 2nd parameter b is declared i32")
| _ -> check "a bad call argument has one note" false)
| None -> check "a bad call argument is refused" false);
(match diag_of "(defn add [a i32 b i32] i32 (+ a b))\n (defn f [] i32 (add 1 (add 2 \"x\")))" with
| Some d ->
let times needle hay =
let n = String.length needle in
List.length
(List.filter
(fun i -> String.length hay - i >= n && String.sub hay i n = needle)
(List.init (max 1 (String.length hay)) Fun.id))
in
(* Named once, by the call that owns it. The outer call sees a refusal
raised against a span that is not its argument's and passes it on
untouched, which is what stops "the 2nd argument of add" being said
twice about two different forms. *)
check "the inner call owns its own argument, and says so once"
(times "argument of add" d.Loc.dmsg = 1)
| None -> check "a nested bad argument is refused" false);
(* The condition, which used to state a type fact and stop. The rule has two
halves and the dyn half is not the typed half — a dyn condition is
Clojure's, where 0 is true — so the comparison is offered only where it
is right, and with the condition's own name where it has one. *)
rejects_check "a non-bool condition states the rule"
"(defn f [] i32 (let [x 1] (if x 1 0)))"
~needle:"a condition is a bool or a dyn, and this is i32 — test it, as (!= x 0)";
rejects_check "and offers no template for a form it cannot name"
"(defn f [] i32 (if (+ 1 2) 1 0))"
~needle:"this is i32 — test it against 0 with !=";
rejects_check "and offers no comparison at all for a type that has none"
"(defstruct P [x i32]) (defn f [] i32 (let [p (P {.x 1})] (if p 1 0)))"
~needle:"a condition is a bool or a dyn, and this is P";
(* A deep nest of not over a condition that is refused. Each level retries
the level below it for its message, and a refusal already settled is
answered from memory, so two hundred levels fail at once — re-walking
each subtree doubled the work per level. The message is the innermost
condition's, as it is at one level. *)
(let deep =
let rec nest k e = if k = 0 then e else nest (k - 1) ("(not " ^ e ^ ")") in
"(defn g [x i32] bool " ^ nest 200 "x" ^ ")"
in
let t0 = Unix.gettimeofday () in
match checked deep with
| _ -> check "a deep not nest over an i32 is refused" false
| exception Loc.Error { Loc.dmsg; _ } ->
check "a deep not nest over an i32 fails fast"
(Unix.gettimeofday () -. t0 < 3.0);
check "a deep not nest keeps the one-level message"
(dmsg = "a condition is a bool or a dyn, and this is i32 — test it, as \
(!= x 0)"));
(* A long or chain refused at its last operand, with nothing expected of it.
Each if tries its else arm on its own terms before checking it at bool,
and a refused if is answered from memory, so a thousand operands fail
at once rather than in the square of that. *)
(let deep =
"(defn g [x i32] bool (let [b (or "
^ String.concat " " (List.init 1000 (Printf.sprintf "(= x %d)"))
^ " 5)] b))"
in
(* Timed rather than under [Watchdog.within]: a catch-all inside the
checker can swallow the alarm's exception. *)
let t0 = Unix.gettimeofday () in
match checked deep with
| _ -> check "a refused or chain is refused" false
| exception Loc.Error { Loc.dmsg; _ } ->
check "a refused or chain fails fast" (Unix.gettimeofday () -. t0 < 3.0);
check "a refused or chain keeps the one-operand message"
(dmsg = "expected bool, found the integer literal 5"));
(* A literal still names itself: that message knows something the rule does
not, so the re-check's answer is kept wherever it is more specific. *)
rejects_check "a literal condition keeps its own message"
"(defn f [] i32 (if 1 1 2))"
~needle:"expected bool, found the integer literal 1";
(* Four words before this: the name and the fact. The declaration is where
the reader's next move is, so it comes along. *)
(match diag_of "(defconst k 1)\n(defn f [] () (set k 2))" with
| Some d ->
check "assigning a constant has a kind" (d.Loc.kind = "check/set-constant");
(match d.Loc.notes with
| [ n ] ->
check "and notes the defconst" (n.Loc.nloc.Loc.line = 1);
check "and says what it is"
(contains n.Loc.nmsg "k is declared a constant here")
| _ -> check "assigning a constant has one note" false)
| None -> check "assigning a constant is refused" false);
(* A type annotation in a let is the first thing anyone arriving from a
typed language writes, and let has no slot for one. The old refusal
landed on the form left over — "binding 5 has no value" — which reads as
if they had miscounted. Only checked on the path that was refusing
anyway, so a binding vector that parses is never examined for it. *)
(match (try ignore (program "(defn f [] i32 (let [x i32 5] x))"); None
with Loc.Error d -> Some d) with
| Some d ->
check "a let annotation has a kind" (d.Loc.kind = "parse/let-type-annotation");
check "and blames the annotation, not the leftover"
(contains d.Loc.dmsg "a let binding takes no type annotation, so i32 \
here is read as the value and 5 is left with no \
name")
| None -> check "a let annotation is refused" false);
(match (try ignore (program "(defn f [] i32 (let [x 1 y] x))"); None
with Loc.Error d -> Some d) with
| Some d ->
check "and an ordinary odd binding vector is unchanged"
(contains d.Loc.dmsg "binding y has no value")
| None -> check "an odd binding vector is refused" false);
(* The operand, not the whole form — the same "whole form vs operand" the
condition work already fixed once. Text gets the extra clause, because
(+ "a" "b") is a reach for concatenation. *)
(match diag_of "(defn f [] () (println (+ \"a\" \"b\")))" with
| Some d ->
check "a non-numeric operand is blamed at the operand"
(d.Loc.dloc.Loc.col = 27);
check "and text is told where concatenation lives"
(contains d.Loc.dmsg
"+ takes numbers, and this is str — there is no + on text. The \
prelude concatenates with concat and join")
| None -> check "a non-numeric operand is refused" false);
(* The return slot, not whatever inside it the type parser gave up on. For
(defn f [x i32] (+ x 1)) that was the 1, three forms deep, where the
mistake is that the whole form is in the slot. What the type parser said
keeps its own span as a note. *)
(match (try ignore (program "(defn f [x i32] (+ x 1))"); None
with Loc.Error d -> Some d) with
| Some d ->
check "a body in the return slot blames the slot" (d.Loc.dloc.Loc.col = 17);
check "and says what is there"
(contains d.Loc.dmsg
"the return type goes here, and this is (+ x 1) — every defn states \
one, and a function that returns nothing writes ()");
check "and keeps the type parser's reason as a note"
(match d.Loc.notes with
| [ n ] -> contains n.Loc.nmsg "expected a type, found 1"
| _ -> false)
| None -> check "a body in the return slot is refused" false);
(* A one-field case binds the payload itself, so the destructuring reach
that follows gets a type fact where it needs to be told the value is
already in hand. Only where the pattern is what bound it: an ordinary
local keeps the sentence it had. *)
rejects_check "a case payload says the field is already in hand"
"(defdata Shape [(Circle [r f64]) (Square [s f64])]) \
(defn f [s Shape] f64 (match s (Circle c) (.r c) (Square q) 0.0))"
~needle:"c is f64 — the pattern bound it to Shape.Circle's field r, so \
the value is already in hand and there is no field left to read";
rejects_check "and an ordinary local keeps the type fact"
"(defn f [] i32 (let [x 1] (.r x)))"
~needle:"i32 is not a struct, so it has no fields";
(* "Allow shadowing but warn": a defn whose name is a builtin's is legal,
it wins at the call sites of the file that wrote it, and the compiler
says so once at the definition.
This used to be the other way round — the dispatch reached every builtin
arm before it looked in the function table, so the defn was silently
unreachable and the arity refusal carried a note saying so. That note
described a resolution order this compiler no longer has, and the source
below, which used to be refused, is the one that proves it: (get p) is
one argument, and the builtin get takes two. *)
let shadow_src =
"(defstruct P [x i32])\n(defn get [p P] i32 (.x p))\n\
(defn f [] i32 (let [p (P {.x 1})] (get p)))"
in
(match Check.shadowed_builtins (program shadow_src) with
| [ d ] ->
check "a defn named after a builtin is warned about, at the definition"
(d.Loc.kind = "check/shadows-builtin"
&& d.Loc.dloc.Loc.line = 2 && d.Loc.dloc.Loc.col = 7);
check "and the warning says what the name now means"
(d.Loc.dmsg
= "get shadows the builtin get — every call in this program now \
reaches your definition — the builtin stays reachable as \
builtin/get");
check "and it carries no notes, being one sentence about one decision"
(d.Loc.notes = [])
| _ -> check "a shadowing defn is warned about exactly once" false);
check "and the call reaches the defn, at the defn's arity"
(match checked shadow_src with
| _ -> true
| exception Loc.Error _ -> false);
(* A parameter vector paired by a lowercase type the program declares reads
as two dyn parameters the day the type goes, so the pairing is warned at,
naming the type and where it is declared. A capitalised type cannot be a
parameter name, so it has nothing to warn about. *)
(match
checked "(defstruct point [x i32])\n(defstruct Vec2 [x i32])\n\
(defn px [p point] i32 (.x p))\n(defn vx [v Vec2] i32 (.x v))"
with
| _ ->
(match !Check.pairing_warnings with
| [ d ] ->
check "a lowercase declared type in a parameter vector is warned at"
(d.Loc.kind = "check/parameter-reads-a-type"
&& d.Loc.dloc.Loc.line = 3 && d.Loc.dloc.Loc.col = 13
&& d.Loc.dmsg
= "[p point] is one parameter p of type point, the struct \
declared at <test>:1:1, and not two dyn parameters. If two \
were meant, give the second a name no type has")
| ds ->
check
(Printf.sprintf "one pairing warning, not %d" (List.length ds))
false)
| exception Loc.Error _ -> check "the paired program checks" false);
(* A Vec or Map parameter is the caller's header copied, so growing it is
warned at the parameter, once, naming the (Ptr ...) that reaches the
caller's own. A pointer parameter and a local are not warned at. The
running side is programs/grow-param.flan. *)
let grown src =
match checked src with
| _ -> Some !Check.grow_warnings
| exception Loc.Error _ -> None
in
(match
grown "(defn f [v (Vec i32) m (Map i32 i32)] ()\n\
\ (push v 1) (reserve v 8) (put m 1 2))"
with
| Some [ dm; dv ] ->
check "a grown Vec parameter is warned at the parameter"
(dv.Loc.kind = "check/grown-parameter"
&& dv.Loc.dloc.Loc.line = 1 && dv.Loc.dloc.Loc.col = 10
&& dv.Loc.dmsg
= "v is a (Vec i32) passed by value, a copy of the caller's header, \
so the push at <test>:2:3 grows this function's copy and the \
caller's container never sees it. Take it as (Ptr (Vec i32)) \
and write (push (deref v) ...), and each caller passes (addr c) \
for its container c");
check "and a grown Map parameter names put"
(dm.Loc.dloc.Loc.col = 22
&& Test_support.contains dm.Loc.dmsg "the put at <test>:2:28")
| Some ds ->
check (Printf.sprintf "two grow warnings, not %d" (List.length ds)) false
| None -> check "the grown-parameter program checks" false);
(* A struct parameter is a copy with its Vec fields in it, through any
depth of fields taken by value; through a pointer, not. *)
(match
grown "(defstruct Bag [items (Vec i32)])\n(defstruct Box [bag Bag])\n\
(defn f [x Box] () (push (.items (.bag x)) 1))\n\
(defn g [x (Ptr Box)] () (push (.items (.bag x)) 1))"
with
| Some [ d ] ->
check "a grown field of a struct parameter is warned at the parameter"
(d.Loc.dloc.Loc.line = 3 && d.Loc.dloc.Loc.col = 10
&& d.Loc.dmsg
= "x is a Box passed by value, a copy of the caller's, so the push \
at <test>:3:20 grows (.items (.bag x)) in this function's copy \
and the caller's never sees it. Take it as (Ptr Box), where \
(.items (.bag x)) reaches the caller's own, and each caller \
passes (addr c) for its Box c")
| Some ds ->
check (Printf.sprintf "one field grow warning, not %d" (List.length ds)) false
| None -> check "the grown-field program checks" false);
(* Not when the grown copy goes back to the caller — the parameter, or the
struct holding the field, is what the function answers — nor when the
field is given a container of the function's own before it grows. *)
check "a grown parameter the function returns is not warned at"
(grown "(defstruct Bag [items (Vec i32)])\n\
(defn add [v (Vec i32) x i32] (Vec i32) (push v x) v)\n\
(defn early [v (Vec i32) c bool] (Vec i32) (push v 1) \
(when c (return v)) v)\n\
(defn bag [b Bag] Bag (push (.items b) 1) b)\n\
(defn items [b Bag] (Vec i32) (push (.items b) 1) (.items b))"
= Some []);
check "a field reassigned before it grows is not warned at"
(grown "(defstruct Bag [items (Vec i32)])\n\
(defn f [b Bag] ()\n\
\ (set (.items b) (vec-new i32)) (push (.items b) 1) (free (.items b)))"
= Some []);
check "a pointer parameter and a local are not warned at"
(grown "(defn f [v (Ptr (Vec i32))] ()\n\
\ (push (deref v) 1) (let [w (vec-new i32)] (push w 1) (free w)))"
= Some []);
check "a program that shadows nothing is warned at not at all"
(Check.shadowed_builtins (program "(defn f [] i32 1)") = []);
(* A prelude function's name is taken over the same way, for the calls in
the defining file. *)
let prelude_src = "(defn abs-f32 [v f32] f32 v)" in
(match
snd (Check.shadow_prelude (Parse.program (Prelude.forms ()))
(program prelude_src))
with
| [ d ] ->
check "a defn of a prelude function's name warns once"
(d.Loc.kind = "check/shadows-prelude"
&& d.Loc.dmsg
= "abs-f32 shadows the prelude's abs-f32 — every call in this file \
now reaches your definition")
| _ -> check "a defn of a prelude function's name warns exactly once" false);
accepts "a defn of a prelude function's name is not defined twice"
prelude_src;
(* A global takes the name over the same way, with the same warning. *)
(match
snd (Check.shadow_prelude (Parse.program (Prelude.forms ()))
(program "(defonce swap i32 3)"))
with
| [ d ] ->
check "a global of a prelude function's name warns once"
(d.Loc.kind = "check/shadows-prelude"
&& d.Loc.dmsg
= "swap shadows the prelude's swap — every use in this file now \
reaches your definition")
| _ -> check "a global of a prelude function's name warns exactly once" false);
accepts "a global of a prelude function's name is not defined twice"
"(defonce swap i32 3)\n(defn f [] i32 swap)";
rejects_check "a struct of a prelude type's name is still defined twice"
"(defstruct Form [x i32])" ~needle:"Form is defined twice";
(* An operator is a builtin like any other and shadows like any other.
Pinned in both halves because it is the case most likely to be thought
of as special and quietly excepted later: the warning is the same
sentence, and the call is a [Call] to the definition rather than the
[Add] prim it would otherwise have lowered to. *)
let plus_src = "(defn + [a i32 b i32] i32 99)\n(defn f [] i32 (+ 1 2))" in
(match Check.shadowed_builtins (program plus_src) with
| [ d ] ->
check "an operator shadowed by a defn warns like any other builtin"
(d.Loc.kind = "check/shadows-builtin"
&& d.Loc.dmsg
= "+ shadows the builtin + — every call in this program now \
reaches your definition — the builtin stays reachable as \
builtin/+")
| _ -> check "a shadowed operator warns exactly once" false);
(match checked plus_src with
| p ->
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "f") p.Tast.fns with
| Some { Tast.body = [ { Tast.e = Tast.Call ("+", _); _ } ]; _ } -> ()
| _ -> check "a shadowed operator's call reaches the defn" false)
| exception _ -> check "a shadowed operator's call reaches the defn" false);
(* And the file the definition was written in is what the shadow follows.
Same declaration list, a call whose location is another file: the
builtin, whose arity this call does not satisfy. This is the package
global-initialiser case at its smallest — an initialiser is checked with
no enclosing function, so the enclosing name cannot be what decides.
The shadowing defn takes *two* parameters and the builtin takes one, so
the two readings cannot produce the same sentence: reaching the builtin
is a refusal measured at one, and reaching the defn is no refusal at
all. With both at one argument this check passed under either
resolution, which is a check that cannot fail — found in review. *)
(match
Check.program
(program "(defn length [a str b str] i32 999)"
@ Parse.program
(read ~file:"<elsewhere>" "(defn g [] i32 (length \"a\" \"b\"))"))
with
| _ -> check "a call in another file does not reach the shadow" false
| exception Loc.Error d ->
check "a call in another file reaches the builtin, at the builtin's arity"
(contains d.Loc.dmsg "length takes 1 argument, given 2"));
(* ── builtin/, the reserved qualifier ──────────────────────────────
The escape from the dead end above: [builtin/length] is the builtin
[length]
whatever the file has decided [length] means. Pinned from both ends —
with a shadow in the way and with nothing in the way at all — because a
spelling that only worked while some other declaration existed would be
one nobody could write down in advance. *)
accepts "builtin/ is legal with nothing shadowed"
"(defn f [] i32 (builtin/length \"abcd\"))";
(* The pair that says the two spellings part company. One declaration list,
two calls: the shadow takes two arguments and the builtin takes one, so
each call is refusable only under one of the two readings. The bare name
at two arguments checks, and the qualified one at two arguments is
measured against the builtin's arity. *)
accepts "the bare name reaches the shadowing defn"
"(defn length [a str b str] i32 999)\n\
(defn f [] i32 (length \"a\" \"b\"))";
rejects_check "and builtin/ beside it reaches the builtin"
"(defn length [a str b str] i32 999)\n\
(defn f [] i32 (builtin/length \"a\" \"b\"))"
~needle:"length takes 1 argument, given 2";
(* The program the earlier lane could not write: a shadowing defn that
*wraps* what it shadows. Without the qualifier the inner call reached
the definition being written and the program stack-overflowed at run
time; what is pinned here is that the body holds no call to [length] at
all, which is the difference between a wrapper and a loop. *)
(match
checked "(defn length [s str] i32 (builtin/+ 1 (builtin/length s)))"
with
| p ->
let recurs = ref false in
(match
List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "length") p.Tast.fns
with
| Some f ->
List.iter
(Tast.walk (fun (e : Tast.expr) ->
match e.Tast.e with
| Tast.Call ("length", _) -> recurs := true
| _ -> ()))
f.Tast.body;
check "a shadowing defn wraps the builtin instead of recurring"
(not !recurs)
| None -> check "the wrapping defn is checked" false)
| exception Loc.Error d ->
check "a shadowing defn wraps the builtin instead of recurring" false;
print_endline d.Loc.dmsg);
(* An operator through the qualifier, which is the case a reader would
expect to need an exception and does not: the reader takes [builtin/+]
as one symbol, and the call lowers to the [Add] prim even with [+]
shadowed two lines above. *)
(match checked "(defn + [a i32 b i32] i32 99)\n\
(defn f [] i32 (builtin/+ 1 2))" with
| p ->
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "f") p.Tast.fns with
| Some { Tast.body = [ { Tast.e = Tast.Prim (Tast.Add, _); _ } ]; _ } -> ()
| _ -> check "builtin/+ is the operator and not the shadowing defn" false)
| exception _ ->
check "builtin/+ is the operator and not the shadowing defn" false);
(* The value arms reach the same way, and [builtin/context/allocator] falls
out of one strip rather than needing a rule of its own. *)
accepts "a builtin written as a name is qualified too"
"(defn f [] dyn builtin/nil)";
accepts "and so is a builtin whose own name carries a slash"
"(defn f [] Allocator builtin/context/allocator)";
(* A builtin in a value position has nothing to hand back — it is an arm in
the compiler and has no address — and the refusal has to say so rather
than falling through to the function table, which holds the very
definition the qualifier was written to get away from. *)
rejects_check "a call-only builtin is refused as a value, not resolved"
"(defn length [s str] i32 1)\n(defn f [] () (println builtin/length))"
~needle:
"builtin/length is the builtin length, which is a call and not a value";
(* The qualifier reaching nothing. Named as not a builtin, and the
did-you-mean is over the builtins alone. *)
(match diag_of "(defn f [] i32 (builtin/nosuch))" with
| Some d ->
check "builtin/ with no builtin behind it has its own kind"
(d.Loc.kind = "check/unknown-builtin");
check "and says what is wrong with it"
(d.Loc.dmsg
= "nosuch is not a builtin, so builtin/nosuch reaches nothing. The \
builtin/ qualifier reaches the compiler's own names and nothing \
else; an ordinary function is called by the name it was defined \
under")
| None -> check "builtin/nosuch is refused" false);
(match diag_of "(defn f [] i32 (builtin/lenght \"ab\"))" with
| Some d ->
check "and a near miss is offered in the qualified spelling"
(d.Loc.dmsg
= "lenght is not a builtin, so builtin/lenght reaches nothing — did you \
mean builtin/length?")
| None -> check "builtin/lenght is refused" false);
(* And the did-you-mean everywhere else is untouched: a bare typo is still
answered with a bare name, not with a qualifier nobody reached for. *)
rejects_check "an unqualified typo is not answered with builtin/"
"(defn f [] i32 (lenght \"ab\"))" ~needle:"did you mean length?";
(* The reservation from the other side. [(defn builtin/length ...)] reads —
'/' is an ordinary symbol character — and would land in the function
table under a name nothing can ever call, because the prefix is stripped
before any table is consulted. *)
(match diag_of "(defn builtin/length [s str] i32 1)" with
| Some d ->
check "a declaration cannot take the reserved qualifier"
(contains d.Loc.dmsg
"builtin/length cannot be declared: builtin/ is a reserved qualifier")
| None -> check "a declaration under builtin/ is refused" false);
(* and's last operand is the then arm and the sentinel carrying the previous
operand's location is the else arm, so with no expectation in hand the
mismatch was reported one operand early. The accepted fix in TODO.org,
"and's last operand gets a misdirected caret": blame the arm that is not
a compiler temp. *)
(match diag_of "(defn f [] () (println (and true true (vec-new i32))))" with
| Some d ->
check "and blames its last operand, not the one before it"
(d.Loc.kind = "check/shortcircuit-operand" && d.Loc.dloc.Loc.col = 39);
check "and states what the two answers are"
(contains d.Loc.dmsg
"an and answers false or its last operand, so the two have to \
be one type — this operand is (Vec i32), and false is a bool")
| None -> check "a mistyped and operand is refused" false);
(* The reader's own two-place error. The bracket that is open is the error
and the end of input is the note, because the fix goes at the first and
the surprise is at the second. *)
(match read "(f\n bad" with
| _ -> check "unclosed is refused" false
| exception Loc.Error d ->
check "unclosed has a kind" (d.Loc.kind = "reader/unclosed");
check "unclosed notes where the input ran out"
(match d.Loc.notes with [ n ] -> n.Loc.nloc.Loc.line = 2 | _ -> false));
(match read "(f x]" with
| _ -> check "a mismatched closer is refused" false
| exception Loc.Error d ->
check "a mismatched closer has a kind"
(d.Loc.kind = "reader/mismatched-closer");
check "and notes the opener"
(match d.Loc.notes with [ n ] -> n.Loc.nloc.Loc.col = 1 | _ -> false));
(* The unterminated string had neither half of that shape: one column on the
opening quote and no note at all, where its two neighbours in this file
both have one. *)
(match read "(println \"oops\n" with
| _ -> check "an unterminated string is refused" false
| exception Loc.Error d ->
check "unterminated string has a kind"
(d.Loc.kind = "reader/unterminated-string");
check "and says what is missing"
(contains d.Loc.dmsg "unterminated string — no closing quote");
check "and notes where the input ran out"
(match d.Loc.notes with
| [ n ] -> contains n.Loc.nmsg "the input ends here, still inside it"
| _ -> false));
(* More than one per run, which is the point of the whole batch. Three bad
bodies, three diagnostics, and the count is exact: a checker that reported
the first and a checker that reported thirty pieces of wreckage would both
fail this row. *)
(match
Check.program_all
(Parse.program_all
(read "(defn a [] i32 nope1)\n\
(defn b [] i32 nope2)\n\
(defn c [] i32 nope3)\n"))
with
| _ -> check "three bad bodies are refused" false
| exception Loc.Errors ds ->
check "three bad bodies give three errors" (List.length ds = 3);
check "and they are in source order"
(List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2; 3 ]));
(* A generic whose abstract pass was refused is not checked again at each
copy: the refusal is one error, however many types call it, and the
caller's own later refusal is still found. *)
(match
Check.program_all
(Parse.program_all
(read "(defn g [x $t] u64 (nosuch x))\n\
(defn main [] i32 (g 3) (g true) nope 0)\n"))
with
| _ -> check "a refused generic body is refused" false
| exception Loc.Errors ds ->
check "a refused generic body is one error, and its caller's is another"
(List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2 ]));
(* A refusal inside a copy names the call that asked for it, and each copy
between: the chain walks back to the line the programmer wrote. *)
(match
checked
"(defn show [v $t] () (println v)) \
(defn outer [v $t] () (show v)) \
(defn main [] i32 (outer main) 0)"
with
| _ -> check "a copy with no printer is refused" false
| exception Loc.Error d ->
let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in
check "a refusal in a copy names both instantiations"
(contains d.Loc.dmsg "no printer for"
&& notes
= [ "show is instantiated at $t = (CFn [] i32) here";
"outer is instantiated at $t = (CFn [] i32) here" ]));
(* A refusal made while collecting declarations — a generic struct that
holds itself, one that grows without end, a where clause over a length —
is one error among the rest of the file's, not the end of the check. *)
let all_lines src =
match Check.program_all (Parse.program_all (read src)) with
| _ -> []
| exception Loc.Errors ds ->
List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds
in
check "a self-containing generic struct is one error of several"
(all_lines
"(defstruct Loop [next (Loop $t)])\n\
(defn g [] i32 (let [p (the (Loop i32) (zeroed))] nope1))\n\
(defn h [] i32 nope2)\n"
= [ 1; 2; 3 ]);
check "a generic struct that grows without end is one error of several"
(all_lines
"(defstruct Grow [next (Ptr (Grow [$t]))])\n\
(defn g [] i32 (let [p (the (Grow i32) (zeroed))] nope1))\n\
(defn h [] i32 nope2)\n"
= [ 1; 2; 3 ]);
check "a where clause over a length is one error of several"
(all_lines
"(defn f [a [$n i32]] i32 {:where (numeric? $n)} nope1)\n\
(defn h [] i32 nope2)\n"
= [ 1; 1; 2 ]);
(* A literal that does not fit what a typed field decided names that field. *)
(match
checked
"(defstruct Pair [a $t b $t]) \
(defn main [] i32 (let [p (Pair (the i32 1) 2.5)] 0))"
with
| _ -> check "a float literal where a typed field decided i32" false
| exception Loc.Error d ->
check "the refusal names the field that decided the variable"
(contains d.Loc.dmsg "Pair's .b is $t, which is i32 here"
&& List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg ".a is i32 here, which decides $t")
d.Loc.notes));
(* A copy that cannot be built at a closure's type: the zeroed value in the
body is refused there, and the call that asked is named. *)
(match
checked
"(defn blank [x $t] $t (let [z (the $t (zeroed))] z)) \
(defn use-it [f (Fn [i32] i32)] i32 (blank f) 0)"
with
| _ -> check "a zeroed closure in a copy is refused" false
| exception Loc.Error d ->
check "a copy at a closure type names the call that asked"
(List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg "blank is instantiated at $t = (Fn [i32] i32) here")
d.Loc.notes));
(* A prelude generic's body is nobody's source at the call: the refusal is
at the call, and the prelude's line is a note. *)
(match
checked
"(defn keep [g (Vec u8)] bool true) \
(defn use-it [xs [(Vec u8)]] i32 (length (filter xs keep)))"
with
| _ -> check "a prelude copy that cannot be built is refused" false
| exception Loc.Error d ->
check "a prelude copy's refusal is at the user's call"
(d.Loc.dloc.Loc.file <> Prelude.file
&& contains d.Loc.dmsg "filter cannot be made at $t = (Vec u8)"
&& not (contains d.Loc.dmsg "clone")
&& List.exists
(fun (n : Loc.note) -> n.Loc.nloc.Loc.file = Prelude.file)
d.Loc.notes));
(* The parser resynchronises on a top-level form, so two bad declarations are
two errors rather than one. *)
(match Parse.program_all (read "(defn a)\n(defn b)\n") with
| _ -> check "two bad declarations are refused" false
| exception Loc.Errors ds ->
check "two bad declarations give two errors" (List.length ds = 2));
(* [Check.program] is a different function from [Check.program_all], and
that is the guarantee: the session calls this one, it raises one
diagnostic, and nobody can turn it into a list by passing a label. *)
(match Check.program (Parse.program (read "(defn a [] i32 nope1)\n\
(defn b [] i32 nope2)\n")) with
| _ -> check "Check.program still refuses" false
| exception Loc.Errors _ ->
check "Check.program never answers with a list" false
| exception Loc.Error _ -> ());
(* The first line of a report is exactly the GNU format compilation-mode
parses, and the squiggle is on an indented line under it, which that mode
ignores. Both halves are load-bearing and neither is visible from the
message alone. *)
(match diag_of "(defn f [] i32 nope)" with
| Some d ->
let lines = String.split_on_char '\n' (Loc.report d) in
(match lines with
| head :: rest ->
check "the first line is file:line:col: message"
(head = Loc.to_string d.Loc.dloc ^ ": " ^ d.Loc.dmsg);
check "and the rest is indented"
(List.for_all (fun l -> l = "" || l.[0] = ' ') rest)
| [] -> check "a report has a first line" false)
| None -> check "a report needs a diagnostic" false);
(* ── Generics: the syntax, the predicates, and the two defaults ── *)
(* The one syntax question the feature had, and how it stopped being one.
[{K V}] used to be a legal *return type* spelling for (Map K V), so a
defn with a map return type and a constraint map put two braces in a row
meaning different things. The brace spelling is now withdrawn from type
position entirely, so the slot after the return type can be nothing but
the constraint map, and braces in a type say where the spelling went. *)
accepts "a map return type, written the one way there is"
"(defn f [] (Map str i32) (map-new str i32))";
accepts "a map return type followed by a constraint map"
"(defn f [x $t] (Map str i32) {:where (equal? $t)} \
(do x (map-new str i32)))";
rejects_check "braces in type position say where the spelling went"
~needle:"written (Map K V)"
"(defn f [] {str i32} (map-new str i32))";
(* The predicates, and each one gating the operator it is for. *)
accepts "ordered? admits <"
"(defn less [a $t b $t] bool {:where (ordered? $t)} (< a b))";
accepts "equal? admits ="
"(defn same [a $t b $t] bool {:where (equal? $t)} (= a b))";
accepts "numeric? admits +"
"(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))";
rejects_check "equal? does not admit <"
~needle:"nothing declares $t ordered?"
"(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))";
(* The entailments, which are the reason a signature is one predicate long
rather than two. Every type the language orders is a number or an enum,
so it is equatable. *)
accepts "ordered? entails equal?"
"(defn same [a $t b $t] bool {:where (ordered? $t)} (= a b))";
accepts "numeric? entails ordered?"
"(defn less [a $t b $t] bool {:where (numeric? $t)} (< a b))";
(* ── integer? — the bound numeric? was one type too wide for ─────────
It admits every integer kind, signed and unsigned, at every width, and
refuses floats and everything else. It exists so a function that can be
generalized does not need a variant per numeric type: an integer body
under numeric? was instantiated at f32 and f64 too, which is why abs
stayed per-width for a milestone. It entails numeric? — every integer
is a number — so the arithmetic, the written 0 and the untyped integer
literal all come with it; the reverse entailment would let floats into
bit-and and does not exist. *)
accepts "integer? admits +, via the entailment"
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 1))";
accepts "integer? admits <, via the entailment"
"(defn small? [x $t] bool {:where (integer? $t)} (< x 10))";
accepts "integer? admits bit-and"
"(defn low? [x $t] bool {:where (integer? $t)} (= (bit-and x 1) 1))";
accepts "integer? admits the shifts"
"(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))";
rejects_check "numeric? does not admit bit-and"
~needle:"nothing declares $t integer?"
"(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))";
rejects_check "nor the shifts"
~needle:"nothing declares $t integer?"
"(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))";
(* An integer?-bounded caller satisfies a numeric?-bounded callee: the
entailment carries across generic calls exactly as ordered?-over-equal?
does. *)
accepts "integer? carries a numeric? callee"
"(defn z? [x $t] bool {:where (numeric? $t)} (= x 0))\n\
(defn odd-z? [x $t] bool {:where (integer? $t)} (z? (bit-and x 1)))";
(* The integer literal is admitted at a bounded variable by the same arm
under both bounds — the bound promises the literal a meaning at every
type the variable can become, and integer?'s types are a subset of
numeric?'s. *)
accepts "an integer literal stands where an integer?-bounded $t is wanted"
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 300))";
(* A float at integer?, refused at the call that asked, naming the bound. *)
rejects_check "a float does not instantiate an integer?-bounded variable"
~needle:"f64 is not integer?"
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 1))\n\
(defn main [] () (println (bump 1.5)))";
(* And dyn is refused by the bound too — the clause's own refusal, the more
specific of the two answers, exactly as at numeric?. *)
rejects_check "dyn does not instantiate an integer?-bounded variable"
~needle:"dyn is not integer?"
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 1))\n\
(defonce d dyn 5)\n\
(defn main [] () (println (bump d)))";
(* A float literal inside an integer?-bounded body is refused at the
definition, in the bound's own words: there is no instantiation at which
it means anything. *)
rejects_check "a float literal has no meaning under integer?"
~needle:"admits no float type"
"(defn h [x $t] $t {:where (integer? $t)} (+ x 1.5))";
(* ── Conversions under a bound ───────────────────────────────────────
A cast asks whether its operand is a number, and a type variable has no
type to answer with — so the bound answers, and the rule is the concrete
arm's rule read off the set a predicate admits: a conversion legal at
every type the bound admits is legal at the variable, and one illegal at
any of them is refused there. Each pair below is the same conversion
written twice, once generic and once concrete, and the two agree. *)
accepts "integer? admits (i32 x), the narrowing conversion"
"(defn to32 [x $t] i32 {:where (integer? $t)} (i32 x))";
accepts "and the concrete conversion it stands for"
"(defn to32 [x i64] i32 (i32 x))";
(* Widening an integer to a float is admitted for the reason every other
cast is: (f64 x) on a written i64 rounds above 2^53 and is not refused,
so the bound does not refuse it either. A conversion is not a promise
that the value survives. *)
accepts "integer? admits (f64 x), the widening one"
"(defn tof [x $t] f64 {:where (integer? $t)} (f64 x))";
accepts "and the concrete widening it stands for"
"(defn tof [x i64] f64 (f64 x))";
(* numeric? admits floats, so (i32 x) under it can truncate — which is
exactly what (i32 x) on a written f64 does, so refusing it at the
variable would make the generic stricter than the code it copies. *)
accepts "numeric? admits (i32 x), which may truncate a float"
"(defn to32 [x $t] i32 {:where (numeric? $t)} (i32 x))";
accepts "and the concrete truncation it stands for"
"(defn to32 [x f64] i32 (i32 x))";
accepts "integer? admits an unsigned target"
"(defn tou [x $t] u8 {:where (integer? $t)} (u8 x))";
(* ordered?, equal? and hashable? say what can be compared or keyed, not
what is a number, so a conversion under one of them alone is refused —
and the message says which predicate to write. *)
rejects_check "ordered? does not admit a conversion"
~needle:"The where clause says t is ordered?, and that does not make it \
a number or an enum — add (numeric? $t) to the where clause, or \
(enum? $t) for an enum"
"(defn to32 [x $t] i32 {:where (ordered? $t)} (i32 x))";
rejects_check "nor does equal?"
~needle:"add (numeric? $t) to the where clause"
"(defn to32 [x $t] i32 {:where (equal? $t)} (i32 x))";
rejects_check "nor does hashable?"
~needle:"add (numeric? $t) to the where clause"
"(defn to32 [x $t] i32 {:where (hashable? $t)} (i32 x))";
(* With no clause at all the message hands over the whole clause rather
than a predicate to add to one that is not there. *)
rejects_check "an unbounded variable does not convert"
~needle:"i32 converts a number or an enum. Nothing here says t is a \
number or an enum — write {:where (numeric? $t)} at the head of \
the body, or {:where (enum? $t)} for an enum"
"(defn to32 [x $t] i32 (i32 x))";
(* enum? is the other bound a conversion to a number takes: it admits the
enums, which convert as an i32, and entails ordered? and equal? but not
numeric?. The running side is programs/enum-generic.flan. *)
accepts "enum? admits the conversion from an enum"
"(defn code [x $t] i32 {:where (enum? $t)} (i32 x))";
accepts "and compares, being ordered? and equal?"
"(defn later? [a $t b $t] bool {:where (enum? $t)} (and (> a b) (= a b)))";
rejects_check "but is not a number"
~needle:"$t"
"(defn sum [a $t b $t] $t {:where (enum? $t)} (+ a b))";
rejects_check "and admits no integer at the call"
~needle:"i32 is not enum?"
"(defn code [x $t] i32 {:where (enum? $t)} (i32 x))\n\
(defn f [] i32 (code (i32 3)))";
rejects_check "nor the conversion to an enum, which needs an integer"
~needle:"add (integer? $t) to the where clause"
"(defenum K [lo -1 hi 1])\n\
(defn as-k [n $t] K {:where (enum? $t)} (K n))";
(* The operand of a cast to a *variable* target is asked the same question
the target was: the target's bound says nothing about a second variable
standing in the argument. *)
accepts "a cast to a variable target takes a numeric? operand"
"(defn conv [x $u y $t] $t {:where [(numeric? $t) (numeric? $u)]} \
(if (< y y) (t x) (t x)))";
rejects_check "a cast to a variable target refuses an ordered? operand"
~needle:"add (numeric? $u) to the where clause"
"(defn conv [x $u y $t] $t {:where [(numeric? $t) (ordered? $u)]} \
(if (< y y) (t x) (t x)))";
(* The enum direction, where the two numeric bounds part company: an enum
is an i32 and a float has no enum reading, so this conversion needs
integer? exactly — numeric? would admit an f64 copy that the concrete
arm two lines below refuses. *)
accepts "integer? admits the conversion to an enum"
"(defenum K [lo -1 hi 1])\n\
(defn as-k [n $t] K {:where (integer? $t)} (K n))";
rejects_check "numeric? does not, because it admits floats"
~needle:"K converts an integer to an enum. The where clause says t is \
numeric?, and that does not make it an integer — add \
(integer? $t) to the where clause"
"(defenum K [lo -1 hi 1])\n\
(defn as-k [n $t] K {:where (numeric? $t)} (K n))";
rejects_check "and the concrete float it stands for is refused too"
~needle:"K converts an integer to an enum, found f64"
"(defenum K [lo -1 hi 1])\n\
(defn as-k [n f64] K (K n))";
accepts "a variable read twice under one predicate"
"(defn twice [a $t] bool {:where (ordered? $t)} (< a a))";
rejects_check "a predicate nobody has heard of"
~needle:"is not a type predicate"
"(defn f [a $t] $t {:where (sortable? $t)} a)";
rejects_check "a predicate about a variable the signature never bound"
~needle:"is not a type variable of f"
"(defn f [a i32] i32 {:where (ordered? $t)} a)";
(* A generic monomorphises by rechecking its body at the concrete type
(instantiate re-walks the AST, it does not substitute into an
already-built Tast), so [equal? $t] instantiated at string reaches the
same [check.ml] arm the direct = on two string literals above does.
[ordered? $t] never gets that far at string: [instantiate] checks the
{:where} clause itself against the concrete type before the body is
rechecked at all, so the refusal is the predicate one, not [<]'s
no-built-in-comparison message — that one is for a string written
directly in an ordering, where there is no predicate in between to catch
it first. *)
accepts "equal? $t instantiated at string"
"(defn same [a $t b $t] bool {:where (equal? $t)} (= a b)) \
(defn f [] bool (same \"a\" \"b\"))";
rejects_check "ordered? $t instantiated at string"
~needle:"is not ordered?"
"(defn less [a $t b $t] bool {:where (ordered? $t)} (< a b)) \
(defn f [] bool (less \"a\" \"b\"))";
(* Everything copies since the second repeal, so a double use of a binding
needs no clause at all — and [copyable?] itself is gone, refused the way
any unknown predicate is, which is this pin's job to remember. *)
accepts "a type variable is usable twice with no clause"
"(defn twice [a $t b (Fn [$t $t] $t)] $t (b a a))";
rejects_check "copyable? is no longer a predicate"
~needle:"is not a type predicate"
"(defn twice [a $t b (Fn [$t $t] $t)] $t {:where (copyable? $t)} (b a a))";
(* The allow-list, and it has two members. println over a type variable is
deferred to the instantiation, because its legality is only decidable
after substituting — which is the one thing the abstract pass otherwise
refuses to do. *)
accepts "println over a type variable is deferred"
"(defn show [x $t] () {:where (equal? $t)} (println x))";
accepts "and so is print"
"(defn show [x $t] () {:where (equal? $t)} (print x))";
(* One generic argument defers the whole call, neighbours included. *)
accepts "a variadic println with a type variable among the arguments"
"(defn show [x $t] () {:where (equal? $t)} (println \"x:\" x 1))";
(* Variadic print/println: any number of arguments, zero included. The
acceptance program pins what comes out; these pin only what the checker
admits, and — the part a program cannot show — where a refusal lands. *)
accepts "println with no arguments" "(defn f [] () (println))";
accepts "print with no arguments" "(defn f [] () (print))";
accepts "println with three arguments of three types"
"(defn f [] () (println \"x:\" 5 true))";
(* An unprintable argument is refused at its own span, not the form's:
each argument is checked carrying its own loc, and render.ml fails on
the expression's loc. Column 43 is the [m], not the [(println]. *)
(let name = "an unprintable argument is refused at the argument" in
match checked "(defn f [m (Map i32 i32)] () (println \"x\" m))" with
| _ ->
incr failures;
Printf.printf "FAIL %s: expected a type error\n" name
| exception Loc.Error { Loc.dloc; dmsg; _ } ->
let got = Loc.to_string dloc in
if got <> "<test>:1:43" || not (contains dmsg "no printer for") then begin
incr failures;
Printf.printf "FAIL %s\n wanted: %s (no printer for)\n got: %s (%s)\n"
name "<test>:1:43" got dmsg
end);
(* The same refusal from watch is worded for watch, not for print. *)
(let name = "an unwatchable value is refused in watch's own words" in
match checked "(defn f [m (Map i32 i32)] () (watch \"m\" m))" with
| _ ->
incr failures;
Printf.printf "FAIL %s: expected a type error\n" name
| exception Loc.Error { Loc.dmsg; _ } ->
if not (contains dmsg "cannot be watched") || contains dmsg "print" then begin
incr failures;
Printf.printf "FAIL %s\n got: %s\n" name dmsg
end);
(* A predicate a body relies on has to be carried by every signature between
it and the call site, or the refusal moves into code the caller did not
write. *)
rejects_check "a predicate is not carried through a generic call"
~needle:"Add {:where (ordered? $t)} to this function's own clause"
"(defn outer [s [$t]] () {:where (equal? $t)} (sort s))";
accepts "and is accepted when it is"
"(defn outer [s [$t]] () {:where (ordered? $t)} (sort s))";
(* ── A generic call inside an abandoned widening trial ──────────────
The two features land days apart and meet here. A binary operator whose
operands disagree re-checks the right one at the left one's type inside a
[trial], and on a refusal reconsiders with the join — so a generic call
written on the right is checked twice, once in a pass that is thrown
away. What the discarded pass leaves behind in [env] is the question, and
[env] is the program's table, not the form's: an instantiation made
during it does not go back out, because [instantiate] rewinds only a copy
whose *body* refused.
It does not have to. The answer is that the two passes cannot disagree
about which copy to make, and that is a consequence of the rule above
rather than luck: a generic call's instantiation is read off its
arguments and never off the ambient want — an unbound variable is checked
with no expectation at all, and a bound one no longer widens — so the
trial and the live pass ask [instantiate] for the same types, and the
second ask is a cache hit on the first. One copy is emitted, at the type
the arguments chose, and the widening happens around the call.
(twoq 2 3) is i32 both times; the i8 on the left is what moves. *)
(let p =
checked
"(defn twoq [a $t b $t] $t {:where (numeric? $t)} (+ a b))\n\
(defn main [] () (let [small (i8 1)] \
(println (+ small (twoq 2 3)))))"
in
let copies =
List.filter
(fun (f : Tast.fn) ->
String.length f.Tast.name >= 5 && String.sub f.Tast.name 0 5 = "twoq-")
p.Tast.fns
in
match copies with
| [ { Tast.name = "twoq-i32"; _ } ] -> ()
| l ->
check
(Printf.sprintf
"a generic inside an abandoned trial is instantiated once: %s"
(String.concat " " (List.map (fun (f : Tast.fn) -> f.Tast.name) l)))
false);
(* ── A type variable is not instantiated at dyn ─────────────────────
Nothing stopped it before: dyn is an ordinary case of Types.t, so it
substituted like any other type and the copy was generated. What the copy
then ran into was the dyn answers that are not all there — (Option dyn)
has no descriptor the collector can find — and the refusal arrived from
inside the generic's own source. (or-else (Some d) e) over two dyns used
to be reported against <prelude>:385, a line the caller did not write.
The refusal is at the call site now, and it names the other model rather
than only saying no. *)
rejects_check "a type variable is not instantiated at dyn"
~needle:"is not instantiated at dyn"
"(defn idf [x $t] $t x)\n\
(defonce d dyn 5)\n\
(defn main [] () (println (idf d)))";
rejects_check "and the refusal names the dyn side rather than only saying no"
~needle:"defmethod"
"(defn idf [x $t] $t x)\n\
(defonce d dyn 5)\n\
(defn main [] () (println (idf d)))";
(* Nor at a type that merely *reaches* a dyn, which is the shape that used
to walk furthest before failing: (Option dyn) is the case the collector
has no descriptor for, and the refusal for it arrived from <prelude>:385.
It arrives here now, against the call that asked for the copy. *)
rejects_check "nor at a type that merely reaches a dyn"
~needle:"$t = (Option dyn)"
"(defn maybe [] (Option dyn) None)\n\
(defn idf [x $t] $t x)\n\
(defn main [] () (println (some? (idf (maybe)))))";
(* A variable that carries a clause keeps the clause's refusal, which names
the predicate the signature actually wrote down — the more specific of
the two answers, and the one the generic cast's pin above depends on. *)
rejects_check "a bounded variable is still refused by its bound"
~needle:"numeric?"
"(defn twice [x $t] $t {:where (numeric? $t)} (+ x x))\n\
(defonce d dyn 5)\n\
(defn main [] () (println (twice d)))";
(* ── Mixed widths at one type variable join at the wider type ───────
The rule used to refuse the pair both ways, with the join recorded as
the coherent alternative that could be added without invalidating
anything — the walk-backable direction. The author walked it back on
2026-09-20: a scalar pair at one $t resolves to whichever of the two
the other widens into, value-preserving widening only, and both
argument orders produce the identical copy. A pair with no join — u64
against i64 — keeps a refusal, because there is no type that holds
every value of both. TODO.org, "abs is one generic, and a bound joins to
the wider type". *)
accepts "a scalar pair at one $t joins at the wider type"
"(defn eq2? [a $t b $t] bool {:where (equal? $t)} (= a b))\n\
(defn main [] () (println (eq2? (i64 3) (i8 3))))";
accepts "and the other argument order joins identically"
"(defn eq2? [a $t b $t] bool {:where (equal? $t)} (= a b))\n\
(defn main [] () (println (eq2? (i8 3) (i64 3))))";
(* Order-independence, pinned on the copies and not only on acceptance:
both orders in one program make exactly one instantiation, at i64, and
none at i8. *)
(let syms order_a order_b =
match
checked
("(defn eq2? [a $t b $t] bool {:where (equal? $t)} (= a b))\n\
(defn main [] () (do (println (eq2? " ^ order_a ^ "))\
(println (eq2? " ^ order_b ^ "))))")
with
| p ->
List.filter_map
(fun (f : Tast.fn) ->
if String.length f.Tast.name >= 4
&& String.sub f.Tast.name 0 4 = "eq2?" then Some f.Tast.name
else None)
p.Tast.fns
| exception _ -> [ "did not check" ]
in
check "both orders share one copy, at the wider type"
(syms "(i8 3) (i64 4)" "(i64 5) (i8 6)" = [ "eq2?-i64" ]);
check "and the reversed program instantiates the same one copy"
(syms "(i64 5) (i8 6)" "(i8 3) (i64 4)" = [ "eq2?-i64" ]));
(* The pair that meets at no type is the refusal that stays: neither u64
nor i64 holds every value of the other, and inventing a third type
would be picking one neither argument was written at. *)
rejects_check "u64 and i64 meet at no type"
~needle:"neither holds every value of the other"
"(defn eq2? [a $t b $t] bool {:where (equal? $t)} (= a b))\n\
(defonce u u64 3)\n(defonce i i64 3)\n\
(defn main [] () (println (eq2? u i)))";
(* And a later, wider argument settles a pair that had no join of its own:
u32 and i32 meet nowhere, but all three meet at the i64 that arrives
third — in either order, which is what the deferred re-ask is for. *)
accepts "a later argument settles a joinless pair"
"(defn tri [a $t b $t c $t] $t {:where (numeric? $t)} (+ a (+ b c)))\n\
(defonce x3 u32 1)\n(defonce y3 i32 2)\n(defonce z3 i64 3)\n\
(defn main [] () (println (tri x3 y3 z3)))";
accepts "and the same trio in the other order"
"(defn tri [a $t b $t c $t] $t {:where (numeric? $t)} (+ a (+ b c)))\n\
(defonce x3 u32 1)\n(defonce y3 i32 2)\n(defonce z3 i64 3)\n\
(defn main [] () (println (tri z3 y3 x3)))";
(* A variable the signature also reaches through a container is bound
exactly — a slice's elements cannot be rewritten to a wider width — so
the join never moves one, in either direction of the mismatch. *)
rejects_check "a container-bound variable does not join wider"
~needle:"binds its element exactly"
"(defn main [] () (let [ns [5 3 9 1]] \
(match (index-of (slice ns 0 4) (i64 9)) \
(Some i) (println i) _ (println -1))))";
(* The one direction a container-fixed binding does admit, and it is new
with the join: a *narrower* scalar widens into the type the container
fixed, through the same cast a monomorphic i32 parameter applies. This
used to refuse with the same both-ways sentence as everything else. *)
accepts "a narrower scalar widens into a container-fixed binding"
"(defn main [] () (let [ns [5 3 9 1]] \
(match (index-of (slice ns 0 4) (i16 9)) \
(Some i) (println i) _ (println -1))))";
(* The written conversion is what the message asks for, and it is accepted:
the refusal is about the *implicit* step, not about reaching i64. *)
accepts "the written conversion is accepted"
"(defn eq2? [a $t b $t] bool {:where (equal? $t)} (= a b))\n\
(defn main [] () (println (eq2? (i64 3) (i64 (i8 3)))))";
(* An untyped constant has no type of its own to keep, so it still takes the
variable's. Nothing is converted here — three i64s were written. *)
accepts "an untyped literal still takes a bound type variable's type"
"(defn clamp3 [x $t lo $t hi $t] $t {:where (ordered? $t)} \
(min (max x lo) hi))\n\
(defn main [] () (println (clamp3 (i64 12) 0 10)))";
(* And the shapes widening cannot reach are untouched, which is the reason
the rule costs so little: [Types.widens_to] admits only numeric scalars,
so a variable bound inside a slice or a function type leaves a parameter
no widening applied to in the first place. *)
accepts "a variable bound inside a constructor is unaffected"
"(defn sort2 [s [$t] before? (Fn [$t $t] bool)] () \
(sort-by s before?))\n\
(defn main [] () (let [ns [5 3 9 1]] \
(sort2 (slice ns 0 4) (fn [a b] (< a b))) (println (at ns 0))))";
(* A form with no type of its own is still checked against the parameter:
the trial that asks for its natural type refuses, and the want it always
had is what it falls back to. *)
accepts "a form that needs a want still gets one at a bound type variable"
"(defn pick [a $t b $t] $t (do b a))\n\
(defn main [] () (println (pick (i64 3) (zeroed))))";
(* ── A numeric literal where a type variable is wanted ──────────────
The author's motivating family — one pos? over every numeric type from
one definition — needs a written 0 to stand where $t stands. The bound
is what makes it sound: every type [numeric?] admits is an integer or a
float, and an untyped integer constant is usable at all of them, so
there is no instantiation of a [numeric?] variable at which the literal
has no meaning. That is the whole rule, and the four pins below are its
two halves and its one asymmetry. *)
accepts "an integer literal stands where a numeric? type variable is wanted"
"(defn above-zero? [x $t] bool {:where (numeric? $t)} (> x 0))";
accepts "and in arithmetic, answering the variable"
"(defn next [x $t] $t {:where (numeric? $t)} (+ x 1))";
(* And the prelude's own three, which are that body under its real name at
every numeric type from one definition. *)
accepts "the prelude's sign family answers at six numeric types"
"(defn main [] () (println (pos? 3) ) (println (neg? (i8 -1))) \
(println (zero? (u8 0))) (println (zero? 0.0)) \
(println (pos? (u64 1))) (println (neg? (f32 -0.5))))";
(* [numeric?] is what admits it and nothing weaker does. [ordered?] admits
an enum, which holds no number, so a literal under it has an
instantiation at which it means nothing — and the refusal below is what
stops that reaching the call site. *)
rejects_check "an unconstrained type variable admits no literal"
~needle:"nothing declares $t numeric"
"(defn f [x $t] bool (> x 0))";
rejects_check "and ordered? is not the bound that admits one"
~needle:"Write {:where (numeric? $t)}"
"(defn f [x $t] bool {:where (ordered? $t)} (> x 0))";
(* The asymmetry, and it is the concrete arms' asymmetry rather than a new
one: an untyped integer constant is usable where a float is wanted, and
a float literal is never usable where an integer is wanted. [numeric?]
covers both halves of the numbers, so a body written with a float
literal has no meaning at the integer half of its own bound. Refused at
the definition, which is where the abstract pass promises refusals
arrive — not at whichever call site first asks for i32. *)
rejects_check "a float literal is refused at a type variable even under numeric?"
~needle:"may be instantiated at an integer type"
"(defn half [x $t] $t {:where (numeric? $t)} (* x 0.5))";
(* A map key that is a type variable has no hash and no equality to emit:
they are chosen from the concrete type, which does not exist yet. So the
map operations join print and println on the list of forms the abstract
pass defers to the instantiation — but only under the predicate, which is
what gives the deferred refusal somewhere to land. Without one the type
itself is refused where it is written, at the definition. *)
rejects_check "a map keyed by a type variable that is not hashable?"
~needle:"is not a map key"
"(defn f [m (Map $t i32)] i32 {:where (numeric? $t)} (length m))";
accepts "and hashable? is what says it is"
"(defn f [m (Map $t i32)] i32 {:where (hashable? $t)} (length m))";
accepts "and under it the operations are deferred, not refused"
"(defn f [m (Map $t i32) k $t] () {:where (hashable? $t)} (put m k 1))";
accepts "get over a type-variable key answers an (Option V)"
"(defn f [m (Map $t i32) k $t] i32 {:where (hashable? $t)} \
(match (get m k) (Some v) v _ 0))";
(* And so does the removal, whose placeholder is [get]'s for the same reason:
it answers an (Option V), so the match around it still has to check while
the key is a variable. *)
accepts "map-remove over a type-variable key answers an (Option V)"
"(defn f [m (Map $t i32) k $t] i32 {:where (hashable? $t)} \
(match (map-remove m k) (Some v) v _ 0))";
accepts "and so do has-key?, reserve and clone"
"(defn f [m (Map $t i32) k $t] bool {:where (hashable? $t)} \
(do (reserve m 8) (let [c (clone m)] (free c) (has-key? m k))))";
(* The definition is still where a generic with no clause to point at is
refused: nothing has been written down for an instantiation to be judged
against, so the refusal has nowhere to move to. *)
rejects_check "a map built inside a generic that declares nothing"
~needle:"is not a map key"
"(defn f [k $t] () (let [m (map-new t i32)] (put m k 1) (free m)))";
(* ── A type variable, spelled with the sigil, where a type name goes ──
[$t] is the signature's spelling and [t] is the body's, and they are the
same variable: the tables that record which variables are in scope are
keyed on the bare name, so every membership test has to strip the sigil
before asking. The ones that did not strip were the guards in front of
[vec-new] and [map-new] and the cast arm, which is why a body that wrote
[(vec-new $t)] was told it had not said what the Vec held. *)
accepts "vec-new over a type variable written with the sigil"
"(defn f [x $t] (Vec $t) (let [v (vec-new $t)] (push v x) v))";
accepts "and against a named allocator"
"(defn f [x $t a Allocator] (Vec $t) \
(let [v (vec-new $t a)] (push v x) v))";
accepts "map-new over type variables written with the sigil"
"(defn f [k $t] i32 {:where (hashable? $t)} \
(let [m (map-new $t i32)] (put m k 1) (let [n (length m)] (free m) n)))";
accepts "a zeroed fixed array of a type variable"
"(defn f [x $t] $t (let [a (array 3 $t)] (set (at a 1) x) (at a 1)))";
accepts "a cast to a type variable written with the sigil"
"(defn f [x i32 d $t] $t {:where (numeric? $t)} (do d ($t x)))";
(* The message these were taking is still the message for the case it was
written for: nothing named, and nothing at the site that says. *)
rejects_check "vec-new with no element type and nothing to take one from"
~needle:"nothing here says what (vec-new) is a Vec of"
"(defn f [x $t] i32 (do x (let [v (vec-new)] (free v) 0)))";
(* A type expression in a type position, generic or not. *)
accepts "vec-new over a slice of a type variable"
"(defn f [x [$t]] i32 (let [v (vec-new [$t])] (push v x) \
(let [n (length v)] (free v) n)))";
rejects_check "map-new with a key type expression and no value type"
~needle:"(map-new) names a key and no value"
"(defn f [] i32 (let [m (map-new [u8])] (free m) 0))";
accepts "vec-new over a function type returning unit"
"(defn f [] i32 (let [v (vec-new (Fn [i32] ()))] (free v) 0))";
accepts "a program's own vec-new takes an array literal"
"(defn vec-new [xs [3 i32]] i32 (at xs 2)) \
(defn f [] i32 (vec-new [1 2 3]))";
accepts "builtin/vec-new over a type expression"
"(defn f [] i32 (let [v (builtin/vec-new [u8])] (free v) 0))";
(* An integer written at or above 2^63 — decimal, or hex with the top bit
set — is a u64 and nothing else, and a refusal prints it as written. *)
accepts "a wide decimal at u64"
"(defconst a u64 18446744073709551615) (defonce b u64 0xFFFFFFFFFFFFFFFF) \
(defn f [x u64] u64 (+ x 9223372036854775808)) \
(defn g [] f64 (f64 (u64 12345678901234567890)))";
(* A negative literal fits no unsigned type, wherever the type comes from;
the cast the refusal names is how to write the bit pattern. *)
List.iter
(fun (what, src, needle) -> rejects_check what src ~needle)
[ ("a negative literal at a u64 constant", "(defconst a u64 -1)",
"-1 does not fit in u64, which holds no negative number — write \
(u64 -1) for the u64 with the same bits, 18446744073709551615");
("a negative literal at a u32 global", "(defonce g u32 -5)",
"write (u32 -5) for the u32 with the same bits, 4294967291");
("a negative literal as a u64 return", "(defn f [] u64 -1)",
"-1 does not fit in u64");
("a negative literal as a u32 argument",
"(defn t [x u32] u32 x) (defn f [] u32 (t -2))", "-2 does not fit in u32");
("a negative literal in a u8 field",
"(defstruct S [a u8]) (defn f [] S (S -3))", "write (u8 -3)");
("a negative literal given a u64 by the",
"(defn f [] i32 (let [a (the u64 -1)] 0))", "-1 does not fit in u64");
("a negative literal beside a u64-only literal",
"(defn f [] i32 (let [a [-1 18446744073709551615]] 0))",
"write (u64 -1) for the u64");
("a negative literal beside a u64 element",
"(defn f [x u64] i32 (let [a [x -1]] 0))", "write (u64 -1) for the u64") ];
accepts "the casts those refusals name compile"
"(defconst a u64 (u64 -1)) (defonce g u32 (u32 -5)) \
(defstruct S [a u8]) (defn f [x u64] S \
(let [a [(u64 -1) 18446744073709551615] b [x (u64 -1)] \
c (the u64 (u64 -1))] \
(S (u8 -3))))";
(* The literal that does not fit is the one blamed, not one that does. *)
rejects_check "a negative literal among u64 elements is the one blamed"
"(defn f [] () (println [(u64 2) 1 -1]))" ~needle:"-1 does not fit in u64";
rejects_check "a negative literal after a u64 element is the one blamed"
"(defn f [] () (println [1 (u64 2) -1]))" ~needle:"-1 does not fit in u64";
(* In a generic body the cast would break the other instantiations. *)
(match
checked
"(defn add1 [x $t] $t {:where (numeric? $t)} (+ x -1)) \
(defn main [] i32 (add1 3) (add1 (u64 5)) 0)"
with
| _ -> check "a negative literal at a u64 instantiation is refused" false
| exception Loc.Error d ->
check "the generic's refusal names a fix for every type and the call"
(contains d.Loc.dmsg "as in (- x 1) in place of (+ x -1)"
&& not (contains d.Loc.dmsg "(u64 -1)")
&& List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg "add1 is instantiated at $t = u64 here")
d.Loc.notes));
accepts "the generic's fix compiles at both types"
"(defn add1 [x $t] $t {:where (numeric? $t)} (- x 1)) \
(defn main [] i32 (add1 3) (add1 (u64 5)) 0)";
accepts "a doubly negated literal is positive at an unsigned type"
"(defn f [] u8 (- (- 1)))";
rejects_check "a folded constant's conversion is still its type"
"(defconst a u8 (i32 5))" ~needle:"expected u8, found i32";
rejects_check "a wide decimal with nothing to say u64"
~needle:"18446744073709551615 does not fit in i32, the type an integer \
literal takes when nothing says otherwise — write (u64 \
18446744073709551615)"
"(defn f [] () (println 18446744073709551615))";
rejects_check "a wide decimal cast to i64"
~needle:"18446744073709551615 does not fit in i64"
"(defn f [] i64 (i64 18446744073709551615))";
rejects_check "a wide decimal cast to f64"
~needle:"write (f64 (u64 18446744073709551615))"
"(defn f [] f64 (f64 18446744073709551615))";
rejects_check "a wide decimal constant at i32"
~needle:"18446744073709551615 does not fit in i32"
"(defconst x i32 18446744073709551615)";
rejects_check "a wide decimal constant at f64"
~needle:"write (f64 (u64 12345678901234567890))"
"(defconst x f64 12345678901234567890)";
rejects_check "a wide decimal argument to an i8 parameter"
~needle:"18446744073709551600 does not fit in i8"
"(defn g [a i8] i8 a) (defn f [] i8 (g 18446744073709551600))";
rejects_check "a wide decimal operand prints as written"
~needle:"9223372036854775808 does not fit in i32"
"(defn f [] () (println (+ 1 9223372036854775808)))";
rejects_check "a hex literal with the top bit set at i32"
~needle:"0xFFFFFFFFFFFFFFFF does not fit in i32"
"(defconst x i32 0xFFFFFFFFFFFFFFFF)";
rejects_check "a hex literal with the top bit set at i64"
~needle:"0xFFFFFFFFFFFFFFFF does not fit in i64"
"(defconst x i64 0xFFFFFFFFFFFFFFFF)";
(* And a sigil on a name nothing binds is answered as the unbound variable
it is, rather than as a missing element type — with the names that *are*
bound, because inside a signature that introduces one the mistake is
nearly always the second spelling of the first. *)
rejects_check "vec-new over a sigil that names no variable in scope"
~needle:"this signature introduces $t, so write $t here"
"(defn f [x $t] i32 (do x (let [v (vec-new $u)] (free v) 0)))";
rejects_check "and a cast over one tells the same story"
~needle:"this signature introduces $t, so write $t here"
"(defn f [x i32 d $t] $t {:where (numeric? $t)} (do d ($u x)))";
rejects_check "two variables in scope are both named"
~needle:"introduces $t and $u, so write one of those"
"(defn f [a $t b $u] i32 (do a b (let [v (vec-new $w)] (free v) 0)))";
(* Where no variable is in scope there is none to name, and the answer is
the rule: a sigil binds, and only a defn signature is a binding site. *)
rejects_check "a sigil in a data case's field, where nothing can bind one"
~needle:"only a defn signature or a defstruct's fields can"
"(defdata D [(C [v $t])])";
(* ── Generic structs: what is refused, and where ─────────────────── *)
rejects_check "a generic struct given the wrong number of arguments"
~needle:"Pair takes 1 argument, (Pair $t), and this gives 2"
"(defstruct Pair [a $t b $t]) (defn f [p (Pair i32 i64)] i32 0)";
rejects_check "a generic struct named with no arguments"
~needle:"Pair is generic, and a type only once it is given its arguments"
"(defstruct Pair [a $t b $t]) (defn f [p Pair] i32 0)";
rejects_check "a type where a length argument goes"
~needle:"Small's $n is a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small i32 4)] i32 0)";
rejects_check "a length where a type argument goes"
~needle:"Small's $t is a type, and 4 is a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small 4 4)] i32 0)";
rejects_check "a negative length argument"
~needle:"-1 is negative"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small -1 i32)] i32 0)";
rejects_check "one variable as both a length and a type"
~needle:"$t stands for a length in one place here and a type in another"
"(defstruct Bad [x $t y [$t i32]])";
rejects_check "a length variable where a type goes"
~needle:"n is a length, not a type"
"(defn f [a [$n i32]] i32 (let [x (the n 0)] 0))";
rejects_check "a where clause over a length variable"
~needle:"$n is a length, and a where clause takes type predicates only"
"(defn f [a [$n i32]] i32 {:where (numeric? $n)} 0)";
rejects_check "a generic struct that contains itself by value"
~needle:"(Loop $t) contains itself by value"
"(defstruct Loop [next (Loop $t)])";
rejects_check "a generic struct that asks for bigger copies of itself"
~needle:"Grow names a copy of itself at a type built around its own"
"(defstruct Grow [next (Ptr (Grow [$t]))]) (defn f [p (Grow i32)] i32 0)";
rejects_check "a copy whose key is already a struct's name"
~needle:"Pair at these arguments is called Pair-i32, and Pair-i32 is \
already defined"
"(defstruct Pair [a $t b $t]) (defstruct Pair-i32 [x i32]) \
(defn f [p (Pair i32)] i32 0)";
rejects_check "a generic struct literal whose fields decide nothing"
~needle:"Pair's $t is not decided by the fields given here"
"(defstruct Pair [a $t b $t]) (defn f [] i32 (let [p (Pair {})] 0))";
rejects_check "two fields that disagree about the variable"
~needle:"(Pair $t)'s .b is i32 here, and this is f64"
"(defstruct Pair [a $t b $t]) \
(defn f [] i32 (let [p (Pair (the i32 1) (the f64 2.5))] 0))";
accepts "a literal field takes its width from a typed one beside it"
"(defstruct Pair [a $t b $t]) \
(defn f [] f64 (let [p (Pair 1 (the f64 2.5))] (.a p)))";
rejects_check "a generic struct as a condition"
~needle:"Pair is generic, and a condition struct is not"
"(defstruct Pair :parent Error [a $t])";
rejects_check "an operator a generic body's struct field does not support"
~needle:"+ over the type variable $t"
"(defstruct Pair [a $t b $t]) (defn f [p (Pair $t)] $t (+ (.a p) (.b p)))";
accepts "the same body with the predicate declared"
"(defstruct Pair [a $t b $t]) \
(defn f [p (Pair $t)] $t {:where (numeric? $t)} (+ (.a p) (.b p))) \
(defn main [] i32 (f (Pair 1 2)))";
accepts "a copy wanted where it is built takes its type from there"
"(defstruct Pair [a $t b $t]) (defn f [] (Pair i64) (Pair 1 2))";
(* A copy whose field is refused names each use that asked for it. *)
(match
checked
"(defstruct Box [f $t]) (defstruct Outer [b (Box $w)]) \
(defn go [g (Fn [i32] i32)] i32 \
(.x (the (Outer (Fn [i32] i32)) (zeroed))) 0)"
with
| _ -> check "a copy with a zeroed function field is refused" false
| exception Loc.Error d ->
let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in
check "a refused copy names each use that made it"
(List.mem "(Box (Fn [i32] i32)) is made here" notes
&& List.mem "(Outer (Fn [i32] i32)) is made here" notes));
rejects_check "a bare generic struct in ordinary code suggests real arguments"
~needle:"write (Pair i32)"
"(defstruct Pair [a $t b $t]) (defn main [] i32 (let [p (the Pair (zeroed))] 0))";
rejects_check "a generic struct applied to nothing"
~needle:"Pair takes 1 argument, (Pair $t), and this gives 0"
"(defstruct Pair [a $t b $t]) \
(defn main [] i32 (let [p (the (Pair) (zeroed))] 0))";
rejects_check "a length argument that is not one"
~needle:"(+ n 1) is not a type or a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn main [] i32 (let [n 3 p (the (Small (+ n 1) i32) (zeroed))] 0))";
accepts "a length argument of literal arithmetic is folded"
"(defstruct Small [items [$n $t] count i32]) \
(defn main [] i32 (let [p (the (Small (+ 1 2) i32) (zeroed))] \
(length (.items p))))";
accepts "two literal fields meet at the wider type"
"(defstruct Pair [a $t b $t]) \
(defn f [] f64 (let [p (Pair 1 2.5)] (+ (.a p) (.b p))))";
rejects_check "a callee's predicate names the caller's variable with its $"
~needle:"passes the type variable $t, which nothing here declares ordered?"
"(defn f [s [$t]] () (sort s))";
accepts "a defonce of a generic struct's copy"
"(defstruct Pair [a $t b $t]) (defonce g (Pair i32)) \
(defn main [] i32 (.a g))";
(* ── The builtin table against the arms it describes ──────────────
[Check.builtins] is what the editor's C-c C-v and M-. read for a name no
program wrote — [arena-new] and the seventy-seven others. A table like
that is worth less than nothing once it is stale: a builtin added without
an entry answers nothing, and an entry for an arm that was deleted
describes a name that no longer exists, which is worse because it reads
as authoritative.
There is no way to reflect over an OCaml match, so this reads the source
instead. The two regions are [named_call]'s arms and [var]'s, each from
its own [and] down to the catch-all at the same indentation, and the
names are the string literals in the arm heads. It is a regex over one
file and costs nothing, which is why it is in the default run rather
than behind an alias.
The catch-all is [ | _ ->] and not [ | _], because a guarded arm is
not one: [named_call] opens with [| _ when shadows_builtin ...], which
is a name the program defined taking its own call over, and stopping
there would read the region as empty and report every builtin as
undescribed. Guarded arms in between are skipped by the same rule that
skips a comment — they carry no string literal in the head. *)
let arm_names () =
let src =
In_channel.with_open_bin "../lib/check.ml" In_channel.input_all
in
let lines = String.split_on_char '\n' src in
let starts_with p s =
String.length s >= String.length p && String.sub s 0 (String.length p) = p
in
let quoted line =
let out = ref [] and i = ref 0 and n = String.length line in
while !i < n do
if line.[!i] = '"' then begin
let j = ref (!i + 1) in
while !j < n && line.[!j] <> '"' do incr j done;
if !j < n then out := String.sub line (!i + 1) (!j - !i - 1) :: !out;
i := !j + 1
end else incr i
done;
List.rev !out
in
let region head =
let rec drop = function
| [] -> []
| l :: rest -> if starts_with head l then rest else drop rest
in
let rec take = function
| [] -> []
| l :: rest ->
if starts_with " | _ ->" l then []
else if starts_with " | \"" l then quoted l @ take rest
else take rest
in
take (drop lines)
in
region "and named_call " @ region "and var ctx "
in
let arms = arm_names () in
let table = List.map (fun (n, _, _) -> n) Check.builtins in
check "every builtin arm is described" (arms <> [] && List.length arms > 60);
List.iter
(fun n ->
if not (List.mem n table) then begin
incr failures;
Printf.printf
"FAIL the builtin %s has an arm in check.ml and no entry in \
Check.builtins\n" n
end)
arms;
List.iter
(fun n ->
if not (List.mem n arms) then begin
incr failures;
Printf.printf
"FAIL Check.builtins describes %s, which is no longer an arm\n" n
end)
table;
(* A signature and a line, for every one of them: an entry that is present
and empty answers the question no better than a missing one. *)
List.iter
(fun (n, sign, doc) ->
if sign = "" || doc = "" then begin
incr failures;
Printf.printf "FAIL the builtin %s has no %s\n" n
(if sign = "" then "signature" else "description")
end)
Check.builtins;
(* ── Memory diagnostics, --warn-memory ──────────────────────────
[Check.memory_sites] over a checked program: which lines allocate, on
which heap, and — the half that is harder to keep true — which lines do
not.
Pinned exactly, location and message both, and the location matters as
much as the wording: the whole feature is a squiggle under a character,
and a pass that found the right number of sites at the wrong columns
would draw them under the wrong forms. The file is fixed to [<test>] so
the prelude's own pushes, which are real and are not the caller's
business, stay out of the comparison. *)
let memory name src want =
let got =
List.map
(fun (d : Loc.diag) ->
(d.Loc.dloc.Loc.line, d.Loc.dloc.Loc.col, d.Loc.kind, d.Loc.dmsg))
(Check.memory_sites ~file:"<test>" (checked src))
in
let show (l, c, k, m) = Printf.sprintf "\n %d:%d %s %S" l c k m in
if got <> want then begin
incr failures;
Printf.printf "FAIL %s\n wanted:%s\n got:%s\n" name
(String.concat "" (List.map show want))
(String.concat "" (List.map show got))
end
in
let gc = "memory/gc" and native = "memory/native" in
(* The collected heap. Every row here is a [gc_alloc] in flan_dyn.c on the
way through, and the negatives between them are the point: a typed
[vec-new] takes no block, and neither does an immediate. *)
memory "the collected heap, and what does not touch it"
"(defonce wide i64 999999999999999)\n\
(defonce small i32 7)\n\
(defn take [x] () (print x))\n\
(defn main [] ()\n\
\ (let [tv (vec-new i32)\n\
\ dv (vec-new dyn)\n\
\ m {:a 1}]\n\
\ (take \"hi\")\n\
\ (take 5)\n\
\ (take true)\n\
\ (take nil)\n\
\ (take :kw)\n\
\ (take 1.5)\n\
\ (take small)\n\
\ (take wide)\n\
\ (push tv 1)\n\
\ (push dv 2)))"
[ (6, 12, gc, "allocates: a dyn vector is an object on the collector's heap");
(7, 11, gc, "allocates: a dyn map is an object on the collector's heap");
(8, 11, gc,
"allocates: a string crossing into dyn is copied onto the collector's \
heap");
(* The only integer here that can leave the 48-bit payload. [small] is an
i32 widened to i64 at the crossing and provably cannot, [5] is a
literal inside the range, and neither is named. *)
(15, 11, gc,
"may allocate: an i64 outside ±2^47 does not fit a dyn's payload and \
spills onto the collector's heap");
(* The typed push, which is the native side; [(push dv 2)] on the line
below it is the dyn runtime's own vector growing itself and is not a
site the program can do anything about. *)
(16, 5, native,
"may allocate: a push past the Vec's capacity grows it through its \
allocator") ];
(* A capturing fn that outlives its frame allocates its environment on the
collected heap. One only called or passed down keeps its copies on the
frame, and one that captures nothing is a code address; neither
allocates. *)
memory "a capturing fn that escapes, one that does not, and one that captures nothing"
"(defn apply1 [f (Fn [i32] i32) x i32] i32 (f x))\n\
(defn make [n i32] (Fn [i32] i32) (fn [x] (+ x n)))\n\
(defn main [] ()\n\
\ (let [n 3]\n\
\ (print (apply1 (fn [x] (+ x n)) 1))\n\
\ (print (apply1 (fn [x] x) 1))\n\
\ (print ((make 2) 1))))"
[ (2, 35, gc,
"allocates: an fn that captures and outlives its frame keeps its \
copies in an environment on the collector's heap") ];
(* The allocator side, and the two shapes of [flan_vec_init]: [slurp] sizes
the Vec to the file and takes a block here, [(vec-new i32 a)] passes a
capacity of zero and takes none. Same runtime entry point, two answers,
which is why the classifier reads the capacity argument rather than the
symbol alone. *)
memory "an allocator the program named"
"(defonce gv (Vec i64) (vec-new i64))\n\
(defn take [x] () (print x))\n\
(defn arith [a b] () (take (+ a b)))\n\
(defn main [] ()\n\
\ (let [a (arena-new 4096)\n\
\ tm (map-new str i32 a)\n\
\ tv (vec-new i32 a)\n\
\ txt (slurp \"x\" a)]\n\
\ (take gv)\n\
\ (put tm \"k\" 1)\n\
\ (reserve tv 4)\n\
\ (arith 1 2)\n\
\ (print (length txt))))"
[ (5, 11, native,
"allocates: an arena takes its whole region from the host here");
(8, 13, native,
"allocates: the Vec is sized up front and takes its block from its \
allocator here");
(* A (Vec i64) crossing into dyn is a view, and the view record is a
heap object even though not one element is copied. *)
(9, 11, gc,
"allocates: a typed container crossing into dyn takes a view record on \
the collector's heap — the elements are not copied, the record is");
(10, 5, native,
"may allocate: a put past the map's load factor grows its block through \
its allocator");
(11, 5, native,
"may allocate: a reserve past the Vec's capacity grows it through its \
allocator") ];
(* Two negatives on their own, because they are the ones a careless
classifier gets wrong and a test that only counted rows would not catch.
[(+ a b)] over two dyns ends in [flan_dyn_from_i64] and can spill — but
nothing static knows the operands, and a squiggle under every dyn
addition is the false positive this pass exists not to have. *)
memory "dyn arithmetic stays immediate, and an empty program is silent"
"(defn take [x] () (print x))\n\
(defn add2 [a b] () (take (+ a b)))\n\
(defn main [] () (add2 1 2))"
[];
(* ── A declared name does not start with $ ─────────────────────── *)
(* $ marks a type variable in every type position, so a name that starts
with one could not be written where a type goes. *)
let sigil what src =
parse_rejects ("a declared name with a $: " ^ what) src
~needle:"a name does not start with $, which marks a type variable"
in
sigil "defn" "(defn $foo [x i32] i32 (+ x 1))";
sigil "defstruct" "(defstruct $S [a i32])";
sigil "a struct field" "(defstruct S [$a i32])";
sigil "defenum" "(defenum $E [A B])";
sigil "an enum member" "(defenum E [A $B])";
sigil "defonce" "(defonce $g i32 0)";
sigil "defconst" "(defconst $k 3)";
sigil "defdata case" "(defdata D [($C [a i32])])";
sigil "defmacro" "(defmacro $m [x] x)";
sigil "a let binding" "(defn f [] i32 (let [$y 1] y))";
sigil "a dotimes counter" "(defn f [] () (dotimes [$i 3] (println i)))";
sigil "a loop binding" "(defn f [] i32 (loop [$i 0] i))";
sigil "a match bind"
"(defdata D [(C [a i32])]) (defn f [d D] i32 (match d (D.C $x) x))";
sigil "a macro parameter" "(defmacro m [$x] x)";
sigil "a class slot" "(defclass K [$s])";
sigil "a generic's parameter" "(defgeneric area [$s] f64)";
sigil "an fn parameter" "(defn f [] i32 (let [g (fn [$a] $a)] 0))";
sigil "a handler-case binder"
"(defstruct E [n i32]) \
(defn f [] i32 (handler-case 1 [(E [$c] 2)]))";
sigil "a handler-bind binder"
"(defstruct E [n i32]) \
(defn f [] i32 (handler-bind [(E [$c] (println 1))] 1))";
sigil "a :keys name"
"(defstruct P [a i32]) (defn f [p P] i32 (let [{:keys [$a]} p] a))";
sigil "a & tail" "(defn f [xs [3 i32]] i32 (let [[a & $r] xs] a))";
parse_rejects "the $ refusal names the bare spelling"
"(defn $foo [x i32] i32 x)" ~needle:"Name it foo";
(* ── An array literal with nothing outside it naming a type ────── *)
infers "a literal takes the other elements' type" "[(f32 1.0) 2.5]" "[2 f32]";
infers "numbers meet at the wider" "[(u8 1) 256]" "[2 i32]";
infers "an int and a float literal meet at f64" "[1 2.5]" "[2 f64]";
infers "a wide literal makes the array u64" "[1 18446744073709551615]" "[2 u64]";
infers "None takes the other element's Option" "[None (Some 1)]" "[2 (Option i32)]";
infers "a number and a string are a dyn vector" "[10 \"Hi\"]" "dyn";
infers "nil beside a number is a dyn vector" "[nil 1]" "dyn";
infers "two dyns are a typed array of dyn" "[nil nil]" "[2 dyn]";
infers "the names the element type of a mixed literal" "(the [dyn] [1 2.5])" "[2 dyn]";
infers "the with a slice type gives the literal's array type"
"(the [f32] [1 2.5])" "[2 f32]";
(* A struct crosses into dyn as a view, so a struct beside a number is a dyn
vector; a pointer has no dyn form, so it is refused against the first. *)
accepts "a struct beside a number is a dyn vector"
"(defstruct P [x i32]) (defn main [] i32 (let [a [(P 1) 2]] (println a) 0))";
(match checked "(defn main [] i32 (let [x 1 a [(addr x) 2]] 0))" with
| _ -> check "a pointer beside a number is refused" false
| exception Loc.Error d ->
check "elements that cannot become a dyn are refused against the first"
(contains d.Loc.dmsg "expected (Ptr i32), found the integer literal 2"
&& List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg "this array's first element is (Ptr i32)")
d.Loc.notes));
(match checked "(defn g [x $t] i32 (let [a [x 1]] 0))" with
| _ -> check "a type variable beside a literal is refused" false
| exception Loc.Error d ->
check "a type variable beside a literal names the bound and spells $t"
(contains d.Loc.dmsg "{:where (numeric? $t)}"
&& List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg "this array's first element is $t")
d.Loc.notes));
rejects_check "numbers with no common type are refused and the fix named"
"(defn f [x i32 y f32] i32 (let [a [x y]] 0))"
~needle:"elements are i32 and f32, and neither holds every value of the \
other — convert one, as in (f32 x)";
accepts "the conversion that refusal names compiles"
"(defn f [x i32 y f32] i32 (let [a [(f32 x) y]] 0))";
rejects_check "two integer types with no common type are refused"
"(defn f [x i64 y u64] i32 (let [a [x y]] 0))" ~needle:"as in (i64 y)";
accepts "the integer conversion that refusal names compiles"
"(defn f [x i64 y u64] i32 (let [a [x (i64 y)]] 0))";
rejects_check "every element needing a type names the first's refusal"
"(defn main [] i32 (let [a [None None]] 0))"
~needle:"what None is an Option of";
(* ── (max-value T) and (min-value T) ──────────────────────────────── *)
infers "max-value carries its type" "(max-value u16)" "u16";
infers "min-value at a float" "(min-value f32)" "f32";
(match checked "(defn f [x $t] $t (max-value $t))" with
| _ -> check "max-value at an unbounded type variable is refused" false
| exception Loc.Error d ->
check "max-value at an unbounded type variable names the bound and only it"
(contains d.Loc.dmsg "write {:where (numeric? $t)}"
&& not (contains d.Loc.dmsg "Fn")));
infers "two literal if arms meet at the wider" "(if true 1 2.5)" "f64";
infers "two integer if arms stay i32" "(if true 1 2)" "i32";
infers "two literal match arms meet at the wider"
"(match (Some 1) (Some v) 1 None 2.5)" "f64";
accepts "max-value at a type variable the bound admits"
"(defn f [x $t] $t {:where (integer? $t)} (max-value t))";
rejects_check "max-value at a type that is not a number names the bound"
"(defn f [] str (max-value str))"
~needle:"max-value takes a numeric? type, and str is not one";
rejects_check "max-value of a value says it takes a type"
"(defn f [x i32] i32 (max-value x))" ~needle:"max-value takes a type";
accepts "max-of of a slice is the prelude's reduction"
"(defn f [xs [i32]] (Option i32) (max-of xs))";
rejects_check "max-of of a type names max-value"
"(defn f [] u8 (max-of u8))" ~needle:"the largest value of a type is (max-value u8)";
(* ── (the T e) ─────────────────────────────────────────────────── *)
infers "the gives a literal its type" "(the u8 200)" "u8";
infers "the widens as an annotation does" "(the i64 (the i32 1))" "i64";
rejects_check "the does not narrow"
"(defn f [x i64] i32 (the i32 x))" ~needle:"expected i32, found i64";
rejects_check "the refuses a dyn and names the cast"
"(defn f [x dyn] i32 (the i32 x))" ~needle:"write (i32 x) to convert it";
accepts "the cast that refusal names compiles" "(defn f [x dyn] i32 (i32 x))";
rejects_check "the refuses a dyn at str, which a dyn becomes where passed"
"(defn f [x dyn] str (the str x))"
~needle:"a dyn becomes a str where a str is passed";
accepts "a dyn becomes a slice, an array and a struct where passed"
"(defstruct P [x i32]) (defn f [a [const i64] b [2 f32] c P s str] i64 (length a)) \
(defn g [d dyn] i64 (f d d d d))";
rejects_check "a dyn does not become an array of Vecs"
"(defn f [d dyn] [2 (Vec i64)] d)"
~needle:"it holds a Vec, which owns its storage";
rejects_check "a dyn does not become a slice of dyn"
"(defn f [d dyn] [const dyn] d)"
~needle:"[const dyn] does not cross into a written type yet";
rejects_check "the refuses a dyn at bool, which a dyn becomes where passed"
"(defn f [x dyn] bool (the bool x))"
~needle:"a dyn becomes a bool where a bool is passed";
accepts "the bool a dyn becomes where it is returned" "(defn f [x dyn] bool x)";
accepts "the at an Option takes nil" "(defn f [] (Option i32) (the (Option i32) nil))";
parse_rejects "the takes a type and a value" "(defn f [] i32 (the i32))"
~needle:"the is (the TYPE value)";
(* The refusals of a form with no type of its own name the as a way out, and
the spellings they name compile. *)
rejects_check "an empty array literal names the"
"(defn main [] i32 (let [a []] 0))" ~needle:"(the [0 i32] [])";
accepts "the empty array that refusal names compiles"
"(defn main [] i32 (let [a (the [0 i32] [])] (length a)))";
accepts "the None that refusal names compiles"
"(defn main [] i32 (let [a (the (Option i32) None)] 0))";
accepts "the zeroed that refusal names compiles"
"(defn main [] i32 (let [a (the [4 i32] (zeroed))] (at a 0)))";
accepts "the fills that refusal names compile"
"(defn main [] i32 (let [a (the [4 u32] (filled 0xFF)) \
b (the [4 u32] (dead-beef))] 0))";
(* ── A wide literal's follow-ups ──────────────────────────────── *)
parse_rejects "a wide enum member is refused for its range"
"(defenum E [A 0xFFFFFFFFFFFFFFFF B])"
~needle:"the member A of E is 0xFFFFFFFFFFFFFFFF, which does not fit i32";
rejects_check "a wide literal in a dyn global names the u64 cast"
"(defonce big 0xFFFFFFFFFFFFFFFF)"
~needle:"Write (u64 0xFFFFFFFFFFFFFFFF) for the u64";
accepts "the cast the dyn refusal names compiles"
"(defonce big (u64 0xFFFFFFFFFFFFFFFF))";
(* A macro's Form has one integer case; the literal comes back wide all the
same, and is refused where it would have been refused unexpanded. *)
rejects_check "a wide literal through a macro is still wide"
"(defmacro idm [x] x) \
(defn f [] i32 (+ 1 (idm 0xFFFFFFFFFFFFFFFF)))"
~needle:"0xFFFFFFFFFFFFFFFF does not fit in i32";
accepts "a wide literal through a macro is still a u64"
"(defmacro idm [x] x) \
(defn f [] u64 (idm 18446744073709551615))";
accepts "a u64 array with a cast first element"
"(defn main [] i32 (let [a [(u64 1) 18446744073709551615]] 0))";
(* ── Suggestions that compile ─────────────────────────────────── *)
(* A let binding has no type slot, so the refusal names only the spelling
that works. *)
rejects_check "vec-new with no element type names only the type argument"
"(defn f [] i32 (let [v (vec-new)] 0))"
~needle:"as (vec-new i32)";
(match checked "(defn f [] i32 (let [m (map-new)] 0))" with
| _ -> check "map-new with no types is refused" false
| exception Loc.Error d ->
check "map-new's refusal does not suggest a binding type"
(not (contains d.Loc.dmsg "binding")));
(* The near miss is a value, and is suggested without the parentheses that
would make it a refused call. *)
rejects_check "a near miss that is a value says it is written bare"
"(defn f [] i32 (let [a (context-allocator)] 0))"
~needle:"did you mean context/allocator? It is a value and not a function";
accepts "the bare spelling that refusal names compiles"
"(defn f [] i32 (let [a context/allocator] 0))";
rejects_check "a near miss that is a function keeps the plain suggestion"
"(defn foo [] i32 1) (defn f [] i32 (fooo))"
~needle:"did you mean foo?";
(* ── The acceptance program checks end to end ──────────────────── *)
accepts "calc-me.flan type checks"
(In_channel.with_open_bin "../calc-me.flan" In_channel.input_all);
(* ── Return types read off the body ([_]) ──────────────────────── *)
(* What each shape reads as, by the signature the editor is shown. *)
(let sign src name =
match checked src with
| p ->
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
| Some f -> Dev.signature_of_fn f
| None -> "missing")
| exception Loc.Error { Loc.dmsg = m; _ } -> "refused: " ^ m
in
let reads_as what src name want =
let got = sign src name in
if got <> want then begin
incr failures;
Printf.printf "FAIL %s\n got: %s\n wanted: %s\n" what got want
end
in
let main = "\n(defn main [] ())" in
reads_as "an inferred return is the body's type"
("(defn f [x i32] _ (+ x 1))" ^ main) "f" "f [i32] i32";
reads_as "an inferred return follows a call to another"
("(defn g [x f64] _ (f x))\n(defn f [x f64] _ (* x 2.0))" ^ main) "g" "g [f64] f64";
reads_as "a literal return takes the other exit's type"
("(defn f [c bool] _ (when c (return 1)) 2.5)" ^ main) "f" "f [bool] f64";
reads_as "a literal return takes a parameter's type"
("(defn f [x i64] _ (when (< x 0) (return 0)) x)" ^ main) "f" "f [i64] i64";
reads_as "a literal return takes an f32"
("(defn f [c bool x f32] _ (when c (return 1)) x)" ^ main) "f" "f [bool f32] f32";
reads_as "a dyn exit beside a literal gives dyn"
("(defn f [d dyn c bool] _ (when c (return d)) 1)" ^ main) "f" "f [dyn bool] dyn";
reads_as "a literal before the typed exit still takes its type"
("(defn f [x i16] _ (when (< x 0) (return x)) 0)" ^ main) "f" "f [i16] i16";
(* Arms and exits meet at one join, whichever comes first. *)
List.iter
(fun (what, sg, body, want) ->
reads_as what ("(defn f " ^ sg ^ " _ " ^ body ^ ")" ^ main) "f" want)
[ ("if i32 then i64", "[c bool x i32 y i64]", "(if c x y)", "f [bool i32 i64] i64");
("if i64 then i32", "[c bool x i32 y i64]", "(if c y x)", "f [bool i32 i64] i64");
("if f32 then f64", "[c bool x f32 y f64]", "(if c x y)", "f [bool f32 f64] f64");
("if u8 then i32", "[c bool x u8 y i32]", "(if c x y)", "f [bool u8 i32] i32");
("if dyn then i8", "[c bool x i8 d dyn]", "(if c d x)", "f [bool i8 dyn] dyn");
("if i8 then dyn", "[c bool x i8 d dyn]", "(if c x d)", "f [bool i8 dyn] dyn");
("if i64 then dyn", "[c bool x i64 d dyn]", "(if c x d)", "f [bool i64 dyn] dyn");
("if i8 then a literal", "[c bool x i8]", "(if c x 1)", "f [bool i8] i8");
("exits i32 then i64", "[c bool x i32 y i64]", "(when c (return x)) y", "f [bool i32 i64] i64");
("exits i64 then i32", "[c bool x i32 y i64]", "(when c (return y)) x", "f [bool i32 i64] i64");
("a return inside the last form, in source order", "[c bool x i64 y i32]",
"(if c x (return y))", "f [bool i64 i32] i64");
("exits writable then read-only slice", "[c bool a [u8] b [const u8]]",
"(when c (return a)) b", "f [bool [u8] [const u8]] [const u8]");
("exits read-only then writable slice", "[c bool a [u8] b [const u8]]",
"(when c (return b)) a", "f [bool [u8] [const u8]] [const u8]");
("exits writable then read-only pointer", "[c bool a (Ptr i32) b (Ptr const i32)]",
"(when c (return a)) b", "f [bool (Ptr i32) (Ptr const i32)] (Ptr const i32)");
("exits dyn then a literal", "[c bool d dyn]", "(when c (return d)) 1", "f [bool dyn] dyn");
("exits nil then a literal", "[c bool]", "(when c (return nil)) 1", "f [bool] dyn") ];
(* A match's arms meet at the same join, in either order. *)
List.iter
(fun (what, sg, body, want) ->
reads_as what ("(defn f " ^ sg ^ " _ " ^ body ^ ")" ^ main) "f" want)
[ ("match i32 then i64", "[o (Option i32) x i32 y i64]",
"(match o (Some q) x None y)", "f [(Option i32) i32 i64] i64");
("match i64 then i32", "[o (Option i32) x i32 y i64]",
"(match o (Some q) y None x)", "f [(Option i32) i32 i64] i64");
("match i8 then dyn", "[o (Option i32) x i8 y dyn]",
"(match o (Some q) x None y)", "f [(Option i32) i8 dyn] dyn");
("match writable then read-only", "[o (Option i32) x [u8] y [const u8]]",
"(match o (Some q) x None y)", "f [(Option i32) [u8] [const u8]] [const u8]");
("match literal arms, i32 then i64", "[n i32 x i32 y i64]",
"(match n 1 x _ y)", "f [i32 i32 i64] i64");
("match a typed arm and a literal arm", "[o (Option i32) x i8]",
"(match o (Some q) x None 1)", "f [(Option i32) i8] i8");
("match an arm that needs the join", "[o (Option i32) d dyn]",
"(match o (Some q) d None nil)", "f [(Option i32) dyn] dyn") ];
reads_as "an f32 exit and a float literal"
("(defn f [x f32] _ (when (< x 0.0) (return x)) 0.0)" ^ main) "f" "f [f32] f32";
reads_as "a function that calls itself and gives nothing is ()"
("(defn f [n i32] _ (when (> n 0) (println n) (f (- n 1))))" ^ main) "f" "f [i32] ()";
reads_as "two that call each other and give nothing are ()"
("(defn ev [n i32] _ (when (> n 0) (od (- n 1))))\n\
(defn od [n i32] _ (when (> n 0) (ev (- n 1))))" ^ main) "od" "od [i32] ()";
reads_as "a dyn body gives dyn" ("(defn f [x] _ x)" ^ main) "f" "f [dyn] dyn";
reads_as "no value gives ()" ("(defn f [x i32] _ (println x))" ^ main) "f" "f [i32] ()";
reads_as "an empty body gives ()" ("(defn f [] _)" ^ main) "f" "f [] ()";
reads_as "a return that never falls off the end"
("(defn f [x i32] _ (if (< x 0) (return 0) x))" ^ main) "f" "f [i32] i32";
reads_as "a local that shares a name is not a call"
("(defn f [x i32] _ (let [f 2] (+ x f)))" ^ main) "f" "f [i32] i32";
reads_as "defn- reads it too" ("(defn- f [x i32] _ x)" ^ main) "f" "f [i32] i32");
rejects_check "an inferred function that calls itself"
~needle:"fact calls itself, so its return type cannot be read off its body"
"(defn fact [n i32] _ (if (< n 2) 1 (* n (fact (- n 1)))))\n(defn main [] ())";
rejects_check "inferred functions that call each other, named in order"
~needle:"ev and od call each other (ev → od → ev), so neither"
"(defn top [n i32] _ (ev n))\n\
(defn ev [n i32] _ (if (= n 0) true (od (- n 1))))\n\
(defn od [n i32] _ (if (= n 0) false (ev (- n 1))))\n\
(defn main [] ())";
rejects_check "a cycle of three is named whole"
~needle:"a and b and c call each other (a → b → c → a), so none"
"(defn a [n i32] _ (+ 1 (b n)))\n(defn b [n i32] _ (+ 1 (c n)))\n\
(defn c [n i32] _ (+ 1 (a n)))\n(defn main [] ())";
accepts "a written return type breaks the cycle"
"(defn ev [n i32] bool (if (= n 0) true (od (- n 1))))\n\
(defn od [n i32] _ (if (= n 0) false (ev (- n 1))))\n\
(defn main [] ())";
rejects_check "a body error behind an inferred return is its own"
~needle:"expected i32, found str"
"(defn f [x i32] _ (+ x \"a\"))\n(defn g [x i32] _ (f x))\n(defn main [] ())";
rejects_check "no value on one path and a value on another"
~needle:"f gives no value here and i32 on another path"
"(defn f [x i32] _ (when (> x 0) (return 1)) (println 2))\n(defn main [] ())";
(* Every error in the file is still reported, a [_] body's included, and
a call to a [_] function whose body failed adds none of its own. *)
(let count src =
match program src |> Check.program_all with
| _ -> 0
| exception Loc.Error _ -> 1
| exception Loc.Errors ds -> List.length ds
in
let errors what src n =
let got = count src in
if got <> n then begin
incr failures;
Printf.printf "FAIL %s: %d errors, wanted %d\n" what got n
end
in
errors "a _ body's error does not hide the others"
"(defn bad1 [x i32] _ (+ x \"s\"))\n\
(defn bad2 [x i32] i32 (+ x \"t\"))\n\
(defn bad3 [x i32] i32 (undefined-thing x))\n(defn main [] i32 0)" 3;
errors "every error in one _ body"
"(defn bad1 [x i32] _ (+ x \"s\") (foo) (bar))\n(defn main [] i32 0)" 3;
errors "a call to a failed _ body adds nothing"
"(defn bad1 [x i32] _ (+ x \"s\"))\n(defn g [x i32] _ (bad1 x))\n\
(defn h [x i32] i32 (+ 1 (g x)))\n\
(defn main [] i32 (println (bad1 1)) 0)" 1;
errors "a refused loop does not hide the others"
"(defn a [n i32] _ (if (> n 0) (b (- n 1)) 5))\n(defn b [n i32] _ (a n))\n\
(defn z [n i32] i32 (+ n \"q\"))\n(defn main [] i32 (a 3) 0)" 2;
errors "a refused exit does not hide the others"
"(defn u [c bool] _ (when c (return)) 1)\n\
(defn z [n i32] i32 (+ n \"q\"))\n(defn main [] i32 (u true) 0)" 2);
(* Exits meet as an if's arms do, and are refused where those are. *)
rejects_check "a struct exit and a literal exit"
~needle:"expected Pt, found the integer literal 1"
"(defstruct Pt [x i32 y i32])\n\
(defn m [c bool] _ (when c (return (Pt {.x 1 .y 2}))) 1)\n(defn main [] ())";
rejects_check "no value on one exit and a value on the other"
~needle:"u gives no value here and i32 on another path"
"(defn u [c bool] _ (when c (return)) 1)\n(defn main [] ())";
rejects_check "an i32 exit and a u32 exit, which neither widens into"
~needle:"expected i32, found u32"
"(defn f [x i32 y u32 c bool] _ (when c (return x)) y)\n(defn main [] ())";
rejects_check "a u32 exit and an i32 exit, the other order"
~needle:"expected u32, found i32"
"(defn f [x i32 y u32 c bool] _ (when c (return y)) x)\n(defn main [] ())";
rejects_check "an if over i32 and u32, either order"
~needle:"expected i32, found u32"
"(defn f [x i32 y u32 c bool] i32 (let [v (if c x y)] 0))\n(defn main [] ())";
rejects_check "a literal that does not fit the typed exit"
~needle:"300 does not fit in u8"
"(defn f [c bool] _ (when c (return 300)) (u8 2))\n(defn main [] ())";
rejects_check "a string exit and a number exit"
~needle:"expected str, found the integer literal 1"
"(defn f [c bool] _ (when c (return \"s\")) 1)\n(defn main [] ())";
rejects_check "a constant computed by a _ function, as by a written one"
~needle:"a constant's value must be a compile-time constant — the constant K is computed"
"(defn five [] _ 5)\n(defconst K (five))\n(defn main [] i32 0)";
(* An else arm refused on its own terms is not also blamed for a type it
was never going to have. *)
(let n =
match
program "(defn g [c bool a i32 b i64] i64 (let [v (if c a (+ b (nope2 1)))] v))\n\
(defn main [] i32 0)"
|> Check.program_all
with
| _ -> 0
| exception Loc.Error _ -> 1
| exception Loc.Errors ds -> List.length ds
in
if n <> 1 then begin
incr failures;
Printf.printf "FAIL an else arm's own error alone: %d errors\n" n
end);
(* An arm that needs the other's type, and is refused at it too, says why
at that type — not that it has no type on its own. *)
rejects_check "a bare struct else arm with an unknown name in it"
~needle:"unknown name q2"
"(defstruct P [x i32 y i32])\n\
(defn b3 [c bool p P] i32 (let [v (if c p {.x q2 .y 2})] (.y v)))\n\
(defn main [] i32 0)";
rejects_check "a bare struct match arm with an unknown name in it"
~needle:"unknown name q2"
"(defstruct P [x i32 y i32])\n\
(defn a3 [o (Option i32) p P] i32 \
(let [v (match o (Some q) p None {.x q2 .y 2})] (.y v)))\n\
(defn main [] i32 0)";
(* A match arm that does not meet the others is refused at its value. *)
(match
checked
"(defn m4 [o (Option i32) x i8] i32 \
(let [v (match o (Some q) x None (do (println \"a\") \"lit\"))] 0))\n\
(defn main [] i32 0)"
with
| _ -> check "a match arm of another type is refused" false
| exception Loc.Error { Loc.dloc; dmsg; _ } ->
check "a match arm of another type is refused at its value"
(dloc.Loc.col = 87 && contains dmsg "expected i8, found str"));
(* Nested arms that meet at a wider type are checked once each, not once
per level above them — when the else arm fits the then arm's type, and
when it is wider, so that every level's first attempt is refused. *)
(let nest kind depth =
let rec go k e =
if k = 0 then e
else
go (k - 1)
(match kind with
| `If -> Printf.sprintf "(if c a (+ (idg b) (i32 %s)))" e
| `Match ->
Printf.sprintf "(match o (Some q) a None (+ (idg b) (i32 %s)))" e
| `If_wider -> Printf.sprintf "(if c b (+ a (i64 %s)))" e
| `Match_wider ->
Printf.sprintf "(match o (Some q) b None (+ a (i64 %s)))" e)
in
go depth "(i32 b)"
in
let structs =
String.concat ""
(List.init 300 (Printf.sprintf "(defstruct S%d [a i32 b i64])\n"))
in
List.iter
(fun (kind, sg, what) ->
let src =
"(defn idg [x $t] $t x)\n" ^ structs
^ "(defn f " ^ sg ^ " i64 (let [v " ^ nest kind 20 ^ "] v))\n\
(defn g " ^ sg ^ " _ " ^ nest kind 20 ^ ")"
in
let t0 = Unix.gettimeofday () in
match checked src with
| p ->
check (what ^ " twenty deep checks fast")
(Unix.gettimeofday () -. t0 < 3.0);
check (what ^ " twenty deep meets at i64")
(List.exists
(fun (f : Tast.fn) ->
f.Tast.name = "g" && Types.equal f.Tast.ret (Types.Int Types.I64))
p.Tast.fns)
| exception Loc.Error { Loc.dmsg; _ } ->
check (what ^ " twenty deep checks: " ^ dmsg) false)
[ (`If, "[c bool a i64 b i32]", "an if");
(`Match, "[o (Option i32) a i64 b i32]", "a match");
(`If_wider, "[c bool a i64 b i32]", "an if whose else arm is wider");
(`Match_wider, "[o (Option i32) a i64 b i32]",
"a match whose last arm is wider") ]);
(* An arm is asked the other arm's type first, so a value that takes its
type from what is asked — nil, (Some 3), arithmetic — gets it, and the
two meet the same way whichever is written first. *)
(let reads_as_top what src name want =
let got =
match checked src with
| p ->
(match List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name) p.Tast.fns with
| Some f -> Dev.signature_of_fn f
| None -> "missing")
| exception Loc.Error { Loc.dmsg = m; _ } -> "refused: " ^ m
in
if got <> want then begin
incr failures;
Printf.printf "FAIL %s\n got: %s\n wanted: %s\n" what got want
end
in
List.iter
(fun (what, sg, body, want) ->
reads_as_top what ("(defn f " ^ sg ^ " _ " ^ body ^ ")\n(defn main [] ())") "f" want)
[ ("nil beside an Option", "[c bool p (Option i64)]", "(if c p nil)",
"f [bool (Option i64)] (Option i64)");
("nil first beside an Option", "[c bool p (Option i64)]", "(if c nil p)",
"f [bool (Option i64)] (Option i64)");
("(Some 3) beside an Option", "[c bool p (Option i64)]", "(if c p (Some 3))",
"f [bool (Option i64)] (Option i64)");
("float arithmetic beside an f32", "[c bool p f32]", "(if c p (* 2.0 3.0))",
"f [bool f32] f32");
("a do ending in a literal beside a u8", "[c bool p u8]",
"(if c p (do (println 1) 7))", "f [bool u8] u8");
("a match's nil arm first", "[o (Option i32) p (Option i64)]",
"(match o None nil (Some z) p)", "f [(Option i32) (Option i64)] (Option i64)") ]);
(* Thirty deep, each level's first try refused: a chain of matches whose
last arm is wider, and sums nested in their second operands. *)
List.iter
(fun (what, src) ->
let t0 = Unix.gettimeofday () in
(match checked src with
| _ -> ()
| exception Loc.Error { Loc.dmsg; _ } -> check (what ^ ": " ^ dmsg) false);
check (what ^ " checks fast") (Unix.gettimeofday () -. t0 < 3.0))
(let nest f = let rec go k e = if k = 0 then e else go (k - 1) (f e) in go 30 in
[ ("thirty matches whose last arm is wider",
"(defn f [o (Option i32) a i64 b i32] i64 (let [v "
^ nest (Printf.sprintf "(match o (Some q) (+ q 1) None (+ b %s))") "a"
^ "] v))");
("thirty matches with the narrow arm last",
"(defn f [o (Option i32) a i64 b i32] i64 (let [v "
^ nest (Printf.sprintf "(match o None b (Some q) (+ b %s))") "a"
^ "] v))");
("thirty matches over a dyn at the bottom",
"(defn f [o (Option i32) d dyn b i32] dyn (let [v "
^ nest (Printf.sprintf "(match o (Some q) q None (+ b %s))") "d"
^ "] v))");
("thirty sums nested in their second operands",
"(defn f [a i64 b i32] i64 (let [v "
^ nest (Printf.sprintf "(+ b %s)") "a" ^ "] v))") ]);
rejects_check "an Option compared with a dyn, as before"
~needle:"(Option i64) does not cross into dyn yet"
"(defn eqo [b (Option i64) d dyn] bool (= b d))\n(defn main [] ())";
rejects_check "nil beside a string, as before"
~needle:"str"
"(defn f [c bool s str] str (let [v (if c s nil)] v))\n(defn main [] ())";
rejects_check "an else arm's own error is the one reported"
~needle:"unknown function nope2"
"(defn g [c bool a i32 b i64] i64 (let [v (if c a (+ b (nope2 1)))] v))\n\
(defn main [] i32 0)";
rejects_check "some under an inferred return"
~needle:"Write the return type: (Option T)"
"(defn f [o (Option i32)] _ (+ 1 (some o)))\n(defn main [] ())";
rejects_check "_ in a generic's return slot" ~needle:"f is generic, and _"
"(defn f [x $t] _ x)\n(defn main [] ())";
rejects_check "_ as a parameter type"
~needle:"_ here asks for x's type to be read off a body"
"(defn f [x _] i32 3)\n(defn main [] ())";
rejects_check "_ as a field type" ~needle:"only a defn's return slot"
"(defstruct P [x _])\n(defn main [] ())";
rejects_check "_ in a function type" ~needle:"only a defn's return slot"
"(defn main [] () (let [f (the (Fn [i32] _) (fn [x] x))] (f 1)))";
rejects_check "_ in a declare" ~needle:"only a defn's return slot"
"(declare cabs [x i32] _ \"abs\")\n(defn main [] ())";
parse_rejects "_ in a defgeneric's return slot"
~needle:"defgeneric's methods each have their own"
"(defgeneric area [s] _)";
Test_support.report ()
Reference in New Issue View Git Blame Copy Permalink