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

Merge branch 'master' into worktree-agent-a46233a32d1912c78

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 23:27:55 +07:00
commit 2135f6d37f
29 changed files with 1702 additions and 201 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
TODO.org
View File

@ -327,10 +327,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.
@ -1485,11 +1481,6 @@ Its signature changes in the session but its body is not recompiled, so every ca
stops on StaleCall naming a type nobody wrote. Proposal: recompile such callers.
Postponed 2026-09-25 while .fln takes priority.
** TODO A prelude function shadowed live is reached by the prelude's own calls
A defn of a prelude function's name sent to a running =flan dev= installs into the
host's cell for that name, so the prelude's calls compiled into the host follow it;
a rebuild gives them the prelude's again, as =Check.shadow_prelude= intends.
** DONE The dev loop, step 1: the reload primitive
A list of top-level forms is recompiled and installed into a running process, and
call sites compiled before those forms existed follow them through an indirection
@ -1662,9 +1653,6 @@ CLOSED: [2026-09-25]
** TODO The inspector holds a value
Reading needs no module now, so an address and a type are enough to keep a value on the daemon's side between requests, the way CIDER keeps a JVM object. Nothing holds one yet: the Emacs stack is still a stack of expressions.
** TODO A frame that prints is skipped from the globals section
A frame whose body calls =print= comes back in =:skipped= as "running a body that has been redefined since" though nothing was redefined: its global-reference fingerprint differs between the build and the daemon. test/programs/dev-parity.flan stores each global to itself instead of printing it for this reason.
** DONE The watch table stays pushed
CLOSED: [2026-09-25]
The watch table stays pushed, and shares the push channel program output moves to.
@ -1794,17 +1782,6 @@ crashed session keeping its directory.
The fork pool is drained before anything reads the failure count, and a nonzero
count is an exit status. A red row used to be able to print and pass.
** TODO test_dev dies on Wire.Closed after the half-write abort
Intermittent, on an unmodified tree too: the =--llvm= half-write daemon in
=test_dev.ml='s =half_written= sometimes exits before it replies to =abort=, and
=request= raises =Wire.Closed= uncaught, so test_dev ends with a fatal, no =FAIL=
line and every later row unrun.
** TODO flan build and flan run leave an empty flan-<pid> directory
=Build.workdir= is created per process and nothing removes it once the IR is
gone. The dev daemon now removes its own on a clean end; the one-shot commands do
not.
** WAIT An x86 dev session's read of a dyn global after an allocating thunk failed once
WAIT on a recurrence; the test now prints the failing read's own reply.
The one failure's message came from a second read, which said "kept"; the failing
@ -1943,6 +1920,8 @@ and an =eval-expr= of the =get=, all succeed. In a session every installed
function of no arguments returning =()= has the type =(CFn [] ())=, not only
=pause= — a bare =pause= or =tick= asked of the session says so — so the
keyword may not be what resolved. The next report wants the exact form sent.
Nor (2026-09-25) by a mark at the =:pause= or the =when=, frame evaluation, the
indented syntax, or =load-file= after slot changes and with a program =pause=.
** DONE A digit does not take the restart RET takes
CLOSED: [2026-09-25]

35
bin/main.ml
View File

@ -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
@ -949,12 +950,36 @@ let () =
~csrcs:f.csrcs ~lflags:f.lflags
~pnames:(if debug then param_names f.load else [])
f.program ~out:exe);
let code =
Sys.command
(String.concat " " (List.map Filename.quote (exe :: prog_args)))
(* Spawned and waited on here rather than through [Sys.command], so a
SIGTERM or SIGHUP sent to flan reaches the program and flan still
removes the executable and its work directory: the default action
would end flan inside the wait with neither removed. SIGINT and
SIGQUIT are ignored while the program runs, as [system] does, since
the terminal sends them to the program too. A flan killed outright
takes the program with it ([Spawn.dying]). *)
let pid = Flan.Spawn.dying exe (Array.of_list (exe :: prog_args)) in
let caught = ref None in
let forward s =
Sys.Signal_handle (fun _ ->
caught := Some s;
try Unix.kill pid s with Unix.Unix_error _ -> ())
in
Sys.set_signal Sys.sigterm (forward Sys.sigterm);
Sys.set_signal Sys.sighup (forward Sys.sighup);
Sys.set_signal Sys.sigint Sys.Signal_ignore;
Sys.set_signal Sys.sigquit Sys.Signal_ignore;
let rec wait () =
match Unix.waitpid [] pid with
| _, Unix.WEXITED c -> c
| _, (Unix.WSIGNALED s | Unix.WSTOPPED s) -> 128 + Flan.Spawn.host_signal s
| exception Unix.Unix_error (Unix.EINTR, _, _) -> wait ()
in
let code = wait () in
(try Sys.remove exe with Sys_error _ -> ());
exit code)
exit (match !caught with
| Some s when s = Sys.sigterm -> 143
| Some _ -> 129
| None -> code))
| _ ->
prerr_endline
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n flan check <file.flan>... [--warn-memory]\n flan emit <file.flan> [--x86] [--dev] [--debug] [--no-bounds-checks]\n\

22
emacs/flan.el
View File

@ -673,6 +673,26 @@ Set to nil to leave the program's state to whatever replies happen to say."
flan-socket-name)))
(and dir (expand-file-name flan-socket-name dir))))
(defun flan--short-socket (socket)
"The path to connect to SOCKET by.
A unix socket path holds at most 107 bytes, and a longer one cannot be
connected to by name. For such a SOCKET the daemon makes a symlink at a
short path computed from it, and this computes the same one: see
`Wire.short_socket_path' in lib/wire.ml."
(let ((abs (expand-file-name socket)))
(if (<= (string-bytes abs) 107)
socket
(let* ((env (getenv "XDG_RUNTIME_DIR"))
(dir (if (and env (not (string= env "")) (file-directory-p env))
env
"/tmp")))
(expand-file-name
(concat "flan-"
(substring (secure-hash 'md5 (encode-coding-string abs 'utf-8))
0 16)
".sock")
dir)))))
(defun flan--open (socket)
"Open a connection to SOCKET and make it the current one."
(when (process-live-p flan--connection)
@ -683,7 +703,7 @@ Set to nil to leave the program's state to whatever replies happen to say."
(with-current-buffer buf (erase-buffer) (set-buffer-multibyte nil))
(setq flan--connection
(make-network-process
:name "flan" :buffer buf :family 'local :service socket
:name "flan" :buffer buf :family 'local :service (flan--short-socket socket)
:coding 'binary :noquery t
:filter #'flan--filter :sentinel #'flan--sentinel))
(setq flan--socket socket))

40
lib/ast.ml
View File

@ -491,7 +491,9 @@ let map_children f (e : expr) : expr =
in
{ e with e = kind }
let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc }
(* [fn] is the name the prelude's function answers to, which is not its own
when the program defines one of that name: see [Session.prelude_fn]. *)
let pause_call ?(fn = "pause") loc = { e = Call ({ e = Var fn; loc }, []); loc }
(* The stepper. [instrument_step ds] is [ds] with every [defn] rebuilt so a
call stops before each form of its body, at any depth of body: the forms of
@ -509,36 +511,36 @@ let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc }
the local is visibly the compiler's and hidden from the locals listing. *)
let step_flag = "flan~step"
let step_point loc =
let step_point fn loc =
let v = { e = Var step_flag; loc } in
{ e =
If (v,
{ e = Set (Pvar step_flag, { e = Call ({ e = Var "step-point"; loc }, []); loc });
{ e = Set (Pvar step_flag, { e = Call ({ e = Var fn; loc }, []); loc });
loc },
None);
loc }
let rec step_body (es : expr list) : expr list =
List.concat_map (fun (e : expr) -> [ step_point e.loc; step_expr e ]) es
let rec step_body fn (es : expr list) : expr list =
List.concat_map (fun (e : expr) -> [ step_point fn e.loc; step_expr fn e ]) es
and step_expr (e : expr) : expr =
and step_expr fn (e : expr) : expr =
let branch (x : expr) =
match x.e with
| Do _ -> step_expr x
| _ -> { e = Do [ step_point x.loc; step_expr x ]; loc = x.loc }
| Do _ -> step_expr fn x
| _ -> { e = Do [ step_point fn x.loc; step_expr fn x ]; loc = x.loc }
in
match e.e with
| Do es -> { e with e = Do (step_body es) }
| Let (bs, es) -> { e with e = Let (bs, step_body es) }
| Do es -> { e with e = Do (step_body fn es) }
| Let (bs, es) -> { e with e = Let (bs, step_body fn es) }
| If (c, a, b) -> { e with e = If (c, branch a, Option.map branch b) }
| While (l, c, es) -> { e with e = While (l, c, step_body es) }
| Loop (bs, es) -> { e with e = Loop (bs, step_body es) }
| Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body es) }
| While (l, c, es) -> { e with e = While (l, c, step_body fn es) }
| Loop (bs, es) -> { e with e = Loop (bs, step_body fn es) }
| Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body fn es) }
| Match (sc, arms) ->
{ e with e = Match (sc, List.map (fun a -> { a with body = step_body a.body }) arms) }
{ e with e = Match (sc, List.map (fun a -> { a with body = step_body fn a.body }) arms) }
| _ -> e
let instrument_step (ds : decl list) : decl list option =
let instrument_step ?(fn = "step-point") (ds : decl list) : decl list option =
let hit = ref false in
let ds =
List.map
@ -551,7 +553,7 @@ let instrument_step (ds : decl list) : decl list option =
bval = { e = Var "true"; loc = d.dloc }; bloc = d.dloc }
in
{ d with
d = Defn { f with fbody = [ { e = Let ([ on ], step_body f.fbody);
d = Defn { f with fbody = [ { e = Let ([ on ], step_body fn f.fbody);
loc = d.dloc } ] } }
| _ -> d)
ds
@ -573,7 +575,7 @@ let instrument_step (ds : decl list) : decl list option =
A whole top-level [defn] is the third target from §9 and cannot be wrapped:
[(do (pause) (defn ...))] is not an expression. Marking one means stopping
on entry, so the call goes at the front of its body. *)
let mark_pause ~line ~col (ds : decl list) : decl list option =
let mark_pause ?fn ~line ~col (ds : decl list) : decl list option =
let at (l : Loc.t) = l.Loc.line = line && l.Loc.col = col in
let hit = ref false in
let rec walk (e : expr) =
@ -583,7 +585,7 @@ let mark_pause ~line ~col (ds : decl list) : decl list option =
(* The [Do] takes the target's own location, and the target keeps its
own: a wrapper at [Loc.unknown] would put the frame the break loop
reports, and the line DWARF names, nowhere. *)
{ e with e = Do [ pause_call e.loc; e ] }
{ e with e = Do [ pause_call ?fn e.loc; e ] }
end
else map_children walk e
in
@ -592,7 +594,7 @@ let mark_pause ~line ~col (ds : decl list) : decl list option =
match d.d with
| Defn f when (not !hit) && at d.dloc ->
hit := true;
{ d with d = Defn { f with fbody = pause_call d.dloc :: f.fbody } }
{ d with d = Defn { f with fbody = pause_call ?fn d.dloc :: f.fbody } }
| Defn f -> { d with d = Defn { f with fbody = body f.fbody } }
(* A method's body and a defmulti's dispatch body are code someone wrote
and can stop inside, so both are walked. Marking the whole declaration

196
lib/body_macros.ml Normal file
View 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

14
lib/build.ml
View File

@ -64,8 +64,18 @@ let workdir () =
workdir_exit := Some d;
let pid = Unix.getpid () in
at_exit (fun () ->
if Unix.getpid () = pid then
try Unix.rmdir d with Unix.Unix_error _ -> ())
if Unix.getpid () = pid then begin
(* The dyn header [compile_c] leaves for every compile in the process
to include, and not a build's own: gone when it is all that is
left, kept beside a failed build's C that includes it. *)
(match Sys.readdir d with
| [| "flan_dyn.h" |] ->
(try Unix.unlink (Filename.concat d "flan_dyn.h")
with Unix.Unix_error _ -> ())
| _ -> ()
| exception Sys_error _ -> ());
try Unix.rmdir d with Unix.Unix_error _ -> ()
end)
end;
d

78
lib/dev.ml
View File

@ -213,7 +213,7 @@ let over_socket t line =
Fun.protect
~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
(fun () ->
Unix.connect s (Unix.ADDR_UNIX t.agent);
Wire.connect_socket s t.agent;
let msg = line ^ "\n" in
ignore (Unix.write_substring s msg 0 (String.length msg));
let b = Bytes.create 4096 in
@ -940,8 +940,7 @@ let refusal ~parked reply =
frame boundary is the next one it reaches. That includes a running program
whose agent socket is not bound. The agent package binds it in a
constructor before [main], so the one way to be running and unbound with
the agent linked is a bind that failed — a socket path longer than
[max_socket_path], which [session_dir] refuses before building — and there
the agent linked is a bind that failed, and there
the module is still queued through the in-process call. A note saying the
program "has not called (agent/start ...)" named a cause that was not the
cause, so there is none. *)
@ -2592,11 +2591,11 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
up" is a claim about the body this session holds, and a
zero-slot frame whose body has since been replaced by one
with slots is a frame that claim is false about. *)
if nslots <> Array.length fn.Tast.slots then
if nslots <> Emit.recorded_slots fn then
Error
(Printf.sprintf
"%s on the stack has %d slots and the %s this session holds has %d — the frame is running a body that has been redefined since"
name nslots name (Array.length fn.Tast.slots))
name nslots name (Emit.recorded_slots fn))
else if sig_ <> Emit.slot_fingerprint fn then
(* The count matching is not the same as the body matching.
A redefinition that renames a local, or changes its type
@ -2632,7 +2631,7 @@ let eval_expr ?frame ?at_stop t ~code ~origin ~pause =
(* A frame with no slots has no locals to bind, and the program
has no table to answer for it: the expression sees globals. *)
let bound =
if Array.length fn.Tast.slots = 0 then Ok []
if Emit.recorded_slots fn = 0 then Ok []
else bound_slots t ~frame:index
in
(* [at_stop] is the stop the editor drew the frame at. It is not
@ -2681,7 +2680,7 @@ let locals t ~frame =
match stopped_frame t ~frame ~what:"locals" with
| Error m -> error m
| Ok (name, fn) ->
if Array.length fn.Tast.slots = 0 then
if Emit.recorded_slots fn = 0 then
ok
[ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()";
":note " ^ Wire.quote "this frame has no named locals" ]
@ -3461,7 +3460,7 @@ let globals_op t =
"not a function this session holds; a lifted handler clause \
has no declaration of its own to read references from"
| Some fn ->
if nslots <> Array.length fn.Tast.slots then
if nslots <> Emit.recorded_slots fn then
skip
"the frame is running a body that has been redefined \
since, so what this session holds is a different body's \
@ -5360,20 +5359,42 @@ let remove_session_dirs t =
remove t.dir;
remove (Build.workdir ())
(* The longest path a unix socket can be bound at: [sun_path] is 108 bytes on
Linux and the path is written into it with its terminating NUL. A longer one
fails at the bind, where the reason reaches nobody — the agent's constructor
drops it, and [connect] later answers "File name too long" with no path. *)
let max_socket_path = 107
(* A socket path longer than [Wire.max_socket_path] is bound through its
directory, so only a file name too long for that is refused. *)
let socket_fits ~what ~fix path =
let n = String.length path in
if n > max_socket_path then
if not (Wire.socket_fits path) then
failwith
(Printf.sprintf
"%s would be at %s, which is %d bytes long, and a unix socket path \
can be at most %d bytes. %s"
what path n max_socket_path fix)
"%s would be at %s, and its file name, %s, is too long for a unix \
socket. %s"
what path (Filename.basename path) fix)
(* An editor socket too long to connect to by path gets a symlink at
[Wire.short_socket_path], made before the bind so it is there by the time
the socket is, and removed on a clean end only while it is still this
socket's. *)
let absolute p =
if Filename.is_relative p then Filename.concat (Sys.getcwd ()) p else p
let link_short_socket sock =
if String.length sock > Wire.max_socket_path then begin
let s = Wire.short_socket_path sock in
(match (Unix.lstat s).Unix.st_kind with
| Unix.S_LNK -> (try Unix.unlink s with Unix.Unix_error _ -> ())
| _ -> ()
| exception Unix.Unix_error _ -> ());
try Unix.symlink (absolute sock) s with Unix.Unix_error _ -> ()
end
let unlink_short_socket sock =
if String.length sock > Wire.max_socket_path then begin
let s = Wire.short_socket_path sock in
match Unix.readlink s with
| target when String.equal target (absolute sock) ->
(try Unix.unlink s with Unix.Unix_error _ -> ())
| _ -> ()
| exception Unix.Unix_error _ -> ()
end
(* The directory a session keeps its program, its modules and the agent's
socket in, checked before anything is built so that a TMPDIR that cannot
@ -5381,11 +5402,6 @@ let socket_fits ~what ~fix path =
let session_dir ~file ~sock =
let tmp = Filename.get_temp_dir_name () in
let dir = Filename.concat tmp (Printf.sprintf "flan-dev-%d" (Unix.getpid ())) in
let shorter =
Printf.sprintf
"Set TMPDIR to a shorter directory, for example: TMPDIR=/tmp flan dev %s"
(Filename.quote file)
in
if not (Sys.file_exists tmp && Sys.is_directory tmp) then
failwith
(Printf.sprintf
@ -5393,10 +5409,8 @@ let session_dir ~file ~sock =
program there. Create it, or set TMPDIR to a directory that exists, \
for example: TMPDIR=/tmp flan dev %s"
tmp (Filename.quote file));
socket_fits ~what:"the program's agent socket" ~fix:shorter
(Filename.concat dir "agent.sock");
socket_fits ~what:"the editor's socket"
~fix:"Give flan dev -s a shorter path." sock;
~fix:"Give flan dev -s a shorter file name." sock;
dir
(* Made only once the program has been found to have something to run, so a
@ -5589,7 +5603,8 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock (
ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ());
let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
Unix.bind ls (Unix.ADDR_UNIX sock);
link_short_socket sock;
Wire.bind_socket ls sock;
Unix.listen ls 4;
Printf.eprintf "flan dev: %s ready on %s (%.0fms)\n%!" file sock
((Unix.gettimeofday () -. t0) *. 1000.);
@ -5601,7 +5616,8 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock (
| None -> ());
(try Unix.close ls with Unix.Unix_error _ -> ());
(try Unix.close t.stdout with Unix.Unix_error _ -> ());
(try Unix.unlink sock with Unix.Unix_error _ -> ()))
(try Unix.unlink sock with Unix.Unix_error _ -> ());
unlink_short_socket sock)
(fun () -> accept_loop t ls);
(* Here only when the loop returned: an exception out of it has already
left through the [finally]. A child killed by a signal is the crash that
@ -6451,7 +6467,8 @@ let merged_setup () =
ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ());
let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
Unix.bind ls (Unix.ADDR_UNIX sock);
link_short_socket sock;
Wire.bind_socket ls sock;
Unix.listen ls 4;
merged_state := Some (t, ls, sock);
Printf.eprintf "flan dev: %s ready on %s (%.0fms, one process)\n%!" file
@ -6511,6 +6528,7 @@ let merged_serve () =
in
(try Unix.close ls with Unix.Unix_error _ -> ());
(try Unix.unlink sock with Unix.Unix_error _ -> ());
unlink_short_socket sock;
(* The program is this process, so a program that crashed never gets here;
the one end that does and is not clean is the loop raising. *)
if clean then remove_session_dirs t;

2
lib/dune
View File

@ -13,7 +13,7 @@
; only C the compiler itself is built from. See lib/dynload_stubs.c.
(foreign_stubs
(language c)
(names dynload_stubs))
(names dynload_stubs spawn_stubs))
; No (c_library_flags (-ldl)): since glibc 2.34 dlopen lives in libc itself
; and libdl is a stub, and naming it breaks the merged build -- the partial
; link -output-complete-obj performs cannot resolve -ldl, so `flan dev` in

11
lib/emit.ml
View File

@ -2022,6 +2022,17 @@ let slot_fingerprint (fn : Tast.fn) =
fn.Tast.slots;
Hashtbl.hash (Buffer.contents b) land 0x3fffffff
(* How many slots a frame's record says it has: all of them when any is named,
and none otherwise, since only a function with a named slot gets a slot
table (see the shadow stack's push in [emit_fn]). Both backends write it and
[Dev] compares a frame against it, so a body whose slots are all the
compiler's own — a [print]'s temporaries — reads as the same body at both
ends. *)
let recorded_slots (fn : Tast.fn) =
if Array.exists (fun n -> n <> None) fn.Tast.snames then
Array.length fn.Tast.slots
else 0
let fninfo m (fn : Tast.fn) ~nslots =
let nid, nlen = fi_bytes m fn.Tast.name in
let lid, llen = fi_bytes m (Loc.to_string fn.Tast.floc) in

333
lib/indent_printer.ml
View File

@ -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) ]
@ -592,7 +863,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) ->
@ -677,10 +950,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
@ -695,18 +967,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
@ -716,10 +983,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"

11
lib/indent_reader.ml
View File

@ -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 =

78
lib/session.ml
View File

@ -831,6 +831,21 @@ let shadowing_fns t origin =
| _ -> None)
t.decls
(* The name a prelude function the session splices a call to — [pause] for a
mark, [step-point] for the stepper — answers to in [decls]. A program's own
function or global of that name takes the name over and the prelude's is
renamed (see [Check.shadow_prelude]), and the spliced call is the
prelude's, not the program's. *)
let prelude_fn (decls : Ast.decl list) n =
let takes (d : Ast.decl) =
match d.Ast.d with
| Ast.Defn fn | Ast.Declare (fn, _) | Ast.DeclareC (fn, _) ->
String.equal fn.Ast.name n
| Ast.Defvar (m, _, _, _) | Ast.Defconst (m, _, _) -> String.equal m n
| _ -> false
in
if List.exists takes decls then Check.prelude_alias ^ "/" ^ n else n
(* [forms], when given, are [src] already read — [pruned] runs this over a
file a form fewer each round and has no text for the subset. [base] is the
file an [(import ...)] in them is resolved against, the session's own when
@ -920,7 +935,10 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
match pause with
| None -> incoming
| Some (line, col) ->
(match Ast.mark_pause ~line ~col incoming with
(match
Ast.mark_pause ~fn:(prelude_fn (t.decls @ incoming) "pause") ~line ~col
incoming
with
| Some ds -> ds
| None ->
fail loc "nothing to pause at line %d, column %d of the form sent"
@ -931,7 +949,10 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
let incoming =
if not step then incoming
else
match Ast.instrument_step incoming with
match
Ast.instrument_step ~fn:(prelude_fn (t.decls @ incoming) "step-point")
incoming
with
| Some ds -> ds
| None -> fail loc "there is no defn in the form sent to step through"
in
@ -1189,9 +1210,55 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
| None -> None)
program.Tast.fns
in
(* A name that takes over a prelude function's moves the prelude's body to
[Check.prelude_alias] and the prelude's own calls with it (see
[Check.shadow_prelude]). The process was built with those calls going
through the name's cell, which the new body is about to be installed
into, so the prelude's body is installed under its new name and every
body whose calls moved is compiled again: the prelude keeps its own
function, as a rebuild would give it. *)
let prelude_moved =
if not (List.exists (fun (f : Tast.fn) -> Check.internal_name f.Tast.name)
program.Tast.fns)
then []
else
let calls_moved (f : Tast.fn) (b : built) =
let hit = ref false in
let see (e : Tast.expr) =
match e.Tast.e with
| Tast.Call (m, _)
| Tast.FnAddr (Tast.Fnval m) | Tast.Closure (Tast.Fnval m, _)
when Check.internal_name m
&& not (List.exists
(fun (s : site) -> String.equal s.callee m) b.sites) ->
hit := true
| _ -> ()
in
List.iter (Tast.walk see) f.Tast.body;
List.iter (Tast.walk see) f.Tast.fdefers;
!hit
in
List.filter_map
(fun (f : Tast.fn) ->
(* A moved body not yet in the process is installed; one that is
— moved by an earlier shadowing — is compiled again like any
other when a later shadowing moves a call inside it. *)
if Check.internal_name f.Tast.name
&& not (known t f.Tast.name || SM.mem f.Tast.name t.built)
then Some f.Tast.name
else
match SM.find_opt f.Tast.name t.built with
| Some b when calls_moved f b ->
(* A lifted clause is compiled with the body it came from. *)
(match f.Tast.fparent with
| Some p when p <> "<thick>" -> Some p
| _ -> Some f.Tast.name)
| _ -> None)
program.Tast.fns
in
let fns =
List.sort_uniq String.compare
(declared_fns @ def_inits @ from_generics @ new_instances)
(declared_fns @ def_inits @ from_generics @ new_instances @ prelude_moved)
in
(* A constant that changed and can be published: known to the host, not
consumed by the checker. The module stores its new value at the frame
@ -2313,7 +2380,10 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
the break loop reports reads it. *)
let parsed =
if pause then
{ Ast.e = Ast.Do [ Ast.pause_call parsed.Ast.loc; parsed ];
{ Ast.e =
Ast.Do
[ Ast.pause_call ~fn:(prelude_fn t.decls "pause") parsed.Ast.loc;
parsed ];
Ast.loc = parsed.Ast.loc }
else parsed
in

6
lib/spawn.ml Normal file
View File

@ -0,0 +1,6 @@
(** Starting a program that dies with this process; see spawn_stubs.c. *)
external dying : string -> string array -> int = "flan_spawn_dying"
(** The host number of an OCaml signal number. *)
external host_signal : int -> int = "flan_host_signal"

58
lib/spawn_stubs.c Normal file
View File

@ -0,0 +1,58 @@
/* Starting a program that dies with the process that started it.
*
* `flan run` builds a program, runs it and deletes it. A flan killed by
* SIGKILL runs nothing on the way out, so without this the program would go on
* running with nobody waiting for it. On Linux the child asks the kernel for
* SIGKILL when its parent dies, between the fork and the exec; elsewhere it is
* an ordinary fork and exec.
*/
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
#include <caml/fail.h>
/* Exported by the runtime, declared only under CAML_INTERNALS. */
extern int caml_convert_signal_number(int);
#include <errno.h>
#include <signal.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#ifdef __linux__
#include <sys/prctl.h>
#endif
value flan_spawn_dying(value path, value argv) {
CAMLparam2(path, argv);
mlsize_t n = Wosize_val(argv), i;
char **args = malloc((n + 1) * sizeof(char *));
char *file = strdup(String_val(path));
pid_t parent = getpid(), pid;
if (args == NULL || file == NULL) caml_failwith("flan_spawn_dying: out of memory");
for (i = 0; i < n; i++) args[i] = strdup(String_val(Field(argv, i)));
args[n] = NULL;
pid = fork();
if (pid == 0) {
sigset_t none;
sigemptyset(&none);
sigprocmask(SIG_SETMASK, &none, NULL);
#ifdef __linux__
prctl(PR_SET_PDEATHSIG, SIGKILL);
/* The parent may have died before the request was made. */
if (getppid() != parent) _exit(137);
#endif
execv(file, args);
_exit(127);
}
for (i = 0; i < n; i++) free(args[i]);
free(args);
free(file);
if (pid < 0) caml_failwith(strerror(errno));
CAMLreturn(Val_int(pid));
}
/* OCaml numbers the signals it knows by negative constants; a shell's exit
* status wants the host's number. */
value flan_host_signal(value s) {
return Val_int(caml_convert_signal_number(Int_val(s)));
}

50
lib/wire.ml
View File

@ -29,6 +29,56 @@ let quote s =
let list items = "(" ^ String.concat " " items ^ ")"
let strings ss = list (List.map quote ss)
(* A unix socket path is at most 107 bytes: [sun_path] is 108 and holds the
terminating NUL. A longer one is reached through its directory instead,
opened and named as [/proc/self/fd/N/], which Linux resolves like the path
itself, so only the file's own name has to fit. The descriptor is closed as
soon as the bind or connect returns; the socket file stays where it was
made. *)
let max_socket_path = 107
let proc_prefix = String.length "/proc/self/fd/2147483647/"
let socket_fits path =
String.length path <= max_socket_path
|| String.length (Filename.basename path) + proc_prefix <= max_socket_path
let with_socket_addr path k =
if String.length path <= max_socket_path then k (Unix.ADDR_UNIX path)
else begin
let d =
Unix.openfile (Filename.dirname path) [ Unix.O_RDONLY; Unix.O_CLOEXEC ] 0
in
Fun.protect
~finally:(fun () -> try Unix.close d with Unix.Unix_error _ -> ())
(fun () ->
(* A [file_descr] is the fd number on Unix. *)
k (Unix.ADDR_UNIX
(Printf.sprintf "/proc/self/fd/%d/%s" (Obj.magic d : int)
(Filename.basename path))))
end
(* Where a client that cannot use the directory route above — Emacs, whose
[make-network-process] takes only a path — finds a socket whose own path is
too long: a symlink the daemon makes at a short path computed from the long
one, the same way on both sides. emacs/flan.el's [flan--short-socket] is
the other copy of this rule. *)
let short_socket_path path =
let abs =
if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path
else path
in
let dir =
match Sys.getenv_opt "XDG_RUNTIME_DIR" with
| Some d when d <> "" && Sys.file_exists d && Sys.is_directory d -> d
| _ -> "/tmp"
in
Filename.concat dir
("flan-" ^ String.sub (Digest.to_hex (Digest.string abs)) 0 16 ^ ".sock")
let bind_socket s path = with_socket_addr path (Unix.bind s)
let connect_socket s path = with_socket_addr path (Unix.connect s)
let send fd payload =
let framed = Printf.sprintf "%d\n%s" (String.length payload) payload in
let n = String.length framed in

30
spec-syntax.md
View File

@ -180,8 +180,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
@ -348,8 +364,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

23
test/programs/dev-parity.flan
View File

@ -54,18 +54,19 @@
(defonce pair (Pair i32))
;; The innermost frame names every global above, so the break loop's section
;; holds all of them; then it stops. Each is stored back to itself rather than
;; printed: a frame that prints is refused attribution today (TODO.org, "A
;; frame that prints is skipped from the globals section"), and this is about
;; the values.
;; holds all of them; then it stops. It prints them, and a frame whose only
;; slots are the printer's temporaries is still attributed its globals.
;; [nowhere] is stored to itself as well: a pointer prints as <ptr> without
;; reading the variable, so printing it alone would not name it.
(defn inner [] i64
(set small small) (set mid mid) (set large large) (set huge huge)
(set neg neg) (set ratio ratio) (set far far) (set odd odd) (set yes yes)
(set byte byte) (set text text) (set colour colour) (set stray stray)
(set some some) (set none none) (set wide wide) (set deep deep)
(set dot dot) (set empty empty) (set row row) (set words words)
(set nums nums) (set live live) (set dead dead) (set nowhere nowhere)
(set un un) (set anything anything) (set pair pair)
(print small) (print mid) (print large) (print huge)
(print neg) (print ratio) (print far) (print odd) (print yes)
(print byte) (print text) (print colour) (print stray)
(print some) (print none) (print wide) (print deep)
(print dot) (print empty) (print row) (print words)
(print nums) (print live) (print dead) (print nowhere)
(print un) (print anything) (print pair) (set nowhere nowhere)
(println "")
(error (Boom {.why 3}))
0)

20
test/syntax/algorithms.fln
View File

@ -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
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)

28
test/syntax/sand.fln
View File

@ -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

9
test/test_acceptance.ml
View File

@ -7354,6 +7354,15 @@ level "1"
(Printf.sprintf "run %s" (Filename.quote nomain)) ~code:1
~says:[ "has no main"; "(defn main [] i32" ];
Sys.remove nomain;
(* A program killed by a signal ends [flan run] with the shell's
128 + n for it, SIGSEGV's 139 here, not a flat 255. *)
let killed = Filename.concat scratch "killed.flan" in
Out_channel.with_open_bin killed (fun oc ->
output_string oc
"(declare-c raise [s i32] i32 \"raise\")\n(defn main [] i32 (raise 11))\n");
cli_case "run of a program killed by a signal exits 128 + n"
(Printf.sprintf "run %s" (Filename.quote killed)) ~code:139 ~says:[];
Sys.remove killed;
(* Every row above that went through the pool has been forked; nothing
after this point may look at [failures] until every one of them has

182
test/test_dev.ml
View File

@ -5832,14 +5832,11 @@ let () =
(* ── What stops a session from starting, said at the start ─────────
Three things a session cannot start without, each refused before
anything is built, in both shapes, with the fix named: a TMPDIR that
does not exist (it was an uncaught ENOENT out of mkdir), one so deep
that the agent's socket path does not fit in a unix socket address
(the bind failed where nobody heard it, and every reply after that
said "File name too long" or asked about (agent/start ...)), and a
program with no main (a link error, or a sentence about the merged
build's internals). *)
Two things a session cannot start without, each refused before
anything is built, with the fix named: a TMPDIR that does not exist (it
was an uncaught ENOENT out of mkdir), and a program with no main (a
link error, or a sentence about the merged build's internals). A TMPDIR
too deep for a socket path is not one of them; see the session below. *)
let refused_at_start what ~tmpdir ~prog ~mode want =
let out = tmp "start-refusal.out" in
let fd = Unix.openfile out [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
@ -5870,17 +5867,10 @@ let () =
want
in
let here = Filename.get_temp_dir_name () in
let deep =
Filename.concat here (String.make (max 1 (110 - String.length here)) 'd')
in
Unix.mkdir deep 0o700;
let missing = Filename.concat here "no-such-directory" in
let nomain = "programs/dev-nomain.flan" in
List.iter
(fun mode ->
refused_at_start "a TMPDIR too deep for a socket path" ~tmpdir:deep
~prog:"programs/dev-lateagent.flan" ~mode
[ "at most 107 bytes"; "TMPDIR=/tmp flan dev" ];
refused_at_start "a TMPDIR that does not exist" ~tmpdir:missing
~prog:"programs/dev-lateagent.flan" ~mode
[ missing ^ " does not exist"; "TMPDIR=/tmp flan dev" ];
@ -5890,7 +5880,157 @@ let () =
refused_at_start "a program with no main" ~tmpdir:here ~prog:nomain
~mode [ "has no main"; "(defn main [] i32"; "without --two-process" ])
[ [||]; [| "--two-process" |] ];
(try Unix.rmdir deep with Unix.Unix_error _ -> ());
(* ── A session under a TMPDIR too deep for a socket path ────────────
Both sockets are past the 107 bytes a unix socket address holds: the
editor's, named with -s, and the agent's, which the daemon puts under
TMPDIR. Both are bound and reached through their directory, so the
session starts and an evaluation reaches the program, in both shapes.
It used to be refused, and before that it failed at the bind. *)
let deep =
Filename.concat here (String.make (max 1 (110 - String.length here)) 'd')
in
Unix.mkdir deep 0o700;
List.iter
(fun mode ->
let shape = if mode = [||] then "one process" else "--two-process" in
let dsock = Filename.concat deep "editor-socket-for-a-deep-tmpdir.sock"
and dout = tmp "deep.out" in
let fd =
Unix.openfile dout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let env =
Array.append [| "TMPDIR=" ^ deep |]
(Array.of_list
(List.filter
(fun v -> not (String.starts_with ~prefix:"TMPDIR=" v))
(Array.to_list (Unix.environment ()))))
in
let pid =
Unix.create_process_env flan
(Array.append
[| flan; "dev"; "programs/dev-pause.flan"; "-s"; dsock |] mode)
env Unix.stdin fd fd
in
Unix.close fd;
if not (listening ~pid dsock) then begin
fail "a deep TMPDIR (%s): the daemon %s (%S)" shape !listen_why
(In_channel.with_open_bin dout In_channel.input_all);
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect dsock in
let said r =
Option.value ~default:(status r) (Wire.string_field r "message")
in
let r =
request c
"(:op \"eval\" :code \"(defn boom [] i64 7)\" :file \
\"programs/dev-pause.flan\")"
in
if status r <> "ok" then
fail "a deep TMPDIR (%s): eval: %s" shape (said r);
let answered = ref "" in
let seven () =
let r =
request c
"(:op \"eval-expr\" :code \"(boom)\" :file \
\"programs/dev-pause.flan\")"
in
answered := Option.value ~default:(said r) (Wire.string_field r "value");
!answered = "7"
in
if not (await ~ms:20000 seven) then
fail "a deep TMPDIR (%s): (boom) answered %S" shape !answered;
(try
ignore (Wire.send c "(:op \"close\")");
ignore (Wire.recv c)
with _ -> ());
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ())
end;
(try Sys.remove dout with Sys_error _ -> ()))
[ [||]; [| "--two-process" |] ];
Own_tmp.remove deep;
(* ── Prelude functions shadowed live keep the prelude's own calls ──
[rand] and then [rand-int] redefined in a running program: the
prelude's [rand-float-range] still reaches the prelude's [rand], which
still reaches the prelude's [rand-int], so it answers something other
than what 4096 would make of it. The second shadowing moves a call
inside a body the first one had already moved. Both backends. *)
List.iter
(fun backend ->
let ssock = tmp ("shadow" ^ backend ^ ".sock")
and sout = tmp ("shadow" ^ backend ^ ".out") in
(try Sys.remove ssock with Sys_error _ -> ());
let fd =
Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let pid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-pause.flan"; "-s"; ssock; backend |]
Unix.stdin fd Unix.stderr
in
Unix.close fd;
if not (listening ~pid ssock) then begin
fail "the %s shadowing daemon %s" backend !listen_why;
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect ssock in
let said r =
Option.value ~default:(status r) (Wire.string_field r "message")
in
(try
List.iter
(fun code ->
let r =
request c
(Printf.sprintf
"(:op \"eval\" :code %S :file \"programs/dev-pause.flan\")"
code)
in
if status r <> "ok" then
fail "%s: %s: %s" backend code (said r))
[ "(defn rand [] f64 0.5)"; "(defn rand-int [] u64 4096)" ];
let ask code =
let r =
request c
(Printf.sprintf
"(:op \"eval-expr\" :code %S :file \"programs/dev-pause.flan\")"
code)
in
Option.value ~default:(said r) (Wire.string_field r "value")
in
(match ask "(rand-int)", ask "(rand)" with
| "4096", "0.5" -> ()
| a, b ->
fail "%s: the shadowing bodies answer %s and %s" backend a b);
(* 4096 through the prelude's rand is 2^-52, which is what the
prelude's calls answered when they followed the new body. *)
let v = ask "(rand-float-range 0.0 1.0)" in
match float_of_string_opt v with
| Some x when x > 1e-9 && x < 1.0 -> ()
| _ ->
fail "%s: the prelude's rand-float-range followed a shadowing \
body: %s" backend v
with (Wire.Closed | Unix.Unix_error _) as e ->
fail "%s: the shadowing session ended: %s" backend
(Printexc.to_string e));
(try
ignore (Wire.send c "(:op \"close\")");
ignore (Wire.recv c)
with _ -> ());
(try Unix.close c with Unix.Unix_error _ -> ());
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ())
end;
(try Sys.remove sout with Sys_error _ -> ()))
[ "--llvm"; "--x86" ];
(* ── A build that fails is a refusal, not the end of the session ── *)
@ -6241,7 +6381,7 @@ let () =
let hit_and_run () =
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
(try
Unix.connect s (Unix.ADDR_UNIX rsock);
Wire.connect_socket s rsock;
Wire.send s "(:op \"describe\")"
with Unix.Unix_error _ -> ());
(try Unix.close s with Unix.Unix_error _ -> ())
@ -6971,6 +7111,9 @@ let () =
:: _); _ } -> n
| _ -> ""
in
(* A daemon that goes away mid-question is a failure named here, not
a [Wire.Closed] that ends the binary with every later row unrun. *)
(try
if not (await (fun () -> inside () = "in-local")) then
fail "%s: the program never stopped inside the local's assignment" flag
else begin
@ -7009,7 +7152,10 @@ let () =
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got))
end
end;
end
with (Wire.Closed | Unix.Unix_error _) as e ->
fail "%s: the half-write session ended under a question: %s" flag
(Printexc.to_string e));
(* No [close]: the program is stopped with nothing left to resume into,
so the way out is the abort, and the daemon follows the program. An
abort is refused by a program that is *running*, which is what a

66
test/test_emacs.ml
View File

@ -148,3 +148,69 @@ let () =
exit 1
end
end
(* A socket path longer than a unix socket address holds, which Emacs cannot
connect to by name: the daemon links it at a short path, the client
computes the same one, and the link goes when the session is closed. *)
let () =
let have = Test_support.have in
if have "emacs" && have "clang" && have "llc" then begin
let deep =
Filename.concat Test_support.scratch
(String.make (max 1 (110 - String.length Test_support.scratch)) 'd')
in
Unix.mkdir deep 0o700;
let sock = Filename.concat deep "an-editor-socket-past-the-limit.sock"
and err = tmp "long.err" in
let efd = Unix.openfile err [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let flan = "../bin/main.exe" in
let pid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-pause.flan"; "-s"; sock |]
Unix.stdin efd efd
in
Unix.close efd;
let short = Flan.Wire.short_socket_path sock in
let failed = ref false in
let fail fmt =
Printf.ksprintf (fun s -> failed := true; print_endline ("FAIL " ^ s)) fmt
in
if not (listening ~pid sock) then fail "the long-socket daemon %s" !listen_why
else begin
let code =
Sys.command
(Printf.sprintf
"emacs -Q --batch -L ../../../emacs -l flan --eval %s 2>&1"
(Filename.quote
(Printf.sprintf
"(progn (flan--open %S) \
(flan--send flan--connection '(:op \"describe\")) \
(let ((r (flan--read-reply flan--connection))) \
(flan--send flan--connection '(:op \"close\")) \
(ignore-errors (flan--read-reply flan--connection)) \
(delete-process flan--connection) \
(kill-emacs (if (equal (plist-get r :status) \"ok\") 0 1))))"
sock)))
in
if code <> 0 then
fail "emacs could not talk to a daemon on a %d-byte socket path \
(exit %d; daemon: %s)" (String.length sock) code
(In_channel.with_open_bin err In_channel.input_all)
end;
if not (await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] pid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] pid) with Unix.Unix_error _ -> ());
fail "the long-socket daemon did not end when the client left"
end
else if (try ignore (Unix.lstat short); true with Unix.Unix_error _ -> false)
then fail "the short link %s was left after a clean end" short;
(try Unix.unlink short with Unix.Unix_error _ -> ());
(try Sys.remove err with Sys_error _ -> ());
Own_tmp.remove deep;
if !failed then exit 1 else print_endline "emacs: a long socket path connects"
end

72
test/test_session.ml
View File

@ -265,6 +265,78 @@ let () =
if has c.Session.ir "flan_dev_cell" then
fail "a name the host has went through the registry";
(* A defn of a prelude function's name, sent live. The host's prelude calls
[rand-int] through the cell the new body goes into, so the prelude's body
moves to its own name and its callers are compiled again to call it, as
a rebuild would have them. Once: a second redefinition moves nothing. *)
(let t, _ = Session.create ~file:"programs/reload.flan" () in
let c =
Session.eval ~origin:"programs/reload.flan" t "(defn rand-int [] u64 4096)"
in
List.iter
(fun n ->
if not (List.mem n c.Session.fns) then
fail "shadowing rand-int live did not install %s: %s" n
(String.concat " " c.Session.fns))
[ "rand-int"; "prelude~/rand-int"; "rand"; "rand-int-range" ];
let c =
Session.eval ~origin:"programs/reload.flan" t "(defn rand-int [] u64 8)"
in
if c.Session.fns <> [ "rand-int" ] then
fail "redefining a shadowed rand-int again installed %s"
(String.concat " " c.Session.fns));
(* Two shadowings, in either order: the prelude body the first one moved is
compiled again when the second moves a call inside it. *)
List.iter
(fun (first, second, want) ->
let t, _ = Session.create ~file:"programs/reload.flan" () in
ignore (Session.eval ~origin:"programs/reload.flan" t first);
let c = Session.eval ~origin:"programs/reload.flan" t second in
List.iter
(fun n ->
if not (List.mem n c.Session.fns) then
fail "shadowing %S after %S did not install %s: %s" second first
n (String.concat " " c.Session.fns))
want)
[ ("(defn rand [] f64 0.5)", "(defn rand-int [] u64 4096)",
[ "rand-int"; "prelude~/rand-int"; "prelude~/rand" ]);
("(defn rand-int [] u64 4096)", "(defn rand [] f64 0.5)",
[ "rand"; "prelude~/rand" ]) ];
(* And a mark or a step once the program has a [pause] and a [step-point] of
its own: the call spliced in is still the prelude's, or a mark would run
the program's function and never stop. *)
(let t, _ = Session.create ~file:"programs/reload.flan" () in
ignore (Session.eval t "(defn pause [] i64 0)");
ignore (Session.eval t "(defn step-point [] bool false)");
let calls name want =
match
List.find_opt (fun (f : Tast.fn) -> f.Tast.name = name)
t.Session.program.Tast.fns
with
| None -> false
| Some f ->
let hit = ref false in
List.iter
(Tast.walk (fun (e : Tast.expr) ->
match e.Tast.e with
| Tast.Call (m, _) when m = want -> hit := true
| _ -> ()))
f.Tast.body;
!hit
in
ignore
(Session.eval ~pause:(1, 1) t
"(defn bump [] i64 (set counter (+ counter 5)) counter)");
if not (calls "bump" "prelude~/pause") then
fail "a mark with the program's own pause defined does not call the prelude's";
ignore
(Session.eval ~step:true t
"(defn bump [] i64 (set counter (+ counter 5)) counter)");
if not (calls "bump" "prelude~/step-point") then
fail "a step with the program's own step-point defined does not call the prelude's");
(* DWARF in a redefinition module, which is a property of the session and
not of the call. [Emit.redefinition] has taken a ~debug argument all
along and was tested with it; what was missing was anyone passing it, so

9
test/test_support.ml
View File

@ -89,7 +89,12 @@ let scratch = Own_tmp.dir
same time under dune, so "flan-agent-dev.sock" and "flan-repl-dev.sock"
being different files is what keeps two suites from unlinking each other's
sockets. *)
let tmp prefix name = Filename.concat scratch (prefix ^ name)
let tmp prefix name =
(* A socket goes without the prefix: [scratch] is this binary's alone, and a
unix socket path is short (see [Wire.max_socket_path]), which an emacs
client connecting by the plain path cannot get around. *)
if Filename.check_suffix name ".sock" then Filename.concat scratch name
else Filename.concat scratch (prefix ^ name)
(* ── Toolchain probes ─────────────────────────────────────────────── *)
@ -126,7 +131,7 @@ let rec await ?(ms = 5000) f =
disk, so the race this does catch is the only one left. *)
let rec connect ?(ms = 5000) path =
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
match Unix.connect s (Unix.ADDR_UNIX path) with
match Wire.connect_socket s path with
| () -> s
| exception Unix.Unix_error (Unix.ECONNREFUSED, _, _) when ms > 0 ->
Unix.close s;

335
test/test_syntax.ml
View File

@ -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)
@ -113,13 +272,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 =
@ -211,7 +372,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 ->
@ -359,7 +521,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))";
@ -421,6 +584,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
@ -440,6 +605,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()";
@ -685,8 +945,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";
(* Return types read off the body, in both spellings of [_]. *)

33
vendor/agent/flan_agent.c vendored
View File

@ -43,6 +43,7 @@
#endif
#include <dlfcn.h>
#include <errno.h>
#include <fcntl.h>
#include <stdlib.h>
#include <pthread.h>
#include <setjmp.h>
@ -1015,6 +1016,10 @@ int32_t flan_agent_poll(void);
* came from. */
static char bound_sock[sizeof(((struct sockaddr_un *)0)->sun_path)];
/* The directory a socket path too long for sun_path was bound through, or -1;
* see [start_on]. */
static int sock_dir_fd = -1;
/* A socket file outlives the process that bound it, and a stale one answers
* the next client with ECONNREFUSED — which reads like a program that is there
* and refusing rather than one that has gone. So the bind registers its own
@ -2732,10 +2737,32 @@ static int32_t start_on(const char *path) {
int made = 0;
if (atomic_exchange(&started, 1)) return 1;
len = strlen(path);
if (len == 0 || len >= sizeof addr.sun_path) goto failed;
if (len == 0) goto failed;
memset(&addr, 0, sizeof addr);
addr.sun_family = AF_UNIX;
memcpy(addr.sun_path, path, len);
if (len < sizeof addr.sun_path) {
memcpy(addr.sun_path, path, len);
} else {
/* Too long for sun_path: bound through its directory, opened and named
* as /proc/self/fd/N/, which Linux resolves like the path itself. The
* descriptor stays open for the life of the process, because the unlinks
* at exit go through the same name. */
const char *slash = strrchr(path, '/');
char dir[4096];
int n;
size_t dlen = slash == NULL ? 0 : (size_t)(slash - path);
if (slash == NULL || dlen >= sizeof dir) goto failed;
memcpy(dir, path, dlen);
dir[dlen] = '\0';
if (sock_dir_fd < 0)
sock_dir_fd = open(dlen == 0 ? "/" : dir,
O_RDONLY | O_DIRECTORY | O_CLOEXEC);
if (sock_dir_fd < 0) goto failed;
n = snprintf(addr.sun_path, sizeof addr.sun_path, "/proc/self/fd/%d/%s",
sock_dir_fd, slash + 1);
if (n < 0 || (size_t)n >= sizeof addr.sun_path) goto failed;
len = (size_t)n;
}
unlink(addr.sun_path);
fd = socket(AF_UNIX, SOCK_STREAM, 0);
if (fd < 0) goto failed;
@ -2814,7 +2841,7 @@ static const char *daemon_socket(void) {
* and guessing wrong fails silently: everything compiles, the module is built,
* and nothing ever receives it. */
int32_t flan_agent_start(const uint8_t *path, int64_t len) {
char buf[sizeof(((struct sockaddr_un *)0)->sun_path)];
char buf[4096];
const char *env = daemon_socket();
if (env != NULL) return start_on(env) < 0 ? -1 : 0;
if (len <= 0 || (size_t)len >= sizeof buf) return -1;