From 8dc90416d4f5da5dd42cfd35d13ba388f03b2a0e Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:14:23 +0700 Subject: [PATCH 1/4] The daemon's buffer draws errors, warnings and notes in compilation's faces and the program's own output in a face of its own --- TODO.org | 6 ------ emacs/flan.el | 30 +++++++++++++++++++++++++++--- emacs/test-flan.el | 31 +++++++++++++++++++++++++++++++ 3 files changed, 58 insertions(+), 9 deletions(-) diff --git a/TODO.org b/TODO.org index 899c9b6e..e04e66a1 100644 --- a/TODO.org +++ b/TODO.org @@ -2079,12 +2079,6 @@ per-phase; making it per-form would need a resync point inside a body. 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. -=*flan*= is all plain text. =compilation-minor-mode= is on (=emacs/flan.el:822=) -so =next-error= works, but a minor mode installs no font-lock. Open: whether the -program's output should look different from the compiler's. - ** DONE compilation-mode steps over the notes CLOSED: [2026-09-25] The daemon buffer and the diagnostics buffer set =compilation-skip-threshold= to diff --git a/emacs/flan.el b/emacs/flan.el index 92e42a89..36f78e31 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -412,6 +412,25 @@ nil keeps everything." (let ((inhibit-read-only t)) (delete-region (point-min) (line-beginning-position))))))) +(defface flan-output-face '((t :inherit font-lock-string-face)) + "Face for the running program's own output in the daemon's buffer. +It sets that output apart from what the compiler and the daemon say, whose +errors, warnings and notes take `compilation-mode''s faces." + :group 'flan) + +(defun flan--daemon-buffer-setup () + "Make the current buffer the daemon's log: navigable and coloured. +The daemon writes a diagnostic as `file:line:col: message', the shape +`compilation-minor-mode' already reads, so it only has to be switched on. +The minor mode adds its font-lock rules but turns nothing on, and a process +buffer is in `fundamental-mode', which global font-lock skips; so font-lock +is switched on here, first, or the rules would never be drawn." + (font-lock-mode 1) + ;; A log, not source: a quote the program printed opens no string. + (setq-local font-lock-keywords-only t) + (compilation-minor-mode 1) + (flan--navigable-notes)) + (defun flan--append-output (text) "Append TEXT, the running program's own output, where it can be read. Two places. The daemon's log always gets it, so output lands somewhere @@ -423,7 +442,13 @@ open, above its prompt, which is where whoever is typing there is looking." (inhibit-read-only t)) (save-excursion (goto-char (point-max)) - (insert text)) + ;; Marked as it is inserted, because nothing in the text says whose + ;; it is. A line the program prints in the diagnostic shape is + ;; still read as one by `compilation-minor-mode', and takes its + ;; face. `face' for a buffer with font-lock off, `font-lock-face' + ;; so fontification does not strip it. + (insert (propertize text 'face 'flan-output-face + 'font-lock-face 'flan-output-face))) (flan--trim-lines) ;; Follow the tail only for someone who was already at it; a reader ;; scrolled back is reading something. @@ -893,8 +918,7 @@ It builds the program first, which for a cold project is most of this." ;; program runs, and `compilation-mode' would claim it as the output of ;; one finished command — killing the process on a `recompile', among ;; other things it has no business doing to a live session. - (compilation-minor-mode 1) - (flan--navigable-notes)) + (flan--daemon-buffer-setup)) (make-process :name "flan-daemon" :buffer buf :command args diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 74853a05..5fa5cd5d 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -533,6 +533,37 @@ already rely on it — so nothing here is a stand-in for the real thing." ;; The session is not poisoned by that: a good form still lands. (flan--eval "(defn step [] i64 (set ticks (+ ticks 100)) ticks)" "form") + ;; The daemon's buffer is coloured: the compiler's errors, warnings and + ;; notes take compilation's faces and the program's own output takes + ;; `flan-output-face'. Checked on `font-lock-face', which is what + ;; fontification writes; batch Emacs cannot turn `font-lock-mode' on, so + ;; nothing here aliases it to `face'. + (let ((flan-daemon-buffer " *flan-colour-test*")) + (with-current-buffer (get-buffer-create flan-daemon-buffer) + (insert "flan dev: built x.flan in 3ms\n" + "/tmp/a.flan:2:8: expected i32, found string\n" + "/tmp/a.flan:3:1: warning: w\n" + "/tmp/a.flan:4:1: note: n\n") + (flan--daemon-buffer-setup) + (flan--append-output "said hi\n") + (font-lock-ensure) + (let ((face-on (lambda (text) + (goto-char (point-min)) + (search-forward text) + (get-text-property (match-beginning 0) 'font-lock-face)))) + (test-flan--check + "the daemon's buffer draws an error, a warning and a note in compilation's faces" + (and (memq 'compilation-error (ensure-list (funcall face-on "a.flan:2"))) + (memq 'compilation-warning (ensure-list (funcall face-on "a.flan:3"))) + (memq 'compilation-info (ensure-list (funcall face-on "a.flan:4"))))) + (test-flan--check + "the program's output takes its own face" + (eq (funcall face-on "said") 'flan-output-face)) + (test-flan--check + "the daemon's own line is left plain" + (null (funcall face-on "flan dev:"))))) + (kill-buffer flan-daemon-buffer)) + ;; The program's own output arrives on replies and lands in the daemon's ;; buffer — no REPL is open yet, and the log is the fallback that makes a ;; println never depend on one. From da9f21ddcd072fe897703f5ed58c1bfe9b6a7ade Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:33:23 +0700 Subject: [PATCH 2/4] A form sent to the daemon is refused with every error in it, and an expression evaluated from the break buffer sees the stopped frame's locals --- TODO.org | 16 --- emacs/flan-cnr.el | 32 +++++- emacs/flan.el | 10 +- emacs/test-flan-cider.el | 30 +++++ lib/check.ml | 232 +++++++++++++++++++++++++++++++++------ lib/dev.ml | 92 +++++++++++----- lib/loc.ml | 1 + lib/session.ml | 76 ++++++++++++- lib/tast.ml | 59 ++++++++++ test/test_dev.ml | 47 ++++++++ test/test_session.ml | 38 +++++++ 11 files changed, 552 insertions(+), 81 deletions(-) diff --git a/TODO.org b/TODO.org index e04e66a1..80f35745 100644 --- a/TODO.org +++ b/TODO.org @@ -2021,15 +2021,6 @@ maps bind =q=, and the diagnostics map binds =RET= and =q=, so those keys are the mode's own and behave the same under Evil. Every key a mode does not bind itself, including the rest of =special-mode-map=, stays Evil's. -** NEXT Eval in the frame, from the break loop -Decided 2026-09-25: SLIME's eval-in-frame, as described. -An expression is evaluated at a frame boundary, so it sees globals and not the -stopped frame's locals — which are the values anyone stopped there wants. Wants -SLIME's eval-in-frame: pick a frame, and the expression is checked and run with -its slots in scope. The slots are already on the frame and already readable -(=flan_dev_frame_slot=); what is missing is checking an expression against that -frame's names and types. - ** DONE The stack lists prelude frames CLOSED: [2026-09-25] A frame whose location is == is hidden by default, and a line in its @@ -2068,13 +2059,6 @@ rebinds all at once. No other form had the gap: =let= was already sequential, =dotimes= binds one name, and =fn=, =defn=, =match= and the handler and restart clauses bind parameters with no initialisers. -** NEXT C-c C-c reports one error, not every error in the form -Decided 2026-09-25: every error in the form, at any depth. A failed subexpression takes an error type that fits any want, so checking continues around it and the errors it would cause are not reported — Rust's, TypeScript's and Elm's shape. Rules out stopping at a statement boundary. -Whole-file paths use =Check.program_all= and report every bad declaration. The -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. - ** 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=. diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 8f29907f..1c444758 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -574,7 +574,7 @@ puts the likely culprit on top." ;; an entry is annotated with have to be on screen above it to read. (flan-cnr--insert-globals state) (insert (propertize - "RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect a abort g refresh q quit\n" + "RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame a abort g refresh q quit\n" 'face 'shadow)) (goto-char (point-min)) ;; Point starts on the restart that abandons the evaluation, when there is @@ -833,6 +833,34 @@ drawn from." (`(:expr ,expr) (flan-inspect expr)) (_ (user-error "flan: this line carries no root the inspector knows"))))) +(defun flan-cnr--frame-at-point () + "The index of the frame point is on, or on a local of, or nil." + (or (get-text-property (point) 'flan-cnr-frame) + (pcase (get-text-property (point) 'flan-cnr-inspect) + (`(:slot ,frame . ,_) frame)))) + +(defun flan-cnr-eval-in-frame (frame code) + "Evaluate CODE in stopped FRAME, SLIME's eval-in-frame, and show the value. +CODE sees FRAME's locals as well as the globals, and a `set' of a local +changes the frame. Interactively FRAME is the one point is on, or on a +local of, and CODE is read from the minibuffer." + (interactive + (let ((frame (flan-cnr--frame-at-point))) + (unless frame + (user-error "flan: point is not on a frame — e evaluates in the frame point is on")) + (list frame (read-string (format "Eval in frame %d: " frame))))) + (let ((r (funcall flan-cnr-request-function + (list :op "eval-expr" :frame frame :code code)))) + (if (equal (plist-get r :status) "ok") + (let ((v (or (plist-get r :value) (plist-get r :note) ""))) + ;; A set may have changed what an open frame shows, so each is + ;; asked again the next time it is opened. + (dolist (fr (plist-get flan-cnr--state :stack)) + (when (consp fr) (plist-put fr :fetched nil))) + (message "=> %s" v) + v) + (user-error "flan: %s" (or (plist-get r :message) "refused"))))) + (defun flan-cnr-refresh () "Ask the program again what it is offering." (interactive) @@ -889,6 +917,8 @@ anyone who would rather TAB always moved." (define-key map "v" #'flan-cnr-visit) (define-key map "P" #'flan-cnr-toggle-prelude) (define-key map "i" #'flan-cnr-inspect) + ;; SLIME's `e': evaluate in the frame at point. + (define-key map "e" #'flan-cnr-eval-in-frame) (define-key map "a" #'flan-cnr-abort) (define-key map "g" #'flan-cnr-refresh) (define-key map "q" #'quit-window) diff --git a/emacs/flan.el b/emacs/flan.el index 36f78e31..55c4a446 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -2609,7 +2609,15 @@ breakpoint is marked from the editor, without editing the buffer\"." ;; END as the place a value could go. Every caller of this sends a ;; declaration and declarations have no value, so this is the path that ;; stays open rather than one anybody takes today. - (flan--report reply what end) + ;; + ;; A form with several errors is refused with all of them under + ;; `:errors'; `flan--report' marks and signals the first, and the rest + ;; are marked beside it before the signal leaves, as `C-c C-k' does. + (condition-case err + (flan--report reply what end) + (user-error + (flan--report-load-errors (cdr (plist-get reply :errors)) t) + (signal (car err) (cdr err)))) ;; `flan--report' signals on a rejection, so reaching here means it ;; landed. Flashing the text that was sent answers "which form did that ;; take?" — the question the echo area cannot, because point may be nowhere diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 1cdcaf74..2e850c1a 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1477,6 +1477,36 @@ would be overwritten. Look again and re-do the edit") (test-flan--check "nothing is evaluated as an expression" (null (plist-get (car asked) :code)))))) +;; `e' evaluates in the frame point is on, or on a local of: the request +;; names that frame, and the value comes back to the echo area. +(let* ((asked nil) + (flan-cnr-request-function + (lambda (form) (push form asked) '(:status "ok" :value "8")))) + (with-current-buffer (test-flan--cnr + (list :condition "Missing" :restarts '("retry") + :stack (list (list :fn "g" :fetched t + :locals '(("b" "i64" "1" 4))) + (list :fn "f" :fetched t + :locals '(("n" "i64" "7" 0)))))) + (goto-char (point-min)) + (search-forward " 1: > f") + (flan-cnr-toggle-frame) + (goto-char (point-min)) + (search-forward " 1: v f") + (search-forward "i64 n") + (let ((said (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(+ n 1)")) + ((symbol-function 'message) + (lambda (fmt &rest args) (apply #'format fmt args)))) + (call-interactively #'flan-cnr-eval-in-frame)))) + (test-flan--check "`e' on a local evaluates in that local's frame" + (and (equal (plist-get (car asked) :op) "eval-expr") + (= 1 (plist-get (car asked) :frame)) + (equal (plist-get (car asked) :code) "(+ n 1)"))) + (test-flan--check "and answers the value" + (equal said "8"))) + (test-flan--check "`e' is the break buffer's own key" + (eq (lookup-key flan-cnr-mode-map "e") #'flan-cnr-eval-in-frame)))) + ;; `flan-cnr-show' refuses a running program by name rather than opening an ;; empty buffer. ;; The layout without the values: what a `layout' op alone would buy. The diff --git a/lib/check.ml b/lib/check.ml index ee0c4daf..7d7250c4 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -211,6 +211,19 @@ type env = { the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan name a program calls. *) tracks : (string, Shim.track) Hashtbl.t; + (* Recovery: checking goes on past a refused subexpression. See [check]. + [recovering] is on only while a whole-file or session check is collecting + every error; [recovered] is what it found, newest first; [poison] counts + failed subexpressions and reads of what they were bound to, which is how + an error caused by an earlier one is told apart and left unsaid. + [speculating] turns recovery off inside a trial, whose refusal is an + answer the caller acts on; [guard_next] turns it off for the one next + [check], whose own refusal a caller re-words. *) + mutable recovering : bool; + mutable recovered : Loc.diag list; + mutable poison : int; + mutable speculating : int; + mutable guard_next : bool; } let new_env () = { @@ -243,6 +256,11 @@ let new_env () = { in_field = false; classes = Hashtbl.create 8; tracks = Hashtbl.create 16; + recovering = false; + recovered = []; + poison = 0; + speculating = 0; + guard_next = false; } (* Where a named type was declared, and what it has, as a note. @@ -3527,6 +3545,63 @@ let hash_ty = Types.Int Types.U64 Each caller calls it again rather than sharing one value: [slots] and [slot_tys] are counted up per frame, and two frames that shared a context would share a slot counter. *) +(* What a refused subexpression stands as while recovering. [Zero] of [Never] + is a value nothing else builds, so it is recognisable; see [check]. *) +let poison loc = { Tast.e = Tast.Zero Types.Never; ty = Types.Never; loc } + +(* A poison, or a read of a local one was bound to. *) +let is_poison (r : Tast.expr) = + Types.equal r.Tast.ty Types.Never + && (match r.Tast.e with Tast.Zero Types.Never | Tast.Local _ -> true | _ -> false) + +let record_recovered env (d : Loc.diag) = + let same (x : Loc.diag) = x.Loc.dloc = d.Loc.dloc && String.equal x.Loc.dmsg d.Loc.dmsg in + if not (List.exists same env.recovered) then env.recovered <- d :: env.recovered + +(* [f] with recovery off, for a check whose refusal is an answer: a trial, a + probe, a fallback that re-checks. *) +let speculate env f = + env.speculating <- env.speculating + 1; + Fun.protect ~finally:(fun () -> env.speculating <- env.speculating - 1) f + +(* A refusal a caller has re-worded: recorded and stood in for while + recovering, raised otherwise. The [check] it re-words was [guarded], so its + own refusal came here rather than being recorded in its first wording. *) +let refuse_or_poison env loc (d : Loc.diag) = + if env.recovering && env.speculating = 0 then begin + record_recovered env d; + env.poison <- env.poison + 1; + poison loc + end + else raise (Loc.Error d) + +(* [f], a declaration's body, with recovery on when [on]. Everything it + recorded is raised as [Loc.Errors] at the end, together with whatever + refusal ended it, so nothing checked with a poison in it is ever returned. *) +let with_recovery env ~on f = + if not on then f () + else begin + let saved = (env.recovering, env.recovered, env.poison) in + let restore () = + let r, d, p = saved in + env.recovering <- r; env.recovered <- d; env.poison <- p + in + env.recovering <- true; env.recovered <- []; env.poison <- 0; + match f () with + | x -> + let found = List.rev env.recovered in + restore (); + if found = [] then x else raise (Loc.Errors found) + | exception Loc.Error d -> + let found = List.rev env.recovered in + restore (); + (* Raised past the end of the body after something in it already + failed: a return that does not fit, a value that is missing, both of + them what the failure left behind. *) + if found = [] then raise (Loc.Error d) else raise (Loc.Errors found) + | exception e -> restore (); raise e + end + let invented_ctx env ret = { env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; place_ok = false; envslot = None; parent = None; in_frames = None; loops = []; tail = false; @@ -4034,7 +4109,43 @@ let tracked_call loc env name (tr : Shim.track) ret (args : Tast.expr list) = (* Every expression goes through here, and [check_value] is the one that knows the forms. What this adds is [refuse_owned_copy], asked of whatever came back unless the form was checked as the target of a place. *) +(* Recovery, when [env.recovering] is on: a subexpression that is refused is + recorded and stands as a [poison] of type [Never], which fits any want, so + checking carries on around it and every error in a body is reported. What + an earlier failure causes is not reported: an error raised by a node one of + whose subexpressions failed, or with [Never] wanted, is dropped, as long as + something has been recorded. That last condition keeps a poison from ever + reaching a backend unreported — a scope with a poison in it always ends in + a raise (see [with_recovery]). *) let rec check ctx ?want (e : Ast.expr) : Tast.expr = + let env = ctx.env in + let guarded = env.guard_next in + env.guard_next <- false; + if (not env.recovering) || env.speculating > 0 || guarded then + check_plain ctx ?want e + else begin + let seen = env.poison in + let caused () = + env.recovered <> [] + && (env.poison > seen || want = Some Types.Never) + in + match check_plain ctx ?want e with + | r -> + if is_poison r then env.poison <- env.poison + 1; + r + | exception Loc.Error d -> + if not (caused ()) then record_recovered env d; + env.poison <- env.poison + 1; + poison e.Ast.loc + (* A checker arm that was never written for a [Never] operand may fail + some other way over one. Only then, and only as a consequence. *) + | exception (Not_found | Invalid_argument _ | Failure _ | Assert_failure _ + | Match_failure _) when caused () -> + env.poison <- env.poison + 1; + poison e.Ast.loc + end + +and check_plain ctx ?want (e : Ast.expr) : Tast.expr = let place = ctx.place_ok in ctx.place_ok <- false; let r = check_value ctx ?want e in @@ -5448,6 +5559,9 @@ and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body = let want = Option.map (resolve ctx.env) b.Ast.bty in let v = check ctx ?want b.Ast.bval in (match v.Tast.ty with + (* A refused initialiser, already reported: the name is bound to + the poison so that what follows is still checked. *) + | Types.Never when is_poison v -> () | Types.Unit | Types.Never -> fail b.Ast.bloc "%s would be bound to %s, which is not a value" b.Ast.bname (Types.to_string v.Tast.ty) @@ -5678,6 +5792,9 @@ and check_loop ctx ?want loc bs body = (fun (n, v) -> let v = check ctx v in (match v.Tast.ty with + (* A refused initialiser, already reported: the name is bound to + the poison so that what follows is still checked. *) + | Types.Never when is_poison v -> () | Types.Unit | Types.Never -> fail v.Tast.loc "%s would be bound to %s, which is not a value" n (Types.to_string v.Tast.ty) @@ -5851,7 +5968,10 @@ and check_recur ctx ~tail loc args = accident. *) and check_truthy ctx c = let loc = c.Ast.loc in - match check ctx c with + (* Speculative, because a refusal here is answered by asking again at + [bool]; and that second ask is guarded, because its refusal is re-worded + below. Recovery sees each refusal once, in its final words. *) + match speculate ctx.env (fun () -> check ctx c) with | c0 when c0.Tast.ty = Types.Dyn -> widen loc Types.Bool (rt loc (Types.Int Types.I32) "flan_dyn_truthy" [ c0 ]) | c0 when Types.fits ~expected:Types.Bool ~actual:c0.Tast.ty -> c0 @@ -5877,10 +5997,11 @@ and check_truthy ctx c = Anything more complicated than a name gets the operator and no template: a reconstructed expression would be a guess at code the reader can see for themselves. *) - (match check ctx ~want:Types.Bool c with + (ctx.env.guard_next <- true; + match check ctx ~want:Types.Bool c with | c1 -> c1 | exception Loc.Error d when not (String.equal d.Loc.kind "check/type-mismatch") -> - raise (Loc.Error d) + refuse_or_poison ctx.env loc d | exception Loc.Error _ -> let how = let zero = match c0.Tast.ty with Types.Float _ -> "0.0" | _ -> "0" in @@ -5892,9 +6013,11 @@ and check_truthy ctx c = | _, true -> Printf.sprintf " — test it against %s with !=" zero | _ -> "" in - Loc.failk "check/condition-not-bool" loc - "a condition is a bool or a dyn, and this is %s%s" - (Types.to_string c0.Tast.ty) how) + (try + Loc.failk "check/condition-not-bool" loc + "a condition is a bool or a dyn, and this is %s%s" + (Types.to_string c0.Tast.ty) how + with Loc.Error d -> refuse_or_poison ctx.env loc d)) | exception Loc.Error _ -> check ctx ~want:Types.Bool c and check_if ctx ?(tail = false) ?want loc c t e = @@ -5962,15 +6085,23 @@ and check_if ctx ?(tail = false) ?want loc c t e = location; and with an expectation in hand both arms are checked against it rather than against each other, so nothing here runs. *) let e = - match branch ctx (fun () -> in_tail (fun () -> check ctx ?want:ewant e)) with + let reworded = want = None && and_sentinel e in + match + branch ctx (fun () -> + in_tail (fun () -> + if reworded then ctx.env.guard_next <- true; + check ctx ?want:ewant e)) + with | v -> v | exception Loc.Error d - when want = None && and_sentinel e - && String.equal d.Loc.kind "check/type-mismatch" -> - Loc.failk "check/shortcircuit-operand" t.Tast.loc - "an and answers false or its last operand, so the two have to be \ - one type — this operand is %s, and false is a bool" - (Types.to_string t.Tast.ty) + when reworded && String.equal d.Loc.kind "check/type-mismatch" -> + (try + Loc.failk "check/shortcircuit-operand" t.Tast.loc + "an and answers false or its last operand, so the two have to be \ + one type — this operand is %s, and false is a bool" + (Types.to_string t.Tast.ty) + with Loc.Error d -> refuse_or_poison ctx.env e.Ast.loc d) + | exception Loc.Error d when reworded -> refuse_or_poison ctx.env e.Ast.loc d in let t, e = match free_join, Types.const_join t.Tast.ty e.Tast.ty with @@ -6072,16 +6203,19 @@ and positional_struct ctx ~want loc name args = let fields = map2_lr (fun (f : Tast.field) (a : Ast.expr) -> + ctx.env.guard_next <- true; try check ctx ~want:f.Tast.fty a with | Loc.Error d when d.Loc.dloc = a.Ast.loc -> - Loc.raise_diag - { d with - Loc.notes = - d.Loc.notes - @ [ Loc.note a.Ast.loc - (Printf.sprintf "this is %s's field .%s" name - f.Tast.fname) ] - @ note }) + refuse_or_poison ctx.env a.Ast.loc + (Loc.sort_notes + { d with + Loc.notes = + d.Loc.notes + @ [ Loc.note a.Ast.loc + (Printf.sprintf "this is %s's field .%s" name + f.Tast.fname) ] + @ note }) + | Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d) fields args in expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) @@ -6524,6 +6658,8 @@ and numbers_disagree : 'a. ctx -> (Ast.expr * Types.t) list -> 'a = that finds nothing. *) and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = fun ctx items d -> + (* Every check here only looks for a better sentence for [d]. *) + speculate ctx.env @@ fun () -> match items with | [] -> raise (Loc.Error d) | first :: rest -> @@ -6723,7 +6859,7 @@ and check_the ctx ~want loc (t : Ast.texpr) (v : Ast.expr) = dyn — a dyn becomes a %s where a %s is passed, returned or stored" tn tn tn | None -> - (match check ctx ~want:ty v with + (match speculate ctx.env (fun () -> check ctx ~want:ty v) with | _ -> fail v.Ast.loc "the checks a value as %s and does not convert one, and this is \ @@ -7223,6 +7359,7 @@ and ordinal n = points at the wrong form. The rekind is what stops a nested call from being named twice: once enriched, it is no longer the kind this looks for. *) and check_arg ctx name i (want : Types.t) (a : Ast.expr) = + ctx.env.guard_next <- true; match check ctx ~want a with | e -> e | exception Loc.Error d @@ -7238,9 +7375,10 @@ and check_arg ctx name i (want : Types.t) (a : Ast.expr) = name which p.Ast.fname (Types.to_string want)) ] | _ -> [] in - Loc.raise_diag + refuse_or_poison ctx.env a.Ast.loc (Loc.diag ~kind:"check/argument-type" ~notes a.Ast.loc (Printf.sprintf "%s — this is the %s argument of %s" d.Loc.dmsg which name)) + | exception Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d and fields_named env n : Tast.structure option = match Hashtbl.find_opt env.structs n with @@ -11285,7 +11423,9 @@ and instantiate env loc gname vars subst cparams cret = env.tvpreds <- saved_preds; env.chain <- saved_chain in let tfn = - match !check_fn_ref env { fn with Ast.name = sym } with + (* Without recovery: a copy that does not check is refused whole, at + the call that asked for it, as it always was. *) + match speculate env (fun () -> !check_fn_ref env { fn with Ast.name = sym }) with | tfn -> restore (); tfn | exception e -> restore (); @@ -11408,7 +11548,7 @@ and trial ctx f = outer_what; caught; place_ok; envslot; parent = _; in_frames; loops; tail; in_defer; owner = _ } = ctx in - match f () with + match speculate ctx.env f with | r -> Ok r | exception Loc.Error d -> ctx.slots <- slots; ctx.slot_tys <- slot_tys; @@ -12488,7 +12628,7 @@ let collect env (decls : Ast.decl list) = let left = List.filter (fun ((n, _) as c) -> - match infer c with + match speculate env (fun () -> infer c) with | ty -> Hashtbl.replace env.globals n (ty, true); false | exception Loc.Error _ -> true) !pending @@ -13854,7 +13994,7 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : in (match f () with | x -> x - | exception (Loc.Error d as e) -> + | exception ((Loc.Error d | Loc.Errors (d :: _)) as e) -> if ok env name d then begin Hashtbl.filter_map_inplace (fun g r -> @@ -13935,7 +14075,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : | Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name -> ignore (Loc.caught s (fun () -> - tolerant fn.Ast.name (fun () -> Some (check_generic env fn)))) + tolerant fn.Ast.name (fun () -> + with_recovery env ~on:keep_going (fun () -> + Some (check_generic env fn))))) | _ -> ()) decls; let globals = @@ -13943,9 +14085,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : (fun (d : Ast.decl) -> Option.join (Loc.caught s (fun () -> + let checked () = + with_recovery env ~on:keep_going (fun () -> check_global env d) + in match Ast.declared_name d with - | Some n -> tolerant n (fun () -> check_global env d) - | None -> check_global env d))) + | Some n -> tolerant n checked + | None -> checked ()))) decls in let fns = @@ -13958,7 +14103,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) : | Ast.Defn fn -> Option.join (Loc.caught s (fun () -> - tolerant fn.Ast.name (fun () -> Some (check_fn env fn)))) + tolerant fn.Ast.name (fun () -> + with_recovery env ~on:keep_going (fun () -> + Some (check_fn env fn))))) | _ -> None) decls in @@ -14017,8 +14164,8 @@ let program_with_env (decls : Ast.decl list) : Tast.program * env = (** The same, with [tolerate] deciding which body failures leave a declaration out rather than refuse it — see [build_program]. The names left out come back beside the program; nothing else about it changes. *) -let program_tolerant ~tolerate (decls : Ast.decl list) = - build_program ~keep_going:false ~tolerate decls +let program_tolerant ?(keep_going = false) ~tolerate (decls : Ast.decl list) = + build_program ~keep_going ~tolerate decls let program (decls : Ast.decl list) : Tast.program = let p, _, _ = build_program ~keep_going:false decls in @@ -14136,6 +14283,25 @@ let expressions env (es : (Types.t option * Ast.expr) list) : (ts, Array.of_list (List.rev ctx.slot_tys), Array.of_list (List.rev ctx.slot_names)) +(* One expression checked with [scope]'s names already bound, in order, so a + later entry shadows an earlier one of the same name: evaluating in a stopped + frame, whose locals the expression may name. Each is bound to a slot of the + expression's own frame, and which slot is answered beside the name, so the + caller can point every use of it at the stopped frame's storage instead + ([Tast.rewrite_locals]). *) +let expression_in_scope env ~(scope : (string * Types.t * bool) list) + (e : Ast.expr) : + Tast.expr * Types.t array * string option array * (string * int) list = + let ctx = invented_ctx env Types.Unit in + let bound = + List.map + (fun (name, ty, assignable) -> (name, bind ctx name ty ~assignable)) + scope + in + let t = expect ctx e.Ast.loc ~want:None (check ctx e) in + (t, Array.of_list (List.rev ctx.slot_tys), + Array.of_list (List.rev ctx.slot_names), bound) + (* The one-expression case, which is every caller but the write verb. *) let expression env ?want (e : Ast.expr) : Tast.expr * Types.t array * string option array = diff --git a/lib/dev.ml b/lib/dev.ml index 7f052f25..562333ed 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -997,6 +997,31 @@ let stale_field (ss : Session.stale list) = (if x.Session.running then " :running t" else "")) ss) ] +(* Every refusal a check found, one plist each: beside what a load installed, + or beside the first of them when a form sent had several. *) +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) ] + +(* A refusal with several diagnostics: the first where every refusal puts its + message, all of them under [:errors]. *) +let errors_reply (ds : Loc.diag list) = + match ds with + | [] -> error "nothing was refused" + | d :: _ -> + 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 ds) ^ ")" + let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = let now = liveness t in let parked_now = now = Parked in @@ -1102,20 +1127,9 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> 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) ] + | exception Loc.Errors ds -> + Session.restore t.session before; + errors_reply 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 @@ -1143,16 +1157,9 @@ let load_file t ~code ~origin = (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) ^ ")" + | exception Loc.Errors ds -> errors_reply 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) ^ ")" + if errs <> [] && kept = [] then errors_reply errs else eval ~forms:kept ?base ~extra:(errors_field errs) t ~code ~origin ~pause:None) @@ -1193,7 +1200,7 @@ let load_file t ~code ~origin = state to spawn it beside; the price is that eval races the application and the race is documented as the programmer's problem. There is no race to document here, because there is nothing running to race. *) -let eval_expr t ~code ~origin ~pause = +let eval_expr_at t ~code ~origin ~pause ~at = match liveness t with | Gone -> error gone | Live | Parked -> @@ -1209,7 +1216,7 @@ let eval_expr t ~code ~origin ~pause = let had = List.map (fun (f : Tast.fn) -> f.Tast.name) t.session.Session.program.Tast.fns in - match Session.eval_expr ~origin ~pause t.session code with + match Session.eval_expr ~origin ~pause ?frame:(Option.map snd at) t.session code with | c -> let before = match result t with Some (g, _) -> g | None -> 0L in (* Read here, beside [before], and for the same kind of reason: all @@ -1256,7 +1263,14 @@ let eval_expr t ~code ~origin ~pause = in (match build_module c ~debug:t.session.Session.debug ~out with | _ -> - (match deliver t out with + (match + (* In a frame, only at the stop the frame was read at: the thunk + reads that frame's slots by address, and after a resume they + are somebody else's storage. *) + match at with + | Some (gen, _) -> deliver_at_stop t ~gen out + | None -> deliver t out + with | "ok" -> if copies <> [] then begin t.gen <- t.gen + 1; @@ -2406,6 +2420,30 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = name name) else Ok (name, fn))) +(* [:frame N] on [eval-expr] is SLIME's eval-in-frame: the expression sees + that stopped frame's locals — see [Session.in_frame]. The frame is checked + the way [locals] and [inspect] check it, and the thunk is delivered at this + stop only. *) +let eval_expr ?frame t ~code ~origin ~pause = + match frame with + | None -> eval_expr_at t ~code ~origin ~pause ~at:None + | Some index -> + (match stopped_frame t ~frame:index ~what:"an expression in a frame" with + | Error m -> error m + | Ok (_, fn) -> + (match stop_gen t with + | None | Some 0 -> + error + "the program resumed while this was being asked; there is no frame \ + to evaluate in any more" + | Some gen -> + (match bound_slots t ~frame:index with + | Error m -> + error ("the program refused to say which slots are bound: " ^ m) + | Ok bound -> + eval_expr_at t ~code ~origin ~pause + ~at:(Some (gen, (index, fn, bound)))))) + (* [(:op "locals" :frame N)] — what a stopped frame's named locals hold. The half of a break loop that the author actually wanted, and the reason @@ -4379,7 +4417,7 @@ let handle t req = | Some { Form.v = Form.Sym "nil"; _ } | None -> false | Some _ -> true in - eval_expr t ~code ~origin ~pause + eval_expr ?frame:(Wire.int_field req "frame") t ~code ~origin ~pause | None -> error "eval-expr needs :code") (* [:all], absent or [nil] being false and anything else true — the spelling [:pause], [:on] and [:reset] already use. One step is the default because diff --git a/lib/loc.ml b/lib/loc.ml index 9cfb41e4..c72cf840 100644 --- a/lib/loc.ml +++ b/lib/loc.ml @@ -205,6 +205,7 @@ let caught s f = match f () with | x -> Some x | exception Error d -> s.found <- d :: s.found; None + | exception Errors ds -> s.found <- List.rev_append ds s.found; None (** Raise everything found, in the order it was found, or return if the pass was clean. *) diff --git a/lib/session.ml b/lib/session.ml index 41d45d6f..286c6e38 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -968,8 +968,13 @@ let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : chan && List.exists stale_site b.sites) t.built in + (* Every error in the form sent, not the first: [keep_going] checks past a + refused subexpression (see [Check.check]). One error is still raised as + [Loc.Error], which is what every caller of one form expects. *) let program, env, tolerated = - Check.program_tolerant ~tolerate:stale_owner decls + match Check.program_tolerant ~keep_going:true ~tolerate:stale_owner decls with + | r -> r + | exception Loc.Errors [ d ] -> raise (Loc.Error d) in let program = if tolerated = [] then program @@ -2507,7 +2512,68 @@ let render_globals ?(origin = "") t ~(globals : Tast.global list) sticks — a thunk is built and thrown away, so the mark lasts exactly one evaluation, which is the truthful thing for an expression that has no declaration to live in. *) -let eval_expr ?(origin = "") ?(pause = false) t src : change = +(* [frame] is SLIME's eval-in-frame: a stopped frame's index, the function it + is running and which of its slots were bound when it stopped. The + expression is then checked with that frame's named locals in scope — the + innermost of two of one name winning, as it does in the source — and every + use of one reads or writes the frame's own storage through [flan/dev-slot], + so a [set] changes the frame and a vec is not copied. A local not bound + yet is refused where it is named: its address is null. *) +let in_frame t ~frame:(index, (fn : Tast.fn), bound) (parsed : Ast.expr) = + let n = Array.length fn.Tast.slots in + let nparams = List.length fn.Tast.params in + let named = + List.filter_map + (fun i -> + match if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None with + | Some raw -> Some (i, strip_rebind raw) + | None -> None) + (List.init n Fun.id) + in + (* Unbound first, so that of two slots one name the bound one shadows. *) + let order = + List.filter (fun (i, _) -> not (List.mem i bound)) named + @ List.filter (fun (i, _) -> List.mem i bound) named + in + let scope = + List.map (fun (i, name) -> (name, fn.Tast.slots.(i), i >= nparams)) order + in + let checked, base, bnames, syn = Check.expression_in_scope t.env ~scope parsed in + let table = List.map2 (fun (i, name) (_, j) -> (j, (i, name))) order syn in + let idx loc k = + { Tast.e = Tast.Int (Int64.of_int k, Types.I64); ty = Types.Int Types.I64; loc } + in + let pointer i loc = + let ty = fn.Tast.slots.(i) in + { Tast.e = + Tast.Prim + (Tast.Cast (Types.Ptr (Types.Mut, ty)), + [ { Tast.e = Tast.Call ("flan/dev-slot", [ idx loc index; idx loc i ]); + ty = Types.Ptr (Types.Mut, Types.Int Types.U8); loc } ]); + ty = Types.Ptr (Types.Mut, ty); loc } + in + let checked = + Tast.rewrite_locals + (fun j loc -> + match List.assoc_opt j table with + | None -> None + | Some (i, name) when not (List.mem i bound) -> + fail loc + "%s is not bound yet where the program stopped, so there is no \ + value to read" name + | Some (i, _) -> Some (pointer i loc)) + checked + in + (* The slots the frame's names were bound to are read through the pointer + now, never directly; a byte keeps each from costing its type's size. *) + let base = + Array.mapi (fun j ty -> if List.mem_assoc j table then Types.Int Types.U8 else ty) base + and bnames = + Array.mapi (fun j nm -> if List.mem_assoc j table then None else nm) bnames + in + (checked, base, bnames) + +let eval_expr ?(origin = "") ?(pause = false) ?frame t src : change = let form = match Reader.read_all ~file:origin src with | [ f ] -> f @@ -2556,7 +2622,11 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = and the host has no cell for. *) let mark = Check.instance_mark t.env in let lmark = Check.lifted_mark t.env in - let checked, base, bnames = Check.expression t.env parsed in + let checked, base, bnames = + match frame with + | None -> Check.expression t.env parsed + | Some frame -> in_frame t ~frame parsed + in let fresh = Check.instances_since t.env mark in let lifted = Check.lifted_since t.env lmark in (* The thunk's frame starts at whatever [Check.expression] needed and grows diff --git a/lib/tast.ml b/lib/tast.ml index 5267488e..f165c8cc 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -506,6 +506,65 @@ and walk_place f (p : place) = | Pfield (t, _) | Pderef t -> walk f t | Pindex (t, idx) -> walk f t; List.iter (walk f) idx +(* [e] with every read, store and address of a local slot [f] answers for + replaced: a read of slot [i] by [Deref p], its place by [Pderef p], where + [f i loc] is [Some p], a pointer to where the value really lives. The one + caller is evaluating in a stopped frame, whose locals are the other frame's + slots reached by address. Slots [f] answers [None] for are left alone, and + so is every binder: only the slots [f] names are replaced, and none of them + is bound inside [e]. *) +let rec rewrite_locals (f : int -> Loc.t -> expr option) (e : expr) : expr = + let go = rewrite_locals f in + let gos = List.map go in + let kind = + match e.e with + | Local i -> + (match f i e.loc with Some p -> Deref p | None -> e.e) + | Int _ | Float _ | Bool _ | Str _ | Unit | Zero _ | Uninit _ | Global _ + | None_ | FnAddr _ | Break _ | Continue _ -> e.e + | Fill (t, b) -> Fill (t, go b) + | DeadBeef (t, b) -> DeadBeef (t, go b) + | Prim (p, es) -> Prim (p, gos es) + | Call (n, es) -> Call (n, gos es) + | Do es -> Do (gos es) + | Make (n, es) -> Make (n, gos es) + | MakeCase (d, c, es) -> MakeCase (d, c, gos es) + | Arr es -> Arr (gos es) + | InvokeRestart (a, b, es, c, d, l) -> InvokeRestart (a, b, gos es, c, d, l) + | CallPtr (c, es) -> CallPtr (go c, gos es) + | Let (bs, body) -> Let (List.map (fun (s, v) -> (s, go v)) bs, gos body) + | If (a, b, c) -> If (go a, go b, go c) + | While (c, body, latch) -> While (go c, gos body, gos latch) + | Return v -> Return (Option.map go v) + | Set (p, v) -> Set (rewrite_place f e.loc p, go v) + | Addr p -> Addr (rewrite_place f e.loc p) + | Field (t, i) -> Field (go t, i) + | Deref t -> Deref (go t) + | CaseField (t, c, i) -> CaseField (go t, c, i) + | Some_ t -> Some_ (go t) + | UnwrapSome t -> UnwrapSome (go t) + | Signal (k, d, t) -> Signal (k, d, go t) + | Closure (r, t) -> Closure (r, go t) + | Thicken (n, t) -> Thicken (n, go t) + | Match (sc, arms) -> + Match (go sc, List.map (fun a -> { a with abody = gos a.abody }) arms) + | Handled (hs, body) -> + Handled + (List.map (fun h -> { h with henv = Option.map go h.henv }) hs, gos body) + | RestartCase (cs, body) -> + RestartCase (List.map (fun c -> { c with rbody = gos c.rbody }) cs, go body) + | WithAlloc (a, body) -> WithAlloc (go a, gos body) + in + { e with e = kind } + +and rewrite_place f loc (p : place) : place = + match p with + | Plocal i -> (match f i loc with Some ptr -> Pderef ptr | None -> p) + | Pglobal _ -> p + | Pfield (t, i) -> Pfield (rewrite_locals f t, i) + | Pderef t -> Pderef (rewrite_locals f t) + | Pindex (t, idx) -> Pindex (rewrite_locals f t, List.map (rewrite_locals f) idx) + (* ── What the object image can hold ─────────────────────────────────── *) (* Whether an initialiser is a value a linker can write into the program's diff --git a/test/test_dev.ml b/test/test_dev.ml index d5446668..dfc4a1fb 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -127,6 +127,51 @@ let status r = let contains_sub = Test_support.contains +(* Eval-in-frame against dev-locals.flan's [look], stopped at its (error ...): + the expression sees that frame's locals, the inner of two [label]s wins, a + [set] writes the frame's own storage, and a local not bound yet is refused + by name. [ask] sends one request. Run under each backend. *) +let eval_in_frame_checks ~backend ask = + let value code = + let r = + ask (Printf.sprintf "(:op \"eval-expr\" :frame 0 :code %S)" code) + in + if status r = "ok" then Ok (Option.value ~default:"" (Wire.string_field r "value")) + else Error (Option.value ~default:(status r) (Wire.string_field r "message")) + in + let expect code want = + match value code with + | Ok v when v = want -> () + | Ok v -> fail "%s eval-in-frame %s answered %S, wanted %S" backend code v want + | Error m -> fail "%s eval-in-frame %s: %s" backend code m + in + expect "(+ n 1)" "4"; + expect "(.y p)" "2.5"; + expect "label" "\"inner\""; + expect "(do (set flag false) flag)" "false"; + (match + Wire.field (ask "(:op \"locals\" :frame 0)") "locals" + with + | Some { Form.v = Form.List rows; _ } -> + if not + (List.exists + (fun (e : Form.t) -> + match e.Form.v with + | Form.List ({ Form.v = Form.Str "flag"; _ } :: _ + :: { Form.v = Form.Str "false"; _ } :: _) -> true + | _ -> false) + rows) + then fail "%s eval-in-frame: a set did not reach the frame" backend + | _ -> fail "%s eval-in-frame: no locals after the set" backend); + expect "(do (set flag true) flag)" "true"; + (match value "(+ after 1)" with + | Error m when contains_sub m "after is not bound yet" -> () + | Error m -> fail "%s eval-in-frame of an unbound local said %s" backend m + | Ok v -> fail "%s eval-in-frame read an unbound local as %s" backend v); + match value "(+ n \"x\")" with + | Error _ -> () + | Ok v -> fail "%s eval-in-frame accepted a type error: %s" backend v + (* ── The one verb whose reply races the process it ends ─────────────── *) (* [abort] is answered twice over, and the two answers are not ordered. On the @@ -2284,6 +2329,7 @@ let () = (String.concat ", " (List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused"))) end; + eval_in_frame_checks ~backend:"llvm" ask; (* A frame whose every slot the compiler invented is not an error and is not an empty answer either: it says which it is. *) let r = ask "(:op \"locals\" :frame 1)" in @@ -6141,6 +6187,7 @@ let () = (String.concat ", " (List.map (fun (n, w, _) -> n ^ ": " ^ w) (triples r "refused"))) end; + eval_in_frame_checks ~backend:"x86" (request c); (* One slot by index, which is the inspector's own root rather than [locals]' listing, and an aggregate for it: an x86 frame passes every aggregate by pointer, so a struct is where a recorded address could diff --git a/test/test_session.ml b/test/test_session.ml index 5af415c9..e152b4c5 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1764,4 +1764,42 @@ let () = | _ -> fail "a package's bare name resolved from the program's own file" | exception Loc.Error _ -> ()); + (* ── Every error in the form sent ─────────────────────────────────── + A refused subexpression stands as a value that fits anywhere, so the + check goes on past it: three bad expressions are three errors, one three + levels down is still found, and what a failure causes is not reported. *) + (let errors src = + let t, _ = Session.create ~file:"programs/reload.flan" () in + match Session.eval t src with + | _ -> fail "a form with errors was accepted: %s" src; [] + | exception Loc.Error d -> [ d ] + | exception Loc.Errors ds -> ds + in + let msgs ds = String.concat " | " (List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds) in + let three = + errors + "(defn three [] i64 (println (+ 1 \"a\")) (println (nope 2)) (+ 3 \"c\"))" + in + if List.length three <> 3 then + fail "three bad expressions gave %d errors: %s" (List.length three) (msgs three); + let deep = + errors + "(defn deep [] i64 (+ 1 \"a\") (if true (let [x (do (println (nope 2)) 1)] x) 0))" + in + if List.length deep <> 2 || not (has (msgs deep) "nope") then + fail "an error three levels down was not reported: %s" (msgs deep); + (* The failed call poisons the let's [x]; the field read of it and the sum + it flows into are consequences, and are not said. *) + let caused = + errors "(defn caused [] i64 (let [x (nope 1)] (+ (.foo x) (+ x 1))))" + in + if List.length caused <> 1 || not (has (msgs caused) "nope") then + fail "a failure's consequences were reported: %s" (msgs caused); + (* One error is the [Loc.Error] every caller of one form expects. *) + let t, _ = Session.create ~file:"programs/reload.flan" () in + (match Session.eval t "(defn one [] i64 (nope 1))" with + | _ -> fail "an unknown function was accepted" + | exception Loc.Error _ -> () + | exception Loc.Errors _ -> fail "one error came as a list")); + Test_support.report ~label:"session" () From 9a914404861292f585edc34d03f80e8045e66c9a Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:43:24 +0700 Subject: [PATCH 3/4] C-c C-s installs a defn that stops before each form of its body, and the break buffer steps it with s and runs the rest of the call with c --- TODO.org | 12 ++-- emacs/MANUAL.md | 9 +++ emacs/flan-cnr.el | 64 +++++++++++++++++-- emacs/flan-mode.el | 3 + emacs/flan.el | 23 ++++++- emacs/test-flan-cider.el | 54 ++++++++++++++++ lib/ast.ml | 65 ++++++++++++++++++++ lib/dev.ml | 13 +++- lib/prelude.ml | 12 ++++ lib/session.ml | 20 +++++- test/test_dev.ml | 130 +++++++++++++++++++++++++++++++++++++++ 11 files changed, 385 insertions(+), 20 deletions(-) diff --git a/TODO.org b/TODO.org index 80f35745..fda1a4c8 100644 --- a/TODO.org +++ b/TODO.org @@ -2029,14 +2029,10 @@ because =locals= and the inspector are asked by it. The innermost frame is shown even when it is the prelude's, unless the stop is =(pause)=, because it is where the program stopped. Rules out renumbering the visible frames. -** NEXT There is no stepper -Decided 2026-09-25: stepping happens inside a stopped frame, so the game loop and its clock are frozen, as under =(pause)=. -=(pause)= stops and offers restarts, frames, locals and the inspector, but -nothing advances a form at a time. CIDER instruments a form and steps the -instrumented copy; the equivalent here is a dev-build-only instrumented -redefinition, which the cell indirection already makes deliverable. Open: -whether stepping suspends the frame loop, and what it does to a game's clock. - +** DONE There is no stepper +CLOSED: [2026-09-25] +C-c C-s instruments a defn with a step point before each body form; no step +into a callee, no argument positions, and no value shown after a form. ** DONE A NaN cast says "does not fit", which reads as too big CLOSED: [2026-09-25] Two more =ArithError= codes: 5 for a cast of NaN and 6 for a cast of an infinity, diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 34130ffa..3192aa39 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -236,6 +236,12 @@ breakpoint is just a condition nobody handled. hit it as many times as you like; an ordinary `C-c C-c` over the same form (or `C-c C-k` over the buffer) takes it off. +**Stepping.** `C-c C-s` installs the `defn` at point so that a call stops +before each form of its body. Each stop is a break like `(pause)`, and the +source of the form about to run is shown beside it. `s` goes to the next form, +`c` runs the rest of the call, and the next call steps again. `C-c C-c` over the +same form installs it plain. + `C-u C-x C-e` does the same for the expression before point: it stops *at* the expression instead of printing its value. That one does not stick, because there is no definition for it to stick to. `C-u C-c C-c` on a top-level form that is @@ -375,6 +381,9 @@ Keys in that buffer: | `v` | visit the source of the frame at point | | `P` | show or hide the prelude's frames | | `i` | inspect the local or global at point | +| `e` | evaluate an expression in the frame at point; it sees that frame's locals | +| `s` | at a step, go to the next form | +| `c` | take `continue`: at a step, run the rest of the call | | `a` | abort | | `g` | read the program again | | `q` | close the buffer | diff --git a/emacs/flan-cnr.el b/emacs/flan-cnr.el index 1c444758..45b8923a 100644 --- a/emacs/flan-cnr.el +++ b/emacs/flan-cnr.el @@ -63,6 +63,7 @@ ;;; Code: (require 'seq) +(require 'pulse) (require 'subr-x) (require 'flan-mode) @@ -170,6 +171,15 @@ nothing in the compiler knows a breakpoint from an error and this buffer is the first place that can tell the difference. Named here rather than spelled at its use, because it is a fact about the prelude.") +(defconst flan-cnr-step "StepPoint" + "The condition the stepper's `(step-point)' signals, before each form of a +defn sent with `C-c C-s'. A stop like `(pause)', with `next' and `continue' +restarts: `s' takes the first and `c' the second.") + +(defun flan-cnr--stepping-p (state) + "Whether STATE is a stop of the stepper." + (equal (plist-get state :condition) flan-cnr-step)) + (defun flan-cnr--headline-fields (fields) "The condition's own numbers, folded into the headline. FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the @@ -229,7 +239,7 @@ indexing or the division itself, so it sits directly under the headline." ;; only thing that can be wrong here is the word for it. Calling a ;; breakpoint unhandled would be a small lie told at the top of the ;; one buffer that exists to say what happened. - (paused (equal name flan-cnr-breakpoint)) + (paused (member name (list flan-cnr-breakpoint flan-cnr-step))) (numbers (flan-cnr--headline-fields (plist-get state :fields)))) (insert (propertize name 'face (if paused 'warning 'error))) (when numbers (insert " — " numbers)) @@ -240,9 +250,11 @@ indexing or the division itself, so it sits directly under the headline." (let ((sentence (plist-get state :sentence))) (when sentence (insert sentence "\n"))) (insert (propertize - (if paused - "stopped at (pause); nothing has been unwound\n" - "unhandled; stopped where it erred, nothing unwound\n") + (cond + ((flan-cnr--stepping-p state) + "stepping: stopped before the form below; s steps to the next, c runs the rest of the call\n") + (paused "stopped at (pause); nothing has been unwound\n") + (t "unhandled; stopped where it erred, nothing unwound\n")) 'face 'shadow)) (flan-cnr--insert-site state)) (insert "\n") @@ -439,7 +451,8 @@ breakpoint the program's author wrote, not a step of the program." (if (and (not flan-cnr--show-prelude) (flan-cnr--prelude-frame-p fr) (or (> i 0) - (equal (plist-get state :condition) flan-cnr-breakpoint))) + (equal (plist-get state :condition) flan-cnr-breakpoint) + (flan-cnr--stepping-p state))) (setq hidden (1+ hidden)) (when (> hidden 0) (flan-cnr--insert-hidden hidden) @@ -574,7 +587,7 @@ puts the likely culprit on top." ;; an entry is annotated with have to be on screen above it to read. (flan-cnr--insert-globals state) (insert (propertize - "RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame a abort g refresh q quit\n" + "RET/0-9 take RET on a frame visits it TAB fold P prelude frames i inspect e eval in frame s step c continue a abort g refresh q quit\n" 'face 'shadow)) (goto-char (point-min)) ;; Point starts on the restart that abandons the evaluation, when there is @@ -861,6 +874,41 @@ local of, and CODE is read from the minibuffer." v) (user-error "flan: %s" (or (plist-get r :message) "refused"))))) +(defun flan-cnr--take-named (name) + "Take the innermost restart called NAME, or refuse by name." + (let ((i (seq-position (plist-get flan-cnr--state :restarts) name))) + (unless i (user-error "flan: there is no %s restart at this stop" name)) + (flan-cnr--invoke i name))) + +(defun flan-cnr-step () + "Step to the next form: take the stepper's `next' restart." + (interactive) + (flan-cnr--take-named "next")) + +(defun flan-cnr-continue () + "Take the innermost `continue' restart. +At a stepper's stop it runs the rest of the call; at a `(pause)' it resumes." + (interactive) + (flan-cnr--take-named "continue")) + +(defun flan-cnr--step-site (state) + "Where a stepper's STATE stopped: the first frame that is not the prelude's." + (seq-some (lambda (fr) + (and (not (flan-cnr--prelude-frame-p fr)) + (plist-get fr :loc))) + (plist-get state :stack))) + +(defun flan-cnr--show-step-site (state) + "At a stepper's stop, show the form about to run in its source, highlighted. +The break buffer keeps the selection; the source is shown beside it." + (let ((loc (and (flan-cnr--stepping-p state) (flan-cnr--step-site state)))) + (when loc + (ignore-errors + (save-selected-window + (with-current-buffer (flan-visit-loc loc "the step") + (pulse-momentary-highlight-region + (point) (save-excursion (ignore-errors (forward-sexp)) (point))))))))) + (defun flan-cnr-refresh () "Ask the program again what it is offering." (interactive) @@ -920,6 +968,9 @@ anyone who would rather TAB always moved." ;; SLIME's `e': evaluate in the frame at point. (define-key map "e" #'flan-cnr-eval-in-frame) (define-key map "a" #'flan-cnr-abort) + ;; The stepper's two, CIDER's `c' and SLIME's `s' (`n' moves). + (define-key map "s" #'flan-cnr-step) + (define-key map "c" #'flan-cnr-continue) (define-key map "g" #'flan-cnr-refresh) (define-key map "q" #'quit-window) ;; Numbered, as SBCL's are, and for SBCL's reason: the names are not @@ -1162,6 +1213,7 @@ walk from a running program." ;; the program running again: see `flan--forget-break-stack'. (setq next-error-last-buffer buf)) (pop-to-buffer buf) + (flan-cnr--show-step-site (buffer-local-value 'flan-cnr--state buf)) buf))) (provide 'flan-cnr) diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 8785eebc..3c5b9080 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -87,6 +87,7 @@ ;; wiring they need. (autoload 'flan-inspect "flan-inspect" nil t) (autoload 'flan-cnr-show "flan-cnr" nil t) +(autoload 'flan-step-defun "flan" nil t) (autoload 'flan-doc "flan" nil t) (autoload 'flan "flan" nil t) (autoload 'flan-quit "flan" nil t) @@ -448,6 +449,8 @@ For `syntax-propertize-function'." ;; reads as the client being broken rather than as the key being free. (define-key map (kbd "C-M-x") #'flan-eval-defun) (define-key map (kbd "C-c C-k") #'flan-eval-buffer) + ;; The stepper: the defn at point, installed to stop before each form. + (define-key map (kbd "C-c C-s") #'flan-step-defun) (define-key map (kbd "C-x C-e") #'flan-eval-last-sexp) (define-key map (kbd "C-c C-z") #'flan-connect) (define-key map (kbd "C-c C-q") #'flan-disconnect) diff --git a/emacs/flan.el b/emacs/flan.el index 55c4a446..50ddbcdf 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -2590,7 +2590,7 @@ signature, listed in %s" (user-error "flan: %s%s" (or msg "rejected") (if loc (format " (%s)" loc) ""))))) -(defun flan--eval (code what &optional start end pause) +(defun flan--eval (code what &optional start end pause step) "Send CODE to the running program. WHAT names it for the echo area. START and END, when given, are the region it came from, flashed on success. PAUSE, when given, is (BEG . END): the bounds of the form inside CODE the @@ -2605,7 +2605,8 @@ breakpoint is marked from the editor, without editing the buffer\"." (append (list :op "eval" :code code :file (or buffer-file-name "")) (when pause - (list :pause (flan--wire-position (car pause)))))))) + (list :pause (flan--wire-position (car pause)))) + (when step (list :step t)))))) ;; END as the place a value could go. Every caller of this sends a ;; declaration and declarations have no value, so this is the path that ;; stays open rather than one anybody takes today. @@ -2632,6 +2633,10 @@ breakpoint is marked from the editor, without editing the buffer\"." (cond ((and pause (plist-get reply :pause)) (flan--show-pause (car pause) (cdr pause))) + ;; An instrumented defn is marked whole, as a pause mark is, and an + ;; ordinary C-c C-c of it takes the mark down with the instrumentation. + ((and step start end (plist-get reply :step)) + (flan--show-pause start end)) ((and start end) (flan-clear-pause start end))) reply)) @@ -2913,6 +2918,20 @@ declaration for it to live in." ;; `flan--report' signals on a rejection. (pulse-momentary-highlight-region (car b) end)))))) +;;;###autoload +(defun flan-step-defun () + "Install the defn at point so that a call stops before each form of its body. +A stepper, CIDER's `C-u C-M-x': each stop is a break like `(pause)', with the +program and its clock frozen, and the break buffer shows the form about to +run. There `s' steps to the next form and `c' runs the rest of the call; the +next call steps again. `C-c C-c' on the defn installs it plain." + (interactive) + (let* ((b (flan--defun-bounds)) + (head (and (< (car b) (cdr b)) + (flan--declaration-head-at (car b) flan--defun-heads)))) + (unless head (user-error "flan: no defn at point to step through")) + (flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b) nil t))) + ;;;###autoload (defun flan-eval-buffer () "Load this buffer into the running program, as `C-c C-k' does in SLIME and CIDER. diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 2e850c1a..31407150 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1507,6 +1507,60 @@ would be overwritten. Look again and re-do the edit") (test-flan--check "`e' is the break buffer's own key" (eq (lookup-key flan-cnr-mode-map "e") #'flan-cnr-eval-in-frame)))) +;; The stepper's stop: said as a step, the prelude's own frame hidden, and +;; `s' and `c' take its `next' and `continue' by index. +(let* ((asked nil) + (flan-cnr-request-function + (lambda (form) (push form asked) '(:status "ok")))) + (with-current-buffer (test-flan--cnr + (list :condition "StepPoint" + :restarts '("next" "continue" "continue") + :stack (list (list :fn "step-point" :loc ":250:3") + (list :fn "step" :loc "/s.flan:1:19")))) + (let ((text (buffer-string))) + (test-flan--check "a step's headline says it is stepping" + (string-match-p "stepping: stopped before the form" text)) + (test-flan--check "and the prelude's step-point frame is hidden" + (not (string-match-p "step-point" text)))) + (test-flan--check "the step site is the stepped frame's location" + (equal (flan-cnr--step-site flan-cnr--state) "/s.flan:1:19")) + (save-window-excursion (flan-cnr-step)) + (test-flan--check "`s' takes next" + (and (equal (plist-get (car asked) :op) "restart-at") + (equal (plist-get (car asked) :name) "next") + (= 0 (plist-get (car asked) :index))))) + (with-current-buffer (test-flan--cnr + (list :condition "StepPoint" + :restarts '("next" "continue" "continue"))) + (save-window-excursion (flan-cnr-continue)) + (test-flan--check "`c' takes the innermost continue" + (and (equal (plist-get (car asked) :name) "continue") + (= 1 (plist-get (car asked) :index))))) + (test-flan--check "`s' and `c' are the break buffer's own keys" + (and (eq (lookup-key flan-cnr-mode-map "s") #'flan-cnr-step) + (eq (lookup-key flan-cnr-mode-map "c") #'flan-cnr-continue)))) + +;; C-c C-s sends the defn at point for stepping and marks it. +(let ((sent nil)) + (with-temp-buffer + (flan-mode) + (insert "(defn step [] i64\n (set ticks 1)\n ticks)\n") + (goto-char (point-min)) + (forward-line 1) + (cl-letf (((symbol-function 'flan--request) + (lambda (form) (setq sent form) + '(:status "ok" :fns ("step") :names ("step") :step t))) + ((symbol-function 'flan-refresh-defs) #'ignore)) + (flan-step-defun)) + (test-flan--check "C-c C-s sends the defn with :step" + (and (equal (plist-get sent :op) "eval") + (plist-get sent :step) + (string-prefix-p "(defn step" (plist-get sent :code)))) + (test-flan--check "and marks it as instrumented" + (flan--pause-overlays)) + (test-flan--check "C-c C-s is flan-mode's key for it" + (eq (lookup-key flan-mode-map (kbd "C-c C-s")) #'flan-step-defun)))) + ;; `flan-cnr-show' refuses a running program by name rather than opening an ;; empty buffer. ;; The layout without the values: what a `layout' op alone would buy. The diff --git a/lib/ast.ml b/lib/ast.ml index bc5f0d67..362537c6 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -481,6 +481,71 @@ let map_children f (e : expr) : expr = let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc } +(* The stepper. [instrument_step ds] is [ds] with every [defn] rebuilt so a + call stops before each form of its body, at any depth of body: the forms of + a [do], a [let], a loop, a [match] arm and each branch of an [if]. Not + inside an argument, an [fn] or a handler clause, which are not forms a + person reads as steps, and the last two are functions of their own. [None] + when there is no [defn] to instrument. + + A step is [(step-point)] from the prelude — [error] of a [StepPoint] under a + [restart-case], so the break loop takes it as it takes [(pause)], with the + game loop and its clock frozen. It answers whether to go on stepping: its + [next] restart says yes and its [continue] says no, and the answer is kept + in a local of the call, [flan~step], so [continue] runs the rest of this + call and the next call steps again. [~] cannot occur in a source symbol, so + the local is visibly the compiler's and hidden from the locals listing. *) +let step_flag = "flan~step" + +let step_point loc = + let v = { e = Var step_flag; loc } in + { e = + If (v, + { e = Set (Pvar step_flag, { e = Call ({ e = Var "step-point"; loc }, []); loc }); + loc }, + None); + loc } + +let rec step_body (es : expr list) : expr list = + List.concat_map (fun (e : expr) -> [ step_point e.loc; step_expr e ]) es + +and step_expr (e : expr) : expr = + let branch (x : expr) = + match x.e with + | Do _ -> step_expr x + | _ -> { e = Do [ step_point x.loc; step_expr x ]; loc = x.loc } + in + match e.e with + | Do es -> { e with e = Do (step_body es) } + | Let (bs, es) -> { e with e = Let (bs, step_body es) } + | If (c, a, b) -> { e with e = If (c, branch a, Option.map branch b) } + | While (l, c, es) -> { e with e = While (l, c, step_body es) } + | Loop (bs, es) -> { e with e = Loop (bs, step_body es) } + | Dotimes (l, n, b, es) -> { e with e = Dotimes (l, n, b, step_body es) } + | Match (sc, arms) -> + { e with e = Match (sc, List.map (fun a -> { a with body = step_body a.body }) arms) } + | _ -> e + +let instrument_step (ds : decl list) : decl list option = + let hit = ref false in + let ds = + List.map + (fun (d : decl) -> + match d.d with + | Defn f -> + hit := true; + let on = + { bname = step_flag; bty = None; + bval = { e = Var "true"; loc = d.dloc }; bloc = d.dloc } + in + { d with + d = Defn { f with fbody = [ { e = Let ([ on ], step_body f.fbody); + loc = d.dloc } ] } } + | _ -> d) + ds + in + if !hit then Some ds else None + (* [mark_pause ~line ~col ds] is [ds] with a [(pause)] put in front of whatever starts at that position, or [None] when nothing does. diff --git a/lib/dev.ml b/lib/dev.ml index 562333ed..ca4c1aae 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1022,7 +1022,7 @@ let errors_reply (ds : Loc.diag list) = String.sub e 0 (String.length e - 1) ^ " " ^ String.concat " " (errors_field ds) ^ ")" -let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = +let eval ?forms ?base ?(extra = []) ?(step = false) 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 @@ -1046,7 +1046,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = if now = Gone then error gone else match - Session.eval ~origin ?base ?forms ?pause ~running:(not parked_now) + Session.eval ~origin ?base ?forms ?pause ~step ~running:(not parked_now) t.session code with | c when not c.Session.installs -> @@ -1109,6 +1109,7 @@ let eval ?forms ?base ?(extra = []) t ~code ~origin ~pause = | Some (l, c) -> [ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ] | None -> []) + @ (if step then [ ":step t" ] else []) @ install_note t ~parked:parked_now @ unpolled_note t ~parked:parked_now @ extra) @@ -4399,7 +4400,13 @@ let handle t req = let origin = match Wire.string_field req "file" with Some f -> f | None -> "" in - eval t ~code ~origin ~pause:(Wire.pos_field req "pause") + (* [:step t] instruments every defn sent for the stepper. *) + let step = + match Wire.field req "step" with + | Some { Form.v = Form.Sym "nil"; _ } | None -> false + | Some _ -> true + in + eval t ~code ~origin ~pause:(Wire.pos_field req "pause") ~step | None -> error "eval needs :code") | Some "eval-expr" -> (match Wire.string_field req "code" with diff --git a/lib/prelude.ml b/lib/prelude.ml index 904da3c9..e097d34e 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -240,6 +240,18 @@ let source = {flan| (defn pause [] () (restart-case (error (Pause {})) (continue [] (do)))) +;; The stepper's stop, which C-c C-s puts before each form of a defn's body +;; (Ast.instrument_step). It is (pause) with an answer: next goes on stepping +;; and continue runs the rest of the call, and the instrumented body keeps +;; that answer in a local of its own. Like Pause it is not under Error. +;; Named so a program's own step or Step is not what the instrumented body +;; calls. +(defstruct StepPoint []) + +(defn step-point [] bool + (restart-case (error (StepPoint {})) + (next [] :report "stop at the next form" true) + (continue [] :report "run the rest of this call" false))) ;; A seeded PRNG in Flan rather than libc's, because a grid hash is only a ;; regression test if the sequence is byte-identical on native and wasm32 diff --git a/lib/session.ml b/lib/session.ml index 286c6e38..59b81b99 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -787,7 +787,7 @@ let rerun t = t.live <- SM.empty 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 eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = true) t src : change = let forms = match forms with Some f -> f | None -> Reader.read_all ~file:origin src in @@ -877,6 +877,15 @@ let eval ?(origin = "") ?base ?forms ?pause ?(running = true) t src : chan fail loc "nothing to pause at line %d, column %d of the form sent" line col) in + (* [step]: every defn sent stops before each form of its body — see + [Ast.instrument_step]. After [qualify_decl] for the reason [pause] is. *) + let incoming = + if not step then incoming + else + match Ast.instrument_step incoming with + | Some ds -> ds + | None -> fail loc "there is no defn in the form sent to step through" + in (* A method declares a name of its own — that is what makes evaluating one twice a replacement and evaluating a new one an append, through the same kept/added logic every other declaration goes through. But no function is @@ -1504,6 +1513,15 @@ let shown_names (fn : Tast.fn) : string option array = Array.init n (fun i -> if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None) in + (* A name the compiler gave a local of its own, such as the stepper's + [flan~step], is hidden like an unnamed slot: [~] cannot be typed. *) + let raw = + Array.map + (function + | Some n when String.starts_with ~prefix:"flan~" n -> None + | x -> x) + raw + in let stripped = Array.map (Option.map strip_rebind) raw in let count name = Array.fold_left diff --git a/test/test_dev.ml b/test/test_dev.ml index dfc4a1fb..b781671e 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -8759,6 +8759,136 @@ let () = hook_block ~llvm:false; hook_block ~llvm:true; + (* ── The stepper ───────────────────────────────────────────────── + [dev-pause.flan] calls [step] every 5ms. Sent with [:step t], a call + stops before each form of its body: first the (set ...), then, after + [next], the [ticks] it answers. [continue] runs the rest of the call, + and the next call steps again. A plain evaluation takes it out. Under + both backends, each with its own daemon. *) + let stepper ~llvm = + let what = if llvm then "llvm " else "x86 " in + let ssock = tmp (what ^ "step.sock") and sout = tmp (what ^ "step.out") in + (try Sys.remove ssock with Sys_error _ -> ()); + let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let spid = + Unix.create_process flan + (Array.append + [| flan; "dev"; "programs/dev-pause.flan"; "-s"; ssock |] + (if llvm then [| "--llvm" |] else [||])) + Unix.stdin sfd Unix.stderr + in + Unix.close sfd; + if not (listening ~pid:spid ssock) then + fail "%sstepper daemon %s" what !listen_why + else begin + let c = connect ssock in + let ask = request c in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let body = "(defn step [] i64 (set ticks (+ ticks 1)) ticks)" in + let col sub = + let n = String.length sub in + let rec find i = + if String.equal (String.sub body i n) sub then i + 1 else find (i + 1) + in + find 0 + in + (* Where the stepped frame is: the frame of [step], whose location is + the step point's, which is the form about to run. *) + let at () = + match Wire.field (ask "(:op \"backtrace\")") "frames" with + | Some { Form.v = Form.List l; _ } -> + List.find_map + (fun (f : Form.t) -> + match f.Form.v with + | Form.List ({ Form.v = Form.Str "step"; _ } + :: { Form.v = Form.Str loc; _ } :: _) -> Some loc + | _ -> None) + l + | _ -> None + in + let stops_at sub = + let want = Printf.sprintf ":1:%d" (col sub) in + await (fun () -> + stopped (ask "(:op \"describe\")") + && (match at () with Some l -> contains_sub l want | None -> false)) + in + let r = + ask + (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\" :step t)" + (Wire.quote body)) + in + if status r <> "ok" then + fail "%sinstrumenting for the stepper: %s" what + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + if Wire.field r "step" = None then + fail "%san instrumented defn did not echo :step" what; + if not (stops_at "(set ticks") then + fail "%sthe stepper did not stop before the first form (at %s)" what + (Option.value ~default:"" (at ())) + else begin + (match Wire.string_field (ask "(:op \"describe\")") "condition" with + | Some "StepPoint" -> () + | c -> fail "%sa step stopped on %s" what (Option.value ~default:"" c)); + (* The stepper's own local is not one of the frame's. *) + let fr = ask "(:op \"locals\" :frame 1)" in + (match Wire.string_field fr "frame" with + | Some "step" -> + (match Wire.field fr "locals" with + | Some { Form.v = Form.List []; _ } | None -> () + | _ -> fail "%sthe stepper's flag is listed as a local" what) + | f -> fail "%sframe 1 at a step is %s" what (Option.value ~default:"" f)); + let r = ask "(:op \"restart\" :name \"next\")" in + if status r <> "ok" then + fail "%snext at a step: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + if not (stops_at "ticks)") then + fail "%snext did not stop before the second form (at %s)" what + (Option.value ~default:"" (at ())); + let r = ask "(:op \"restart\" :name \"continue\")" in + if status r <> "ok" then + fail "%scontinue at a step: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + (* The next call, 5ms on, steps again from the top. *) + if not (stops_at "(set ticks") then + fail "%sthe next call did not step again" what; + let r = + ask + (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\")" + (Wire.quote body)) + in + if status r <> "ok" then + fail "%sinstalling the plain defn: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + ignore (ask "(:op \"restart\" :name \"continue\")"); + if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then + fail "%sthe program did not resume from the last step" what; + let deadline = Unix.gettimeofday () +. 0.5 in + let rec run_on () = + if Unix.gettimeofday () > deadline then () + else if stopped (ask "(:op \"describe\")") then + fail "%sthe plain defn still steps" what + else begin + ignore (Unix.select [] [] [] 0.01); + run_on () + end + in + run_on () + end + end; + (try Unix.close c with Unix.Unix_error _ -> ()) + end; + (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ()); + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ] + in + stepper ~llvm:false; + stepper ~llvm:true; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; Test_support.report ~label:"dev" () From 37938db7c2f24652b94c511262003e87434feddf Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 16:47:46 +0700 Subject: [PATCH 4/4] A call through a failed local is not reported and a miscounted call's arguments are, eval-in-frame answers slotless frames and ended stops, flan dev links its own agent, and the daemon buffer colours only file:line:col diagnostics --- TODO.org | 5 + emacs/MANUAL.md | 1 + emacs/flan.el | 9 ++ emacs/test-flan-cider.el | 24 ++++ emacs/test-flan.el | 8 +- lib/check.ml | 36 ++++- lib/dev.ml | 57 ++++++-- test/test_dev.ml | 275 ++++++++++++++++++++------------------- test/test_session.ml | 18 +++ 9 files changed, 284 insertions(+), 149 deletions(-) diff --git a/TODO.org b/TODO.org index de91143d..4cc97b73 100644 --- a/TODO.org +++ b/TODO.org @@ -2015,6 +2015,11 @@ because =locals= and the inspector are asked by it. The innermost frame is shown even when it is the prelude's, unless the stop is =(pause)=, because it is where the program stopped. Rules out renumbering the visible frames. +** DONE C-c C-c reports one error, not every error in the form +CLOSED: [2026-09-25] +Every error at any depth: a refused subexpression stands as a Never that fits +any want, and what it causes is left unsaid. Rules out stopping at a statement boundary. + ** DONE There is no stepper CLOSED: [2026-09-25] C-c C-s instruments a defn with a step point before each body form; no step diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 0cc330e0..be05ee23 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -1195,6 +1195,7 @@ Use `C-c C-g` if you need frames. | `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` | load the whole buffer, as one module; what does not compile is listed | +| `C-c C-s` | install the defn at point to stop before each form of its body | | `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 3fbcdd24..ad175078 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -428,6 +428,15 @@ is switched on here, first, or the rules would never be drawn." (font-lock-mode 1) ;; A log, not source: a quote the program printed opens no string. (setq-local font-lock-keywords-only t) + ;; Only the compiler's own shape, `file:line:col:', is a diagnostic here. + ;; compile.el's other rules are for a build log: one of them draws any + ;; line starting `word:' as a program name, which is every `score: 10' + ;; the program prints. + (setq-local compilation-mode-font-lock-keywords nil) + (setq-local compilation-error-regexp-alist + '(("^\\([^ \t\n:][^\t\n:]*\\):\\([0-9]+\\):\\([0-9]+\\): \ +\\(?:\\(warning\\)\\|\\(note\\|info\\)\\)?" + 1 2 3 (4 . 5)))) (compilation-minor-mode 1) (flan--navigable-notes)) diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 31407150..16f65fc8 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -1540,6 +1540,30 @@ would be overwritten. Look again and re-do the edit") (and (eq (lookup-key flan-cnr-mode-map "s") #'flan-cnr-step) (eq (lookup-key flan-cnr-mode-map "c") #'flan-cnr-continue)))) +;; Every key flan-mode binds has a row in the manual's key reference. +(let ((text (with-temp-buffer + (insert-file-contents + (expand-file-name "MANUAL.md" + (file-name-directory (locate-library "flan-mode")))) + (buffer-string))) + (missing nil)) + (map-keymap + (lambda (k d) + (when (and (eq k ?\C-c) (keymapp d)) + (map-keymap + (lambda (k2 d2) + (when (commandp d2) + (let ((desc (replace-regexp-in-string + "RET" "C-m" + (replace-regexp-in-string + "TAB" "C-i" (key-description (vector k k2)))))) + (unless (string-match-p (regexp-quote (format "| `%s` |" desc)) text) + (push desc missing))))) + d))) + flan-mode-map) + (test-flan--check (format "every C-c key has a row in the manual (missing %s)" missing) + (null missing))) + ;; C-c C-s sends the defn at point for stepping and marks it. (let ((sent nil)) (with-temp-buffer diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 5fa5cd5d..952cb01f 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -545,7 +545,7 @@ already rely on it — so nothing here is a stand-in for the real thing." "/tmp/a.flan:3:1: warning: w\n" "/tmp/a.flan:4:1: note: n\n") (flan--daemon-buffer-setup) - (flan--append-output "said hi\n") + (flan--append-output "said hi\nscore: 10\n") (font-lock-ensure) (let ((face-on (lambda (text) (goto-char (point-min)) @@ -559,6 +559,12 @@ already rely on it — so nothing here is a stand-in for the real thing." (test-flan--check "the program's output takes its own face" (eq (funcall face-on "said") 'flan-output-face)) + (test-flan--check + "a line of output shaped `word:' is not drawn as a program name" + (progn (goto-char (point-min)) (search-forward "score") + (and (null (get-text-property (match-beginning 0) 'face)) + (eq (get-text-property (match-beginning 0) 'font-lock-face) + 'flan-output-face)))) (test-flan--check "the daemon's own line is left plain" (null (funcall face-on "flan dev:"))))) diff --git a/lib/check.ml b/lib/check.ml index e75979b1..d601138c 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4252,7 +4252,17 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = if is_poison r then env.poison <- env.poison + 1; r | exception Loc.Error d -> - if not (caused ()) then record_recovered env d; + if not (caused ()) then begin + record_recovered env d; + (* A call refused as a whole — the wrong number of arguments, say — + never checked its arguments, and a mistake inside one is still a + mistake. They are checked on their own, with no expectation, so + only what no expectation could change is kept: a name that is not + there. *) + match e.Ast.e with + | Ast.Call (_, args) -> recheck_args ctx args + | _ -> () + end; env.poison <- env.poison + 1; poison e.Ast.loc (* A checker arm that was never written for a [Never] operand may fail @@ -4263,6 +4273,20 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = poison e.Ast.loc end +and recheck_args ctx (args : Ast.expr list) = + let env = ctx.env in + let before = env.recovered in + List.iter (fun a -> ignore (check ctx a)) args; + let rec fresh l = if l == before then [] else match l with [] -> [] | d :: r -> d :: fresh r in + let kept = + List.filter + (fun (d : Loc.diag) -> + String.starts_with ~prefix:"check/unknown-" d.Loc.kind + || String.equal d.Loc.kind "check/private") + (fresh env.recovered) + in + env.recovered <- kept @ before + and check_plain ctx ?want (e : Ast.expr) : Tast.expr = let place = ctx.place_ok in ctx.place_ok <- false; @@ -10861,6 +10885,16 @@ and ordinary_call ctx ~want loc name args = lifted body captures it by value and then calls the copy. [peek_outer] rather than [capture] in the guard, because a guard must not take a copy on its way to deciding what a form means. *) + (* A local bound to a refused initialiser's stand-in, called: the refusal + is already reported, so the call stands in too, its arguments still + checked. *) + | _ when ctx.env.recovering + && (match lookup ctx name with + | Some b -> Types.equal b.bty Types.Never + | None -> false) -> + List.iter (fun a -> ignore (check ctx a)) args; + ctx.env.poison <- ctx.env.poison + 1; + poison loc | _ when (match lookup ctx name with | Some b -> callable_ty b.bty | None -> diff --git a/lib/dev.ml b/lib/dev.ml index 1570302c..c71660f7 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1246,6 +1246,18 @@ let eval_expr_at t ~code ~origin ~pause ~at = TODO.org, "Whose break it is, which no counter answers" has it. *) let entered = state t in let entered_gen = stop_gen t in + (* In a frame the thunk is addressed to one stop, and the agent drops it, + and counts the drop, if that stop has ended by the time it is + claimed. Read before the build, which is when that usually happens. *) + let refused_before = if at = None then None else refusals t in + let dropped () = + match refused_before with + | None -> None + | Some (before, _) -> + (match refusals t with + | Some (now, why) when now > before -> Some why + | _ -> None) + in t.n <- t.n + 1; let out = Filename.concat t.dir (Printf.sprintf "e%d.so" t.n) in (* A generic called at a new type makes a copy that is defined in this @@ -1417,6 +1429,9 @@ let eval_expr_at t ~code ~origin ~pause ~at = | Some answer -> (match value () with Some v -> `Value v | None -> answer) | None -> + match dropped () with + | Some why -> `Dropped why + | None -> if ms <= 0 then `Timeout else begin ignore (Unix.select [] [] [] 0.005); @@ -1481,6 +1496,7 @@ let eval_expr_at t ~code ~origin ~pause ~at = left over, which is the shape it was always about: a program that is running, is not parked, and produced nothing in five seconds. *) + | `Dropped why -> error why | `Timeout -> if liveness t = Parked then error @@ -2425,7 +2441,7 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = that stopped frame's locals — see [Session.in_frame]. The frame is checked the way [locals] and [inspect] check it, and the thunk is delivered at this stop only. *) -let eval_expr ?frame t ~code ~origin ~pause = +let eval_expr ?frame ?at_stop t ~code ~origin ~pause = match frame with | None -> eval_expr_at t ~code ~origin ~pause ~at:None | Some index -> @@ -2438,7 +2454,17 @@ let eval_expr ?frame t ~code ~origin ~pause = "the program resumed while this was being asked; there is no frame \ to evaluate in any more" | Some gen -> - (match bound_slots t ~frame:index with + (* A frame with no slots has no locals to bind, and the program + has no table to answer for it: the expression sees globals. *) + let bound = + if Array.length fn.Tast.slots = 0 then Ok [] + else bound_slots t ~frame:index + in + (* [at_stop] is the stop the editor drew the frame at. It is not + checked here: the agent refuses a thunk addressed to a stop that + is over, and says so. *) + let gen = Option.value ~default:gen at_stop in + (match bound with | Error m -> error ("the program refused to say which slots are bound: " ^ m) | Ok bound -> @@ -4444,7 +4470,8 @@ and handle_op t req = | Some { Form.v = Form.Sym "nil"; _ } | None -> false | Some _ -> true in - eval_expr ?frame:(Wire.int_field req "frame") t ~code ~origin ~pause + eval_expr ?frame:(Wire.int_field req "frame") + ?at_stop:(Wire.int_field req "at-stop") t ~code ~origin ~pause | None -> error "eval-expr needs :code") (* [:all], absent or [nil] being false and anything else true — the spelling [:pause], [:on] and [:reset] already use. One step is the default because @@ -5229,19 +5256,21 @@ let need_main ~file (session : Session.t) = (* 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. *) + file that never mentions the agent can still be reached from the editor. + + Always this compiler's own copy, in place of any the program vendors. The + agent is the daemon's other half — the stack it snapshots and the verbs it + answers are what this file reads — and a program outside this repository + carries whatever copy of vendor/agent it was given, however old. An old one + builds and answers, and then puts every frame at its function's own line, + because it predates the call-site record, so the stepper never moves. One + copy and not two: two would collide at the link. A release build is not + built here. *) let with_agent ~dir csrcs lflags = + let c = Filename.concat dir "flan_agent.c" in + write_file c Runtime_src.agent_source; 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 + List.filter (fun x -> Filename.basename x <> "flan_agent.c") csrcs @ [ c ] in let lflags = lflags diff --git a/test/test_dev.ml b/test/test_dev.ml index ba666e10..1dada954 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -127,6 +127,111 @@ let status r = let contains_sub = Test_support.contains +(* The stepper, against a running program whose [step] is dev-pause.flan's + and dev-repl.flan's: sent with [:step t], a call stops before each form of + its body — the (set ...), then after [next] the [ticks] it answers. + [continue] runs the rest of the call and the next call steps again, and a + plain evaluation takes it out. Run in a daemon of each backend that another + block already started, so it costs no build of its own. *) +let stepper_checks ~what ask = + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let body = "(defn step [] i64 (set ticks (+ ticks 1)) ticks)" in + let col sub = + let n = String.length sub in + let rec find i = + if String.equal (String.sub body i n) sub then i + 1 else find (i + 1) + in + find 0 + in + (* Where the stepped frame is: the frame of [step], whose location is + the step point's, which is the form about to run. *) + let at () = + match Wire.field (ask "(:op \"backtrace\")") "frames" with + | Some { Form.v = Form.List l; _ } -> + List.find_map + (fun (f : Form.t) -> + match f.Form.v with + | Form.List ({ Form.v = Form.Str "step"; _ } + :: { Form.v = Form.Str loc; _ } :: _) -> Some loc + | _ -> None) + l + | _ -> None + in + let stops_at sub = + let want = Printf.sprintf ":1:%d" (col sub) in + await (fun () -> + stopped (ask "(:op \"describe\")") + && (match at () with Some l -> contains_sub l want | None -> false)) + in + let r = + ask + (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\" :step t)" + (Wire.quote body)) + in + if status r <> "ok" then + fail "%sinstrumenting for the stepper: %s" what + (Option.value ~default:"" (Wire.string_field r "message")) + else begin + if Wire.field r "step" = None then + fail "%san instrumented defn did not echo :step" what; + if not (stops_at "(set ticks") then + fail "%sthe stepper did not stop before the first form (at %s)" what + (Option.value ~default:"" (at ())) + else begin + (match Wire.string_field (ask "(:op \"describe\")") "condition" with + | Some "StepPoint" -> () + | c -> fail "%sa step stopped on %s" what (Option.value ~default:"" c)); + (* The stepper's own local is not one of the frame's. *) + let fr = ask "(:op \"locals\" :frame 1)" in + (match Wire.string_field fr "frame" with + | Some "step" -> + (match Wire.field fr "locals" with + | Some { Form.v = Form.List []; _ } | None -> () + | _ -> fail "%sthe stepper's flag is listed as a local" what) + | f -> fail "%sframe 1 at a step is %s" what (Option.value ~default:"" f)); + let r = ask "(:op \"restart\" :name \"next\")" in + if status r <> "ok" then + fail "%snext at a step: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + if not (stops_at "ticks)") then + fail "%snext did not stop before the second form (at %s)" what + (Option.value ~default:"" (at ())); + let r = ask "(:op \"restart\" :name \"continue\")" in + if status r <> "ok" then + fail "%scontinue at a step: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + (* The next call, 5ms on, steps again from the top. *) + if not (stops_at "(set ticks") then + fail "%sthe next call did not step again" what; + let r = + ask + (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\")" + (Wire.quote body)) + in + if status r <> "ok" then + fail "%sinstalling the plain defn: %s" what + (Option.value ~default:"" (Wire.string_field r "message")); + ignore (ask "(:op \"restart\" :name \"continue\")"); + if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then + fail "%sthe program did not resume from the last step" what; + let deadline = Unix.gettimeofday () +. 0.5 in + let rec run_on () = + if Unix.gettimeofday () > deadline then () + else if stopped (ask "(:op \"describe\")") then + fail "%sthe plain defn still steps" what + else begin + ignore (Unix.select [] [] [] 0.01); + run_on () + end + in + run_on () + end + end + (* Eval-in-frame against dev-locals.flan's [look], stopped at its (error ...): the expression sees that frame's locals, the inner of two [label]s wins, a [set] writes the frame's own storage, and a local not bound yet is refused @@ -168,9 +273,19 @@ let eval_in_frame_checks ~backend ask = | Error m when contains_sub m "after is not bound yet" -> () | Error m -> fail "%s eval-in-frame of an unbound local said %s" backend m | Ok v -> fail "%s eval-in-frame read an unbound local as %s" backend v); - match value "(+ n \"x\")" with - | Error _ -> () - | Ok v -> fail "%s eval-in-frame accepted a type error: %s" backend v + (match value "(+ n \"x\")" with + | Error _ -> () + | Ok v -> fail "%s eval-in-frame accepted a type error: %s" backend v); + (* Addressed to a stop that is over: the agent drops it, and the reply says + why at once rather than timing out. *) + let t0 = Unix.gettimeofday () in + let r = ask "(:op \"eval-expr\" :frame 0 :at-stop 999999 :code \"n\")" in + let m = Option.value ~default:"" (Wire.string_field r "message") in + if status r = "ok" then fail "%s eval-in-frame ran at a stop that is over" backend + else if not (contains_sub m "resumed" || contains_sub m "stopped again") then + fail "%s eval-in-frame at a stop that is over said %s" backend m + else if Unix.gettimeofday () -. t0 > 4.0 then + fail "%s eval-in-frame at a stop that is over waited out the clock" backend (* ── The one verb whose reply races the process it ends ─────────────── *) @@ -239,7 +354,21 @@ let () = explain and is quoted as it stands. *) let other = Dev.refusal ~parked:true "err flan.abi.x86: the module is x86" in if not (contains_sub other "flan.abi.x86") then - fail "a parked program's other refusals were rewritten too: %S" other + fail "a parked program's other refusals were rewritten too: %S" other; + (* The agent is always this compiler's, never the copy a program vendors: + an old copy answers every frame at its function's own line. *) + let dir = tmp "agent-dir" in + (try Unix.mkdir dir 0o700 with Unix.Unix_error _ -> ()); + let csrcs, _ = + Dev.with_agent ~dir [ "/far/vendor/agent/flan_agent.c"; "/far/x.c" ] [] + in + let own = Filename.concat dir "flan_agent.c" in + if csrcs <> [ "/far/x.c"; own ] then + fail "a vendored agent was linked in place of the compiler's: %s" + (String.concat " " csrcs) + else if In_channel.with_open_bin own In_channel.input_all + <> Runtime_src.agent_source then + fail "the agent linked is not the compiler's own" (* A daemon's death is reported by the signal's name. [WSIGNALED] carries OCaml's own numbering, in which SIGTERM is -11, and a SIGTERM printed as @@ -4418,6 +4547,7 @@ let () = end else begin let c = connect sigsock in + stepper_checks ~what:"llvm " (request c); let stopped r = match Wire.field r "stopped" with | Some { Form.v = Form.Sym "t"; _ } -> true @@ -4882,6 +5012,13 @@ let () = if not (List.exists (String.equal "continue") names) then fail "a break at (pause) offers %s, wanted continue among them" (String.concat ", " names); + (* [step] has no slots at all, so there is nothing to bind and no + table for the program to answer from: an expression evaluated + in its frame sees the globals. Frame 0 is [pause]'s own. *) + (let r = ask "(:op \"eval-expr\" :frame 1 :code \"(+ ticks 0)\")" in + if status r <> "ok" then + fail "eval-in-frame of a frame with no slots: %s" + (Option.value ~default:(status r) (Wire.string_field r "message"))); (* The second claim, and the one this block exists for. A plain re-evaluation of the same form replaces the stored declaration @@ -4927,6 +5064,7 @@ let () = end end end; + stepper_checks ~what:"x86 " ask; (* The other way a thunk reaches a [(pause)], and the one no flag asks for: an ordinary [C-x C-e] over an expression that calls a body @@ -8799,135 +8937,6 @@ let () = hook_block ~llvm:false; hook_block ~llvm:true; - (* ── The stepper ───────────────────────────────────────────────── - [dev-pause.flan] calls [step] every 5ms. Sent with [:step t], a call - stops before each form of its body: first the (set ...), then, after - [next], the [ticks] it answers. [continue] runs the rest of the call, - and the next call steps again. A plain evaluation takes it out. Under - both backends, each with its own daemon. *) - let stepper ~llvm = - let what = if llvm then "llvm " else "x86 " in - let ssock = tmp (what ^ "step.sock") and sout = tmp (what ^ "step.out") in - (try Sys.remove ssock with Sys_error _ -> ()); - let sfd = Unix.openfile sout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in - let spid = - Unix.create_process flan - (Array.append - [| flan; "dev"; "programs/dev-pause.flan"; "-s"; ssock |] - (if llvm then [| "--llvm" |] else [||])) - Unix.stdin sfd Unix.stderr - in - Unix.close sfd; - if not (listening ~pid:spid ssock) then - fail "%sstepper daemon %s" what !listen_why - else begin - let c = connect ssock in - let ask = request c in - let stopped r = - match Wire.field r "stopped" with - | Some { Form.v = Form.Sym "t"; _ } -> true - | _ -> false - in - let body = "(defn step [] i64 (set ticks (+ ticks 1)) ticks)" in - let col sub = - let n = String.length sub in - let rec find i = - if String.equal (String.sub body i n) sub then i + 1 else find (i + 1) - in - find 0 - in - (* Where the stepped frame is: the frame of [step], whose location is - the step point's, which is the form about to run. *) - let at () = - match Wire.field (ask "(:op \"backtrace\")") "frames" with - | Some { Form.v = Form.List l; _ } -> - List.find_map - (fun (f : Form.t) -> - match f.Form.v with - | Form.List ({ Form.v = Form.Str "step"; _ } - :: { Form.v = Form.Str loc; _ } :: _) -> Some loc - | _ -> None) - l - | _ -> None - in - let stops_at sub = - let want = Printf.sprintf ":1:%d" (col sub) in - await (fun () -> - stopped (ask "(:op \"describe\")") - && (match at () with Some l -> contains_sub l want | None -> false)) - in - let r = - ask - (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\" :step t)" - (Wire.quote body)) - in - if status r <> "ok" then - fail "%sinstrumenting for the stepper: %s" what - (Option.value ~default:"" (Wire.string_field r "message")) - else begin - if Wire.field r "step" = None then - fail "%san instrumented defn did not echo :step" what; - if not (stops_at "(set ticks") then - fail "%sthe stepper did not stop before the first form (at %s)" what - (Option.value ~default:"" (at ())) - else begin - (match Wire.string_field (ask "(:op \"describe\")") "condition" with - | Some "StepPoint" -> () - | c -> fail "%sa step stopped on %s" what (Option.value ~default:"" c)); - (* The stepper's own local is not one of the frame's. *) - let fr = ask "(:op \"locals\" :frame 1)" in - (match Wire.string_field fr "frame" with - | Some "step" -> - (match Wire.field fr "locals" with - | Some { Form.v = Form.List []; _ } | None -> () - | _ -> fail "%sthe stepper's flag is listed as a local" what) - | f -> fail "%sframe 1 at a step is %s" what (Option.value ~default:"" f)); - let r = ask "(:op \"restart\" :name \"next\")" in - if status r <> "ok" then - fail "%snext at a step: %s" what - (Option.value ~default:"" (Wire.string_field r "message")); - if not (stops_at "ticks)") then - fail "%snext did not stop before the second form (at %s)" what - (Option.value ~default:"" (at ())); - let r = ask "(:op \"restart\" :name \"continue\")" in - if status r <> "ok" then - fail "%scontinue at a step: %s" what - (Option.value ~default:"" (Wire.string_field r "message")); - (* The next call, 5ms on, steps again from the top. *) - if not (stops_at "(set ticks") then - fail "%sthe next call did not step again" what; - let r = - ask - (Printf.sprintf "(:op \"eval\" :code %s :file \"/tmp/step.flan\")" - (Wire.quote body)) - in - if status r <> "ok" then - fail "%sinstalling the plain defn: %s" what - (Option.value ~default:"" (Wire.string_field r "message")); - ignore (ask "(:op \"restart\" :name \"continue\")"); - if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then - fail "%sthe program did not resume from the last step" what; - let deadline = Unix.gettimeofday () +. 0.5 in - let rec run_on () = - if Unix.gettimeofday () > deadline then () - else if stopped (ask "(:op \"describe\")") then - fail "%sthe plain defn still steps" what - else begin - ignore (Unix.select [] [] [] 0.01); - run_on () - end - in - run_on () - end - end; - (try Unix.close c with Unix.Unix_error _ -> ()) - end; - (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); - (try ignore (Unix.waitpid [] spid) with Unix.Unix_error _ -> ()); - List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ] - in - stepper ~llvm:false; - stepper ~llvm:true; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ]; diff --git a/test/test_session.ml b/test/test_session.ml index e152b4c5..8fe132ae 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1795,6 +1795,24 @@ let () = in if List.length caused <> 1 || not (has (msgs caused) "nope") then fail "a failure's consequences were reported: %s" (msgs caused); + (* A local bound to a refused initialiser and then called is the same + consequence: no "unknown function p". *) + let called = errors "(defn called [] i64 (let [p (nope 1)] (p 3)))" in + if List.length called <> 1 then + fail "calling a local bound to a failure was reported: %s" (msgs called); + (* A call refused for its argument count still has its arguments checked. *) + let arity = + errors "(defn arity [] i64 (bump (nope2) 7 8))" + in + if List.length arity <> 2 || not (has (msgs arity) "nope2") then + fail "an error inside a miscounted call was not reported: %s" (msgs arity); + (* And the whole-file path: fn-no-type.flan has one mistake, reported once. *) + (match Front.checked ~all:true "programs/fn-no-type.flan" with + | _ -> fail "fn-no-type.flan checked" + | exception Loc.Error _ -> () + | exception Loc.Errors ds -> + if List.length ds <> 1 then + fail "fn-no-type.flan gave %d errors: %s" (List.length ds) (msgs ds)); (* One error is the [Loc.Error] every caller of one form expects. *) let t, _ = Session.create ~file:"programs/reload.flan" () in (match Session.eval t "(defn one [] i64 (nope 1))" with