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
|
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=.
|
||||||
|
|||||||
@ -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)
|
||||||
|
|||||||
@ -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.
|
||||||
|
;;
|
||||||
|
;; 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)
|
(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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
206
lib/check.ml
206
lib/check.ml
@ -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
|
||||||
|
(try
|
||||||
Loc.failk "check/condition-not-bool" loc
|
Loc.failk "check/condition-not-bool" loc
|
||||||
"a condition is a bool or a dyn, and this is %s%s"
|
"a condition is a bool or a dyn, and this is %s%s"
|
||||||
(Types.to_string c0.Tast.ty) how)
|
(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,9 +6203,11 @@ 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
|
||||||
|
(Loc.sort_notes
|
||||||
{ d with
|
{ d with
|
||||||
Loc.notes =
|
Loc.notes =
|
||||||
d.Loc.notes
|
d.Loc.notes
|
||||||
@ -6082,6 +6215,7 @@ and positional_struct ctx ~want loc name args =
|
|||||||
(Printf.sprintf "this is %s's field .%s" name
|
(Printf.sprintf "this is %s's field .%s" name
|
||||||
f.Tast.fname) ]
|
f.Tast.fname) ]
|
||||||
@ note })
|
@ 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 =
|
||||||
|
|||||||
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 ""))
|
(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
|
||||||
|
|||||||
@ -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. *)
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
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
|
| 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
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
@ -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" ()
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user