diff --git a/TODO.org b/TODO.org index eb6d0923..b58d5201 100644 --- a/TODO.org +++ b/TODO.org @@ -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. diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index c8f211a0..4910a7fa 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -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) | diff --git a/emacs/flan.el b/emacs/flan.el index b1ec4960..9fd06092 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -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 "") + :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) diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 30bb649e..c46f5dcc 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -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 "")) + :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 "")) + :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) diff --git a/lib/dev.ml b/lib/dev.ml index aa138b5a..ae563a46 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -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 diff --git a/lib/dune b/lib/dune index 4bb39b77..c2d5b71a 100644 --- a/lib/dune +++ b/lib/dune @@ -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"))))) diff --git a/lib/session.ml b/lib/session.ml index f62654f3..cc3ca9cd 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -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 = "" + +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 = "") ?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 = "") ?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 = "") ?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 = "") ?(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 diff --git a/test/programs/dev-load-errors.flan b/test/programs/dev-load-errors.flan new file mode 100644 index 00000000..dc280e6b --- /dev/null +++ b/test/programs/dev-load-errors.flan @@ -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) diff --git a/test/programs/dev-load-generic.flan b/test/programs/dev-load-generic.flan new file mode 100644 index 00000000..53dbc372 --- /dev/null +++ b/test/programs/dev-load-generic.flan @@ -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)) diff --git a/test/programs/dev-noagent-running.flan b/test/programs/dev-noagent-running.flan index f9768554..b4047422 100644 --- a/test/programs/dev-noagent-running.flan +++ b/test/programs/dev-noagent-running.flan @@ -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 diff --git a/test/programs/dev-noagent.flan b/test/programs/dev-noagent.flan index df9fedc8..1133a41f 100644 --- a/test/programs/dev-noagent.flan +++ b/test/programs/dev-noagent.flan @@ -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 diff --git a/test/programs/dev-nomain.flan b/test/programs/dev-nomain.flan index 217a0b02..8b823dc6 100644 --- a/test/programs/dev-nomain.flan +++ b/test/programs/dev-nomain.flan @@ -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) diff --git a/test/test_dev.ml b/test/test_dev.ml index 3d8ff53c..b49bd1e0 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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 \"\")" + (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 diff --git a/test/test_session.ml b/test/test_session.ml index f2d3f6a0..4ec393b2 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -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" ()