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:
parent
8dc90416d4
commit
da9f21ddcd
16
TODO.org
16
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 =<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
|
||||
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=.
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
232
lib/check.ml
232
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 =
|
||||
|
||||
92
lib/dev.ml
92
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
|
||||
|
||||
@ -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. *)
|
||||
|
||||
@ -968,8 +968,13 @@ let eval ?(origin = "<eval>") ?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 = "<globals>") 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 = "<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 =
|
||||
match Reader.read_all ~file:origin src with
|
||||
| [ f ] -> f
|
||||
@ -2556,7 +2622,11 @@ let eval_expr ?(origin = "<eval>") ?(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
|
||||
|
||||
59
lib/tast.ml
59
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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" ()
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user