From c64e91bdfafc87e12bcf21f546996d633e4ae5cd Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Thu, 10 Sep 2026 14:56:17 +0700 Subject: [PATCH] Add AST and forms->AST parser Second stage of the milestone-2 frontend. calc-me.flan (12 decls) and sand.flan (20 decls) both parse end to end, and both are test deps so a regression fails `dune test` rather than surfacing at the CLI. Three silent-misparse bugs fixed along the way -- all cases that read cleanly and meant something else: - dotimes/defer/some/try/fn fell through to Call, discarding their binding and control-flow meaning. Now special forms. Forms from later milestones (handler-bind, restart-case, loop/recur, defmacro, signal, with-allocator, errdefer, await) are rejected outright rather than parsed as calls. - (Some 1) in first body position was read as a return type, because (Option f64) and (Some 1) are identical s-expressions and the heuristic was capitalisation. Now decided by the set of names actually declared as types, collected in a pre-pass -- exact, and order-independent so a type declared below its user still resolves. - Array literals in value position were rejected outright. Also adds NEXT.md with the handoff for the checker. --- NEXT.md | 64 +++++++ bin/main.ml | 43 ++++- dune | 3 + lib/ast.ml | 103 ++++++++++++ lib/parse.ml | 414 ++++++++++++++++++++++++++++++++++++++++++++++ test/dune | 7 +- test/test_flan.ml | 197 ++++++++++++++++++++++ 7 files changed, 822 insertions(+), 9 deletions(-) create mode 100644 NEXT.md create mode 100644 dune create mode 100644 lib/ast.ml create mode 100644 lib/parse.ml diff --git a/NEXT.md b/NEXT.md new file mode 100644 index 0000000..325c224 --- /dev/null +++ b/NEXT.md @@ -0,0 +1,64 @@ +# Where this is + +Milestone 2 of the build sequence in `plan.org`: *run `calc-me.flan` on the +interpreter*. Two of four stages exist. + +``` +reader ✅ → parse ✅ → check ⬜ → interpret ⬜ +``` + +| File | What it does | +|---|---| +| `lib/loc.ml` | source locations + `Loc.Error`, the frontend's one exception | +| `lib/form.ml` | reader output: `Sym Kw Int Float Str Byte List Vec Map` | +| `lib/reader.ml` | hand-written S-expression reader, no menhir/ocamllex | +| `lib/ast.ml` | AST: `texpr`, `expr`, `place`, `pattern`, `decl` | +| `lib/parse.ml` | forms → AST; special forms, desugaring, declarations | +| `bin/main.ml` | `flan read ` and `flan parse ` | +| `test/test_flan.ml` | 110+ assertions; `calc-me.flan` and `sand.flan` are deps | + +`dune build && dune test` is green. `flan parse calc-me.flan` and +`flan parse sand.flan` both succeed. + +## Next: `lib/types.ml` and the checker + +1. **Type representation.** Resolve `Ast.texpr` into a real type. Needs the + declared-type environment `Parse.declared_types` already computes — that + pre-pass exists and should be reused rather than rebuilt. +2. **Top-level environment.** Two passes, because top-level names are + order-independent (`plan.org`, Modules): collect all signatures, then check + bodies. +3. **Check `calc-me.flan`.** It needs: `i32`/`u8`/`f64`/`bool`, structs, `[u8]` + slices, `(Ptr T)` with one level of auto-deref on `.field`, `(Option T)` with + `Some`/`None`, `Unwrap (Usome, _)` as early-return-None, `while`, `return`, + `set` on the five places, `match` on `Option`, and the milestone-2 primitive + list in `plan.org`. +4. **Then the interpreter** over the typed IR. + +## Watch for + +The two bugs found so far were both *silent misparses* — code that read fine and +meant something else: + +- `'skip-form` became a symbol named `'skip-form` +- `dotimes`/`defer`/`some` fell through to `Call`, discarding their binding and + control-flow meaning +- `(Some 1)` in first body position was eaten as a return type + +The rule that catches this class: **anything that binds a name, alters control +flow, or is not yet implemented must be recognised explicitly and rejected if +unsupported — never allowed to fall through to a generic case.** `parse.ml` +rejects `handler-bind`, `restart-case`, `loop`/`recur`, `defmacro`, `signal`, +`with-allocator`, `errdefer` and `await` for exactly this reason. Keep doing that +in the checker. + +## Open decisions that touch the checker + +None block milestone 2. `plan.org` tags each open decision with the milestone it +is due by; #1 (host language) is now settled as OCaml. + +## Untracked on purpose + +`old-ocaml/` — the pre-rewrite menhir/ocamllex frontend, kept as reference and +excluded from the build by the root `dune` file. Its contents are also in git +history at `2c232dd`. diff --git a/bin/main.ml b/bin/main.ml index 94d735b..d8b7ba1 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,18 +1,45 @@ -(* flan — milestone 2 driver. Right now: read a file and print the forms back, - which is the first thing worth having and the first thing worth testing. *) +(* flan — milestone 2 driver. *) + +let with_errors path f = + try f () with + | Flan.Loc.Error (loc, msg) -> + Printf.eprintf "%s: %s\n" (Flan.Loc.to_string loc) msg; + ignore path; + exit 1 + +let summarise (d : Flan.Ast.decl) = + let open Flan.Ast in + match d.d with + | Package n -> Printf.sprintf "package %s" n + | Import (a, p) -> Printf.sprintf "import %s %S" a p + | Defalias (n, _) -> Printf.sprintf "defalias %s" n + | Defstruct (n, fs) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs) + | Defunion (n, vs) -> Printf.sprintf "defunion %s (%d cases)" n (List.length vs) + | Defvar (n, _, _) -> Printf.sprintf "defvar %s" n + | Defconst (n, _, _) -> Printf.sprintf "defconst %s" n + | Defn fn -> + Printf.sprintf "defn %s (%d params, %s return, %d body forms)" + fn.name (List.length fn.params) + (match fn.ret with None -> "Unit" | Some _ -> "explicit") + (List.length fn.fbody) let () = match Array.to_list Sys.argv with | _ :: "read" :: files when files <> [] -> List.iter (fun path -> - try + with_errors path (fun () -> Flan.Reader.read_file path - |> List.iter (fun f -> print_endline (Flan.Form.to_string f)) - with Flan.Loc.Error (loc, msg) -> - Printf.eprintf "%s: %s\n" (Flan.Loc.to_string loc) msg; - exit 1) + |> List.iter (fun f -> print_endline (Flan.Form.to_string f)))) + files + | _ :: "parse" :: files when files <> [] -> + List.iter + (fun path -> + with_errors path (fun () -> + Flan.Reader.read_file path + |> Flan.Parse.program + |> List.iter (fun d -> print_endline (summarise d)))) files | _ -> - prerr_endline "usage: flan read ..."; + prerr_endline "usage: flan (read|parse) ..."; exit 2 diff --git a/dune b/dune new file mode 100644 index 0000000..d770d2b --- /dev/null +++ b/dune @@ -0,0 +1,3 @@ +; old-ocaml/ is kept as reference only — the pre-rewrite menhir/ocamllex +; frontend. Not built, not part of this project. +(dirs :standard \ old-ocaml) diff --git a/lib/ast.ml b/lib/ast.ml new file mode 100644 index 0000000..cc9cf5c --- /dev/null +++ b/lib/ast.ml @@ -0,0 +1,103 @@ +(** The AST: syntax with special forms recognised, before typing. + + Sugar is gone by this point. [when], [unless], [cond] and [and]/[or] are + desugared into [If] and [Do]; they are compiler special forms until macros + arrive at milestone 5, so there is nothing to preserve for a macroexpander + to see yet. + + Types here are *surface* type expressions, not resolved types. [Ptr] and + [Option] are still just names; the checker resolves them. *) + +(* ── Type expressions ──────────────────────────────────────────────── *) + +type texpr = { t : texpr_kind; tloc : Loc.t } + +and texpr_kind = + | Tname of string (* i32 bool Cursor string *) + | Tslice of texpr (* [u8] ptr+len *) + | Tarray of len * texpr (* [4 f32] [rows [cols u32]] *) + | Tmap of texpr * texpr (* {string i32} *) + | Tapp of string * texpr list (* (Ptr Cursor) (Option f64) *) + | Tfn of texpr list * texpr (* (Fn [a a] bool) *) + +(* An array length is an integer or a compile-time constant's name. *) +and len = + | Lint of int64 + | Lname of string + +(* ── Expressions ───────────────────────────────────────────────────── *) + +type expr = { e : expr_kind; loc : Loc.t } + +and expr_kind = + | Int of int64 + | Float of float + | Byte of int + | Str of string + | Kw of string (* :space — coerced at typed call sites *) + | Quote of string (* 'skip-form — restart names *) + | Var of string + | Do of expr list + | Let of binding list * expr list + | If of expr * expr * expr option + | While of expr * expr list + | Return of expr option + | Set of place * expr + | Field of expr * string (* (.pos c) — auto-derefs one level *) + | Call of expr * expr list + | Match of expr * arm list + | Struct of string * (string * expr) list (* (Cursor {:src s}) *) + | Arr of expr list (* [0xE6B800FF ...] — a fixed array value *) + (* These bind names or alter control flow, so none of them can be a call. *) + | Fn of string list * expr list (* (fn [x y] ...) — non-escaping *) + | Dotimes of string * expr * expr list (* (dotimes [i n] ...) *) + | Defer of expr list (* runs on scope exit *) + | Unwrap of unwrap * expr (* (some x) / (try x) *) + +(* Two unwrap operators, because they are two different things — plan.org. *) +and unwrap = Usome | Utry + +and binding = { bname : string; bty : texpr option; bval : expr; bloc : Loc.t } + +(* The fixed list of assignable forms — spec-memory.md. Not setf. *) +and place = + | Pvar of string + | Pfield of expr * string (* (set (.hp e) v) *) + | Pindex of expr * expr list (* (set (at grid r c) v) *) + | Pkey of expr * expr (* (set (get m k) v) *) + | Pderef of expr (* (set (deref p) v) *) + +and arm = { pat : pattern; body : expr list; aloc : Loc.t } + +and pattern = + | Pctor of string * string list (* (Some e) (Rect w h) None *) + | Pwild (* _ :else *) + +(* ── Declarations ──────────────────────────────────────────────────── *) + +type field = { fname : string; fty : texpr; floc : Loc.t } + +type fn = { + name : string; + params : field list; + ret : texpr option; (* None means Unit *) + fbody : expr list; + nloc : Loc.t; +} + +type decl = { d : decl_kind; dloc : Loc.t } + +and decl_kind = + | Package of string + | Import of string * string (* alias, path *) + | Defalias of string * texpr + | Defstruct of string * field list + | Defunion of string * variant list + | Defn of fn + (* value is optional: ZII. `uninit` opts out and is recorded as Uninit. *) + | Defvar of string * texpr option * init + | Defconst of string * texpr option * expr + +and variant = { vname : string; vfields : field list; vloc : Loc.t } + +and init = Zeroed | Uninit | Init of expr diff --git a/lib/parse.ml b/lib/parse.ml new file mode 100644 index 0000000..64ac475 --- /dev/null +++ b/lib/parse.ml @@ -0,0 +1,414 @@ +(** Forms → AST. Recognises special forms, desugars sugar, reports malformed + syntax with the location of the offending form. + + Everything not recognised here is a call, which is how a Lisp should work: + [at], [len], [push], [abort] and the rest are ordinary functions resolved + by the checker, not syntax. *) + +open Form + +let fail (f : Form.t) fmt = Loc.fail f.loc fmt + +let sym (f : Form.t) = + match f.v with + | Sym s -> s + | _ -> fail f "expected a name, found %s" (Form.to_string f) + +(* Primitive type names are lowercase but concrete; every other lowercase name + in type position is a type variable (plan.org, Types). *) +let primitives = + [ "i8"; "i16"; "i32"; "i64"; "u8"; "u16"; "u32"; "u64"; + "f32"; "f64"; "bool"; "string"; "Unit"; "Never" ] + +let is_primitive s = List.mem s primitives + +module Names = Set.Make (String) + +(* Type constructors the language provides. User types are collected by a + pre-pass over the file's declarations — see [program]. *) +let builtin_types = + Names.of_list (primitives @ [ "Ptr"; "Option"; "Result"; "Vec"; "Map"; + "Handle"; "Fn" ]) + +(* ── Type expressions ──────────────────────────────────────────────── *) + +let rec texpr (f : Form.t) : Ast.texpr = + let mk t = { Ast.t; tloc = f.loc } in + match f.v with + | Sym s -> mk (Ast.Tname s) + | Vec [ elem ] -> mk (Ast.Tslice (texpr elem)) + | Vec [ n; elem ] -> mk (Ast.Tarray (len n, texpr elem)) + | Vec _ -> + fail f "a type in brackets is [T] for a slice or [n T] for a fixed array" + | Map [ k; v ] -> mk (Ast.Tmap (texpr k, texpr v)) + | Map _ -> fail f "a map type is {K V}" + | List ({ v = Sym "Fn"; _ } :: rest) -> + (match rest with + | [ { v = Vec params; _ }; ret ] -> + mk (Ast.Tfn (List.map texpr params, texpr ret)) + | _ -> fail f "a function type is (Fn [T ...] R)") + | List ({ v = Sym name; _ } :: args) when args <> [] -> + mk (Ast.Tapp (name, List.map texpr args)) + | _ -> fail f "expected a type, found %s" (Form.to_string f) + +and len (f : Form.t) : Ast.len = + match f.v with + | Int n -> Ast.Lint n + | Sym s -> Ast.Lname s + | _ -> fail f "an array length is an integer or a constant's name" + +(* Inline name/type pairs: [x i32 y f32] — as in let, defstruct and defn. *) +let rec fields (f : Form.t) (items : Form.t list) : Ast.field list = + match items with + | [] -> [] + | name :: ty :: rest -> + { Ast.fname = sym name; fty = texpr ty; floc = name.loc } :: fields f rest + | [ odd ] -> + Loc.fail odd.loc "field %s has no type — these come in name/type pairs" + (Form.to_string odd) + +(* ── Expressions ───────────────────────────────────────────────────── *) + +let rec expr (f : Form.t) : Ast.expr = + let mk e = { Ast.e; loc = f.loc } in + match f.v with + | Int i -> mk (Ast.Int i) + | Float x -> mk (Ast.Float x) + | Byte b -> mk (Ast.Byte b) + | Str s -> mk (Ast.Str s) + | Kw k -> mk (Ast.Kw k) + | Sym s -> mk (Ast.Var s) + (* In value position brackets are a fixed-array literal; in type position + they are a slice or array type. Position disambiguates, as with {}. *) + | Vec items -> mk (Ast.Arr (List.map expr items)) + | Map _ -> fail f "a bare map is not an expression; write (Type {:field v})" + | List [] -> fail f "() is not an expression" + | List (head :: args) -> form f mk head args + +and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = + match head.v with + (* ── quote ─────────────────────────────────────────────────────── *) + | Sym "quote" -> + (match args with + | [ { v = Sym s; _ } ] -> mk (Ast.Quote s) + | _ -> fail f "quote takes one symbol") + + (* ── sequencing and binding ────────────────────────────────────── *) + | Sym "do" -> mk (Ast.Do (List.map expr args)) + + | Sym "let" -> + (match args with + | { v = Vec bs; _ } :: body -> mk (Ast.Let (bindings f bs, body_of body)) + | _ -> fail f "let is (let [name value ...] body ...)") + + (* ── conditionals ──────────────────────────────────────────────── *) + | Sym "if" -> + (match args with + | [ c; t ] -> mk (Ast.If (expr c, expr t, None)) + | [ c; t; e ] -> mk (Ast.If (expr c, expr t, Some (expr e))) + | _ -> fail f "if is (if test then) or (if test then else)") + + (* Sugar, desugared here: special forms until macros land at milestone 5. *) + | Sym "when" -> + (match args with + | c :: body when body <> [] -> + mk (Ast.If (expr c, { Ast.e = Ast.Do (body_of body); loc = f.loc }, None)) + | _ -> fail f "when is (when test body ...)") + + | Sym "unless" -> + (match args with + | c :: body when body <> [] -> + let neg = { Ast.e = Ast.Call ({ Ast.e = Ast.Var "not"; loc = head.loc }, + [ expr c ]); loc = f.loc } in + mk (Ast.If (neg, { Ast.e = Ast.Do (body_of body); loc = f.loc }, None)) + | _ -> fail f "unless is (unless test body ...)") + + | Sym "cond" -> cond f args + + (* Short-circuiting, so they cannot be ordinary calls. *) + | Sym "and" -> shortcircuit f args ~is_and:true + | Sym "or" -> shortcircuit f args ~is_and:false + + (* ── loops ─────────────────────────────────────────────────────── *) + | Sym "while" -> + (match args with + | c :: body -> mk (Ast.While (expr c, body_of body)) + | [] -> fail f "while is (while test body ...)") + + | Sym "until" -> + (match args with + | c :: body -> + let neg = { Ast.e = Ast.Call ({ Ast.e = Ast.Var "not"; loc = head.loc }, + [ expr c ]); loc = f.loc } in + mk (Ast.While (neg, body_of body)) + | [] -> fail f "until is (until test body ...)") + + (* ── control ───────────────────────────────────────────────────── *) + | Sym "return" -> + (match args with + | [] -> mk (Ast.Return None) + | [ v ] -> mk (Ast.Return (Some (expr v))) + | _ -> fail f "return takes at most one value") + + | Sym "set" -> + (match args with + | [ target; value ] -> mk (Ast.Set (place target, expr value)) + | _ -> fail f "set is (set place value)") + + | Sym "match" -> + (match args with + | scrutinee :: rest -> mk (Ast.Match (expr scrutinee, arms f rest)) + | [] -> fail f "match is (match value pattern body ...)") + + (* ── binding and control: never a call ─────────────────────────── *) + (* A form that binds a name or alters control flow cannot fall through to + Call — it would parse cleanly and mean the wrong thing, silently. *) + | Sym "fn" -> + (match args with + | { v = Vec ps; _ } :: body when body <> [] -> + mk (Ast.Fn (List.map sym ps, body_of body)) + | _ -> fail f "fn is (fn [param ...] body ...)") + + | Sym "dotimes" -> + (match args with + | { v = Vec [ n; count ]; _ } :: body -> + mk (Ast.Dotimes (sym n, expr count, body_of body)) + | _ -> fail f "dotimes is (dotimes [name count] body ...)") + + | Sym "defer" -> + (match args with + | [] -> fail f "defer is (defer body ...)" + | body -> mk (Ast.Defer (body_of body))) + + | Sym "some" -> + (match args with + | [ v ] -> mk (Ast.Unwrap (Ast.Usome, expr v)) + | _ -> fail f "some is (some option-value)") + + | Sym "try" -> + (match args with + | [ v ] -> mk (Ast.Unwrap (Ast.Utry, expr v)) + | _ -> fail f "try is (try result-value)") + + (* Recognised, deliberately unimplemented. Rejected rather than left to fall + through to Call, where they would parse and mean nothing. *) + | Sym ("handler-bind" | "handler-case" | "restart-case" | "invoke-restart" + | "signal" | "errdefer" | "with-allocator" | "loop" | "recur" + | "defmacro" | "await" as name) -> + fail f "%s is not implemented yet (see the build sequence in plan.org)" name + + (* ── field access: (.pos c) ────────────────────────────────────── *) + | Sym s when String.length s > 1 && s.[0] = '.' -> + let field = String.sub s 1 (String.length s - 1) in + (match args with + | [ target ] -> mk (Ast.Field (expr target, field)) + | _ -> fail f "field access is (.%s value)" field) + + (* ── struct literal: (Cursor {:src s :pos 0}) ───────────────────── *) + | Sym name when args <> [] && is_map (List.hd args) -> + (match args with + | [ { v = Map kvs; _ } ] -> mk (Ast.Struct (name, struct_fields f kvs)) + | _ -> fail f "a struct literal is (%s {:field value ...})" name) + + (* ── anything else is a call ────────────────────────────────────── *) + | _ -> mk (Ast.Call (expr head, List.map expr args)) + +and is_map (f : Form.t) = match f.v with Map _ -> true | _ -> false + +and body_of (items : Form.t list) : Ast.expr list = List.map expr items + +and bindings f (items : Form.t list) : Ast.binding list = + (* [name value ...] and [name Type value ...] both read; a type is a form + that is not a value position — disambiguated by pair vs triple is + ambiguous, so let requires (let [name value]) and types are inferred. + Annotated locals are not needed by any acceptance program. *) + let rec go = function + | [] -> [] + | name :: value :: rest -> + { Ast.bname = sym name; bty = None; bval = expr value; bloc = name.loc } + :: go rest + | [ odd ] -> + Loc.fail odd.loc "binding %s has no value — let takes name/value pairs" + (Form.to_string odd) + in + if items = [] then Loc.fail f.loc "let needs at least one binding" else go items + +and struct_fields f (items : Form.t list) : (string * Ast.expr) list = + let rec go = function + | [] -> [] + | { v = Kw k; _ } :: value :: rest -> (k, expr value) :: go rest + | other :: _ :: _ -> + Loc.fail other.loc "expected :field, found %s" (Form.to_string other) + | [ odd ] -> Loc.fail odd.loc "field %s has no value" (Form.to_string odd) + in + ignore f; go items + +and cond f (args : Form.t list) : Ast.expr = + let rec go = function + | [] -> { Ast.e = Ast.Do []; loc = f.loc } (* no clause matched: Unit *) + | { v = Kw "else"; _ } :: body :: _ -> expr body + | test :: body :: rest -> + { Ast.e = Ast.If (expr test, expr body, Some (go rest)); loc = f.loc } + | [ odd ] -> Loc.fail odd.loc "cond clause %s has no body" + (Form.to_string odd) + in + if args = [] then Loc.fail f.loc "cond needs at least one clause" else go args + +and shortcircuit f (args : Form.t list) ~is_and : Ast.expr = + let mk e = { Ast.e; loc = f.loc } in + let rec go = function + | [] -> mk (Ast.Var (if is_and then "true" else "false")) + | [ last ] -> expr last + | x :: rest -> + if is_and then mk (Ast.If (expr x, go rest, Some (mk (Ast.Var "false")))) + else mk (Ast.If (expr x, mk (Ast.Var "true"), Some (go rest))) + in + go args + +and place (f : Form.t) : Ast.place = + match f.v with + | Sym s -> Ast.Pvar s + | List ({ v = Sym s; _ } :: args) + when String.length s > 1 && s.[0] = '.' -> + let field = String.sub s 1 (String.length s - 1) in + (match args with + | [ target ] -> Ast.Pfield (expr target, field) + | _ -> fail f "field place is (.%s value)" field) + | List ({ v = Sym "at"; _ } :: target :: idx) when idx <> [] -> + Ast.Pindex (expr target, List.map expr idx) + | List [ { v = Sym "get"; _ }; m; k ] -> Ast.Pkey (expr m, expr k) + | List [ { v = Sym "deref"; _ }; p ] -> Ast.Pderef (expr p) + | _ -> + fail f + "%s is not assignable. set takes a name, (.field x), (at a i ...), \ + (get m k) or (deref p)" + (Form.to_string f) + +and arms f (items : Form.t list) : Ast.arm list = + let rec go = function + | [] -> [] + | p :: body :: rest -> + { Ast.pat = pattern p; body = [ expr body ]; aloc = p.loc } :: go rest + | [ odd ] -> + Loc.fail odd.loc "match arm %s has no body" (Form.to_string odd) + in + if items = [] then Loc.fail f.loc "match needs at least one arm" else go items + +and pattern (f : Form.t) : Ast.pattern = + match f.v with + | Sym "_" -> Ast.Pwild + | Kw "else" -> Ast.Pwild + | Sym ctor -> Ast.Pctor (ctor, []) + | List ({ v = Sym ctor; _ } :: binds) -> + Ast.Pctor (ctor, List.map sym binds) + | _ -> fail f "expected a pattern, found %s" (Form.to_string f) + +(* ── Declarations ──────────────────────────────────────────────────── *) + +let rec decl types (f : Form.t) : Ast.decl = + let mk d = { Ast.d; dloc = f.loc } in + match f.v with + | List ({ v = Sym "package"; _ } :: args) -> + (match args with + | [ n ] -> mk (Ast.Package (sym n)) + | _ -> fail f "package is (package name)") + + | List ({ v = Sym "import"; _ } :: args) -> + (match args with + | [ alias; { v = Str path; _ } ] -> mk (Ast.Import (sym alias, path)) + | _ -> fail f "import is (import alias \"collection:path\")") + + | List ({ v = Sym "defalias"; _ } :: args) -> + (match args with + | [ n; t ] -> mk (Ast.Defalias (sym n, texpr t)) + | _ -> fail f "defalias is (defalias Name Type)") + + | List ({ v = Sym "defstruct"; _ } :: args) -> + (match args with + | [ n; { v = Vec fs; _ } ] -> mk (Ast.Defstruct (sym n, fields f fs)) + | _ -> fail f "defstruct is (defstruct Name [field Type ...])") + + | List ({ v = Sym "defunion"; _ } :: args) -> + (match args with + | [ n; { v = Vec vs; _ } ] -> mk (Ast.Defunion (sym n, List.map variant vs)) + | _ -> fail f "defunion is (defunion Name [(Case [field Type ...]) ...])") + + | List ({ v = Sym "defn"; _ } :: args) -> + (match args with + | n :: { v = Vec ps; _ } :: rest -> + let ret, body = + match rest with + (* An omitted return type means Unit. A leading form that is a type + and is not the whole body is the return type. *) + | [] -> None, [] + | first :: more when more <> [] && is_type_form types first -> + Some (texpr first), body_of more + | _ -> None, body_of rest + in + mk (Ast.Defn { Ast.name = sym n; params = fields f ps; ret; + fbody = body; nloc = n.loc }) + | _ -> fail f "defn is (defn name [param Type ...] ReturnType? body ...)") + + | List ({ v = Sym "defvar"; _ } :: args) -> + (match args with + | [ n; t ] -> mk (Ast.Defvar (sym n, Some (texpr t), Ast.Zeroed)) + | [ n; t; { v = Sym "uninit"; _ } ] -> + mk (Ast.Defvar (sym n, Some (texpr t), Ast.Uninit)) + | [ n; t; v ] -> mk (Ast.Defvar (sym n, Some (texpr t), Ast.Init (expr v))) + | _ -> fail f "defvar is (defvar name Type value?)") + + | List ({ v = Sym "defconst"; _ } :: args) -> + (match args with + | [ n; v ] -> mk (Ast.Defconst (sym n, None, expr v)) + | [ n; t; v ] -> mk (Ast.Defconst (sym n, Some (texpr t), expr v)) + | _ -> fail f "defconst is (defconst name Type? value)") + + | List ({ v = Sym s; _ } :: _) -> fail f "unknown top-level form (%s ...)" s + | _ -> fail f "expected a top-level declaration, found %s" (Form.to_string f) + +(* Is this form the function's return type, or the first form of its body? + + Shape alone cannot tell: [(Option f64)] and [(Some 1)] are identical + s-expressions, one a type application and one a constructor call. Capitalised + heads are not a good enough signal — [(defn f [] (Some 1) (bar))] would eat + the body's first form as a return type, silently. + + So the decision uses the set of names that are actually types, which the + pre-pass in [program] collects from the file's own declarations. That makes + it exact rather than heuristic, because types are only ever introduced by + defstruct, defunion and defalias — all syntactically obvious. *) +and is_type_form types (f : Form.t) = + match f.v with + | Sym s -> Names.mem s types + | Vec _ -> true (* [T] and [n T] are only types *) + | Map _ -> true (* {K V} in this position *) + | List ({ v = Sym n; _ } :: _) -> Names.mem n types + | _ -> false + +and variant (f : Form.t) : Ast.variant = + match f.v with + | Sym n -> { Ast.vname = n; vfields = []; vloc = f.loc } + | List [ { v = Sym n; _ }; { v = Vec fs; _ } ] -> + { Ast.vname = n; vfields = fields f fs; vloc = f.loc } + | List [ { v = Sym n; _ } ] -> { Ast.vname = n; vfields = []; vloc = f.loc } + | _ -> fail f "a union case is Name or (Name [field Type ...])" + +(* Names introduced as types by this file, plus the builtins. Collected before + anything is parsed, so a type declared at the bottom of a file is still known + to a function at the top — top-level names are order-independent. *) +let declared_types (forms : Form.t list) : Names.t = + List.fold_left + (fun acc (f : Form.t) -> + match f.v with + | List [ { v = Sym ("defstruct" | "defunion" | "defalias"); _ }; + { v = Sym n; _ }; _ ] -> Names.add n acc + | _ -> acc) + builtin_types forms + +let program (forms : Form.t list) : Ast.decl list = + let types = declared_types forms in + List.map (decl types) forms + +(* Single-declaration entry point, for tests and the REPL. Sees only the + builtin types plus whatever this one form declares. *) +let decl (f : Form.t) : Ast.decl = decl (declared_types [ f ]) f diff --git a/test/dune b/test/dune index 5d4e2d7..9c9c15c 100644 --- a/test/dune +++ b/test/dune @@ -1,3 +1,8 @@ (test (name test_flan) - (libraries flan)) + (libraries flan) + ; The acceptance programs are part of the test corpus: if the reader or the + ; parser regresses on them we want to know here, not at the CLI. + (deps + (file %{workspace_root}/calc-me.flan) + (file %{workspace_root}/sand.flan))) diff --git a/test/test_flan.ml b/test/test_flan.ml index d2992d7..e646ae1 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -119,3 +119,200 @@ let () = Printf.printf "\n%d failure(s)\n" !failures; exit 1 end + +(* ═══ Parse: forms → AST ═══════════════════════════════════════════ *) + +let parse1 src = + match Reader.read_all ~file:"" src with + | [ f ] -> Parse.expr f + | _ -> failwith "test source must be exactly one form" + +let parse_decl src = + match Reader.read_all ~file:"" src with + | [ f ] -> Parse.decl f + | _ -> failwith "test source must be exactly one form" + +let parse_rejects name src = + match Reader.read_all ~file:"" 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:"" 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)); + + if !failures = 0 then print_endline "ambiguity: all tests passed" + else begin + Printf.printf "\n%d failure(s)\n" !failures; + exit 1 + end