From da9f21ddcd072fe897703f5ed58c1bfe9b6a7ade Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 15:33:23 +0700 Subject: [PATCH] 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" ()