798 lines
35 KiB
OCaml
798 lines
35 KiB
OCaml
(** 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)
|
|
|
|
(* Names for the temporaries a destructuring binding needs — the value is bound
|
|
once and every name in the pattern reads *that*, so a pattern over a call
|
|
calls it once. [~] is a delimiter in the reader, so no symbol anyone can
|
|
write contains one: these cannot collide with a source name and a source
|
|
name cannot shadow one. Reset per program so the names, and therefore the
|
|
slot numbering downstream, are the same every run. *)
|
|
let temps = ref 0
|
|
|
|
let fresh_temp () = incr temps; Printf.sprintf "destructure~%d" !temps
|
|
|
|
(* Destructuring binds in [let] and nowhere else. Every other binding position —
|
|
a [defn] parameter, a [defstruct] field, an [fn] parameter, a [dotimes]
|
|
counter, a [match] arm's binds — takes a plain name, and a pattern written
|
|
there is refused here rather than falling out of [sym] as "expected a name".
|
|
|
|
A parameter is the one worth saying why about: it is a name/type pair, and a
|
|
pattern has no name to pair the type with, so supporting it means a pattern
|
|
inside [Ast.field] — a record [Load] and [Shim] both build and read, and
|
|
neither is this file's to change. *)
|
|
let no_pattern (f : Form.t) =
|
|
match f.v with
|
|
| Map _ | Vec _ ->
|
|
fail f
|
|
"%s is a destructuring pattern, and a pattern binds only in let — this \
|
|
position takes a plain name. Take the value under a name and \
|
|
destructure it in the body"
|
|
(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 ->
|
|
no_pattern name;
|
|
{ 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 <> [] ->
|
|
List.iter no_pattern ps;
|
|
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 ->
|
|
no_pattern n;
|
|
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)")
|
|
|
|
(* (signal c) : Unit, always. When every applicable handler returns normally
|
|
the signalling function simply carries on, and with no handler at all it is
|
|
a no-op — spec-conditions.md §1 and §2. *)
|
|
(* And (error c) : Never — §2's diverging variant. Same lookup, but a
|
|
handler that returns normally does not answer it: with nothing
|
|
transferring the program stops. *)
|
|
| Sym (("signal" | "error") as how) ->
|
|
let kind = if how = "signal" then Ast.Ssignal else Ast.Serror in
|
|
(match args with
|
|
| [ c ] -> mk (Ast.Signal (kind, expr c))
|
|
| _ -> fail f "%s is (%s condition)" how how)
|
|
|
|
(* (handler-bind [(Type [c] body ...) ...] body ...)
|
|
|
|
A clause names a condition type, binds the condition, and runs for effect;
|
|
matching is by type, since there is no condition hierarchy. *)
|
|
| Sym "handler-bind" ->
|
|
let clauses, body =
|
|
match args with
|
|
| { v = Vec clauses; _ } :: body when body <> [] -> (clauses, body)
|
|
| _ ->
|
|
fail f "handler-bind is (handler-bind [(Type [name] body ...) ...] body ...)"
|
|
in
|
|
let clause (c : Form.t) =
|
|
match c.Form.v with
|
|
| Form.List (ty :: { v = Form.Vec [ { v = Form.Sym n; _ } ]; _ } :: cbody)
|
|
when cbody <> [] ->
|
|
{ Ast.hty = texpr ty; hname = n; hbody = List.map expr cbody;
|
|
hloc = c.Form.loc }
|
|
| _ ->
|
|
fail c "a handler-bind clause is (Type [name] body ...)"
|
|
in
|
|
mk (Ast.HandlerBind (List.map clause clauses, body_of body))
|
|
|
|
(* (restart-case BODY (name [] BODY-1) ...) — spec-conditions.md §3.
|
|
The body and every clause have the same type, which is the form's.
|
|
Restarts take no parameters in this version; a clause that declares one is
|
|
rejected below rather than ignored. *)
|
|
| Sym "restart-case" ->
|
|
let body, clauses =
|
|
match args with
|
|
| body :: clauses when clauses <> [] -> (body, clauses)
|
|
| _ ->
|
|
fail f "restart-case is (restart-case body (name [] body ...) ...)"
|
|
in
|
|
let clause (c : Form.t) =
|
|
match c.Form.v with
|
|
| Form.List ({ v = Form.Sym n; _ } :: { v = Form.Vec ps; _ } :: cbody)
|
|
when cbody <> [] ->
|
|
if ps <> [] then
|
|
fail c
|
|
"a restart takes no parameters yet — spec-conditions.md §3 has \
|
|
them, and they need argument marshalling and a runtime arity \
|
|
check that this version does not do";
|
|
{ Ast.rname = n; rbody = List.map expr cbody; rloc = c.Form.loc }
|
|
| _ -> fail c "a restart-case clause is (name [] body ...)"
|
|
in
|
|
mk (Ast.RestartCase (expr body, List.map clause clauses))
|
|
|
|
(* (invoke-restart 'name) : Never. The name is a quoted symbol — that is what
|
|
the reader's quote is for — and it is resolved on the restart stack at run
|
|
time, since restarts are dynamically scoped. *)
|
|
| Sym "invoke-restart" ->
|
|
(match args with
|
|
| [ { v = Form.List [ { v = Form.Sym "quote"; _ }; { v = Form.Sym n; _ } ]; _ } ] ->
|
|
mk (Ast.InvokeRestart n)
|
|
| [ _ ] ->
|
|
fail f
|
|
"invoke-restart takes a quoted restart name, as in \
|
|
(invoke-restart 'use-placeholder)"
|
|
| _ ->
|
|
fail f
|
|
"a restart takes no arguments yet — spec-conditions.md §3 has them, \
|
|
and they need argument marshalling and a runtime arity check that \
|
|
this version does not do")
|
|
|
|
(* ── macros ────────────────────────────────────────────────────── *)
|
|
(* The reader now produces these three, so they arrive here as ordinary heads
|
|
and would fall through to Call — coming back from the checker as "unknown
|
|
name quasiquote", which says nothing about what is actually missing. *)
|
|
| Sym "quasiquote" ->
|
|
fail f "`x is read, but not expanded: macro expansion is not wired up yet \
|
|
(NEXT.md says what it needs)"
|
|
|
|
(* Not a milestone, a mistake: these two mean nothing anywhere else, and the
|
|
reader cannot tell, because it does not track where it is. *)
|
|
| Sym "unquote" ->
|
|
fail f "~x means nothing outside a quasiquote"
|
|
| Sym "unquote-splicing" ->
|
|
fail f "~@x means nothing outside a quasiquote, and splices only into a \
|
|
list or a vector"
|
|
|
|
| Sym "defmacro" ->
|
|
fail f "defmacro is a top-level declaration, not an expression"
|
|
|
|
(* Neither a reader token nor a special form: an ordinary function that a
|
|
macro body calls while the macro runs. There is nowhere for it to run
|
|
yet, so it says that rather than arriving as an unknown name. *)
|
|
| Sym "gensym" ->
|
|
fail f "gensym is only meaningful inside a macro body, and macro expansion \
|
|
is not wired up yet (NEXT.md says what it needs)"
|
|
|
|
(* Recognised, deliberately unimplemented. Rejected rather than left to fall
|
|
through to Call, where they would parse and mean nothing. *)
|
|
| Sym ("handler-case"
|
|
(* Named in the spec and not written yet, so each says so rather than
|
|
falling through to Call and coming back as an unknown name:
|
|
[find-restart] and [compute-restarts] are §4's two ways to look at
|
|
the restart stack without committing to one. *)
|
|
| "find-restart" | "compute-restarts"
|
|
| "errdefer" | "with-allocator" | "loop" | "recur"
|
|
| "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
|
|
| [] -> []
|
|
| pat :: value :: rest ->
|
|
let bs = destructure pat (expr value) in
|
|
no_duplicates pat bs;
|
|
bs @ 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
|
|
|
|
(* ── Destructuring ─────────────────────────────────────────────────── *)
|
|
|
|
(* The temporary every pattern binds its value to before anything reads it, so
|
|
that the value is evaluated once however many names come out of it. Returning
|
|
the reference as well as the binding is what makes the two impossible to
|
|
separate by accident. *)
|
|
and temp (p : Form.t) (v : Ast.expr) : Ast.expr * Ast.binding =
|
|
let t = fresh_temp () in
|
|
({ Ast.e = Ast.Var t; loc = p.loc },
|
|
{ Ast.bname = t; bty = None; bval = v; bloc = p.loc })
|
|
|
|
(* Clojure's destructuring, desugared here into the bindings and field accesses
|
|
the language already has. [Ast.binding] carries a name and nothing else, and
|
|
deliberately so: nothing downstream — not [Load]'s renaming, not [Check], not
|
|
any backend — learns that a pattern exists. The same reason [dotimes] is a
|
|
[Let] plus a [While].
|
|
|
|
The one thing this cannot decide is whether an array pattern's arity matches
|
|
the value's, because that is a type and there are none here. [destructure~nth]
|
|
carries the question to [Check], which answers it and emits an ordinary [at].
|
|
|
|
A binding is a pattern only when it is written in brackets or braces; a bare
|
|
name is what it always was. *)
|
|
and destructure (p : Form.t) (v : Ast.expr) : Ast.binding list =
|
|
match p.v with
|
|
| Sym name -> [ { Ast.bname = name; bty = None; bval = v; bloc = p.loc } ]
|
|
(* The value goes into a temporary first, so it is evaluated once however
|
|
many names the pattern binds, and so that [(let [{:keys [p]} p] ...)]
|
|
reads the old [p] rather than the one it is in the middle of rebinding. *)
|
|
| Map items -> let t, bind = temp p v in bind :: dmap p t items
|
|
| Vec items -> let t, bind = temp p v in bind :: dvec p t items
|
|
| _ ->
|
|
fail p
|
|
"expected a name or a destructuring pattern, found %s — a pattern is \
|
|
{:keys [x y]} over a struct or [a b] over a fixed array"
|
|
(Form.to_string p)
|
|
|
|
(* {:keys [x y]} and {inner :field}, over a struct. Clojure's map destructuring
|
|
with Flan's structs standing in for its maps: [:keys] is the common case and
|
|
the pair form is what nests, since a [:keys] entry is a name and never a
|
|
pattern. Everything else Clojure puts in this position — [:as], [:or],
|
|
[:strs], [:syms] — is refused by name where it is written. *)
|
|
and dmap (p : Form.t) (t : Ast.expr) (items : Form.t list) : Ast.binding list =
|
|
let ex loc e : Ast.expr = { Ast.e; loc } in
|
|
let field loc name = ex loc (Ast.Field (t, name)) in
|
|
let rec go = function
|
|
| [] -> []
|
|
| { v = Kw "keys"; _ } :: names :: rest ->
|
|
let ns =
|
|
match names.v with
|
|
| Vec ns -> ns
|
|
| _ ->
|
|
Loc.fail names.loc
|
|
":keys takes a bracketed list of field names, found %s"
|
|
(Form.to_string names)
|
|
in
|
|
let rec each = function
|
|
| [] -> []
|
|
| (n : Form.t) :: more ->
|
|
let name =
|
|
match n.v with
|
|
| Sym s -> s
|
|
| _ ->
|
|
Loc.fail n.loc
|
|
":keys binds field names, and %s is not one — a nested pattern \
|
|
is written {%s :field}"
|
|
(Form.to_string n) (Form.to_string n)
|
|
in
|
|
{ Ast.bname = name; bty = None; bval = field n.loc name; bloc = n.loc }
|
|
:: each more
|
|
in
|
|
each ns @ go rest
|
|
| ({ v = Kw k; _ } as bad) :: _ :: rest ->
|
|
ignore rest;
|
|
Loc.fail bad.loc
|
|
":%s is not implemented in a destructuring pattern — a struct pattern \
|
|
is {:keys [x y]} or {name :field}, and nothing else" k
|
|
| pat :: ({ v = Kw fld; _ } as fform) :: rest ->
|
|
destructure pat (field fform.loc fld) @ go rest
|
|
| pat :: other :: _ ->
|
|
Loc.fail other.loc
|
|
"expected :field after %s, found %s — a struct pattern binds \
|
|
{name :field}" (Form.to_string pat) (Form.to_string other)
|
|
| [ odd ] ->
|
|
Loc.fail odd.loc "%s has no :field — a struct pattern comes in pairs"
|
|
(Form.to_string odd)
|
|
in
|
|
if items = [] then
|
|
fail p "an empty struct pattern {} binds nothing — write the names it should bind"
|
|
else go items
|
|
|
|
(* [a b] and [a b & rest], over a fixed array. Not over a slice: see [Check]. *)
|
|
and dvec (p : Form.t) (t : Ast.expr) (items : Form.t list) : Ast.binding list =
|
|
let ex loc e : Ast.expr = { Ast.e; loc } in
|
|
let var loc n = ex loc (Ast.Var n) in
|
|
let rec split acc = function
|
|
| [] -> (List.rev acc, None)
|
|
| ({ v = Sym "&"; _ } as amp) :: rest ->
|
|
(match rest with
|
|
| [ r ] -> (List.rev acc, Some r)
|
|
| [] -> Loc.fail amp.loc "& needs a name after it, as in [a b & rest]"
|
|
| _ :: extra :: _ ->
|
|
Loc.fail extra.loc
|
|
"& takes one name and it is the last thing in the pattern")
|
|
| x :: rest -> split (x :: acc) rest
|
|
in
|
|
let elems, rest = split [] items in
|
|
let n = List.length elems in
|
|
(match elems, rest with
|
|
| [], None ->
|
|
fail p "an empty array pattern [] binds nothing — write the names it should bind"
|
|
| [], Some r ->
|
|
Loc.fail r.loc
|
|
"[& %s] binds the whole value — write %s on its own instead of a pattern"
|
|
(Form.to_string r) (Form.to_string r)
|
|
| _ -> ());
|
|
(* With a [& rest] the pattern says "at least this many"; without one it says
|
|
"exactly this many". [Check] is where the array's length is known, so the
|
|
count and which of the two it means travel there as arguments. *)
|
|
let exact = if rest = None then 1L else 0L in
|
|
let nth i =
|
|
ex p.loc
|
|
(Ast.Call (var p.loc "destructure~nth",
|
|
[ t;
|
|
ex p.loc (Ast.Int (Int64.of_int i));
|
|
ex p.loc (Ast.Int (Int64.of_int n));
|
|
ex p.loc (Ast.Int exact) ]))
|
|
in
|
|
let rec each i = function
|
|
| [] -> []
|
|
| e :: more -> destructure e (nth i) @ each (i + 1) more
|
|
in
|
|
let rest_binding =
|
|
match rest with
|
|
| None -> []
|
|
| Some r ->
|
|
(* An ordinary (slice t n (len t)): the tail of the temporary, which is a
|
|
local and outlives the body that reads it. Nothing new. *)
|
|
let name =
|
|
match r.v with
|
|
| Sym s -> s
|
|
| _ ->
|
|
Loc.fail r.loc
|
|
"& binds one name for the tail, and %s is not one — the tail is a \
|
|
slice, so it cannot be destructured further" (Form.to_string r)
|
|
in
|
|
[ { Ast.bname = name; bty = None; bloc = r.loc;
|
|
bval =
|
|
ex r.loc
|
|
(Ast.Call (var r.loc "slice",
|
|
[ t;
|
|
ex r.loc (Ast.Int (Int64.of_int n));
|
|
ex r.loc (Ast.Call (var r.loc "len", [ t ])) ])) } ]
|
|
in
|
|
each 0 elems @ rest_binding
|
|
|
|
(* One pattern binding the same name twice is a mistake, not a shadowing: the
|
|
second would win and the first would bind nothing. Across a let's bindings it
|
|
*is* shadowing and stays legal, so this looks at one pattern at a time. *)
|
|
and no_duplicates (p : Form.t) (bs : Ast.binding list) =
|
|
let rec go seen = function
|
|
| [] -> ()
|
|
| (b : Ast.binding) :: rest ->
|
|
if String.contains b.Ast.bname '~' then go seen rest
|
|
else if List.mem b.Ast.bname seen then
|
|
Loc.fail b.Ast.bloc "this pattern binds %s twice" b.Ast.bname
|
|
else go (b.Ast.bname :: seen) rest
|
|
in
|
|
ignore p; go [] bs
|
|
|
|
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)
|
|
(* Not a place. spec-memory.md gives a map an upsert of its own — [put]
|
|
either inserts or replaces — so there is no store into a lookup, and an
|
|
entry that is absent has no location to store into. Refused here rather
|
|
than parsed into a place form the language does not have. *)
|
|
| List ({ v = Sym "get"; _ } :: _) ->
|
|
fail f "(get m k) is not a place — a map is written with (put m k v)"
|
|
| List [ { v = Sym "deref"; _ }; p ] -> Ast.Pderef (expr p)
|
|
| _ ->
|
|
fail f
|
|
"%s is not assignable. set takes a name, (.field x), (at a i ...), \
|
|
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 ("declare" | "declare-c" as which); _ } :: args) ->
|
|
(* (declare name [param Type ...] ReturnType? "c_symbol"). The C symbol is
|
|
last and is always written: a foreign name is not derivable from a Flan
|
|
one, and guessing it would fail at link time rather than here.
|
|
|
|
[declare-c] is the same shape and a different claim about the symbol.
|
|
[declare]'s signature IS the C signature, already flattened by whoever
|
|
wrote the C; [declare-c]'s is the *library's* — structs by value — and
|
|
[Shim] generates the flattening. The two cannot be one form, because
|
|
(declare f [p string] ...) already means the symbol takes ptr+len and
|
|
(declare-c f [p string] ...) means it takes a NUL-terminated char *. *)
|
|
let mkd fn csym =
|
|
if String.equal which "declare-c" then Ast.DeclareC (fn, csym)
|
|
else Ast.Declare (fn, csym)
|
|
in
|
|
let usage =
|
|
Printf.sprintf
|
|
"%s is (%s name [param Type ...] ReturnType? \"c_symbol\")" which which
|
|
in
|
|
(match List.rev args with
|
|
| { v = Str csym; _ } :: rest ->
|
|
(match List.rev rest with
|
|
| [ n; { v = Form.Vec ps; _ } ] ->
|
|
mk (mkd { Ast.name = sym n; params = fields f ps;
|
|
ret = None; fbody = []; nloc = n.loc } csym)
|
|
| [ n; { v = Form.Vec ps; _ }; r ] ->
|
|
mk (mkd { Ast.name = sym n; params = fields f ps;
|
|
ret = Some (texpr r); fbody = []; nloc = n.loc } csym)
|
|
| _ -> fail f "%s" usage)
|
|
| _ -> fail f "%s" usage)
|
|
|
|
| List ({ v = Sym "defenum"; _ } :: args) ->
|
|
(match args with
|
|
| [ n; { v = Form.Vec ms; _ } ] ->
|
|
let rec pairs = function
|
|
| [] -> []
|
|
| { v = Form.Sym m; _ } :: { v = Form.Int k; _ } :: rest ->
|
|
(m, k) :: pairs rest
|
|
| bad :: _ ->
|
|
fail bad "an enum member is a name followed by an integer, found %s"
|
|
(Form.to_string bad)
|
|
in
|
|
mk (Ast.Defenum (sym n, pairs ms))
|
|
| _ -> fail f "defenum is (defenum Name [member value ...])")
|
|
|
|
| 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)")
|
|
|
|
(* Checked for shape and then refused, which is deliberate. Getting the shape
|
|
wrong and getting the whole feature are two different mistakes, and a
|
|
"defmacro is (defmacro ...)" that only ever fired after expansion landed
|
|
would be a rule nothing enforced in the meantime.
|
|
|
|
The refusal is not about parsing. Expanding a macro means running it, and
|
|
there is no interpreter — the compiled path is the only backend. So it
|
|
means compiling the macro and dlopening it into the compiler, which is
|
|
what Emit.redefinition and Build.shared already do for the dev loop.
|
|
NEXT.md writes down how that goes together. *)
|
|
| List ({ v = Sym "defmacro"; _ } :: args) ->
|
|
(match args with
|
|
| n :: { v = Form.Vec ps; _ } :: body when body <> [] ->
|
|
let name = sym n in
|
|
List.iter (fun (p : Form.t) -> ignore (sym p)) ps;
|
|
fail f
|
|
"defmacro %s parses, but is not expanded: running a macro means \
|
|
compiling it and loading it into the compiler, which is not wired \
|
|
up yet (NEXT.md says what it needs)" name
|
|
| _ ->
|
|
fail f "defmacro is (defmacro name [param ...] body ...)")
|
|
|
|
| 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
|
|
temps := 0;
|
|
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 = temps := 0; decl (declared_types [ f ]) f
|