A macro body counts as run in order only when nothing outside its templates depends on how the body splits into arguments, a let whose longer scope would reach a macro naming it stays in a do: block, and converted programs with shadowed names and macro bodies print what their paren originals print
This commit is contained in:
parent
e18b28be3e
commit
0e26af2107
@ -1,121 +1,185 @@
|
||||
(** Which macros take a body run in order, and at which argument it starts.
|
||||
(** What the indented printer needs to know of macros: which take a body run
|
||||
in order and at which argument it starts, and which names their
|
||||
expansions spell.
|
||||
|
||||
Read off each macro's definition: a macro whose rest parameter is spliced,
|
||||
whole or from a fixed index on, only into places whose forms run in order
|
||||
— a [do], the body of a [let], [fn], [when], [while] or [loop], or the body
|
||||
of another such macro — takes a body there. [comment] counts too: nothing
|
||||
in it runs. The indented printer lets a [let] in such a body take in the
|
||||
statements after it, as it does in a [do].
|
||||
A body is read off the macro's definition. A macro whose rest parameter
|
||||
is spliced, whole or from a fixed index on, only into places whose forms
|
||||
run in order — a [do], the body of a [let], [fn], [when], [while] or
|
||||
[loop], or the body of another such macro — takes a body there, provided
|
||||
nothing else of it depends on how the body is split into arguments: out
|
||||
of its templates the rest parameter may only be counted against the
|
||||
body's start ([(< (length r) 1)]), read before the body ([(at r 0)] when
|
||||
the body starts at 1), or have the body's first form tested with a
|
||||
predicate ([(form-empty-list? (at r 0))]), since a [let] taking in the
|
||||
forms after it changes how many there are and nothing about the first.
|
||||
[comment] counts too: nothing in it runs. The printer lets a [let] in such
|
||||
a body take in the statements after it, as it does in a [do].
|
||||
|
||||
What a macro does with its arguments outside its templates (a guard that
|
||||
counts them, say) is not looked at. *)
|
||||
The names a template spells outside its unquotes are what its expansion
|
||||
can refer to without its call spelling them: a [let] of one of those
|
||||
names is not given a longer scope over a call of that macro. *)
|
||||
|
||||
type t = (string, int) Hashtbl.t
|
||||
type t = {
|
||||
bodies : (string, int) Hashtbl.t; (** called name -> argument the body starts at *)
|
||||
names : (string, string list) Hashtbl.t; (** called name -> names its templates spell *)
|
||||
}
|
||||
|
||||
let create () = { bodies = Hashtbl.create 32; names = Hashtbl.create 64 }
|
||||
|
||||
(* Core forms whose trailing arguments are a body run in order, and how many
|
||||
arguments come before it. *)
|
||||
let core = [ ("do", 0); ("let", 1); ("fn", 1); ("when", 1); ("while", 1); ("loop", 1);
|
||||
("defer", 0); ("with-allocator", 1) ]
|
||||
|
||||
let lookup (known : string -> int option) h =
|
||||
match List.assoc_opt h core with Some k -> Some k | None -> known h
|
||||
let body_start (t : t) h =
|
||||
match List.assoc_opt h core with Some k -> Some k | None -> Hashtbl.find_opt t.bodies h
|
||||
|
||||
(* The argument index the body starts at, from [(defmacro name [p ... & r]
|
||||
body ...)]; [None] when it does not take one. *)
|
||||
let of_defmacro ~(known : string -> int option) (f : Form.t) : (string * int) option =
|
||||
(* The names a template spells outside its unquotes. *)
|
||||
let rec template_names (f : Form.t) acc =
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym "comment"; _ } :: _) ->
|
||||
Some ("comment", 0)
|
||||
| Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ }
|
||||
:: { v = Form.Vec ps; _ } :: body) ->
|
||||
| Form.List ({ v = Form.Sym ("unquote" | "unquote-splicing"); _ } :: _) -> acc
|
||||
| Form.Sym s -> s :: acc
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.fold_left (fun a x -> template_names x a) acc l
|
||||
| _ -> acc
|
||||
|
||||
let rec templates (f : Form.t) acc =
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> x :: acc
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.fold_left (fun a x -> templates x a) acc l
|
||||
| _ -> acc
|
||||
|
||||
(* The argument index the body of [(defmacro name [p ... & r] body ...)]
|
||||
starts at, or [None]. [known] gives another macro's. *)
|
||||
let body_of ~(known : string -> int option) name ps body : int option =
|
||||
if name = "comment" then Some 0
|
||||
else
|
||||
let rec split fixed = function
|
||||
| { Form.v = Form.Sym "&"; _ } :: [ { Form.v = Form.Sym r; _ } ] -> Some (fixed, r)
|
||||
| { Form.v = Form.Sym "&"; _ } :: _ -> None
|
||||
| _ :: rest -> split (fixed + 1) rest
|
||||
| [] -> None
|
||||
in
|
||||
(match split 0 ps with
|
||||
| None -> None
|
||||
| Some (fixed, r) ->
|
||||
let rec mentions (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.Sym s -> s = r
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.exists mentions l
|
||||
| _ -> false
|
||||
in
|
||||
(* Each splice of the rest parameter: [Some k] when it splices from
|
||||
argument [k] of the rest on into a place run in order. *)
|
||||
let starts = ref [] and bad = ref false in
|
||||
let splice_from (e : Form.t) =
|
||||
match e.v with
|
||||
| Form.Sym s when s = r -> Some 0
|
||||
| Form.List [ { v = Form.Sym "form-rest"; _ }; { v = Form.Sym s; _ };
|
||||
{ v = Form.Int k; _ } ] when s = r -> Some (Int64.to_int k)
|
||||
| _ -> None
|
||||
in
|
||||
let rec template (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym "unquote"; _ } :: e) ->
|
||||
(* [~(at r i)] reads one argument, which is fine before the body
|
||||
and not in it; the check is made once the body's start is
|
||||
known. Anything else of [r] under an unquote is not followed. *)
|
||||
List.iter
|
||||
(fun (e : Form.t) ->
|
||||
match e.v with
|
||||
| Form.List [ { v = Form.Sym "at"; _ }; { v = Form.Sym s; _ };
|
||||
{ v = Form.Int i; _ } ] when s = r ->
|
||||
starts := `Read (Int64.to_int i) :: !starts
|
||||
| _ -> if mentions e then bad := true)
|
||||
e
|
||||
| Form.List l ->
|
||||
let head = match l with { v = Form.Sym h; _ } :: _ -> Some h | _ -> None in
|
||||
List.iteri
|
||||
(fun i (x : Form.t) ->
|
||||
match x.v with
|
||||
| Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] ->
|
||||
(match splice_from e, Option.bind head (lookup known) with
|
||||
| Some k, Some b when i >= b + 1 -> starts := `Body k :: !starts
|
||||
| Some _, _ -> bad := true
|
||||
| None, _ -> if mentions e then bad := true)
|
||||
| _ -> template x)
|
||||
l
|
||||
| Form.Vec l | Form.Map l -> List.iter template l
|
||||
| _ -> ()
|
||||
in
|
||||
let rec code (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> template x
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.iter code l
|
||||
| _ -> ()
|
||||
in
|
||||
List.iter code body;
|
||||
let bodies = List.filter_map (function `Body k -> Some k | _ -> None) !starts in
|
||||
let reads = List.filter_map (function `Read i -> Some i | _ -> None) !starts in
|
||||
match bodies with
|
||||
| k :: more when (not !bad) && List.for_all (( = ) k) more
|
||||
&& List.for_all (fun i -> i < k) reads ->
|
||||
Some (name, fixed + k)
|
||||
| _ -> None)
|
||||
| _ -> None
|
||||
match split 0 ps with
|
||||
| None -> None
|
||||
| Some (fixed, r) ->
|
||||
let is_r (f : Form.t) = f.v = Form.Sym r in
|
||||
let rec mentions (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.Sym s -> s = r
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.exists mentions l
|
||||
| _ -> false
|
||||
in
|
||||
let int (f : Form.t) = match f.v with Form.Int i -> Some (Int64.to_int i) | _ -> None in
|
||||
let at_r (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym "at"; _ }; x; i ] when is_r x -> int i
|
||||
| _ -> None
|
||||
in
|
||||
let bodies = ref [] and reads = ref [] and bad = ref false in
|
||||
(* Splices of [r] in a template, each where it lands. *)
|
||||
let splice_from (e : Form.t) =
|
||||
match e.v with
|
||||
| Form.Sym s when s = r -> Some 0
|
||||
| Form.List [ { v = Form.Sym "form-rest"; _ }; x; k ] when is_r x -> int k
|
||||
| _ -> None
|
||||
in
|
||||
let lookup h = match List.assoc_opt h core with Some k -> Some k | None -> known h in
|
||||
let rec template (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym "unquote"; _ }; e ] ->
|
||||
(match at_r e with
|
||||
| Some i -> reads := i :: !reads
|
||||
| None -> if mentions e then bad := true)
|
||||
| Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] ->
|
||||
(* Anywhere but in a list's items: a vector, a map. *)
|
||||
if mentions e then bad := true
|
||||
| Form.List l ->
|
||||
let head = match l with { v = Form.Sym h; _ } :: _ -> Some h | _ -> None in
|
||||
(* A label after while, until or dotimes comes before the test. *)
|
||||
let label =
|
||||
match head, l with
|
||||
| Some ("while" | "until" | "dotimes"), _ :: { v = Form.Kw _; _ } :: _ -> 1
|
||||
| _ -> 0
|
||||
in
|
||||
List.iteri
|
||||
(fun i (x : Form.t) ->
|
||||
match x.v with
|
||||
| Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] ->
|
||||
(match splice_from e, Option.bind head lookup with
|
||||
| Some k, Some b when i >= b + 1 + label -> bodies := k :: !bodies
|
||||
| _ -> if mentions e then bad := true)
|
||||
| _ -> template x)
|
||||
l
|
||||
| Form.Vec l | Form.Map l ->
|
||||
List.iter
|
||||
(fun (x : Form.t) ->
|
||||
match x.v with
|
||||
| Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] ->
|
||||
if mentions e then bad := true
|
||||
| _ -> template x)
|
||||
l
|
||||
| _ -> ()
|
||||
in
|
||||
(* The macro's own code, out of its templates: [r] only counted, read
|
||||
before the body, or its first form tested. [k] is the body's start
|
||||
within [r], known once the templates are read. *)
|
||||
let rec code k (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> template x
|
||||
| Form.Sym s when s = r -> bad := true
|
||||
| Form.List [ { v = Form.Sym ("<" | ">=" | "=" | "<=" | ">"); _ }; a; b ] ->
|
||||
(match a.v, b.v with
|
||||
| Form.List [ { v = Form.Sym "length"; _ }; x ], _ when is_r x ->
|
||||
(match int b with Some c when c <= k + 1 -> () | _ -> code k b; bad := true)
|
||||
| _, Form.List [ { v = Form.Sym "length"; _ }; x ] when is_r x ->
|
||||
(match int a with Some c when c <= k + 1 -> () | _ -> code k a; bad := true)
|
||||
| _ -> code k a; code k b)
|
||||
| Form.List [ { v = Form.Sym p; _ }; e ]
|
||||
when String.length p > 1 && p.[String.length p - 1] = '?' && at_r e <> None ->
|
||||
(match at_r e with Some i when i <= k -> () | _ -> bad := true)
|
||||
| Form.List _ when at_r f <> None ->
|
||||
(match at_r f with Some i when i < k -> () | _ -> bad := true)
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.iter (code k) l
|
||||
| _ -> ()
|
||||
in
|
||||
(* The templates first, for [k]; then the rest of the code against it. *)
|
||||
List.iter (fun t -> template t) (List.fold_left (fun a x -> templates x a) [] body);
|
||||
match !bodies with
|
||||
| k :: more when (not !bad) && List.for_all (( = ) k) more
|
||||
&& List.for_all (fun i -> i < k) !reads ->
|
||||
List.iter (code k) body;
|
||||
if !bad then None else Some (fixed + k)
|
||||
| _ -> None
|
||||
|
||||
let add (tbl : t) ~qualify ~known forms =
|
||||
let add (t : t) ~qualify forms =
|
||||
let local = Hashtbl.create 8 in
|
||||
List.iter
|
||||
(fun f ->
|
||||
match of_defmacro ~known:(fun h ->
|
||||
match Hashtbl.find_opt local h with Some k -> Some k | None -> known h) f with
|
||||
| Some (name, k) -> Hashtbl.replace local name k; Hashtbl.replace tbl (qualify name) k
|
||||
| None -> ())
|
||||
(fun (f : Form.t) ->
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ }
|
||||
:: { v = Form.Vec ps; _ } :: body) ->
|
||||
let known h =
|
||||
match Hashtbl.find_opt local h with
|
||||
| Some k -> Some k
|
||||
| None -> Hashtbl.find_opt t.bodies h
|
||||
in
|
||||
Hashtbl.replace t.names (qualify name)
|
||||
(List.fold_left (fun a x -> template_names x a) []
|
||||
(List.fold_left (fun a x -> templates x a) [] body));
|
||||
(match body_of ~known name ps body with
|
||||
| Some k -> Hashtbl.replace local name k; Hashtbl.replace t.bodies (qualify name) k
|
||||
(* A definition of the same name as a prelude macro replaces it. *)
|
||||
| None -> Hashtbl.remove local name; Hashtbl.remove t.bodies (qualify name))
|
||||
| _ -> ())
|
||||
forms
|
||||
|
||||
(** The prelude's macros, those of the packages [forms] imports (qualified
|
||||
by their alias) and [forms]' own. An import that cannot be found or read
|
||||
adds nothing. *)
|
||||
let table ?file (forms : Form.t list) : t =
|
||||
let tbl = Hashtbl.create 32 in
|
||||
let t = create () in
|
||||
let prelude = try Reader.read_all ~file:Prelude.file Prelude.source with _ -> [] in
|
||||
add tbl ~qualify:Fun.id ~known:(fun _ -> None) prelude;
|
||||
let known h = Hashtbl.find_opt tbl h in
|
||||
add t ~qualify:Fun.id prelude;
|
||||
(match file with
|
||||
| None -> ()
|
||||
| Some file ->
|
||||
@ -125,8 +189,8 @@ let table ?file (forms : Form.t list) : t =
|
||||
let d = Load.resolve_dir ~file loc path in
|
||||
let files = if Sys.is_directory d then Load.source_entries d else [ d ] in
|
||||
let fs = List.concat_map Source.read_file files in
|
||||
add tbl ~qualify:(fun n -> alias ^ "/" ^ n) ~known fs
|
||||
add t ~qualify:(fun n -> alias ^ "/" ^ n) fs
|
||||
with _ -> ())
|
||||
(Load.imports_of forms));
|
||||
add tbl ~qualify:Fun.id ~known forms;
|
||||
tbl
|
||||
add t ~qualify:Fun.id forms;
|
||||
t
|
||||
|
||||
@ -95,7 +95,7 @@ let in_quasi (f : Form.t) k =
|
||||
|
||||
(* Macros whose trailing arguments are a body run in order, by the name they
|
||||
are called by, and the argument the body starts at. Set by [program]. *)
|
||||
let macros : Body_macros.t ref = ref (Hashtbl.create 1)
|
||||
let macros : Body_macros.t ref = ref (Body_macros.create ())
|
||||
|
||||
(* Every name spelled in the top-level form being printed, and every part of
|
||||
a dotted or slashed one: a new name is none of them. *)
|
||||
@ -109,10 +109,16 @@ let rec note_used (f : Form.t) =
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.iter note_used l
|
||||
| _ -> ()
|
||||
|
||||
(* Each new name, and the name it was made from: renaming [x-3] again makes
|
||||
[x-4], not [x-3-2]. *)
|
||||
let made : (string, string) Hashtbl.t = Hashtbl.create 16
|
||||
|
||||
let fresh n =
|
||||
let n = Option.value (Hashtbl.find_opt made n) ~default:n in
|
||||
let rec go i =
|
||||
let c = n ^ "-" ^ string_of_int i in
|
||||
if Hashtbl.mem used c then go (i + 1) else (Hashtbl.replace used c (); c)
|
||||
if Hashtbl.mem used c then go (i + 1)
|
||||
else (Hashtbl.replace used c (); Hashtbl.replace made c n; c)
|
||||
in
|
||||
go 2
|
||||
|
||||
@ -165,7 +171,8 @@ let binds n t = match pat_names t with Some ns -> List.mem n ns | None -> false
|
||||
(* Whether [f] mentions [n]: the name, or a field path or qualified name
|
||||
starting with it. Any occurrence counts, a quoted one or one under an
|
||||
unquote included. A macro whose expansion names a variable its call does
|
||||
not spell is the one case this cannot see. *)
|
||||
not spell is [flatten]'s to see, through [!macros.names]; one defined
|
||||
nowhere [Body_macros.table] reads is the case nothing here can see. *)
|
||||
let rec mentions n (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.Sym s -> s = n || prefixed (n ^ ".") s || prefixed (n ^ "/") s
|
||||
@ -258,10 +265,23 @@ let flatten (f : Form.t) (rest : Form.t list) =
|
||||
Option.bind
|
||||
(all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs))
|
||||
(fun names ->
|
||||
let clash =
|
||||
List.filter (fun n -> List.exists (refers n) rest)
|
||||
(List.sort_uniq compare (List.concat names))
|
||||
(* A call of a macro whose expansion names one of [ns]: that name
|
||||
in the expansion means whatever is in scope where it lands, so
|
||||
the let's scope may not newly reach it and a name it means may
|
||||
not be renamed. *)
|
||||
let rec captures ns (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym m; _ } :: _)
|
||||
when (match Hashtbl.find_opt !macros.names m with
|
||||
| Some ms -> List.exists (fun n -> List.mem n ms) ns
|
||||
| None -> false) -> true
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.exists (captures ns) l
|
||||
| _ -> false
|
||||
in
|
||||
let names = List.sort_uniq compare (List.concat names) in
|
||||
let clash = List.filter (fun n -> List.exists (refers n) rest) names in
|
||||
if List.exists (captures names) rest || List.exists (captures clash) body then None
|
||||
else
|
||||
List.fold_left
|
||||
(fun acc n -> Option.bind acc (fun (bs, body) -> rename_let n (fresh n) bs body))
|
||||
(Some (bs, body)) clash
|
||||
@ -542,14 +562,25 @@ let body_split (h : Form.t) args =
|
||||
| None, Form.Sym s ->
|
||||
(* A body with a [let] in it is written as a block, where the [let] can
|
||||
be flat. *)
|
||||
(match Hashtbl.find_opt !macros s with
|
||||
(match Hashtbl.find_opt !macros.bodies s with
|
||||
| Some b when List.exists let_sugar (List.filteri (fun i _ -> i >= b) args) ->
|
||||
Some (b, true)
|
||||
| _ -> None)
|
||||
| _ ->
|
||||
(* Any other call with a [let] among its arguments: the trailing run
|
||||
of lists as a block, each [let] in a [do:] of its own, rather than
|
||||
the [let] written as a call. *)
|
||||
if List.exists let_sugar args then begin
|
||||
let k = ref 0 in
|
||||
List.iteri (fun i (a : Form.t) ->
|
||||
match a.v with Form.List (_ :: _) -> () | _ -> k := i + 1) args;
|
||||
if List.exists let_sugar (List.filteri (fun i _ -> i >= !k) args)
|
||||
then Some (!k, false) else None
|
||||
end
|
||||
else None)
|
||||
| None, _ -> None
|
||||
| Some k, Form.Sym s ->
|
||||
let n = List.length args in
|
||||
(match List.assoc_opt s Body_macros.core, Hashtbl.find_opt !macros s with
|
||||
(match List.assoc_opt s Body_macros.core, Hashtbl.find_opt !macros.bodies s with
|
||||
| Some b, _ | None, Some b when b < n -> Some (b, true)
|
||||
| _ -> Some (k, List.mem s [ "defmacro"; "defmethod" ]))
|
||||
| Some k, _ -> Some (k, false)
|
||||
@ -954,6 +985,7 @@ let program ?source ?macros:m (fs : Form.t list) : string =
|
||||
that is not last goes in a [do:] block. *)
|
||||
let top x =
|
||||
Hashtbl.reset used;
|
||||
Hashtbl.reset made;
|
||||
note_used x;
|
||||
String.concat "\n" (stmt 0 x)
|
||||
in
|
||||
|
||||
@ -187,9 +187,13 @@ Each item: the proposal, then the reason in one line.
|
||||
another such macro's body; `comment` counts too. Where a rename cannot be
|
||||
trusted (the name quoted, qualified as `x/y`, or called as `x(...)`), and
|
||||
at the top level, among a call's other arguments and in a quasiquote, the
|
||||
`let` goes in a `do:` block instead. One case this cannot see: a macro
|
||||
whose expansion names a variable its call does not spell can pick up a
|
||||
`let`'s name that now reaches further.
|
||||
`let` goes in a `do:` block instead, and so does one whose longer scope
|
||||
would reach a call of a macro whose template names the `let`'s name. A
|
||||
macro's body counts only if nothing but its templates depends on how the
|
||||
body splits into arguments (a count against the body's start, a predicate
|
||||
on its first form). One case this cannot see: a macro defined nowhere the
|
||||
printer reads (not the prelude, the file or an imported package) whose
|
||||
expansion names a variable its call does not spell.
|
||||
Destructuring: `let {.x .y} = p`, `let [head & tail] = xs`. (`defer` is
|
||||
function-scoped, not let-scoped, `TODO.org` "defer may be written in a let",
|
||||
so merging never moves a cleanup.) **Built**; `let x =` with the value as an
|
||||
|
||||
6
test/syntax/flat/capture.flan
Normal file
6
test/syntax/flat/capture.flan
Normal file
@ -0,0 +1,6 @@
|
||||
(defmacro show-it [] `(println it))
|
||||
(defn main [] i32
|
||||
(let [it 1]
|
||||
(let [it 2] (show-it))
|
||||
(show-it))
|
||||
0)
|
||||
46
test/syntax/flat/macros.flan
Normal file
46
test/syntax/flat/macros.flan
Normal file
@ -0,0 +1,46 @@
|
||||
;; Macro bodies the .fln printer must classify from their definitions:
|
||||
;; test_syntax converts this file, runs both and wants the same output.
|
||||
|
||||
;; Counts its body forms: a let taking in the form after it would change the
|
||||
;; count, so the body is not one a let may be flattened in.
|
||||
(defmacro counted [& body]
|
||||
(let [two (= (length body) 2)]
|
||||
`(do (println ~(if two (Form.Sym {.s "true"}) (Form.Sym {.s "false"}))) ~@body)))
|
||||
|
||||
;; Replaces the prelude's unless, and counts too.
|
||||
(defmacro unless [& args]
|
||||
(let [two (= (length args) 3)]
|
||||
`(do (println ~(if two (Form.Sym {.s "true"}) (Form.Sym {.s "false"}))) ~@(form-rest args 1))))
|
||||
|
||||
;; The body once in a do and once as a vector's elements.
|
||||
(defmacro vtwice [& body]
|
||||
`(do ~@body (println (length [~@body]))))
|
||||
|
||||
;; The first body form is the loop's test.
|
||||
(defmacro labelled [& body]
|
||||
`(while :l ~@body))
|
||||
|
||||
;; A guard that only asks whether there is a body: a body run in order.
|
||||
(defmacro guarded [& args]
|
||||
(if (< (length args) 1)
|
||||
`(do)
|
||||
`(do ~@args)))
|
||||
|
||||
(defn main [] i32
|
||||
(counted
|
||||
(let [x 1] (println x))
|
||||
(println 2))
|
||||
(unless false
|
||||
(let [y 3] (println y))
|
||||
(println 4))
|
||||
(vtwice
|
||||
(let [z 5] (println z) z)
|
||||
6)
|
||||
(labelled
|
||||
(let [go false] go)
|
||||
(println 9))
|
||||
(let [g 0]
|
||||
(guarded
|
||||
(let [g 1] (println g))
|
||||
(println g)))
|
||||
0)
|
||||
85
test/syntax/flat/shadows.flan
Normal file
85
test/syntax/flat/shadows.flan
Normal file
@ -0,0 +1,85 @@
|
||||
(defstruct P [x i32 y i32])
|
||||
(defn app [g (Fn [i32] i32) v i32] i32 (g v))
|
||||
|
||||
(defn shadow-chain [] ()
|
||||
(let [x 1]
|
||||
(let [x (+ x 10)]
|
||||
(println x))
|
||||
(println x)
|
||||
(let [x (+ x 100)]
|
||||
(println x)
|
||||
(let [x (* x 2)] (println x))
|
||||
(println x))
|
||||
(println x)))
|
||||
|
||||
(defn closes [] i32
|
||||
(let [x 1]
|
||||
(let [x 5]
|
||||
(println x))
|
||||
(let [f 0]
|
||||
(app (fn [y] (+ x y)) (+ f 2)))))
|
||||
|
||||
(defn loopy [] ()
|
||||
(let [i 0]
|
||||
(while (< i 5)
|
||||
(let [i (* i 100)]
|
||||
(println i))
|
||||
(set i (+ i 1))
|
||||
(when (= i 3) (continue))
|
||||
(println i))))
|
||||
|
||||
(defn loopr [] i32
|
||||
(loop [n 0 acc 0]
|
||||
(let [n (* n 2)]
|
||||
(println n))
|
||||
(if (< n 4) (recur (+ n 1) (+ acc n)) acc)))
|
||||
|
||||
(defn ret [a i32] i32
|
||||
(let [a (+ a 1)]
|
||||
(println a))
|
||||
(when (> a 3)
|
||||
(let [a 0] (println a))
|
||||
(return a))
|
||||
(let [a (- a 1)] (println a))
|
||||
a)
|
||||
|
||||
(defn deferring [] ()
|
||||
(let [x 1]
|
||||
(let [x 2]
|
||||
(defer (println x)))
|
||||
(defer (println x))
|
||||
(println "body")))
|
||||
|
||||
(defn destr [] ()
|
||||
(let [p (P {.x 3 .y 4}) x 100]
|
||||
(let [{.x .y} p]
|
||||
(println (+ x y)))
|
||||
(println x)
|
||||
(let [{:keys [x]} p]
|
||||
(println x))
|
||||
(println x)
|
||||
(let [[a b] [x 7]]
|
||||
(println a))
|
||||
(println x)))
|
||||
|
||||
(defn dos [c bool] i32
|
||||
(let [v 0]
|
||||
(if c
|
||||
(do (let [v 5] (println v)) (println v))
|
||||
(do (let [v 6] (println v)) (println v)))
|
||||
(unless c (let [v 9] (println v)) (println v))
|
||||
(when c (let [v 8] (println v)) (println v))
|
||||
v))
|
||||
|
||||
(defn main [] i32
|
||||
(shadow-chain)
|
||||
(println (closes))
|
||||
(loopy)
|
||||
(println (loopr))
|
||||
(println (ret 5))
|
||||
(println (ret 1))
|
||||
(deferring)
|
||||
(destr)
|
||||
(println (dos true))
|
||||
(println (dos false))
|
||||
0)
|
||||
@ -138,7 +138,7 @@ let canon (f : Form.t) : Form.t =
|
||||
go [] f
|
||||
|
||||
(* The macros of the file being compared ([Body_macros.table]). *)
|
||||
let macros : Body_macros.t ref = ref (Hashtbl.create 1)
|
||||
let macros : Body_macros.t ref = ref (Body_macros.create ())
|
||||
|
||||
(* Where the statements of a body start, for a head whose trailing arguments
|
||||
are a body run in order. *)
|
||||
@ -159,7 +159,7 @@ let body_start (l : Form.t list) =
|
||||
| h ->
|
||||
(match List.assoc_opt h Body_macros.core with
|
||||
| Some k -> Some (k + 1)
|
||||
| None -> Option.map (fun k -> k + 1) (Hashtbl.find_opt !macros h)))
|
||||
| None -> Option.map (fun k -> k + 1) (Hashtbl.find_opt !macros.bodies h)))
|
||||
| _ -> None
|
||||
|
||||
let is_let (f : Form.t) =
|
||||
@ -654,6 +654,40 @@ let () =
|
||||
"(defmacro listed [& xs] `(list ~@xs))\n(defn f [] () (listed (let [a 1] (g a)) (set x 2)))"
|
||||
" listed:\n do:\n let a = 1\n g(a)\n x = 2";
|
||||
prints "comment is a body in order" "(comment (let [a 1] (g a)) (h))" "comment:\n let a = 1\n g(a)\n h()";
|
||||
prints "a later lambda keeps the outer name"
|
||||
"(defn f [] i32 (let [x 1] (let [x 5] (g x)) (app (fn [y] (+ x y)) 2)))"
|
||||
" let x = 1\n let x-2 = 5\n g(x-2)\n app(fn(y) = x + y, 2)";
|
||||
prints "a renamed name renamed again counts on"
|
||||
"(defn f [] () (let [x 1] (let [x 2] (let [x 3] (g x)) (g x)) (g x)))"
|
||||
" let x = 1\n let x-2 = 2\n let x-3 = 3\n g(x-3)\n g(x-2)\n g(x)";
|
||||
prints "a macro that names the let's name keeps its scope"
|
||||
"(defmacro show-it [] `(println it))\n(defn f [] () (let [it 1] (let [it 2] (show-it)) (show-it)))"
|
||||
" let it = 1\n do:\n let it = 2\n show-it()\n show-it()";
|
||||
(* Which macros take a body run in order, read off their definitions. *)
|
||||
let body name src want =
|
||||
let t = Body_macros.table (Reader.read_all ~file:"<m>" src) in
|
||||
let got = Hashtbl.find_opt t.Body_macros.bodies name in
|
||||
if got <> want then
|
||||
fail "%s: body at %s, wanted %s" name
|
||||
(match got with Some k -> string_of_int k | None -> "none")
|
||||
(match want with Some k -> string_of_int k | None -> "none")
|
||||
in
|
||||
body "twice" "(defmacro twice [n & b] `(do ~@b ~@b))" (Some 1);
|
||||
body "tail" "(defmacro tail [& a] `(let [x ~(at a 0)] ~@(form-rest a 1)))" (Some 1);
|
||||
body "nested" "(defmacro inner [& b] `(do ~@b))\n(defmacro nested [& b] `(inner ~@b))" (Some 0);
|
||||
body "listed" "(defmacro listed [& b] `(list ~@b))" None;
|
||||
body "vtwice" "(defmacro vtwice [& b] `(do ~@b (println (length [~@b]))))" None;
|
||||
body "counted" "(defmacro counted [& b] (let [n (length b)] `(do ~n ~@b)))" None;
|
||||
body "counts" "(defmacro counts [& b] (if (= (length b) 2) `(do) `(do ~@b)))" None;
|
||||
body "guarded" "(defmacro guarded [& b] (if (< (length b) 1) `(do) `(do ~@b)))" (Some 0);
|
||||
body "labelled" "(defmacro labelled [& b] `(while :l ~@b))" None;
|
||||
body "labelled-test" "(defmacro labelled-test [& b] `(while :l true ~@b))" (Some 0);
|
||||
body "reads-body" "(defmacro reads-body [& b] `(do ~(at b 0) ~@b))" None;
|
||||
body "unless" "" (Some 1);
|
||||
body "comment" "" (Some 0);
|
||||
body "with-drawing"
|
||||
"(defmacro with-drawing [& args]\n (if (or (< (length args) 1) (and (= (length args) 1) (form-empty-list? (at args 0))))\n `(takes-a-body)\n `(do (begin) ~@args (end))))"
|
||||
(Some 0);
|
||||
prints "in a quasiquote" "(defmacro m [x] (quasiquote (do (let [a 1] (g a)) (h ~x))))"
|
||||
" do:\n let a = 1\n g(a)\n h(~x)";
|
||||
prints "among a call's arguments" "(foo 1 (let [a 1] (g a)) (set x 2))"
|
||||
@ -907,8 +941,41 @@ let run_both path want =
|
||||
(if x86 then " --x86" else "") text code want)
|
||||
[ false; true ]
|
||||
|
||||
(* A program and its conversion print the same: the flat lets, the renames
|
||||
and the macro bodies they rest on keep what each name means. *)
|
||||
let run_converted path =
|
||||
let run p =
|
||||
let exe = Filename.concat scratch
|
||||
(Printf.sprintf "flan-flat-%s-%d" (Filename.basename p) (Unix.getpid ())) in
|
||||
let prog, csrcs, lflags = Test_support.linked p in
|
||||
ignore (Build.executable ~opts:Build.default ~csrcs ~lflags prog ~out:exe);
|
||||
let out = exe ^ ".out" in
|
||||
let code = Sys.command (Filename.quote exe ^ " > " ^ Filename.quote out ^ " 2>&1") in
|
||||
let text = In_channel.with_open_bin out In_channel.input_all in
|
||||
(try Sys.remove out; Sys.remove exe with Sys_error _ -> ());
|
||||
(code, text)
|
||||
in
|
||||
match
|
||||
let forms = Reader.read_file path in
|
||||
let source = In_channel.with_open_bin path In_channel.input_all in
|
||||
let macros = Body_macros.table ~file:path forms in
|
||||
let fln = Filename.concat scratch
|
||||
(Printf.sprintf "%d-%s.fln" (Unix.getpid ()) (Filename.remove_extension (Filename.basename path))) in
|
||||
Out_channel.with_open_bin fln (fun oc ->
|
||||
output_string oc (Indent_printer.program ~source ~macros forms));
|
||||
let a = run path and b = run fln in
|
||||
(try Sys.remove fln with Sys_error _ -> ());
|
||||
(a, b)
|
||||
with
|
||||
| exception e -> fail "%s converted: %s" path (diag_text e)
|
||||
| ((0, a), (0, b)) when a = b -> ()
|
||||
| ((c, a), (d, b)) ->
|
||||
fail "%s printed %S (exit %d), and converted %S (exit %d)" path a c b d
|
||||
|
||||
let () =
|
||||
if Test_support.have "clang" then begin
|
||||
List.iter run_converted
|
||||
[ "syntax/flat/shadows.flan"; "syntax/flat/macros.flan"; "syntax/flat/capture.flan" ];
|
||||
run_both "syntax/mixed/main.flan" "12\n12\n0\n55\n";
|
||||
run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n"
|
||||
end
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user