Joseph Ferano
41b60d2e4a
Loc.Errors is a second exception, and the handlers in the session and the daemon name only Loc.Error — so a list reaching them is an unhandled exception and a dead session, which is the one thing the dev loop exists to prevent. A flag on the function the session already calls left that one label away from happening. Parse.program_all and Check.program_all are separate names, so the session's call site has to be edited by a person for its behaviour to change, and the guarantee stops being a default argument. Placeless diagnostics now sort last rather than first. A wrong main signature is raised against unknown, which is line 0, and sorting on the number alone put it above every error that can actually be clicked. It is a real error and it is not anywhere, so it goes after the ones that are.
1742 lines
87 KiB
OCaml
1742 lines
87 KiB
OCaml
(* 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 = ref 0
|
|
|
|
let check name cond =
|
|
if not cond then begin
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n" name
|
|
end
|
|
|
|
let contains hay needle =
|
|
let n = String.length needle and h = String.length hay in
|
|
let rec go i = i + n <= h && (String.sub hay i n = needle || go (i + 1)) in
|
|
n = 0 || go 0
|
|
|
|
(* 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";
|
|
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 "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);
|
|
|
|
if !failures = 0 then print_endline "reader: all tests passed"
|
|
else begin
|
|
Printf.printf "\n%d failure(s)\n" !failures;
|
|
exit 1
|
|
end
|
|
|
|
(* ═══ 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);
|
|
|
|
(* 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 *)
|
|
(match (parse1 "(and a b)").e with
|
|
| If (_, _, Some { e = Var "false"; _ }) -> ()
|
|
| _ -> check "and short-circuits" false);
|
|
(match (parse1 "(or a b)").e with
|
|
| If (_, { e = Var "true"; _ }, Some _) -> ()
|
|
| _ -> 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", { e = Int 10L; _ }, [ _ ]) -> ()
|
|
| _ -> check "dotimes binds" 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 ─────────── *)
|
|
let ty src =
|
|
match parse_decl (Printf.sprintf "(defn f [x %s] ())" src) with
|
|
| { d = Defn { params = [ { fty; _ } ]; _ }; _ } -> fty.t
|
|
| _ -> failwith "bad type test"
|
|
in
|
|
(match ty "[u8]" with Tslice _ -> () | _ -> check "[T] is a slice" 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);
|
|
(match ty "{string i32}" with
|
|
| Tmap (_, _) -> () | _ -> check "{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 _; params = [ _ ]; 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 "(defvar grid [4 u32])").d with
|
|
| Defvar ("grid", Some _, Zeroed) -> ()
|
|
| _ -> check "defvar is ZII" false);
|
|
(match (parse_decl "(defvar buf [4 u8] uninit)").d with
|
|
| Defvar (_, _, Uninit) -> () | _ -> check "defvar uninit opts out" false);
|
|
(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 { t = Tname "Form"; _ }, Tname "Form" -> ()
|
|
| _ -> check "defmacro is [Form] -> Form" false)
|
|
| _ -> check "defmacro parses as a defn" false);
|
|
|
|
(* One parameter, the forms at the call site. Two is not an arity mistake, it
|
|
is a misunderstanding of what a macro takes, and it gets its own reason. *)
|
|
parse_rejects "defmacro with two parameters" "(defmacro m [a b] a)"
|
|
~needle:"a macro takes one parameter";
|
|
(* 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:"expected a name";
|
|
parse_rejects "defmacro in expression position" "(defn f [] () (defmacro m [] 1))"
|
|
~needle:"top-level declaration";
|
|
|
|
(* 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 not counted -- not by the reader, deliberately, and not here,
|
|
which is why the inner one is refused by name rather than given a meaning
|
|
nobody chose. *)
|
|
parse_rejects "a quasiquote inside a quasiquote" "(defn f [] Form `(a `(b)))"
|
|
~needle:"quasiquote inside a quasiquote";
|
|
(* 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";
|
|
|
|
(* ── 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 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" ];
|
|
|
|
if !failures = 0 then print_endline "parse: all tests passed"
|
|
else begin
|
|
Printf.printf "\n%d failure(s)\n" !failures;
|
|
exit 1
|
|
end
|
|
|
|
(* ═══ 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 type a defconst's value infers to, as the checker prints it. Enough to
|
|
pin down literal defaulting and every primitive's result. *)
|
|
let infers name src expected =
|
|
match checked (Printf.sprintf "(defconst probe %s)" src) with
|
|
| p ->
|
|
(match List.find_opt (fun (g : Tast.global) -> g.gname = "probe") p.globals with
|
|
| Some g ->
|
|
let got = Types.to_string g.gty 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
|
|
| None -> incr failures; Printf.printf "FAIL %s: no probe\n" name)
|
|
| 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
|
|
| _ -> ())
|
|
|
|
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\"" "string";
|
|
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]";
|
|
infers "array of a struct" "(array 2 i32)" "[2 i32]";
|
|
infers "array of an array" "(array 2 [3 u8])" "[2 [3 u8]]";
|
|
infers "bytes of a string" "(bytes \"hi\")" "[u8]";
|
|
infers "len is i32" "(len (bytes \"hi\"))" "i32";
|
|
infers "slice of a slice" "(slice (bytes \"hi\") 0 1)" "[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";
|
|
|
|
(* ── 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:"what None is an Option of";
|
|
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";
|
|
|
|
(* ── 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 stirng] ())"
|
|
~needle:"did you mean string?";
|
|
rejects_check "a mistyped struct"
|
|
"(defstruct Cursor [x i32]) (defn f [c Curser] ())"
|
|
~needle:"did you mean Cursor?";
|
|
(* Nothing close: the type-variable rule still applies, and still names the
|
|
milestone. *)
|
|
rejects_check "a real type variable" "(defn f [x t] ())"
|
|
~needle:"milestone 5";
|
|
rejects_check "an unknown concrete type" "(defn f [x Widget] ())"
|
|
~needle:"unknown type Widget";
|
|
|
|
(* ── 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 = "(defvar 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"
|
|
"(defvar 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))";
|
|
|
|
(* ── 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";
|
|
(* The old spelling is refused rather than quietly accepted, and the refusal
|
|
names the new one. Two accepted spellings is how two spellings become
|
|
permanent, and the colon is wanted for keys. *)
|
|
rejects_check "a field label written with a colon"
|
|
(cursor ^ "(defn f [s [u8]] Cursor (Cursor {:src s}))")
|
|
~needle:"a field label is written .src, not :src";
|
|
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:"parameters are not assignable";
|
|
rejects_check "a constant is not assignable"
|
|
"(defconst k 1) (defn f [] () (set k 2))" ~needle:"is a constant";
|
|
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";
|
|
|
|
(* ── 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 i32] 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";
|
|
rejects_check "defined twice" "(defn f [] ()) (defn f [] ())"
|
|
~needle:"defined twice";
|
|
accepts "main with no parameters and no return" "(defn main [] ())";
|
|
accepts "main with argv and a status" "(defn main [args [string]] 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";
|
|
|
|
(* ── Unconstrained operators, and everything past milestone 2 ──── *)
|
|
rejects_check "no built-in = on strings"
|
|
"(defn f [] bool (= \"a\" \"b\"))" ~needle:"no built-in comparison";
|
|
(* (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";
|
|
(* {K V} resolves now — it is the Map type spelling, and the only one, since
|
|
a bare map form in expression position is a struct literal's field list.
|
|
What is still refused 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:"milestone 6";
|
|
rejects_check "try is milestone 6" "(defn f [] i32 (try 1))"
|
|
~needle:"milestone 6";
|
|
(* 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)))";
|
|
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. *)
|
|
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";
|
|
(* 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 and against nothing else. *)
|
|
rejects_check "a keyword needs an enum"
|
|
"(defn g [x i32] ()) (defn f [] () (g :space))" ~needle:"is expected here";
|
|
rejects_check "a keyword with no expectation"
|
|
"(defn f [] () (print (i64 :space)))" ~needle:"no keyword type";
|
|
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";
|
|
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"
|
|
"(defvar x i32 1) (defvar x i32 2)" ~needle:"defined twice";
|
|
rejects_check "a constant shadowing a variable"
|
|
"(defconst c 1) (defvar c i32 2)" ~needle:"defined twice";
|
|
rejects_check "a function and a global"
|
|
"(defn item [] i32 1) (defvar 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";
|
|
(* 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" "(defvar a [4 u32]) (defn f [] u32 (let [i 2] (at a (u32 i))))";
|
|
rejects_check "an i64 index"
|
|
"(defvar 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 "type variables are milestone 5" "(defn f [x a] ())"
|
|
~needle:"milestone 5";
|
|
(* 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"
|
|
"(defvar 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"
|
|
"(defvar grid [rows i32]) (defconst rows 8)";
|
|
accepts "constants defined out of order"
|
|
"(defconst a (+ b 1)) (defconst b 1)";
|
|
accepts "an untyped constant from a later function"
|
|
"(defconst k (g)) (defn g [] u8 1)";
|
|
rejects_check "a genuinely unknown constant still reports itself"
|
|
"(defconst a (+ nope 1))" ~needle:"unknown name nope";
|
|
|
|
(* ── Conditions, spec-conditions.md §1 and §2 ──────────────────── *)
|
|
|
|
accepts "handler-bind over a struct condition"
|
|
"(defstruct C [id i32]) (defvar 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 is lifted into a function of its own, so the establishing
|
|
function's locals are not there. Capturing them is a closure, which is
|
|
milestone 5 — until then it is refused for the reason it is refused for
|
|
rather than as an unknown name. *)
|
|
rejects_check "a handler capturing a 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 see 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 [] () (set (get m 1) 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 string";
|
|
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 string";
|
|
(* §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")
|
|
[ "handler-case", "(defn f [] () (handler-case 1))";
|
|
"find-restart", "(defn f [] () (find-restart 'skip))";
|
|
"compute-restarts", "(defn f [] () (compute-restarts))" ];
|
|
|
|
(* ── 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)))");
|
|
|
|
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 field name with no pattern before it"
|
|
(pt ^ "(defn f [p Point] i32 (let [{.x} p] 0))")
|
|
~needle:"has no .field";
|
|
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 (len r))))";
|
|
accepts "& rest taking an empty tail"
|
|
"(defn f [] i32 (let [xs [1 2] [a b & r] xs] (+ a (+ b (len 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 a runtime value";
|
|
rejects_check "an array pattern over a slice, even with & rest"
|
|
"(defn f [s [i32]] i32 (let [[a & r] s] (+ a (len r))))"
|
|
~needle:"a slice's length is a runtime value";
|
|
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] (len 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:"a pattern binds only in let")
|
|
[ "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 ────────────────────────────────────────── *)
|
|
|
|
(* Not shipped, and refused twice over because there are two ways to write it
|
|
and they fail in different files. Both now say the same thing, which is the
|
|
point: the lowering is not what is missing — a keyword has no case in
|
|
[Ast.pattern], and [lib/load.ml] matches that type exhaustively. *)
|
|
rejects_check "match over an enum, members written as keywords"
|
|
"(defenum K [lo 0 hi 1])\n(defn f [k K] i32 (match k :lo 1 :hi 2))"
|
|
~needle:"is not implemented as a pattern";
|
|
rejects_check "match over an enum, members written as names"
|
|
"(defenum K [lo 0 hi 1])\n(defn f [k K] i32 (match k lo 1 hi 2))"
|
|
~needle:"match over the enum K is not implemented";
|
|
(* The old message blamed milestone 2, which was never the reason, and the
|
|
milestone has since arrived: match now works over a declared union as
|
|
well, so the message names both subjects and no milestone. *)
|
|
rejects_check "match over something that is neither"
|
|
"(defn f [n i32] i32 (match n _ 2))"
|
|
~needle:"match works on an Option or a union, not on i32";
|
|
(* 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:"a pattern binds only in let";
|
|
|
|
(* 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";
|
|
|
|
(* ── 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"
|
|
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_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_enums ~taken ~bound_syms:[]
|
|
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 string] i32 \"name_length\")";
|
|
emits "a pointer parameter"
|
|
"(declare-c count-at [values (Ptr 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 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 "name-of" "returns char *";
|
|
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));
|
|
|
|
(* 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 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 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 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
|
|
= []);
|
|
|
|
(* 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 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]) (defvar 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]) (defvar 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 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));
|
|
|
|
(* 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 ]));
|
|
|
|
(* 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);
|
|
|
|
(* ── 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);
|
|
|
|
if !failures = 0 then print_endline "all tests passed"
|
|
else begin
|
|
Printf.printf "\n%d failure(s)\n" !failures;
|
|
exit 1
|
|
end
|