From 5ce8e7a68e1b6eb7ecbea19b8bcd5b4196254c99 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 11 Sep 2026 07:27:50 +0700 Subject: [PATCH] handler-bind and signal, which alter no control flow MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit spec-conditions.md §1 and §2 and nothing else, because those two are worth having alone: signal returns Unit whatever it finds, a handler that returns normally leaves the signalling function to carry on, and with nothing matching it is a no-op. So none of §6's transfer machinery exists yet and no signature changed - which is the whole reason to do this step first. The runtime is a linked list. Establishing a handler is two stores and a push onto a frame on the establishing function's own stack, and signal with an empty stack is a null check, which is what §2 asks for. Popping is by frame rather than by count, so restoring what this one displaced is right even if something below it left the stack out of step. A condition's type is a hash of its name and not an index: an index would shift the moment a struct were added, and every handler a running program had already pushed would match the wrong type. The condition crosses as a pointer, since a handler runs while the signalling frame is alive and there is nothing to copy - but what the clause binds is the condition itself, the pointer being a hidden parameter and the name a slot loaded from it, so a handler passing c to something expecting the struct is not handed an address. A clause is lifted into a function of its own, because a handler runs from wherever the signal was and cannot be a branch in the function that wrote it. That gives two refusals, both by the house rule. A handler cannot see the establishing function's locals - that is a closure with an explicit environment, so a reference to one is refused for that reason rather than reported as an unknown name. And return inside a handler-bind body is refused, since the frames are popped on the way out and an early exit would leave them pointing into a function that has gone. Settled in advance for the next step: in a dev build every function is transfer-transparent, because a cell can hold anything and the honest answer to what it can call is anything. Same bargain as the indirect call, and it means redefinition acquires no new refusal class. Still open is whether the discriminated result is returned by value or through an out-parameter. --- NEXT.md | 69 +++++++++++++++ lib/ast.ml | 6 ++ lib/check.ml | 157 ++++++++++++++++++++++++++++++++-- lib/emit.ml | 52 +++++++++++ lib/load.ml | 14 +++ lib/parse.ml | 34 +++++++- lib/tast.ml | 11 +++ runtime/flan_rt.c | 40 +++++++++ test/programs/conditions.flan | 45 ++++++++++ test/test_acceptance.ml | 7 ++ test/test_flan.ml | 27 ++++++ 11 files changed, 454 insertions(+), 8 deletions(-) create mode 100644 test/programs/conditions.flan diff --git a/NEXT.md b/NEXT.md index 3417d0b..982fbc8 100644 --- a/NEXT.md +++ b/NEXT.md @@ -56,6 +56,7 @@ reader ✅ → parse ✅ → load ✅ → check ✅ → emit ✅ → clang ✅ | `test/test_session.ml` | **what a running process cannot be told, and recovering from a typo** | | `test/test_dev.ml` | **the daemon, driven the way an editor drives it** | | `test/test_repl.ml` | **`C-x C-e`: an expression evaluated inside a running program** | +| `test/programs/conditions.flan` | **`handler-bind` and `signal`, the accumulation case** | | `test/test_emacs.ml` | **the client, driven against a real daemon and a real program** | | `test/reload_host.c` | the C host that loads and installs two rebuilds, in one process | @@ -834,6 +835,74 @@ thing anyone types at a prompt — answered `()` while nothing happened. A Unit expression is almost always a call made for its effect, and is now evaluated and *then* reported. +### Conditions — step 1: `handler-bind` and `signal` + +`spec-conditions.md` §1 and §2, and nothing else yet. They are worth having on +their own because **neither alters control flow**: `signal` returns `Unit` +whatever it finds, a handler that returns normally leaves the signalling +function to carry on, and with nothing matching it is a no-op. So none of the +transfer machinery §6 describes exists yet, and no signature changed. + +``` +(handler-bind [(AssetMissing [c] (set seen (+ seen (i64 (.id c)))))] + (load-all)) +``` + +The runtime is a linked list: establishing a handler is two stores and a push +onto a frame allocated on the establishing function's own stack, and `signal` +with an empty stack is a null check — which is what §2 asks for. Popping is by +frame rather than by count, so restoring what this one displaced is right even +if something below it left the stack out of step. + +Three decisions worth keeping: + +- **A condition's type is a hash of its name**, not an index. An index would + shift the moment a struct were added, and every handler a running program had + already pushed would then match the wrong type. FNV-1a over the name. +- **The condition crosses as a pointer**, because a handler runs while the + signalling frame is still alive and there is nothing to copy. What the clause + *binds* is the condition itself, though — the pointer is a hidden parameter + and the name is a slot loaded from it, so a handler passing `c` to something + expecting the struct is not handed an address instead. +- **A clause is lifted into a function of its own.** A handler runs from + wherever the signal was, so it cannot be a branch in the function that wrote + it. + +Which gives the two refusals, both by the house rule rather than by accident: + +- **A handler cannot see the establishing function's locals.** That is a + closure with an explicit environment — milestone 5's work — so a reference to + one is refused *for that reason* rather than reported as an unknown name. + Globals and the condition are in scope, which is what the accumulation case + needs. +- **`return` inside a `handler-bind` body is refused.** The frames are popped + on the way out and an early exit would leave them on the stack pointing into + a function that has gone. Same shape as `defer` inside a block. + +### Conditions — what step 1 does not do + +- `restart-case` and `invoke-restart`, which are the transfer, and with it §6's + calling-convention change: a transfer-transparent function returns a + discriminated "value / transferring to frame N" and forwards it after each + call. **Settled in advance:** in a dev build every function is + transfer-transparent, because a cell can hold anything and the honest answer + to "what can this call?" is "anything". That is the same bargain as the + indirect call, and it means redefinition acquires *no* new refusal class. + Release builds keep escape analysis and pay nothing. What is *not* settled is + whether the discriminated result is returned by value or through an + out-parameter; the spec leaves it open and it is in every signature, so it is + the thing to decide before writing that step. +- `handler-case`, which §"What this does not settle" leaves open as possibly a + macro over `handler-bind` plus a transfer. +- The **dev-build break loop** of §2 — where an unhandled `error` stops and + talks to the daemon instead of `rt_die()`. That is where "a crash kills the + program" finally gets fixed. +- Restarts offered in the minibuffer, which needs `compute-restarts` and two + protocol ops. + +Checked on the way: sand has no raylib callback anywhere, so nothing in the +demo path would hit §6's "a transfer cannot cross a foreign frame" wall. + ### What is left - **Editor comforts**: completion, eldoc, jump-to-definition, error overlays. diff --git a/lib/ast.ml b/lib/ast.ml index c7ae83d..e8d051a 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -53,6 +53,12 @@ and expr_kind = | Dotimes of string * expr * expr list (* (dotimes [i n] ...) *) | Defer of expr list (* runs on scope exit *) | Unwrap of unwrap * expr (* (some x) / (try x) *) + (* (handler-bind [(Type [c] body ...) ...] body ...) — spec-conditions.md. + A clause binds a name for the condition, so this cannot be a call. *) + | HandlerBind of hclause list * expr list + | Signal of expr (* (signal c) : Unit *) + +and hclause = { hty : texpr; hname : string; hbody : expr list; hloc : Loc.t } (* Two unwrap operators, because they are two different things — plan.org. *) and unwrap = Usome | Utry diff --git a/lib/check.ml b/lib/check.ml index bd73a1d..10f9633 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -55,6 +55,10 @@ type env = { externs : (string, string) Hashtbl.t; fns : (string, Types.t list * Types.t) Hashtbl.t; globals : (string, Types.t * bool) Hashtbl.t; (* type, is a constant *) + (* Functions the checker made up: a handler-bind clause is lifted into one, + because a handler is called from wherever the signal was and cannot be a + branch in the function that established it. *) + mutable lifted : Tast.fn list; } let new_env () = { @@ -67,6 +71,7 @@ let new_env () = { externs = Hashtbl.create 32; fns = Hashtbl.create 32; globals = Hashtbl.create 16; + lifted = []; } (* Per-function state. Slots are never reused, so [slots] is also the frame @@ -83,6 +88,12 @@ type ctx = { they run in. At milestone 4 [defer] is function-scoped (see [check_fn]), so this list belongs to the function and not to a block. *) mutable defers : Tast.expr list; + (* Only for the two things a handler clause cannot do. [outer] is the + establishing function's scope, kept so that a reference to one of its + locals can be refused for the reason it is really refused for rather than + as an unknown name. *) + outer : (string * binding) list; + in_handler : bool; } let fresh_slot ctx ty = @@ -98,6 +109,21 @@ let bind ctx name bty ~assignable = let lookup ctx name = List.assoc_opt name ctx.scope +(* A handler clause is lifted into a function of its own, so the establishing + function's locals are simply not there. Capturing them is a closure with an + explicit environment — milestone 5's work — and until it exists a reference + to one is refused for the reason it is really refused for, rather than as a + name nobody has heard of. *) +let captured ctx loc name = + if ctx.in_handler && List.mem_assoc name ctx.outer then + raise + (Loc.Error + (loc, + Printf.sprintf + "a handler cannot see %s: it is a local of the function that \ + established the handler, and a handler runs from wherever the \ + signal was. Use a global, or pass it on the condition." name)) + let scoped ctx f = let saved = ctx.scope in let r = f () in @@ -232,6 +258,20 @@ let unit_at loc = mk loc Types.Unit Tast.Unit (* Every integer index into an array or slice is i32 at milestone 2. *) let index_ty = Types.Int Types.I32 +(* A condition's type at run time is a number, and it has to be the *same* + number in a module compiled later against a program already running. So it + is a hash of the name and not an index into anything: an index would shift + the moment a struct were added, and every handler pushed by the old code + would then match the wrong type. FNV-1a over the name, 32 bits. *) +let type_id name = + let h = ref 0x811c9dc5 in + String.iter + (fun c -> + h := (!h lxor Char.code c) land 0xffffffff; + h := (!h * 0x01000193) land 0xffffffff) + name; + !h + let expect loc ~want (got : Tast.expr) = match want with | None -> got @@ -290,6 +330,16 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = let c = check ctx ~want:Types.Bool c in let body = scoped ctx (fun () -> map_lr (fun b -> check ctx b) body) in expect loc ~want (mk loc Types.Unit (Tast.While (c, body))) + | Ast.Return v when ctx.in_handler -> + ignore v; + (* The frames are pushed and popped around the body, so an early exit would + leave them on the handler stack pointing into a function that has gone. + Rejected rather than left to corrupt it, the same rule as defer inside a + block. *) + fail loc + "return is not allowed inside handler-bind yet — the handler frames are \ + popped on the way out and an early exit would leave them on the stack" + | Ast.Return v -> let v = match v with @@ -340,6 +390,26 @@ let rec check ctx ?want (e : Ast.expr) : Tast.expr = | Ast.Unwrap (Ast.Utry, _) -> unimplemented loc "try (Result)" 6 | Ast.Fn _ -> unimplemented loc "fn values" 5 | Ast.Dotimes (name, count, body) -> check_dotimes ctx ~want loc name count body + (* (signal c) : Unit, always — spec-conditions.md §1. A handler that returns + normally leaves the signalling function to carry on, and with nothing + matching this is a no-op, so nothing about it alters control flow. That is + what makes it checkable here rather than needing the transfer machinery + restart-case will want. *) + | Ast.Signal c -> + let c = check ctx c in + let name = + match c.Tast.ty with + | Types.Named n -> n + | t -> + fail c.Tast.loc + "a condition is a struct, not %s — matching is by type and there is \ + no condition hierarchy" + (Types.to_string t) + in + mk loc Types.Unit (Tast.Signal (type_id name, c)) + + | Ast.HandlerBind (clauses, body) -> check_handler_bind ctx ?want loc clauses body + | Ast.Defer _ -> (* Registered by [check_fn], which is the only place that sees a form's position. A defer anywhere else would run at function exit rather than @@ -409,7 +479,7 @@ and var ctx loc ~want name = if Hashtbl.mem ctx.env.fns name then unimplemented loc (Printf.sprintf "the function value %s (a name used as a value)" name) 5 - else fail loc "unknown name %s" name + else begin captured ctx loc name; fail loc "unknown name %s" name end and block ctx ?want loc body = match body with @@ -424,6 +494,73 @@ and block ctx ?want loc body = let body, ty = go body in mk loc ty (Tast.Do body) +(* A handler runs where the *signal* was, not where it was established, so it + cannot be a branch in the function that wrote it: it is lifted into a + function of its own and reached through a pointer. + + Which means it cannot see the establishing function's locals. Capturing them + is a closure with an explicit environment, which is real work and is + milestone 5's; until then a reference to one is rejected by name rather than + silently resolving to something else. Globals and the condition itself are + in scope, which is enough for the accumulation case §1 is about. + + The body may not [return] either. The frames are pushed and popped around + it, and an early exit would leave them on the stack pointing into a function + that has gone. *) +and check_handler_bind ctx ?want loc clauses body = + ignore want; + let frames = + List.map + (fun (c : Ast.hclause) -> + let ty = resolve ctx.env c.Ast.hty in + let name = + match ty with + | Types.Named n -> n + | t -> + fail c.Ast.hloc + "a handler matches a struct type, not %s" (Types.to_string t) + in + (* Its own context: a fresh frame, an empty scope, and no way to reach + the enclosing one. *) + let hctx = + { env = ctx.env; ret = Types.Unit; slots = 0; slot_tys = []; + scope = []; defers = []; outer = ctx.scope; in_handler = true } + in + (* The condition crosses as a pointer, because the handler runs while + the signalling frame is still alive and there is nothing to copy. + What the clause binds is the condition itself, though, so the + pointer is a hidden parameter and the name is a slot loaded from + it — a handler that passed [c] to something expecting the struct + would otherwise be handed an address. *) + let pslot = fresh_slot hctx (Types.Ptr ty) in + let cslot = bind hctx c.Ast.hname ty ~assignable:false in + let hbody = map_lr (fun e -> check hctx e) c.Ast.hbody in + let hbody = + [ mk c.Ast.hloc Types.Unit + (Tast.Let + ([ (cslot, + mk c.Ast.hloc ty + (Tast.Deref + (mk c.Ast.hloc (Types.Ptr ty) (Tast.Local pslot)))) ], + hbody)) ] + in + let fname = Printf.sprintf "handler/%s/%d" name (type_id name land 0xffff) in + let fname = + Printf.sprintf "%s/%d" fname (List.length ctx.env.lifted) + in + ctx.env.lifted <- + { Tast.name = fname; params = [ Types.Ptr ty ]; + slots = Array.of_list (List.rev hctx.slot_tys); + ret = Types.Unit; body = hbody; floc = c.Ast.hloc } + :: ctx.env.lifted; + { Tast.htype = type_id name; hfn = fname }) + clauses + in + let body = + map_lr (fun e -> check { ctx with in_handler = true } e) body + in + mk loc Types.Unit (Tast.Handled (frames, body)) + and check_let ctx ?want loc bs body = scoped ctx (fun () -> let bs = @@ -627,7 +764,7 @@ and check_place ctx loc (p : Ast.place) : Tast.place * Types.t = match Hashtbl.find_opt ctx.env.globals name with | Some (_, true) -> fail loc "%s is a constant" name | Some (ty, false) -> Tast.Pglobal name, ty - | None -> fail loc "unknown name %s" name) + | None -> captured ctx loc name; fail loc "unknown name %s" name) | Ast.Pfield (target, name) -> let target, sname = struct_target ctx target in let s = Hashtbl.find ctx.env.structs sname in @@ -1137,7 +1274,8 @@ let collect env (decls : Ast.decl list) = not check once no progress is left has a real error, so the last round is run without swallowing it. *) let infer (_, v) = - (check { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = []; defers = [] } v).Tast.ty + (check { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = []; defers = []; + outer = []; in_handler = false } v).Tast.ty in let pending = ref (List.rev !untyped) in let rec settle () = @@ -1189,7 +1327,8 @@ let check_finite env = let check_fn env (fn : Ast.fn) : Tast.fn = let params, ret = Hashtbl.find env.fns fn.Ast.name in - let ctx = { env; ret; slots = 0; slot_tys = []; scope = []; defers = [] } in + let ctx = { env; ret; slots = 0; slot_tys = []; scope = []; defers = []; + outer = []; in_handler = false } in List.iter2 (fun (p : Ast.field) ty -> if List.mem_assoc p.Ast.fname ctx.scope then @@ -1258,7 +1397,8 @@ let check_fn env (fn : Ast.fn) : Tast.fn = ret; body; floc = fn.Ast.nloc } let check_global env (d : Ast.decl) : Tast.global option = - let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = []; defers = [] } in + let ctx () = { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = []; defers = []; + outer = []; in_handler = false } in match d.Ast.d with | Ast.Defvar (n, _, init) -> let ty, _ = Hashtbl.find env.globals n in @@ -1331,6 +1471,10 @@ let program_with_env (decls : Ast.decl list) : Tast.program * env = | _ -> None) decls in + (* The handler clauses lifted out along the way. They are ordinary functions + from here down; nothing in the backend knows they were written inside + something else. *) + let fns = fns @ List.rev env.lifted in (* Sorted, so the emitted IR is reproducible build to build: a Hashtbl's fold order is not. *) let values name tbl = @@ -1357,7 +1501,8 @@ let program (decls : Ast.decl list) : Tast.program = fst (program_with_env decls function — so the slots it needs are whatever its own [let]s allocate. *) let expression env (e : Ast.expr) : Tast.expr * Types.t array = let ctx = - { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = []; defers = [] } + { env; ret = Types.Unit; slots = 0; slot_tys = []; scope = []; defers = []; + outer = []; in_handler = false } in let t = check ctx e in (t, Array.of_list (List.rev ctx.slot_tys)) diff --git a/lib/emit.ml b/lib/emit.ml index 52e055a..34144fb 100644 --- a/lib/emit.ml +++ b/lib/emit.ml @@ -147,6 +147,13 @@ let alloca f ty = Buffer.add_string f.allocas (Printf.sprintf " %s = alloca %s\n" name (ll ty)); name +(* For the few slots whose LLVM type is not a Flan type: a handler frame is the + runtime's shape, not something [Types] can name. *) +let alloca_raw f lltype = + let name = fresh f in + Buffer.add_string f.allocas (Printf.sprintf " %s = alloca %s\n" name lltype); + name + (* ── Constants ─────────────────────────────────────────────────────── *) (* LLVM's hex form is exact, which decimal is not: a literal must mean the same @@ -304,6 +311,13 @@ let rec value f (e : Tast.expr) : string = b | Tast.Match (s, arms) -> emit_match f e.Tast.ty s arms | Tast.UnwrapSome v -> emit_unwrap f e.Tast.ty v + (* The condition crosses as a pointer: a handler runs while the signalling + frame is still alive, so there is nothing to copy and nothing to own. *) + | Tast.Signal (id, c) -> + let p = addr f c in + ins f "call void @flan_signal(i32 %d, ptr %s)" id p; + "zeroinitializer" + | Tast.Handled (frames, body) -> emit_handled f frames body (* Where a global's storage is. A global the host was built with is a symbol; one introduced since lives wherever [flan_dev_global] put it. *) @@ -467,6 +481,38 @@ and extern_call f ret name args = t end +(* Establishing a handler is two stores and a push, per spec-conditions.md §2, + and the frame lives on this function's own stack. Popping is by frame rather + than by count: restoring what this one displaced is right even if something + below it left the stack out of step. + + The body may not [return] — the checker rejects that — so the pops here are + on the only path out. *) +and emit_handled f frames body = + let allocated = + List.map + (fun (h : Tast.hframe) -> + let slot = alloca_raw f "%handler" in + let ty = fresh f in + ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 1" + ty slot; + ins f "store i32 %d, ptr %s" h.Tast.htype ty; + let fp = fresh f in + ins f "%s = getelementptr inbounds %%handler, ptr %s, i32 0, i32 2" + fp slot; + ins f "store ptr %s, ptr %s" (fname h.Tast.hfn) fp; + ins f "call void @flan_handler_push(ptr %s)" slot; + slot) + frames + in + let last = block f body in + (* Innermost first, which is the order they were pushed in reverse. *) + List.iter + (fun slot -> ins f "call void @flan_handler_pop(ptr %s)" slot) + (List.rev allocated); + ignore last; + "zeroinitializer" + and emit_if f ty c t e = let cv = value f c in let lt = fresh_label f "then" and le = fresh_label f "else" @@ -872,6 +918,9 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher ; so a Flan struct is exactly its C struct and nothing marshals. %slice = type { ptr, i64 } +; A handler frame: the one it displaced, the condition type it matches, and +; the lifted function that runs. Allocated on the establishing frame's stack. +%handler = type { ptr, i32, ptr } declare void @flan_rt_init(i32, ptr) declare void @flan_argv(ptr) @@ -881,6 +930,9 @@ declare double @flan_bytes_to_f64(ptr, i64) declare i64 @flan_bytes_to_i64(ptr, i64) declare void @flan_f64_to_bytes(double, ptr) declare void @flan_i64_to_bytes(i64, ptr) +declare void @flan_handler_push(ptr) +declare void @flan_handler_pop(ptr) +declare void @flan_signal(i32, ptr) declare void @flan_bounds_fail(ptr, i64, i64, i64) noreturn cold declare void @flan_slice_fail(ptr, i64, i64, i64, i64) noreturn cold |} diff --git a/lib/load.ml b/lib/load.ml index 89635b5..79a08ba 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -174,6 +174,20 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = Ast.Dotimes (i, go n, List.map (rename_expr owned alias (i :: bound)) body) | Ast.Defer body -> Ast.Defer (gos body) | Ast.Unwrap (u, v) -> Ast.Unwrap (u, go v) + | Ast.Signal c -> Ast.Signal (go c) + (* A clause names a condition *type*, which an import renames like any + other, and binds a name for the condition inside its own body. *) + | Ast.HandlerBind (clauses, body) -> + Ast.HandlerBind + (List.map + (fun (c : Ast.hclause) -> + { c with + Ast.hty = rename_texpr owned alias c.Ast.hty; + hbody = + List.map (rename_expr owned alias (c.Ast.hname :: bound)) + c.Ast.hbody }) + clauses, + gos body) in { e with Ast.e = k } diff --git a/lib/parse.ml b/lib/parse.ml index 7a75edf..483e091 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -190,10 +190,40 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = | [ v ] -> mk (Ast.Unwrap (Ast.Utry, expr v)) | _ -> fail f "try is (try result-value)") + (* (signal c) : Unit, always. When every applicable handler returns normally + the signalling function simply carries on, and with no handler at all it is + a no-op — spec-conditions.md §1 and §2. *) + | Sym "signal" -> + (match args with + | [ c ] -> mk (Ast.Signal (expr c)) + | _ -> fail f "signal is (signal condition)") + + (* (handler-bind [(Type [c] body ...) ...] body ...) + + A clause names a condition type, binds the condition, and runs for effect; + matching is by type, since there is no condition hierarchy. *) + | Sym "handler-bind" -> + let clauses, body = + match args with + | { v = Vec clauses; _ } :: body when body <> [] -> (clauses, body) + | _ -> + fail f "handler-bind is (handler-bind [(Type [name] body ...) ...] body ...)" + in + let clause (c : Form.t) = + match c.Form.v with + | Form.List (ty :: { v = Form.Vec [ { v = Form.Sym n; _ } ]; _ } :: cbody) + when cbody <> [] -> + { Ast.hty = texpr ty; hname = n; hbody = List.map expr cbody; + hloc = c.Form.loc } + | _ -> + fail c "a handler-bind clause is (Type [name] body ...)" + in + mk (Ast.HandlerBind (List.map clause clauses, body_of body)) + (* Recognised, deliberately unimplemented. Rejected rather than left to fall through to Call, where they would parse and mean nothing. *) - | Sym ("handler-bind" | "handler-case" | "restart-case" | "invoke-restart" - | "signal" | "errdefer" | "with-allocator" | "loop" | "recur" + | Sym ("handler-case" | "restart-case" | "invoke-restart" + | "errdefer" | "with-allocator" | "loop" | "recur" | "defmacro" | "await" as name) -> fail f "%s is not implemented yet (see the build sequence in plan.org)" name diff --git a/lib/tast.ml b/lib/tast.ml index d977d88..20fd6ff 100644 --- a/lib/tast.ml +++ b/lib/tast.ml @@ -62,6 +62,13 @@ and expr_kind = (* (some x): unwrap Some, else early-return None from the enclosing function. An early return, not an expression that can fail — hence its own node. *) | UnwrapSome of expr + (* Conditions, spec-conditions.md. [Signal] walks the handler stack and + returns Unit whatever it finds — with nothing matching it is a no-op, so + nothing here alters control flow. [HandlerBind] pushes one frame per + clause, runs its body, and pops them; each clause was lifted into its own + function by the checker, so what is left is the frame and the call. *) + | Signal of int * expr (* type id, the condition value *) + | Handled of hframe list * expr list and place = | Plocal of int @@ -71,6 +78,10 @@ and place = | Pkey of expr * expr | Pderef of expr +(* A pushed handler: which condition type it matches, and the lifted function + that runs when one is signalled. *) +and hframe = { htype : int; hfn : string } + (* [binds] are the slots the pattern's fields are bound to, in field order. *) and arm = { acase : string option; binds : int list; abody : expr list } diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 50b61e8..6c30f55 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -16,6 +16,46 @@ #include #include +/* ── Conditions, spec-conditions.md ────────────────────────────────── */ + +/* A handler stack, and nothing more. signal walks it, calls every frame whose + * type matches, and returns; a handler that returns normally leaves the + * signalling function to carry on, and with an empty stack signal is a null + * check. Nothing here transfers control — restart-case is what will, and it + * needs a calling convention this does not. + * + * Frames are allocated by the caller, on its own stack: establishing a handler + * is two stores and a push. The condition crosses as a pointer because a + * condition is a struct and the handler runs while the signalling frame is + * still alive, so there is nothing to copy. + * + * A type is a number rather than a pointer to anything, so that a module + * compiled later against a running program agrees with it: see Check.type_id. */ + +typedef struct flan_handler { + struct flan_handler *prev; + uint32_t type_id; + void (*fn)(void *condition); +} flan_handler; + +static flan_handler *handlers; + +void flan_handler_push(flan_handler *h) { + h->prev = handlers; + handlers = h; +} + +void flan_handler_pop(flan_handler *h) { + /* By frame, not by count: restoring what this frame displaced is correct + * even if something below it got the stack out of step. */ + handlers = h->prev; +} + +void flan_signal(uint32_t type_id, void *condition) { + for (flan_handler *h = handlers; h != NULL; h = h->prev) + if (h->type_id == type_id) h->fn(condition); +} + /* [T] and string are both ptr+len — see Emit.ll. */ typedef struct { const uint8_t *ptr; int64_t len; } flan_slice; diff --git a/test/programs/conditions.flan b/test/programs/conditions.flan new file mode 100644 index 0000000..4419c5b --- /dev/null +++ b/test/programs/conditions.flan @@ -0,0 +1,45 @@ +;;;; handler-bind and signal — spec-conditions.md §1 and §2. +;;;; +;;;; The accumulation case, which is what makes these two worth having on their +;;;; own: signal returns Unit, a handler that returns normally leaves the +;;;; signalling function to carry on, and with nothing matching signal is a +;;;; no-op. No control flow is altered, so none of the transfer machinery +;;;; restart-case needs exists yet. +(defstruct AssetMissing [id i32]) +(defstruct Corrupt [id i32]) + +(defvar seen i64) +(defvar other i64) + +;;; Signals twice and keeps going both times — that is the whole of §1. +(defn load-all [] + (signal (AssetMissing {:id 1})) + (signal (AssetMissing {:id 2})) + (signal (Corrupt {:id 3}))) + +(defn main [] i32 + ;; No handler: a no-op, not an abort and not a message (§2). + (load-all) + (print-i64 seen) (newline) ; 0 + + (handler-bind [(AssetMissing [c] (set seen (+ seen (i64 (.id c)))))] + (load-all)) + (print-i64 seen) (newline) ; 1 + 2 = 3 + + ;; Two clauses, and only the matching one runs for each condition. + (handler-bind [(AssetMissing [c] (set seen (+ seen 10))) + (Corrupt [c] (set other (+ other (i64 (.id c)))))] + (load-all)) + (print-i64 seen) (newline) ; 3 + 20 = 23 + (print-i64 other) (newline) ; 3 + + ;; Nesting: the inner frame does not displace the outer one, so both run. + (handler-bind [(Corrupt [c] (set other (+ other 100)))] + (handler-bind [(Corrupt [c] (set other (+ other 1000)))] + (signal (Corrupt {:id 0})))) + (print-i64 other) (newline) ; 3 + 1000 + 100 = 1103 + + ;; And the stack is back to what it was: no handler, no effect. + (load-all) + (print-i64 other) (newline) ; 1103 + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 8e9af15..1e73a8d 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -109,6 +109,13 @@ let () = outputs "value semantics" "programs/values.flan" values_out; outputs "machine surface" "programs/machine.flan" machine_out; outputs "unit main exits 0" "programs/unit-main.flan" "ok\n"; + (* handler-bind and signal, spec-conditions.md §1 and §2: signal returns + Unit and carries on, an unhandled one is a no-op, a nested frame does + not displace the one outside it, and the stack is restored after. *) + let conditions_out = "0\n3\n23\n3\n1103\n1103\n" in + outputs "conditions" "programs/conditions.flan" conditions_out; + outputs ~opt:"-O0" "conditions, -O0" "programs/conditions.flan" conditions_out; + outputs ~dev:true "conditions, dev" "programs/conditions.flan" conditions_out; (* The raylib FFI, headless. GetColor and the enums need no window, so the whole boundary is exercised without a display: a struct returned through diff --git a/test/test_flan.ml b/test/test_flan.ml index 711a3ed..27d222a 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -626,6 +626,33 @@ let () = rejects_check "a genuinely unknown constant still reports itself" "(defconst a (+ nope 1))" ~needle:"unknown name nope"; + (* ── Conditions, spec-conditions.md §1 and §2 ──────────────────── *) + + accepts "handler-bind over a struct condition" + "(defstruct C [id i32]) (defvar n i64)\n\ + (defn f [] (handler-bind [(C [c] (set n 1))] (signal (C {:id 2}))))"; + (* Matching is by type and there is no hierarchy, so a condition has to be a + struct — an integer would have nothing to match against. *) + rejects_check "signalling a non-struct" + "(defn f [] (signal 1))" ~needle:"a condition is a struct"; + (* A handler is lifted into a function of its own, so the establishing + function's locals are not there. Capturing them is a closure, which is + milestone 5 — until then it is refused for the reason it is refused for + rather than as an unknown name. *) + rejects_check "a handler capturing a local" + "(defstruct C [id i32])\n\ + (defn f [] (let [n 0] (handler-bind [(C [c] (set n 1))] (signal (C {:id 2})))))" + ~needle:"a handler cannot see n"; + (* The frames are popped on the way out of the body, so an early exit would + leave them on the stack pointing into a function that has gone. *) + rejects_check "return inside handler-bind" + "(defstruct C [id i32])\n\ + (defn f [] i32 (handler-bind [(C [c] (signal c))] (return 1)) 0)" + ~needle:"return is not allowed inside handler-bind"; + (* Everything the four operators do not yet cover still says so by name. *) + rejects_check "restart-case is still unimplemented" + "(defn f [] (restart-case 1 (skip [] 2)))" ~needle:"not implemented yet"; + (* ── The acceptance program checks end to end ──────────────────── *) accepts "calc-me.flan type checks" (In_channel.with_open_bin "../calc-me.flan" In_channel.input_all);