From 0e26af21076f1835382453bc9c69c92243fdd849 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 23:00:27 +0700 Subject: [PATCH] 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 --- lib/body_macros.ml | 252 +++++++++++++++++++++------------- lib/indent_printer.ml | 50 +++++-- spec-syntax.md | 10 +- test/syntax/flat/capture.flan | 6 + test/syntax/flat/macros.flan | 46 +++++++ test/syntax/flat/shadows.flan | 85 ++++++++++++ test/test_syntax.ml | 71 +++++++++- 7 files changed, 412 insertions(+), 108 deletions(-) create mode 100644 test/syntax/flat/capture.flan create mode 100644 test/syntax/flat/macros.flan create mode 100644 test/syntax/flat/shadows.flan diff --git a/lib/body_macros.ml b/lib/body_macros.ml index 28dd6084..f03c0d9d 100644 --- a/lib/body_macros.ml +++ b/lib/body_macros.ml @@ -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 diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index da818b98..844f2dda 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -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 diff --git a/spec-syntax.md b/spec-syntax.md index 8356c938..5f05b1ef 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -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 diff --git a/test/syntax/flat/capture.flan b/test/syntax/flat/capture.flan new file mode 100644 index 00000000..99916cf7 --- /dev/null +++ b/test/syntax/flat/capture.flan @@ -0,0 +1,6 @@ +(defmacro show-it [] `(println it)) +(defn main [] i32 + (let [it 1] + (let [it 2] (show-it)) + (show-it)) + 0) diff --git a/test/syntax/flat/macros.flan b/test/syntax/flat/macros.flan new file mode 100644 index 00000000..c76b1965 --- /dev/null +++ b/test/syntax/flat/macros.flan @@ -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) diff --git a/test/syntax/flat/shadows.flan b/test/syntax/flat/shadows.flan new file mode 100644 index 00000000..87dd7fa0 --- /dev/null +++ b/test/syntax/flat/shadows.flan @@ -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) diff --git a/test/test_syntax.ml b/test/test_syntax.ml index ff748c81..611a2161 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -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:"" 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