diff --git a/TODO.org b/TODO.org index bc5923fb..4ce1c9ce 100644 --- a/TODO.org +++ b/TODO.org @@ -55,6 +55,11 @@ Decided (140), reversing 125a: a kept =when=, else-less =if=/=elif= or =if let= arm is already a =T?= is a =T?=, and =T= beside =T?= arms is =T?=; a =T??= arm stays =T??=. Where =T??= is wanted the arm is Some of it. Rules out telling "no branch matched" apart from "a branch gave None" without asking for =T??=. +** 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. @@ -824,6 +829,18 @@ 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. +** TODO A dyn nil past the first pair of a fold is refused at compile time +=(+ 1 2 (the dyn nil))= says nil has no None at i32, while =(+ (the dyn nil) 1 2)= traps +at run time. Both should trap at run time. +** TODO A generic $t beside a dyn operand is refused +"does not cross into a written type yet"; rule 117 says typed beside dyn gives dyn. ** WAIT Checking a wide fold of let operands is slow Parked 2026-09-26: design first; remeasure on a quiet machine, it was timed under load 20. A 2000-operand (bit-and (let …) …) takes 32 s to check (37 s before the bit operators); diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index 03be0160..b8dbb240 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -1831,6 +1831,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." @@ -1905,8 +1918,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 ef3000f0..f79500ad 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..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) = @@ -632,3 +644,29 @@ 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" + +(* [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"; _ }) + when as_name g -> g :: as_binds q + | _ -> [] diff --git a/lib/check.ml b/lib/check.ml index 61500504..f0c7a1e5 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 @@ -3191,6 +3193,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)) @@ -4940,7 +4946,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; @@ -5321,7 +5327,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 = "" } @@ -5381,7 +5387,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; @@ -5501,7 +5507,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 <- @@ -5584,7 +5590,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 <- @@ -5632,7 +5638,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 <- @@ -5707,7 +5713,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 <- @@ -6615,7 +6621,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))) @@ -6694,6 +6700,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 @@ -7376,7 +7391,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 @@ -7499,7 +7514,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 @@ -8663,12 +8678,25 @@ 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 + (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 thing the body does. Both arms are kept when the [if] is. *) @@ -10972,11 +11000,92 @@ 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 + | 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. 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 + 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 + 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 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 + (* [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 ~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; + (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 + 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 @@ -11019,7 +11128,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 @@ -11434,7 +11543,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" @@ -11518,6 +11627,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 @@ -17294,7 +17408,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; @@ -17305,7 +17419,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; @@ -19084,7 +19198,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 @@ -19715,7 +19829,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 @@ -20896,13 +21010,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/indent_reader.ml b/lib/indent_reader.ml index 092df315..c2e39c01 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -1005,7 +1005,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 @@ -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. \ @@ -1487,12 +1494,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) | _ -> @@ -1533,53 +1535,89 @@ 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) - | _ -> - (* [a |> f? as g] would test [f] alone: a compound test is bracketed. *) - let t = text_of c in - let compound = - let depth = ref 0 and quoted = ref false and hit = ref false in - String.iteri - (fun i ch -> - if !quoted then - (if ch = '"' && (i = 0 || t.[i - 1] <> '\\') then quoted := false) - else - match ch with - | '"' -> quoted := true - | '(' | '[' | '{' -> incr depth - | ')' | ']' | '}' -> decr depth - | ' ' when !depth = 0 -> hit := true - | _ -> ()) - t; - !hit - in - failk "as-test" at.loc - "as names what a test found, and %s is not one. Write %s? as name" - t (if compound then "(" ^ t ^ ")" else t)) - | _ -> 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 + (* Level 1 is an [or], or a pipe, which is loosest: [a |> f(1) as v] + names what the pipe answers. *) + let is_or (f : Form.t) = + match f.v with Form.List ({ v = Form.Sym "or"; _ } :: _) -> true | _ -> false + in + if lvl = 1 && is_or x 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] >= 'A' && g.[0] <= 'Z' -> + failk "as-name" (where_ p) + "as binds a name to what %s holds, and %s is a case, not a name. \ + Match a pattern with if let, as in if let %s(v) = %s" + (text_of e) g g (text_of e) + | 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 = mk p last.loc (Form.List [ sym at.loc "as"; g; e ]) 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 && is_or y 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 -> 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 @@ -2820,12 +2858,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. *) @@ -2842,11 +2875,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 -> @@ -2958,21 +2987,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..bf2e9515 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. *) @@ -295,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 @@ -858,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 757f8803..ca461c4f 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,33 @@ 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 = + (* 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 + | ({ 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 + (* 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 let rec go = function 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/spec-syntax.md b/spec-syntax.md index 7c85a91f..0d760e48 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -330,7 +330,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?`, @@ -342,15 +342,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..4bdd4055 --- /dev/null +++ b/test/programs/as-chain.fln @@ -0,0 +1,92 @@ +;; 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) + 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 + 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/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_acceptance.ml b/test/test_acceptance.ml index caa407e8..8b872bb7 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -2281,7 +2281,12 @@ let () = some some some none\nsome some some none none\n1 6 -1 -1\n1\n9 8 3 5\n\ 4000000000 4000000000 4 4\n4 4000000000\n3.5 3.5 7 7\n200 200\n3000000000 3000000000 3 3\n-1 5\n1 0\n10\n"); (* 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\n43\n-4 5\n"); + ("as-chain-dyn.fln", "dog nobody ann\n4 nil nil\n6 2\n5\n-1\n") ]; (* The pipe (decision 137): chains, multi-line, qualified, dyn, and the left side run before the other arguments (the last 1 2 3). *) (let want = "7\n6\n6\n60\n10\n8\nfalse\n30\n7\n7 -1\n6\n7\n1\n2\n3\n-4\n" in diff --git a/test/test_dev.ml b/test/test_dev.ml index e7940991..3b77dbc7 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -2483,6 +2483,104 @@ 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); + (* 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; + 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_flan.ml b/test/test_flan.ml index 8aa8f4e5..a1f67db1 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 f7bbcc17..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 |] -> () @@ -2038,4 +2038,59 @@ 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 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 + "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 <> 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" () diff --git a/test/test_syntax.ml b/test/test_syntax.ml index af8de176..02745e02 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -1409,14 +1409,46 @@ 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 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"; + "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" ]; (* Decision 137: x |> f(a) is f(x, a), below or. *) reads "|> into a call" "y = x |> f(1, 2)" "(set y (f x 1 2))"; reads "|> into an empty call" "y = x |> f()" "(set y (f x))"; @@ -1456,11 +1488,10 @@ let () = refuses "|> before a test" "y = a |> f?" "indent/pipe-target" "\n (a |> f)?"; refuses "|> chained before ==" "y = a |> b |> f(1) == 2" "indent/pipe-target" "\n (a |> b |> f(1)) == 2"; - refuses "|> before as" "if a |> f(1) as v\n v" "indent/as-test" "Write (a |> f(1))? as name"; - refuses "|> before as over a pattern" "if a |> f as Some(v)\n v" "indent/as-test" - "Write (a |> f)? as name"; - refuses "a call before as is not bracketed" "if f(x) as v\n v" "indent/as-test" - "Write f(x)? as name"; + reads "as names what a pipe answers" "if a |> f(1) as v and v > 0\n v" + "(when (and (as v (f a 1)) (> v 0)) v)"; + refuses "as before a pattern" "if a |> f as Some(v)\n v" "indent/as-name" + "if let Some(v) = a |> f"; reads "|> into a macro passes the place" "y = x |> set(5)" "(set y (set x 5))"; refuses "|> into parentheses" "y = x |> (f)" "indent/pipe-target" "(f) is neither"; refuses "|> unspaced on the right" "y = x |>[f]" "indent/unspaced-operator" "x |> f(a)"; @@ -1478,7 +1509,7 @@ let () = 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)" ]; @@ -1512,7 +1543,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" ]; @@ -1520,7 +1551,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"; @@ -1881,9 +1912,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" ()