A restart that takes values can be taken from the break loop, which asks for one per parameter and stores them into the frame as an invoke-restart would
This commit is contained in:
parent
23b144178a
commit
1fb4b37125
@ -385,6 +385,7 @@ indexing or the division itself, so it sits directly under the headline."
|
||||
(add-text-properties start (point)
|
||||
(list 'flan-cnr-restart name
|
||||
'flan-cnr-restart-loc at
|
||||
'flan-cnr-params params
|
||||
'flan-cnr-shadowed owner
|
||||
'flan-cnr-kind kind
|
||||
'flan-cnr-index i
|
||||
@ -612,8 +613,10 @@ puts the likely culprit on top."
|
||||
"flan: restart %d is below the evaluation this break is inside, so a transfer to it has nowhere to land. Take one offered above it, or abandon the evaluation"
|
||||
(get-text-property (point) 'flan-cnr-index)))
|
||||
((get-text-property (point) 'flan-cnr-restart)
|
||||
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-index)
|
||||
(get-text-property (point) 'flan-cnr-restart)))
|
||||
(let ((name (get-text-property (point) 'flan-cnr-restart)))
|
||||
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-index) name
|
||||
(flan-cnr--read-args
|
||||
name (get-text-property (point) 'flan-cnr-params)))))
|
||||
((get-text-property (point) 'flan-cnr-hidden) (flan-cnr-toggle-prelude))
|
||||
((or (get-text-property (point) 'flan-cnr-frame)
|
||||
(get-text-property (point) 'flan-cnr-loc))
|
||||
@ -698,15 +701,41 @@ visits the source of the one it lands on."
|
||||
(when (eq next-error-last-buffer (current-buffer))
|
||||
(setq next-error-last-buffer nil)))
|
||||
|
||||
(defun flan-cnr--invoke (index name)
|
||||
"Take restart INDEX, named NAME.
|
||||
(defun flan-cnr-param-types (params)
|
||||
"The types in PARAMS, a restart's parameters as the program spells them.
|
||||
PARAMS is a parenthesised list such as \"(i64 (Option string))\"; the result
|
||||
is one string per type, or nil when it takes none or cannot be read."
|
||||
(let ((form (and (stringp params)
|
||||
(condition-case nil (car (read-from-string params))
|
||||
(error nil)))))
|
||||
(when (listp form)
|
||||
(mapcar (lambda (ty) (format "%S" ty)) form))))
|
||||
|
||||
(defun flan-cnr--read-args (name params)
|
||||
"One value for each of restart NAME's PARAMS, read in the minibuffer.
|
||||
Each is Flan source, checked by the daemon against its parameter's type, as an
|
||||
`invoke-restart' passing it would have been. Nil when it takes none."
|
||||
(let* ((types (flan-cnr-param-types params))
|
||||
(n (length types))
|
||||
(i 0))
|
||||
(mapcar (lambda (ty)
|
||||
(setq i (1+ i))
|
||||
(read-string (if (= n 1)
|
||||
(format "%s, a value of type %s: " name ty)
|
||||
(format "%s, value %d of %d, of type %s: " name i n ty))))
|
||||
types)))
|
||||
|
||||
(defun flan-cnr--invoke (index name &optional args)
|
||||
"Take restart INDEX, named NAME, passing ARGS when it takes values.
|
||||
ARGS is one Flan expression per parameter, as strings.
|
||||
By index, because the index is the identity — two frames can offer `retry'
|
||||
and only one of them is the one on this line. The name rides along as a
|
||||
receipt: the daemon checks it against what the program has at that index and
|
||||
refuses if the two have drifted apart, so a stale buffer cannot take a
|
||||
different restart than the one it showed."
|
||||
(let ((r (funcall flan-cnr-request-function
|
||||
(list :op "restart-at" :index index :name name))))
|
||||
(append (list :op "restart-at" :index index :name name)
|
||||
(and args (list :args args))))))
|
||||
(if (equal (plist-get r :status) "ok")
|
||||
;; Accepted, not resumed — the choice is validated against the stopped
|
||||
;; stack and taken when that thread next comes round its loop. So the
|
||||
|
||||
@ -378,6 +378,7 @@ open, above its prompt, which is where whoever is typing there is looking."
|
||||
;; so requiring it here would be a cycle, and it is wanted only at the moment
|
||||
;; a program stops.
|
||||
(autoload 'flan-cnr-show "flan-cnr" nil t)
|
||||
(autoload 'flan-cnr--read-args "flan-cnr")
|
||||
|
||||
;;; Opening the break buffer when the program stops
|
||||
|
||||
@ -1161,12 +1162,14 @@ identity: two entries may read the same and mean different frames."
|
||||
i))
|
||||
restarts)))
|
||||
|
||||
(defun flan-restart-at (index name)
|
||||
(defun flan-restart-at (index name &optional args)
|
||||
"Resume the stopped program at the restart at position INDEX.
|
||||
NAME is sent with it and is not the lookup: the program checks it against
|
||||
the name it holds at that position and refuses if the two have drifted
|
||||
apart, so a prompt cannot take a different restart than the one it showed."
|
||||
(let ((r (flan--request (list :op "restart-at" :index index :name name))))
|
||||
apart, so a prompt cannot take a different restart than the one it showed.
|
||||
ARGS is one Flan expression per parameter, for a restart that takes values."
|
||||
(let ((r (flan--request (append (list :op "restart-at" :index index :name name)
|
||||
(and args (list :args args))))))
|
||||
(if (equal (plist-get r :status) "ok")
|
||||
(progn
|
||||
;; Accepted, not resumed — see `flan-restart'.
|
||||
@ -1285,7 +1288,12 @@ than being told so."
|
||||
;; not something a person can type — but deriving the table wrongly
|
||||
;; should say so rather than put nil on the wire as an index.
|
||||
((null index) (user-error "flan: %s is not on the list" choice))
|
||||
(t (flan-restart-at index (nth index restarts)))))))
|
||||
(t (let ((name (nth index restarts)))
|
||||
;; A restart that takes values asks for them, one per parameter.
|
||||
(flan-restart-at
|
||||
index name
|
||||
(flan-cnr--read-args
|
||||
name (plist-get (nth index (plist-get r :details)) :params)))))))))
|
||||
|
||||
(defun flan-describe ()
|
||||
"Report what the running program currently defines."
|
||||
|
||||
@ -1097,6 +1097,28 @@ would be overwritten. Look again and re-do the edit")
|
||||
(test-flan--check "v on a restart visits its clause"
|
||||
(equal visited '("/src/files.flan:12:3" "restart use-value")))))
|
||||
|
||||
;; A restart that takes values asks for one per parameter and sends them.
|
||||
(test-flan--check "a restart's parameter types are read from their spelling"
|
||||
(equal (flan-cnr-param-types "(i64 (Option string))")
|
||||
'("i64" "(Option string)")))
|
||||
(let ((sent nil) (asked nil))
|
||||
(let ((flan-cnr-request-function
|
||||
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
|
||||
(cl-letf (((symbol-function 'read-string)
|
||||
(lambda (prompt &rest _) (push prompt asked) "(+ 40 2)")))
|
||||
(with-current-buffer
|
||||
(test-flan--cnr
|
||||
(list :condition "ArithError" :restarts '("use-value")
|
||||
:details '((:report "" :at nil :arity 1 :params "(i64)"))))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 0: ")
|
||||
(save-window-excursion (flan-cnr-take)))))
|
||||
(test-flan--check "taking a typed restart asks for its value by type"
|
||||
(equal asked '("use-value, a value of type i64: ")))
|
||||
(test-flan--check "and sends it as :args"
|
||||
(equal sent '(:op "restart-at" :index 0 :name "use-value"
|
||||
:args ("(+ 40 2)")))))
|
||||
|
||||
;; A stopped program with nothing on offer between the error and the top. It
|
||||
;; is a real state — spec-conditions §2's `error' with no `restart-case' above
|
||||
;; it — and it must not look like a bug in the buffer.
|
||||
|
||||
76
lib/dev.ml
76
lib/dev.ml
@ -3209,7 +3209,55 @@ let accepted reply =
|
||||
| "ok abandon" -> Some true
|
||||
| _ -> None
|
||||
|
||||
let choose_at t ~index ~name =
|
||||
(* A restart that takes values gets them before it is taken: [:args] is one
|
||||
expression per parameter, which [Session.arm_restart] checks against the
|
||||
parameter's own type and a thunk stores into the frame's buffer, as an
|
||||
[invoke-restart] would have. Only then is the choice sent, and the agent
|
||||
refuses a restart that takes values and was not given them. [Ok ""] when
|
||||
nothing was given, without a round trip: most restarts take nothing, and
|
||||
the agent says so when one that takes values was sent none. *)
|
||||
let arm_restart t ~index ~name ~args =
|
||||
if args = [] then Ok "" else
|
||||
match restarts t with
|
||||
| Error m -> Error ("the program refused to list its restarts: " ^ m)
|
||||
| Ok (rows, _) ->
|
||||
(match List.find_opt (fun r -> r.ridx = index) rows with
|
||||
| None -> Error "there is no restart at that index; list the restarts again"
|
||||
| Some r ->
|
||||
(match name with
|
||||
| Some n when not (String.equal n r.rname) ->
|
||||
Error
|
||||
("that index is now " ^ r.rname
|
||||
^ ", not what you named; list the restarts again")
|
||||
| _ ->
|
||||
let given = List.length args in
|
||||
if given <> r.rarity then
|
||||
Error
|
||||
(Printf.sprintf "restart %s takes %s, %d %s, and was given %d"
|
||||
r.rname r.rsig r.rarity
|
||||
(if r.rarity = 1 then "value" else "values")
|
||||
given)
|
||||
else
|
||||
(match Session.restart_params t.session r.rsig with
|
||||
| Error m -> Error m
|
||||
| Ok params ->
|
||||
(match stop_gen t with
|
||||
| None | Some 0 ->
|
||||
Error "the program resumed while this was being asked"
|
||||
| Some gen ->
|
||||
let held = Session.held t.session in
|
||||
let refused m = Session.restore t.session held; Error m in
|
||||
(match
|
||||
Session.arm_restart t.session ~index ~params ~codes:args
|
||||
with
|
||||
| exception Loc.Error { Loc.dmsg = why; _ } -> refused why
|
||||
| Error why -> refused why
|
||||
| Ok (c, _) ->
|
||||
(match run_render_thunk ~at_stop:gen t ~tag:"r" ~c with
|
||||
| Error m -> refused m
|
||||
| Ok v -> Ok v))))))
|
||||
|
||||
let choose_at ?(args = []) t ~index ~name =
|
||||
match liveness t with
|
||||
| Gone -> error gone
|
||||
| Parked when not (parked_break t) ->
|
||||
@ -3229,6 +3277,9 @@ let choose_at t ~index ~name =
|
||||
| None -> false
|
||||
then error "a restart name cannot contain a control character"
|
||||
else
|
||||
match arm_restart t ~index ~name ~args with
|
||||
| Error m -> error m
|
||||
| Ok given ->
|
||||
let verb =
|
||||
"restart-at " ^ string_of_int index
|
||||
^ match name with Some n -> " " ^ n | None -> ""
|
||||
@ -3236,9 +3287,12 @@ let choose_at t ~index ~name =
|
||||
match ask t verb with
|
||||
| reply when accepted reply <> None ->
|
||||
ok
|
||||
[ ":index " ^ string_of_int index;
|
||||
":note "
|
||||
^ taken_note ~abandoned:(accepted reply = Some true) ]
|
||||
([ ":index " ^ string_of_int index;
|
||||
":note "
|
||||
^ taken_note ~abandoned:(accepted reply = Some true) ]
|
||||
(* The values the clause will bind, as the program now holds them. *)
|
||||
@ (if given = "" then []
|
||||
else [ ":values " ^ Wire.strings (String.split_on_char '\n' given) ]))
|
||||
| reply -> error (String.trim reply)
|
||||
| exception Unix.Unix_error (e, _, _) ->
|
||||
error (unreachable t e)
|
||||
@ -4191,7 +4245,19 @@ let handle t req =
|
||||
showed. *)
|
||||
| Some "restart-at" ->
|
||||
(match Wire.int_field req "index" with
|
||||
| Some index -> choose_at t ~index ~name:(Wire.string_field req "name")
|
||||
| Some index ->
|
||||
(* [:args] is one expression per parameter, for a restart that takes
|
||||
values; see [arm_restart]. *)
|
||||
let args =
|
||||
match Wire.field req "args" with
|
||||
| Some { Form.v = Form.List l; _ } ->
|
||||
List.filter_map
|
||||
(fun (f : Form.t) ->
|
||||
match f.Form.v with Form.Str s -> Some s | _ -> None)
|
||||
l
|
||||
| _ -> []
|
||||
in
|
||||
choose_at ~args t ~index ~name:(Wire.string_field req "name")
|
||||
| None -> error "restart-at needs :index")
|
||||
| Some "abort" -> abort t
|
||||
(* No fields: the only thing it could take is which function to run, and the
|
||||
|
||||
130
lib/session.ml
130
lib/session.ml
@ -1104,6 +1104,15 @@ let externs : Tast.extern list =
|
||||
{ Tast.ename = "flan/dev-cond"; esym = "flan_agent_condition";
|
||||
eparams = []; eret = Types.Ptr (Types.Int Types.U8);
|
||||
eloc = Loc.unknown };
|
||||
(* A typed restart's parameter, by the restart's index in the snapshot on
|
||||
top and a byte offset into its buffer, and the flag that says the
|
||||
buffer was written. See [arm_restart]. *)
|
||||
{ Tast.ename = "flan/dev-restart-arg"; esym = "flan_agent_restart_arg";
|
||||
eparams = [ Types.Int Types.I64; Types.Int Types.I64 ];
|
||||
eret = Types.Ptr (Types.Int Types.U8); eloc = Loc.unknown };
|
||||
{ Tast.ename = "flan/dev-restart-arm"; esym = "flan_agent_restart_arm";
|
||||
eparams = [ Types.Int Types.I64 ]; eret = Types.Unit;
|
||||
eloc = Loc.unknown };
|
||||
(* The character beside a rendered byte. See [Render.pointers]. *)
|
||||
{ Tast.ename = "flan/dev-emit-u8-char"; esym = "flan_dev_emit_u8_char";
|
||||
eparams = [ Types.Int Types.I64 ]; eret = Types.Unit;
|
||||
@ -2019,6 +2028,127 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
|
||||
({ ir; x86 = t.x86; names = []; fns = []; installs = true },
|
||||
where, Types.to_string shown.Tast.ty))))
|
||||
|
||||
(* ── A typed restart, taken from the break loop ──────────────────────── *)
|
||||
|
||||
(* The types a restart takes, read back from how its frame spells them —
|
||||
[Check.restart_sig], a parenthesised list of [Types.to_string]s, which the
|
||||
reader reads as one list of type forms. *)
|
||||
let restart_params t sg =
|
||||
match Reader.read_all ~file:"<restart>" sg with
|
||||
| [ { Form.v = Form.List forms; _ } ] ->
|
||||
(match List.map (fun f -> Check.resolve t.env (Parse.texpr f)) forms with
|
||||
| tys -> Ok tys
|
||||
| exception Loc.Error { Loc.dmsg = why; _ } ->
|
||||
Error ("the restart takes " ^ sg ^ ", and " ^ why))
|
||||
| _ -> Error ("the restart's parameters are spelled " ^ sg ^ ", which is not a list of types")
|
||||
|
||||
(* What [invoke-restart] does to a frame before it aims the channel, done by a
|
||||
thunk instead: each value, checked against the parameter's own type, stored
|
||||
at its offset in the buffer the frame owns, and the flag set that says the
|
||||
buffer was written. The offsets are [Emit.lay_fields] over the parameter
|
||||
types, which is how both backends lay out that buffer and how the invoker
|
||||
and the clause agree on it.
|
||||
|
||||
The values are expressions, checked in the session like any evaluated one,
|
||||
so the refusal for a value that does not fit is the checker's own sentence.
|
||||
The thunk renders the stored values back, which is what the program holds
|
||||
now rather than what was asked for. *)
|
||||
let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
|
||||
~(codes : string list) : (change * string list, string) result =
|
||||
let loc = Loc.unknown in
|
||||
let md = X86.layout_ctx ~checks:false ~dev:true t.program in
|
||||
let _, _, offs = Emit.lay_fields md params in
|
||||
let mark = Check.instance_mark t.env in
|
||||
let wanted =
|
||||
List.map2
|
||||
(fun ty code ->
|
||||
let form =
|
||||
match Reader.read_all ~file:origin code with
|
||||
| [ f ] -> f
|
||||
| [] -> fail loc "a value for a %s is empty" (Types.to_string ty)
|
||||
| _ :: f :: _ -> fail f.Form.loc "one value for each parameter"
|
||||
in
|
||||
(Some ty, Parse.with_imported t.macros (fun () -> Parse.expr form)))
|
||||
params codes
|
||||
in
|
||||
let values, base, bnames = Check.expressions t.env wanted in
|
||||
let fresh = Check.instances_since t.env mark in
|
||||
let i64 n =
|
||||
{ Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64; loc }
|
||||
in
|
||||
let at ty off =
|
||||
let raw =
|
||||
{ Tast.e = Tast.Call ("flan/dev-restart-arg", [ i64 index; i64 off ]);
|
||||
ty = Types.Ptr (Types.Int Types.U8); loc }
|
||||
in
|
||||
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr ty), [ raw ]); ty = Types.Ptr ty; loc }
|
||||
in
|
||||
let stores =
|
||||
List.map2
|
||||
(fun (ty, off) (v : Tast.expr) ->
|
||||
{ Tast.e = Tast.Set (Tast.Pderef (at ty off), v); ty = Types.Unit; loc })
|
||||
(List.combine params offs) values
|
||||
in
|
||||
let arm =
|
||||
{ Tast.e = Tast.Call ("flan/dev-restart-arm", [ i64 index ]); ty = Types.Unit; loc }
|
||||
in
|
||||
let extra = ref [] and nslots = ref (Array.length base) in
|
||||
let c =
|
||||
{ Render.structs = t.program.Tast.structs;
|
||||
datas = t.program.Tast.datas;
|
||||
unions = t.program.Tast.unions;
|
||||
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
|
||||
emit = dev_emitter;
|
||||
ptrs = Some dev_pointers;
|
||||
alloc = (fun ty ->
|
||||
let i = !nslots in
|
||||
incr nslots;
|
||||
extra := ty :: !extra;
|
||||
i) }
|
||||
in
|
||||
let bytes_of str =
|
||||
{ Tast.e =
|
||||
Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]);
|
||||
ty = Types.Slice (Types.Int Types.U8); loc }
|
||||
in
|
||||
let lit str = c.Render.emit.Render.ebytes (bytes_of str) in
|
||||
match
|
||||
List.concat
|
||||
(List.map2
|
||||
(fun (ty, off) k ->
|
||||
(if k > 0 then [ lit "\n" ] else [])
|
||||
@ Render.render c 0 { Tast.e = Tast.Deref (at ty off); ty; loc })
|
||||
(List.combine params offs)
|
||||
(List.init (List.length params) Fun.id))
|
||||
with
|
||||
| exception Loc.Error { Loc.dmsg = why; _ } -> Error why
|
||||
| shown ->
|
||||
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
|
||||
t.thunks <- t.thunks + 1;
|
||||
let tname = Printf.sprintf "restart/%d" t.thunks in
|
||||
let thunk : Tast.fn =
|
||||
{ Tast.name = tname; params = []; ret = Types.Unit;
|
||||
body =
|
||||
stores @ [ arm ] @ (nullary "flan/dev-begin" :: shown)
|
||||
@ [ nullary "flan/dev-end" ];
|
||||
fdefers = []; fenv = None; fparent = None; floc = loc;
|
||||
slots = Array.append base (Array.of_list (List.rev !extra));
|
||||
snames = Array.append bnames (Array.make (List.length !extra) None) }
|
||||
in
|
||||
let program =
|
||||
{ t.program with
|
||||
Tast.fns = t.program.Tast.fns @ fresh @ [ thunk ];
|
||||
externs = t.program.Tast.externs @ externs }
|
||||
in
|
||||
let ir =
|
||||
redefinition t ~call:tname program
|
||||
~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ])
|
||||
in
|
||||
t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh };
|
||||
Ok
|
||||
({ ir; x86 = t.x86; names = []; fns = []; installs = true },
|
||||
List.map Types.to_string params)
|
||||
|
||||
(* ── The globals a stopped stack reaches ───────────────────────────── *)
|
||||
|
||||
(* The other half of what a break loop can show, and in this language arguably
|
||||
|
||||
@ -247,6 +247,19 @@ int32_t flan_restart_frame_hidden(const void *frame) {
|
||||
return (((const flan_restart *)frame)->flags & FLAN_RESTART_HIDDEN) != 0;
|
||||
}
|
||||
|
||||
/* The other way a typed restart's buffer is filled: an invoke-restart writes
|
||||
* it and sets [armed], and a break loop taking one by hand has an evaluated
|
||||
* thunk do the same two things through these, before it aims the channel. */
|
||||
void *flan_restart_frame_args(const void *frame) {
|
||||
return ((const flan_restart *)frame)->args;
|
||||
}
|
||||
|
||||
int32_t flan_restart_frame_armed(const void *frame) {
|
||||
return ((const flan_restart *)frame)->armed;
|
||||
}
|
||||
|
||||
void flan_restart_frame_arm(void *frame) { ((flan_restart *)frame)->armed = 1; }
|
||||
|
||||
/* Aim the transfer channel at a frame obtained earlier. The same store an
|
||||
* invoke-restart makes — this only spells it without a lookup, for a caller
|
||||
* that did its looking up when the stack was worth reading. */
|
||||
|
||||
@ -30,10 +30,14 @@
|
||||
;;; the prelude, and the break loop's render now reads them field by field,
|
||||
;;; padding and all. A layout that drifted would show the op in `lhs'.
|
||||
;;; The operands are parameters so nothing constant-folds the division away.
|
||||
;;; And a restart that takes a value, which the break loop has to be given.
|
||||
(defonce got i64)
|
||||
|
||||
(defn divide [a i64 b i64] i64
|
||||
(restart-case
|
||||
(/ a b)
|
||||
(use-zero [] 0)))
|
||||
(use-zero [] 0)
|
||||
(use-value [v i64] :report "Answer v instead" v)))
|
||||
|
||||
(defn main [] i32
|
||||
(agent/start "/tmp/flan-dev-break-fallback.sock")
|
||||
|
||||
@ -977,7 +977,7 @@ let () =
|
||||
if String.length floc = 0 || floc.[0] <> '/' then
|
||||
fail "a frame's location is not absolute: %s" floc;
|
||||
(* And an outer frame is at the call it is in, not at its defn. *)
|
||||
if not (contains_sub mloc "dev-break.flan:40:10") then
|
||||
if not (contains_sub mloc "dev-break.flan:44:10") then
|
||||
fail "main's frame is at %s, not at its call to fetch" mloc
|
||||
| fs ->
|
||||
fail "backtrace of a stopped program: %s"
|
||||
@ -1421,6 +1421,80 @@ let () =
|
||||
fail "the program never resumed past a division by zero"
|
||||
end);
|
||||
|
||||
(* ── A restart that takes a value, taken from the break loop ────────
|
||||
[use-value] takes an i64. The break names what it takes; taking it
|
||||
without a value is refused with that; a value of the wrong type is
|
||||
refused by the checker, in its own words; and a value that fits is
|
||||
stored into the frame's buffer by a thunk and the clause binds it —
|
||||
so [got] is 42 afterwards, a number only the typed value can make. *)
|
||||
(let r =
|
||||
ask
|
||||
"(:op \"eval-expr\" :code \"(set got (divide (i64 5) (i64 0)))\" \
|
||||
:file \"/tmp/buf.flan\")"
|
||||
in
|
||||
if status r <> "error" then
|
||||
fail "a division by zero under use-value answered instead of stopping"
|
||||
else if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
||||
fail "a division by zero under use-value never stopped"
|
||||
else begin
|
||||
let r = ask "(:op \"break\")" in
|
||||
let names =
|
||||
match Wire.field r "restarts" with
|
||||
| Some { Form.v = Form.List l; _ } ->
|
||||
List.filter_map
|
||||
(fun (n : Form.t) ->
|
||||
match n.Form.v with Form.Str x -> Some x | _ -> None)
|
||||
l
|
||||
| _ -> []
|
||||
in
|
||||
let rec index_of i = function
|
||||
| [] -> -1
|
||||
| n :: rest -> if n = "use-value" then i else index_of (i + 1) rest
|
||||
in
|
||||
let i = index_of 0 names in
|
||||
if i < 0 then fail "use-value is not on offer: %s" (String.concat ", " names)
|
||||
else begin
|
||||
(match Wire.field r "details" with
|
||||
| Some { Form.v = Form.List ds; _ } when List.length ds > i ->
|
||||
let d = List.nth ds i in
|
||||
if Wire.string_field d "params" <> Some "(i64)" then
|
||||
fail "use-value's parameters are not on the wire as (i64)"
|
||||
| _ -> fail "break carried no details for use-value");
|
||||
let take args =
|
||||
ask
|
||||
(Printf.sprintf
|
||||
"(:op \"restart-at\" :index %d :name \"use-value\"%s)" i
|
||||
(if args = "" then "" else " :args " ^ args))
|
||||
in
|
||||
let said r = Option.value ~default:"" (Wire.string_field r "message") in
|
||||
let r = take "" in
|
||||
if status r <> "error" || not (contains_sub (said r) "takes (i64)") then
|
||||
fail "use-value taken with no value: %s" (said r);
|
||||
let r = take "(\"1\" \"2\")" in
|
||||
if status r <> "error" || not (contains_sub (said r) "was given 2") then
|
||||
fail "use-value taken with two values: %s" (said r);
|
||||
let r = take "(\"\\\"text\\\"\")" in
|
||||
if status r <> "error" || not (contains_sub (said r) "i64") then
|
||||
fail "use-value taken with a string: %s" (said r);
|
||||
let r = take "(\"(+ 40 2)\")" in
|
||||
if status r <> "ok" then fail "use-value taken with 42: %s" (said r)
|
||||
else begin
|
||||
(match Wire.field r "values" with
|
||||
| Some { Form.v = Form.List [ { Form.v = Form.Str "42"; _ } ]; _ } -> ()
|
||||
| _ -> fail "the reply does not show the value the clause binds");
|
||||
if not (await (fun () -> not (stopped (ask "(:op \"describe\")"))))
|
||||
then fail "the program never resumed through use-value"
|
||||
else
|
||||
let r =
|
||||
ask "(:op \"eval-expr\" :code \"got\" :file \"/tmp/buf.flan\")"
|
||||
in
|
||||
if Wire.string_field r "value" <> Some "42" then
|
||||
fail "use-value's clause bound %s, not 42"
|
||||
(Option.value ~default:(said r) (Wire.string_field r "value"))
|
||||
end
|
||||
end
|
||||
end);
|
||||
|
||||
(* ...and the other way out. Every check above is of an abort being
|
||||
*refused*; the accepted path is the one that must not be left as code
|
||||
that has never run, because it is the one that ends a program. Break
|
||||
|
||||
46
vendor/agent/flan_agent.c
vendored
46
vendor/agent/flan_agent.c
vendored
@ -348,6 +348,9 @@ extern const uint8_t *flan_restart_frame_report(const void *frame, int64_t *len)
|
||||
extern const uint8_t *flan_restart_frame_sig(const void *frame, int64_t *len);
|
||||
extern int32_t flan_restart_frame_arity(const void *frame);
|
||||
extern int32_t flan_restart_frame_hidden(const void *frame);
|
||||
extern void *flan_restart_frame_args(const void *frame);
|
||||
extern int32_t flan_restart_frame_armed(const void *frame);
|
||||
extern void flan_restart_frame_arm(void *frame);
|
||||
extern void flan_restart_pop_c(void *frame);
|
||||
|
||||
/* -- How far down a transfer can actually land ----------------------- */
|
||||
@ -620,6 +623,37 @@ static snapshot *snap_top(void) {
|
||||
return d <= 0 ? NULL : &snaps[d - 1];
|
||||
}
|
||||
|
||||
/* Where a restart's parameter lives, for the thunk the daemon builds to fill
|
||||
* one in before taking it: restart [i] of the snapshot on top, [off] bytes
|
||||
* into its buffer. The daemon lays the buffer out the way both backends do
|
||||
* (Emit.lay_fields over the clause's types), so [off] is its to compute.
|
||||
* NULL for an index this snapshot does not have or a restart that takes
|
||||
* nothing, and the thunk is built only for one that takes something. */
|
||||
void *flan_agent_restart_arg(int64_t i, int64_t off) {
|
||||
snapshot *s = snap_top();
|
||||
void *args;
|
||||
if (s == NULL || i < 0 || i >= s->n || off < 0) return NULL;
|
||||
if (s->arity[i] <= 0) return NULL;
|
||||
args = flan_restart_frame_args(s->frame[i]);
|
||||
return args == NULL ? NULL : (char *)args + off;
|
||||
}
|
||||
|
||||
/* And the flag an invoke-restart sets beside the values: the clause refuses a
|
||||
* buffer nobody wrote, and this says somebody did. */
|
||||
void flan_agent_restart_arm(int64_t i) {
|
||||
snapshot *s = snap_top();
|
||||
if (s == NULL || i < 0 || i >= s->n || s->arity[i] <= 0) return;
|
||||
flan_restart_frame_arm(s->frame[i]);
|
||||
}
|
||||
|
||||
/* A restart that takes values and has not been given them is refused here,
|
||||
* where the reason can be said, rather than taken and refused at the clause,
|
||||
* which is a trap the program cannot come back from. */
|
||||
static int unarmed(snapshot *s, int32_t i) {
|
||||
return s->arity[i] > 0 && !flan_restart_frame_armed(s->frame[i]);
|
||||
}
|
||||
|
||||
|
||||
/* One string into the snapshot's text pool, with its offset and length. A
|
||||
* string that does not fit is recorded as empty rather than cut: an empty
|
||||
* report or location is a state the reader handles, and half of one is not. */
|
||||
@ -1287,6 +1321,16 @@ static const char *abi_mismatch(const char *err) {
|
||||
* It is held across the [dlopen], which is milliseconds. That is what the
|
||||
* accept loop already did to itself by serving connections inline, so no
|
||||
* caller waits longer than it did before. The game thread never takes it. */
|
||||
/* [unarmed]'s refusal, with what the restart takes. */
|
||||
static void reply_unarmed(sink *o, snapshot *s, int32_t i) {
|
||||
reply(o, "err restart ");
|
||||
reply(o, s->names + s->off[i]);
|
||||
reply(o, " takes ");
|
||||
emit(o, s->text + s->sigoff[i], (size_t)s->siglen[i]);
|
||||
reply(o, "; give it one value of each type, which the break buffer asks for "
|
||||
"when it is taken\n");
|
||||
}
|
||||
|
||||
static pthread_mutex_t request_lock = PTHREAD_MUTEX_INITIALIZER;
|
||||
|
||||
static void handle_line(char *line, sink *o) {
|
||||
@ -1541,6 +1585,7 @@ static void handle_line(char *line, sink *o) {
|
||||
"above it, or abort\n");
|
||||
return;
|
||||
}
|
||||
if (unarmed(s, (int32_t)idx)) { reply_unarmed(o, s, (int32_t)idx); return; }
|
||||
atomic_store(&chosen_index, (int)idx);
|
||||
atomic_store(&chosen_gen, s->gen);
|
||||
/* Published last, so the game thread never reads an index that is about
|
||||
@ -1589,6 +1634,7 @@ static void handle_line(char *line, sink *o) {
|
||||
"above it, or abort\n");
|
||||
return;
|
||||
}
|
||||
if (unarmed(s, at)) { reply_unarmed(o, s, at); return; }
|
||||
atomic_store(&chosen_index, at);
|
||||
atomic_store(&chosen_gen, s->gen);
|
||||
atomic_store(&chosen_ready, 1);
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user