Joseph Ferano
18db822095
spec-conditions.md §2. The same lookup as signal, and the difference is entirely what happens when the walk ends: signal returns Unit and the signalling function carries on, error has type Never and the program stops. Only a transfer gets past it, so emit puts a guard after the call and then unreachable - and flan_error cannot be marked noreturn for the same reason, it does return, on exactly one path. Being Never is what lets it stand where a value was expected, which is the fall-through shape §1's load-texture example needs and the reason it is worth having before the break loop rather than after. An unhandled one names the condition on stderr and dies the way every other trap does; flan_error is where the dev-build break loop will go. The two spellings share one AST and IR node with a kind beside them, the same shape Ast.unwrap already uses for some and try, because they differ in one decision and nothing else. test/programs/error.flan is the unhandled case, asserted on the exit code and the reason rather than through the outputs table, which only has room for a program that exits 0.
726 lines
35 KiB
OCaml
726 lines
35 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
|
|
|
|
let failures = ref 0
|
|
|
|
let check name cond =
|
|
if not cond then begin
|
|
incr failures;
|
|
Printf.printf "FAIL %s\n" name
|
|
end
|
|
|
|
let reads name src expected =
|
|
match Reader.read_all ~file:"<test>" 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
|
|
|
|
let rejects name src =
|
|
match Reader.read_all ~file:"<test>" src with
|
|
| _ -> incr failures; Printf.printf "FAIL %s: expected a read error\n" name
|
|
| exception Loc.Error _ -> ()
|
|
|
|
let () =
|
|
(* ── Atoms ─────────────────────────────────────────────────────── *)
|
|
reads "integer" "42" "42";
|
|
reads "negative" "-1" "-1";
|
|
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))";
|
|
|
|
(* 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 = '^') 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)" in
|
|
check "no sigils leak into names"
|
|
(bad_names (Form.make (Form.List (Reader.read_all ~file:"<test>" 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";
|
|
rejects "metadata" "^:async";
|
|
rejects "dangling quote" "'";
|
|
|
|
(* ── Locations ─────────────────────────────────────────────────── *)
|
|
(match Reader.read_all ~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 Reader.read_all ~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 Reader.read_all ~file:"<test>" src with
|
|
| [ f ] -> Parse.expr f
|
|
| _ -> failwith "test source must be exactly one form"
|
|
|
|
let parse_decl src =
|
|
match Reader.read_all ~file:"<test>" src with
|
|
| [ f ] -> Parse.decl f
|
|
| _ -> failwith "test source must be exactly one form"
|
|
|
|
let parse_rejects name src =
|
|
match Reader.read_all ~file:"<test>" src |> Parse.program with
|
|
| _ -> incr failures; Printf.printf "FAIL %s: expected a parse error\n" name
|
|
| exception Loc.Error _ -> ()
|
|
|
|
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))";
|
|
parse_rejects "defmacro" "(defmacro m [] 1)";
|
|
|
|
(* ── 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 Reader.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. *)
|
|
|
|
let program src = Reader.read_all ~file:"<test>" 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
|
|
|
|
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
|
|
|
|
(* [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";
|
|
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";
|
|
rejects_check "Vec is milestone 6" "(defn f [x (Vec i32)])"
|
|
~needle:"milestone 6";
|
|
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 (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))";
|
|
(* 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";
|
|
(* ── 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";
|
|
(* The two halves of §3 this version does not do, each refused by name with
|
|
the reason rather than parsed into something that means less. *)
|
|
rejects_check "a restart with parameters"
|
|
"(defn f [] i32 (restart-case 1 (skip [n i32] n)))"
|
|
~needle:"a restart takes no parameters yet";
|
|
rejects_check "invoke-restart with arguments"
|
|
"(defn f [] (invoke-restart 'skip 1))"
|
|
~needle:"a restart takes no arguments yet";
|
|
rejects_check "invoke-restart on an unquoted name"
|
|
"(defn f [] (invoke-restart skip))"
|
|
~needle:"quoted restart name";
|
|
(* §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))" ];
|
|
|
|
(* ── 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
|