flan/lib/expand.ml

(** Macro expansion: the pass between the reader and [Parse].

    There is no interpreter and there is not going to be one (docs/BUILT.md, "Why
    there is no interpreter"), so running a macro at compile time means
    compiling it and loading it into this process. Every piece of that is
    already built and measured — [Emit.macro_thunk], [Build.macro_module],
    [Dynload] — and this file is the two halves nobody had written: the image
    format the two sides share, and the walk that finds macro calls and
    replaces them.

    Expansion runs over [Form], before [Parse]. Not over [Ast]: [Parse] refuses
    [defmacro] outright and there is no [Ast.Defmacro], so an Ast-level pass
    would have nothing to work with. That refusal is the ordering. It is also
    Clojure's ordering, and it is why a macro expanding to a special form is
    ordinary here rather than a special case. *)

(* ── The image format ──────────────────────────────────────────────
   A Form is { i32 tag, [2 x i64] payload }: 24 bytes, align 8, payload at
   offset 8. Those three numbers are the whole agreement between this file and
   the compiled macro, and they are not taken on trust — test_acceptance.ml's
   "Form's image format" asks LLVM for each of them through the same ptrtoint
   oracle the DWARF offsets go through. Change the prelude's defdata and that
   test says which number moved.

   The tag is the case's position in the prelude's (defdata Form ...), which
   is why that list is a layout contract and says so. *)

let form_size = 24
let payload = 8

(* A string and a slice are both %slice = { ptr, i64 }: two words at the start
   of the payload. Every case of Form holds one member, so there is no third
   offset anywhere below. *)
let ptr_off = payload
let len_off = payload + 8

type tag =
  | TSym | TKw | TInt | TFloat | TStr | TByte | TList | TVec | TMap

let tag_int = function
  | TSym -> 0l | TKw -> 1l | TInt -> 2l | TFloat -> 3l | TStr -> 4l
  | TByte -> 5l | TList -> 6l | TVec -> 7l | TMap -> 8l

let tag_of_int = function
  | 0l -> TSym | 1l -> TKw | 2l -> TInt | 3l -> TFloat | 4l -> TStr
  | 5l -> TByte | 6l -> TList | 7l -> TVec | 8l -> TMap
  | n ->
    failwith
      (Printf.sprintf
         "a macro returned a Form with tag %ld, and Form has nine cases. The \
          prelude's (defdata Form ...) and lib/expand.ml's tag list are one \
          contract and have come apart"
         n)

(* ── Writing a Form into memory a macro can read ───────────────────
   OCaml cannot address raw memory, so this goes through the poke family in
   dynload_stubs.c, one field at a time. Everything allocated here is owned by
   [Dynload] and released together after the call. *)

(* Into an existing 24 bytes, which is what an argument array needs: the macro
   takes a [Form] slice, and a slice is contiguous elements and not an array of
   pointers — so this writes *into* memory the caller took, and every caller
   here takes it as part of an array. *)
let rec write p (f : Form.t) =
  let tag t = Dynload.poke_i32 p 0 (tag_int t) in
  let str t s =
    tag t;
    let n = String.length s in
    (* A zero-length string still gets a pointer, because a slice with a null
       base is not the same value as one with a live base and a zero length --
       the difference shows the day something concatenates onto it. *)
    let b = Dynload.take (max n 1) in
    if n > 0 then Dynload.poke_bytes b 0 s;
    Dynload.poke_ptr p ptr_off b;
    Dynload.poke_i64 p len_off (Int64.of_int n)
  in
  let seq t xs =
    tag t;
    let n = List.length xs in
    let b = Dynload.take (max (n * form_size) 1) in
    List.iteri (fun i x -> write (Nativeint.add b (Nativeint.of_int (i * form_size))) x) xs;
    Dynload.poke_ptr p ptr_off b;
    Dynload.poke_i64 p len_off (Int64.of_int n)
  in
  match f.Form.v with
  | Form.Sym s -> str TSym s
  | Form.Kw s -> str TKw s
  | Form.Str s -> str TStr s
  | Form.Int i -> tag TInt; Dynload.poke_i64 p payload i
  | Form.Float x -> tag TFloat; Dynload.poke_f64 p payload x
  | Form.Byte b -> tag TByte; Dynload.poke_i32 p payload (Int32.of_int b)
  | Form.List xs -> seq TList xs
  | Form.Vec xs -> seq TVec xs
  | Form.Map xs -> seq TMap xs

(* ── Reading one back ──────────────────────────────────────────────
   [loc] is the call site's, stamped onto every node. A macro cannot invent a
   source location and the image has no room for one: Form on the Flan side
   mirrors [Form.value], not [Form.t]. So an error inside an expansion points
   at the call that produced it, which is the part of "the error carries the
   expansion" that can be had now without the structured-error rewrite. *)

let rec unmarshal ~loc (p : Dynload.addr) : Form.t =
  let str () =
    let b = Dynload.peek_ptr p ptr_off in
    let n = Int64.to_int (Dynload.peek_i64 p len_off) in
    if n = 0 then "" else Dynload.peek_bytes b 0 n
  in
  let seq () =
    let b = Dynload.peek_ptr p ptr_off in
    let n = Int64.to_int (Dynload.peek_i64 p len_off) in
    List.init n (fun i ->
      unmarshal ~loc (Nativeint.add b (Nativeint.of_int (i * form_size))))
  in
  let v =
    match tag_of_int (Dynload.peek_i32 p 0) with
    | TSym -> Form.Sym (str ())
    | TKw -> Form.Kw (str ())
    | TStr -> Form.Str (str ())
    | TInt -> Form.Int (Dynload.peek_i64 p payload)
    | TFloat -> Form.Float (Dynload.peek_f64 p payload)
    | TByte -> Form.Byte (Int32.to_int (Dynload.peek_i32 p payload) land 0xff)
    | TList -> Form.List (seq ())
    | TVec -> Form.Vec (seq ())
    | TMap -> Form.Map (seq ())
  in
  Form.make v loc

(* ── One call ──────────────────────────────────────────────────────
   The arguments are one contiguous run of Forms, not an array of pointers,
   because the macro's parameter is [[Form]] and a Flan slice is { ptr, len }
   over elements. *)

let call ~loc (fn : Dynload.addr) (args : Form.t list) : Form.t =
  let n = List.length args in
  let a = Dynload.take (max (n * form_size) 1) in
  List.iteri
    (fun i x -> write (Nativeint.add a (Nativeint.of_int (i * form_size))) x)
    args;
  let out = Dynload.take form_size in
  Dynload.call fn a (Int64.of_int n) out;
  unmarshal ~loc out

(* ── Quasiquote ────────────────────────────────────────────────────
   A desugaring over [Form], and nothing more: a quasiquoted (if ~t ~b) becomes
   calls to the prelude's form-building surface, which the checker then sees as
   ordinary code. There is no quasiquote left in the language after this runs,
   which is why the expander's own walk needs no idea that quoting exists: by
   the time it looks for macro calls, a [cond] written inside a quasiquote is a
   (Form.Sym {.s "cond"}) and there is no head there to mistake for a call the
   compiler should make now.

   The reader stays dumb and produces (quasiquote x), (unquote x) and
   (unquote-splicing x) with no idea whether one is inside another. Counting
   levels is this file's job, and it does not: a quasiquote inside a quasiquote
   is refused by name. A macro that writes a macro is the only thing that wants
   one, nothing in the corpus does, and CL's level arithmetic has a real cost
   that no use case has asked for. *)

let sym loc s = Form.make (Form.Sym s) loc
let lst loc xs = Form.make (Form.List xs) loc

(* (Form.Case {.field value}) — a node of the image, written as the Flan
   constructor the prelude declares. *)
let node loc case field v =
  lst loc [ sym loc ("Form." ^ case);
            Form.make (Form.Map [ sym loc ("." ^ field); Form.make v loc ]) loc ]

let unquote_of (f : Form.t) =
  match f.Form.v with
  | Form.List [ { Form.v = Form.Sym "unquote"; _ }; x ] -> Some x
  | _ -> None

let splice_of (f : Form.t) =
  match f.Form.v with
  | Form.List [ { Form.v = Form.Sym "unquote-splicing"; _ }; x ] -> Some x
  | _ -> None

let rec quote (f : Form.t) : Form.t =
  let loc = f.Form.loc in
  match unquote_of f with
  (* The escape: whatever the program wrote, evaluated. It is already a Form,
     because a Form is what a macro body deals in. *)
  | Some x -> x
  | None ->
    match splice_of f with
    | Some _ ->
      Loc.fail loc
        "~@x splices into a list or a vector, and there is nothing here for it \
         to splice into"
    | None ->
      match f.Form.v with
      | Form.List ({ Form.v = Form.Sym "quasiquote"; _ } :: _) ->
        Loc.fail loc
          "a quasiquote inside a quasiquote is not implemented: the reader does \
           not count nesting levels and neither does this, so the inner one has \
           no meaning to give. Build the inner form with form-cons"
      | Form.Sym s -> node loc "Sym" "s" (Form.Str s)
      | Form.Kw s -> node loc "Kw" "s" (Form.Str s)
      | Form.Int i -> node loc "Int" "i" (Form.Int i)
      | Form.Float x -> node loc "Float" "x" (Form.Float x)
      | Form.Str s -> node loc "Str" "s" (Form.Str s)
      | Form.Byte b -> node loc "Byte" "b" (Form.Int (Int64.of_int b))
      | Form.List xs -> node loc "List" "xs" (seq loc xs).Form.v
      | Form.Vec xs -> node loc "Vec" "xs" (seq loc xs).Form.v
      | Form.Map xs -> node loc "Map" "xs" (seq loc xs).Form.v

(* The [Form] slice one bracket's worth of items comes to. Built right to left,
   so each item is consed onto what follows it and a splice is an append — the
   three prelude functions and no fourth. *)
and seq loc items =
  List.fold_left
    (fun acc (item : Form.t) ->
       match splice_of item with
       | Some x -> lst item.Form.loc [ sym item.Form.loc "form-append"; x; acc ]
       | None -> lst item.Form.loc [ sym item.Form.loc "form-cons"; quote item; acc ])
    (lst loc [ sym loc "form-nil" ])
    (List.rev items)

(* Every quasiquote in a form, outermost first. Pure, total, and dependent on
   nothing but Form, which is what lets [Parse] run it on the way in rather
   than needing the whole expander wired up first. *)
let rec quasiquote (f : Form.t) : Form.t =
  match f.Form.v with
  | Form.List [ { Form.v = Form.Sym "quasiquote"; _ }; x ] -> quote x
  | Form.List xs -> Form.make (Form.List (List.map quasiquote xs)) f.Form.loc
  | Form.Vec xs -> Form.make (Form.Vec (List.map quasiquote xs)) f.Form.loc
  | Form.Map xs -> Form.make (Form.Map (List.map quasiquote xs)) f.Form.loc
  | _ -> f

(* ── A macro's parameter list ──────────────────────────────────────
   [(defmacro do-grid [[r rows c cols] & body] ...)] — positional parameters,
   a destructuring vector wherever one is written, and [&] for the tail. The
   grammar is [dvec]'s (lib/parse.ml), read over [Form] instead of over the
   values a [let] binds, because a macro's arguments *are* Forms.

   It lives here rather than in [Parse] because both sides of the feature need
   it and they are on opposite sides of the parser: [Parse] turns the list into
   the bindings a macro body opens with, and [Macro] checks a call against it
   before the macro is ever run. This file is below both and depends on nothing
   above [Form], which is what lets them share one reading of the list.

   Map destructuring is not here. [dmap] is [{:keys [x y]}] over a *struct*, and
   a macro's argument is a [Form] whose [Map] case is a flat list of alternating
   forms with no field names in it at all — the pattern would have to mean
   something new rather than the same thing over a different value. Refused by
   name below, and written down in FIX.org. *)

type pat =
  | Pname of string * Loc.t
  (* A [ ] in the parameter list: the argument at this position must be a
     [Form.Vec], and its elements are matched against these in turn. *)
  (* The [Form] is the pattern as written: a refusal shows the shape the call
     failed to match, and nothing else can render it back. *)
  | Pvec of pat list * (string * Loc.t) option * Form.t

type msig = {
  ps   : pat list;                  (* the positional parameters, in order *)
  rest : (string * Loc.t) option;   (* [& name], if there is one *)
  src  : Form.t;                    (* the list as written, for the messages *)
}

(* [a b & rest], shared by the top level and by every destructuring vector
   inside it. The three refusals are [dvec]'s, word for word where they say the
   same thing: one grammar, so one set of sentences about getting it wrong. *)
let split_amp (items : Form.t list) : Form.t list * (string * Loc.t) option =
  let rec go acc = function
    | [] -> (List.rev acc, None)
    | ({ Form.v = Form.Sym "&"; _ } as amp) :: rest ->
      (match rest with
       | [ { Form.v = Form.Sym r; loc } ] -> (List.rev acc, Some (r, loc))
       | [] -> Loc.fail amp.Form.loc "& needs a name after it, as in [a b & rest]"
       | [ bad ] ->
         Loc.fail bad.Form.loc
           "& binds one name for the rest of the arguments, and %s is not one \
            — the rest is a slice of forms, so it cannot be destructured \
            further"
           (Form.to_string bad)
       | _ :: extra :: _ ->
         Loc.fail extra.Form.loc
           "& takes one name and it is the last thing in the parameter list")
    | x :: rest -> go (x :: acc) rest
  in
  go [] items

(* Never handed a [&]: every list of items reaching here has been through
   [split_amp], which stops at the first one and refuses every way of getting
   the tail wrong itself. So there is no arm for it and no sentence about it. *)
let rec pat_of (f : Form.t) : pat =
  match f.Form.v with
  | Form.Sym s -> Pname (s, f.Form.loc)
  | Form.Vec items ->
    let elems, rest = split_amp items in
    (match elems, rest with
     | [], None ->
       Loc.fail f.Form.loc
         "an empty pattern [] in a macro's parameter list binds nothing — \
          write the names it should bind"
     | [], Some (r, loc) ->
       Loc.fail loc
         "[& %s] binds the whole vector — write %s on its own instead of a \
          pattern" r r
     | _ -> ());
    Pvec (List.map pat_of elems, rest, f)
  | Form.Map _ ->
    Loc.fail f.Form.loc
      "map destructuring is not implemented in a macro's parameter list — a \
       macro's argument is a Form, whose Map case is a flat run of alternating \
       forms with no fields to name. Take the form and pick it apart in the \
       body"
  | _ ->
    Loc.fail f.Form.loc
      "a macro's parameter is a name or a [ ] pattern over one, and %s is \
       neither"
      (Form.to_string f)

(* Every name the list binds, so that two of them can be refused where they are
   written rather than reaching the checker as a local declared twice. *)
let rec pat_names acc = function
  | Pname (s, loc) -> (s, loc) :: acc
  | Pvec (ps, rest, _) ->
    let acc = List.fold_left pat_names acc ps in
    (match rest with None -> acc | Some nl -> nl :: acc)

let params_of (v : Form.t) : msig =
  let items = match v.Form.v with
    | Form.Vec items -> items
    | _ ->
      Loc.fail v.Form.loc "a macro's parameter list is written in [ ], and %s is not"
        (Form.to_string v)
  in
  let elems, rest = split_amp items in
  let sg = { ps = List.map pat_of elems; rest; src = v } in
  let names = List.fold_left pat_names [] sg.ps in
  let names =
    match sg.rest with None -> names | Some nl -> nl :: names in
  let seen = Hashtbl.create 8 in
  List.iter
    (fun (n, loc) ->
       if Hashtbl.mem seen n then
         Loc.fail loc "%s is bound twice in this parameter list" n
       else Hashtbl.add seen n ())
    (List.rev names);
  sg

(* ── Checking a call against it ────────────────────────────────────
   Before expansion, so the location is the call's own and not the
   [Loc.from_macro] stamp every node of an expansion carries. That is the whole
   reason this is a separate pass rather than something the macro body could
   do: a macro has no error facility, and by the time its body runs the only
   location left is the one it was called from anyway — stamped onto forms the
   author never wrote. *)

let written (sg : msig) = Form.to_string sg.src

let arity (sg : msig) ~name ~loc (args : Form.t list) =
  let n = List.length sg.ps in
  let got = List.length args in
  let plural k = if k = 1 then "argument" else "arguments" in
  match sg.rest with
  | Some (r, _) when got < n ->
    Loc.fail loc
      "%s takes at least %d %s and this call gives %d — its parameter list is \
       %s, where &%s is the rest"
      name n (plural n) got (written sg) r
  | Some _ -> ()
  | None when got <> n ->
    Loc.fail loc
      "%s takes %d %s and this call gives %d — its parameter list is %s"
      name n (plural n) got (written sg)
  | None -> ()

let rec check_pat ~name (p : pat) (a : Form.t) =
  match p with
  | Pname _ -> ()
  | Pvec (ps, rest, src) ->
    let items =
      match a.Form.v with
      | Form.Vec items -> items
      | _ ->
        Loc.fail a.Form.loc
          "%s destructures this argument with %s, so a [ ] belongs here and \
           %s was written"
          name (Form.to_string src) (Form.to_string a)
    in
    let n = List.length ps in
    let got = List.length items in
    if (rest = None && got <> n) || got < n then
      Loc.fail a.Form.loc
        "%s destructures this argument with %s, which takes %s%d, and %d %s \
         written here"
        name (Form.to_string src)
        (if rest = None then "" else "at least ")
        n got (if got = 1 then "is" else "are");
    List.iteri (fun i q -> check_pat ~name q (List.nth items i)) ps

let check_call ~name ~loc (sg : msig) (args : Form.t list) =
  arity sg ~name ~loc args;
  List.iteri (fun i p -> check_pat ~name p (List.nth args i)) sg.ps