From d6c33928f52ed19fb6f8e46eb8541113bdb4bbd6 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 18:16:13 +0700 Subject: [PATCH] A name an as bound is refused as itself when assigned, in the program and in a stopped frame alike. --- lib/check.ml | 48 ++++++++++++++++++++++++++++---------------- lib/emit.ml | 2 +- lib/session.ml | 16 ++++++++++----- lib/tast.ml | 4 ++++ test/test_dev.ml | 31 +++++++++++++++++++++++++++- test/test_flan.ml | 9 +++++++++ test/test_session.ml | 2 +- 7 files changed, 87 insertions(+), 25 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index b69a6d3e..751b538a 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -834,6 +834,8 @@ type ctx = { here rather than recovered later because this scope list is the only place that ever knows it. *) mutable slot_names : string option list; + (* The slots an [as] bound in this function: [Tast.fn.as_slots]. *) + mutable as_slots : int list; mutable scope : (string * binding) list; (* innermost first *) (* Deferred forms, most recently registered first โ€” which is also the order they run in. [defer] is function-scoped, so this list belongs to the @@ -3184,6 +3186,10 @@ let unnarrowable_in (body : Ast.expr list) = List.iter (walk ~in_fn:false) body; !out +(* The [bwhat] of a name an [as] bound (decision 136), for the refusal to + assign it. *) +let as_tag = "~as" + let local_of loc (b : binding) = if b.bwhat = Some narrowed_tag then mk loc b.bty (Tast.Field (mk loc (Types.Option b.bty) (Tast.Local b.slot), 1)) @@ -4919,7 +4925,7 @@ let thick_thunk env loc ps r = env.lifted <- { Tast.name; params = ps; slots = Array.of_list (ps @ [ fty ]); - snames = Array.make (n + 1) None; + snames = Array.make (n + 1) None; as_slots = []; ret = r; body = [ mk loc r (Tast.CallPtr (callee, args)) ]; fdefers = []; fenv = Some n; fparent = Some ""; floc = loc } :: env.lifted; @@ -5277,7 +5283,7 @@ let with_recovery env ~on f = end let invented_ctx env ret = - { env; ret; lits = None; slots = 0; slot_tys = []; slot_names = []; scope = []; + { env; ret; lits = None; slots = 0; slot_tys = []; slot_names = []; as_slots = []; scope = []; defers = []; defer_slot = None; outer = []; outer_what = None; caught = []; place_ok = false; envslot = None; parent = None; in_frames = None; loops = []; tail = false; used = false; kept = []; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "" } @@ -5337,7 +5343,7 @@ let condition_desc ctx loc name = ctx.env.lifted <- { Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ]; slots = Array.of_list (List.rev hctx.slot_tys); - snames = Array.of_list (List.rev hctx.slot_names); + snames = Array.of_list (List.rev hctx.slot_names); as_slots = hctx.as_slots; ret = Types.Unit; body; fdefers = []; fenv = None; fparent = Some ctx.owner; floc = loc } :: ctx.env.lifted; @@ -5457,7 +5463,7 @@ and struct_key_pair env loc n = The body is filled in below; nothing can call these in between. *) let placeholder name ret params = { Tast.name; params; slots = Array.of_list params; - snames = Array.make (List.length params) None; + snames = Array.make (List.length params) None; as_slots = []; ret; body = []; fdefers = []; fenv = None; fparent = None; floc = loc } in env.lifted <- @@ -5540,7 +5546,7 @@ and struct_key_pair env loc n = let finish name ret params ctx body = { Tast.name; params; slots = Array.of_list (List.rev ctx.slot_tys); - snames = Array.of_list (List.rev ctx.slot_names); + snames = Array.of_list (List.rev ctx.slot_names); as_slots = ctx.as_slots; ret; body; fdefers = []; fenv = None; fparent = None; floc = loc } in env.lifted <- @@ -5588,7 +5594,7 @@ and array_key_pair env loc n e = let eparams = [ pty; pty; Types.Int Types.I64 ] in let placeholder name ret params = { Tast.name; params; slots = Array.of_list params; - snames = Array.make (List.length params) None; + snames = Array.make (List.length params) None; as_slots = []; ret; body = []; fdefers = []; fenv = None; fparent = None; floc = loc } in env.lifted <- @@ -5663,7 +5669,7 @@ and array_key_pair env loc n e = let finish name ret params ctx body = { Tast.name; params; slots = Array.of_list (List.rev ctx.slot_tys); - snames = Array.of_list (List.rev ctx.slot_names); + snames = Array.of_list (List.rev ctx.slot_names); as_slots = ctx.as_slots; ret; body; fdefers = []; fenv = None; fparent = None; floc = loc } in env.lifted <- @@ -7321,7 +7327,7 @@ and check_fn ctx ~want ?gen loc (params : string list) body = let lifted = { Tast.name = fname; params = pts; slots = Array.of_list (List.rev fctx.slot_tys); - snames = Array.of_list (List.rev fctx.slot_names); + snames = Array.of_list (List.rev fctx.slot_names); as_slots = fctx.as_slots; ret; body = prefix fbody; fdefers = []; fenv; fparent = Some ctx.owner; floc = loc } in @@ -7444,7 +7450,7 @@ and check_handler_bind ctx ?want ?(what = "handler-bind") loc clauses body = let lifted = { Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ]; slots = Array.of_list (List.rev hctx.slot_tys); - snames = Array.of_list (List.rev hctx.slot_names); + snames = Array.of_list (List.rev hctx.slot_names); as_slots = hctx.as_slots; ret = Types.Unit; body = prefix hbody; fdefers = []; fenv; fparent = Some ctx.owner; floc = c.Ast.hloc } in @@ -10830,7 +10836,8 @@ and as_cond ctx (c : Ast.expr) = its payload copied into [g]'s once the test holds. *) let bound ty = scoped ctx (fun () -> - let slot = bind ctx g ty ~assignable:false in + let slot = bind ctx ~what:as_tag g ty ~assignable:false in + ctx.as_slots <- slot :: ctx.as_slots; let b = Option.get (lookup ctx g) in incr held_n; named := (g, Printf.sprintf "~as%d" !held_n, b) :: !named; @@ -11318,7 +11325,7 @@ and struct_of ctx (target : Ast.expr) (t : Tast.expr) : Tast.expr * string = "%s is tested with %s? above, so here it is what the Option \ holds, %s, and %s has no fields" n n (tyname target.Ast.loc other) (tyname target.Ast.loc other) - | Some { bwhat = Some w; _ } -> + | Some { bwhat = Some w; _ } when w <> as_tag -> fail target.Ast.loc "%s is %s โ€” the pattern bound it to %s, so the value is already \ in hand and there is no field left to read" @@ -11402,6 +11409,11 @@ and check_place ?(store = true) ctx loc (p : Ast.place) : Tast.place * Types.t = (match List.assoc_opt name ctx.caught with | Some (_, slot) when slot = b.slot -> captured_set ctx loc name | _ -> ()); + if b.bwhat = Some as_tag then + fail loc + "%s names what an as test found, and it cannot be given a new \ + value. To change it, copy it into a local first: let %s2 = %s" + name name name; fail loc "%s is a parameter, and a parameter is not assignable โ€” bind a \ local with let" name @@ -17172,7 +17184,7 @@ and trial ctx f = Only [Loc.Error] is caught. A timeout or a stack overflow is not a refusal to reconsider, and silently continuing past one would turn a resource failure into a wrong answer. *) - let[@warning "+9"] { env = _; ret = _; lits = _; slots; slot_tys; slot_names; scope; + let[@warning "+9"] { env = _; ret = _; lits = _; slots; slot_tys; slot_names; as_slots; scope; defers; defer_slot; defer_ok; defer_block; outer = _; outer_what; caught; place_ok; envslot; parent = _; in_frames; loops; tail; used; kept; in_defer; @@ -17183,7 +17195,7 @@ and trial ctx f = | exception Loc.Error d -> undo (); ctx.slots <- slots; ctx.slot_tys <- slot_tys; - ctx.slot_names <- slot_names; ctx.scope <- scope; + ctx.slot_names <- slot_names; ctx.as_slots <- as_slots; ctx.scope <- scope; ctx.defers <- defers; ctx.defer_slot <- defer_slot; ctx.defer_ok <- defer_ok; ctx.defer_block <- defer_block; ctx.outer_what <- outer_what; ctx.in_frames <- in_frames; @@ -18960,7 +18972,7 @@ let rec check_fn ?sign env (fn : Ast.fn) : Tast.fn = let checked = { Tast.name = fn.Ast.name; params; slots = Array.of_list (List.rev ctx.slot_tys); - snames = Array.of_list (List.rev ctx.slot_names); + snames = Array.of_list (List.rev ctx.slot_names); as_slots = ctx.as_slots; (* The same defers again, for the transfer exit path ยง5 describes. The normal path has them spliced into [body] above; this one is guarded on the count, because a transfer can start above a defer that the text has @@ -19591,7 +19603,7 @@ let lift_ginit ctx loc n ty (v : Tast.expr) = ctx.env.lifted <- { Tast.name = fname; params = []; slots = Array.of_list (List.rev ctx.slot_tys); - snames = Array.of_list (List.rev ctx.slot_names); + snames = Array.of_list (List.rev ctx.slot_names); as_slots = ctx.as_slots; (* An initialiser is a nested form as far as [defer_ok] is concerned, so nothing can register one here and both of these are empty. Written the same way [check_fn] writes them anyway, so that the day the rule @@ -20772,13 +20784,15 @@ let expressions env (es : (Types.t option * Ast.expr) list) : 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) +let expression_in_scope env ~(scope : (string * Types.t * bool * 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)) + (fun (name, ty, assignable, by_as) -> + let what = if by_as then Some as_tag else None in + (name, bind ctx ?what name ty ~assignable:(assignable && not by_as))) scope in let t = expect ctx e.Ast.loc ~want:None (check ctx e) in diff --git a/lib/emit.ml b/lib/emit.ml index c519af35..73c595aa 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -4876,7 +4876,7 @@ let emit_startup m ?(hidden = false) (globals : Tast.global list) = own to live in. *) List.iter (emit_global m ~hidden) flags; emit_fn m ~hidden - { Tast.name = ".init-globals"; params = []; slots = [||]; snames = [||]; + { Tast.name = ".init-globals"; params = []; slots = [||]; snames = [||]; as_slots = []; ret = Types.Unit; body; fdefers = []; fenv = None; fparent = None; floc = (List.hd computed).Tast.ginit.Tast.loc }; true diff --git a/lib/session.ml b/lib/session.ml index 30f426b2..4363b65a 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1371,7 +1371,7 @@ let eval ?(origin = "") ?base ?forms ?pause ?(step = false) ?(running = tr { Tast.name = Printf.sprintf "install/%d" t.thunks; params = []; ret = Types.Unit; body; fdefers = []; fenv = None; fparent = None; floc = loc; - slots = [||]; snames = [||] } + slots = [||]; snames = [||]; as_slots = [] } in let ir = match run_thunk with @@ -2122,7 +2122,8 @@ let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path scratch and have none to keep. *) snames = Array.append bnames - (Array.make (List.length !extra) None) } + (Array.make (List.length !extra) None); + as_slots = [] } in (* A struct copy the values named first, laid out in this module and kept, as [eval_expr] keeps one. *) @@ -2258,7 +2259,8 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) @ [ 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) } + snames = Array.append bnames (Array.make (List.length !extra) None); + as_slots = [] } in let copies = Check.fresh_copies t.env t.program.Tast.structs in let program = @@ -2310,7 +2312,10 @@ let in_frame t ~frame:(index, (fn : Tast.fn), bound) (parsed : Ast.expr) = @ 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 + List.map + (fun (i, name) -> + (name, fn.Tast.slots.(i), i >= nparams, List.mem i fn.Tast.as_slots)) + 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 @@ -2436,7 +2441,8 @@ let eval_expr ?(origin = "") ?(pause = false) ?frame t src : change = slots = Array.append base (Array.of_list (List.rev !extra)); (* The expression's own [let]s keep their names; the slots [render] added behind them are the walk's own scratch and have none to keep. *) - snames = Array.append bnames (Array.make (List.length !extra) None) } + snames = Array.append bnames (Array.make (List.length !extra) None); + as_slots = [] } in (* Built against the program but never spliced into it: an evaluation is not a declaration, and adding one would leave the session carrying an eval/N diff --git a/lib/tast.ml b/lib/tast.ml index e297c882..2d806b90 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -354,6 +354,10 @@ type fn = { backend is free to ignore it entirely -- nothing is *resolved* through it, and a slot is still only ever referred to by index. *) snames : string option array; + (* The slots an [as] bound (decision 136): named, and read-only, so + evaluating in a stopped frame may read them and may not assign them, + as the program itself may not. *) + as_slots : int list; ret : Types.t; body : expr list; (* The defers again, innermost first. [body] already has them spliced onto diff --git a/test/test_dev.ml b/test/test_dev.ml index 31bff637..3b77dbc7 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -2533,7 +2533,36 @@ let () = (match List.assoc_opt "e" rows with | Some ("dyn", v) when Test_support.contains v "hi" -> () | Some (ty, v) -> fail "locals show e as %s %s (%s)" ty v backend - | None -> fail "locals do not show e (%s)" backend) + | None -> fail "locals do not show e (%s)" backend); + (* Eval-in-frame reads them and, as the program may not, cannot + assign them. *) + let eval code = + ask + (Printf.sprintf "(:op \"eval-expr\" :frame 0 :code %s :syntax \"indented\")" + (Wire.quote code)) + in + let r = eval "g + 1" in + if Wire.string_field r "value" <> Some "42" then + fail "eval-in-frame g + 1 (%s): %s" backend + (Option.value ~default:(status r) (Wire.string_field r "message")); + List.iter + (fun (code, name) -> + let r = eval code in + if status r = "ok" then + fail "eval-in-frame %s was accepted (%s)" code backend + else if + not + (Test_support.contains + (Option.value ~default:"" (Wire.string_field r "message")) + (name ^ " names what an as test found")) + then + fail "eval-in-frame %s (%s) said: %s" code backend + (Option.value ~default:"" (Wire.string_field r "message"))) + [ ("g = 7", "g"); ("e = 1", "e") ]; + let r = eval "g" in + if Wire.string_field r "value" <> Some "41" then + fail "g changed after a refused assignment (%s): %s" backend + (Option.value ~default:(status r) (Wire.string_field r "value")) end; ignore (ask "(:op \"close\")"); Unix.close c; diff --git a/test/test_flan.ml b/test/test_flan.ml index 9154491e..d736e89f 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1507,6 +1507,15 @@ let () = refuses_all ~fln:true "~~ in .fln" "fn f(a: bool) -> i32\n ~~a\n" "~~ works on the bits"; refuses_all ~fln:true "^^ in .fln" "fn f(a: bool, b: bool) -> bool\n a ^^ b == 0\n" "write a != b"; + (* A name an as bound is read-only, and says so as itself, not as a + parameter (decision 136). *) + refuses_all ~fln:true "assigning an as name" + "fn f(o: i32?, d) -> i32\n if o as g and d as e\n g = 5\n g\n else\n 0\n" + "g names what an as test found, and it cannot be given a new value. To \ + change it, copy it into a local first: let g2 = g"; + refuses_all ~fln:true "assigning a dyn as name" + "fn f(o: i32?, d) -> i32\n if o as g and d as e\n e = 5\n g\n else\n 0\n" + "e names what an as test found"; rejects_check "popcount of a float" "(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64"; rejects_check "a rotation's count does not widen the value" diff --git a/test/test_session.ml b/test/test_session.ml index 6df9c9d2..4b6dc915 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -1805,7 +1805,7 @@ let () = { Tast.name = "f"; params = []; ret = Types.Unit; body = []; fdefers = []; fenv = None; fparent = None; floc = Loc.unknown; slots = Array.make (Array.length snames) (Types.Int Types.I32); - snames } + snames; as_slots = [] } in (match Session.shown_names (fn [| Some "k~2"; None |]) with | [| Some "k"; None |] -> ()