From c1916ed819e7a0ca579c387710528d9fe37c6598 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 17:07:01 +0700 Subject: [PATCH 1/5] e as g is any test of a condition's and chain, binding g for the rest of the chain and the block. --- TODO.org | 5 ++ emacs/flan-fln-mode.el | 16 +++- emacs/test-flan-fln.el | 10 +++ lib/ast.ml | 15 ++++ lib/check.ml | 83 ++++++++++++++++++- lib/indent_reader.ml | 147 +++++++++++++++++++++------------ lib/load.ml | 4 +- lib/parse.ml | 24 ++++++ spec-syntax.md | 32 +++++-- test/programs/as-chain-dyn.fln | 31 +++++++ test/programs/as-chain.fln | 90 ++++++++++++++++++++ test/test_acceptance.ml | 7 +- test/test_syntax.ml | 48 ++++++++--- 13 files changed, 435 insertions(+), 77 deletions(-) create mode 100644 test/programs/as-chain-dyn.fln create mode 100644 test/programs/as-chain.fln diff --git a/TODO.org b/TODO.org index c54bcdc7..fb813245 100644 --- a/TODO.org +++ b/TODO.org @@ -34,6 +34,11 @@ Decided (133): =x?= is a bool; =if x?=, =elif x?=, =while x?= and the rest of an make a local Option its payload in the block, in place (not a copy). Assigning an Option to it there is refused rather than ending the narrowing; =e? as g= names what a test found. Rules out =if let g = x= over a plain name, which is refused toward these. +** DONE e as g inside an and chain +CLOSED: [2026-09-26] +Decided (136): =e as g= (or =e? as g=) is any test of a condition's =and= chain, binding =g= +for the rest of the chain and the block, and a kept =when= with one is one flat Option. Rules +out =as= as a cast (only an Option or a dyn), and a binding under =or=, =not= or =until=. ** TODO The stepper does not step inside an optional chain =Ast.step_expr= treats a =Chain= as a leaf (its catch-all), so nothing in a chain's body gets a step point of its own. diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index fe93577d..1c53b045 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -1807,6 +1807,19 @@ it, so a block pasted at another depth stays one block." (defun flan-fln--fallback-re (heads) (concat "^" (regexp-opt heads t) "(" flan-fln--name-re)) +(defun flan-fln--as-matcher (limit) + "Find the next `as' of a condition up to LIMIT, `if e as g and ...': an +`as' before a name, on a line an `if', `elif', `while' or `when' comes first on." + (let (found) + (while (and (not found) + (re-search-forward "[ \t]\\(as\\)[ \t]+[^][ \t\n(){},;\":]" limit t)) + (setq found (save-excursion + (save-match-data + (goto-char (match-beginning 1)) + (re-search-backward "\\_<\\(?:if\\|elif\\|while\\|when\\)\\_>" + (line-beginning-position) t))))) + found)) + (defun flan-fln--return-type-matcher (limit) "Find the next return type up to LIMIT: after the `->' of a fn header, a lambda or a `Fn(...)' type, and not after a match arm's." @@ -1881,8 +1894,9 @@ lambda or a `Fn(...)' type, and not after a match arm's." ;; The words inside a line: `for i in range(n)', `if c then a else b', a ;; `where' constraint. ("[ \t]\\(then\\|else\\|in\\|where\\)[ \t]" 1 font-lock-keyword-face) - ;; A test's `as', `if e? as g'. + ;; A test's `as', `if e? as g', and a condition's, `if e as g and ...'. ("?[ \t]+\\(as\\)[ \t]" 1 font-lock-keyword-face) + (flan-fln--as-matcher 1 font-lock-keyword-face) ;; `if let Some(g) = x', and a value's `if' or `when', `x = when c then a'. ("\\_<\\(?:el\\)?if[ \t]+\\(let\\)[ \t]" 1 font-lock-keyword-face) ("[ \t=(,]\\(if\\|when\\)[ \t]" 1 font-lock-keyword-face) diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el index 42ec72af..4a6a4fbe 100644 --- a/emacs/test-flan-fln.el +++ b/emacs/test-flan-fln.el @@ -938,6 +938,16 @@ defconst(k, 3) (search-forward "g!") (backward-char 1) (test-flan-fln--is "the name at x! is x" (thing-at-point 'symbol t) "g")) +;; A condition's `as' with no `?' before it, twice on a line; an `as' outside +;; a condition is left alone. +(test-flan-fln--in "fn f()\n left = when get(grid, r) as g and b(g) as h then g\n x = as y\n" + (font-lock-ensure) + (let ((face (lambda (needle) + (save-excursion (goto-char (point-min)) (search-forward needle) + (get-text-property (match-beginning 0) 'face))))) + (test-flan-fln--is "a condition's as is a keyword" (funcall face "as g") 'font-lock-keyword-face) + (test-flan-fln--is "and a second one" (funcall face "as h") 'font-lock-keyword-face) + (test-flan-fln--is "an as outside a condition is not" (funcall face "as y") nil))) (test-flan-fln--is "after if x? as g, one level deeper" (test-flan-fln--tabs "fn f() -> ()\n if o? as g\n|" 1) 4) (with-temp-buffer diff --git a/lib/ast.ml b/lib/ast.ml index 2d85db01..e20f43e4 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -632,3 +632,18 @@ let mark_pause ?fn ~line ~col (ds : decl list) : decl list option = in let ds = List.map decl ds in if !hit then Some ds else None + +(* The names the [as] tests of condition [c] bind (decision 136), for the + block [c] guards. [Parse.as_chain] reads the chain to this shape: each + test an [If] with [false] for its else, each [as] an [IfLet] over a plain + name with the rest of the chain as its body and [false] for its else. *) +let as_name g = + g <> "" && (match g.[0] with 'A' .. 'Z' -> false | _ -> true) + && g <> "true" && g <> "false" + +let rec as_binds (c : expr) = + match c.e with + | If (_, q, Some { e = Var "false"; _ }) -> as_binds q + | IfLet (_, { pat = Pctor (g, []); body = [ q ]; _ }, Some { e = Var "false"; _ }) + when as_name g -> g :: as_binds q + | _ -> [] diff --git a/lib/check.ml b/lib/check.ml index 48360e96..8771c299 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -6480,7 +6480,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = fail loc "%s is tested with %s? above, so in this block it is %s, and it \ cannot be given an Option here: the block reads it as present \ - throughout. Assign a %s, or test a new name, as in while %s? as \ + throughout. Assign a %s, or test a new name, as in while %s as \ item, and assign %s from that" n n (tyname loc b.bty) (tyname loc b.bty) n n | _ -> raise (Loc.Error d))) @@ -8525,12 +8525,29 @@ and check_if ctx ?(tail = false) ?(used = false) ?want loc c t e = raise ex) and check_if_once ctx ~tail ~used ?want loc c t e = + if as_binds c = [] then check_if_tested ctx ~tail ~used ?want loc c t e + else scoped ctx (fun () -> check_if_tested ctx ~tail ~used ?want loc c t e) + +and check_if_tested ctx ~tail ~used ?want loc c t e = let t = match narrows c with | [] -> t | names -> { t with Ast.e = Ast.Narrow (names, t) } in - let c = check_truthy ctx c in + let c, t = + match as_binds c with + | [] -> (check_truthy ctx c, t) + | _ -> + (* What an [as] named reaches the block through a name no reader can + write, bound in the scope this if was given; the else is checked + without it. *) + let cv, named = as_cond ctx c in + let bnd (g, h) = + { Ast.bname = g; bty = None; bval = { Ast.e = Ast.Var h; loc = t.Ast.loc }; + bloc = t.Ast.loc } + in + (cv, { t with Ast.e = Ast.Let (List.map bnd named, [ t ]) }) + in (* Both arms are the tail, and a one-armed [if] counts: [(when c (recur ...))] is how nearly every loop is written, and the branch is still the last thing the body does. Both arms are kept when the [if] is. *) @@ -10673,8 +10690,68 @@ and narrows (c : Ast.expr) = match c.Ast.e with | Ast.Call ({ Ast.e = Ast.Var "?"; _ }, [ { Ast.e = Ast.Var x; _ } ]) -> [ x ] | Ast.If (p, q, Some { Ast.e = Ast.Var "false"; _ }) -> narrows p @ narrows q + | Ast.IfLet (_, { Ast.pat = Ast.Pctor (g, []); body = [ q ]; _ }, + Some { Ast.e = Ast.Var "false"; _ }) when as_name g -> narrows q | _ -> [] +and as_binds c = Ast.as_binds c + +and as_name g = Ast.as_name g + +(* A condition with [as] in it, as the bool it tests, and each name it binds + with the hidden name the block reads it through. The chain runs left to + right and stops at the first test that fails, so each value is found + once; what an [as] finds is copied into its name's slot there, and a + later test and the block read that slot. *) +and as_cond ctx (c : Ast.expr) = + let named = ref [] in + let no loc = mk loc Types.Bool (Tast.Bool false) in + let rec go (c : Ast.expr) = + let loc = c.Ast.loc in + match c.Ast.e with + | Ast.If (p, q, Some { Ast.e = Ast.Var "false"; _ }) when as_binds q <> [] -> + let pv = check_truthy ctx p in + let qv = with_narrowed ctx (narrows p) (fun () -> go q) in + mk loc Types.Bool (Tast.If (pv, qv, no loc)) + | Ast.IfLet (e, { Ast.pat = Ast.Pctor (g, []); body = [ q ]; _ }, + Some { Ast.e = Ast.Var "false"; _ }) when as_name g -> + let ev = check ctx e in + let hs = fresh_slot ctx ev.Tast.ty in + let hv = mk loc ev.Tast.ty (Tast.Local hs) in + let test, payload, ty = + match ev.Tast.ty with + | Types.Option t -> (opt_is_some loc hv, opt_payload loc t hv, t) + | Types.Dyn -> (dyn_not_nil loc hv, hv, Types.Dyn) + | t -> + Loc.failk "check/as-not-optional" e.Ast.loc + "%s is %s, which always holds a value, so as has nothing to test. \ + as names what an Option or a dyn holds, when it holds something. \ + It is not a conversion: a number is converted with its type's \ + name, as in i32(x)" + (source_text e) (tyname loc t) + in + let slot, qv = + scoped ctx (fun () -> + let slot = bind ctx g ty ~assignable:false in + (match lookup ctx g with + | Some b -> + incr held_n; + named := (g, Printf.sprintf "~as%d" !held_n, b) :: !named + | None -> ()); + (slot, go q)) + in + mk loc Types.Bool + (Tast.Let ([ (hs, ev) ], + [ mk loc Types.Bool + (Tast.If (test, mk loc Types.Bool (Tast.Let ([ (slot, payload) ], [ qv ])), + no loc)) ])) + | _ -> check_truthy ctx c + in + let cv = go c in + let named = List.rev !named in + List.iter (fun (_, h, b) -> ctx.scope <- (h, b) :: ctx.scope) named; + (cv, List.map (fun (g, h, _) -> (g, h)) named) + (* [f] with each of [names] that is a local (Option T) read as its payload: the same slot, so a field set through it lands in the Option itself. A dyn stays as it is; a name that is not a local is not narrowed. Assigning @@ -10717,7 +10794,7 @@ and with_narrowed : 'a. ctx -> string list -> (unit -> 'a) -> 'a = fun ctx names (Printf.sprintf "%s? does not make %s its payload here: %s's address \ is taken, or a fn assigns it, in this function, so \ - something else could clear it. Write if %s? as g, \ + something else could clear it. Write if %s as g, \ which copies what it holds into g" n n n n) ] } in diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 3898b753..448d3ba8 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -994,7 +994,7 @@ let no_place (e : Form.t) = failk "chain-assign" e.loc "%s is an optional chain, and a chain cannot be assigned to: when it \ holds nothing there is no place to write. Test it first: if %s?, and \ - in the block %s is what it holds, or if %s? as g, then assign through g" + in the block %s is what it holds, or if %s as g, then assign through g" (text_of e) r r r | Form.List [ { v = Form.Sym "!!"; _ }; x ] -> let r = text_of x in @@ -1376,12 +1376,7 @@ and if_expr p = let t = advance p in let word = match t.tok with NAME w -> w | _ -> "if" in let letp = if word = "if" then if_let_head p else None in - let c = match letp with Some m -> m | None -> fst (binary p 1) in - let letp, c = - match letp with - | Some _ -> (letp, c) - | None -> (match as_head p c with Some m when word = "if" -> (Some m, m) | _ -> (None, c)) - in + let c = match letp with Some m -> m | None -> cond_head p in (match (peek p).tok with | NAME "then" -> ignore (advance p) | _ -> @@ -1422,35 +1417,79 @@ and if_let_head p = failk "if-let-name" pat.loc "if let %s = %s has no pattern to test. To test that %s holds a \ value, write if %s?, and in the block it is what it holds; to name \ - what it holds, write if %s? as %s" + what it holds, write if %s as %s" g (text_of v) (text_of v) (text_of v) (text_of v) g | _ -> ()); Some (mk p lt.loc (Form.Vec [ pat; v ])) | _ -> None -(* [e? as g]: after a test [e?], the name what [e] holds is bound to, as - the head [[g e]] an [if let] over a plain name stands as (decision 133). *) -and as_head p (c : Form.t) = +(* A condition, where [e as g] may stand as a test of a top-level [and] + chain (decisions 133, 136): [e] holds a value, and [g] names it for the + rest of the chain and the block. [e? as g] is the same test. Each binding + reads [(as g e)] in its test's place, in one flat [(and ...)]; the checker + gives [g] its scope. It cannot stand under [or] or [not], where the test + holding would not mean [e] held anything. *) +and cond_head p = + let x, lvl = binary p 1 in match (peek p).tok with - | NAME "as" -> - let at = advance p in - (match c.v with - | Form.List [ { v = Form.Sym "?"; _ }; e ] -> - let g = - match (peek p).tok with - | NAME g when g <> "" && g.[0] <> '.' -> - let gt = advance p in - check_name gt g; - sym gt.loc g - | tk -> - failk "as-name" (where_ p) "as takes the name to bind, and found %s" (show tk) - in - Some (Form.make (Form.Vec [ g; e ]) c.loc) - | _ -> - failk "as-test" at.loc - "as names what a test found, and %s is not one. Write %s? as name" - (text_of c) (text_of c)) - | _ -> None + | NAME "as" -> as_chain p x lvl + | _ -> x + +and as_chain p (x : Form.t) lvl = + let at = advance p in + let refuse_or loc = + failk "as-or" loc + "as names what a test found, for the rest of an and chain and the \ + block. With or, the block can run when that test did not hold, and \ + there would be nothing to name. Bind with as in an if of its own, and \ + test the rest inside it" + in + let items (f : Form.t) = + match f.v with + | Form.List ({ v = Form.Sym "and"; _ } :: (_ :: _ as xs)) -> xs + | _ -> [ f ] + in + if lvl = 1 then refuse_or x.loc; + let before, last = + match List.rev (if lvl = 2 then items x else [ x ]) with + | last :: rb -> (List.rev rb, last) + | [] -> ([], x) + in + (match last.v with + | Form.List ({ v = Form.Sym "not"; _ } :: _) -> + failk "as-not" at.loc + "as names what a test found, and not turns the test around: the \ + block runs when %s holds nothing, so there is nothing to name. Bind \ + with as, and put what runs when it is absent in the else" + (text_of last) + | Form.List ({ v = Form.Sym "or"; _ } :: _) -> refuse_or last.loc + | _ -> ()); + let e = match last.v with Form.List [ { v = Form.Sym "?"; _ }; e ] -> e | _ -> last in + let g = + match (peek p).tok with + | NAME g when g <> "" && g.[0] <> '.' && not (is_op_word g) -> + let gt = advance p in + check_name gt g; + sym gt.loc g + | tk -> failk "as-name" (where_ p) "as takes the name to bind, and found %s" (show tk) + in + let bound = Form.make (Form.List [ sym at.loc "as"; g; e ]) last.loc in + let rest = + match (peek p).tok with + | NAME "and" -> + ignore (advance p); + let y, ylvl = binary p 1 in + (match (peek p).tok with + | NAME "as" -> items (as_chain p y ylvl) + | _ -> + if ylvl = 1 then refuse_or y.loc; + if ylvl = 2 then items y else [ y ]) + | NAME "or" -> refuse_or (peek p).loc + | _ -> [] + in + match before @ (bound :: rest) with + | [ one ] -> one + | xs -> Form.make (Form.List (sym x.loc "and" :: xs)) x.loc (* The if an [if let] head was read into, rewritten to (if-let [P v] then else): [(if [P v] a b)], [(when [P v] body ...)] and an elif chain's @@ -2691,12 +2730,7 @@ and header (s : st) w : Form.t = form [ alias; path ] | "if" | "when" -> let letp = if w = "if" then if_let_head p else None in - let c = match letp with Some m -> m | None -> fst (binary p 1) in - let letp, c = - match letp with - | Some _ -> (letp, c) - | None -> (match as_head p c with Some m when w = "if" -> (Some m, m) | _ -> (None, c)) - in + let c = match letp with Some m -> m | None -> cond_head p in (* The elif and else clauses at the if's column, then the whole form. [oneline] when the if was [if c then a]: its clauses may then be one-line too, [elif c then x] and [else y], or take blocks. *) @@ -2713,11 +2747,7 @@ and header (s : st) w : Form.t = let c = match if_let_head p with | Some m -> elif_lets := m :: !elif_lets; m - | None -> - let c = fst (binary p 1) in - (match as_head p c with - | Some m -> elif_lets := m :: !elif_lets; m - | None -> c) + | None -> cond_head p in (match (peek p).tok with | NAME "then" when oneline -> @@ -2829,21 +2859,30 @@ and header (s : st) w : Form.t = | KW k, n when n <> NEWLINE -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ] | _ -> [] in - let c, _ = expr p in - (match (if w = "while" then as_head p c else None) with - (* [while e? as g]: [(while true (if-let [g e] (do body) (break)))]. A - break or continue in the body is this loop's. *) - | Some m -> - expect_line_end p ~after:(w ^ " " ^ text_of c ^ " as ..."); - let body = block s ~after:w in + let c = cond_head p in + let binds = + let is_as (f : Form.t) = + match f.v with Form.List ({ v = Form.Sym "as"; _ } :: _) -> true | _ -> false + in + match c.v with + | Form.List ({ v = Form.Sym "and"; _ } :: xs) -> List.exists is_as xs + | _ -> is_as c + in + if binds && w = "until" then + failk "as-until" c.Form.loc + "until runs while its test does not hold, so as would name what a \ + test found when it found nothing. Write while, with the test the \ + other way round"; + expect_line_end p ~after:(w ^ " " ^ text_of c); + let body = block s ~after:w in + if binds then + (* [while c]: [(while true (if c (do body) (break)))], so what [c] + binds reaches the body. A break or continue in the body is this + loop's, and a continue tests [c] again. *) let at = c.Form.loc in let f items = Form.make (Form.List items) at in - form (label @ [ sym at "true"; - f [ sym at "if-let"; m; f (sym at "do" :: body); f [ sym at "break" ] ] ]) - | None -> - expect_line_end p ~after:(w ^ " " ^ text_of c); - let body = block s ~after:w in - form (label @ (c :: body))) + form (label @ [ sym at "true"; f [ sym at "if"; c; f (sym at "do" :: body); f [ sym at "break" ] ] ]) + else form (label @ (c :: body)) | "for" -> let label = match (peek p).tok with diff --git a/lib/load.ml b/lib/load.ml index 1ac7734c..1809fecc 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -255,7 +255,9 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = (bound, []) bs in Ast.Let (List.rev bs, List.map (rename_expr owned alias bound) body) - | Ast.If (c, t, e') -> Ast.If (go c, go t, Option.map go e') + (* What an [as] in the condition binds is bound in the block. *) + | Ast.If (c, t, e') -> + Ast.If (go c, rename_expr owned alias (Ast.as_binds c @ bound) t, Option.map go e') | Ast.While (l, c, body) -> Ast.While (l, go c, gos body) (* A loop's names are its own and are never imported; its initial values and its body are ordinary expressions. *) diff --git a/lib/parse.ml b/lib/parse.ml index 757f8803..f34cefde 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -508,6 +508,8 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr = | _ -> fail f "?. is (?. [name value] body)") (* Short-circuiting, so they cannot be ordinary calls. *) + | Sym "and" when List.exists is_as args -> as_chain f args + | Sym "as" -> as_chain f [ f ] | Sym "and" -> shortcircuit f args ~is_and:true | Sym "or" -> shortcircuit f args ~is_and:false @@ -1303,6 +1305,28 @@ and cond f (args : Form.t list) : Ast.expr = actually fix it is check_if preferring the arm that is not a compiler temp when it reports, which is check.ml's call. Written up in TODO.org, "and's last operand gets a misdirected caret". *) +(* [(as g e)]: the test that [e] holds a value, naming it [g] (decision + 136). The reader writes one only as a condition or a test of the [and] + chain that is one. Each test of that chain is an [If] whose else is + [false], and each [as] an [IfLet] over the plain name [g] whose body is + the rest of the chain and whose else is [false]; [Check.as_cond] reads + that shape and gives [g] to the block the condition guards as well. *) +and is_as (f : Form.t) = + match f.v with List ({ v = Sym "as"; _ } :: _) -> true | _ -> false + +and as_chain f (args : Form.t list) : Ast.expr = + let no (x : Form.t) = { Ast.e = Ast.Var "false"; loc = x.loc } in + let rec go = function + | [] -> { Ast.e = Ast.Var "true"; loc = f.loc } + | [ x ] when not (is_as x) -> expr x + | ({ v = List [ { v = Sym "as"; _ }; { v = Sym g; _ }; e ]; _ } as x) :: rest -> + let arm = { Ast.pat = Ast.Pctor (g, []); body = [ go rest ]; aloc = x.loc } in + { Ast.e = Ast.IfLet (expr e, arm, Some (no x)); loc = x.loc } + | x :: _ when is_as x -> fail x "as is (as name value)" + | x :: rest -> { Ast.e = Ast.If (expr x, go rest, Some (no x)); loc = x.loc } + in + go args + and shortcircuit f (args : Form.t list) ~is_and : Ast.expr = let mk e = { Ast.e; loc = f.loc } in let rec go = function diff --git a/spec-syntax.md b/spec-syntax.md index d6b13f7d..cca64da6 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -287,7 +287,7 @@ Each item: the proposal, then the reason in one line. Kept with no `else` at the end of its chain, it gives an Option as `when` does. `P` is any `match` pattern, and its names are bound in the block only. One line: `if let Some(g) = o then g else 0`. A plain name, `if let g = o`, is - refused toward `if o?` and `if o? as g` below; `_` is refused toward `let`. + refused toward `if o?` and `if o as g` below; `_` is refused toward `let`. **Built.** - **`x?` tests that a value is present** (decision 133): a bool, true when an Option is `Some` and when a dyn is not `nil`. It reads `(? x)`. In `if x?`, @@ -299,15 +299,33 @@ Each item: the proposal, then the reason in one line. present; giving it an Option is refused, and a parameter or a captured copy is no more assignable than outside it. A local whose address is taken, or that a `fn` assigns, anywhere in the function is not narrowed (something - else could clear it); `if x? as g` copies what it holds instead. A `?` after + else could clear it); `if x as g` copies what it holds instead. A `?` after a chain tests the whole chain: `o?.i?`. A capitalised name before `?` is read as a type, so a local tested this way needs a lowercase name. **Built.** -- **`e? as g`** names what a test found, for an `e` that is not a plain name: - `if get(grid, r, c)? as cell` reads `(if-let [cell (get grid r c)] …)`, an - `if-let` over a plain name, which binds what an Option holds or a dyn that - is not `nil`. It works after `if`, `elif` and `while`; `while e? as g` plus - a block reads `(while true (if-let [g e] (do …) (break)))`. **Built.** +- **`e as g`** tests that `e` holds a value and names it `g` (decisions 133, + 136): an Option that is `Some` binds its payload, a dyn that is not `nil` + binds itself. `e? as g` is the same test. Over any other type it is + refused; `as` is never a conversion, which is written `i32(x)`. It stands + after `if`, `elif`, `while` and a one-line `if … then` or kept `when`, as + the whole condition or as any test of an `and` chain, and `g` is bound for + the rest of that chain and for the block: Swift's `if let g = e, c`. + + ``` + if get(grid, r + 1, c - 1) as g and is-empty-cell(g) + move(g) + if a as x and b as y and x < y + println(x, y) + let left = when get(grid, r + 1, c - 1) as g and is-empty-cell(g) then g + ``` + + The tests run left to right and stop at the first that fails, so each + value is found once. `g` is not bound in the `else`, in an `elif` or after + the block. It is refused under `or` and `not`, and after `until`, where the + block could run with nothing found. `x?` on a plain local narrows beside it + in the same chain. Reads `(as g e)` in the test's place, `(when (and a (as + g e) (f g)) …)`; `while c` with one reads `(while true (if c (do …) + (break)))`. **Built.** - **`while c`, `until c`**, optional label first: `while :outer c`. **Built.** - **`for i in range(n)`**, `range(a, b)`, `range(a, b, step)` read as `dotimes`. `range` here is syntax, not a function. `..` is avoided because diff --git a/test/programs/as-chain-dyn.fln b/test/programs/as-chain-dyn.fln new file mode 100644 index 00000000..d7805607 --- /dev/null +++ b/test/programs/as-chain-dyn.fln @@ -0,0 +1,31 @@ +;; e as g over a dyn inside an and chain (decision 136): g is bound when e +;; is not nil, for the rest of the chain and the block. + +fn pet-name(m) + if m.pet as pet and pet != "cat" + pet + elif m.name as who and who != "bo" + who + else + "nobody" + +fn first-big(xs, lo) + let found = when get(xs, 0) as x and x > lo then x + found + +fn run(m, xs, a, b) + println(pet-name(m), pet-name({:pet "cat" :name "bo"}), pet-name({:name "ann"})) + println(first-big(xs, 0), first-big(xs, 5), first-big([], 0)) + let i = 0 + let total = 0 + while get(xs, i) as x and x > 0 + total += x + i += 1 + println(total, i) + if a? and get(xs, 1) as y and a + y > 4 + println(a + y) + let v = if b as z and z > 1 then z else -1 + println(v) + +fn main() + run({:pet "dog" :name "ann"}, [4, 2, 0, 7], 3, nil) diff --git a/test/programs/as-chain.fln b/test/programs/as-chain.fln new file mode 100644 index 00000000..eda9bc5b --- /dev/null +++ b/test/programs/as-chain.fln @@ -0,0 +1,90 @@ +;; e as g inside an and chain (decision 136): g is bound for the rest of the +;; chain and for the block, and not in the else, an elif or after the block. +;; e? as g is the same test. + +struct Grain + color-idx: i32 + +let calls: i32 = 0 + +fn get-cell(grid: [4 i32], i: i32) -> Grain? + calls += 1 + if i < 0 or i >= 4 + return None + Some(Grain{.color-idx grid[i]}) + +fn is-empty-cell(g: Grain) -> bool + g.color-idx < 0 + +fn tick(n: i32) -> i32 + calls += 1 + print(n, "") + n + +fn half(n: i32) -> i32? + calls += 1 + if n % 2 == 0 then Some(n / 2) else None + +fn classify(grid: [4 i32], i: i32) -> str + if get-cell(grid, i) as g and is-empty-cell(g) + "empty" + elif get-cell(grid, i) as g and g.color-idx > 1 + "big" + elif half(i) as h and h > 0 + "half" + else + "other" + +fn main() + let grid = [1, -1, 2, -3] + ;; A block if, with an else that does not see g. + let g = 100 + if get-cell(grid, 1) as g and is-empty-cell(g) + println("empty", g.color-idx) + if get-cell(grid, 0) as g and is-empty-cell(g) + println("empty", g.color-idx) + else + println("else sees the outer g", g) + println("after", g) + ;; A kept when gives a Grain?. + let left = when get-cell(grid, 3) as g and is-empty-cell(g) then g + println(left!.color-idx) + let none: Grain? = when get-cell(grid, 0)? as g and is-empty-cell(g) then g + println(none?) + ;; Two bindings, and a test over both. + let a: i32? = Some(3) + let b: i32? = Some(5) + if a as x and b as y and x < y + println(x, y) + if a as x and b as y and x > y + println(x, y) + else + println("not less") + ;; One line, in a let. + let v = if half(8) as h and h > 3 then h * 10 else -1 + let w = if half(6) as h and h > 3 then h * 10 else -1 + println(v, w) + ;; An elif chain. + println(classify(grid, 1), classify(grid, 2), classify(grid, 0), classify(grid, 4), classify(grid, 5)) + ;; Each value is found once, left to right, and a failed test stops the chain. + calls = 0 + if tick(1) > 0 and half(tick(2)) as h and tick(3) + h > 0 + println("ran", h) + println(calls) + calls = 0 + if tick(1) > 0 and half(tick(3)) as h and tick(5) + h > 0 + println("ran", h) + else + println("stopped") + println(calls) + ;; x? narrows beside as in one chain. + let n: i32? = Some(40) + if n? and half(n) as h and n + h > 50 + println(n + h) + ;; while: pop while the next cell is empty. + let i = 1 + let seen = 0 + while get-cell(grid, i) as c and is-empty-cell(c) + seen += c.color-idx + i += 2 + println(seen, i) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 1233fb1c..1484a776 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2275,7 +2275,12 @@ let () = outputs ~x86:true (path ^ ", --x86") ("programs/" ^ path) want) [ ("optionals.fln", optionals_out); ("optionals-dyn.fln", optionals_dyn_out); (* x? tests and narrows, e? as g names what it found (decision 133). *) - ("presence.fln", "true false true\n6\n-1\n3\n101 209 0\n11\n42\n2\nabsent\n6\nfalse true\n3\n6\n15\n"); ("presence-dyn.fln", "true false\n103 209 0\nno pet\nann\n3 2\n") ]; + ("presence.fln", "true false true\n6\n-1\n3\n101 209 0\n11\n42\n2\nabsent\n6\nfalse true\n3\n6\n15\n"); ("presence-dyn.fln", "true false\n103 209 0\nno pet\nann\n3 2\n"); + (* e as g inside an and chain, typed and dyn (decision 136). *) + ("as-chain.fln", + "empty -1\nelse sees the outer g 100\nafter 100\n-3\nfalse\n3 5\nnot less\n40 -1\n\ + empty big other half other\n1 2 3 ran 1\n4\n1 3 stopped\n3\n60\n-4 5\n"); + ("as-chain-dyn.fln", "dog nobody ann\n4 nil nil\n6 2\n5\n-1\n") ]; (* x! over nothing traps at its site and names the expression. *) List.iter (fun (x86, arg, want) -> diff --git a/test/test_syntax.ml b/test/test_syntax.ml index d64e413d..8791d8a3 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -1409,21 +1409,49 @@ let () = found; if let over a plain name is refused toward those. *) refuses "if let over a plain name" "if let g = x\n g" "indent/if-let-name" "write if x?, and in the block it is what it holds; to name what it holds, \ - write if x? as g"; + write if x as g"; reads "x? is a test" "y = f(x)? and not z.w?" "(set y (and (? (f x)) (not (? (.w z)))))"; reads "e? as g" "if f(x)? as g\n g\nelif y? as h\n h\nelse\n 0" - "(if-let [g (f x)] g (if-let [h y] h 0))"; - reads "one-line e? as g" "v = if y? as h then h else 0" "(set v (if-let [h y] h 0))"; + "(cond (as g (f x)) g (as h y) h :else 0)"; + reads "one-line e? as g" "v = if y? as h then h else 0" "(set v (if (as h y) h 0))"; reads "while e? as g" "while pop(s)? as x\n f(x)" - "(while true (if-let [x (pop s)] (do (f x)) (break)))"; - refuses "as after no test" "if x as y\n y" "indent/as-test" "Write x? as name"; + "(while true (if (as x (pop s)) (do (f x)) (break)))"; + (* Decision 136: e as g without the ?, and inside an and chain. *) + reads "e as g" "if f(x) as g\n g" "(when (as g (f x)) g)"; + reads "as in an and chain" "if a and f(x) as g and g > 1 and b\n g" + "(when (and a (as g (f x)) (> g 1) b) g)"; + reads "two as in one chain" "v = if a as x and b? as y and x < y then x else y" + "(set v (if (and (as x a) (as y b) (< x y)) x y))"; + reads "a kept when with as" "left = when get(grid, r + 1, c - 1) as g and is-empty-cell(g) then g" + "(set left (when (and (as g (get grid (+ r 1) (- c 1))) (is-empty-cell g)) g))"; + reads "while as and" "while pop(s) as x and x > 0\n f(x)" + "(while true (if (and (as x (pop s)) (> x 0)) (do (f x)) (break)))"; + reads "elif as and" "if a\n 1\nelif f(x) as g and g > 1\n g" + "(cond a 1 (and (as g (f x)) (> g 1)) g)"; + refuses "as under or" "if a or f(x) as g\n g" "indent/as-or" "Bind with as in an if of its own"; + refuses "or after as" "if f(x) as g or b\n g" "indent/as-or" "nothing to name"; + refuses "or later in the chain" "if f(x) as g and a or b\n g" "indent/as-or" "nothing to name"; + refuses "as under not" "if not f(x) as g\n g" "indent/as-not" "not turns the test around"; + refuses "as after until" "until f(x) as g\n g" "indent/as-until" "Write while"; + refused "as-not-optional.fln" "fn main()\n let n = 5\n if n as g and g > 1\n println(g)\n" + [ "n is i32, which always holds a value, so as has nothing to test"; + "It is not a conversion" ]; + refused "as-not-in-else.fln" + "fn f(o: i32?) -> i32\n if o as g and g > 1\n g\n else\n g\n\nfn main()\n println(f(None))\n" + [ "unknown name g" ]; + refused "as-not-in-elif.fln" + "fn f(o: i32?) -> i32\n if o as g and g > 1\n g\n elif g > 0\n 1\n else\n 0\n\nfn main()\n println(f(None))\n" + [ "unknown name g" ]; + refused "as-not-after.fln" + "fn f(o: i32?) -> i32\n if o as g and g > 1\n println(g)\n g\n\nfn main()\n println(f(None))\n" + [ "unknown name g" ]; refused "present-i32.fln" "fn main()\n let x = 5\n println(x?)\n" [ "x is i32, which always holds a value, so x? has nothing to test"; "a yes-or-no name starts with is- or has-, as in is-x" ]; refused "narrowed-set.fln" "fn main()\n let x: i32? = Some(1)\n if x?\n x = None\n println(x ?? 0)\n" [ "x is tested with x? above, so in this block it is i32"; - "while x? as item" ]; + "while x as item" ]; refused "not-narrowed-in-else.fln" "fn main()\n let x: i32? = None\n if x?\n println(x + 1)\n else\n println(x + 1)\n" [ "Option(i32)" ]; @@ -1457,7 +1485,7 @@ let () = reads "a trailing ? tests the whole chain" "y = o?.i?" "(set y (? (?. [~o1 o] (.i ~o1))))"; reads "and ? then as binds the chain's result" "if d?.k? as k\n k" - "(if-let [k (?. [~o1 d] (.k ~o1))] k)"; + "(when (as k (?. [~o1 d] (.k ~o1))) k)"; refused "narrowed-param.fln" "fn f(x: i32?)\n if x?\n x += 100\n\nfn main()\n f(Some(1))\n" [ "x is a parameter, and a parameter is not assignable" ]; @@ -1465,7 +1493,7 @@ let () = "fn main()\n let x: i32? = Some(1)\n if x?\n x.n = 1\n" [ "so here it is what the Option holds, i32, and i32 has no fields" ]; refuses "a chain is no place, and the fix is a test" "q?.x = 5" "indent/chain-assign" - "Test it first: if q?, and in the block q is what it holds, or if q? as g"; + "Test it first: if q?, and in the block q is what it holds, or if q as g"; refused "lowercase-type-arg.fln" "struct grain\n w: i32\n\nfn main()\n let v = vec-new(grain?)\n" [ "grain? here is the test that a value is present, and grain is a type"; @@ -1826,9 +1854,9 @@ let () = | _ -> fail "addr-taken-note.fln checked" | exception (Loc.Error d | Loc.Errors (d :: _)) -> if not (List.exists - (fun (n : Loc.note) -> Test_support.contains n.Loc.nmsg "Write if x? as g") + (fun (n : Loc.note) -> Test_support.contains n.Loc.nmsg "Write if x as g") d.Loc.notes) - then fail "addr-taken-note.fln: no note naming if x? as g on: %s" d.Loc.dmsg + then fail "addr-taken-note.fln: no note naming if x as g on: %s" d.Loc.dmsg | exception e -> fail "addr-taken-note.fln: %s" (diag_text e) let () = Test_support.report ~label:"syntax" () From 87709618f9fdf501402bc84f4e1884b7d7331621 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 17:15:24 +0700 Subject: [PATCH 2/5] An as chain's refusals quote the whole condition, and narrowing after an as is tested. --- lib/indent_reader.ml | 4 ++-- test/programs/as-chain.fln | 2 ++ test/test_acceptance.ml | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 448d3ba8..286b95db 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -1473,7 +1473,7 @@ and as_chain p (x : Form.t) lvl = sym gt.loc g | tk -> failk "as-name" (where_ p) "as takes the name to bind, and found %s" (show tk) in - let bound = Form.make (Form.List [ sym at.loc "as"; g; e ]) last.loc in + let bound = mk p last.loc (Form.List [ sym at.loc "as"; g; e ]) in let rest = match (peek p).tok with | NAME "and" -> @@ -1489,7 +1489,7 @@ and as_chain p (x : Form.t) lvl = in match before @ (bound :: rest) with | [ one ] -> one - | xs -> Form.make (Form.List (sym x.loc "and" :: xs)) x.loc + | xs -> mk p x.loc (Form.List (sym x.loc "and" :: xs)) (* The if an [if let] head was read into, rewritten to (if-let [P v] then else): [(if [P v] a b)], [(when [P v] body ...)] and an elif chain's diff --git a/test/programs/as-chain.fln b/test/programs/as-chain.fln index eda9bc5b..4bdd4055 100644 --- a/test/programs/as-chain.fln +++ b/test/programs/as-chain.fln @@ -81,6 +81,8 @@ fn main() let n: i32? = Some(40) if n? and half(n) as h and n + h > 50 println(n + h) + if half(6) as h and n? and n + h > 40 + println(n + h) ;; while: pop while the next cell is empty. let i = 1 let seen = 0 diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 1484a776..7fc52f1f 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2279,7 +2279,7 @@ let () = (* e as g inside an and chain, typed and dyn (decision 136). *) ("as-chain.fln", "empty -1\nelse sees the outer g 100\nafter 100\n-3\nfalse\n3 5\nnot less\n40 -1\n\ - empty big other half other\n1 2 3 ran 1\n4\n1 3 stopped\n3\n60\n-4 5\n"); + empty big other half other\n1 2 3 ran 1\n4\n1 3 stopped\n3\n60\n43\n-4 5\n"); ("as-chain-dyn.fln", "dog nobody ann\n4 nil nil\n6 2\n5\n-1\n") ]; (* x! over nothing traps at its site and names the expression. *) List.iter From e4d0e9c60eed160de750f5d2ed90b044056b121f Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 17:52:06 +0700 Subject: [PATCH 3/5] A pause mark on any column of a condition keeps what it binds, an as in parentheses gets its own refusal, and what an as finds is held in one slot. --- TODO.org | 4 +++ lib/ast.ml | 25 +++++++++++++++++- lib/check.ml | 61 ++++++++++++++++++++++++++------------------ lib/indent_reader.ml | 7 +++++ lib/load.ml | 3 ++- lib/parse.ml | 9 +++++-- test/test_session.ml | 53 ++++++++++++++++++++++++++++++++++++++ test/test_syntax.ml | 4 +++ 8 files changed, 137 insertions(+), 29 deletions(-) diff --git a/TODO.org b/TODO.org index 8e81f037..de5fdfa9 100644 --- a/TODO.org +++ b/TODO.org @@ -819,6 +819,10 @@ One spelling for one operation; != stays, and not= is refused with a suggestion of !=. * Checker +** TODO An error in a callee's condition adds a bogus one at main +=fn f(a)= with a refused condition (=if n + 1= over an i32), and =fn main()= calling =f(3)= +last, also reports "main returns i32 or nothing, not Never": the recovered body reads as +Never and main's last form inherits it. ** TODO A u64 above the i64 maximum becomes -1 when it crosses into dyn =(+ z u)= and =(max u 0 z)= with u = u64 max read u as -1, silently. It should trap at the crossing, as a u64 field read through a view already does. diff --git a/lib/ast.ml b/lib/ast.ml index e20f43e4..a494b837 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -91,6 +91,10 @@ and expr_kind = (Option T) tested by [x?] in the condition above it, read as its payload ([if x?] narrowing, decision 133). *) | Narrow of string list * expr + (* Made by the checker, never read: [body] with each [(g, h)] reading [g] + as the binding of the hidden name [h], what an [as] in the condition + above found (decision 136). *) + | Alias of (string * string) list * expr | Struct of string * (string * expr) list (* (Cursor {.src s}) *) (* {.src s .pos 0} with no type written in front of it. The fields alone do not name a type, so this node carries no name and is only checkable where @@ -480,6 +484,7 @@ let map_children f (e : expr) : expr = | IfLet (s, a, e) -> IfLet (ex s, arm a, Option.map ex e) | Chain (n, v, b) -> Chain (n, ex v, ex b) | Narrow (ns, b) -> Narrow (ns, ex b) + | Alias (ps, b) -> Alias (ps, ex b) | Struct (n, fs) -> Struct (n, List.map (fun (n, v) -> (n, ex v)) fs) | Bare fs -> Bare (List.map (fun (n, v) -> (n, ex v)) fs) | MapLit (tag, kvs) -> MapLit (tag, List.map (fun (k, v) -> (ex k, ex v)) kvs) @@ -604,7 +609,14 @@ let mark_pause ?fn ~line ~col (ds : decl list) : decl list option = reports, and the line DWARF names, nowhere. *) { e with e = Do [ pause_call ?fn e.loc; e ] } end - else map_children walk e + else + match e.e with + (* A call's name is not a form of its own: a mark on it, the [?] of + [x?] or the [>] of [(> a b)], stops before the call. *) + | Call ({ e = Var _; loc = hl }, _) when at hl -> + hit := true; + { e with e = Do [ pause_call ?fn e.loc; e ] } + | _ -> map_children walk e in let body es = List.map walk es in let decl (d : decl) = @@ -641,7 +653,18 @@ let as_name g = g <> "" && (match g.[0] with 'A' .. 'Z' -> false | _ -> true) && g <> "true" && g <> "false" +(* [x] when [c] is [x] with a pause mark in front of it, [Do [pause; x]]: + [mark_pause] wraps whatever starts at the column marked, a test of a + condition's chain included, and the chain still means what it did. *) +let unpause (c : expr) = + match c.e with + | Do [ { e = Call ({ e = Var _; _ }, []); loc }; x ] when loc = x.loc -> Some x + | _ -> None + let rec as_binds (c : expr) = + match unpause c with + | Some x -> as_binds x + | None -> match c.e with | If (_, q, Some { e = Var "false"; _ }) -> as_binds q | IfLet (_, { pat = Pctor (g, []); body = [ q ]; _ }, Some { e = Var "false"; _ }) diff --git a/lib/check.ml b/lib/check.ml index 8771c299..9df157fb 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3184,8 +3184,12 @@ let unnarrowable_in (body : Ast.expr list) = List.iter (walk ~in_fn:false) body; !out +(* A name an [as] bound to what an Option held: the slot holding the Option, + read as its payload, as a narrowed local is, but not assignable. *) +let as_tag = "~as" + let local_of loc (b : binding) = - if b.bwhat = Some narrowed_tag then + if b.bwhat = Some narrowed_tag || b.bwhat = Some as_tag then mk loc b.bty (Tast.Field (mk loc (Types.Option b.bty) (Tast.Local b.slot), 1)) else mk loc b.bty (Tast.Local b.slot) @@ -6559,6 +6563,15 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr = | Ast.Narrow (names, body) -> with_narrowed ctx names (fun () -> ctx.tail <- tail; ctx.used <- used; check ctx ?want body) + | Ast.Alias (pairs, body) -> + scoped ctx (fun () -> + List.iter + (fun (g, h) -> + match lookup ctx h with + | Some b -> ctx.scope <- (g, b) :: ctx.scope + | None -> ()) + pairs; + ctx.tail <- tail; ctx.used <- used; check ctx ?want body) (* Constant integer arithmetic where a type variable is wanted is folded to the literal it computes first, so [(+ x (+ 1 2))] is admitted wherever [(+ x 3)] is. The instantiation re-checks the form unfolded, at a concrete @@ -8542,11 +8555,7 @@ and check_if_tested ctx ~tail ~used ?want loc c t e = write, bound in the scope this if was given; the else is checked without it. *) let cv, named = as_cond ctx c in - let bnd (g, h) = - { Ast.bname = g; bty = None; bval = { Ast.e = Ast.Var h; loc = t.Ast.loc }; - bloc = t.Ast.loc } - in - (cv, { t with Ast.e = Ast.Let (List.map bnd named, [ t ]) }) + (cv, { t with Ast.e = Ast.Alias (named, t) }) in (* Both arms are the tail, and a one-armed [if] counts: [(when c (recur ...))] is how nearly every loop is written, and the branch is still the last @@ -10687,6 +10696,9 @@ and if_let_name ctx ~tail ~used ?want loc scrutinee n (arm : Ast.arm) els = in the block it guards (decision 133). Not through [or] or [not], where the test holding says nothing about [x]. *) and narrows (c : Ast.expr) = + match Ast.unpause c with + | Some x -> narrows x + | None -> match c.Ast.e with | Ast.Call ({ Ast.e = Ast.Var "?"; _ }, [ { Ast.e = Ast.Var x; _ } ]) -> [ x ] | Ast.If (p, q, Some { Ast.e = Ast.Var "false"; _ }) -> narrows p @ narrows q @@ -10701,13 +10713,21 @@ and as_name g = Ast.as_name g (* A condition with [as] in it, as the bool it tests, and each name it binds with the hidden name the block reads it through. The chain runs left to right and stops at the first test that fails, so each value is found - once; what an [as] finds is copied into its name's slot there, and a - later test and the block read that slot. *) + once. What an [as] tests is held in one slot, and its name reads that + slot: the payload of an Option held there, or the dyn itself. *) and as_cond ctx (c : Ast.expr) = let named = ref [] in let no loc = mk loc Types.Bool (Tast.Bool false) in let rec go (c : Ast.expr) = let loc = c.Ast.loc in + match Ast.unpause c, c.Ast.e with + (* A pause mark on a test of the chain stops before it and leaves the + chain as it was. *) + | Some x, Ast.Do [ pause; _ ] -> + let pv = check ctx pause in + let xv = go x in + mk loc Types.Bool (Tast.Do [ pv; xv ]) + | _, _ -> match c.Ast.e with | Ast.If (p, q, Some { Ast.e = Ast.Var "false"; _ }) when as_binds q <> [] -> let pv = check_truthy ctx p in @@ -10718,10 +10738,10 @@ and as_cond ctx (c : Ast.expr) = let ev = check ctx e in let hs = fresh_slot ctx ev.Tast.ty in let hv = mk loc ev.Tast.ty (Tast.Local hs) in - let test, payload, ty = + let test, what, ty = match ev.Tast.ty with - | Types.Option t -> (opt_is_some loc hv, opt_payload loc t hv, t) - | Types.Dyn -> (dyn_not_nil loc hv, hv, Types.Dyn) + | Types.Option t -> (opt_is_some loc hv, Some as_tag, t) + | Types.Dyn -> (dyn_not_nil loc hv, None, Types.Dyn) | t -> Loc.failk "check/as-not-optional" e.Ast.loc "%s is %s, which always holds a value, so as has nothing to test. \ @@ -10730,21 +10750,12 @@ and as_cond ctx (c : Ast.expr) = name, as in i32(x)" (source_text e) (tyname loc t) in - let slot, qv = - scoped ctx (fun () -> - let slot = bind ctx g ty ~assignable:false in - (match lookup ctx g with - | Some b -> - incr held_n; - named := (g, Printf.sprintf "~as%d" !held_n, b) :: !named - | None -> ()); - (slot, go q)) - in + let b = { slot = hs; bty = ty; assignable = false; bwhat = what; blit = None } in + incr held_n; + named := (g, Printf.sprintf "~as%d" !held_n, b) :: !named; + let qv = scoped ctx (fun () -> ctx.scope <- (g, b) :: ctx.scope; go q) in mk loc Types.Bool - (Tast.Let ([ (hs, ev) ], - [ mk loc Types.Bool - (Tast.If (test, mk loc Types.Bool (Tast.Let ([ (slot, payload) ], [ qv ])), - no loc)) ])) + (Tast.Let ([ (hs, ev) ], [ mk loc Types.Bool (Tast.If (test, qv, no loc)) ])) | _ -> check_truthy ctx c in let cv = go c in diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 25e6f1c6..c2e39c01 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -1456,6 +1456,13 @@ and primary p : Form.t * int = (match (peek p).tok with | RP -> ignore (advance p) | EOF -> unclosed p '(' l0 + | NAME "as" -> + failk "as-paren" (peek p).loc + "as names what a test found for the block of the if, elif, while \ + or when it is a test of, so it stands in that condition's and \ + chain and not inside parentheses. Write it without them: if %s as \ + g and ..." + (text_of e) | COMMA -> failk "tuple" (peek p).loc "parentheses group one value, and this comma starts a second. \ diff --git a/lib/load.ml b/lib/load.ml index 1809fecc..bf2e9515 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -297,6 +297,7 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = | Ast.Chain (n, v, b) -> Ast.Chain (n, go v, rename_expr owned alias (n :: bound) b) | Ast.Narrow (ns, b) -> Ast.Narrow (ns, go b) + | Ast.Alias (ps, b) -> Ast.Alias (ps, go b) (* A quoted symbol naming something the package declares. [(Form.Sym {.s "Cursor"})] is what a quasiquote desugars to, and it is the one place a package's name survives into a *string* — which is @@ -860,7 +861,7 @@ let rec expr_uses acc (e : Ast.expr) = go sc; List.iter (fun (a : Ast.arm) -> gos a.Ast.body) arms | Ast.IfLet (sc, a, e') -> go sc; gos a.Ast.body; Option.iter go e' | Ast.Chain (_, v, b) -> go v; go b - | Ast.Narrow (_, b) -> go b + | Ast.Narrow (_, b) | Ast.Alias (_, b) -> go b | Ast.Struct (n, kvs) -> acc := (n, e.Ast.loc) :: !acc; List.iter (fun (_, v) -> go v) kvs diff --git a/lib/parse.ml b/lib/parse.ml index f34cefde..ca461c4f 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1315,7 +1315,9 @@ and is_as (f : Form.t) = match f.v with List ({ v = Sym "as"; _ } :: _) -> true | _ -> false and as_chain f (args : Form.t list) : Ast.expr = - let no (x : Form.t) = { Ast.e = Ast.Var "false"; loc = x.loc } in + (* At no position, so a pause mark cannot land on the chain's own + [false]: it has none in the source. *) + let no (_ : Form.t) = { Ast.e = Ast.Var "false"; loc = Loc.unknown } in let rec go = function | [] -> { Ast.e = Ast.Var "true"; loc = f.loc } | [ x ] when not (is_as x) -> expr x @@ -1325,7 +1327,10 @@ and as_chain f (args : Form.t list) : Ast.expr = | x :: _ when is_as x -> fail x "as is (as name value)" | x :: rest -> { Ast.e = Ast.If (expr x, go rest, Some (no x)); loc = x.loc } in - go args + (* The chain's own node is at the [and], so a pause mark there has a form + to stop before. *) + let top = go args in + { top with Ast.loc = f.loc } and shortcircuit f (args : Form.t list) ~is_and : Ast.expr = let mk e = { Ast.e; loc = f.loc } in diff --git a/test/test_session.ml b/test/test_session.ml index f7bbcc17..463038eb 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -2038,4 +2038,57 @@ let () = | exception Loc.Error _ -> () | exception Loc.Errors _ -> fail "one error came as a list")); + (* A pause mark at any column of a condition leaves what it binds bound: + an [as] (decision 136), and an [x?] narrowing through [and] (133). + [mark_pause] wraps a test of the chain in [(do (pause) test)]. *) + (let t, _ = Session.create ~file:"programs/reload.flan" () in + let marks name origin src line = + let text = List.nth (String.split_on_char '\n' src) (line - 1) in + let hits = ref 0 in + for col = 1 to String.length text do + let syntax = if Filename.check_suffix origin ".fln" then Source.Indented else Source.Paren in + match + Source.with_code ~syntax ~at:None (fun () -> + Session.eval ~origin ~pause:(line, col) t src) + with + | _ -> incr hits + | exception Loc.Error d when has d.Loc.dmsg "nothing to pause" -> () + | exception Loc.Error d -> + fail "%s, a mark at %d:%d: %s" name line col d.Loc.dmsg + | exception e -> fail "%s, a mark at %d:%d: %s" name line col (Printexc.to_string e) + done; + if !hits < 3 then fail "%s: only %d columns took a mark" name !hits + in + marks "if o? as g" "mark-a.fln" "fn pa(o: i32?) -> i32\n if o? as g then g else 0\n" 2; + marks "if o as g and" "mark-b.fln" "fn pb(o: i32?) -> i32\n if o as g and g > 1 then g else 0\n" 2; + marks "if o? and" "mark-c.fln" "fn pc(o: i32?) -> i32\n if o? and o > 1 then o else 0\n" 2; + let paren = "(defn pd [o (Option i32)] i32 (if (and (as g o) (> g 1)) g 0))" in + marks "(and (as g o) ...)" "" paren 1; + (* The chain has a node of its own at the [(and]. *) + let col = + let rec find i = if String.sub paren i 4 = "(and" then i + 1 else find (i + 1) in + find 0 + in + (match Session.eval ~pause:(1, col) t paren with + | _ -> () + | exception Loc.Error d -> fail "a mark at (and: %s" d.Loc.dmsg); + (* What an as finds is held once, and its name reads that slot: one + binding in the function, where a copy into g's own slot and another + into the block's would be three. *) + ignore + (Source.with_code ~syntax:Source.Indented ~at:None (fun () -> + Session.eval ~origin:"copies.fln" t + "fn pe(o: i32?) -> i32\n if o? as g and g > 1 then g + 1 else 0\n")); + match + List.find_opt (fun (f : Tast.fn) -> f.Tast.name = "pe") t.Session.program.Tast.fns + with + | None -> fail "pe was not installed" + | Some f -> + let n = ref 0 in + List.iter + (Tast.walk (fun (e : Tast.expr) -> + match e.Tast.e with Tast.Let (bs, _) -> n := !n + List.length bs | _ -> ())) + f.Tast.body; + if !n <> 1 then fail "if o? as g binds %d slots, wanted 1" !n); + Test_support.report ~label:"session" () diff --git a/test/test_syntax.ml b/test/test_syntax.ml index c8659741..ce15fe57 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -1432,6 +1432,10 @@ let () = refuses "or after as" "if f(x) as g or b\n g" "indent/as-or" "nothing to name"; refuses "or later in the chain" "if f(x) as g and a or b\n g" "indent/as-or" "nothing to name"; refuses "as under not" "if not f(x) as g\n g" "indent/as-not" "not turns the test around"; + refuses "as in parentheses under not" "if not (a as g)\n g" "indent/as-paren" + "not inside parentheses"; + refuses "as in a bracketed chain" "if (a as g and g > 1) and b\n g" "indent/as-paren" + "if a as g and"; refuses "as after until" "until f(x) as g\n g" "indent/as-until" "Write while"; refused "as-not-optional.fln" "fn main()\n let n = 5\n if n as g and g > 1\n println(g)\n" [ "n is i32, which always holds a value, so as has nothing to test"; From 83bb65957d24241386558f002a232c8bfa22a395 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 17:59:59 +0700 Subject: [PATCH 4/5] Each name an as binds is a slot of its own under its name, so the break loop's locals show it with what the test found. --- lib/check.ml | 66 +++++++++++++++++++++++--------------- test/programs/dev-as.fln | 26 +++++++++++++++ test/test_dev.ml | 69 ++++++++++++++++++++++++++++++++++++++++ test/test_session.ml | 10 +++--- 4 files changed, 141 insertions(+), 30 deletions(-) create mode 100644 test/programs/dev-as.fln diff --git a/lib/check.ml b/lib/check.ml index 17c04445..b69a6d3e 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -3184,12 +3184,8 @@ let unnarrowable_in (body : Ast.expr list) = List.iter (walk ~in_fn:false) body; !out -(* A name an [as] bound to what an Option held: the slot holding the Option, - read as its payload, as a narrowed local is, but not assignable. *) -let as_tag = "~as" - let local_of loc (b : binding) = - if b.bwhat = Some narrowed_tag || b.bwhat = Some as_tag then + if b.bwhat = Some narrowed_tag then mk loc b.bty (Tast.Field (mk loc (Types.Option b.bty) (Tast.Local b.slot), 1)) else mk loc b.bty (Tast.Local b.slot) @@ -10797,8 +10793,8 @@ and as_name g = Ast.as_name g (* A condition with [as] in it, as the bool it tests, and each name it binds with the hidden name the block reads it through. The chain runs left to right and stops at the first test that fails, so each value is found - once. What an [as] tests is held in one slot, and its name reads that - slot: the payload of an Option held there, or the dyn itself. *) + once. Each name an [as] binds is one slot, read by the rest of the chain + and, through [Ast.Alias], by the block. *) and as_cond ctx (c : Ast.expr) = let named = ref [] in let no loc = mk loc Types.Bool (Tast.Bool false) in @@ -10820,26 +10816,44 @@ and as_cond ctx (c : Ast.expr) = | Ast.IfLet (e, { Ast.pat = Ast.Pctor (g, []); body = [ q ]; _ }, Some { Ast.e = Ast.Var "false"; _ }) when as_name g -> let ev = check ctx e in - let hs = fresh_slot ctx ev.Tast.ty in - let hv = mk loc ev.Tast.ty (Tast.Local hs) in - let test, what, ty = - match ev.Tast.ty with - | Types.Option t -> (opt_is_some loc hv, Some as_tag, t) - | Types.Dyn -> (dyn_not_nil loc hv, None, Types.Dyn) - | t -> - Loc.failk "check/as-not-optional" e.Ast.loc - "%s is %s, which always holds a value, so as has nothing to test. \ - as names what an Option or a dyn holds, when it holds something. \ - It is not a conversion: a number is converted with its type's \ - name, as in i32(x)" - (source_text e) (tyname loc t) + let refuse t = + Loc.failk "check/as-not-optional" e.Ast.loc + "%s is %s, which always holds a value, so as has nothing to test. \ + as names what an Option or a dyn holds, when it holds something. \ + It is not a conversion: a number is converted with its type's \ + name, as in i32(x)" + (source_text e) (tyname loc t) in - let b = { slot = hs; bty = ty; assignable = false; bwhat = what; blit = None } in - incr held_n; - named := (g, Printf.sprintf "~as%d" !held_n, b) :: !named; - let qv = scoped ctx (fun () -> ctx.scope <- (g, b) :: ctx.scope; go q) in - mk loc Types.Bool - (Tast.Let ([ (hs, ev) ], [ mk loc Types.Bool (Tast.If (test, qv, no loc)) ])) + (* [g] is a slot of its own under its own name, so locals, the stepper, + the inspector and the watch view show it as the program reads it. A + dyn is held there directly; an Option is held in a hidden slot and + 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 b = Option.get (lookup ctx g) in + incr held_n; + named := (g, Printf.sprintf "~as%d" !held_n, b) :: !named; + (slot, go q)) + in + (match ev.Tast.ty with + | Types.Option t -> + let hs = fresh_slot ctx ev.Tast.ty in + let hv = mk loc ev.Tast.ty (Tast.Local hs) in + let slot, qv = bound t in + mk loc Types.Bool + (Tast.Let ([ (hs, ev) ], + [ mk loc Types.Bool + (Tast.If (opt_is_some loc hv, + mk loc Types.Bool + (Tast.Let ([ (slot, opt_payload loc t hv) ], [ qv ])), + no loc)) ])) + | Types.Dyn -> + let slot, qv = bound Types.Dyn in + let sv = mk loc Types.Dyn (Tast.Local slot) in + mk loc Types.Bool + (Tast.Let ([ (slot, ev) ], [ mk loc Types.Bool (Tast.If (dyn_not_nil loc sv, qv, no loc)) ])) + | t -> refuse t) | _ -> check_truthy ctx c in let cv = go c in diff --git a/test/programs/dev-as.fln b/test/programs/dev-as.fln new file mode 100644 index 00000000..ebd78c8a --- /dev/null +++ b/test/programs/dev-as.fln @@ -0,0 +1,26 @@ +;; A program that stops inside an if o as g block (decision 136): the break +;; loop's locals list g, with the value the test found, on both backends. +import agent "vendor:agent" + +struct Boom + why: i32 + +let ticks: i64 = 0 + +fn look(o: i32?, d) -> i64 + if o as g and g > 1 and d as e + restart-case + error(Boom{.why g}) + 0 + restart carry-on() + 5 + else + 0 + +fn main() -> i32 + agent/start("/tmp/flan-dev-as-fallback.sock") + println(look(Some(41), "hi")) + for i in range(4000) + agent/wait(5) + ticks += 1 + 0 diff --git a/test/test_dev.ml b/test/test_dev.ml index e7940991..31bff637 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -2483,6 +2483,75 @@ let () = null_park "--llvm"; null_park "--x86"; + (* A stop inside an [if o as g and ... and d as e] block (decision 136): + each name an [as] binds is a slot of its own under its name, so the + locals list it with what the test found. *) + let as_locals backend = + let asock = tmp ("as" ^ backend ^ ".sock") and aout = tmp ("as" ^ backend ^ ".out") in + (try Sys.remove asock with Sys_error _ -> ()); + let afd = Unix.openfile aout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let apid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-as.fln"; "-s"; asock; backend |] + Unix.stdin afd Unix.stderr + in + Unix.close afd; + if not (listening ~pid:apid asock) then begin + fail "the as daemon (%s) %s" backend !listen_why; + (try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect asock in + let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then + fail "the as program never stopped (%s)" backend + else begin + let r = ask "(:op \"locals\" :frame 0)" in + let rows = + match Wire.field r "locals" with + | Some { Form.v = Form.List l; _ } -> + List.filter_map + (fun (e : Form.t) -> + match e.Form.v with + | Form.List ({ Form.v = Form.Str n; _ } :: { Form.v = Form.Str ty; _ } + :: { Form.v = Form.Str v; _ } :: _) -> Some (n, (ty, v)) + | _ -> None) + l + | _ -> [] + in + (match List.assoc_opt "g" rows with + | Some ("i32", "41") -> () + | Some (ty, v) -> fail "locals show g as %s %s (%s)" ty v backend + | None -> + fail "locals do not show g (%s): %s" backend + (String.concat " " (List.map fst rows))); + (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) + end; + ignore (ask "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] apid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] apid) with Unix.Unix_error _ -> ()) + end + end + in + as_locals "--llvm"; + as_locals "--x86"; + (* ── The locals of a stopped frame ─────────────────────────────── *) (* A third daemon, over a program that stops with something worth looking diff --git a/test/test_session.ml b/test/test_session.ml index 463038eb..6df9c9d2 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -2072,9 +2072,9 @@ let () = (match Session.eval ~pause:(1, col) t paren with | _ -> () | exception Loc.Error d -> fail "a mark at (and: %s" d.Loc.dmsg); - (* What an as finds is held once, and its name reads that slot: one - binding in the function, where a copy into g's own slot and another - into the block's would be three. *) + (* What an as finds is copied once, into g's own named slot, which the + rest of the chain and the block read: two bindings, the Option held + and g, where another copy into the block's would be three. *) ignore (Source.with_code ~syntax:Source.Indented ~at:None (fun () -> Session.eval ~origin:"copies.fln" t @@ -2089,6 +2089,8 @@ let () = (Tast.walk (fun (e : Tast.expr) -> match e.Tast.e with Tast.Let (bs, _) -> n := !n + List.length bs | _ -> ())) f.Tast.body; - if !n <> 1 then fail "if o? as g binds %d slots, wanted 1" !n); + if !n <> 2 then fail "if o? as g binds %d slots, wanted 2" !n; + if not (Array.exists (fun x -> x = Some "g") f.Tast.snames) then + fail "if o? as g has no slot named g"); Test_support.report ~label:"session" () From d6c33928f52ed19fb6f8e46eb8541113bdb4bbd6 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 18:16:13 +0700 Subject: [PATCH 5/5] 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 |] -> ()