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

Master is merged into the when, get and if let lane for the review fixes.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 12:53:34 +07:00
commit a3899f3ecb
16 changed files with 1434 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
CLAUDE.md
View File

@ -23,10 +23,12 @@ saying what is now true, not what was done.
## Tests ## Tests
`dune test --root .` must be green before a lane reports; grep its output for A lane never runs the full `dune test`: it builds with `-j 2` and runs only the
FAIL, since the exit code alone has lied. `@checks` (`@page`, `@x86`, `@cells`), programs and test executables its change touches, one at a time, and lists them in
`@sanitize` and `@valgrind` are slow and run once between batches of lanes, with its report. After about five lanes merge, one tester agent runs `dune test --root .`
the author's permission, never inside a lane. ASan misses uninitialised stack on master and fixes what broke; grep its output for FAIL, since the exit code alone
has lied. `@checks` (`@page`, `@x86`, `@cells`), `@sanitize` and `@valgrind` are
slow and run only with the author's permission. ASan misses uninitialised stack
reads; `@valgrind` catches them. reads; `@valgrind` catches them.
## Evidence ## Evidence

20
TODO.org
View File

@ -10,6 +10,12 @@ pointing at it. A CANCELLED entry carries the one-line reason, because an idea
rejected without a record is an idea that gets re-proposed. rejected without a record is an idea that gets re-proposed.
* Language surface * Language surface
** NEXT A typed char
Decided 2026-09-26 (127): =char= is a typed code point. A char literal is typed by local
inference like a number literal: u8 or i32 where typed code wants a number (a literal
above 127 is refused as a u8), =char= otherwise; a =char= crossing into dyn stays a char.
Rules out the fork where =f(\a)= printed =\a= and =let c = \a= then =f(c)= printed 97.
Waits on the dyn char lane and the literal inference lane.
** DONE if let ** DONE if let
CLOSED: [2026-09-26] CLOSED: [2026-09-26]
=(if-let [P v] then else)= in paren syntax; an elif chain is the else. With no else it =(if-let [P v] then else)= in paren syntax; an elif chain is the else. With no else it
@ -46,11 +52,19 @@ next free-temp. Rules out copy-in/copy-out at a call, and rooting the text in th
** NEXT Dyn unless annotated ** NEXT Dyn unless annotated
Decided 2026-09-26, replacing the plain rule: number, bool and char literals are typed, Decided 2026-09-26, replacing the plain rule: number, bool and char literals are typed,
their type inferred from their uses inside the function (never across functions); an their type inferred from their uses inside the function (never across functions); an
unconstrained integer literal is int (i32) and a float literal float (f32); uses that unconstrained integer literal is int (i32) and a float literal f64 (decision 121); uses that
disagree are refused with a request for an annotation. Vector, map and text literals disagree are refused with a request for an annotation. Vector, map and text literals
are dyn unless something typed wants them. A typed value is boxed where it goes into are dyn unless something typed wants them. A typed value is boxed where it goes into
dyn, and a dyn unboxed (checked) where typed code needs it; typed beside dyn in an dyn, and a dyn unboxed (checked) where typed code needs it; typed beside dyn in an
operator gives dyn. Dyn integers stay i64 and dyn floats f64. operator gives dyn. Dyn integers stay i64 and dyn floats f64.
Decision 121: f64 and not f32, because f32 locals lost precision silently — 0.1 summed a
million times printed 100958. A float literal is f32 only where inference finds typed code
wanting f32 (a parameter, field, return or operand). A literal local fed only by dyn takes
the dyn width, i64 or f64.
Done: local inference (check.ml [lit_session]), an integer and a float literal meeting
at the float. Waiting: text and vector literals dyn by default, on
dyn text to str and dyn vec to slice conversion (a lane after views); =FLAN_LIT=dyn=
measures it, and under it a let-bound one some typed use wants already stays typed.
** DONE Dynamic-first, and the dyn half of the language ** DONE Dynamic-first, and the dyn half of the language
CLOSED: [2026-09-20] CLOSED: [2026-09-20]
An unannotated parameter or return is =dyn=: a NaN-boxed value over a mark-sweep An unannotated parameter or return is =dyn=: a NaN-boxed value over a mark-sweep
@ -702,6 +716,10 @@ consecutive lets this way.
Rules out ~loop~/~recur~ anywhere the .fln reader reads, ~quote~ included; loops are Rules out ~loop~/~recur~ anywhere the .fln reader reads, ~quote~ included; loops are
~while~/~until~/~dotimes~/~for~. The Lisp syntax and its macros' expansions keep them. ~while~/~until~/~dotimes~/~for~. The Lisp syntax and its macros' expansions keep them.
** DONE A .fln chain may mix < with <=, or > with >= (decision 124)
~0 <= r < rows~ is the ~and~ of its tests; like ~(< a b c)~ every operand runs once, left to right,
with no short-circuit. Direction changes and ~==~/~!=~ in a mix stay refused.
** TODO Hard-coded code in messages is still paren syntax in a .fln file ** TODO Hard-coded code in messages is still paren syntax in a .fln file
Types follow the code's syntax now (=Types.spell=). Hints written into a message's Types follow the code's syntax now (=Types.spell=). Hints written into a message's
text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the

785
lib/check.ml
View File

File diff suppressed because it is too large Load Diff

103
lib/indent_printer.ml
View File

@ -173,6 +173,92 @@ let rec pat_names (t : Form.t) : string list option =
let binds n t = match pat_names t with Some ns -> List.mem n ns | None -> false let binds n t = match pat_names t with Some ns -> List.mem n ns | None -> false
(* [f] as a comparison chain that mixes < with <=, or > with >=: its operands
and operators, when the reader would read the chain back as [f] itself.
The candidate is rebuilt by the reader's own [cmp_chain] and compared up to
the names its [let]s bind, so an [and] of tests that only looks like a
chain, or a [let] the reader would not have made, prints as it is. *)
let chain_of (f : Form.t) =
let rec eq env (a : Form.t) (b : Form.t) =
match a.v, b.v with
| Form.Sym x, Form.Sym y ->
(match List.assoc_opt x env with
| Some y' -> y = y'
| None -> x = y && not (List.exists (fun (_, y') -> y' = y) env))
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bx; _ } :: xs),
Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec by; _ } :: ys) ->
let rec binds env bx by =
match bx, by with
| ({ Form.v = Form.Sym tx; _ }) :: vx :: bx', ({ Form.v = Form.Sym ty; _ }) :: vy :: by' ->
if eq env vx vy then binds ((tx, ty) :: env) bx' by' else None
| [], [] -> Some env
| _ -> None
in
(match binds env bx by with
| Some env -> List.length xs = List.length ys && List.for_all2 (eq env) xs ys
| None -> false)
| Form.List xs, Form.List ys | Form.Vec xs, Form.Vec ys | Form.Map xs, Form.Map ys ->
List.length xs = List.length ys && List.for_all2 (eq env) xs ys
| x, y -> x = y
in
let subst env (x : Form.t) =
match x.v with
| Form.Sym s -> Option.value (List.assoc_opt s env) ~default:x
| _ -> x
in
(* The tests, left to right, with each bound name replaced by its value. *)
let rec tests env (f : Form.t) =
match f.v with
| Form.List [ { v = Form.Sym "let"; _ }; { v = Form.Vec bs; _ }; body ] ->
let rec binds env = function
| ({ Form.v = Form.Sym t; _ }) :: v :: rest -> binds ((t, subst env v) :: env) rest
| [] -> Some env
| _ -> None
in
Option.bind (binds env bs) (fun env -> tests env body)
| Form.List ({ v = Form.Sym "and"; _ } :: (_ :: _ :: _ as cs)) ->
List.fold_left
(fun acc c -> Option.bind acc (fun l -> Option.map (( @ ) l) (tests env c)))
(Some []) cs
| Form.List [ { v = Form.Sym op; _ }; a; b ] when R.cmp_dir op <> None ->
Some [ (op, subst env a, subst env b) ]
| _ -> None
in
let rec linked = function
| (_, _, b) :: ((_, a, _) :: _ as rest) -> eq [] b a && linked rest
| _ -> true
in
(* In a template the paren text spells a [~cmp] name as the unquoted call
that makes it, [~(Form.Sym {.s "~cmp1"})]: read it as the name. *)
let rec unwrap (x : Form.t) =
match x.v with
| Form.List [ { v = Form.Sym "unquote"; _ };
{ v = Form.List [ { v = Form.Sym "Form.Sym"; _ };
{ v = Form.Map [ { v = Form.Sym ".s"; _ };
{ v = Form.Str n; _ } ]; _ } ]; _ } ]
when String.length n > 4 && String.sub n 0 4 = "~cmp" -> { x with v = Form.Sym n }
| Form.List l -> { x with v = Form.List (List.map unwrap l) }
| Form.Vec l -> { x with v = Form.Vec (List.map unwrap l) }
| _ -> x
in
match f.v with
| Form.List ({ v = Form.Sym ("and" | "let"); _ } :: _) ->
let f = unwrap f in
(match tests [] f with
| Some (((op1, x0, _) :: _ :: _) as ts)
when linked ts
&& List.for_all (fun (op, _, _) -> R.cmp_dir op = R.cmp_dir op1) ts
&& List.exists (fun (op, _, _) -> op <> op1) ts ->
let xs = x0 :: List.map (fun (_, _, b) -> b) ts in
let ops = List.map (fun (op, _, _) -> op) ts in
let n = ref 0 in
let fresh () = incr n; Printf.sprintf "~cmp%d" !n in
if eq [] f (R.cmp_chain ~fresh f.loc xs ops) then Some (xs, ops) else None
| _ -> None)
| _ -> None
let is_chain f = chain_of f <> None
(* Whether [f] mentions [n]: the name, or a field path or qualified name (* Whether [f] mentions [n]: the name, or a field path or qualified name
starting with it. Any occurrence counts, a quoted one or one under an starting with it. Any occurrence counts, a quoted one or one under an
unquote included. A macro whose expansion names a variable its call does unquote included. A macro whose expansion names a variable its call does
@ -266,7 +352,7 @@ let rename_let n n' (bs : Form.t list) (body : Form.t list) =
let flatten (f : Form.t) (rest : Form.t list) = let flatten (f : Form.t) (rest : Form.t list) =
match f.v with match f.v with
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: (_ :: _ as body)) | Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: (_ :: _ as body))
when rest <> [] && bs <> [] && List.length bs mod 2 = 0 -> when rest <> [] && bs <> [] && List.length bs mod 2 = 0 && not (is_chain f) ->
Option.bind Option.bind
(all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs)) (all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs))
(fun names -> (fun names ->
@ -326,6 +412,13 @@ let rec expr (f : Form.t) : string * int =
| Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 13) | Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 13)
| Form.Map xs -> ("{" ^ map_text xs ^ "}", 13) | Form.Map xs -> ("{" ^ map_text xs ^ "}", 13)
| Form.List [] -> ("()", 13) | Form.List [] -> ("()", 13)
| Form.List _ when is_chain f ->
let xs, ops = Option.get (chain_of f) in
let lvl = Option.get (R.binop_level (List.hd ops)) in
let ts = List.map (at (lvl + 1)) xs in
(List.hd ts
^ String.concat "" (List.map2 (fun op t -> " " ^ op ^ " " ^ t) ops (List.tl ts)),
lvl)
| Form.List (h :: args) -> in_quasi f (fun () -> list f h args) | Form.List (h :: args) -> in_quasi f (fun () -> list f h args)
and sym f s = and sym f s =
@ -616,6 +709,7 @@ let body_guess (h : Form.t) args =
lists goes in the block. *) lists goes in the block. *)
let stmt_like (a : Form.t) = let stmt_like (a : Form.t) =
match a.v with match a.v with
| Form.List _ when is_chain a -> false
| Form.List ({ v = Form.Sym h; _ } :: _) -> | Form.List ({ v = Form.Sym h; _ } :: _) ->
List.mem h [ "let"; "set"; "when"; "if-let"; "unless"; "cond"; "while"; List.mem h [ "let"; "set"; "when"; "if-let"; "unless"; "cond"; "while";
"until"; "dotimes"; "match"; "handler-case"; "until"; "dotimes"; "match"; "handler-case";
@ -652,7 +746,8 @@ let body_guess (h : Form.t) args =
let let_sugar (f : Form.t) = let let_sugar (f : Form.t) =
match f.v with match f.v with
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: _ :: _) -> | Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: _ :: _)
when not (is_chain f) ->
(match pairs bs with None | Some [] -> false | Some _ -> true) (match pairs bs with None | Some [] -> false | Some _ -> true)
| _ -> false | _ -> false
@ -951,6 +1046,7 @@ and value_lines n prefix (v : Form.t) =
if n + String.length inline <= width then [ ind n ^ inline ] if n + String.length inline <= width then [ ind n ^ inline ]
else else
match v.v with match v.v with
| _ when is_chain v -> [ ind n ^ inline ]
| Form.List ({ v = Form.Sym h; _ } :: _) | Form.List ({ v = Form.Sym h; _ } :: _)
when not (List.mem h sugar_heads || h = "fn" || h = "if") -> when not (List.mem h sugar_heads || h = "fn" || h = "if") ->
wrapped n (prefix ^ " = ") v wrapped n (prefix ^ " = ") v
@ -967,7 +1063,8 @@ and label_of = function
and sugar n (f : Form.t) : string list option = and sugar n (f : Form.t) : string list option =
let i = ind n in let i = ind n in
match f.v with match f.v with
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) -> | Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body))
when not (is_chain f) ->
(match pairs bs with (match pairs bs with
| None | Some [] -> None | None | Some [] -> None
| Some prs -> Some (let_lines n prs body)) | Some prs -> Some (let_lines n prs body))

130
lib/indent_reader.ml
View File

@ -100,6 +100,49 @@ let compound (at : Loc.t) op (e : Form.t) (v : Form.t) span =
Form.List Form.List
[ Form.make (Form.Sym "update") at; e; Form.make (Form.Sym op) at; v ] [ Form.make (Form.Sym "update") at; e; Form.make (Form.Sym op) at; v ]
(* A comparison chain that mixes [<] with [<=], or [>] with [>=], is the
[and] of its neighbouring pairs: [0 <= r < rows] is
[(and (<= 0 r) (< r rows))]. It is evaluated as [(< a b c)] is: every
operand once, left to right, before any test, with no short-circuit. When
an operand is more than a name or a literal, every operand but a literal
is bound first, in order, to a fresh [~cmp] name, which no reader can
produce: a name too, since a call to its right may change it. The printer
rebuilds a candidate with this same function and prints the chain only
when the two agree. *)
let cmp_dir = function
| "<" | "<=" -> Some `Up
| ">" | ">=" -> Some `Down
| _ -> None
let cmp_chain ~fresh (l : Loc.t) (xs : Form.t list) (ops : string list) =
let mkf v = Form.make v l in
let s x = mkf (Form.Sym x) in
let literal (x : Form.t) =
match x.v with
| Form.Int _ | Form.UInt _ | Form.Float _ | Form.Str _ | Form.Byte _
| Form.Kw _ | Form.Sym ("true" | "false" | "nil") -> true
| _ -> false
in
let simple (x : Form.t) = literal x || (match x.v with Form.Sym _ -> true | _ -> false) in
let keep = if List.for_all simple xs then simple else literal in
let bound =
List.map (fun x -> if keep x then (None, x) else
let t = s (fresh ()) in (Some (t, x), t)) xs
in
let refs = List.map snd bound in
let rec tests = function
| a :: (b :: _ as rest), op :: ops -> mkf (Form.List [ s op; a; b ]) :: tests (rest, ops)
| _ -> []
in
let body = mkf (Form.List (s "and" :: tests (refs, ops))) in
match List.concat_map (function (Some (t, x), _) -> [ t; x ] | _ -> []) bound with
| [] -> body
| bs -> mkf (Form.List [ s "let"; mkf (Form.Vec bs); body ])
(* The reader's fresh names for [cmp_chain], counted per [read_all]. *)
let cmp_n = ref 0
let cmp_fresh () = incr cmp_n; Printf.sprintf "~cmp%d" !cmp_n
(* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything (* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything
else keeps the Lisp reading, so [--], [->] and [-=] stay names. *) else keeps the Lisp reading, so [--], [->] and [-=] stay names. *)
let is_neg_char c = let is_neg_char c =
@ -683,6 +726,30 @@ let when_else p =
and None when it does not. For two branches write if c then a else b, \ and None when it does not. For two branches write if c then a else b, \
or an if with an else block" or an if with an else block"
(* A refused chain written out as the [and] of all its tests. A middle
operand that is more than a name or a literal is named by a [let] first,
so the rewrite does not run it twice. *)
let and_rewrite (xs : Form.t list) ops =
let n = List.length xs in
let lets = ref [] in
let texts =
List.mapi
(fun i (x : Form.t) ->
let plain = match x.v with Form.List _ | Form.Vec _ | Form.Map _ -> false | _ -> true in
if plain || i = 0 || i = n - 1 then text_of x
else begin
let m = if !lets = [] then "mid" else Printf.sprintf "mid%d" (List.length !lets + 1) in
lets := Printf.sprintf " let %s = %s\n" m (text_of x) :: !lets;
m
end)
xs
in
let rec tests = function
| a :: (b :: _ as rest), op :: ops -> Printf.sprintf "%s %s %s" a op b :: tests (rest, ops)
| _ -> []
in
String.concat "" (List.rev !lets) ^ " " ^ String.concat " and " (tests (texts, ops))
(* Expressions come back with their syntactic level: 13 an atom or a bracket, (* Expressions come back with their syntactic level: 13 an atom or a bracket,
12 a postfix chain, 11 a prefix [-] or [~~], 1-10 a binary operator's 12 a postfix chain, 11 a prefix [-] or [~~], 1-10 a binary operator's
level, 3 a [not], 0 a one-line [if] or a lambda. Anything under 11 is level, 3 a [not], 0 a one-line [if] or a lambda. Anything under 11 is
@ -713,31 +780,62 @@ and binary p lvl : Form.t * int =
binop_level s = Some lvl binop_level s = Some lvl
&& not ((peek_at p 1).tok = LP && not (peek_at p 1).sp) && not ((peek_at p 1).tok = LP && not (peek_at p 1).sp)
in in
let operator s =
let ot = advance p in
if not (ot.sp && (peek p).sp) then
failk "unspaced-operator" ot.loc
"%s is an operator here, and a binary operator has a space on each \
side: a %s b. Without them a-b is one name"
s s;
let rhs, _ = binary p (lvl + 1) in
(ot, rhs)
in
let rec run op operands = let rec run op operands =
match (peek p).tok with match (peek p).tok with
| NAME s when binary_here s -> | NAME s when binary_here s ->
let ot = advance p in let _, rhs = operator s in
if not (ot.sp && (peek p).sp) then
failk "unspaced-operator" ot.loc
"%s is an operator here, and a binary operator has a space on each \
side: a %s b. Without them a-b is one name"
s s;
let rhs, _ = binary p (lvl + 1) in
if s = op then run op (rhs :: operands) if s = op then run op (rhs :: operands)
else begin else
if lvl = 4 then
failk "mixed-comparison" ot.loc
"%s follows %s in one chain, and a chain compares with one \
operator. Join the tests with and, or parenthesise one side"
s op;
let folded, _ = close op operands in let folded, _ = close op operands in
run s [ rhs; folded ] run s [ rhs; folded ]
end
| _ -> close op operands | _ -> close op operands
in in
(* A comparison chain is read whole, then judged: one operator throughout
is the variadic call, one direction is [cmp_chain], anything else is
refused at the first operator that breaks it. *)
let rec chain acc =
match (peek p).tok with
| NAME s when binary_here s ->
let ot, rhs = operator s in
chain ((s, ot, rhs) :: acc)
| _ -> List.rev acc
in
let comparison () =
let links = chain [] in
let ops = List.map (fun (s, _, _) -> s) links in
let xs = first :: List.map (fun (_, _, x) -> x) links in
let op1 = List.hd ops in
if List.for_all (( = ) op1) ops then close op1 (List.rev xs)
else
let d = cmp_dir op1 in
Array.iteri
(fun i (op, (ot : token), _) ->
if i > 0 && (d = None || cmp_dir op <> d) then begin
let prev, _, _ = List.nth links (i - 1) in
failk "mixed-comparison" ot.loc
"%s follows %s in one chain. A chain may repeat one operator, \
or mix < with <=, or > with >=, as in 0 <= i < n. Write this \
one as tests joined with and:\n\n%s"
op prev (and_rewrite xs ops)
end)
(Array.of_list links);
(cmp_chain ~fresh:cmp_fresh (span p l0) xs ops, lvl)
in
(* [run] folds a different operator at the same level into the left (* [run] folds a different operator at the same level into the left
operand, so the first operator here only starts the first run. *) operand, so the first operator here only starts the first run. *)
match (peek p).tok with match (peek p).tok with
| NAME s when binary_here s && (cmp_dir s <> None || s = "==" || s = "!=") ->
comparison ()
| NAME s when binary_here s -> run s [ first ] | NAME s when binary_here s -> run s [ first ]
| _ -> fst_ | _ -> fst_
@ -2355,12 +2453,14 @@ let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
let snippet = col <> None in let snippet = col <> None in
let col = Option.value col ~default:1 in let col = Option.value col ~default:1 in
let saved = !source in let saved = !source in
let saved_n = !cmp_n in
cmp_n := 0;
(* The quoted text is indexed by the buffer's lines, so a snippet that (* The quoted text is indexed by the buffer's lines, so a snippet that
starts on line 40 is padded to start there. *) starts on line 40 is padded to start there. *)
source := source :=
(file, Array.of_list (String.split_on_char '\n' (file, Array.of_list (String.split_on_char '\n'
(String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src))); (String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src)));
Fun.protect ~finally:(fun () -> source := saved) (fun () -> Fun.protect ~finally:(fun () -> source := saved; cmp_n := saved_n) (fun () ->
let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) in let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) in
let s = { p = { toks; i = 0; closed = -1 }; lets = [] } in let s = { p = { toks; i = 0; closed = -1 }; lets = [] } in
(* At the top level, a [let] is a global, [(def x dyn v)]: a let there has (* At the top level, a [let] is a global, [(def x dyn v)]: a let there has

53
lib/paren_printer.ml
View File

@ -315,7 +315,60 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
| _ -> [ one ] | _ -> [ one ]
(** A whole file, with [source]'s comments and spellings when given. *) (** A whole file, with [source]'s comments and spellings when given. *)
(* A .fln comparison chain binds its operands to [~cmp] names, which paren
text cannot spell ([~] opens an unquote). Outside a template each gets a
name that nothing in its top-level form uses, so no reference there is
captured. Inside one a plain name would capture the caller's variable of
that name, and the paren syntax has no auto-gensym, so the name is made
where it lands: [~(Form.Sym {.s "~cmp1"})], a name no caller can write. *)
let readable_temps (f : Form.t) =
let is_temp s = String.length s > 4 && String.sub s 0 4 = "~cmp" in
let rec syms acc (f : Form.t) =
match f.v with
| Form.Sym s -> s :: acc
| Form.List l | Form.Vec l | Form.Map l -> List.fold_left syms acc l
| _ -> acc
in
let all = syms [] f in
let temps =
List.fold_left
(fun acc s -> if is_temp s && not (List.mem s acc) then s :: acc else acc)
[] (List.rev all)
|> List.rev
in
if temps = [] then f
else
let taken = ref all in
let rec pick i =
let n = if i = 1 then "mid" else Printf.sprintf "mid%d" i in
if List.mem n !taken then pick (i + 1) else (taken := n :: !taken; n)
in
let names = List.map (fun t -> (t, pick 1)) temps in
let rec go depth (f : Form.t) =
let sub l = List.map (go depth) l in
match f.v with
| Form.Sym s when is_temp s && depth > 0 ->
let m v = Form.make v f.loc in
m (Form.List
[ m (Form.Sym "unquote");
m (Form.List [ m (Form.Sym "Form.Sym");
m (Form.Map [ m (Form.Sym ".s"); m (Form.Str s) ]) ]) ])
| Form.Sym s ->
(match List.assoc_opt s names with Some n -> { f with v = Form.Sym n } | None -> f)
| Form.List [ ({ v = Form.Sym "quasiquote"; _ } as h); x ] ->
{ f with v = Form.List [ h; go (depth + 1) x ] }
| Form.List [ ({ v = Form.Sym ("unquote" | "unquote-splicing"); _ } as h); x ]
when depth > 0 ->
{ f with v = Form.List [ h; go (depth - 1) x ] }
| Form.List l -> { f with v = Form.List (sub l) }
| Form.Vec l -> { f with v = Form.Vec (sub l) }
| Form.Map l -> { f with v = Form.Map (sub l) }
| _ -> f
in
go 0 f
let program ?source (fs : Form.t list) : string = let program ?source (fs : Form.t list) : string =
let fs = List.map readable_temps fs in
let spell = let spell =
match source with Some src -> Source_text.spelling src | None -> fun _ -> None match source with Some src -> Source_text.spelling src | None -> fun _ -> None
in in

79
runtime/flan_rt.c
View File

@ -1125,13 +1125,86 @@ _Noreturn void flan_restart_fail(const uint8_t *loc, int64_t loclen,
* dynamic stack, so the invoke site cannot see what it will find, and the * dynamic stack, so the invoke site cannot see what it will find, and the
* frame cannot see who will find it. What each end knows is its own parameter * frame cannot see who will find it. What each end knows is its own parameter
* list, so the message is both of them side by side. */ * list, so the message is both of them side by side. */
/* The top-level items of a signature "(a b c)", where an item may itself be
* bracketed: "(Ptr i32)", "[3 f64]". Up to [max]; answers how many. */
static int sig_items(const uint8_t *s, int64_t n, const uint8_t **at,
int64_t *len, int max) {
int count = 0, depth = 0;
int64_t start = -1;
for (int64_t i = 1; i + 1 < n; i++) {
uint8_t c = s[i];
if (c == ' ' && depth == 0) {
if (start >= 0 && count < max) { at[count] = s + start; len[count] = i - start; count++; }
start = -1;
continue;
}
if (start < 0) start = i;
if (c == '(' || c == '[') depth++;
else if (c == ')' || c == ']') depth--;
}
if (start >= 0 && count < max) { at[count] = s + start; len[count] = n - 1 - start; count++; }
return count;
}
static int is_number_type(const uint8_t *s, int64_t n) {
static const char *names[] = { "i8", "i16", "i32", "i64", "u8", "u16",
"u32", "u64", "f32", "f64" };
for (size_t k = 0; k < sizeof names / sizeof names[0]; k++)
if ((int64_t)strlen(names[k]) == n && memcmp(names[k], s, (size_t)n) == 0)
return 1;
return 0;
}
/* [got] is the invoke site's signature, then after each 0x1f: the syntax
* (i or p) and every argument as written. Where the two signatures differ
* only in which number type an argument is, the fix is that argument
* converted: (f64 2.5), or f64(2.5) in the indented syntax. */
_Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen, _Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen,
const uint8_t *name, int64_t namelen, const uint8_t *name, int64_t namelen,
const uint8_t *want, int64_t wantlen, const uint8_t *want, int64_t wantlen,
const uint8_t *got, int64_t gotlen) { const uint8_t *got, int64_t gotlen) {
flan_say(loc, loclen, "restart %.*s takes %.*s, given %.*s", (int)namelen, enum { MAX = 16 };
(const char *)name, (int)wantlen, (const char *)want, (int)gotlen, const uint8_t *part[MAX + 2];
(const char *)got); int64_t plen[MAX + 2];
int parts = 0;
int64_t start = 0;
for (int64_t i = 0; i <= gotlen && parts < MAX + 2; i++)
if (i == gotlen || got[i] == 0x1f) {
part[parts] = got + start; plen[parts] = i - start; parts++;
start = i + 1;
}
const uint8_t *w[MAX], *g[MAX];
int64_t wl[MAX], gl[MAX];
int nw = sig_items(want, wantlen, w, wl, MAX);
int ng = sig_items(part[0], plen[0], g, gl, MAX);
char fix[512];
size_t used = 0;
fix[0] = 0;
int ok = parts >= 2 && nw == ng && ng == parts - 2 && ng > 0;
for (int k = 0; ok && k < ng; k++) {
if (wl[k] == gl[k] && memcmp(w[k], g[k], (size_t)wl[k]) == 0) continue;
if (!is_number_type(w[k], wl[k]) || !is_number_type(g[k], gl[k])) { ok = 0; break; }
int indented = plen[1] == 1 && part[1][0] == 'i';
int wrote = indented
? snprintf(fix + used, sizeof fix - used, "%s%.*s(%.*s)", used ? ", " : "",
(int)wl[k], (const char *)w[k], (int)plen[k + 2], (const char *)part[k + 2])
: snprintf(fix + used, sizeof fix - used, "%s(%.*s %.*s)", used ? ", " : "",
(int)wl[k], (const char *)w[k], (int)plen[k + 2], (const char *)part[k + 2]);
if (wrote < 0 || (size_t)wrote >= sizeof fix - used) { ok = 0; break; }
used += (size_t)wrote;
}
/* An argument the compiler could not spell is an ellipsis, and a fix with
* a hole in it is a conversion to make, not code to paste. */
int holed = strstr(fix, "\xe2\x80\xa6") != NULL;
if (ok && used > 0)
flan_say(loc, loclen, "restart %.*s takes %.*s, given %.*s. %s %s",
(int)namelen, (const char *)name, (int)wantlen, (const char *)want,
(int)plen[0], (const char *)part[0],
holed ? "Convert the argument with" : "Write", fix);
else
flan_say(loc, loclen, "restart %.*s takes %.*s, given %.*s", (int)namelen,
(const char *)name, (int)wantlen, (const char *)want, (int)plen[0],
(const char *)part[0]);
rt_trap((const uint8_t *)"RestartArity", 12); rt_trap((const uint8_t *)"RestartArity", 12);
} }

15
spec-syntax.md
View File

@ -156,14 +156,25 @@ Each item: the proposal, then the reason in one line.
- **Precedence**, low to high: `or` < `and` < `not` < comparisons - **Precedence**, low to high: `or` < `and` < `not` < comparisons
(`== != < <= > >=`) < `||` < `^^` < `&&` < `<< >>` < `+ -` < `* / %` < (`== != < <= > >=`) < `||` < `^^` < `&&` < `<< >>` < `+ -` < `* / %` <
prefix `-` and `~~` < postfix (call, index, field). **Built.** Mixing prefix `-` and `~~` < postfix (call, index, field). **Built.** An operator
comparison operators in one chain, `a < b <= c`, is refused. An operator
glued to `(` is always a call. The bit operators sit where Python and Rust glued to `(` is always a call. The bit operators sit where Python and Rust
put them, so `x && mask == 0` is `(x && mask) == 0`. put them, so `x && mask == 0` is `(x && mask) == 0`.
- **The bit operators** are `a && b`, `a || b`, `a ^^ b` and `~~a`, reading - **The bit operators** are `a && b`, `a || b`, `a ^^ b` and `~~a`, reading
`(bit-and a b)`, `(bit-or a b)`, `(bit-xor a b)` and `(bit-not a)`. They take `(bit-and a b)`, `(bit-or a b)`, `(bit-xor a b)` and `(bit-not a)`. They take
integers; `and`, `or` and `not` are the logical ones. `~~` is one token, so a integers; `and`, `or` and `not` are the logical ones. `~~` is one token, so a
nested unquote is written `~(~x)`. **Built.** nested unquote is written `~(~x)`. **Built.**
- **A comparison chain may mix `<` with `<=`, or `>` with `>=`** (decision
124). `0 <= r < rows` reads `(and (<= 0 r) (< r rows))`. It is evaluated as
`a < b < c` is: every operand once, left to right, before any test, with no
short-circuit. When an operand is more than a name or a literal, every
operand but a literal is bound first, in order, to a fresh name, so a name
is read before a call to its right runs: `a < f(x) <= b` reads
`(let [~cmp1 a ~cmp2 (f x) ~cmp3 b] (and (< ~cmp1 ~cmp2) (<= ~cmp2 ~cmp3)))`.
`flan convert` to parens names them `mid`, `mid2`, ..., or, inside a
template, `~(Form.Sym {.s "~cmp1"})`, which no caller can capture. A chain that
changes direction, `a < b > c`, or mixes in `==` or `!=`, is refused with the
whole chain rewritten as `and`, a middle call named by a `let` first. The
printer writes such an `and` back as the chain. **Built.**
- **`==` is `=`; `=` is assignment.** `x = v` reads `(set x v)`, `a[i] = v` - **`==` is `=`; `=` is assignment.** `x = v` reads `(set x v)`, `a[i] = v`
reads `(set (at a i) v)`, `p.x = v` reads `(set (.x p) v)`. `x += v` reads reads `(set (at a i) v)`, `p.x = v` reads `(set (.x p) v)`. `x += v` reads
`(set x (+ x v))` where every part of the place is a name or a literal, and `(set x (+ x v))` where every part of the place is a name or a literal, and

82
test/programs/literal-locals.flan Normal file
View File

@ -0,0 +1,82 @@
;;;; A number literal bound by let or loop takes its type from its uses in
;;;; the function. Each line's expected output is beside it.
;; A set of an i64 sum makes the accumulator an i64.
(defn total [xs [i64]] i64
(let [t 0]
(dotimes [i (length xs)]
(set t (+ t (at xs i))))
t))
;; The operand beside it: an f64 accumulator from a float literal.
(defn mean [xs [f64]] f64
(let [s 0.0]
(dotimes [i (length xs)]
(set s (+ s (at xs i))))
(/ s (f64 (length xs)))))
;; A counter compared with an i64 bound counts past i32.
(defn count-to [n i64] i64
(let [i 0]
(while (< i n)
(set i (+ i 1000000000)))
i))
;; A set of one literal local into another links them: b holds a value past
;; i32, so a is an i64 too.
(defn linked [] i64
(let [a 0 b 0]
(set b 3000000000)
(set a b)
a))
;; Two locals fed from each other: i is counted against an i64, and acc
;; sums a literal past i32.
(defn sum-to [n i64] i64
(let [i 0 acc 0]
(while (< i n)
(set acc (+ acc 1000000000))
(set i (+ i 1)))
acc))
;; Inside a generic body the literal takes the type variable.
(defn sum-of [xs [$t]] $t {:where (numeric? $t)}
(let [acc 0]
(dotimes [i (length xs)]
(set acc (+ acc (at xs i))))
acc))
;; A chain of sets settles however long it is.
(defn chained [x i64] i64
(let [a0 0 a1 0 a2 0 a3 0 a4 0 a5 0]
(set a0 x) (set a1 (+ a0 1)) (set a2 (+ a1 1)) (set a3 (+ a2 1))
(set a4 (+ a3 1)) (set a5 (+ a4 1))
a5))
;; A dyn number is an i64 or an f64, and so is a literal local it feeds.
(defn boxed [x] dyn x)
(defn from-dyn [] ()
(let [d (boxed 0.1) s 0.0 n 0]
(set s (+ s d))
(set n (+ n (boxed 5000000000)))
(println s n)))
(defn main [] i32
(let [xs (the [3 i64] [3000000000 4 5])
fs (the [2 f64] [0.5 0.25])
gs (the [2 u8] [200 50])]
(println (total (slice xs 0 3))) ; 3000000009
(println (mean (slice fs 0 2))) ; 0.375
(println (count-to 5000000000)) ; 5000000000
(println (linked)) ; 3000000000
(println (sum-to 3)) ; 3000000000
(println (sum-of (slice xs 0 3))) ; 3000000009
(println (sum-of (slice fs 0 2)))) ; 0.75
(println (chained 3000000000)) ; 3000000005
(from-dyn) ; 0.1 5000000000
(let [x 0.1]
(println (= (boxed x) (boxed 0.1)))) ; true
;; Nothing says otherwise: an i32 and an f64.
(let [n 7 f 1.5]
(println n f)) ; 7 1.5
0)

11
test/programs/restarts.flan
View File

@ -101,6 +101,15 @@
(handler-bind [(AssetMissing [c] (invoke-restart 'use-value 21))] (handler-bind [(AssetMissing [c] (invoke-restart 'use-value 21))]
(shadowed n))) (shadowed n)))
;;; A number of another type: the refusal writes the conversion.
(defn widened [n i32] i32
(handler-bind [(AssetMissing [c] (let [big (i64 7)] (invoke-restart 'use-value big)))]
(supplied n)))
(defn doubled [n i32] i32
(handler-bind [(AssetMissing [c] (let [big (i64 7)] (invoke-restart 'use-value (* big 2))))]
(supplied n)))
(defn main [args [str]] i32 (defn main [args [str]] i32
;; One argument selects a trap; none runs the table's case. ;; One argument selects a trap; none runs the table's case.
(if (> (length args) 1) (if (> (length args) 1)
@ -110,6 +119,8 @@
(= k 2) (print (mistyped 91)) (= k 2) (print (mistyped 91))
(= k 3) (print (overfull 92)) (= k 3) (print (overfull 92))
(= k 4) (print (mislaid 93)) (= k 4) (print (mislaid 93))
(= k 5) (print (widened 94))
(= k 6) (print (doubled 95))
:else (println "?")) :else (println "?"))
(return 0))) (return 0)))

16
test/syntax/chain/macro.fln Normal file
View File

@ -0,0 +1,16 @@
;;;; A chain in a macro's template, converted to parens: the names it binds
;;;; must not capture the caller's, which here are the ones the converter
;;;; would otherwise pick.
defmacro(between, [lo x hi]):
quote
~lo <= ~x < ~hi
fn main() -> i32
let mid = 1
let mid2 = 2
let mid3 = 3
println(between(mid, 5, mid))
println(between(0, mid2, mid3))
println(between(mid3, mid2, mid))
0

76
test/syntax/handwritten/chain-mixed.fln Normal file
View File

@ -0,0 +1,76 @@
;;;; A comparison chain that mixes < with <=, or > with >=, is the and of its
;;;; neighbouring tests, evaluated as a < b < c is. Every operand below comes
;;;; through mark, which prints its tag, so each tag line is a transcript:
;;;; each operand runs exactly once, in source order, even after a false test.
once calls = 0
fn mark(tag: str, v: i32) -> i32
calls += 1
print(tag)
v
fn line(b: bool) -> ()
print(" -> ")
println(b)
; A name is read where it stands, before a call to its right changes it.
once level = 0
fn raise() -> i32
level = 10
5
fn dyn-mark(tag, v)
print(tag)
v
fn in-grid(r: i32, rows: i32) -> bool = 0 <= r < rows
fn dyn-between(lo, x, hi) = lo <= x < hi
fn main() -> i32
print(in-grid(0, 3))
print(" ")
print(in-grid(2, 3))
print(" ")
print(in-grid(3, 3))
print(" ")
print(in-grid(-1, 3))
println("")
let a = 1
let b = 2
let c = 2
let d = 5
print(a < b <= c < d)
print(" ")
print(a < b <= c < 2)
print(" ")
print(d >= c > 1)
print(" ")
print(d >= c > 2)
println("")
; A middle operand that is a call runs once although two tests name it.
line(mark("a", 1) < mark("b", 2) <= mark("c", 2))
line(mark("a", 1) < mark("b", 2) <= mark("c", 1))
; The first test is false, and every operand still runs.
line(mark("a", 3) < mark("b", 2) <= mark("c", 5))
line(mark("a", 1) <= mark("b", 2) < mark("c", 3) <= mark("d", 3))
line(mark("a", 9) >= mark("b", 5) > mark("c", 7) >= mark("d", 0))
println(calls)
; The same over dyn operands.
print(dyn-between(0, 0, 3))
print(" ")
print(dyn-between(0, 3, 3))
print(" ")
print(dyn-between(1.5, 2, 2.5))
println("")
line(dyn-mark("p", 1) < dyn-mark("q", 2) <= dyn-mark("r", 2))
line(dyn-mark("p", 5) < dyn-mark("q", 2) <= dyn-mark("r", 9))
print(level < raise() <= 7)
level = 0
print(" ")
println(<(level, raise(), 7))
0

12
test/syntax/handwritten/chain-mixed.out Normal file
View File

@ -0,0 +1,12 @@
true true false false
true false true false
abc -> true
abc -> false
abc -> false
abcd -> true
abcd -> false
17
true false true
pqr -> true
pqr -> false
true true

12
test/test_acceptance.ml
View File

@ -389,6 +389,14 @@ let () =
outputs "value semantics" "programs/values.flan" values_out; outputs "value semantics" "programs/values.flan" values_out;
outputs "machine surface" "programs/machine.flan" machine_out; outputs "machine surface" "programs/machine.flan" machine_out;
outputs "unit main exits 0" "programs/unit-main.flan" "ok\n"; outputs "unit main exits 0" "programs/unit-main.flan" "ok\n";
let literal_locals_out =
"3000000009\n0.375\n5000000000\n3000000000\n3000000000\n3000000009\n\
0.75\n3000000005\n0.1 5000000000\ntrue\n7 1.5\n"
in
outputs "literal locals take their uses' type" "programs/literal-locals.flan"
literal_locals_out;
outputs ~x86:true "literal locals take their uses' type, --x86"
"programs/literal-locals.flan" literal_locals_out;
(* Comparisons over three operands and more. The lines that carry the (* Comparisons over three operands and more. The lines that carry the
whole claim are the tag transcripts: [abc -> false] is a chain whose whole claim are the tag transcripts: [abc -> false] is a chain whose
*first* link already decided the answer and whose middle operand — *first* link already decided the answer and whose middle operand —
@ -1467,6 +1475,10 @@ let () =
have taken them is not consulted. *) have taken them is not consulted. *)
refuses "a shadowing clause of the same name and a different signature" "4" refuses "a shadowing clause of the same name and a different signature" "4"
"restart use-value takes (str), given (i32)"; "restart use-value takes (str), given (i32)";
refuses "a number of another type is refused with its conversion" "5"
"restart use-value takes (i32), given (i64). Write (i32 big)";
refuses "and the argument as it was written when it is an expression" "6"
"restart use-value takes (i32), given (i64). Write (i32 (* big 2))";
(try Sys.remove exe with Sys_error _ -> ()) (try Sys.remove exe with Sys_error _ -> ())
in in
restart_mismatch (); restart_mismatch ();

47
test/test_flan.ml
View File

@ -1086,6 +1086,53 @@ let () =
two [infers] above still hold — and this is the position that had no way two [infers] above still hold — and this is the position that had no way
to say it. *) to say it. *)
infers "array constructor" "(array 4 f32)" "[4 f32]"; infers "array constructor" "(array 4 f32)" "[4 f32]";
(* A literal bound by a let takes its type from its uses in the function,
and two uses no one type satisfies are refused with the annotation. *)
accepts "a literal local takes the type set into it"
"(defn f [x i64] i64 (let [t 0] (set t (+ t x)) t))";
accepts "a literal local takes an operand's type"
"(defn f [x f64] f64 (let [s 0.0] (set s (+ s x)) s))";
accepts "recur rebinds a literal local at the type it brings"
"(defn f [n i64] i64 (loop [i 0 acc 0] (if (< i n) (recur (+ i 1) (+ acc n)) acc)))";
accepts "a set links two literal locals"
"(defn f [] i64 (let [a 0 b 0] (set b 3000000000) (set a b) a))";
accepts "a float literal local takes the f32 typed code wants"
"(defn f [x f32] f32 (let [s 0.0] (set s (+ s x)) s))";
rejects_check "a literal past f32's range where f32 is wanted"
~needle:"1e+39 does not fit in f32, whose largest value is about 3.4e38"
"(defn f [] f32 1e39)";
rejects_check "a literal f32 rounds to 0 where f32 is wanted"
~needle:"1e-50 is too small for f32, which rounds it to 0"
"(defn f [] f32 1e-50)";
infers "a literal past f32's range is an f64 like any other" "(+ 1.0 1e300)" "f64";
(* Chains through a second round, and through do, let and if arms that
merge without one. *)
accepts "a literal local fed through do, however long the chain"
"(defn f [x i64] i64 (let [a0 0 a1 0 a2 0 a3 0 a4 0 a5 0 a6 0 a7 0 a8 0 a9 0 a10 0 \
a11 0 a12 0] (set a0 x) (set a1 (do a0)) (set a2 (do a1)) (set a3 (do a2)) \
(set a4 (do a3)) (set a5 (do a4)) (set a6 (do a5)) (set a7 (do a6)) \
(set a8 (do a7)) (set a9 (do a8)) (set a10 (do a9)) (set a11 (do a10)) \
(set a12 (do a11)) a12))";
accepts "a literal local fed through a let"
"(defn f [x i64] i64 (let [a0 0 a1 0 a2 0] (set a0 x) (set a1 (let [t a0] t)) \
(set a2 (let [t a1] t)) a2))";
accepts "a literal local fed through both arms of an if"
"(defn f [x i64] i64 (let [a0 0 a1 0] (set a0 x) (set a1 (if true a0 a0)) a1))";
accepts "a literal local fed through a generic call settles in rounds"
"(defn same [x $t] $t x) (defn f [x i64] i64 (let [a0 0 a1 0 a2 0] (set a0 x) \
(set a1 (same a0)) (set a2 (same a1)) a2))";
rejects_check "a chain the rounds cannot follow names the local to annotate"
~needle:"the type of a7 depends on too long a chain of the values stored into \
it to be read off them. Write the type it should have: (i64 0)"
"(defn same [x $t] $t x) (defn f [x i64] i64 (let [a0 0 a1 0 a2 0 a3 0 a4 0 a5 0 \
a6 0 a7 0 a8 0 a9 0 a10 0] (set a0 x) (set a1 (same a0)) (set a2 (same a1)) \
(set a3 (same a2)) (set a4 (same a3)) (set a5 (same a4)) (set a6 (same a5)) \
(set a7 (same a6)) (set a8 (same a7)) (set a9 (same a8)) (set a10 (same a9)) a10))";
rejects_check "two uses of a literal local disagree"
~needle:"x is used as u32 and as i32, and 0 can have only one type. \
Write the one it should have: (u32 0)"
"(defn u [x u32] u32 x) (defn i [x i32] i32 x) \
(defn f [] i32 (let [x 0] (u x) (i x)) 0)";
infers "array of a struct" "(array 2 i32)" "[2 i32]"; infers "array of a struct" "(array 2 i32)" "[2 i32]";
infers "array of an array" "(array 2 [3 u8])" "[2 [3 u8]]"; infers "array of an array" "(array 2 [3 u8])" "[2 [3 u8]]";
(* (array-fill [r c] v): the same type at any rank, with the element type (* (array-fill [r c] v): the same type at any rank, with the element type

53
test/test_syntax.ml
View File

@ -549,7 +549,25 @@ let () =
"(quasiquote (f (bit-not x) (unquote (bit-not y))))"; "(quasiquote (f (bit-not x) (unquote (bit-not y))))";
refuses "not-equal chain" "x = a != b != c" "indent/chained-not-equal" "!=(a, b, c)"; refuses "not-equal chain" "x = a != b != c" "indent/chained-not-equal" "!=(a, b, c)";
reads "not-equal call" "x = !=(a, b, c)" "(set x (!= a b c))"; reads "not-equal call" "x = !=(a, b, c)" "(set x (!= a b c))";
refuses "mixed comparison" "x = a < b <= c" "indent/mixed-comparison" "and"; (* One direction mixes; each operand that is a call is bound once, in
order, before any test. *)
reads "mixed chain" "x = 0 <= r < rows" "(set x (and (<= 0 r) (< r rows)))";
reads "mixed chain of four" "x = a < b <= c < d"
"(set x (and (< a b) (<= b c) (< c d)))";
reads "mixed chain downward" "x = x >= y > 0" "(set x (and (>= x y) (> y 0)))";
(* A name is bound too once any operand is, so it is read in its turn. *)
reads "mixed chain over a call" "x = a < f(b) <= c"
"(set x (let [~cmp1 a ~cmp2 (f b) ~cmp3 c] (and (< ~cmp1 ~cmp2) (<= ~cmp2 ~cmp3))))";
reads "mixed chain over two calls" "x = 0 < f() <= g() < h()"
"(set x (let [~cmp1 (f) ~cmp2 (g) ~cmp3 (h)] (and (< 0 ~cmp1) (<= ~cmp1 ~cmp2) (< ~cmp2 ~cmp3))))";
refuses "chain that turns around" "x = a < b > c" "indent/mixed-comparison"
"a < b and b > c";
refuses "== in a chain" "x = a == b < c" "indent/mixed-comparison" "a == b and b < c";
refuses "== after a chain" "x = x < 1 <= 2 == true" "indent/mixed-comparison"
"x < 1 and 1 <= 2 and 2 == true";
refuses "a refused chain's middle call is named once" "x = a < f(b) <= g(c) > d"
"indent/mixed-comparison"
"let mid = f(b)\n let mid2 = g(c)\n a < mid and mid <= mid2 and mid2 > d";
(* Statements. *) (* Statements. *)
reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b" reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b"
"(defn f [] i32 (let [a 1 b 2] (+ a b)))"; "(defn f [] i32 (let [a 1 b 2] (+ a b)))";
@ -946,6 +964,23 @@ let () =
fail "%s: read back %s from %S" name (describe_diff forms back) text fail "%s: read back %s from %S" name (describe_diff forms back) text
| exception e -> fail "%s: its text is refused: %s\n%s" name (diag_text e) text | exception e -> fail "%s: its text is refused: %s\n%s" name (diag_text e) text
in in
round "a mixed chain" "(defn f [r i32 n i32] bool (and (<= 0 r) (< r n)))" "= 0 <= r < n";
round "an and of one operator stays an and"
"(defn f [r i32 n i32] bool (and (< 0 r) (< r n)))" "= 0 < r and r < n";
round "an and whose middles differ stays an and"
"(defn f [r i32 n i32] bool (and (<= 0 r) (< n 9)))" "= 0 <= r and n < 9";
round "a let the reader would not make stays a let"
"(defn f [a i32] bool (let [m (g)] (and (<= a m) (< m (h)))))" " let m = g()";
back "a chain's middle call gets a name paren text can spell"
"fn f(a, b) -> bool = a < g() <= b"
"(let [mid a mid2 (g) mid3 b] (and (< mid mid2) (<= mid2 mid3)))";
(* And the paren text prints as the chain again, up to the names. *)
let src = "(defn f [a i32 b i32] bool (let [mid a mid2 (g) mid3 b] (and (< mid mid2) (<= mid2 mid3))))" in
prints "a mixed chain over a call comes back a chain" src " a < g() <= b";
(let forms = Reader.read_all ~file:"<p>" src in
let back = Indent_reader.read_all ~file:"<p>" (Indent_printer.program ~source:src forms) in
if not (same_forms (List.map norm forms) (List.map norm back)) then
fail "a mixed chain over a call: read back %s" (describe_diff forms back));
round "bit operators print infix" round "bit operators print infix"
"(defn f [a i32 m i32] bool (= (bit-and a (bit-not m)) (bit-or (bit-xor a 1) (<< m 2))))" "(defn f [a i32 m i32] bool (= (bit-and a (bit-not m)) (bit-or (bit-xor a 1) (<< m 2))))"
"a && ~~m == a ^^ 1 || m << 2"; "a && ~~m == a ^^ 1 || m << 2";
@ -1467,6 +1502,22 @@ let () =
[ "syntax/flat/shadows.flan"; "syntax/flat/macros.flan"; "syntax/flat/capture.flan" ]; [ "syntax/flat/shadows.flan"; "syntax/flat/macros.flan"; "syntax/flat/capture.flan" ];
run_both "syntax/mixed/main.flan" "12\n12\n0\n55\n"; run_both "syntax/mixed/main.flan" "12\n12\n0\n55\n";
run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n"; run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n";
(* A chain in a template: its names made where the macro expands in the
paren text, and the chain printed back as one. *)
let src = In_channel.with_open_bin "syntax/chain/macro.fln" In_channel.input_all in
let want = "false\ntrue\nfalse\n" in
run_both "syntax/chain/macro.fln" want;
let forms = Indent_reader.read_all ~file:"syntax/chain/macro.fln" src in
let paren = Paren_printer.program ~source:src forms in
if not (Test_support.contains paren "~(Form.Sym {.s \"~cmp1\"}) ~lo") then
fail "a template's chain in parens: %s" paren;
let flan = Filename.concat scratch (Printf.sprintf "chain-macro-%d.flan" (Unix.getpid ())) in
Out_channel.with_open_bin flan (fun oc -> output_string oc paren);
run_both flan want;
let back = Indent_printer.program ~source:paren (Reader.read_all ~file:flan paren) in
(try Sys.remove flan with Sys_error _ -> ());
if not (Test_support.contains back "~lo <= ~x < ~hi") then
fail "a template's chain back from parens: %s" back;
(* Return types read off the body, in both spellings of [_]. *) (* Return types read off the body, in both spellings of [_]. *)
List.iter List.iter
(fun p -> run_both p "3\n2.5\n1.5\n2.5\nyes 0\n4\n0 5\n2\n1\n") (fun p -> run_both p "3\n2.5\n1.5\n2.5\nyes 0\n4\n0 5\n2\n1\n")