JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A condition can bind what it tests with as, inside and chains too, and the bound name is read-only in the program and in the debugger.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 18:21:00 +07:00
commit 8d198f88c9
20 changed files with 765 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
TODO.org
View File

@ -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??=. 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 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??=. 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 ** 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 =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. 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 !=. of !=.
* Checker * 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 ** 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. 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); A 2000-operand (bit-and (let …) …) takes 32 s to check (37 s before the bit operators);

16
emacs/flan-fln-mode.el
View File

@ -1831,6 +1831,19 @@ it, so a block pasted at another depth stays one block."
(defun flan-fln--fallback-re (heads) (defun flan-fln--fallback-re (heads)
(concat "^" (regexp-opt heads t) "(" flan-fln--name-re)) (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) (defun flan-fln--return-type-matcher (limit)
"Find the next return type up to LIMIT: after the `->' of a fn header, a "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." 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 ;; The words inside a line: `for i in range(n)', `if c then a else b', a
;; `where' constraint. ;; `where' constraint.
("[ \t]\\(then\\|else\\|in\\|where\\)[ \t]" 1 font-lock-keyword-face) ("[ \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) ("?[ \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'. ;; `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) ("\\_<\\(?:el\\)?if[ \t]+\\(let\\)[ \t]" 1 font-lock-keyword-face)
("[ \t=(,]\\(if\\|when\\)[ \t]" 1 font-lock-keyword-face) ("[ \t=(,]\\(if\\|when\\)[ \t]" 1 font-lock-keyword-face)

10
emacs/test-flan-fln.el
View File

@ -938,6 +938,16 @@ defconst(k, 3)
(search-forward "g!") (search-forward "g!")
(backward-char 1) (backward-char 1)
(test-flan-fln--is "the name at x! is x" (thing-at-point 'symbol t) "g")) (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--is "after if x? as g, one level deeper"
(test-flan-fln--tabs "fn f() -> ()\n if o? as g\n|" 1) 4) (test-flan-fln--tabs "fn f() -> ()\n if o? as g\n|" 1) 4)
(with-temp-buffer (with-temp-buffer

40
lib/ast.ml
View File

@ -91,6 +91,10 @@ and expr_kind =
(Option T) tested by [x?] in the condition above it, read as its (Option T) tested by [x?] in the condition above it, read as its
payload ([if x?] narrowing, decision 133). *) payload ([if x?] narrowing, decision 133). *)
| Narrow of string list * expr | 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}) *) | 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 (* {.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 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) | IfLet (s, a, e) -> IfLet (ex s, arm a, Option.map ex e)
| Chain (n, v, b) -> Chain (n, ex v, ex b) | Chain (n, v, b) -> Chain (n, ex v, ex b)
| Narrow (ns, b) -> Narrow (ns, 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) | 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) | 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) | 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. *) reports, and the line DWARF names, nowhere. *)
{ e with e = Do [ pause_call ?fn e.loc; e ] } { e with e = Do [ pause_call ?fn e.loc; e ] }
end 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 in
let body es = List.map walk es in let body es = List.map walk es in
let decl (d : decl) = let decl (d : decl) =
@ -632,3 +644,29 @@ let mark_pause ?fn ~line ~col (ds : decl list) : decl list option =
in in
let ds = List.map decl ds in let ds = List.map decl ds in
if !hit then Some ds else None 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
| _ -> []

154
lib/check.ml
View File

@ -834,6 +834,8 @@ type ctx = {
here rather than recovered later because this scope list is the only place here rather than recovered later because this scope list is the only place
that ever knows it. *) that ever knows it. *)
mutable slot_names : string option list; 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 *) mutable scope : (string * binding) list; (* innermost first *)
(* Deferred forms, most recently registered first — which is also the order (* Deferred forms, most recently registered first — which is also the order
they run in. [defer] is function-scoped, so this list belongs to the 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; List.iter (walk ~in_fn:false) body;
!out !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) = let local_of loc (b : binding) =
if b.bwhat = Some narrowed_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)) 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 <- env.lifted <-
{ Tast.name; params = ps; { Tast.name; params = ps;
slots = Array.of_list (ps @ [ fty ]); 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)) ]; ret = r; body = [ mk loc r (Tast.CallPtr (callee, args)) ];
fdefers = []; fenv = Some n; fparent = Some "<thick>"; floc = loc } fdefers = []; fenv = Some n; fparent = Some "<thick>"; floc = loc }
:: env.lifted; :: env.lifted;
@ -5321,7 +5327,7 @@ let with_recovery env ~on f =
end end
let invented_ctx env ret = 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 = []; 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"; in_defer = false; defer_ok = false; defer_block = "a nested form";
owner = "<none>" } owner = "<none>" }
@ -5381,7 +5387,7 @@ let condition_desc ctx loc name =
ctx.env.lifted <- ctx.env.lifted <-
{ Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ]; { Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ];
slots = Array.of_list (List.rev hctx.slot_tys); 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 = []; ret = Types.Unit; body; fdefers = [];
fenv = None; fparent = Some ctx.owner; floc = loc } fenv = None; fparent = Some ctx.owner; floc = loc }
:: ctx.env.lifted; :: 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. *) The body is filled in below; nothing can call these in between. *)
let placeholder name ret params = let placeholder name ret params =
{ Tast.name; params; slots = Array.of_list 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 } ret; body = []; fdefers = []; fenv = None; fparent = None; floc = loc }
in in
env.lifted <- env.lifted <-
@ -5584,7 +5590,7 @@ and struct_key_pair env loc n =
let finish name ret params ctx body = let finish name ret params ctx body =
{ Tast.name; params; { Tast.name; params;
slots = Array.of_list (List.rev ctx.slot_tys); 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 } ret; body; fdefers = []; fenv = None; fparent = None; floc = loc }
in in
env.lifted <- env.lifted <-
@ -5632,7 +5638,7 @@ and array_key_pair env loc n e =
let eparams = [ pty; pty; Types.Int Types.I64 ] in let eparams = [ pty; pty; Types.Int Types.I64 ] in
let placeholder name ret params = let placeholder name ret params =
{ Tast.name; params; slots = Array.of_list 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 } ret; body = []; fdefers = []; fenv = None; fparent = None; floc = loc }
in in
env.lifted <- env.lifted <-
@ -5707,7 +5713,7 @@ and array_key_pair env loc n e =
let finish name ret params ctx body = let finish name ret params ctx body =
{ Tast.name; params; { Tast.name; params;
slots = Array.of_list (List.rev ctx.slot_tys); 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 } ret; body; fdefers = []; fenv = None; fparent = None; floc = loc }
in in
env.lifted <- env.lifted <-
@ -6615,7 +6621,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
fail loc fail loc
"%s is tested with %s? above, so in this block it is %s, and it \ "%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 \ 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" item, and assign %s from that"
n n (tyname loc b.bty) (tyname loc b.bty) n n n n (tyname loc b.bty) (tyname loc b.bty) n n
| _ -> raise (Loc.Error d))) | _ -> raise (Loc.Error d)))
@ -6694,6 +6700,15 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
| Ast.Narrow (names, body) -> | Ast.Narrow (names, body) ->
with_narrowed ctx names (fun () -> with_narrowed ctx names (fun () ->
ctx.tail <- tail; ctx.used <- used; check ctx ?want body) 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 (* Constant integer arithmetic where a type variable is wanted is folded to
the literal it computes first, so [(+ x (+ 1 2))] is admitted wherever 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 [(+ 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 = let lifted =
{ Tast.name = fname; params = pts; { Tast.name = fname; params = pts;
slots = Array.of_list (List.rev fctx.slot_tys); 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 = []; ret; body = prefix fbody; fdefers = [];
fenv; fparent = Some ctx.owner; floc = loc } fenv; fparent = Some ctx.owner; floc = loc }
in in
@ -7499,7 +7514,7 @@ and check_handler_bind ctx ?want ?(what = "handler-bind") loc clauses body =
let lifted = let lifted =
{ Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ]; { Tast.name = fname; params = [ Types.Ptr (Types.Mut, ty) ];
slots = Array.of_list (List.rev hctx.slot_tys); 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 = []; ret = Types.Unit; body = prefix hbody; fdefers = [];
fenv; fparent = Some ctx.owner; floc = c.Ast.hloc } fenv; fparent = Some ctx.owner; floc = c.Ast.hloc }
in in
@ -8663,12 +8678,25 @@ and check_if ctx ?(tail = false) ?(used = false) ?want loc c t e =
raise ex) raise ex)
and check_if_once ctx ~tail ~used ?want loc c t e = 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 = let t =
match narrows c with match narrows c with
| [] -> t | [] -> t
| names -> { t with Ast.e = Ast.Narrow (names, t) } | names -> { t with Ast.e = Ast.Narrow (names, t) }
in 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 ...))] (* 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 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. *) 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 in the block it guards (decision 133). Not through [or] or [not], where
the test holding says nothing about [x]. *) the test holding says nothing about [x]. *)
and narrows (c : Ast.expr) = and narrows (c : Ast.expr) =
match Ast.unpause c with
| Some x -> narrows x
| None ->
match c.Ast.e with match c.Ast.e with
| Ast.Call ({ Ast.e = Ast.Var "?"; _ }, [ { Ast.e = Ast.Var x; _ } ]) -> [ x ] | 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.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: (* [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 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 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 (Printf.sprintf
"%s? does not make %s its payload here: %s's address \ "%s? does not make %s its payload here: %s's address \
is taken, or a fn assigns it, in this function, so \ 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" which copies what it holds into g"
n n n n) ] } n n n n) ] }
in 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 \ "%s is tested with %s? above, so here it is what the Option \
holds, %s, and %s has no fields" holds, %s, and %s has no fields"
n n (tyname target.Ast.loc other) (tyname target.Ast.loc other) 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 fail target.Ast.loc
"%s is %s — the pattern bound it to %s, so the value is already \ "%s is %s — the pattern bound it to %s, so the value is already \
in hand and there is no field left to read" 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 (match List.assoc_opt name ctx.caught with
| Some (_, slot) when slot = b.slot -> captured_set ctx loc name | 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 fail loc
"%s is a parameter, and a parameter is not assignable — bind a \ "%s is a parameter, and a parameter is not assignable — bind a \
local with let" name 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 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 refusal to reconsider, and silently continuing past one would turn a
resource failure into a wrong answer. *) 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 = _; defers; defer_slot; defer_ok; defer_block; outer = _;
outer_what; caught; place_ok; envslot; parent = _; outer_what; caught; place_ok; envslot; parent = _;
in_frames; loops; tail; used; kept; in_defer; in_frames; loops; tail; used; kept; in_defer;
@ -17305,7 +17419,7 @@ and trial ctx f =
| exception Loc.Error d -> | exception Loc.Error d ->
undo (); undo ();
ctx.slots <- slots; ctx.slot_tys <- slot_tys; 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.defers <- defers; ctx.defer_slot <- defer_slot;
ctx.defer_ok <- defer_ok; ctx.defer_block <- defer_block; ctx.defer_ok <- defer_ok; ctx.defer_block <- defer_block;
ctx.outer_what <- outer_what; ctx.in_frames <- in_frames; 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 = let checked =
{ Tast.name = fn.Ast.name; params; { Tast.name = fn.Ast.name; params;
slots = Array.of_list (List.rev ctx.slot_tys); 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 (* 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 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 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 <- ctx.env.lifted <-
{ Tast.name = fname; params = []; { Tast.name = fname; params = [];
slots = Array.of_list (List.rev ctx.slot_tys); 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 (* 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 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 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 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 caller can point every use of it at the stopped frame's storage instead
([Tast.rewrite_locals]). *) ([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) : (e : Ast.expr) :
Tast.expr * Types.t array * string option array * (string * int) list = Tast.expr * Types.t array * string option array * (string * int) list =
let ctx = invented_ctx env Types.Unit in let ctx = invented_ctx env Types.Unit in
let bound = let bound =
List.map 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 scope
in in
let t = expect ctx e.Ast.loc ~want:None (check ctx e) in let t = expect ctx e.Ast.loc ~want:None (check ctx e) in

2
lib/emit.ml
View File

@ -4876,7 +4876,7 @@ let emit_startup m ?(hidden = false) (globals : Tast.global list) =
own to live in. *) own to live in. *)
List.iter (emit_global m ~hidden) flags; List.iter (emit_global m ~hidden) flags;
emit_fn m ~hidden 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; ret = Types.Unit; body; fdefers = []; fenv = None; fparent = None;
floc = (List.hd computed).Tast.ginit.Tast.loc }; floc = (List.hd computed).Tast.ginit.Tast.loc };
true true

182
lib/indent_reader.ml
View File

@ -1005,7 +1005,7 @@ let no_place (e : Form.t) =
failk "chain-assign" e.loc failk "chain-assign" e.loc
"%s is an optional chain, and a chain cannot be assigned to: when it \ "%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 \ 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 (text_of e) r r r
| Form.List [ { v = Form.Sym "!!"; _ }; x ] -> | Form.List [ { v = Form.Sym "!!"; _ }; x ] ->
let r = text_of x in let r = text_of x in
@ -1456,6 +1456,13 @@ and primary p : Form.t * int =
(match (peek p).tok with (match (peek p).tok with
| RP -> ignore (advance p) | RP -> ignore (advance p)
| EOF -> unclosed p '(' l0 | 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 -> | COMMA ->
failk "tuple" (peek p).loc failk "tuple" (peek p).loc
"parentheses group one value, and this comma starts a second. \ "parentheses group one value, and this comma starts a second. \
@ -1487,12 +1494,7 @@ and if_expr p =
let t = advance p in let t = advance p in
let word = match t.tok with NAME w -> w | _ -> "if" 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 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 c = match letp with Some m -> m | None -> cond_head p 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
(match (peek p).tok with (match (peek p).tok with
| NAME "then" -> ignore (advance p) | NAME "then" -> ignore (advance p)
| _ -> | _ ->
@ -1533,53 +1535,89 @@ and if_let_head p =
failk "if-let-name" pat.loc failk "if-let-name" pat.loc
"if let %s = %s has no pattern to test. To test that %s holds a \ "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 \ 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 g (text_of v) (text_of v) (text_of v) (text_of v) g
| _ -> ()); | _ -> ());
Some (mk p lt.loc (Form.Vec [ pat; v ])) Some (mk p lt.loc (Form.Vec [ pat; v ]))
| _ -> None | _ -> None
(* [e? as g]: after a test [e?], the name what [e] holds is bound to, as (* A condition, where [e as g] may stand as a test of a top-level [and]
the head [[g e]] an [if let] over a plain name stands as (decision 133). *) chain (decisions 133, 136): [e] holds a value, and [g] names it for the
and as_head p (c : Form.t) = 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 match (peek p).tok with
| NAME "as" -> | NAME "as" -> as_chain p x lvl
let at = advance p in | _ -> x
(match c.v with
| Form.List [ { v = Form.Sym "?"; _ }; e ] -> and as_chain p (x : Form.t) lvl =
let g = let at = advance p in
match (peek p).tok with let refuse_or loc =
| NAME g when g <> "" && g.[0] <> '.' -> failk "as-or" loc
let gt = advance p in "as names what a test found, for the rest of an and chain and the \
check_name gt g; block. With or, the block can run when that test did not hold, and \
sym gt.loc g there would be nothing to name. Bind with as in an if of its own, and \
| tk -> test the rest inside it"
failk "as-name" (where_ p) "as takes the name to bind, and found %s" (show tk) in
in let items (f : Form.t) =
Some (Form.make (Form.Vec [ g; e ]) c.loc) match f.v with
| _ -> | Form.List ({ v = Form.Sym "and"; _ } :: (_ :: _ as xs)) -> xs
(* [a |> f? as g] would test [f] alone: a compound test is bracketed. *) | _ -> [ f ]
let t = text_of c in in
let compound = (* Level 1 is an [or], or a pipe, which is loosest: [a |> f(1) as v]
let depth = ref 0 and quoted = ref false and hit = ref false in names what the pipe answers. *)
String.iteri let is_or (f : Form.t) =
(fun i ch -> match f.v with Form.List ({ v = Form.Sym "or"; _ } :: _) -> true | _ -> false
if !quoted then in
(if ch = '"' && (i = 0 || t.[i - 1] <> '\\') then quoted := false) if lvl = 1 && is_or x then refuse_or x.loc;
else let before, last =
match ch with match List.rev (if lvl = 2 then items x else [ x ]) with
| '"' -> quoted := true | last :: rb -> (List.rev rb, last)
| '(' | '[' | '{' -> incr depth | [] -> ([], x)
| ')' | ']' | '}' -> decr depth in
| ' ' when !depth = 0 -> hit := true (match last.v with
| _ -> ()) | Form.List ({ v = Form.Sym "not"; _ } :: _) ->
t; failk "as-not" at.loc
!hit "as names what a test found, and not turns the test around: the \
in block runs when %s holds nothing, so there is nothing to name. Bind \
failk "as-test" at.loc with as, and put what runs when it is absent in the else"
"as names what a test found, and %s is not one. Write %s? as name" (text_of last)
t (if compound then "(" ^ t ^ ")" else t)) | Form.List ({ v = Form.Sym "or"; _ } :: _) -> refuse_or last.loc
| _ -> None | _ -> ());
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 (* 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 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 ] form [ alias; path ]
| "if" | "when" -> | "if" | "when" ->
let letp = if w = "if" then if_let_head p else None in 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 c = match letp with Some m -> m | None -> cond_head p 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
(* The elif and else clauses at the if's column, then the whole form. (* 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 [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. *) 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 = let c =
match if_let_head p with match if_let_head p with
| Some m -> elif_lets := m :: !elif_lets; m | Some m -> elif_lets := m :: !elif_lets; m
| None -> | None -> cond_head p
let c = fst (binary p 1) in
(match as_head p c with
| Some m -> elif_lets := m :: !elif_lets; m
| None -> c)
in in
(match (peek p).tok with (match (peek p).tok with
| NAME "then" when oneline -> | 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 ] | KW k, n when n <> NEWLINE -> let kt = advance p in [ Form.make (Form.Kw k) kt.loc ]
| _ -> [] | _ -> []
in in
let c, _ = expr p in let c = cond_head p in
(match (if w = "while" then as_head p c else None) with let binds =
(* [while e? as g]: [(while true (if-let [g e] (do body) (break)))]. A let is_as (f : Form.t) =
break or continue in the body is this loop's. *) match f.v with Form.List ({ v = Form.Sym "as"; _ } :: _) -> true | _ -> false
| Some m -> in
expect_line_end p ~after:(w ^ " " ^ text_of c ^ " as ..."); match c.v with
let body = block s ~after:w in | 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 at = c.Form.loc in
let f items = Form.make (Form.List items) at in let f items = Form.make (Form.List items) at in
form (label @ [ sym at "true"; form (label @ [ sym at "true"; f [ sym at "if"; c; f (sym at "do" :: body); f [ sym at "break" ] ] ])
f [ sym at "if-let"; m; f (sym at "do" :: body); f [ sym at "break" ] ] ]) else form (label @ (c :: body))
| None ->
expect_line_end p ~after:(w ^ " " ^ text_of c);
let body = block s ~after:w in
form (label @ (c :: body)))
| "for" -> | "for" ->
let label = let label =
match (peek p).tok with match (peek p).tok with

7
lib/load.ml
View File

@ -255,7 +255,9 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr =
(bound, []) bs (bound, []) bs
in in
Ast.Let (List.rev bs, List.map (rename_expr owned alias bound) body) 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) | 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 (* A loop's names are its own and are never imported; its initial
values and its body are ordinary expressions. *) 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, v, b) ->
Ast.Chain (n, go v, rename_expr owned alias (n :: bound) b) Ast.Chain (n, go v, rename_expr owned alias (n :: bound) b)
| Ast.Narrow (ns, b) -> Ast.Narrow (ns, go 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. (* A quoted symbol naming something the package declares.
[(Form.Sym {.s "Cursor"})] is what a quasiquote desugars to, and it is [(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 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 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.IfLet (sc, a, e') -> go sc; gos a.Ast.body; Option.iter go e'
| Ast.Chain (_, v, b) -> go v; go b | 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) -> | Ast.Struct (n, kvs) ->
acc := (n, e.Ast.loc) :: !acc; acc := (n, e.Ast.loc) :: !acc;
List.iter (fun (_, v) -> go v) kvs List.iter (fun (_, v) -> go v) kvs

29
lib/parse.ml
View File

@ -508,6 +508,8 @@ and form f mk (head : Form.t) (args : Form.t list) : Ast.expr =
| _ -> fail f "?. is (?. [name value] body)") | _ -> fail f "?. is (?. [name value] body)")
(* Short-circuiting, so they cannot be ordinary calls. *) (* 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 "and" -> shortcircuit f args ~is_and:true
| Sym "or" -> shortcircuit f args ~is_and:false | 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 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 when it reports, which is check.ml's call. Written up in TODO.org, "and's
last operand gets a misdirected caret". *) 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 = and shortcircuit f (args : Form.t list) ~is_and : Ast.expr =
let mk e = { Ast.e; loc = f.loc } in let mk e = { Ast.e; loc = f.loc } in
let rec go = function let rec go = function

16
lib/session.ml
View File

@ -1371,7 +1371,7 @@ let eval ?(origin = "<eval>") ?base ?forms ?pause ?(step = false) ?(running = tr
{ Tast.name = Printf.sprintf "install/%d" t.thunks; { Tast.name = Printf.sprintf "install/%d" t.thunks;
params = []; ret = Types.Unit; body; params = []; ret = Types.Unit; body;
fdefers = []; fenv = None; fparent = None; floc = loc; fdefers = []; fenv = None; fparent = None; floc = loc;
slots = [||]; snames = [||] } slots = [||]; snames = [||]; as_slots = [] }
in in
let ir = let ir =
match run_thunk with match run_thunk with
@ -2122,7 +2122,8 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
scratch and have none to keep. *) scratch and have none to keep. *)
snames = snames =
Array.append bnames Array.append bnames
(Array.make (List.length !extra) None) } (Array.make (List.length !extra) None);
as_slots = [] }
in in
(* A struct copy the values named first, laid out in this (* A struct copy the values named first, laid out in this
module and kept, as [eval_expr] keeps one. *) module and kept, as [eval_expr] keeps one. *)
@ -2258,7 +2259,8 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
@ [ nullary "flan/dev-end" ]; @ [ nullary "flan/dev-end" ];
fdefers = []; fenv = None; fparent = None; floc = loc; fdefers = []; fenv = None; fparent = None; floc = loc;
slots = Array.append base (Array.of_list (List.rev !extra)); 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 in
let copies = Check.fresh_copies t.env t.program.Tast.structs in let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program = 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 @ List.filter (fun (i, _) -> List.mem i bound) named
in in
let scope = 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 in
let checked, base, bnames, syn = Check.expression_in_scope t.env ~scope parsed 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 let table = List.map2 (fun (i, name) (_, j) -> (j, (i, name))) order syn in
@ -2436,7 +2441,8 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
slots = Array.append base (Array.of_list (List.rev !extra)); slots = Array.append base (Array.of_list (List.rev !extra));
(* The expression's own [let]s keep their names; the slots [render] added (* 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. *) 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 in
(* Built against the program but never spliced into it: an evaluation is not (* 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 a declaration, and adding one would leave the session carrying an eval/N

4
lib/tast.ml
View File

@ -354,6 +354,10 @@ type fn = {
backend is free to ignore it entirely -- nothing is *resolved* through it, backend is free to ignore it entirely -- nothing is *resolved* through it,
and a slot is still only ever referred to by index. *) and a slot is still only ever referred to by index. *)
snames : string option array; 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; ret : Types.t;
body : expr list; body : expr list;
(* The defers again, innermost first. [body] already has them spliced onto (* The defers again, innermost first. [body] already has them spliced onto

32
spec-syntax.md
View File

@ -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. 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 `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 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.** **Built.**
- **`x?` tests that a value is present** (decision 133): a bool, true when an - **`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?`, 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 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 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 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 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. read as a type, so a local tested this way needs a lowercase name.
**Built.** **Built.**
- **`e? as g`** names what a test found, for an `e` that is not a plain name: - **`e as g`** tests that `e` holds a value and names it `g` (decisions 133,
`if get(grid, r, c)? as cell` reads `(if-let [cell (get grid r c)] …)`, an 136): an Option that is `Some` binds its payload, a dyn that is not `nil`
`if-let` over a plain name, which binds what an Option holds or a dyn that binds itself. `e? as g` is the same test. Over any other type it is
is not `nil`. It works after `if`, `elif` and `while`; `while e? as g` plus refused; `as` is never a conversion, which is written `i32(x)`. It stands
a block reads `(while true (if-let [g e] (do …) (break)))`. **Built.** 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.** - **`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 - **`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 `dotimes`. `range` here is syntax, not a function. `..` is avoided because

31
test/programs/as-chain-dyn.fln Normal file
View File

@ -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)

92
test/programs/as-chain.fln Normal file
View File

@ -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)

26
test/programs/dev-as.fln Normal file
View File

@ -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

7
test/test_acceptance.ml
View File

@ -2281,7 +2281,12 @@ let () =
some some some none\nsome some some none none\n1 6 -1 -1\n1\n9 8 3 5\n\ 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"); 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). *) (* 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 (* The pipe (decision 137): chains, multi-line, qualified, dyn, and the
left side run before the other arguments (the last 1 2 3). *) 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 (let want = "7\n6\n6\n60\n10\n8\nfalse\n30\n7\n7 -1\n6\n7\n1\n2\n3\n-4\n" in

98
test/test_dev.ml
View File

@ -2483,6 +2483,104 @@ let () =
null_park "--llvm"; null_park "--llvm";
null_park "--x86"; 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 ─────────────────────────────── *) (* ── The locals of a stopped frame ─────────────────────────────── *)
(* A third daemon, over a program that stops with something worth looking (* A third daemon, over a program that stops with something worth looking

9
test/test_flan.ml
View File

@ -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) -> 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" refuses_all ~fln:true "^^ in .fln" "fn f(a: bool, b: bool) -> bool\n a ^^ b == 0\n"
"write a != b"; "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" rejects_check "popcount of a float"
"(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64"; "(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64";
rejects_check "a rotation's count does not widen the value" rejects_check "a rotation's count does not widen the value"

57
test/test_session.ml
View File

@ -1805,7 +1805,7 @@ let () =
{ Tast.name = "f"; params = []; ret = Types.Unit; body = []; { Tast.name = "f"; params = []; ret = Types.Unit; body = [];
fdefers = []; fenv = None; fparent = None; floc = Loc.unknown; fdefers = []; fenv = None; fparent = None; floc = Loc.unknown;
slots = Array.make (Array.length snames) (Types.Int Types.I32); slots = Array.make (Array.length snames) (Types.Int Types.I32);
snames } snames; as_slots = [] }
in in
(match Session.shown_names (fn [| Some "k~2"; None |]) with (match Session.shown_names (fn [| Some "k~2"; None |]) with
| [| Some "k"; None |] -> () | [| Some "k"; None |] -> ()
@ -2038,4 +2038,59 @@ let () =
| exception Loc.Error _ -> () | exception Loc.Error _ -> ()
| exception Loc.Errors _ -> fail "one error came as a list")); | 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) ...)" "<eval>" 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" () Test_support.report ~label:"session" ()

61
test/test_syntax.ml
View File

@ -1409,14 +1409,46 @@ let () =
found; if let over a plain name is refused toward those. *) 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" 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?, 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 "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" 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))"; "(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-let [h y] h 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)" reads "while e? as g" "while pop(s)? as x\n f(x)"
"(while true (if-let [x (pop s)] (do (f x)) (break)))"; "(while true (if (as 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"; (* 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. *) (* 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 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))"; 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 "|> before a test" "y = a |> f?" "indent/pipe-target" "\n (a |> f)?";
refuses "|> chained before ==" "y = a |> b |> f(1) == 2" "indent/pipe-target" refuses "|> chained before ==" "y = a |> b |> f(1) == 2" "indent/pipe-target"
"\n (a |> b |> f(1)) == 2"; "\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"; reads "as names what a pipe answers" "if a |> f(1) as v and v > 0\n v"
refuses "|> before as over a pattern" "if a |> f as Some(v)\n v" "indent/as-test" "(when (and (as v (f a 1)) (> v 0)) v)";
"Write (a |> f)? as name"; refuses "as before a pattern" "if a |> f as Some(v)\n v" "indent/as-name"
refuses "a call before as is not bracketed" "if f(x) as v\n v" "indent/as-test" "if let Some(v) = a |> f";
"Write f(x)? as name";
reads "|> into a macro passes the place" "y = x |> set(5)" "(set y (set x 5))"; 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 "|> 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)"; refuses "|> unspaced on the right" "y = x |>[f]" "indent/unspaced-operator" "x |> f(a)";
@ -1478,7 +1509,7 @@ let () =
refused "narrowed-set.fln" refused "narrowed-set.fln"
"fn main()\n let x: i32? = Some(1)\n if x?\n x = None\n println(x ?? 0)\n" "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"; [ "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" 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" "fn main()\n let x: i32? = None\n if x?\n println(x + 1)\n else\n println(x + 1)\n"
[ "Option(i32)" ]; [ "Option(i32)" ];
@ -1512,7 +1543,7 @@ let () =
reads "a trailing ? tests the whole chain" "y = o?.i?" reads "a trailing ? tests the whole chain" "y = o?.i?"
"(set y (? (?. [~o1 o] (.i ~o1))))"; "(set y (? (?. [~o1 o] (.i ~o1))))";
reads "and ? then as binds the chain's result" "if d?.k? as k\n k" 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" refused "narrowed-param.fln"
"fn f(x: i32?)\n if x?\n x += 100\n\nfn main()\n f(Some(1))\n" "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" ]; [ "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" "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" ]; [ "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" 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" refused "lowercase-type-arg.fln"
"struct grain\n w: i32\n\nfn main()\n let v = vec-new(grain?)\n" "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"; [ "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" | _ -> fail "addr-taken-note.fln checked"
| exception (Loc.Error d | Loc.Errors (d :: _)) -> | exception (Loc.Error d | Loc.Errors (d :: _)) ->
if not (List.exists 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) 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) | exception e -> fail "addr-taken-note.fln: %s" (diag_text e)
let () = Test_support.report ~label:"syntax" () let () = Test_support.report ~label:"syntax" ()