Joseph Ferano
d4cef99718
(defmacro m [x] x) answered "unknown top-level form (defmacro ...)" — refused, but not by name and with no reason, because the refusal list only covered expressions. Now it checks the shape and then refuses, which are two different mistakes and get two different reasons: a defmacro with no body is a typo, a defmacro with a body is a feature that is not here. The reader's new sigils made this urgent rather than tidy. quasiquote, unquote and unquote-splicing are now real heads arriving at the parser, and without a case each they would fall through to Call and come back from the checker as "unknown name quasiquote" — which tells you nothing about what is missing. unquote and unquote-splicing are refused as mistakes rather than as milestones: they mean nothing outside a quasiquote and the reader cannot notice, because it does not track where it is. gensym is neither a reader token nor a special form — it is a function a macro body calls while the macro runs, and there is nowhere for it to run. Refused by name so it does not arrive as an unknown one.
816 lines
40 KiB
OCaml
816 lines
40 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 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
|
|
|
|
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
|
|
|
|
(* [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 Reader.read_all ~file:"<test>" src with
|
|
| _ -> incr failures; Printf.printf "FAIL %s: expected a read error\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";
|
|
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 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}"
|
|
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" "'";
|
|
(* 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 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"
|
|
|
|
(* [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 Reader.read_all ~file:"<test>" 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 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";
|
|
(* 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";
|
|
(* 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
|