JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 23:00:27 +07:00
parent e18b28be3e
commit 0e26af2107
7 changed files with 412 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

252
lib/body_macros.ml
View File

@ -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, A body is read off the macro's definition. A macro whose rest parameter
whole or from a fixed index on, only into places whose forms run in order is spliced, whole or from a fixed index on, only into places whose forms
— a [do], the body of a [let], [fn], [when], [while] or [loop], or the body run in order — a [do], the body of a [let], [fn], [when], [while] or
of another such macro — takes a body there. [comment] counts too: nothing [loop], or the body of another such macro — takes a body there, provided
in it runs. The indented printer lets a [let] in such a body take in the nothing else of it depends on how the body is split into arguments: out
statements after it, as it does in a [do]. 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 The names a template spells outside its unquotes are what its expansion
counts them, say) is not looked at. *) 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 (* Core forms whose trailing arguments are a body run in order, and how many
arguments come before it. *) arguments come before it. *)
let core = [ ("do", 0); ("let", 1); ("fn", 1); ("when", 1); ("while", 1); ("loop", 1); let core = [ ("do", 0); ("let", 1); ("fn", 1); ("when", 1); ("while", 1); ("loop", 1);
("defer", 0); ("with-allocator", 1) ] ("defer", 0); ("with-allocator", 1) ]
let lookup (known : string -> int option) h = let body_start (t : t) h =
match List.assoc_opt h core with Some k -> Some k | None -> known 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] (* The names a template spells outside its unquotes. *)
body ...)]; [None] when it does not take one. *) let rec template_names (f : Form.t) acc =
let of_defmacro ~(known : string -> int option) (f : Form.t) : (string * int) option =
match f.v with match f.v with
| Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym "comment"; _ } :: _) -> | Form.List ({ v = Form.Sym ("unquote" | "unquote-splicing"); _ } :: _) -> acc
Some ("comment", 0) | Form.Sym s -> s :: acc
| Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ } | Form.List l | Form.Vec l | Form.Map l -> List.fold_left (fun a x -> template_names x a) acc l
:: { v = Form.Vec ps; _ } :: body) -> | _ -> 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 let rec split fixed = function
| { Form.v = Form.Sym "&"; _ } :: [ { Form.v = Form.Sym r; _ } ] -> Some (fixed, r) | { Form.v = Form.Sym "&"; _ } :: [ { Form.v = Form.Sym r; _ } ] -> Some (fixed, r)
| { Form.v = Form.Sym "&"; _ } :: _ -> None | { Form.v = Form.Sym "&"; _ } :: _ -> None
| _ :: rest -> split (fixed + 1) rest | _ :: rest -> split (fixed + 1) rest
| [] -> None | [] -> None
in in
(match split 0 ps with match split 0 ps with
| None -> None | None -> None
| Some (fixed, r) -> | Some (fixed, r) ->
let rec mentions (f : Form.t) = let is_r (f : Form.t) = f.v = Form.Sym r in
match f.v with let rec mentions (f : Form.t) =
| Form.Sym s -> s = r match f.v with
| Form.List l | Form.Vec l | Form.Map l -> List.exists mentions l | Form.Sym s -> s = r
| _ -> false | Form.List l | Form.Vec l | Form.Map l -> List.exists mentions l
in | _ -> false
(* Each splice of the rest parameter: [Some k] when it splices from in
argument [k] of the rest on into a place run in order. *) let int (f : Form.t) = match f.v with Form.Int i -> Some (Int64.to_int i) | _ -> None in
let starts = ref [] and bad = ref false in let at_r (f : Form.t) =
let splice_from (e : Form.t) = match f.v with
match e.v with | Form.List [ { v = Form.Sym "at"; _ }; x; i ] when is_r x -> int i
| Form.Sym s when s = r -> Some 0 | _ -> None
| Form.List [ { v = Form.Sym "form-rest"; _ }; { v = Form.Sym s; _ }; in
{ v = Form.Int k; _ } ] when s = r -> Some (Int64.to_int k) let bodies = ref [] and reads = ref [] and bad = ref false in
| _ -> None (* Splices of [r] in a template, each where it lands. *)
in let splice_from (e : Form.t) =
let rec template (f : Form.t) = match e.v with
match f.v with | Form.Sym s when s = r -> Some 0
| Form.List ({ v = Form.Sym "unquote"; _ } :: e) -> | Form.List [ { v = Form.Sym "form-rest"; _ }; x; k ] when is_r x -> int k
(* [~(at r i)] reads one argument, which is fine before the body | _ -> None
and not in it; the check is made once the body's start is in
known. Anything else of [r] under an unquote is not followed. *) let lookup h = match List.assoc_opt h core with Some k -> Some k | None -> known h in
List.iter let rec template (f : Form.t) =
(fun (e : Form.t) -> match f.v with
match e.v with | Form.List [ { v = Form.Sym "unquote"; _ }; e ] ->
| Form.List [ { v = Form.Sym "at"; _ }; { v = Form.Sym s; _ }; (match at_r e with
{ v = Form.Int i; _ } ] when s = r -> | Some i -> reads := i :: !reads
starts := `Read (Int64.to_int i) :: !starts | None -> if mentions e then bad := true)
| _ -> if mentions e then bad := true) | Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] ->
e (* Anywhere but in a list's items: a vector, a map. *)
| Form.List l -> if mentions e then bad := true
let head = match l with { v = Form.Sym h; _ } :: _ -> Some h | _ -> None in | Form.List l ->
List.iteri let head = match l with { v = Form.Sym h; _ } :: _ -> Some h | _ -> None in
(fun i (x : Form.t) -> (* A label after while, until or dotimes comes before the test. *)
match x.v with let label =
| Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] -> match head, l with
(match splice_from e, Option.bind head (lookup known) with | Some ("while" | "until" | "dotimes"), _ :: { v = Form.Kw _; _ } :: _ -> 1
| Some k, Some b when i >= b + 1 -> starts := `Body k :: !starts | _ -> 0
| Some _, _ -> bad := true in
| None, _ -> if mentions e then bad := true) List.iteri
| _ -> template x) (fun i (x : Form.t) ->
l match x.v with
| Form.Vec l | Form.Map l -> List.iter template l | Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] ->
| _ -> () (match splice_from e, Option.bind head lookup with
in | Some k, Some b when i >= b + 1 + label -> bodies := k :: !bodies
let rec code (f : Form.t) = | _ -> if mentions e then bad := true)
match f.v with | _ -> template x)
| Form.List [ { v = Form.Sym "quasiquote"; _ }; x ] -> template x l
| Form.List l | Form.Vec l | Form.Map l -> List.iter code l | Form.Vec l | Form.Map l ->
| _ -> () List.iter
in (fun (x : Form.t) ->
List.iter code body; match x.v with
let bodies = List.filter_map (function `Body k -> Some k | _ -> None) !starts in | Form.List [ { v = Form.Sym "unquote-splicing"; _ }; e ] ->
let reads = List.filter_map (function `Read i -> Some i | _ -> None) !starts in if mentions e then bad := true
match bodies with | _ -> template x)
| k :: more when (not !bad) && List.for_all (( = ) k) more l
&& List.for_all (fun i -> i < k) reads -> | _ -> ()
Some (name, fixed + k) in
| _ -> None) (* The macro's own code, out of its templates: [r] only counted, read
| _ -> None 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 let local = Hashtbl.create 8 in
List.iter List.iter
(fun f -> (fun (f : Form.t) ->
match of_defmacro ~known:(fun h -> match f.v with
match Hashtbl.find_opt local h with Some k -> Some k | None -> known h) f with | Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ }
| Some (name, k) -> Hashtbl.replace local name k; Hashtbl.replace tbl (qualify name) k :: { v = Form.Vec ps; _ } :: body) ->
| None -> ()) 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 forms
(** The prelude's macros, those of the packages [forms] imports (qualified (** 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 by their alias) and [forms]' own. An import that cannot be found or read
adds nothing. *) adds nothing. *)
let table ?file (forms : Form.t list) : t = 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 let prelude = try Reader.read_all ~file:Prelude.file Prelude.source with _ -> [] in
add tbl ~qualify:Fun.id ~known:(fun _ -> None) prelude; add t ~qualify:Fun.id prelude;
let known h = Hashtbl.find_opt tbl h in
(match file with (match file with
| None -> () | None -> ()
| Some file -> | Some file ->
@ -125,8 +189,8 @@ let table ?file (forms : Form.t list) : t =
let d = Load.resolve_dir ~file loc path in 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 files = if Sys.is_directory d then Load.source_entries d else [ d ] in
let fs = List.concat_map Source.read_file files 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 _ -> ()) with _ -> ())
(Load.imports_of forms)); (Load.imports_of forms));
add tbl ~qualify:Fun.id ~known forms; add t ~qualify:Fun.id forms;
tbl t

50
lib/indent_printer.ml
View File

@ -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 (* 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]. *) 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 (* 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. *) 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 | 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 fresh n =
let n = Option.value (Hashtbl.find_opt made n) ~default:n in
let rec go i = let rec go i =
let c = n ^ "-" ^ string_of_int i in 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 in
go 2 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 (* 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 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 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) = let rec mentions n (f : Form.t) =
match f.v with match f.v with
| Form.Sym s -> s = n || prefixed (n ^ ".") s || prefixed (n ^ "/") s | 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 Option.bind
(all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs)) (all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs))
(fun names -> (fun names ->
let clash = (* A call of a macro whose expansion names one of [ns]: that name
List.filter (fun n -> List.exists (refers n) rest) in the expansion means whatever is in scope where it lands, so
(List.sort_uniq compare (List.concat names)) 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 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 List.fold_left
(fun acc n -> Option.bind acc (fun (bs, body) -> rename_let n (fresh n) bs body)) (fun acc n -> Option.bind acc (fun (bs, body) -> rename_let n (fresh n) bs body))
(Some (bs, body)) clash (Some (bs, body)) clash
@ -542,14 +562,25 @@ let body_split (h : Form.t) args =
| None, Form.Sym s -> | None, Form.Sym s ->
(* A body with a [let] in it is written as a block, where the [let] can (* A body with a [let] in it is written as a block, where the [let] can
be flat. *) 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 when List.exists let_sugar (List.filteri (fun i _ -> i >= b) args) ->
Some (b, true) 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 | None, _ -> None
| Some k, Form.Sym s -> | Some k, Form.Sym s ->
let n = List.length args in 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 b, _ | None, Some b when b < n -> Some (b, true)
| _ -> Some (k, List.mem s [ "defmacro"; "defmethod" ])) | _ -> Some (k, List.mem s [ "defmacro"; "defmethod" ]))
| Some k, _ -> Some (k, false) | 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. *) that is not last goes in a [do:] block. *)
let top x = let top x =
Hashtbl.reset used; Hashtbl.reset used;
Hashtbl.reset made;
note_used x; note_used x;
String.concat "\n" (stmt 0 x) String.concat "\n" (stmt 0 x)
in in

10
spec-syntax.md
View File

@ -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 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 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 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 `let` goes in a `do:` block instead, and so does one whose longer scope
whose expansion names a variable its call does not spell can pick up a would reach a call of a macro whose template names the `let`'s name. A
`let`'s name that now reaches further. 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 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", 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 so merging never moves a cleanup.) **Built**; `let x =` with the value as an

6
test/syntax/flat/capture.flan Normal file
View 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
View 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
View 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)

71
test/test_syntax.ml
View File

@ -138,7 +138,7 @@ let canon (f : Form.t) : Form.t =
go [] f go [] f
(* The macros of the file being compared ([Body_macros.table]). *) (* 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 (* Where the statements of a body start, for a head whose trailing arguments
are a body run in order. *) are a body run in order. *)
@ -159,7 +159,7 @@ let body_start (l : Form.t list) =
| h -> | h ->
(match List.assoc_opt h Body_macros.core with (match List.assoc_opt h Body_macros.core with
| Some k -> Some (k + 1) | 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 | _ -> None
let is_let (f : Form.t) = 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)))" "(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"; " 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 "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))))" 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)"; " 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))" 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) (if x86 then " --x86" else "") text code want)
[ false; true ] [ 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 () = let () =
if Test_support.have "clang" then begin 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.flan" "12\n12\n0\n55\n";
run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n" run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n"
end end