A .fln let is always flat, and flan convert writes flat lets, renaming a shadowed name instead of nesting
This commit is contained in:
commit
c1beb602a7
4
TODO.org
4
TODO.org
@ -315,10 +315,6 @@ keyword resolves against the expected type and against nothing else, so two enum
|
||||
could always share a member spelling. What the prefix buys is the call site read
|
||||
on its own.
|
||||
|
||||
** NEXT The .fln printer writes a flat let where the scope does not matter
|
||||
Decided 2026-09-25: a let whose name no later statement of its block mentions prints
|
||||
flat, not as a nested block; a one-argument and/or prints as its argument.
|
||||
|
||||
** WAIT ML-style patterns
|
||||
Held 2026-09-25 as a future direction, like the JS backend: nested destructuring,
|
||||
guards, or-patterns, literals at any depth, exhaustiveness over the nesting.
|
||||
|
||||
@ -337,7 +337,8 @@ let () =
|
||||
if Flan.Source.is_indented path then
|
||||
print_string (Flan.Paren_printer.program ~source forms)
|
||||
else
|
||||
match Flan.Indent_printer.program ~source forms with
|
||||
let macros = Flan.Body_macros.table ~file:path forms in
|
||||
match Flan.Indent_printer.program ~source ~macros forms with
|
||||
| text -> print_string text
|
||||
| exception Flan.Indent_printer.Unprintable (f, why) ->
|
||||
Flan.Loc.failk "convert/unprintable" f.Flan.Form.loc
|
||||
|
||||
196
lib/body_macros.ml
Normal file
196
lib/body_macros.ml
Normal file
@ -0,0 +1,196 @@
|
||||
(** 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.
|
||||
|
||||
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].
|
||||
|
||||
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 = {
|
||||
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 body_start (t : t) h =
|
||||
match List.assoc_opt h core with Some k -> Some k | None -> Hashtbl.find_opt t.bodies h
|
||||
|
||||
(* 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 ("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 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 (t : t) ~qualify forms =
|
||||
let local = Hashtbl.create 8 in
|
||||
List.iter
|
||||
(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 t = create () in
|
||||
let prelude = try Reader.read_all ~file:Prelude.file Prelude.source with _ -> [] in
|
||||
add t ~qualify:Fun.id prelude;
|
||||
(match file with
|
||||
| None -> ()
|
||||
| Some file ->
|
||||
List.iter
|
||||
(fun (alias, path, loc) ->
|
||||
try
|
||||
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 t ~qualify:(fun n -> alias ^ "/" ^ n) fs
|
||||
with _ -> ())
|
||||
(Load.imports_of forms));
|
||||
add t ~qualify:Fun.id forms;
|
||||
t
|
||||
@ -69,6 +69,226 @@ let rec same (a : Form.t) (b : Form.t) =
|
||||
|
||||
let is_sym s (f : Form.t) = match f.v with Form.Sym x -> x = s | _ -> false
|
||||
|
||||
(* Inside a quasiquote the forms are a template, not code: an unquote may put
|
||||
anything in place, a name a flat [let] would then capture included, so no
|
||||
[let] there takes in what follows it and no one-argument [and] is dropped. *)
|
||||
let quasi = ref 0
|
||||
|
||||
let in_quasi (f : Form.t) k =
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym "quasiquote"; _ } :: _) ->
|
||||
incr quasi;
|
||||
Fun.protect ~finally:(fun () -> decr quasi) k
|
||||
| _ -> k ()
|
||||
|
||||
(* ── Flat lets ─────────────────────────────────────────────────────── *)
|
||||
|
||||
(* A [let] in the indented syntax is always flat: [let x = v] scopes to the
|
||||
end of its block. So a [let] with statements after it in a body is printed
|
||||
as the [let] taking those statements into its own body. That changes
|
||||
nothing when none of them refers to a name it binds — a [let] is no frame
|
||||
and a [defer] is function-scoped, so the longer scope releases nothing
|
||||
later. When one does, the name is renamed inside the [let] to one the
|
||||
whole top-level form does not use. Where a rename cannot be trusted, or
|
||||
where the statements are not a body run in order, the [let] goes in a
|
||||
[do:] block of its own instead. *)
|
||||
|
||||
(* 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 (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. *)
|
||||
let used : (string, unit) Hashtbl.t = Hashtbl.create 64
|
||||
|
||||
let rec note_used (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.Sym s ->
|
||||
List.iter (fun p -> Hashtbl.replace used p ())
|
||||
(s :: List.concat_map (String.split_on_char '/') (String.split_on_char '.' s))
|
||||
| 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 (); Hashtbl.replace made c n; c)
|
||||
in
|
||||
go 2
|
||||
|
||||
let prefixed pre s =
|
||||
String.length s > String.length pre && String.sub s 0 (String.length pre) = pre
|
||||
|
||||
let dotted s = String.length s > 1 && s.[0] = '.'
|
||||
|
||||
let all f l =
|
||||
List.fold_right
|
||||
(fun x acc -> match f x, acc with Some y, Some ys -> Some (y :: ys) | _ -> None)
|
||||
l (Some [])
|
||||
|
||||
(* A struct pattern's entries as [name .field] pairs, in order: [.x] is
|
||||
[x .x], and [:keys [x y]] is [x .x y .y] ([Parse.dmap]). [None] for a
|
||||
shape [Parse] refuses. *)
|
||||
let struct_pairs (items : Form.t list) =
|
||||
let rec go = function
|
||||
| [] -> Some []
|
||||
| ({ Form.v = Form.Sym s; _ } as f) :: rest when dotted s ->
|
||||
let n = String.sub s 1 (String.length s - 1) in
|
||||
Option.map (fun r -> ({ f with v = Form.Sym n }, f) :: r) (go rest)
|
||||
| { Form.v = Form.Kw "keys"; _ } :: { Form.v = Form.Vec ns; _ } :: rest ->
|
||||
Option.bind
|
||||
(all (fun (n : Form.t) -> match n.v with
|
||||
| Form.Sym s -> Some (n, { n with v = Form.Sym ("." ^ s) })
|
||||
| _ -> None) ns)
|
||||
(fun ps -> Option.map (fun r -> ps @ r) (go rest))
|
||||
| pat :: ({ Form.v = Form.Sym s; _ } as f) :: rest when dotted s ->
|
||||
Option.map (fun r -> (pat, f) :: r) (go rest)
|
||||
| _ -> None
|
||||
in
|
||||
go items
|
||||
|
||||
(* The names a binding target binds, or [None] for a target [Parse] would
|
||||
refuse. *)
|
||||
let rec pat_names (t : Form.t) : string list option =
|
||||
match t.v with
|
||||
| Form.Sym s -> Some [ s ]
|
||||
| Form.Vec l ->
|
||||
Option.map List.concat
|
||||
(all (fun (x : Form.t) -> if x.v = Form.Sym "&" then Some [] else pat_names x) l)
|
||||
| Form.Map l ->
|
||||
Option.bind (struct_pairs l) (fun ps ->
|
||||
Option.map List.concat (all (fun (p, _) -> pat_names p) ps))
|
||||
| _ -> None
|
||||
|
||||
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 [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
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.exists (mentions n) l
|
||||
| _ -> false
|
||||
|
||||
(* [mentions], less what a [let] inside [f] rebinds before any use: a later
|
||||
[let a = ...] of the same name is a new [a], not the one before it. *)
|
||||
let rec refers n (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: body) ->
|
||||
let rec go = function
|
||||
| t :: v :: rest -> refers n v || ((not (binds n t)) && go rest)
|
||||
| [ t ] -> refers n t
|
||||
| [] -> List.exists (refers n) body
|
||||
in
|
||||
go bs
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.exists (refers n) l
|
||||
| _ -> mentions n f
|
||||
|
||||
(* A binding target with [n] renamed [n']. A struct pattern that binds [n]
|
||||
is written out as pairs, so the field keeps its name. *)
|
||||
let rec rename_pat n n' (t : Form.t) : Form.t option =
|
||||
match t.v with
|
||||
| Form.Sym s when s = n -> Some { t with v = Form.Sym n' }
|
||||
| Form.Sym _ -> Some t
|
||||
| Form.Vec l -> Option.map (fun l -> { t with v = Form.Vec l }) (all (rename_pat n n') l)
|
||||
| Form.Map l ->
|
||||
Option.bind (struct_pairs l) (fun ps ->
|
||||
if not (binds n t) then Some t
|
||||
else
|
||||
Option.map
|
||||
(fun ps -> { t with v = Form.Map (List.concat_map (fun (p, f) -> [ p; f ]) ps) })
|
||||
(all (fun (p, f) -> Option.map (fun p -> (p, f)) (rename_pat n n' p)) ps))
|
||||
| _ -> None
|
||||
|
||||
(* [f] with [n] renamed [n'], or [None] where the rename cannot be trusted:
|
||||
a quoted [n] is data, [n/x] names a package, and [(n ...)] may call a
|
||||
function of that name rather than the local. A [let] inside renames its
|
||||
targets as patterns. *)
|
||||
let rec rename n n' (f : Form.t) : Form.t option =
|
||||
match f.v with
|
||||
| Form.Sym s when s = n -> Some { f with v = Form.Sym n' }
|
||||
| Form.Sym s when prefixed (n ^ ".") s ->
|
||||
let k = String.length n in
|
||||
Some { f with v = Form.Sym (n' ^ String.sub s k (String.length s - k)) }
|
||||
| Form.Sym s when prefixed (n ^ "/") s -> None
|
||||
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) when mentions n f -> None
|
||||
| Form.List ({ v = Form.Sym s; _ } :: _) when s = n -> None
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: body) ->
|
||||
let rec go = function
|
||||
| t :: v :: rest ->
|
||||
(match rename_pat n n' t, rename n n' v, go rest with
|
||||
| Some t, Some v, Some r -> Some (t :: v :: r)
|
||||
| _ -> None)
|
||||
| rest -> all (rename n n') rest
|
||||
in
|
||||
(match go bs, all (rename n n') body with
|
||||
| Some bs, Some body -> Some { f with v = Form.List (h :: { bv with v = Form.Vec bs } :: body) }
|
||||
| _ -> None)
|
||||
| Form.List l -> Option.map (fun l -> { f with v = Form.List l }) (all (rename n n') l)
|
||||
| Form.Vec l -> Option.map (fun l -> { f with v = Form.Vec l }) (all (rename n n') l)
|
||||
| Form.Map l -> Option.map (fun l -> { f with v = Form.Map l }) (all (rename n n') l)
|
||||
| _ -> Some f
|
||||
|
||||
(* [n] renamed [n'] in a [let]'s bindings [bs] and [body], from the binding
|
||||
that binds it on: the values up to and including that binding's see the
|
||||
outer [n]. *)
|
||||
let rename_let n n' (bs : Form.t list) (body : Form.t list) =
|
||||
let rec go = function
|
||||
| t :: v :: rest when binds n t ->
|
||||
(* From here on, the rest reads as a [let] of its own. *)
|
||||
(match rename_pat n n' t,
|
||||
rename n n' { t with v = Form.List (Form.make (Form.Sym "let") t.loc
|
||||
:: Form.make (Form.Vec rest) t.loc :: body) } with
|
||||
| Some t', Some { v = Form.List (_ :: { v = Form.Vec rest'; _ } :: body'); _ } ->
|
||||
Some (t' :: v :: rest', body')
|
||||
| _ -> None)
|
||||
| t :: v :: rest -> Option.map (fun (r, b) -> (t :: v :: r, b)) (go rest)
|
||||
| _ -> Some (bs, body)
|
||||
in
|
||||
go bs
|
||||
|
||||
(* The [let] [f] taking [rest] in as the end of its body, its names that
|
||||
[rest] refers to renamed; [None] when a rename cannot be trusted. *)
|
||||
let flatten (f : Form.t) (rest : Form.t list) =
|
||||
match f.v with
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: (_ :: _ as body))
|
||||
when rest <> [] && bs <> [] && List.length bs mod 2 = 0 ->
|
||||
Option.bind
|
||||
(all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs))
|
||||
(fun 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
|
||||
|> Option.map (fun (bs, body) ->
|
||||
{ f with v = Form.List (h :: { bv with v = Form.Vec bs } :: (body @ rest)) }))
|
||||
| _ -> None
|
||||
|
||||
(* ── Expressions ───────────────────────────────────────────────────── *)
|
||||
|
||||
(* Text and syntactic level, the same scale [Indent_reader] reads: 10 an atom
|
||||
@ -94,7 +314,7 @@ let rec expr (f : Form.t) : string * int =
|
||||
| Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 10)
|
||||
| Form.Map xs -> ("{" ^ map_text xs ^ "}", 10)
|
||||
| Form.List [] -> ("()", 10)
|
||||
| Form.List (h :: args) -> list f h args
|
||||
| Form.List (h :: args) -> in_quasi f (fun () -> list f h args)
|
||||
|
||||
and sym f s =
|
||||
if s = "==" then unprintable f "the name == (it reads as =)"
|
||||
@ -166,6 +386,8 @@ and list _f h args =
|
||||
if l >= 9 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 8)
|
||||
else ("-(" ^ at 0 x ^ ")", 9)
|
||||
| Form.Sym "not", [ x ] -> ("not " ^ at 3 x, 3)
|
||||
(* [and] or [or] of one value is that value. *)
|
||||
| Form.Sym ("and" | "or"), [ x ] when !quasi = 0 -> expr x
|
||||
| Form.Sym "at", t :: (_ :: _ as idx) -> (at 9 t ^ "[" ^ commas idx ^ "]", 9)
|
||||
| Form.Sym s, [ t ]
|
||||
when String.length s > 1 && s.[0] = '.' && name_ok s
|
||||
@ -282,7 +504,7 @@ let stmts_of (f : Form.t) =
|
||||
| _ -> [ f ]
|
||||
|
||||
(* Heads whose trailing arguments are a body, and how many come before it. *)
|
||||
let body_split (h : Form.t) args =
|
||||
let body_guess (h : Form.t) args =
|
||||
match h.v with
|
||||
| Form.Sym s ->
|
||||
let base =
|
||||
@ -326,21 +548,70 @@ let body_split (h : Form.t) args =
|
||||
else None)
|
||||
| _ -> None
|
||||
|
||||
let let_sugar (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: _ :: _) ->
|
||||
(match pairs bs with None | Some [] -> false | Some _ -> true)
|
||||
| _ -> false
|
||||
|
||||
(* [Some (k, seq)]: the arguments from [k] on print as a block, and [seq]
|
||||
when that block is a body run in order ([Body_macros]), whose start the
|
||||
definition gives rather than the guess. *)
|
||||
let body_split (h : Form.t) args =
|
||||
match body_guess h args, h.v with
|
||||
| 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.bodies s with
|
||||
| Some b when List.exists let_sugar (List.filteri (fun i _ -> i >= b) args) ->
|
||||
Some (b, true)
|
||||
| _ ->
|
||||
(* 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.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)
|
||||
|
||||
let sugar_heads =
|
||||
[ "let"; "set"; "if"; "when"; "cond"; "while"; "until"; "dotimes"; "match";
|
||||
"handler-case"; "handler-bind"; "restart-case"; "return"; "defer"; "do";
|
||||
"quasiquote"; "update" ]
|
||||
|
||||
let rec block n (fs : Form.t list) : string list =
|
||||
|
||||
(* [(do x)]: printed as [do:] and [x] as the one statement of its block. *)
|
||||
let in_do (x : Form.t) = { x with v = Form.List [ Form.make (Form.Sym "do") x.loc; x ] }
|
||||
|
||||
(* [seq] when the block is a body run in order, where a [let] may take in
|
||||
the statements after it. Not for the arguments of a call that happen to
|
||||
print as a block, whose count that would change. *)
|
||||
let rec block ?(seq = true) n (fs : Form.t list) : string list =
|
||||
let rec go = function
|
||||
| [] -> []
|
||||
| [ x ] -> stmt n ~last:true x
|
||||
| x :: rest -> stmt n ~last:false x @ go rest
|
||||
| [ x ] -> stmt n x
|
||||
| x :: rest when let_sugar x ->
|
||||
(match (if seq && !quasi = 0 then flatten x rest else None) with
|
||||
| Some x' -> stmt n x'
|
||||
| None -> stmt n (in_do x) @ go rest)
|
||||
| x :: rest -> stmt n x @ go rest
|
||||
in
|
||||
go fs
|
||||
|
||||
and stmt n ~last (f : Form.t) : string list =
|
||||
let ls = match sugar n ~last f with Some ls -> ls | None -> plain n f in
|
||||
and stmt n (f : Form.t) : string list =
|
||||
in_quasi f @@ fun () ->
|
||||
let ls = match sugar n f with Some ls -> ls | None -> plain n f in
|
||||
(* The first line carries the line the form came from, for
|
||||
[Source_text.weave] to put the comments back by. *)
|
||||
match ls with
|
||||
@ -359,7 +630,7 @@ and plain n (f : Form.t) : string list =
|
||||
match f.v with
|
||||
| Form.List (h :: args) when args <> [] ->
|
||||
(match body_split h args with
|
||||
| Some k when k < List.length args ->
|
||||
| Some (k, seq) when k < List.length args ->
|
||||
let fixed = List.filteri (fun i _ -> i < k) args in
|
||||
let rest = List.filteri (fun i _ -> i >= k) args in
|
||||
let opener =
|
||||
@ -369,7 +640,7 @@ and plain n (f : Form.t) : string list =
|
||||
| Form.Sym s, [] when name_ok s && not (List.mem s reserved) -> s ^ ":"
|
||||
| _ -> head_text h ^ "(" ^ commas fixed ^ "):"
|
||||
in
|
||||
[ ind n ^ guard opener ] @ block (n + 2) rest
|
||||
[ ind n ^ guard opener ] @ block ~seq (n + 2) rest
|
||||
| _ when n + String.length text > width && fst (expr f) = text ->
|
||||
wrapped n "" f
|
||||
| _ -> one)
|
||||
@ -438,13 +709,13 @@ and label_of = function
|
||||
| ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
|
||||
| rest -> ("", rest)
|
||||
|
||||
and sugar n ~last (f : Form.t) : string list option =
|
||||
and sugar n (f : Form.t) : string list option =
|
||||
let i = ind n in
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) ->
|
||||
(match pairs bs with
|
||||
| None | Some [] -> None
|
||||
| Some prs -> Some (let_lines n ~last prs body))
|
||||
| Some prs -> Some (let_lines n prs body))
|
||||
| Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym ("+" | "-" | "*" | "/"); _ }; _ ]
|
||||
when not (R.simple_place t) ->
|
||||
Some [ i ^ guard (inline_text f) ]
|
||||
@ -590,7 +861,9 @@ and sugar n ~last (f : Form.t) : string list option =
|
||||
(match body with
|
||||
| [] -> Some [ head ]
|
||||
| [ x ] when (match x.v with
|
||||
| Form.List ({ v = Form.Sym h; _ } :: _) -> not (List.mem h sugar_heads)
|
||||
| Form.List (({ v = Form.Sym h; _ } as hf) :: args) ->
|
||||
(* A call that takes a block is a statement, not a value. *)
|
||||
not (List.mem h sugar_heads) && body_split hf args = None
|
||||
| _ -> true)
|
||||
&& String.length head + 3 + String.length (at 0 x) <= width
|
||||
&& not (!inside f) ->
|
||||
@ -675,10 +948,9 @@ and handler_clauses n cls =
|
||||
let cs = List.map clause cls in
|
||||
if List.mem None cs then None else Some (List.concat_map Option.get cs)
|
||||
|
||||
(* A [let] last in its block reads to the block's end, so it is written flat.
|
||||
One with siblings after it takes its body as an indented block under the
|
||||
first binding, and the rest of the bindings go inside that block. *)
|
||||
and let_lines n ~last prs body =
|
||||
(* A [let] is always written flat: [block] has made it the last statement of
|
||||
its block, so its body is the rest of the block. *)
|
||||
and let_lines n prs body =
|
||||
(* [(let [x (the T v)])] is [let x: T = v]. *)
|
||||
let bind ((t : Form.t), (v : Form.t)) =
|
||||
match t.v, v.v with
|
||||
@ -693,18 +965,13 @@ and let_lines n ~last prs body =
|
||||
| [] -> []
|
||||
in
|
||||
let lines n b = let p, v = bind b in tagged b (value_lines n p v) in
|
||||
if last then List.concat_map (lines n) prs @ block n body
|
||||
else
|
||||
match prs with
|
||||
| b :: rest ->
|
||||
let p, v = bind b in
|
||||
tagged b [ ind n ^ p ^ " = " ^ at 0 v ]
|
||||
@ List.concat_map (lines (n + 2)) rest
|
||||
@ block (n + 2) body
|
||||
| [] -> block n body
|
||||
List.concat_map (lines n) prs @ block n body
|
||||
|
||||
(** A whole file: top-level forms with a blank line between them. *)
|
||||
let program ?source (fs : Form.t list) : string =
|
||||
(** A whole file: top-level forms with a blank line between them. [macros]
|
||||
is [Body_macros.table] of the file; without it, the prelude's and the
|
||||
file's own macros are known and no imported package's. *)
|
||||
let program ?source ?macros:m (fs : Form.t list) : string =
|
||||
macros := (match m with Some m -> m | None -> Body_macros.table fs);
|
||||
spelling :=
|
||||
(match source with Some src -> Source_text.spelling src | None -> fun _ -> None);
|
||||
let cs = match source with Some src -> Source_text.comments src | None -> [] in
|
||||
@ -714,10 +981,18 @@ let program ?source (fs : Form.t list) : string =
|
||||
(fun (c : Source_text.comment) ->
|
||||
f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline)
|
||||
cs);
|
||||
(* A flat [let] at the top level would take in the forms after it, so one
|
||||
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
|
||||
let rec go = function
|
||||
| [] -> []
|
||||
| [ x ] -> [ String.concat "\n" (stmt 0 ~last:true x) ]
|
||||
| x :: rest -> String.concat "\n" (stmt 0 ~last:false x) :: go rest
|
||||
| [ x ] -> [ top x ]
|
||||
| x :: rest -> top (if let_sugar x then in_do x else x) :: go rest
|
||||
in
|
||||
let text =
|
||||
try String.concat "\n\n" (go fs) ^ "\n"
|
||||
|
||||
@ -1118,10 +1118,13 @@ and let_stmt (s : st) : Form.t list =
|
||||
make (target :: v :: bs) body
|
||||
| _ -> make [ target; v ] body
|
||||
in
|
||||
if (peek p).tok = INDENT then begin
|
||||
let f = merged (block s ~after:"let") in
|
||||
f :: stmts s
|
||||
end
|
||||
(* A let has no block: its name lasts to the end of the block it is in. *)
|
||||
if (peek p).tok = INDENT then
|
||||
failk "let-block" (peek_at p 1).loc
|
||||
"this line is indented under let %s, which takes no block. A let's \
|
||||
name lasts to the end of the block the let is in, so the lines after \
|
||||
it go at the let's column"
|
||||
(text_of target)
|
||||
else [ merged (stmts s) ]
|
||||
|
||||
and stmt (s : st) : Form.t =
|
||||
|
||||
@ -176,8 +176,24 @@ Each item: the proposal, then the reason in one line.
|
||||
|
||||
- **`let x = v`** scopes to the end of its block and reads as
|
||||
`(let [x v] rest…)`. Consecutive `let`s merge into one binding vector.
|
||||
`let x = v` followed by a deeper-indented block scopes to that block only,
|
||||
which is how the printer writes a `let` that has siblings after it.
|
||||
A `let` is always flat: a line indented deeper under `let x = v` is
|
||||
refused. To end a `let`'s scope early, put it in a `do:` block.
|
||||
The printer writes every `let` flat. A `let` with statements after it
|
||||
takes them into its body; when one of them means an outer name the `let`
|
||||
rebinds, the `let`'s is renamed (`x` to `x-2`, a name the top-level form
|
||||
does not use; a struct pattern is written as `{x-2 .x}` pairs). A macro's
|
||||
body counts as statements run in order when its definition splices its
|
||||
rest parameter only into a `do`, a `let`/`fn`/`when`/`while`/`loop` body or
|
||||
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, 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
|
||||
@ -344,8 +360,14 @@ Each step lands on its own, with `dune test --root .` green.
|
||||
3. **The printer**, `Form.t` → indented text, and a `flan convert` command.
|
||||
**Test:** for every corpus file, read with parens, print indented, read
|
||||
indented; the forms must be equal to the first read, after one normalisation:
|
||||
a `let` whose whole body is another `let` counts as equal to the merged
|
||||
`let`. That covers 394 files and runs on readers alone, so it's fast.
|
||||
every name a `let` binds is renamed through its scope to one numbered by
|
||||
binding order; then, in a body run in order, a `let` counts as equal to
|
||||
itself taking in the later statements of the body (a macro's body by the
|
||||
same rule as the printer's); `(do x)` with `x` a
|
||||
`let` counts as `x`; a `let` whose whole body is another `let` counts as
|
||||
equal to the merged `let`; `(and x)` and `(or x)` count as `x`. Taking in
|
||||
and the one-argument `and` stop at a quote or quasiquote. That covers 394
|
||||
files and runs on readers alone, so it's fast.
|
||||
4. **The dev loop.** Code-carrying wire ops (`eval`, `eval-expr`,
|
||||
`macroexpand`, `set`) get an explicit `:syntax` field instead of guessing
|
||||
from `:file`. The `:file` guess breaks for `<repl>`/`<inspect>` origins and
|
||||
|
||||
@ -29,12 +29,12 @@ fn insertion-sort(coll: [$t]) -> () where ordered?($t)
|
||||
let length = length(coll)
|
||||
while and(i < length)
|
||||
let j = i
|
||||
while j > 0
|
||||
and coll[j] < coll[dec(j)]
|
||||
let temp = coll[j]
|
||||
coll[j] = coll[dec(j)]
|
||||
coll[dec(j)] = temp
|
||||
--(j)
|
||||
while j > 0
|
||||
and coll[j] < coll[dec(j)]
|
||||
let temp = coll[j]
|
||||
coll[j] = coll[dec(j)]
|
||||
coll[dec(j)] = temp
|
||||
--(j)
|
||||
++(i)
|
||||
|
||||
fn main() -> i32 = 0
|
||||
@ -43,10 +43,10 @@ comment():
|
||||
insertion-sort([\I \N \S \E \R \T \I \O \N \S \O \R \T])
|
||||
insertion-sort(slice([6 2 4 9 1 9 4 5], 0, 8))
|
||||
let str = bytes("INSERTIONSORT")
|
||||
insertion-sort(str)
|
||||
println(str)
|
||||
insertion-sort(str)
|
||||
println(str)
|
||||
let str = bytes("SELECTIONSORT")
|
||||
selection-sort(str)
|
||||
println(str)
|
||||
selection-sort(str)
|
||||
println(str)
|
||||
find-match("aababba", "abba")
|
||||
:-
|
||||
|
||||
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)
|
||||
@ -59,20 +59,20 @@ fn settle(row: i32, col: i32) -> ()
|
||||
velocity[row, col] = 0.0
|
||||
return
|
||||
let left? = col > 0 and 0 == grid[y, col - 1]
|
||||
let right? = col < cols - 1 and 0 == grid[y, col + 1]
|
||||
if left? or right?
|
||||
let side =
|
||||
if not left?
|
||||
1
|
||||
elif not right?
|
||||
-1
|
||||
else
|
||||
if f32(rand()) < 0.5 then 1 else -1
|
||||
grid[y, col + side] = grid[row, col]
|
||||
grid[row, col] = 0
|
||||
velocity[y, col + side] = vel
|
||||
velocity[row, col] = 0.0
|
||||
return
|
||||
let right? = col < cols - 1 and 0 == grid[y, col + 1]
|
||||
if left? or right?
|
||||
let side =
|
||||
if not left?
|
||||
1
|
||||
elif not right?
|
||||
-1
|
||||
else
|
||||
if f32(rand()) < 0.5 then 1 else -1
|
||||
grid[y, col + side] = grid[row, col]
|
||||
grid[row, col] = 0
|
||||
velocity[y, col + side] = vel
|
||||
velocity[row, col] = 0.0
|
||||
return
|
||||
y = y - 1
|
||||
velocity[row, col] = 0.0
|
||||
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
|
||||
Four parts. Two programs hand-converted from paren to indented must read to
|
||||
the same forms. Every corpus file must survive paren -> printed indented ->
|
||||
read indented unchanged, up to the one merge the spec allows. A table pins
|
||||
read indented unchanged, up to the normalisation the spec allows. A table pins
|
||||
the lexical edge cases and the refusals, with their kinds. And a program in
|
||||
each syntax importing a package in the other builds and runs the same on
|
||||
both backends. *)
|
||||
@ -49,23 +49,178 @@ let describe_diff a b =
|
||||
(Form.to_string w) w.loc.Loc.line w.loc.Loc.col
|
||||
| None -> "equal"
|
||||
|
||||
(* A [let] whose whole body is another [let] is the merged [let]: spec §4
|
||||
step 3's one normalisation. Flan's [let] binds in order, so the two mean
|
||||
the same thing. *)
|
||||
let rec norm (f : Form.t) : Form.t =
|
||||
let v =
|
||||
match f.v with
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: { v = Form.Vec bs; loc } :: body) ->
|
||||
(match List.map norm body with
|
||||
| [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] ->
|
||||
Form.List (h :: Form.make (Form.Vec (List.map norm bs @ bs2)) loc :: body2)
|
||||
| body -> Form.List (h :: Form.make (Form.Vec (List.map norm bs)) loc :: body))
|
||||
| Form.List l -> Form.List (List.map norm l)
|
||||
| Form.Vec l -> Form.Vec (List.map norm l)
|
||||
| Form.Map l -> Form.Map (List.map norm l)
|
||||
| v -> v
|
||||
(* Spec §4 step 3's normalisation. Each rule keeps the meaning.
|
||||
|
||||
First every name a [let] binds is renamed, through its scope, to one
|
||||
numbered in the order the binders come: so two forms that differ only in
|
||||
what their [let]s call things compare equal, and one where a name was
|
||||
captured does not. Then, where statements are a body run in order, a
|
||||
[let] takes in the statements after it (the printer's flat [let]; with
|
||||
every [let] name unique by now, nothing after it can mean one of them). A
|
||||
[(do x)] whose [x] is a [let] is [x], a [let] whose whole body is another
|
||||
[let] is the merged [let], and [(and x)] and [(or x)] are [x]. The flat
|
||||
[let] and the one-argument [and] stop at a quote or quasiquote: data, or
|
||||
a template whose unquotes could name anything. *)
|
||||
|
||||
(* A binding target with every struct pattern written as [name .field]
|
||||
pairs: [{.x}] and [{:keys [x]}] are [{x .x}] (Parse.dmap). *)
|
||||
let rec pairs_pat (t : Form.t) : Form.t =
|
||||
let dotted s = String.length s > 1 && s.[0] = '.' in
|
||||
let rec items = function
|
||||
| ({ Form.v = Form.Sym s; _ } as f) :: rest when dotted s ->
|
||||
{ f with v = Form.Sym (String.sub s 1 (String.length s - 1)) } :: f :: items rest
|
||||
| { Form.v = Form.Kw "keys"; _ } :: { Form.v = Form.Vec ns; _ } :: rest ->
|
||||
List.concat_map
|
||||
(fun (n : Form.t) -> match n.v with
|
||||
| Form.Sym x -> [ n; { n with v = Form.Sym ("." ^ x) } ]
|
||||
| _ -> [ n ])
|
||||
ns
|
||||
@ items rest
|
||||
| pat :: f :: rest -> pairs_pat pat :: f :: items rest
|
||||
| rest -> rest
|
||||
in
|
||||
{ f with v }
|
||||
match t.v with
|
||||
| Form.Vec l -> { t with v = Form.Vec (List.map pairs_pat l) }
|
||||
| Form.Map l -> { t with v = Form.Map (items l) }
|
||||
| _ -> t
|
||||
|
||||
(* The names a target so written binds, in order. *)
|
||||
let rec binders (t : Form.t) =
|
||||
match t.v with
|
||||
| Form.Sym "&" -> []
|
||||
| Form.Sym s -> [ s ]
|
||||
| Form.Vec l -> List.concat_map binders l
|
||||
| Form.Map l -> List.concat (List.filteri (fun i _ -> i mod 2 = 0) (List.map binders l))
|
||||
| _ -> []
|
||||
|
||||
let canon (f : Form.t) : Form.t =
|
||||
let k = ref 0 in
|
||||
let look env s =
|
||||
match List.assoc_opt s env with
|
||||
| Some c -> c
|
||||
| None ->
|
||||
(* [x.y], a field path on a bound [x]. *)
|
||||
match String.index_opt s '.' with
|
||||
| Some i when i > 0 ->
|
||||
(match List.assoc_opt (String.sub s 0 i) env with
|
||||
| Some c -> c ^ String.sub s i (String.length s - i)
|
||||
| None -> s)
|
||||
| _ -> s
|
||||
in
|
||||
let rec go env (f : Form.t) =
|
||||
let v =
|
||||
match f.v with
|
||||
| Form.Sym s -> Form.Sym (look env s)
|
||||
(* Quoted data keeps its names: renaming them would hide a printer
|
||||
that renamed them too. *)
|
||||
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> f.v
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: body) ->
|
||||
let rec binds env acc = function
|
||||
| t :: v :: rest ->
|
||||
let v' = go env v in
|
||||
let t = pairs_pat t in
|
||||
let env' =
|
||||
List.fold_left (fun e n -> incr k; (n, "%" ^ string_of_int !k) :: e)
|
||||
env (binders t)
|
||||
in
|
||||
binds env' (v' :: go env' t :: acc) rest
|
||||
| rest -> (env, List.rev_append acc (List.map (go env) rest))
|
||||
in
|
||||
let env', bs' = binds env [] bs in
|
||||
Form.List (h :: { bv with v = Form.Vec bs' } :: List.map (go env') body)
|
||||
| Form.List l -> Form.List (List.map (go env) l)
|
||||
| Form.Vec l -> Form.Vec (List.map (go env) l)
|
||||
| Form.Map l -> Form.Map (List.map (go env) l)
|
||||
| v -> v
|
||||
in
|
||||
{ f with v }
|
||||
in
|
||||
go [] f
|
||||
|
||||
(* The macros of the file being compared ([Body_macros.table]). *)
|
||||
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. *)
|
||||
let body_start (l : Form.t list) =
|
||||
let label k = match List.nth_opt l 1 with
|
||||
| Some { Form.v = Form.Kw _; _ } -> k + 1 | _ -> k in
|
||||
match l with
|
||||
| { Form.v = Form.Sym h; _ } :: _ ->
|
||||
(match h with
|
||||
| "do" | "defer" -> Some 1
|
||||
| "let" | "when" | "fn" | "loop" -> Some 2
|
||||
| "while" | "until" | "dotimes" -> Some (label 2)
|
||||
| "defmacro" -> Some 3
|
||||
| "defmethod" -> Some 4
|
||||
| "defn" | "defn-" ->
|
||||
Some (match List.nth_opt l 4 with
|
||||
| Some { Form.v = Form.Map _; _ } -> 5 | _ -> 4)
|
||||
| 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.bodies h)))
|
||||
| _ -> None
|
||||
|
||||
let is_let (f : Form.t) =
|
||||
match f.v with Form.List ({ v = Form.Sym "let"; _ } :: _) -> true | _ -> false
|
||||
|
||||
let rec shape ?(q = false) (f : Form.t) : Form.t =
|
||||
let q = q || (match f.v with
|
||||
| Form.List ({ v = Form.Sym ("quote" | "quasiquote"); _ } :: _) -> true | _ -> false) in
|
||||
let sh = shape ~q in
|
||||
(* A body's statements, each [let] taking in the ones after it. *)
|
||||
let rec stmts = function
|
||||
| [] -> []
|
||||
| x :: (_ :: _ as rest) when not q ->
|
||||
(match (sh x).v with
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec (_ :: _); _ } as bv)
|
||||
:: (_ :: _ as body)) ->
|
||||
[ sh { x with v = Form.List (h :: bv :: (body @ rest)) } ]
|
||||
| _ -> sh x :: stmts rest)
|
||||
| x :: rest -> sh x :: stmts rest
|
||||
in
|
||||
let seq_list l =
|
||||
match body_start l with
|
||||
| Some k when List.length l > k ->
|
||||
List.map sh (List.filteri (fun i _ -> i < k) l)
|
||||
@ stmts (List.filteri (fun i _ -> i >= k) l)
|
||||
| _ -> List.map sh l
|
||||
in
|
||||
(* Handler and restart clauses: [(name [v] body ...)]. *)
|
||||
let clause (c : Form.t) =
|
||||
match c.v with
|
||||
| Form.List (n :: p :: body) -> { c with v = Form.List (sh n :: sh p :: stmts body) }
|
||||
| _ -> sh c
|
||||
in
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym ("and" | "or"); _ }; x ] when not q -> sh x
|
||||
| _ ->
|
||||
let v =
|
||||
match f.v with
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: { v = Form.Vec bs; loc } :: body) ->
|
||||
(match stmts body with
|
||||
| [ { v = Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs2; _ } :: body2); _ } ] ->
|
||||
Form.List (h :: Form.make (Form.Vec (List.map sh bs @ bs2)) loc :: body2)
|
||||
| body -> Form.List (h :: Form.make (Form.Vec (List.map sh bs)) loc :: body))
|
||||
| Form.List (({ v = Form.Sym "handler-case"; _ } as h) :: body :: ({ v = Form.Vec cls; _ } as cv) :: more) ->
|
||||
Form.List (h :: sh body :: { cv with v = Form.Vec (List.map clause cls) }
|
||||
:: List.map sh more)
|
||||
| Form.List (({ v = Form.Sym "handler-bind"; _ } as h) :: ({ v = Form.Vec cls; _ } as cv) :: body) ->
|
||||
Form.List (h :: { cv with v = Form.Vec (List.map clause cls) } :: stmts body)
|
||||
| Form.List (({ v = Form.Sym "restart-case"; _ } as h) :: body :: cls) ->
|
||||
Form.List (h :: sh body :: List.map clause cls)
|
||||
| Form.List l ->
|
||||
(match seq_list l with
|
||||
| [ { v = Form.Sym "do"; _ }; x ] when is_let x -> x.v
|
||||
| l -> Form.List l)
|
||||
| Form.Vec l -> Form.Vec (List.map sh l)
|
||||
| Form.Map l -> Form.Map (List.map sh l)
|
||||
| v -> v
|
||||
in
|
||||
{ f with v }
|
||||
|
||||
let norm f = shape (canon f)
|
||||
|
||||
let diag_text = function
|
||||
| Loc.Error d -> Printf.sprintf "%s %d:%d %s" d.Loc.kind d.dloc.Loc.line d.dloc.Loc.col d.dmsg
|
||||
@ -76,6 +231,10 @@ let diag_text = function
|
||||
let pair flan fln =
|
||||
match Reader.read_file flan, Source.read_file fln with
|
||||
| a, b ->
|
||||
macros := Body_macros.table ~file:flan a;
|
||||
(* Normalised: a hand conversion writes a let flat where its scope does
|
||||
not matter, as the printer does. *)
|
||||
let a = List.map norm a and b = List.map norm b in
|
||||
if not (same_forms a b) then
|
||||
fail "%s and %s read differently: %s" flan fln (describe_diff a b)
|
||||
| exception e -> fail "%s / %s: %s" flan fln (diag_text e)
|
||||
@ -112,13 +271,15 @@ let starts_of (fs : Form.t list) =
|
||||
let rec walk (f : Form.t) =
|
||||
(* Outermost first among forms starting at one place: [x = v] and its
|
||||
[x] start together, and the statement is what a comment is about. *)
|
||||
let t = Form.to_string (norm f) in
|
||||
let t = Form.to_string f in
|
||||
out := ((f.loc.Loc.line, f.loc.Loc.col, - String.length t), t) :: !out;
|
||||
match f.v with
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.iter walk l
|
||||
| _ -> ()
|
||||
in
|
||||
List.iter walk fs;
|
||||
(* The normalised forms: a [let] a flat line extended is, on both sides,
|
||||
the one that holds what now follows it. *)
|
||||
List.iter walk (List.map norm fs);
|
||||
List.map (fun ((l, c, _), t) -> (l, c, t)) (List.sort compare !out)
|
||||
|
||||
let attachments src forms =
|
||||
@ -210,7 +371,8 @@ let () =
|
||||
| exception Loc.Error _ -> () (* not a program the paren reader takes *)
|
||||
| forms ->
|
||||
let source = In_channel.with_open_bin path In_channel.input_all in
|
||||
match Indent_printer.program ~source forms with
|
||||
macros := Body_macros.table ~file:path forms;
|
||||
match Indent_printer.program ~source ~macros:!macros forms with
|
||||
| exception Indent_printer.Unprintable (f, why) ->
|
||||
fail "round trip %s: %s at %d:%d" path why f.loc.Loc.line f.loc.Loc.col
|
||||
| text ->
|
||||
@ -355,7 +517,8 @@ let () =
|
||||
(* Statements. *)
|
||||
reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b"
|
||||
"(defn f [] i32 (let [a 1 b 2] (+ a b)))";
|
||||
reads "let with a block" "let a = 1\n a\nb" "(let [a 1] a)\nb";
|
||||
refuses "let with a block" "let a = 1\n a\nb" "indent/let-block" "go at the let's column";
|
||||
reads "flat let" "let a = 1\na\nb" "(let [a 1] a b)";
|
||||
reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)";
|
||||
reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))";
|
||||
reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))";
|
||||
@ -417,6 +580,8 @@ let () =
|
||||
reads "one-line quote" "defmacro(m, [x]):\n quote ~x + 1"
|
||||
"(defmacro m [x] (quasiquote (+ (unquote x) 1)))";
|
||||
reads "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)";
|
||||
refuses "a let takes no block" "fn f() -> ()\n let x = 1\n g(x)\n h(x)"
|
||||
"indent/let-block" "go at the let's column";
|
||||
(* And back: the printer writes the idioms. *)
|
||||
let prints name src want =
|
||||
match Reader.read_all ~file:"<p>" src with
|
||||
@ -436,6 +601,101 @@ let () =
|
||||
prints "a statement argument makes a block" "(foo 1 (set x 2))" "foo(1):\n x = 2";
|
||||
prints "no arguments before the block" "(comment (f))" "comment:\n f()";
|
||||
prints "typed let" "(defn f [] i32 (let [x (the i32 5)] x))" "let x: i32 = 5";
|
||||
(* A let is always flat: it takes in the rest of its block. *)
|
||||
prints "flat let" "(defn f [] () (let [j 1] (g j)) (h))" " let j = 1\n g(j)\n h()";
|
||||
prints "a chain of lets, all flat" "(defn f [] () (let [a 1] (let [b 2] (g b)) (k a)) (h))"
|
||||
" let a = 1\n let b = 2\n g(b)\n k(a)\n h()";
|
||||
(* A later statement that means an outer name of the same spelling: the
|
||||
let's own is renamed. *)
|
||||
prints "a later outer name of the same spelling renames the let's"
|
||||
"(defn f [x i32] () (let [x 1] (g x)) (h x))" " let x-2 = 1\n g(x-2)\n h(x)";
|
||||
prints "the inner let of a chain renamed"
|
||||
"(defn f [] () (let [a 1] (let [b 2] (g b)) (h b)))" " let a = 1\n let b-2 = 2\n g(b-2)\n h(b)";
|
||||
prints "the binding's own value keeps the outer name"
|
||||
"(defn f [x i32] () (let [x (+ x 1)] (g x)) (h x))" " let x-2 = x + 1\n g(x-2)\n h(x)";
|
||||
prints "a later binding's value takes the new name"
|
||||
"(defn f [x i32] () (let [x 1 y (+ x 1)] (g y)) (h x))"
|
||||
" let x-2 = 1\n let y = x-2 + 1\n g(y)\n h(x)";
|
||||
prints "the new name is one the function does not use"
|
||||
"(defn f [x i32] () (let [x 1] (g x x-2)) (h x))" " let x-3 = 1\n g(x-3, x-2)\n h(x)";
|
||||
prints "a later let of the same name is no mention"
|
||||
"(defn f [] () (let [a 1] (g a)) (let [a 2] (k a)))" " let a = 1\n g(a)\n let a = 2\n k(a)";
|
||||
prints "unless its value uses the name"
|
||||
"(defn f [a i32] () (let [a 1] (g a)) (let [a (+ a 1)] (k a)))"
|
||||
" let a-2 = 1\n g(a-2)\n let a = a + 1\n k(a)";
|
||||
prints "a destructured name renamed alone" "(defn f [] () (let [[p q] v] (g p q)) (h q))"
|
||||
" let [p q-2] = v\n g(p, q-2)\n h(q)";
|
||||
prints "a qualified name counts" "(defn f [] () (let [p (pt)] (g p)) (h p/x))"
|
||||
" let p-2 = pt()\n g(p-2)\n h(p/x)";
|
||||
prints "a quoted name later counts" "(defn f [] () (let [a 1] (g a)) (h 'a))"
|
||||
" let a-2 = 1\n g(a-2)\n h('a)";
|
||||
(* Where a rename cannot be trusted, a do: block holds the let. *)
|
||||
prints "a quoted name inside is not renamed" "(defn f [] () (let [a 1] (g 'a)) (h a))"
|
||||
" do:\n let a = 1\n g('a)\n h(a)";
|
||||
prints "a call of the name inside is not renamed" "(defn f [] () (let [len 1] (len v)) (h len))"
|
||||
" do:\n let len = 1\n len(v)\n h(len)";
|
||||
(* A struct pattern renames as pairs, so the field keeps its name. *)
|
||||
prints "a struct pattern renamed"
|
||||
"(defn f [x i32] () (let [{.x .y} p] (g x y)) (h x))" " let {x-2 .x y .y} = p\n g(x-2, y)\n h(x)";
|
||||
prints "a :keys pattern renamed"
|
||||
"(defn f [x i32] () (let [{:keys [x y]} p] (g x y)) (h x))" " let {x-2 .x y .y} = p\n g(x-2, y)\n h(x)";
|
||||
prints "a struct pattern that binds none of them stays"
|
||||
"(defn f [x i32] () (let [{.y .z} p] (g y)) (h x))" " let {.y .z} = p\n g(y)\n h(x)";
|
||||
prints "a later struct pattern rebinding the name is no mention"
|
||||
"(defn f [] () (let [x 1] (g x)) (let [{.x} p] (k x)))" " let x = 1\n g(x)\n let {.x} = p\n k(x)";
|
||||
prints "a struct literal inside is renamed"
|
||||
"(defn f [x i32] () (let [x 1] (g (P {.x x}))) (h x))" " let x-2 = 1\n g(P{.x x-2})\n h(x)";
|
||||
(* A macro whose body its definition splices into a do is a body run in
|
||||
order; one that splices it anywhere else is not. *)
|
||||
prints "a macro's in-order body"
|
||||
"(defmacro twice [n & body] `(do ~@body ~@body))\n(defn f [] () (twice 2 (let [a 1] (g a)) (h)))"
|
||||
" twice(2):\n let a = 1\n g(a)\n h()";
|
||||
prints "a macro's list of arguments"
|
||||
"(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))"
|
||||
"foo(1):\n do:\n let a = 1\n g(a)\n x = 2";
|
||||
prints "at the top level" "(let [a 1] (g a))\n(h)" "do:\n let a = 1\n g(a)\n\nh()";
|
||||
prints "one-argument and" "(defn f [] () (while (and (< i n)) (g)))" " while i < n\n";
|
||||
prints "one-argument or" "(defn f [] () (when (or c) (g)))" " if c\n";
|
||||
prints "one-argument and in a quasiquote" "(defmacro m [x] (quasiquote (and ~x)))" "and(~x)";
|
||||
prints "do in an arm is a block" "(defn f [] () (match s _ (do (a) (b))))" "_ ->\n a()";
|
||||
prints "hex spelling" "(def c dyn 0xFFF00FFF)" "0xFFF00FFF";
|
||||
prints "own-line comment above its form" "(defn f [] ()\n ;; why\n (g))" " ;; why\n g()";
|
||||
@ -681,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