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

This commit is contained in:
Joseph Ferano 2026-09-25 15:33:23 +07:00
parent 8dc90416d4
commit da9f21ddcd
11 changed files with 552 additions and 81 deletions

View File

@ -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 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. 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 ** DONE The stack lists prelude frames
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
A frame whose location is =<prelude>= is hidden by default, and a line in its A frame whose location is =<prelude>= 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 =dotimes= binds one name, and =fn=, =defn=, =match= and the handler and restart
clauses bind parameters with no initialisers. 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 ** DONE A session should start before a program compiles
CLOSED: [2026-09-25] 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=. 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=.

View File

@ -574,7 +574,7 @@ puts the likely culprit on top."
;; an entry is annotated with have to be on screen above it to read. ;; an entry is annotated with have to be on screen above it to read.
(flan-cnr--insert-globals state) (flan-cnr--insert-globals state)
(insert (propertize (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)) 'face 'shadow))
(goto-char (point-min)) (goto-char (point-min))
;; Point starts on the restart that abandons the evaluation, when there is ;; Point starts on the restart that abandons the evaluation, when there is
@ -833,6 +833,34 @@ drawn from."
(`(:expr ,expr) (flan-inspect expr)) (`(:expr ,expr) (flan-inspect expr))
(_ (user-error "flan: this line carries no root the inspector knows"))))) (_ (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 () (defun flan-cnr-refresh ()
"Ask the program again what it is offering." "Ask the program again what it is offering."
(interactive) (interactive)
@ -889,6 +917,8 @@ anyone who would rather TAB always moved."
(define-key map "v" #'flan-cnr-visit) (define-key map "v" #'flan-cnr-visit)
(define-key map "P" #'flan-cnr-toggle-prelude) (define-key map "P" #'flan-cnr-toggle-prelude)
(define-key map "i" #'flan-cnr-inspect) (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 "a" #'flan-cnr-abort)
(define-key map "g" #'flan-cnr-refresh) (define-key map "g" #'flan-cnr-refresh)
(define-key map "q" #'quit-window) (define-key map "q" #'quit-window)

View File

@ -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 ;; 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 ;; declaration and declarations have no value, so this is the path that
;; stays open rather than one anybody takes today. ;; 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 ;; `flan--report' signals on a rejection, so reaching here means it
;; landed. Flashing the text that was sent answers "which form did that ;; landed. Flashing the text that was sent answers "which form did that
;; take?" — the question the echo area cannot, because point may be nowhere ;; take?" — the question the echo area cannot, because point may be nowhere

View File

@ -1477,6 +1477,36 @@ would be overwritten. Look again and re-do the edit")
(test-flan--check "nothing is evaluated as an expression" (test-flan--check "nothing is evaluated as an expression"
(null (plist-get (car asked) :code)))))) (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 ;; `flan-cnr-show' refuses a running program by name rather than opening an
;; empty buffer. ;; empty buffer.
;; The layout without the values: what a `layout' op alone would buy. The ;; The layout without the values: what a `layout' op alone would buy. The

View File

@ -211,6 +211,19 @@ type env = {
the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan the declare-c forms before [Shim.expand] rewrites them. Keyed by the Flan
name a program calls. *) name a program calls. *)
tracks : (string, Shim.track) Hashtbl.t; 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 () = { let new_env () = {
@ -243,6 +256,11 @@ let new_env () = {
in_field = false; in_field = false;
classes = Hashtbl.create 8; classes = Hashtbl.create 8;
tracks = Hashtbl.create 16; 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. (* 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 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 [slot_tys] are counted up per frame, and two frames that shared a context
would share a slot counter. *) 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 = let invented_ctx env ret =
{ env; ret; slots = 0; slot_tys = []; slot_names = []; scope = []; { 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; 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 (* 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 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. *) 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 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 let place = ctx.place_ok in
ctx.place_ok <- false; ctx.place_ok <- false;
let r = check_value ctx ?want e in 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 want = Option.map (resolve ctx.env) b.Ast.bty in
let v = check ctx ?want b.Ast.bval in let v = check ctx ?want b.Ast.bval in
(match v.Tast.ty with (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 -> | Types.Unit | Types.Never ->
fail b.Ast.bloc "%s would be bound to %s, which is not a value" fail b.Ast.bloc "%s would be bound to %s, which is not a value"
b.Ast.bname (Types.to_string v.Tast.ty) b.Ast.bname (Types.to_string v.Tast.ty)
@ -5678,6 +5792,9 @@ and check_loop ctx ?want loc bs body =
(fun (n, v) -> (fun (n, v) ->
let v = check ctx v in let v = check ctx v in
(match v.Tast.ty with (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 -> | Types.Unit | Types.Never ->
fail v.Tast.loc "%s would be bound to %s, which is not a value" n fail v.Tast.loc "%s would be bound to %s, which is not a value" n
(Types.to_string v.Tast.ty) (Types.to_string v.Tast.ty)
@ -5851,7 +5968,10 @@ and check_recur ctx ~tail loc args =
accident. *) accident. *)
and check_truthy ctx c = and check_truthy ctx c =
let loc = c.Ast.loc in 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 -> | c0 when c0.Tast.ty = Types.Dyn ->
widen loc Types.Bool (rt loc (Types.Int Types.I32) "flan_dyn_truthy" [ c0 ]) 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 | 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 Anything more complicated than a name gets the operator and no
template: a reconstructed expression would be a guess at code the template: a reconstructed expression would be a guess at code the
reader can see for themselves. *) 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 | c1 -> c1
| exception Loc.Error d when not (String.equal d.Loc.kind "check/type-mismatch") -> | 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 _ -> | exception Loc.Error _ ->
let how = let how =
let zero = match c0.Tast.ty with Types.Float _ -> "0.0" | _ -> "0" in 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 | _, true -> Printf.sprintf " — test it against %s with !=" zero
| _ -> "" | _ -> ""
in in
Loc.failk "check/condition-not-bool" loc (try
"a condition is a bool or a dyn, and this is %s%s" Loc.failk "check/condition-not-bool" loc
(Types.to_string c0.Tast.ty) how) "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 | exception Loc.Error _ -> check ctx ~want:Types.Bool c
and check_if ctx ?(tail = false) ?want loc c t e = 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 location; and with an expectation in hand both arms are checked against
it rather than against each other, so nothing here runs. *) it rather than against each other, so nothing here runs. *)
let e = 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 | v -> v
| exception Loc.Error d | exception Loc.Error d
when want = None && and_sentinel e when reworded && String.equal d.Loc.kind "check/type-mismatch" ->
&& String.equal d.Loc.kind "check/type-mismatch" -> (try
Loc.failk "check/shortcircuit-operand" t.Tast.loc Loc.failk "check/shortcircuit-operand" t.Tast.loc
"an and answers false or its last operand, so the two have to be \ "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" one type — this operand is %s, and false is a bool"
(Types.to_string t.Tast.ty) (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 in
let t, e = let t, e =
match free_join, Types.const_join t.Tast.ty e.Tast.ty with 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 = let fields =
map2_lr map2_lr
(fun (f : Tast.field) (a : Ast.expr) -> (fun (f : Tast.field) (a : Ast.expr) ->
ctx.env.guard_next <- true;
try check ctx ~want:f.Tast.fty a with try check ctx ~want:f.Tast.fty a with
| Loc.Error d when d.Loc.dloc = a.Ast.loc -> | Loc.Error d when d.Loc.dloc = a.Ast.loc ->
Loc.raise_diag refuse_or_poison ctx.env a.Ast.loc
{ d with (Loc.sort_notes
Loc.notes = { d with
d.Loc.notes Loc.notes =
@ [ Loc.note a.Ast.loc d.Loc.notes
(Printf.sprintf "this is %s's field .%s" name @ [ Loc.note a.Ast.loc
f.Tast.fname) ] (Printf.sprintf "this is %s's field .%s" name
@ note }) f.Tast.fname) ]
@ note })
| Loc.Error d -> refuse_or_poison ctx.env a.Ast.loc d)
fields args fields args
in in
expect ctx loc ~want (mk loc (Types.Named name) (Tast.Make (name, fields))) 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. *) that finds nothing. *)
and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a = and mixed_refusal : 'a. ctx -> Ast.expr list -> Loc.diag -> 'a =
fun ctx items d -> fun ctx items d ->
(* Every check here only looks for a better sentence for [d]. *)
speculate ctx.env @@ fun () ->
match items with match items with
| [] -> raise (Loc.Error d) | [] -> raise (Loc.Error d)
| first :: rest -> | 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" dyn — a dyn becomes a %s where a %s is passed, returned or stored"
tn tn tn tn tn tn
| None -> | None ->
(match check ctx ~want:ty v with (match speculate ctx.env (fun () -> check ctx ~want:ty v) with
| _ -> | _ ->
fail v.Ast.loc fail v.Ast.loc
"the checks a value as %s and does not convert one, and this is \ "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 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. *) 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) = and check_arg ctx name i (want : Types.t) (a : Ast.expr) =
ctx.env.guard_next <- true;
match check ctx ~want a with match check ctx ~want a with
| e -> e | e -> e
| exception Loc.Error d | 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)) ] name which p.Ast.fname (Types.to_string want)) ]
| _ -> [] | _ -> []
in in
Loc.raise_diag refuse_or_poison ctx.env a.Ast.loc
(Loc.diag ~kind:"check/argument-type" ~notes 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)) (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 = and fields_named env n : Tast.structure option =
match Hashtbl.find_opt env.structs n with 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 env.tvpreds <- saved_preds; env.chain <- saved_chain
in in
let tfn = 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 | tfn -> restore (); tfn
| exception e -> | exception e ->
restore (); restore ();
@ -11408,7 +11548,7 @@ and trial ctx f =
outer_what; caught; place_ok; envslot; parent = _; outer_what; caught; place_ok; envslot; parent = _;
in_frames; loops; tail; in_defer; in_frames; loops; tail; in_defer;
owner = _ } = ctx in owner = _ } = ctx in
match f () with match speculate ctx.env f with
| r -> Ok r | r -> Ok r
| exception Loc.Error d -> | exception Loc.Error d ->
ctx.slots <- slots; ctx.slot_tys <- slot_tys; ctx.slots <- slots; ctx.slot_tys <- slot_tys;
@ -12488,7 +12628,7 @@ let collect env (decls : Ast.decl list) =
let left = let left =
List.filter List.filter
(fun ((n, _) as c) -> (fun ((n, _) as c) ->
match infer c with match speculate env (fun () -> infer c) with
| ty -> Hashtbl.replace env.globals n (ty, true); false | ty -> Hashtbl.replace env.globals n (ty, true); false
| exception Loc.Error _ -> true) | exception Loc.Error _ -> true)
!pending !pending
@ -13854,7 +13994,7 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
in in
(match f () with (match f () with
| x -> x | x -> x
| exception (Loc.Error d as e) -> | exception ((Loc.Error d | Loc.Errors (d :: _)) as e) ->
if ok env name d then begin if ok env name d then begin
Hashtbl.filter_map_inplace Hashtbl.filter_map_inplace
(fun g r -> (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 -> | Ast.Defn fn when Hashtbl.mem env.gsigs fn.Ast.name ->
ignore ignore
(Loc.caught s (fun () -> (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; decls;
let globals = let globals =
@ -13943,9 +14085,12 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
(fun (d : Ast.decl) -> (fun (d : Ast.decl) ->
Option.join Option.join
(Loc.caught s (fun () -> (Loc.caught s (fun () ->
let checked () =
with_recovery env ~on:keep_going (fun () -> check_global env d)
in
match Ast.declared_name d with match Ast.declared_name d with
| Some n -> tolerant n (fun () -> check_global env d) | Some n -> tolerant n checked
| None -> check_global env d))) | None -> checked ())))
decls decls
in in
let fns = let fns =
@ -13958,7 +14103,9 @@ let build_program ~keep_going ?tolerate (decls : Ast.decl list) :
| Ast.Defn fn -> | Ast.Defn fn ->
Option.join Option.join
(Loc.caught s (fun () -> (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) | _ -> None)
decls decls
in 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 (** The same, with [tolerate] deciding which body failures leave a
declaration out rather than refuse it — see [build_program]. The names declaration out rather than refuse it — see [build_program]. The names
left out come back beside the program; nothing else about it changes. *) left out come back beside the program; nothing else about it changes. *)
let program_tolerant ~tolerate (decls : Ast.decl list) = let program_tolerant ?(keep_going = false) ~tolerate (decls : Ast.decl list) =
build_program ~keep_going:false ~tolerate decls build_program ~keep_going ~tolerate decls
let program (decls : Ast.decl list) : Tast.program = let program (decls : Ast.decl list) : Tast.program =
let p, _, _ = build_program ~keep_going:false decls in 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), (ts, Array.of_list (List.rev ctx.slot_tys),
Array.of_list (List.rev ctx.slot_names)) 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. *) (* The one-expression case, which is every caller but the write verb. *)
let expression env ?want (e : Ast.expr) : let expression env ?want (e : Ast.expr) :
Tast.expr * Types.t array * string option array = Tast.expr * Types.t array * string option array =

View File

@ -997,6 +997,31 @@ let stale_field (ss : Session.stale list) =
(if x.Session.running then " :running t" else "")) (if x.Session.running then " :running t" else ""))
ss) ] 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 eval ?forms ?base ?(extra = []) t ~code ~origin ~pause =
let now = liveness t in let now = liveness t in
let parked_now = now = Parked 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; _ } -> | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
Session.restore t.session before; Session.restore t.session before;
error ~loc:(Loc.to_string l) msg error ~loc:(Loc.to_string l) msg
| exception Loc.Errors ds ->
(* The refusals a load answered beside what it installed, one plist each. *) Session.restore t.session before;
let errors_field (ds : Loc.diag list) = errors_reply ds
match ds with
| [] -> []
| ds ->
[ ":errors "
^ Wire.list
(List.map
(fun (d : Loc.diag) ->
Printf.sprintf "(:loc %s :message %s)"
(Wire.quote (Loc.to_string d.Loc.dloc))
(Wire.quote d.Loc.dmsg))
ds) ]
(* C-c C-k: a whole file into the running session, SBCL's [load]. [eval] with (* 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 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 (match Session.pruned check forms with
| exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } -> | exception Loc.Error { Loc.dloc = l; dmsg = msg; _ } ->
error ~loc:(Loc.to_string l) msg error ~loc:(Loc.to_string l) msg
| exception Loc.Errors ({ Loc.dloc = l; dmsg = msg; _ } :: _ as ds) -> | exception Loc.Errors ds -> errors_reply ds
let e = error ~loc:(Loc.to_string l) msg in
String.sub e 0 (String.length e - 1)
^ " " ^ String.concat " " (errors_field ds) ^ ")"
| (), kept, errs -> | (), kept, errs ->
if errs <> [] && kept = [] then if errs <> [] && kept = [] then errors_reply errs
let d = List.hd errs in
let e = error ~loc:(Loc.to_string d.Loc.dloc) d.Loc.dmsg in
String.sub e 0 (String.length e - 1)
^ " " ^ String.concat " " (errors_field errs) ^ ")"
else else
eval ~forms:kept ?base ~extra:(errors_field errs) t ~code ~origin eval ~forms:kept ?base ~extra:(errors_field errs) t ~code ~origin
~pause:None) ~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 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 the race is documented as the programmer's problem. There is no race to
document here, because there is nothing running to race. *) 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 match liveness t with
| Gone -> error gone | Gone -> error gone
| Live | Parked -> | Live | Parked ->
@ -1209,7 +1216,7 @@ let eval_expr t ~code ~origin ~pause =
let had = let had =
List.map (fun (f : Tast.fn) -> f.Tast.name) t.session.Session.program.Tast.fns List.map (fun (f : Tast.fn) -> f.Tast.name) t.session.Session.program.Tast.fns
in 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 -> | c ->
let before = match result t with Some (g, _) -> g | None -> 0L in let before = match result t with Some (g, _) -> g | None -> 0L in
(* Read here, beside [before], and for the same kind of reason: all (* Read here, beside [before], and for the same kind of reason: all
@ -1256,7 +1263,14 @@ let eval_expr t ~code ~origin ~pause =
in in
(match build_module c ~debug:t.session.Session.debug ~out with (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" -> | "ok" ->
if copies <> [] then begin if copies <> [] then begin
t.gen <- t.gen + 1; t.gen <- t.gen + 1;
@ -2406,6 +2420,30 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
name name) name name)
else Ok (name, fn))) 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. (* [(: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 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 { Form.v = Form.Sym "nil"; _ } | None -> false
| Some _ -> true | Some _ -> true
in 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") | None -> error "eval-expr needs :code")
(* [:all], absent or [nil] being false and anything else true — the spelling (* [:all], absent or [nil] being false and anything else true — the spelling
[:pause], [:on] and [:reset] already use. One step is the default because [:pause], [:on] and [:reset] already use. One step is the default because

View File

@ -205,6 +205,7 @@ let caught s f =
match f () with match f () with
| x -> Some x | x -> Some x
| exception Error d -> s.found <- d :: s.found; None | 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 (** Raise everything found, in the order it was found, or return if the pass
was clean. *) was clean. *)

View File

@ -968,8 +968,13 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(running = true) t src : chan
&& List.exists stale_site b.sites) && List.exists stale_site b.sites)
t.built t.built
in 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 = 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 in
let program = let program =
if tolerated = [] then program if tolerated = [] then program
@ -2507,7 +2512,68 @@ let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
sticks — a thunk is built and thrown away, so the mark lasts exactly one 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 evaluation, which is the truthful thing for an expression that has no
declaration to live in. *) declaration to live in. *)
let eval_expr ?(origin = "<eval>") ?(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 = "<eval>") ?(pause = false) ?frame t src : change =
let form = let form =
match Reader.read_all ~file:origin src with match Reader.read_all ~file:origin src with
| [ f ] -> f | [ f ] -> f
@ -2556,7 +2622,11 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) t src : change =
and the host has no cell for. *) and the host has no cell for. *)
let mark = Check.instance_mark t.env in let mark = Check.instance_mark t.env in
let lmark = Check.lifted_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 fresh = Check.instances_since t.env mark in
let lifted = Check.lifted_since t.env lmark in let lifted = Check.lifted_since t.env lmark in
(* The thunk's frame starts at whatever [Check.expression] needed and grows (* The thunk's frame starts at whatever [Check.expression] needed and grows

View File

@ -506,6 +506,65 @@ and walk_place f (p : place) =
| Pfield (t, _) | Pderef t -> walk f t | Pfield (t, _) | Pderef t -> walk f t
| Pindex (t, idx) -> walk f t; List.iter (walk f) idx | 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 ─────────────────────────────────── *) (* ── What the object image can hold ─────────────────────────────────── *)
(* Whether an initialiser is a value a linker can write into the program's (* Whether an initialiser is a value a linker can write into the program's

View File

@ -127,6 +127,51 @@ let status r =
let contains_sub = Test_support.contains 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 ─────────────── *) (* ── The one verb whose reply races the process it ends ─────────────── *)
(* [abort] is answered twice over, and the two answers are not ordered. On the (* [abort] is answered twice over, and the two answers are not ordered. On the
@ -2284,6 +2329,7 @@ let () =
(String.concat ", " (String.concat ", "
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused"))) (List.map (fun (n, w, _) -> n ^ ": " ^ w) (pairs r "refused")))
end; end;
eval_in_frame_checks ~backend:"llvm" ask;
(* A frame whose every slot the compiler invented is not an error and (* A frame whose every slot the compiler invented is not an error and
is not an empty answer either: it says which it is. *) is not an empty answer either: it says which it is. *)
let r = ask "(:op \"locals\" :frame 1)" in let r = ask "(:op \"locals\" :frame 1)" in
@ -6141,6 +6187,7 @@ let () =
(String.concat ", " (String.concat ", "
(List.map (fun (n, w, _) -> n ^ ": " ^ w) (triples r "refused"))) (List.map (fun (n, w, _) -> n ^ ": " ^ w) (triples r "refused")))
end; end;
eval_in_frame_checks ~backend:"x86" (request c);
(* One slot by index, which is the inspector's own root rather than (* 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 [locals]' listing, and an aggregate for it: an x86 frame passes every
aggregate by pointer, so a struct is where a recorded address could aggregate by pointer, so a struct is where a recorded address could

View File

@ -1764,4 +1764,42 @@ let () =
| _ -> fail "a package's bare name resolved from the program's own file" | _ -> fail "a package's bare name resolved from the program's own file"
| exception Loc.Error _ -> ()); | 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" () Test_support.report ~label:"session" ()