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

flan dev starts on a file with no main and links the agent into every program it builds, C-c C-k loads a file keeping what compiles, and an expression sent from a package's file resolves in that package

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 12:44:15 +07:00
parent d2867a4267
commit 11e1ff10a7
14 changed files with 721 additions and 276 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
TODO.org
View File

@ -1693,10 +1693,9 @@ nothing sweeps other sessions' directories.
CLOSED: [2026-09-20]
The zero-argument form takes the daemon's socket where there is one and an
announced path where there is not, bound by a constructor before =main=. =Reach=
prunes a package nothing calls into, so the constructor reaches only a program
that polls or waits. Full invisibility — a dev build linking the agent whether or
not the source says so — needs the package force-linked and is a decision about
what =--dev= means.
prunes a package nothing calls into in a release build. =flan dev= links the
agent's C into every program it builds whether or not the source imports it; a
release build links it only when the program calls into it.
** NEXT FLAN_AGENT_SOCKET in a shell's environment steals the socket
Decided 2026-09-25: narrow the gate. The daemon also exports its own pid, and the constructor binds the socket only when that pid is the program's parent (or the program itself, in a merged build).
@ -2091,12 +2090,6 @@ motion states in that mode; every other key, including what =special-mode-map=
binds, stays Evil's. The other special-mode buffers (inspect, watch, doc, disassembly,
diagnostics, lower) have the same exposure and are not changed.
** NEXT C-x C-e in a package's file resolves names in that package
Decided 2026-09-25: CIDER's rule — an evaluation sent from a file resolves names
as code written in that file would, so =(integrate 1.0)= in =physics/step.flan=
reaches the package's own functions, =defn-= included. Today it answers
"unknown function", resolving as the program's main file.
** NEXT Evil takes the keys in the other Flan buffers
The inspect, watch, doc, disassembly, diagnostics and lower buffers get the break
buffer's treatment: the keys each binds itself go to Evil's normal and motion
@ -2174,13 +2167,9 @@ daemon asks for the sink off (=lib/loc.ml:185=) and gets one exception, so a
function with three bad expressions takes three round trips. The sink is
per-phase; making it per-form would need a resync point inside a body.
** NEXT A session should start before a program compiles
Decided 2026-09-25: SBCL/nREPL order: an empty host session, then a load-file op. Re-running with no =main= says there is none; a half-loaded file keeps what compiled and lists the errors. =C-c C-k= is load-file and the inspector moves to =C-c M-i=, CIDER's key.
=flan dev= builds the program first, so a =main= that does not compile gives no
session. Want SBCL/nREPL order: empty image, then load a file into it. Needs a
host built with no user program, and a load-file op — the reload machinery
already builds a file as a module. Open: what =flan-rerun= does with no =main=,
and a half-loaded file. =C-c C-k= is taken by the inspector.
** DONE A session should start before a program compiles
CLOSED: [2026-09-25]
A file with no =main= starts on a stub =main= that returns and parks; =load-file= (=C-c C-k=, already its key — the inspector stays on =C-c C-i=) keeps what compiles and lists the rest. Rules out =flan dev= with no file at all, and =--two-process= on a file with no =main=.
** NEXT The daemon buffer is navigable but not coloured
Decided 2026-09-25: errors, warnings and notes take compilation-mode's faces, and the program's own output takes a face of its own so it reads apart from the compiler's.

38
emacs/MANUAL.md
View File

@ -90,6 +90,20 @@ stops the program too — but only one this Emacs started. A daemon you launched
in a terminal is not Emacs' to kill, and it will say so rather than do something
surprising.
### A file with no `main`
A file of functions with no `main` — a scratch file, a library being written —
starts a session too. Nothing runs, and the session is there to take
definitions and expressions: `C-x C-e` on `(fib 10)` answers, and `C-c C-k`
loads more into it. `M-x flan-rerun` says there is no `main` until one has been
loaded.
A form in such a file that does not compile is left out of the start and printed
in `*flan*`, and the session starts with the rest.
The program does not have to import the agent. `flan dev` links it into every
program it builds, and a release build is unaffected.
### Which backend the session uses, and what it costs
`flan dev` compiles the session with the hand-written x86-64 backend. That is
@ -195,6 +209,11 @@ The form before point can also be a declaration — a `defonce` typed at the top
a file — in which case `C-x C-e` installs it rather than refusing it, and says
which names changed instead of printing a value.
**Names mean what they mean in the file.** An expression sent from a package's
file resolves as code written in that file would: `(integrate 1.0)` in
`physics/step.flan` reaches `physics/integrate`, a `defn-` included. The REPL is
not a file, so there the program's own names apply.
### `C-u C-c C-c` — stop there
The same key with a prefix argument **marks a form as a breakpoint**. `C-u C-c
@ -261,12 +280,18 @@ drawn on the call — it does not hang.
### `C-c C-k` — the whole buffer
The whole buffer, sent as **one** module rather than as a form at a time. That
matters: a `defonce` and the function that uses it have to arrive together, or the
function refers to storage that does not exist yet.
The whole buffer is loaded into the running program, as `C-c C-k` loads a file in
SLIME and CIDER. It is sent as **one** module rather than as a form at a time.
That matters: a `defonce` and the function that uses it have to arrive together,
or the function refers to storage that does not exist yet.
Use this when you have changed several things at once, or when you have added a
new global.
A form that does not compile is left out, and so is any form that uses it; the
rest are installed. Each form left out is marked in the buffer and listed in
`*flan-diagnostics*`, and the echo area counts them. When nothing compiles,
nothing is installed and the first error is reported as `C-c C-c` reports one.
Use this when you have changed several things at once, when you have added a new
global, or to load a file into a session started on another.
### When it lands
@ -1155,7 +1180,8 @@ Use `C-c C-g` if you need frames.
| `C-c C-c` | the top-level form at point: a declaration installed, anything else evaluated |
| `C-u C-c C-c` | ...and stop at the form point is inside (`C-u C-u`: on entry) |
| `C-M-x` | the same as `C-c C-c`, on the binding SLIME and CIDER use |
| `C-c C-k` | the whole buffer, as one module |
| `C-c C-k` | load the whole buffer, as one module; what does not compile is listed |
| `C-x C-e` | the form before point, evaluated — or installed, if it is a declaration |
| `C-u C-x C-e` | ...and stop at it instead of showing its value |
| `C-c C-z` | connect (finds `.flan-dev.sock` upward) |

68
emacs/flan.el
View File

@ -1618,15 +1618,17 @@ quitting the program — which is the point of it."
(set-marker flan--diagnostics-memory-start nil)
(setq flan--diagnostics-memory-start nil))))
(defun flan--show-error (loc msg)
(defun flan--show-error (loc msg &optional keep)
"Mark MSG at LOC, if LOC names a file some buffer is visiting.
The buffer's other error marks are taken down first unless KEEP is non-nil.
Returns non-nil when it put an overlay somewhere."
(let ((parts (flan--parse-loc loc)))
(when parts
(let ((buf (flan--buffer-visiting (nth 0 parts))))
(when buf
(with-current-buffer buf
(flan-clear-errors buf)
(unless keep (flan-clear-errors buf))
;; A refusal is not a value, and the two must never be drawn over
;; one form at once. Ordinarily the command that ran this
;; evaluation already cleared the last one through the hook; this
@ -1651,7 +1653,8 @@ Returns non-nil when it put an overlay somewhere."
;; Point goes there too, but only in the buffer being looked at:
;; moving point in a buffer nobody is showing is a surprise the
;; next time it is visited.
(when (eq buf (current-buffer)) (goto-char beg))
(when (and (not keep) (eq buf (current-buffer)))
(goto-char beg))
t)))))))
;;; Inline results
@ -2795,18 +2798,55 @@ declaration for it to live in."
;;;###autoload
(defun flan-eval-buffer ()
"Recompile every top-level form in this buffer and install them together.
One module, not one per form: a var and the function that uses it have to
arrive in the same load or the first refers to storage that does not exist."
"Load this buffer into the running program, as `C-c C-k' does in SLIME and CIDER.
Every top-level form is compiled and installed together, as one module: a var
and the function that uses it have to arrive in the same load or the first
refers to storage that does not exist.
A form that does not compile is left out, and so is a form that uses it; the
rest are installed. Each one left out is marked in the buffer and listed in
`flan-diagnostics-buffer'. When nothing compiles, nothing is installed and
the command signals, as `C-c C-c' does."
(interactive)
(flan--eval (buffer-substring-no-properties (point-min) (point-max))
(buffer-name))
;; `flan--eval' signals on a rejection, so reaching here means every
;; declaration in the buffer was just replaced by an unmarked one — and
;; therefore that every mark in it is gone. Done here rather than by passing
;; bounds, because those are also what gets flashed and pulsing a whole
;; buffer is not feedback, it is a flicker.
(flan-clear-pause))
(let* ((reply (flan--request
(list :op "load-file" :file (or buffer-file-name "<buffer>")
:code (buffer-substring-no-properties
(point-min) (point-max)))))
(errors (plist-get reply :errors)))
(if (equal (plist-get reply :status) "ok")
(progn
(flan--report reply (buffer-name))
;; Every declaration that installed was replaced by an unmarked one,
;; so every mark in the buffer is gone. Done here rather than by
;; passing bounds, because those are also what gets flashed and
;; pulsing a whole buffer is not feedback, it is a flicker.
(flan-clear-pause)
(when errors
(flan--report-load-errors errors)
(message "flan: %s loaded; %d form%s did not compile, listed in %s"
(buffer-name) (length errors)
(if (= (length errors) 1) "" "s")
flan-diagnostics-buffer)))
;; `flan--report' records, marks and signals the first; the others are
;; recorded and marked beside it before the signal leaves.
(condition-case err
(flan--report reply (buffer-name))
(user-error
(flan--report-load-errors (cdr errors) t)
(signal (car err) (cdr err)))))
reply))
(defun flan--report-load-errors (errors &optional keep)
"Record and mark each of ERRORS, a load reply's `:errors' list.
The marks from earlier in the same load are kept, and so are the marks
already in the buffer when KEEP is non-nil."
(let ((first (not keep)))
(dolist (e errors)
(let ((loc (plist-get e :loc))
(msg (plist-get e :message)))
(ignore-errors (flan--record-diagnostic loc msg))
(ignore-errors (flan--show-error loc msg (not first)))
(setq first nil)))))
;;;###autoload
(defun flan-eval-last-sexp (&optional arg)

61
emacs/test-flan.el
View File

@ -2302,6 +2302,67 @@ already rely on it — so nothing here is a stand-in for the real thing."
(flan-quit)
(ignore-errors (delete-file socket5)))
;; ── A file with no main ───────────────────────────────────────────────
;;
;; SBCL's order: the session comes up on a file that has nothing to run,
;; and `C-c C-k' loads into it. A load keeps what compiles and marks what
;; does not; a re-run says there is no main.
(let ((socket6 (concat socket "-nomain"))
(scratch (expand-file-name "nomain.flan" (file-name-directory file)))
(value (lambda (code)
(plist-get (flan--request
(list :op "eval-expr" :code code :file "<test>"))
:value))))
(with-temp-file scratch
(insert "(defn fib [n i64] i64\n (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))\n"))
(ignore-errors (delete-file socket6))
(flan scratch socket6)
(test-flan--check "a daemon starts on a file with no main"
(process-live-p flan--connection))
(test-flan--check "and an expression reaches the file's functions"
(equal (funcall value "(fib 10)") "55"))
(with-current-buffer (find-file-noselect scratch)
(goto-char (point-max))
(insert "\n(defn biggest [xs [$t]] $t\n {:where (ordered? $t)}\n"
" (let [m (at xs 0)]\n (dotimes [i (length xs)]\n"
" (set m (max m (at xs i))))\n m))\n\n"
"(defn twice [n i64] i64 (* 2 n))\n")
(flan-eval-buffer)
(test-flan--check "C-c C-k loads a generic into it"
(equal (funcall value "(let [ns [3 9 2]] (biggest (slice ns 0 3)))")
"9"))
(test-flan--check "and a plain function"
(equal (funcall value "(twice 21)") "42"))
(erase-buffer)
(insert "(defn good [] i64 (bad))\n\n(defn bad [] i64 \"x\")\n\n"
"(defn fine [] i64 42)\n")
(let ((said (test-flan--said (flan-eval-buffer))))
(test-flan--check "a load with errors installs the rest and counts what it left out"
(and said (string-match-p "2 forms did not compile" said))))
(test-flan--check "and marks each form it left out"
(= 2 (length (flan--error-overlays))))
(test-flan--check "what compiled is in the program"
(equal (funcall value "(fine)") "42"))
(test-flan--check "and what used a form that did not is not"
(equal (plist-get (flan--request
(list :op "eval-expr" :code "(good)"
:file "<test>"))
:status)
"error"))
(erase-buffer)
(insert "(defn bad [] i64 \"x\")\n")
(test-flan--check "a load where nothing compiles is refused"
(condition-case nil (progn (flan-eval-buffer) nil)
(user-error t)))
(set-buffer-modified-p nil))
(test-flan--check "a re-run with no main says there is none"
(condition-case err (progn (flan-rerun) nil)
(user-error
(string-match-p "has no main" (error-message-string err)))))
(flan-quit)
(ignore-errors (delete-file socket6))
(ignore-errors (delete-file scratch)))
(if (zerop test-flan--failures)
(message "flan.el: all tests passed")
(message "\n%d failure(s)" test-flan--failures)

229
lib/dev.ml
View File

@ -122,27 +122,10 @@ let await ?(ms = 5000) f =
in
go ms
(* What a program needs so that code from the editor can reach it. Spelled once
because three replies give it: a delivery, an evaluation and the daemon's
own warning. Both lines compile as written. *)
let agent_howto =
"Import the agent with (import agent \"vendor:agent\") and call \
(agent/poll) once in each pass of the program's main loop, then start \
flan dev again."
let no_agent =
"the program has no agent, so nothing in it can receive code from the \
editor. " ^ agent_howto
(* Whether anything in this session can hand code to the program. A merged
build with no agent linked has no agent to call and never binds a socket,
and a connect to one answers "No such file or directory" about a path the
reader never chose; that is the case this names. *)
let agentless t = t.child = None && not (Agent.present ())
let unreachable t e =
if agentless t then no_agent
else "cannot reach the program: " ^ Unix.error_message e
(* Every program [flan dev] builds has the agent linked — see [with_agent] — so
a program that cannot be reached is one whose socket went away, not one that
never had an agent. *)
let unreachable _t e = "cannot reach the program: " ^ Unix.error_message e
(* Whether the program has bound the socket it receives modules on.
@ -183,7 +166,7 @@ let agent_check t =
t.agent_watch <- None;
Printf.eprintf
"flan dev: nothing is listening on %s, so code from the editor cannot \
reach the program. %s\n%!" t.agent agent_howto
reach the program.\n%!" t.agent
end
(* ── Asking the agent ──────────────────────────────────────────────── *)
@ -826,8 +809,8 @@ let refusal ~parked reply =
[max_socket_path], which [session_dir] refuses before building — 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. A program with no agent linked has nothing to
queue a module on, and its delivery is refused with [no_agent]. *)
cause, so there is none. *)
let install_note t ~parked =
if parked then begin
let first = not t.park_noted in
@ -882,7 +865,7 @@ let stale_field (ss : Session.stale list) =
(if x.Session.running then " :running t" else ""))
ss) ]
let eval t ~code ~origin ~pause =
let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
let now = liveness t in
let parked_now = now = Parked in
(* A park that is over takes its note with it: the long sentence below is
@ -905,15 +888,19 @@ let eval t ~code ~origin ~pause =
let refused msg = Session.restore t.session before; error msg in
if now = Gone then error gone
else
match Session.eval ~origin ?pause ~running:(not parked_now) t.session code with
match
Session.eval ~origin ?base ?forms ?pause ~running:(not parked_now)
t.session code
with
| c when not c.Session.installs ->
(* Accepted into the session and nothing to send: a declaration the
program already has, with no body and no new storage. Saying "ok" and
shipping an empty module would report success for a change that cannot
have taken effect. *)
ok
[ ":names " ^ Wire.strings c.Session.names; ":fns ()";
":note " ^ Wire.quote "nothing to install" ]
([ ":names " ^ Wire.strings c.Session.names; ":fns ()";
":note " ^ Wire.quote "nothing to install" ]
@ extra)
| c ->
(* Everything from here to the delivery is inside the restore, and by
exception type as well as by arm. The three named below are the ones
@ -965,14 +952,13 @@ let eval t ~code ~origin ~pause =
| Some (l, c) ->
[ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ]
| None -> [])
@ install_note t ~parked:parked_now)
@ install_note t ~parked:parked_now
@ extra)
| reply -> refused (refusal ~parked:parked_now reply)
| exception Unix.Unix_error (e, _, _) ->
refused
(if agentless t then no_agent
else
"cannot reach the program on " ^ t.agent ^ ": "
^ Unix.error_message e))
("cannot reach the program on " ^ t.agent ^ ": "
^ Unix.error_message e))
| exception Failure m -> refused m)
with e when not !accepted -> Session.restore t.session before; raise e)
(* Nothing to put back: the check itself raised, so [Session.eval] never
@ -984,6 +970,60 @@ let eval t ~code ~origin ~pause =
Session.restore t.session before;
error ~loc:(Loc.to_string l) msg
(* The refusals a load answered beside what it installed, one plist each. *)
let errors_field (ds : Loc.diag list) =
match ds with
| [] -> []
| ds ->
[ ":errors "
^ Wire.list
(List.map
(fun (d : Loc.diag) ->
Printf.sprintf "(:loc %s :message %s)"
(Wire.quote (Loc.to_string d.Loc.dloc))
(Wire.quote d.Loc.dmsg))
ds) ]
(* C-c C-k: a whole file into the running session, SBCL's [load]. [eval] with
one difference — a form that does not compile is left out and listed
rather than refusing the rest, so a file with one broken function still
defines the others ([Session.pruned] finds which). The survivors go through
[eval] as one module, as the whole buffer always has. When nothing
survives the reply is a refusal, with the first error where every other
refusal puts it. *)
let load_file t ~code ~origin =
match Reader.read_all ~file:origin code with
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
error ~loc:(Loc.to_string l) msg
| forms ->
(* The imports of a file on disk are its own, wherever the session's file
is. *)
let base = if Sys.file_exists origin then Some origin else None in
let running = liveness t <> Parked in
let check forms =
let before = Session.held t.session in
Fun.protect
~finally:(fun () -> Session.restore t.session before)
(fun () ->
ignore (Session.eval ~origin ?base ~forms ~running t.session code))
in
(match Session.pruned check forms with
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
error ~loc:(Loc.to_string l) msg
| exception Loc.Errors ({ Loc.dloc = l; dmsg = msg; _ } :: _ as ds) ->
let e = error ~loc:(Loc.to_string l) msg in
String.sub e 0 (String.length e - 1)
^ " " ^ String.concat " " (errors_field ds) ^ ")"
| (), kept, errs ->
if errs <> [] && kept = [] then
let d = List.hd errs in
let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in
String.sub e 0 (String.length e - 1)
^ " " ^ String.concat " " (errors_field errs) ^ ")"
else
eval ~forms:kept ?base ~extra:(errors_field errs) t ~code ~origin
~pause:None)
(* Redefining a name installs a body; evaluating an expression has no name to
install into, so the module carries a thunk the agent runs once. The value
comes back through the runtime rather than through this reply, because the
@ -1023,7 +1063,6 @@ let eval t ~code ~origin ~pause =
let eval_expr t ~code ~origin ~pause =
match liveness t with
| Gone -> error gone
| (Live | Parked) when agentless t -> error no_agent
| Live | Parked ->
(* The same rollback [eval] takes, for the same reason and a smaller
cargo. A thunk is not a declaration and never joins the session, but the
@ -3315,6 +3354,17 @@ let abort t =
let rerun t =
match liveness t with
| Gone -> error gone
(* A file started with no [main] runs a stub that returns at once; running
it again would answer "running main again" about nothing. *)
| (Live | Parked) when not (Session.has_main t.session) ->
error
(Printf.sprintf
"%s has no main, so there is nothing to run. A program starts at a \
function named main; add one and load the file with C-c C-k, for \
example:\n\n\
\ (defn main [] i32\n\
\ 0)"
t.session.Session.file)
| Live | Parked ->
(* Read before the request and not after it. Taking a re-run is what ends
the park — the C stores the new state as it accepts — so by the time
@ -4008,7 +4058,21 @@ let handle t req =
in
macroexpand t ~code ~origin ~all
| None -> error "macroexpand needs :code")
(* A whole file, [:code] being its text as the editor holds it — which need
not be what is saved — and [:file] where it lives. Without [:code] the
file is read from disk. *)
| Some "load-file" ->
(match Wire.string_field req "file" with
| None -> error "load-file needs :file"
| Some origin ->
(match Wire.string_field req "code" with
| Some code -> load_file t ~code ~origin
| None ->
(match read_file origin with
| code -> load_file t ~code ~origin
| exception Sys_error m -> error ("cannot read the file: " ^ m))))
| Some "describe" -> describe t
| Some "defs" -> defs t
| Some "break" -> break t
| Some "condition" -> condition_op t
@ -4539,9 +4603,10 @@ let make_session_dir ~file dir =
dev %s"
dir (Unix.error_message e) (Filename.quote file))
(* A session over a file with no [main] has nothing to run, and the build
would find that out at the link — as a missing symbol, or as the merged
build's rename finding nothing to rename. *)
(* The two-process daemon's program is a child process, and a child whose
[main] returns at once is a dead child rather than a parked one — so the
stub [Session.create_dev] gives a file with no [main] is no use to it. The
one-process daemon takes such a file. *)
let need_main ~file (session : Session.t) =
if not
(List.exists (fun (f : Tast.fn) -> f.Tast.name = "main")
@ -4549,12 +4614,49 @@ let need_main ~file (session : Session.t) =
then
failwith
(Printf.sprintf
"%s has no main, so flan dev has nothing to run. A program starts at \
a function named main, for example:\n\n\
"%s has no main, and flan dev --two-process runs the program as a \
separate process, which needs one. Start flan dev without \
--two-process, or add a function named main, for example:\n\n\
\ (defn main [] i32\n\
\ 0)"
file)
(* The agent's C, in every program [flan dev] builds, whether or not the source
imports the package: its constructor binds the socket before [main], so a
file that never mentions the agent can still be reached from the editor. A
program that imports it already has it, and is left alone — two copies
would collide at the link. A release build is not built here and is not
affected. *)
let with_agent ~dir csrcs lflags =
let csrcs =
if List.exists (fun c -> Filename.basename c = "flan_agent.c") csrcs then
csrcs
else begin
let c = Filename.concat dir "flan_agent.c" in
write_file c Runtime_src.agent_source;
csrcs @ [ c ]
end
in
let lflags =
lflags
@ List.filter (fun f -> not (List.mem f lflags)) [ "-lpthread"; "-ldl" ]
in
(csrcs, lflags)
(* What [flan dev] says about the forms of a file with no [main] that did not
compile. The session starts without them; C-c C-k loads the file again once
they are fixed. *)
let report_dropped ~file = function
| [] -> ()
| ds ->
Printf.eprintf "%s\n%!" (Loc.report_all ds);
Printf.eprintf
"flan dev: %s has %d form%s that did not compile; the session starts \
without %s\n%!"
file (List.length ds)
(if List.length ds = 1 then "" else "s")
(if List.length ds = 1 then "it" else "them")
(* [debug] is off by default, which keeps [flan dev] exactly what it was: a
-O2 host and -O2 modules. It is opt-in rather than always-on because a debug
build is an -O0 build — [llvm.dbg.declare] describes an alloca and mem2reg
@ -4574,6 +4676,7 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
let session, l = Session.create ~debug ~x86 ~file () in
need_main ~file:given session;
make_session_dir ~file:given dir;
let csrcs, lflags = with_agent ~dir l.Load.csrcs l.Load.lflags in
let exe = Filename.concat dir "program" in
(* [keep] so the host's own IR survives the build. It is the text [llc] was
actually given, not a second emission of it, which is the difference
@ -4590,7 +4693,7 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
Build.executable
~opts:{ Build.default with Build.dev = true; Build.keep = true;
Build.debug; Build.x86 }
~csrcs:l.Load.csrcs ~lflags:l.Load.lflags session.Session.host ~out:exe
~csrcs ~lflags session.Session.host ~out:exe
in
(* Host and modules are chosen together, which is the whole licence: an
[--x86] host gets [--x86] modules because one flag set both, and the
@ -4642,7 +4745,7 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
failwith
("the program did not open its agent socket at " ^ agent
^ ". Under --two-process every edit reaches the program through that \
socket. " ^ agent_howto)
socket.")
end;
let t =
@ -4723,10 +4826,9 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
the process starts rather than because anybody asked — and the startup below
is still the one place that decides, in three lines of C.
What is genuinely open is the *session*: [Session.create ~file] is the only
entry there is, so a REPL that starts empty and accumulates as files are
loaded needs [Session] to have a second constructor. It already accumulates;
it just cannot start from nothing. And [rerun] runs [main] and nothing else,
The session starts from a file with no [main] as well: [Session.create_dev]
gives it a stub that returns at once, so the process comes up, parks, and
accumulates what the editor loads into it. And [rerun] runs [main] and nothing else,
deliberately — running a *named* function is what [eval-expr] already is,
and the two should not grow into one verb with a mode. *)
@ -4971,11 +5073,26 @@ static void flan_merged_park(void) {
program_state = PROGRAM_PARKED;
pthread_mutex_unlock(&program_lock);
fflush(NULL);
fprintf(stderr,
"flan dev: the program finished with %d; the process is parked and "
"its globals are as it left them — M-x flan-rerun runs it again\n",
(int)program_status);
/* A file with no main is started on a stub that returns at once, and its
* first park is the session coming up rather than a program finishing. */
{
static int first_park = 1;
const char *no_main = getenv("FLAN_DEV_NO_MAIN");
if (first_park && no_main != NULL && no_main[0] == '1')
fprintf(stderr,
"flan dev: the file has no main, so nothing runs until one is "
"loaded; the session is up and takes definitions and "
"expressions\n");
else
fprintf(stderr,
"flan dev: the program finished with %d; the process is parked "
"and its globals are as it left them — M-x flan-rerun runs it "
"again\n",
(int)program_status);
first_park = 0;
}
fflush(stderr);
pthread_mutex_lock(&program_lock);
for (;;) {
while (!program_asked && !program_poll)
@ -5472,7 +5589,7 @@ let merged_setup () =
marshalling a [Session.t] through a file, which buys nothing: the source
cannot have changed between the two, because the build that produced
this binary is the one that exec'd it. *)
let session, _ = Session.create ~debug ~x86 ~file () in
let session, _, _ = Session.create_dev ~debug ~x86 ~file () in
(* The program's output has to reach an editor exactly as it did when the
daemon held the other end of a pipe. Same pipe, one process: fd 1 is
replaced before the program starts, and the accept loop drains it —
@ -5576,9 +5693,10 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
let dir = session_dir ~file ~sock in
let given = file in
let file = try Unix.realpath file with Unix.Unix_error _ -> file in
let session, l = Session.create ~debug ~x86 ~file () in
need_main ~file:given session;
let session, l, dropped = Session.create_dev ~debug ~x86 ~file () in
report_dropped ~file:given dropped;
make_session_dir ~file:given dir;
let csrcs, lflags = with_agent ~dir l.Load.csrcs l.Load.lflags in
let exe = Filename.concat dir "program" in
(* The host's IR goes straight to its final home rather than being written
into the build's working directory and moved: the merged link is spelled
@ -5589,8 +5707,13 @@ let start_merged ?(debug = false) ?(x86 = true) ~file ~sock () =
ignore
(merged_executable
~opts:{ Build.default with Build.dev = true; Build.debug; Build.x86 }
~csrcs:l.Load.csrcs ~lflags:l.Load.lflags ~pnames:[]
~csrcs ~lflags ~pnames:[]
session.Session.host ~out:exe ~ll:host_ll);
(* Read by the park, so the first one says the session is waiting rather
than that a program finished. *)
Unix.putenv "FLAN_DEV_NO_MAIN"
(if Session.has_main session then "0" else "1");
let agent = Filename.concat dir "agent.sock" in
(* Every one of these is read by the exec'd binary and by nothing else. They
are set before the exec rather than by the compiler thread afterwards, so

7
lib/dune
View File

@ -39,7 +39,8 @@
%{workspace_root}/runtime/flan_rt.c
%{workspace_root}/runtime/flan_dev.c
%{workspace_root}/runtime/flan_dyn.c
%{workspace_root}/runtime/flan_dyn.h)
%{workspace_root}/runtime/flan_dyn.h
%{workspace_root}/vendor/agent/flan_agent.c)
(action
(with-stdout-to
runtime_src.ml
@ -58,4 +59,8 @@
; compiled against the old one.
(echo "|c}\n\nlet dyn_header = {c|\n")
(cat %{workspace_root}/runtime/flan_dyn.h)
; And the agent's C, which flan dev links into every program it builds
; whether or not the source imports the package. See [Dev.with_agent].
(echo "|c}\n\nlet agent_source = {c|\n")
(cat %{workspace_root}/vendor/agent/flan_agent.c)
(echo "|c}\n")))))

113
lib/session.ml
View File

@ -252,8 +252,7 @@ let with_expansion_macros (forms : Form.t list) (load : unit -> 'a) : 'a * Form.
Parse.expansion_macros := [];
(r, Load.macro_union (own_macros forms) defined)
let create ?(debug = false) ?(x86 = false) ~file () =
let forms = Reader.read_file file in
let of_forms ~debug ~x86 ~file forms =
let l, mine = with_expansion_macros forms (fun () -> Load.program ~file forms) in
let p, env = Check.program_with_env l.Load.decls in
({ file; decls = l.Load.decls; program = p; env; host = p; pkgs = l.Load.pkgs;
@ -264,6 +263,92 @@ let create ?(debug = false) ?(x86 = false) ~file () =
thunks = 0; debug; x86;
built = record_built env p p.Tast.fns SM.empty; live = SM.empty }, l)
let create ?(debug = false) ?(x86 = false) ~file () =
of_forms ~debug ~x86 ~file (Reader.read_file file)
(* ── A file loaded a form at a time, keeping what compiles ─────────── *)
(* The form a diagnostic is about: the last one in [forms] that starts at or
before the position it was reported at — the call, for an error inside a
macro's expansion. [None] when the position is in no file these forms came
from, which is an error nothing here can drop a form to avoid. *)
let blame (forms : Form.t list) (d : Loc.diag) : Form.t option =
let at = Loc.call_site d.Loc.dloc in
List.fold_left
(fun acc (f : Form.t) ->
if String.equal f.Form.loc.Loc.file at.Loc.file
&& Loc.before f.Form.loc at <= 0
then Some f
else acc)
None forms
(* SBCL's [load] and CIDER's load-file: a file whose third form does not
compile still defines the other two. [attempt] is run over [forms]; each
refusal drops the form it is about and runs it again over the rest, so a
form that only failed because it called one that was dropped is dropped
with its own error on the next round. Each round drops at least one form,
so this ends. Answers what [attempt] returned, the forms it was given, and
every error in the order found. An error no form can be blamed for is
raised as it came. *)
let pruned (attempt : Form.t list -> 'a) (forms : Form.t list) :
'a * Form.t list * Loc.diag list =
let rec go forms errs =
let drop ds e =
let bad = List.map (blame forms) ds in
if List.exists Option.is_none bad then raise e
else
let bad = List.filter_map Fun.id bad in
go (List.filter (fun f -> not (List.memq f bad)) forms)
(List.rev_append ds errs)
in
match attempt forms with
| r -> (r, forms, List.rev errs)
| exception (Loc.Error d as e) -> drop [ d ] e
| exception (Loc.Errors ds as e) -> drop ds e
in
go forms []
(* Where [flan dev] writes the [main] a file without one is given. Not a path:
nothing reads it back, and a location here is how the session tells that
[main] apart from one somebody wrote. *)
let stub_file = "<flan dev>"
let stub_main () = Reader.read_all ~file:stub_file "(defn main [] i32 0)"
let declares_main (forms : Form.t list) =
List.exists
(fun (f : Form.t) ->
match f.Form.v with
| Form.List
({ Form.v = Form.Sym "defn"; _ } :: { Form.v = Form.Sym "main"; _ } :: _)
-> true
| _ -> false)
forms
(* Whether the [main] this session would run is one somebody wrote. *)
let has_main t =
List.exists
(fun (d : Ast.decl) ->
Ast.declared_name d = Some "main"
&& not (String.equal d.Ast.dloc.Loc.file stub_file))
t.decls
(* The session [flan dev] starts. A file with a [main] is [create]'s. A file
without one is the empty image of SBCL's order: a [main] that returns at
once is added so there is a process to park, and the file's forms are
loaded into it as [pruned] loads them — what compiles is in the host, and
what does not is answered beside the session rather than instead of it. A
[main] loaded later replaces the stub like any other redefinition. *)
let create_dev ?(debug = false) ?(x86 = false) ~file () =
let forms = Reader.read_file file in
if declares_main forms then
let t, l = create ~debug ~x86 ~file () in
(t, l, [])
else
let build forms = of_forms ~debug ~x86 ~file (forms @ stub_main ()) in
let (t, l), _, errs = pruned build forms in
(t, l, errs)
(* What a macro may call, for the same reason [macros] is held: an evaluation
parses one form with no import in sight, and a package macro whose body
calls its own package's functions has to find them. [Load.program] hands
@ -669,8 +754,15 @@ let restore t h =
newest one and no older activation is left running. *)
let rerun t = t.live <- SM.empty
let eval ?(origin = "<eval>") ?pause ?(running = true) t src : change =
let forms = Reader.read_all ~file:origin src in
(* [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
absent: a file loaded from another directory names its packages from
there. *)
let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : change =
let forms =
match forms with Some f -> f | None -> Reader.read_all ~file:origin src
in
(* What an annotated listing quotes for this form is what was sent, not what
the file on disk said when it was last read. *)
Loc.remember ~file:origin src;
@ -683,7 +775,8 @@ let eval ?(origin = "<eval>") ?pause ?(running = true) t src : change =
let macros = ref t.macros in
let incoming =
let l, mine =
with_expansion_macros forms (fun () -> Load.program ~file:t.file forms)
with_expansion_macros forms (fun () ->
Load.program ~file:(Option.value base ~default:t.file) forms)
in
(* An evaluated import *adds* to the session's set, so a macro brought in
by C-c C-k is there for the C-c C-c after it. A union and not an
@ -2236,6 +2329,16 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
and the non-termination refusals raise [Loc.Error] out of this call, which
the daemon already answers as an error rather than a silence. *)
let parsed = Parse.with_imported ~decls:(package_decls t) t.macros (fun () -> Parse.expr form) in
(* CIDER's rule: an expression sent from a package's file means what it
would mean written in that file, so [(integrate 1.0)] in physics/step.flan
reaches [physics/integrate]. The qualification [eval] gives a declaration
from the same buffer. A [defn-] is reachable too, because the location
[private_ref] compares is the buffer's own path. *)
let parsed =
match package_of t origin with
| None -> parsed
| Some p -> Load.rename_expr p.Load.owns p.Load.alias [] parsed
in
(* Wrapped before the checker, so the call is checked like any other and a
prelude that stopped offering [pause] would be an ordinary unknown name
rather than a thunk that silently did not stop. The [Do] takes the

8
test/programs/dev-load-errors.flan Normal file
View File

@ -0,0 +1,8 @@
;;;; A file loaded into a session with two forms that do not compile: [bad]
;;;; returns a string where it says i64, and [good] calls [bad], so it goes
;;;; when [bad] does. [fine] is the form that has to arrive anyway.
(defn good [] i64 (bad))
(defn bad [] i64 "x")
(defn fine [] i64 42)

9
test/programs/dev-load-generic.flan Normal file
View File

@ -0,0 +1,9 @@
;;;; A file loaded into a session with no main: a generic and a plain function.
(defn biggest [xs [$t]] $t
{:where (ordered? $t)}
(let [m (at xs 0)]
(dotimes [i (length xs)]
(set m (max m (at xs i))))
m))
(defn twice [n i64] i64 (* 2 n))

20
test/programs/dev-noagent-running.flan
View File

@ -1,19 +1,9 @@
;;;; A program that has not been told about the agent and is still running.
;;;; A program that never imports the agent and is still running. flan dev
;;;; links the agent anyway, so a delivery is queued rather than refused; it
;;;; installs at a frame boundary the program never reaches, since nothing in
;;;; it calls (agent/poll).
;;;;
;;;; dev-noagent.flan is the other half of this pair and stops short of it: its
;;;; main returns, so a moment later it is parked, and a redefinition sent to a
;;;; parked program is answered by the parking path. This one keeps running,
;;;; which is the state nothing had pinned: there is no agent in the process to
;;;; hand a module to and no socket to fall back on, so the daemon refuses the
;;;; delivery.
;;;;
;;;; That is the honest answer for it: the reply says the program has no agent
;;;; and how to add one. A program that *links* the agent has its socket bound
;;;; by the package's constructor before main, and the one way that bind fails
;;;; — a socket path too long for a unix socket — is refused when flan dev
;;;; starts.
;;;;
;;;; So: no (import agent ...) anywhere, and a loop that outlasts the test.
;;;; No (import agent ...) anywhere, and a loop that outlasts the test.
(defn step [] i64 7)
(defn main [] i32

14
test/programs/dev-noagent.flan
View File

@ -1,13 +1,7 @@
;;;; A program [flan dev] can host that never calls (agent/start ...), which
;;;; is the one condition the merged session and the two-process daemon answer
;;;; differently: [two_process] kills the child and fails, [merged_serve]
;;;; warns and serves anyway. See test_dev.ml's last block.
;;;;
;;;; No (import agent ...) at all, because the point is a program that has not
;;;; been told about the agent rather than one that forgot a call. It prints
;;;; and returns: a Flan main that returns under [flan dev] parks instead of
;;;; ending the process (flan_merged_exit), so the session outlives it and the
;;;; accept loop keeps answering.
;;;; A program that never imports the agent. flan dev links the agent's C into
;;;; every program it builds, so a definition and an expression sent while it
;;;; is parked both land. It prints and returns: a Flan main that returns under
;;;; flan dev parks instead of ending the process (flan_merged_exit).
(defn step [] i64 7)
(defn main [] i32

4
test/programs/dev-nomain.flan
View File

@ -1,2 +1,4 @@
;;;; A file with no main: flan dev has nothing to run, and says so before building.
;;;; A file with no main. flan dev starts a session on it anyway, with a stub
;;;; main that returns at once, and the file's functions are in the host.
;;;; flan dev --two-process refuses it, since its program is a child process.
(defn helper [] i64 1)

319
test/test_dev.ml
View File

@ -4885,55 +4885,20 @@ let () =
(try ignore (Unix.waitpid [ Unix.WNOHANG ] opid) with Unix.Unix_error _ -> ());
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ osock; oout ];
(* A program that never calls [agent/start], which is the one condition on
which the two shapes of [flan dev] deliberately disagree. [two_process]
kills its child and [failwith]s: the program is a separate process, the
daemon owns it, and a daemon with nothing to deliver to is useless.
[merged_serve] prints a warning and serves anyway, because the thing it
would have to kill is itself — an editor connected to it still deserves
[describe], [defs] and the program's output, and only a *delivery*
needs the agent.
(* A program whose source never mentions the agent. [flan dev] links the
agent's C into every program it builds ([Dev.with_agent]), and the
constructor binds the socket before main, so the file is reachable from
the editor as it stands: dev-noagent.flan's main prints and returns,
and a definition and an expression sent to the park both land.
That second policy was held up by nothing at all. Nothing in the suite
reached lib/dev.ml's warning branch, and the shape of the mistake it
guards against is a small one: copying the daemon's answer back into
the merged path is the obvious tidy-up, and it would turn every program
without an agent into a session that dies at startup, silently, because
no test would have noticed.
So what is asserted is the policy and not the sentence: the session
answers. The warning text is checked second, as the evidence that this
is the branch that produced it and not some other path that happened to
work.
WHEN it answers is asserted too, and that is the newer half. The wait
for the agent socket used to sit in front of [accept_loop], so this
[describe] could not arrive until the ten seconds had run out — the
block's cost, and every real session's first keystroke. The wait is a
deadline the session passes now ([Dev.agent_check]), so the reply comes
back immediately and the sentence is said later, by the accept loop,
once the deadline is behind it. The second half is what still costs ten
seconds here: a warning about a program that is never going to start an
agent cannot honestly be said before waiting for one.
[describe] and not a cheaper op on purpose: it is what
[emacs/flan.el] sends straight after [flan--open] (flan.el:646) and
what its poll sends after that, so this is the stall a person would
actually have felt. *)
[--llvm] here, on a daemon that was going to stand up anyway: one
merged LLVM daemon stays in the suite now that a flagless one is x86,
and the host listing proves the opt-in reached the build. *)
let nsock = tmp "noagent.sock" and nlog = tmp "noagent.log" in
(try Sys.remove nsock with Sys_error _ -> ());
(* Its own stderr, unlike every other daemon here: the warning is the
evidence and it is written there. *)
let nfd =
Unix.openfile nlog [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
(* [--llvm] here, on a daemon that was going to stand up anyway: the
opt-in is the other half of the default checked at the top of this file,
and proving it costs the same [stat] on the same directory. It also
keeps one merged LLVM daemon in the suite now that a flagless one is an
x86 one -- this test is about a program with no [(agent/start ...)],
which is a claim about the daemon and not about a backend, so it is the
cheapest place for both. *)
let npid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-noagent.flan"; "-s"; nsock; "--llvm" |]
@ -4955,78 +4920,44 @@ let () =
if Sys.file_exists (nhost "s") then
fail "flan dev --llvm left an x86 listing at %s" (nhost "s");
let nc = connect nsock in
(* The exception arm is not defensive: a session that adopted the
daemon's policy would exit here, and the connection would come back
ECONNRESET rather than with a status. Reported by name because an
uncaught [Unix_error] out of a test binary says nothing about which
test. *)
let nt0 = Unix.gettimeofday () in
(match Wire.parse (Wire.send nc "(:op \"describe\")"; Wire.recv nc) with
| r when status r = "ok" -> ()
| r ->
fail "a program without (agent/start ...) was not served: describe: %s"
(status r)
| exception e ->
fail
"a program without (agent/start ...) ended the session instead of \
drawing a warning: %s" (Printexc.to_string e));
let ndt = Unix.gettimeofday () -. nt0 in
(* Two seconds, against a stall that was ten and a reply that is a
fraction of one. The threshold is loose on purpose: what is being
held is "the session does not wait for the program's socket before
answering", and a number close to the real cost would fail on a
loaded machine for a reason that has nothing to do with the wait. *)
if ndt > 2. then
fail
"the first editor request waited %.1fs on a program without \
(agent/start ...); the accept loop is gated on the agent again"
ndt;
(* Dropped rather than closed with [(:op "close")], and the difference
is the rest of this row: [close] ends the session, the process
[_exit]s, and the deadline below would be waited out by nobody. A
dropped connection leaves the accept loop cycling, which is where
the sentence is said from. *)
let parked () =
match Wire.field (request nc "(:op \"describe\")") "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
if not (await parked) then fail "the agentless program never parked"
else begin
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let r =
request nc
"(:op \"eval\" :code \"(defn step [] i64 8)\" :file \
\"programs/dev-noagent.flan\")"
in
if status r <> "ok" then
fail "a definition for a program that never imports the agent: %s"
(said r);
let r =
request nc
"(:op \"eval-expr\" :code \"(step)\" :file \
\"programs/dev-noagent.flan\")"
in
if Wire.string_field r "value" <> Some "8" then
fail "an expression for a program that never imports the agent: %s %s"
(status r) (said r)
end;
(try
ignore (Wire.send nc "(:op \"close\")");
ignore (Wire.recv nc)
with _ -> ());
(try Unix.close nc with Unix.Unix_error _ -> ())
end;
(* And the sentence, which arrives after the deadline rather than before
the loop. Awaited with the daemon still alive — the accept loop is what
says it, so killing first would be testing that a dead process does not
print. Generous against the ten-second deadline for the reason the
threshold above is loose. *)
let nlog_says () =
contains_sub
(try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> "")
"(import agent \"vendor:agent\")"
in
ignore (await ~ms:30000 nlog_says);
(try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ());
if not (nlog_says ()) then
fail
"a program with no agent drew no warning from flan dev:\n%s"
(try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> "");
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ nsock; nlog ];
(* ── ...and what a delivery to one is told ────────────────────────
The row above is about the daemon's own stderr. This one is about the
reply an editor gets for a redefinition, and it is here because that
reply was never pinned and this lane changed which of two it is.
A program that does not link the agent at all has no agent in this
process to call and no socket to fall back to, so the delivery is
REFUSED, and the reply says the program has no agent and how to give it
one — both for a redefinition and for an expression. "Queued" would
have promised a poll that has nothing to drain, and "connect: No such
file or directory" names a path the reader never chose.
It needs the program to be running, which is why it is not folded into
the row above: dev-noagent.flan's main returns, so it parks within the
first moment and a delivery to it is answered by the parking path
instead. This fixture loops. *)
(* And one still running, which never calls [(agent/poll)]: a delivery is
queued rather than refused, because the agent is there to take it. *)
let gsock = tmp "noagent-running.sock" and glog = tmp "noagent-running.log" in
(try Sys.remove gsock with Sys_error _ -> ());
let gfd =
@ -5049,46 +4980,9 @@ let () =
"(:op \"eval\" :code \"(defn step [] i64 9)\" :file \
\"programs/dev-noagent-running.flan\")"
in
let msg = Option.value ~default:"" (Wire.string_field r "message") in
(* Refused, and the reason is the program's rather than the compiler's:
the module built, and what is missing is an agent to hand it to. The
fix it names is the import. *)
let names_the_fix m =
contains_sub m "has no agent"
&& contains_sub m "(import agent \"vendor:agent\")"
&& contains_sub m "(agent/poll)"
in
if status r = "ok" then
fail
"a redefinition for a program with no agent in it was answered \
ok%s — nothing can install it"
(match Wire.string_field r "note" with
| Some n -> Printf.sprintf " (note: %S)" n
| None -> "")
else if not (names_the_fix msg) then
fail "a delivery to a running agentless program was refused with: %S"
msg;
(* And an expression, which used to be answered with the connect's own
errno. *)
let r =
request gc
"(:op \"eval-expr\" :code \"(step)\" :file \
\"programs/dev-noagent-running.flan\")"
in
let msg = Option.value ~default:"" (Wire.string_field r "message") in
if status r = "ok" || not (names_the_fix msg) then
fail "an expression for a running agentless program was answered %s: %S"
(status r) msg;
(* And the session is still there afterwards, which is the rest of the
claim: a refusal is a reply, not the end. *)
(match request gc "(:op \"describe\")" with
| r when status r = "ok" -> ()
| r ->
fail "the session did not survive an unreachable delivery: %s"
(status r)
| exception e ->
fail "the session ended on an unreachable delivery: %s"
(Printexc.to_string e));
if status r <> "ok" then
fail "a delivery to a running program that never imports the agent: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(try
ignore (Wire.send gc "(:op \"close\")");
ignore (Wire.recv gc)
@ -5154,8 +5048,11 @@ let () =
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" ];
refused_at_start "a program with no main" ~tmpdir:here ~prog:nomain
~mode [ "has no main"; "(defn main [] i32" ])
(* Only the two-process daemon: its program is a child, and a child
whose main returns is gone. One process starts on the file. *)
if mode <> [||] then
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 _ -> ());
@ -7264,10 +7161,9 @@ let () =
let lc = connect lsock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
(* The program sleeps for three seconds before [agent/start], so this is
asked inside the delay. Two seconds is the threshold for the reason
the agentless row gives: the reply is a fraction of one and the bug
was ten, so anything in between is a loaded machine rather than a
regression. *)
asked inside the delay. Two seconds is the threshold because the reply
is a fraction of one and the bug was ten, so anything in between is a
loaded machine rather than a regression. *)
let lt0 = Unix.gettimeofday () in
let r = request lc "(:op \"describe\")" in
let ldt = Unix.gettimeofday () -. lt0 in
@ -7450,6 +7346,121 @@ let () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ psock; pout ];
(* ── A session on a file with no main ─────────────────────────────
SBCL's order: the session comes up with nothing to run, and a file is
loaded into it. A load that has forms which do not compile installs the
rest and lists them; a re-run says there is no main and how to add one. *)
let msock = tmp "nomain.sock" and mout = tmp "nomain.out" in
(try Sys.remove msock with Sys_error _ -> ());
let mfd =
Unix.openfile mout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let mpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-nomain.flan"; "-s"; msock |]
Unix.stdin mfd mfd
in
Unix.close mfd;
if not (listening ~pid:mpid msock) then begin
fail "a daemon on a file with no main %s (%S)" !listen_why
(In_channel.with_open_bin mout In_channel.input_all);
(try Unix.kill mpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let mc = connect msock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let value code =
let r =
request mc
(Printf.sprintf "(:op \"eval-expr\" :code %s :file \"<test>\")"
(Wire.quote code))
in
match Wire.string_field r "value" with
| Some v -> v
| None -> "refused: " ^ said r
in
let load file = request mc (Printf.sprintf "(:op \"load-file\" :file %S)" file) in
let errors r =
match Wire.field r "errors" with
| Some { Form.v = Form.List l; _ } ->
List.map
(fun e -> Option.value ~default:"" (Wire.string_field e "message"))
l
| _ -> []
in
(match value "(helper)" with
| "1" -> ()
| v -> fail "the no-main file's own function: %s" v);
let r = load "programs/dev-load-generic.flan" in
if status r <> "ok" then fail "loading a generic and a function: %s" (said r)
else begin
(match value "(let [ns [3 9 2]] (biggest (slice ns 0 3)))" with
| "9" -> ()
| v -> fail "a loaded generic, called: %s" v);
match value "(twice 21)" with
| "42" -> ()
| v -> fail "a loaded function, called: %s" v
end;
let r = load "programs/dev-load-errors.flan" in
if status r <> "ok" then
fail "a load with two bad forms installed nothing: %s" (said r)
else begin
(match errors r with
| [ a; b ] ->
if not (contains_sub a "expected i64" && contains_sub b "unknown function bad")
then fail "a load listed %S and %S" a b
| es -> fail "a load with two bad forms listed %d" (List.length es));
(match value "(fine)" with
| "42" -> ()
| v -> fail "the form that compiled beside two that did not: %s" v);
if not (contains_sub (value "(good)") "refused") then
fail "a form that called one left out was installed"
end;
(* Nothing compiles: a refusal, with the error where every refusal
puts it and the list beside it. *)
let r =
request mc
"(:op \"load-file\" :file \"programs/dev-load-errors.flan\" :code \
\"(defn bad [] i64 \\\"x\\\")\")"
in
if status r <> "error" || errors r = [] || Wire.string_field r "loc" = None
then fail "a load where nothing compiles: %s %s" (status r) (said r);
let r = request mc "(:op \"rerun\")" in
if status r <> "error"
|| not (contains_sub (said r) "has no main")
|| not (contains_sub (said r) "(defn main [] i32")
then fail "a re-run with no main: %s %s" (status r) (said r);
(* A main loaded into it is the one a re-run runs. *)
let r =
request mc
"(:op \"eval\" :code \"(defn main [] i32 (println \\\"from main\\\") 0)\" \
:file \"programs/dev-nomain.flan\")"
in
if status r <> "ok" then fail "loading a main: %s" (said r)
else begin
let before = Buffer.length output in
let r = request mc "(:op \"rerun\")" in
if status r <> "ok" then fail "a re-run after a main was loaded: %s" (said r)
else if
not
(await (fun () ->
ignore (request mc "(:op \"describe\")");
contains_sub
(Buffer.sub output before (Buffer.length output - before))
"from main"))
then fail "the loaded main did not run"
end;
(try
ignore (Wire.send mc "(:op \"close\")");
ignore (Wire.recv mc)
with _ -> ());
(try Unix.close mc with Unix.Unix_error _ -> ())
end;
(try Unix.kill mpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] mpid) with Unix.Unix_error _ -> ());
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ msock; mout ];
(* ── A class redefined under its own instances ──────────────────
CLHS 4.3.6's update protocol, end to end, with a real editor at one
end and the running program's own heap at the other. "A method added

84
test/test_session.ml
View File

@ -1619,4 +1619,88 @@ let () =
| _ ->
fail "two slots that strip to one name did not keep their raw spellings"));
(* ── A file with no main ───────────────────────────────────────────
[create_dev] gives it a [main] that returns, so there is a process to
start, and [has_main] tells that stub from one somebody wrote. *)
(match Session.create_dev ~file:"programs/dev-nomain.flan" () with
| t, _, [] ->
if Session.has_main t then fail "the stub main counted as the file's own";
if not
(List.exists (fun (f : Tast.fn) -> f.Tast.name = "main")
t.Session.host.Tast.fns)
then fail "a file with no main was given no main to start";
(* A [main] loaded later is the file's own. *)
(match Session.eval ~origin:"programs/dev-nomain.flan" t
"(defn main [] i32 3)" with
| _ ->
if not (Session.has_main t) then
fail "a main loaded into the session did not replace the stub"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "loading a main into a session started without one: %s" m)
| _, _, _ :: _ -> fail "dev-nomain.flan had forms that did not compile"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a session over a file with no main: %s" m);
(match Session.create_dev ~file:"programs/dev-parknote.flan" () with
| t, _, _ ->
if not (Session.has_main t) then fail "a file's own main was not its own"
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "dev-parknote.flan: %s" m);
(* A file with no main whose forms do not all compile starts without them,
and names them. [good] goes because it calls [bad]. *)
(match Session.create_dev ~file:"programs/dev-load-errors.flan" () with
| t, _, errs ->
let fns = List.map (fun (f : Tast.fn) -> f.Tast.name) t.Session.host.Tast.fns in
if not (List.mem "fine" fns) then fail "the form that compiled was left out";
if List.mem "good" fns || List.mem "bad" fns then
fail "a form that did not compile is in the host";
if List.length errs <> 2 then
fail "a start with two bad forms named %d" (List.length errs)
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a no-main file with a bad form refused the session: %s" m);
(* [pruned] on its own, as the daemon's load-file runs it: each round drops
the form the error is in, and one it could not blame is raised. *)
(let t, _ = Session.create ~file:"programs/dev-parknote.flan" () in
let src =
In_channel.with_open_bin "programs/dev-load-errors.flan" In_channel.input_all
in
let origin = "programs/dev-load-errors.flan" in
let forms = Reader.read_all ~file:origin src in
let check forms =
let h = Session.held t in
Fun.protect ~finally:(fun () -> Session.restore t h)
(fun () -> ignore (Session.eval ~origin ~forms t src))
in
match Session.pruned check forms with
| (), kept, errs ->
if List.length kept <> 1 then fail "load kept %d forms, not 1" (List.length kept);
(match errs with
| [ a; b ] ->
if not (has a.Loc.dmsg "expected i64") then
fail "the first error a load found was %S" a.Loc.dmsg;
if not (has b.Loc.dmsg "unknown function bad") then
fail "the form that used a dropped one went for %S" b.Loc.dmsg
| _ -> fail "load found %d errors, not 2" (List.length errs))
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "pruned raised: %s" m);
(* ── An expression from a package's file ─────────────────────────────
CIDER's rule: it resolves as the file would, so the package's own names
reach it bare, a [defn-] included. From the program's file the same bare
name is not the package's. *)
(let tq, _ = Session.create ~file:"programs/pkg-private.flan" () in
(match
Session.eval_expr ~origin:"programs/pkgs/secret/secret.flan" tq
"(+ (combine 1 2) (mix 3 4))"
with
| c ->
if not (has c.Session.ir "secret") then
fail "an expression from a package's file did not reach the package"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "an expression from a package's file: %s" m);
match
Session.eval_expr ~origin:"programs/pkg-private.flan" tq "(combine 1 2)"
with
| _ -> fail "a package's bare name resolved from the program's own file"
| exception Loc.Error _ -> ());
Test_support.report ~label:"session" ()