Joseph Ferano
cb757868b4
render.ml's output is parsed by emacs/flan-inspect.el, which hard-codes the colon when it reads a field out of a rendered struct. Moving the printer on its own would break inspection in the dev loop without breaking a test that says so, so the printer waits and moves with its reader, in the Emacs lane. The sweep could not tell a rendered *expectation* from a Flan *source* snippet -- both are strings in a test -- so it converted both. The suite named every one it got wrong, and those are back. emacs/test-flan-dev.el:415 is the one edit inside emacs/: Flan source sent to the daemon for eval, which the parser now refuses in the old spelling. One label, in a fixture.
1095 lines
54 KiB
OCaml
1095 lines
54 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, 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 (_, 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)]";
|
|
|
|
(* 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, _) ->
|
|
check "unclosed reports opening loc" (loc.line = 1 && loc.col = 1));
|
|
|
|
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 (_, 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);
|
|
|
|
(match (parse1 "(unless c a)").e with
|
|
| If ({ e = Call ({ e = Var "not"; _ }, [ _ ]); _ }, _, None) -> ()
|
|
| _ -> check "unless -> if(not)" false);
|
|
|
|
(match (parse1 "(until c a)").e with
|
|
| While ({ 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 ("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);
|
|
(* An omitted return type means Unit — the body must not be eaten as a type *)
|
|
(match (parse_decl "(defn f [x i32] (g x))").d with
|
|
| Defn { ret = None; fbody = [ _ ]; _ } -> ()
|
|
| _ -> check "defn without return type" 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: the front half is here, the expander is not ───────── *)
|
|
(* Was "unknown top-level form (defmacro ...)" — refused, but not by name and
|
|
with no reason, which is the hole the house rule had at the top level. *)
|
|
parse_rejects "defmacro declaration" "(defmacro m [x] x)"
|
|
~needle:"not expanded";
|
|
(* Shape and feature are separate mistakes and get 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 reader now hands these three to the parser, so each says what is
|
|
actually wrong rather than arriving at the checker as an unknown name. *)
|
|
parse_rejects "quasiquote in a function" "(defn f [] `(a b))"
|
|
~needle:"not expanded";
|
|
(* 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";
|
|
parse_rejects "gensym outside a macro" "(defn f [] (gensym))"
|
|
~needle:"only meaningful inside a macro body";
|
|
|
|
(* ── 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)";
|
|
|
|
(* ── The corpus parses ─────────────────────────────────────────── *)
|
|
List.iter
|
|
(fun path ->
|
|
match read_file path |> Parse.program with
|
|
| _ -> ()
|
|
| exception Loc.Error (loc, 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 / body ambiguity ═════════════════════════════ *)
|
|
(* (Option f64) and (Some 1) are the same s-expression shape. Which one is a
|
|
return type is decided by the set of names that are actually types, not by
|
|
capitalisation — otherwise a body starting with a constructor call gets
|
|
silently eaten as a return type. *)
|
|
|
|
(* 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 "known type ctor is a return type"
|
|
(ret_and_body "option" "(defn f [] (Option f64) (g))" = (true, 1));
|
|
|
|
check "value ctor is NOT a return type"
|
|
(ret_and_body "some" "(defn f [] (Some 1) (bar))" = (false, 2));
|
|
|
|
check "user struct is a return type"
|
|
(ret_and_body "user"
|
|
"(defstruct Cursor [pos i32]) (defn f [] Cursor (g))" = (true, 1));
|
|
|
|
(* Order-independent: the type is declared after the function that returns it *)
|
|
check "type declared later is still known"
|
|
(ret_and_body "later"
|
|
"(defn f [] Cursor (g)) (defstruct Cursor [pos i32])" = (true, 1));
|
|
|
|
check "unknown capitalised head is a body form"
|
|
(ret_and_body "unknown" "(defn f [] (Nope 1) (bar))" = (false, 2));
|
|
|
|
()
|
|
|
|
(* ── 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, 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, 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 (_, 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]]";
|
|
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";
|
|
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";
|
|
rejects_check "Map is milestone 6" "(defn f [x {string i32}])"
|
|
~needle:"milestone 6";
|
|
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; what is still rejected is a defer that
|
|
is not a top-level form, because it would run at function exit rather than
|
|
at the exit of the block it was written in. *)
|
|
rejects_check "defer must be top-level"
|
|
"(defn f [] (let [x 1] (defer (g))))" ~needle:"top-level";
|
|
(* 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";
|
|
rejects_check "fn values are milestone 5" "(defn f [] (fn [x] x))"
|
|
~needle:"milestone 5";
|
|
rejects_check "type variables are milestone 5" "(defn f [x a])"
|
|
~needle:"milestone 5";
|
|
rejects_check "a function name as a value is milestone 5"
|
|
"(defn g []) (defn f [] i32 g)" ~needle:"milestone 5";
|
|
|
|
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. An Option
|
|
still gets that answer, and still should. *)
|
|
rejects_check "match over something that is neither"
|
|
"(defn f [n i32] i32 (match n _ 2))"
|
|
~needle:"match works on an Option at milestone 2, 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";
|
|
|
|
(* ── 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
|