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

An unconstrained float literal is an f64, literal locals settle by merging the locals that feed each other, and a restart refused for a number type writes the conversion

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 10:45:46 +07:00
parent 207f5d7bad
commit 23663c4773
11 changed files with 545 additions and 248 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
TODO.org
View File

@ -31,13 +31,17 @@ crossing, a dyn big int for u64, and any check in a release build.
** 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.
Done: local inference (check.ml [lit_session]), the f32 float default, an integer and a Decision 121: f64 and not f32, because f32 locals lost precision silently — 0.1 summed a
float literal meeting at the float. Waiting: text and vector literals dyn by default, on 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= 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. 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

4
emacs/test-flan.el
View File

@ -1891,9 +1891,9 @@ already rely on it — so nothing here is a stand-in for the real thing."
(test-flan--check "a generic's IR is shown copy by copy" (test-flan--check "a generic's IR is shown copy by copy"
(and (string-match-p "\\`; LLVM IR for selection-sort, one copy" text) (and (string-match-p "\\`; LLVM IR for selection-sort, one copy" text)
(string-match-p "^;; selection-sort at \\$t = i32$" text) (string-match-p "^;; selection-sort at \\$t = i32$" text)
(string-match-p "^;; selection-sort at \\$t = f32$" text) (string-match-p "^;; selection-sort at \\$t = f64$" text)
(string-match-p "^define .*flan\\.selection-sort-i32" text) (string-match-p "^define .*flan\\.selection-sort-i32" text)
(string-match-p "^define .*flan\\.selection-sort-f32" text))) (string-match-p "^define .*flan\\.selection-sort-f64" text)))
(test-flan--check "each copy names the file the generic was sent from" (test-flan--check "each copy names the file the generic was sent from"
(string-match-p (regexp-quote file) text))))) (string-match-p (regexp-quote file) text)))))

611
lib/check.ml
View File

@ -746,13 +746,14 @@ type lentry =
| Lbarrier of string | Lbarrier of string
(* Local inference for a number or character literal bound by a [let] or a (* Local inference for a number or character literal bound by a [let] or a
[loop]: [(let [t 0.0] ... (set t (+ t x)))] makes [t] x's type. The uses [loop]: [(let [t 0.0] ... (set t (+ t x)))] makes [t] x's type. The form
are read by checking the form once with the literal locals at their current is checked with every literal local at its current guess while each use
guess and every hook below recording instead of refusing, then undoing that records what it says about the local. When the uses agree with the
check; the guesses are solved, and the form is checked for real. A guess guesses that check is the answer; otherwise it is undone, the guesses are
that moved is checked again, at most [lit_rounds] times, so a local fed by solved and it is checked again. Locals that feed one another are merged
another settles. One session per function context, opened by its outermost into one group (union-find), so a chain of any length settles in one more
such [let], so a lambda or a generic's copy is inferred on its own and a round. One session per function context, opened by its outermost such
[let], so a lambda or a generic's copy is inferred on its own and a
literal's type never depends on another function. literal's type never depends on another function.
What a use says about the local: What a use says about the local:
@ -760,20 +761,35 @@ type lentry =
index. The local has to widen into [t]. index. The local has to widen into [t].
- [Down t]: a [t] is [set] into it, or passed to [recur] for it. [t] has to - [Down t]: a [t] is [set] into it, or passed to [recur] for it. [t] has to
widen into the local. widen into the local.
- [Hint t]: an operator's other operand, which meets it at either. - [Hint t]: an operator's other operand, which meets it at either; or a
A [set] of one such local into another links the two, and a group of dyn it meets, as the dyn width ([Types.Dyn] here, i64 or f64 in [solve]).
linked locals takes one type. *) A [set] of arithmetic over such locals and literals into another merges
them, as does an operator between two of them. *)
type lit_con = Up | Down | Hint type lit_con = Up | Down | Hint
(* Initialiser nodes by identity: two expansions of one macro are two nodes
and may print alike. *)
module Phys = Hashtbl.Make (struct
type t = Ast.expr
let equal = ( == )
let hash = Hashtbl.hash
end)
type lit_session = { type lit_session = {
(* The type each literal local is checked at, by its initialiser's node. *) (* The type each literal local is checked at. Kept across rounds. *)
mutable decided : (Ast.expr * Types.t) list; decided : Types.t Phys.t;
(* On during the recording check and off for the real one. *) (* On while a round checks; off for a final check after one that failed. *)
mutable recording : bool; mutable recording : bool;
mutable cons : (Ast.expr * (lit_con * Types.t * Loc.t)) list; (* This round's locals, numbered as they are bound, and their names. *)
mutable links : (Ast.expr * Ast.expr) list; ids : int Phys.t;
(* Each literal local the recording check bound, with its name. *) mutable keys : (Ast.expr * string) list;
mutable seen : (Ast.expr * string) list; mutable count : int;
(* Union-find over the numbers, and each one's uses. *)
parent : (int, int) Hashtbl.t;
cons : (int, lit_con * Types.t * Loc.t) Hashtbl.t;
(* A use its guess could not serve was read at the type it asked for, so
this round's check is not a program and is thrown away. *)
mutable dirty : bool;
} }
(* Nonzero while any recording check runs: the refusal memos ([arm_failed], (* Nonzero while any recording check runs: the refusal memos ([arm_failed],
@ -781,9 +797,15 @@ type lit_session = {
at a guessed type must not be replayed at the decided one. *) at a guessed type must not be replayed at the decided one. *)
let lit_recording = ref 0 let lit_recording = ref 0
(* Set around the one check of an operator's operand that is a literal local, (* The operands of the operators being checked that are literal locals, by
so its use is recorded as a [Hint] and not an [Up]. *) location: a want reaching one is the other operand's type, a [Hint] and not
let lit_hint = ref false an [Up], and a refusal there is the operator's to handle. *)
let lit_operand_locs : Loc.t list ref = ref []
(* Set while arithmetic over literal locals is checked at the type of the
local it is stored into ([lit_down]): the locals in it are merged with that
one, so the guess it is checked at says nothing about them. *)
let lit_quiet = ref false
(* Text and bracket literals keep their typed reading while this is set (the (* Text and bracket literals keep their typed reading while this is set (the
[dyn] switch only): a [defconst]'s value, and a let-bound one some typed [dyn] switch only): a [defconst]'s value, and a let-bound one some typed
@ -3663,8 +3685,9 @@ let dyn_f64 = Types.Float Types.F64
that half lands. *) that half lands. *)
let lit_mode = try Sys.getenv "FLAN_LIT" with Not_found -> "" let lit_mode = try Sys.getenv "FLAN_LIT" with Not_found -> ""
let lit_has m = List.mem m (String.split_on_char ',' lit_mode) let lit_has m = List.mem m (String.split_on_char ',' lit_mode)
(* An unconstrained float literal is an f32, as an integer one is an i32. *) (* An unconstrained float literal is an f64 (decision 121); it is an f32 only
let float_default () = Types.F32 where typed code wants one. *)
let float_default () = Types.F64
(* ── Literal locals ([lit_session]) ────────────────────────────────── *) (* ── Literal locals ([lit_session]) ────────────────────────────────── *)
@ -3685,7 +3708,7 @@ let lit_kind (e : Ast.expr) =
(* A text or bracket literal ([`Box]) is dyn, or with a typed use its typed (* A text or bracket literal ([`Box]) is dyn, or with a typed use its typed
reading; [Types.Unit] stands for "typed" in [decided], since the typed reading; [Types.Unit] stands for "typed" in [decided], since the typed
reading is the literal's own and not one a use names. *) reading is the literal's own and not one a use names. *)
let lit_default = function let lit_default (_ : Ast.expr) = function
| `Int -> Types.Int Types.I32 | `Int -> Types.Int Types.I32
| `Char -> Types.Int Types.U8 | `Char -> Types.Int Types.U8
| `Float -> Types.Float (float_default ()) | `Float -> Types.Float (float_default ())
@ -3704,78 +3727,121 @@ let lit_admits kind (t : Types.t) =
| `Box, t -> not (Types.equal t Types.Dyn) | `Box, t -> not (Types.equal t Types.Dyn)
| _ -> false | _ -> false
let lit_rounds = 3 (* The rounds a session may take before its last guesses are checked as
they stand. Merging makes two the usual count; the bound only stops a
pathological program from looping. *)
let lit_rounds = 8
(* Every literal local the recording check bound, with the type the uses let lit_id (s : lit_session) (key : Ast.expr) = Phys.find_opt s.ids key
decide for it, and the first pair of uses that no one type satisfies. *)
let lit_solve (s : lit_session) = let rec lit_root (s : lit_session) i =
let keys = match Hashtbl.find_opt s.parent i with
List.fold_left | Some p when p <> i ->
(fun acc (k, n) -> if List.exists (fun (k', _) -> k' == k) acc then acc else (k, n) :: acc) let r = lit_root s p in
[] s.seen Hashtbl.replace s.parent i r;
in r
(* The linked group of [k]: a [set] of one literal local into another. *) | _ -> i
let group k =
let rec go seen = function let lit_add (s : lit_session) key c =
| [] -> seen match lit_id s key with Some i -> Hashtbl.add s.cons i c | None -> ()
| k :: rest when List.memq k seen -> go seen rest
| k :: rest -> let lit_union (s : lit_session) a b =
let next = match lit_id s a, lit_id s b with
List.filter_map | Some i, Some j ->
(fun (a, b) -> if a == k then Some b else if b == k then Some a else None) let ri = lit_root s i and rj = lit_root s j in
s.links if ri <> rj then Hashtbl.replace s.parent (max ri rj) (min ri rj)
in | _ -> ()
go (k :: seen) (next @ rest)
(* What earlier sessions decided, while an outermost one is open. An outer
session that checks its form again checks every lambda inside it again,
and each of those opens a session of its own; starting that one from its
last answer makes it settle in one round, where starting from the default
made nested lambdas cost a factor per level. Keyed by the node and the
type variables' bindings, since a generic's body is one node checked at
several types. Only ever a first guess: a wrong one costs a round. *)
let lit_depth = ref 0
let lit_memo : ((string * Types.t) list * Types.t) list Phys.t = Phys.create 64
let lit_guess ~subst (s : lit_session) key kind =
match Phys.find_opt s.decided key with
| Some t -> t
| None ->
let same (sb, _) =
List.equal (fun (a, t) (b, u) -> String.equal a b && Types.equal t u) sb subst
in in
go [] [ k ] match Option.bind (Phys.find_opt lit_memo key) (List.find_opt same) with
in | Some (_, t) -> t
| None -> lit_default key kind
(* Each literal local this round bound, with the type its group's uses decide
or the first pair of uses no one type satisfies. Linear in locals and
uses. *)
let lit_solve (s : lit_session) =
let keys = Array.of_list (List.rev s.keys) in
let n = Array.length keys in
let root = Array.init n (lit_root s) in
let members = Array.make n [] in
for i = n - 1 downto 0 do members.(root.(i)) <- i :: members.(root.(i)) done;
let widens a b = Types.equal a b || Types.widens_to ~from:a ~into:b in let widens a b = Types.equal a b || Types.widens_to ~from:a ~into:b in
List.map let result = Array.make n (Ok Types.Unit) in
(fun (k, name) -> Array.iteri
let members = List.filter (fun m -> List.exists (fun (k', _) -> k' == m) keys) (group k) in (fun r ms ->
let kind = if ms <> [] then begin
if lit_kind k = Some `Box then `Box let kinds = List.map (fun m -> Option.value (lit_kind (fst keys.(m))) ~default:`Int) ms in
else if List.exists (fun m -> lit_kind m = Some `Float) members then `Float let kind =
else Option.value (lit_kind k) ~default:`Int if List.mem `Box kinds then `Box
in else if List.mem `Float kinds then `Float
let cons = else if List.mem `Int kinds then `Int
List.filter_map else `Char
(fun (k', c) -> if List.memq k' members then Some c else None) in
s.cons let dyn_width =
|> List.filter (fun (_, t, _) -> lit_admits kind t) match kind with `Float -> Types.Float Types.F64 | _ -> Types.Int Types.I64
|> List.rev in
in let cons =
let pick c = List.filter_map (fun (c', t, l) -> if c' = c then Some (t, l) else None) cons in List.concat_map (fun m -> List.rev (Hashtbl.find_all s.cons m)) ms
if kind = `Box then (k, name, Ok (if cons = [] then Types.Dyn else Types.Unit)) else |> List.filter_map (fun (c, t, l) ->
let ups = pick Up and downs = pick Down and hints = pick Hint in if kind <> `Box && Types.equal t Types.Dyn then Some (Hint, dyn_width, l)
let res = else if lit_admits kind t then Some (c, t, l)
match ups with else None)
| (u0, l0) :: _ -> in
(match List.find_opt (fun (u, _) -> List.for_all (fun (u', _) -> widens u u') ups) ups with let pick c = List.filter_map (fun (c', t, l) -> if c' = c then Some (t, l) else None) cons in
| None -> let res =
let (u1, l1) = if kind = `Box then Ok (if cons = [] then Types.Dyn else Types.Unit)
List.find (fun (u, _) -> not (widens u u0 || widens u0 u)) ups else
in let ups = pick Up and downs = pick Down and hints = pick Hint in
Error ((u0, l0), (u1, l1)) match ups with
| Some (c, lc) -> | (u0, l0) :: _ ->
(match List.find_opt (fun (d, _) -> not (widens d c)) downs with (match List.find_opt (fun (u, _) -> List.for_all (fun (u', _) -> widens u u') ups) ups with
| None -> Ok c | None ->
| Some (d, ld) -> Error ((c, lc), (d, ld)))) let (u1, l1) = List.find (fun (u, _) -> not (widens u u0 || widens u0 u)) ups in
| [] -> Error ((u0, l0), (u1, l1))
(match downs @ hints with | Some (c, lc) ->
| [] -> Ok (lit_default kind) (match List.find_opt (fun (d, _) -> not (widens d c)) downs with
| (t0, l0) :: rest -> | None -> Ok c
let rec fold (t, l) = function | Some (d, ld) -> Error ((c, lc), (d, ld))))
| [] -> Ok t | [] ->
| (t', l') :: rest -> (match downs @ hints with
(match Types.join t t' with | [] ->
| Some j -> fold ((j, if Types.equal j t then l else l')) rest (* No use names a type: the widest of the members' own. *)
| None -> Error ((t, l), (t', l'))) Ok (List.fold_left
in (fun acc m ->
fold (t0, l0) rest) let t = lit_default (fst keys.(m)) kind in
in match Types.join acc t with Some j -> j | None -> acc)
(k, name, res)) (lit_default (fst keys.(r)) kind) ms)
keys | (t0, l0) :: rest ->
let rec fold (t, l) = function
| [] -> Ok t
| (t', l') :: rest ->
(match Types.join t t' with
| Some j -> fold ((j, if Types.equal j t then l else l')) rest
| None -> Error ((t, l), (t', l')))
in
fold (t0, l0) rest)
in
List.iter (fun m -> result.(m) <- res) ms
end)
members;
Array.to_list (Array.mapi (fun i (k, name) -> (k, name, result.(i))) keys)
(* Converting to whatever width the other side of the boundary wants, with a (* Converting to whatever width the other side of the boundary wants, with a
[Cast] and not a silent reinterpretation. The name is for the direction it [Cast] and not a silent reinterpretation. The name is for the direction it
@ -5915,12 +5981,17 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
(tyname loc other) x (tyname loc other) x
| _ -> float_default () | _ -> float_default ()
in in
(* Past f32's largest value the literal would be infinity, silently. *) (* Where f32 is wanted, a literal past its range would be infinity or 0,
if k = Types.F32 && Float.is_finite x && Float.abs x > 3.4028234663852886e38 then silently. *)
Loc.failk literal_at_want loc (if k = Types.F32 && Float.is_finite x && x <> 0.0 then
"%g does not fit in f32, whose largest value is about 3.4e38. Write \ let f = Int32.float_of_bits (Int32.bits_of_float x) in
%s" if Float.is_integer f && f = 0.0 then
x (if fln_source loc then Printf.sprintf "f64(%g)" x else Printf.sprintf "(f64 %g)" x); Loc.failk literal_at_want loc
"%g is too small for f32, which rounds it to 0 — the smallest \
f32 above 0 is about 1.4e-45" x
else if not (Float.is_finite f) then
Loc.failk literal_at_want loc
"%g does not fit in f32, whose largest value is about 3.4e38" x);
mk loc (Types.Float k) (Tast.Float (x, k)) mk loc (Types.Float k) (Tast.Float (x, k))
| Ast.Str s when want = None && lit_has "dyn" && not !typed_literals -> box loc (mk loc Types.String (Tast.Str s)) | Ast.Str s when want = None && lit_has "dyn" && not !typed_literals -> box loc (mk loc Types.String (Tast.Str s))
| Ast.Str s -> expect ctx loc ~want (mk loc Types.String (Tast.Str s)) | Ast.Str s -> expect ctx loc ~want (mk loc Types.String (Tast.Str s))
@ -6331,6 +6402,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
if ctx.in_defer then if ctx.in_defer then
fail loc fail loc
"invoke-restart is not allowed inside a defer"; "invoke-restart is not allowed inside a defer";
let written = args in
let args = map_lr (fun a -> check ctx a) args in let args = map_lr (fun a -> check ctx a) args in
List.iter List.iter
(fun (a : Tast.expr) -> (fun (a : Tast.expr) ->
@ -6342,6 +6414,22 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
| _ -> ()) | _ -> ())
args; args;
let sg = restart_sig (List.map (fun (a : Tast.expr) -> a.Tast.ty) args) in let sg = restart_sig (List.map (fun (a : Tast.expr) -> a.Tast.ty) args) in
(* What the run-time refusal needs to write its fix, after the signature
and a 0x1f: the syntax (i indented, p parenthesised), then each
argument as written, or x. Only the message reads past the 0x1f; the
comparison is on [type_id sg]. *)
let said =
let spell (a : Ast.expr) =
match a.Ast.e with
| Ast.Float x ->
let t = Printf.sprintf "%g" x in
if String.exists (fun c -> c = '.' || c = 'e' || c = 'n' || c = 'i') t
then t else t ^ ".0"
| _ -> spell_arg "x" a
in
String.concat "\x1f"
(sg :: (if fln_source loc then "i" else "p") :: List.map spell written)
in
(* Evaluated into slots first, so that an argument which transfers on its (* Evaluated into slots first, so that an argument which transfers on its
own is guarded before this form aims the channel, and so that a call own is guarded before this form aims the channel, and so that a call
written in an argument is on the ordinary walk rather than hidden written in an argument is on the ordinary walk rather than hidden
@ -6356,7 +6444,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
in in
let invoke = let invoke =
mk loc Types.Never mk loc Types.Never
(Tast.InvokeRestart (type_id name, name, locals, sg, type_id sg, loc)) (Tast.InvokeRestart (type_id name, name, locals, said, type_id sg, loc))
in in
expect ctx loc ~want expect ctx loc ~want
(if binds = [] then invoke (if binds = [] then invoke
@ -6578,17 +6666,25 @@ and var ctx ?(qualified = false) loc ~want name =
defn to pass that" builtin_prefix name name builtin_prefix name defn to pass that" builtin_prefix name name builtin_prefix name
| _ -> | _ ->
match lookup ctx name with match lookup ctx name with
(* A literal local while its uses are being recorded: the use is noted (* A literal local while its uses are being recorded: the use is noted.
and read at the type it asks for, so the recording check goes on past One its guess cannot serve is read at the type it asks for, so the
a use its guess would have refused. That check is thrown away. *) check goes on to the uses after it, and the round is marked to be
thrown away. A dyn want says the dyn width ([lit_solve]). *)
| Some ({ blit = Some key; _ } as b) | Some ({ blit = Some key; _ } as b)
when (match ctx.lits, want with when (match ctx.lits, want with
| Some s, Some t -> s.recording && lit_admits (Option.value (lit_kind key) ~default:`Int) t | Some s, Some t ->
s.recording && not !lit_quiet
&& (Types.equal t Types.Dyn
|| lit_admits (Option.value (lit_kind key) ~default:`Int) t)
| _ -> false) -> | _ -> false) ->
let s = Option.get ctx.lits and t = Option.get want in let s = Option.get ctx.lits and t = Option.get want in
s.cons <- (key, ((if !lit_hint then Hint else Up), t, loc)) :: s.cons; let operand = List.memq loc !lit_operand_locs in
if lit_kind key = Some `Box then expect ctx loc ~want (mk loc b.bty (Tast.Local b.slot)) let c = if operand || Types.equal t Types.Dyn then Hint else Up in
else mk loc t (Tast.Local b.slot) lit_add s key (c, t, loc);
(try expect ctx loc ~want (mk loc b.bty (Tast.Local b.slot))
with Loc.Error _ when lit_kind key <> Some `Box && not operand ->
s.dirty <- true;
mk loc t (Tast.Local b.slot))
| Some b -> | Some b ->
expect ctx loc ~want (mk loc b.bty (Tast.Local b.slot)) expect ctx loc ~want (mk loc b.bty (Tast.Local b.slot))
(* A local of the enclosing function, in a body that was lifted out of it: (* A local of the enclosing function, in a body that was lifted out of it:
@ -7308,7 +7404,7 @@ and lit_typed_use ctx (e : Ast.expr) =
| Ast.Var n, Some s when s.recording -> | Ast.Var n, Some s when s.recording ->
(match lookup ctx n with (match lookup ctx n with
| Some { blit = Some key; _ } when lit_kind key = Some `Box -> | Some { blit = Some key; _ } when lit_kind key = Some `Box ->
s.cons <- (key, (Up, Types.Unit, e.Ast.loc)) :: s.cons lit_add s key (Up, Types.Unit, e.Ast.loc)
| _ -> ()) | _ -> ())
| _ -> () | _ -> ()
@ -7318,48 +7414,79 @@ and lit_recorded ctx n =
| Some s, Some { blit = Some key; _ } when s.recording -> Some key | Some s, Some { blit = Some key; _ } when s.recording -> Some key
| _ -> None | _ -> None
(* [v] read as arithmetic: the literal locals among its operands, and the
operands that are something else (a call, an index, a typed name). Number
literals are neither. The result's type is the join of all of them, so the
locals are merged with whatever [v] is stored into and the others are
what it brings. *)
and lit_parts ctx (v : Ast.expr) =
let rec go (v : Ast.expr) (vars, others) =
match v.Ast.e with
| Ast.Var n ->
(match lookup ctx n with
| Some { blit = Some k; _ } when lit_kind k <> Some `Box -> (k :: vars, others)
| _ -> (vars, v :: others))
| Ast.Int _ | Ast.Float _ | Ast.Byte _ -> (vars, others)
| Ast.Call ({ Ast.e = Ast.Var ("+" | "-" | "*" | "/" | "%" | "min" | "max"); _ }, args)
when args <> [] ->
List.fold_left (fun acc a -> go a acc) (vars, others) args
| _ -> (vars, v :: others)
in
go v ([], [])
(* A float literal, or an integer one past i32, anywhere in [v]'s arithmetic. *)
and lit_wide_literals (v : Ast.expr) =
let rec go (v : Ast.expr) =
match v.Ast.e with
| Ast.Float _ -> [ (Types.Float (float_default ()), v.Ast.loc) ]
| Ast.Int n when Int64.compare n (Int64.of_int32 Int32.max_int) > 0
|| Int64.compare n (Int64.of_int32 Int32.min_int) < 0 ->
[ (Types.Int Types.I64, v.Ast.loc) ]
| Ast.Call ({ Ast.e = Ast.Var ("+" | "-" | "*" | "/" | "%" | "min" | "max"); _ }, args) ->
List.concat_map go args
| _ -> []
in
go v
(* [v] stored into the literal local [key] (a [set] or a [recur]), while (* [v] stored into the literal local [key] (a [set] or a [recur]), while
recording: checked on its own terms, so its type is what it brings rather recording: the literal locals it is arithmetic over are merged with [key],
than the guess. Another literal local links the two; a float literal says and each other operand says, on its own terms, what it brings ([Down]) —
only that it is a float. *) never the guess the round happens to have. Then [v] is checked at [key]'s
guess, quietly, since a want there is the guess and says nothing. *)
and lit_down ctx key pty (v : Ast.expr) = and lit_down ctx key pty (v : Ast.expr) =
let s = Option.get ctx.lits in let s = Option.get ctx.lits in
let other = let quietly f =
match v.Ast.e with let was = !lit_quiet in
| Ast.Var m -> (match lookup ctx m with Some { blit = Some k; _ } -> Some k | _ -> None) lit_quiet := true;
| _ -> None Fun.protect ~finally:(fun () -> lit_quiet := was) f
in in
match other with let vars, others = lit_parts ctx v in
| Some k -> s.links <- (key, k) :: s.links; check ctx v List.iter (lit_union s key) vars;
| None -> List.iter (fun (t, l) -> lit_add s key (Hint, t, l)) (lit_wide_literals v);
match lit_kind v with List.iter
| Some `Float -> (fun (o : Ast.expr) ->
s.cons <- (key, (Hint, Types.Float (float_default ()), v.Ast.loc)) :: s.cons; match trial ctx (fun () -> check ctx o) with
check ctx v | Ok e -> lit_add s key (Down, e.Tast.ty, o.Ast.loc)
(* An integer literal fits wherever its value does; one past i32 says | Error _ -> ())
the local is at least an i64. *) others;
| Some _ -> match trial ctx (fun () -> quietly (fun () -> check ctx ~want:pty v)) with
(match v.Ast.e with | Ok e -> e
| Ast.Int n when Int64.compare n (Int64.of_int32 Int32.max_int) > 0 | Error _ ->
|| Int64.compare n (Int64.of_int32 Int32.min_int) < 0 -> s.dirty <- true;
s.cons <- (key, (Hint, Types.Int Types.I64, v.Ast.loc)) :: s.cons; quietly (fun () -> check ctx v)
check ctx ~want:(Types.Int Types.I64) v
| _ -> check ctx ~want:pty v)
| None ->
(match trial ctx (fun () -> check ctx v) with
| Ok e ->
s.cons <- (key, (Down, e.Tast.ty, v.Ast.loc)) :: s.cons;
e
| Error _ -> check ctx ~want:pty v)
(* The type a literal initialiser is checked at while a session is open — (* The type a literal initialiser is checked at while a session is open —
its current guess, or the decision — noting it as seen while recording. its current guess, or the decision — numbering it while recording.
[None] for anything that is not a literal, or with no session open. *) [None] for anything that is not a literal, or with no session open. *)
and lit_local ctx name (e : Ast.expr) = and lit_local ctx name (e : Ast.expr) =
match ctx.lits, lit_kind e with match ctx.lits, lit_kind e with
| Some s, Some kind -> | Some s, Some kind ->
if s.recording then s.seen <- (e, name) :: s.seen; if s.recording && not (Phys.mem s.ids e) then begin
Some (match List.assq_opt e s.decided with Some t -> t | None -> lit_default kind) Phys.replace s.ids e s.count;
s.count <- s.count + 1;
s.keys <- (e, name) :: s.keys
end;
Some (lit_guess ~subst:ctx.env.subst s e kind)
| _ -> None | _ -> None
(* A literal local's initialiser, at the type [lit_local] gave it: [Unit] is (* A literal local's initialiser, at the type [lit_local] gave it: [Unit] is
@ -7376,44 +7503,100 @@ and with_lits : 'a. ctx -> Loc.t -> Ast.expr list -> (unit -> 'a) -> 'a =
if ctx.lits <> None || not (List.exists (fun e -> lit_kind e <> None) inits) if ctx.lits <> None || not (List.exists (fun e -> lit_kind e <> None) inits)
then run () then run ()
else begin else begin
let s = { decided = []; recording = false; cons = []; links = []; seen = [] } in let s = { decided = Phys.create 16; recording = false; ids = Phys.create 16;
keys = []; count = 0; parent = Hashtbl.create 16;
cons = Hashtbl.create 16; dirty = false } in
ctx.lits <- Some s; ctx.lits <- Some s;
Fun.protect ~finally:(fun () -> ctx.lits <- None) @@ fun () -> incr lit_depth;
let undo = Loc.diag ~kind:"check/lit-undo" loc "undone" in let remember () =
let subst = ctx.env.subst in
List.iter
(fun (k, _) ->
let kind = Option.value (lit_kind k) ~default:`Int in
let t = lit_guess ~subst s k kind in
let others =
Option.value (Phys.find_opt lit_memo k) ~default:[]
|> List.filter (fun (sb, _) -> sb != subst)
in
Phys.replace lit_memo k ((subst, t) :: others))
s.keys
in
Fun.protect
~finally:(fun () ->
ctx.lits <- None;
decr lit_depth;
if !lit_depth = 0 then Phys.reset lit_memo)
@@ fun () ->
let unsettled = Loc.diag ~kind:"check/lit-unsettled" loc "unsettled" in
(* The decisions the uses recorded so far make, and whether any moved. *)
let settle () =
let solved = lit_solve s in
let moved = ref false in
List.iter
(fun (k, _, r) ->
match r with
| Ok t ->
let kind = Option.value (lit_kind k) ~default:`Int in
if not (Types.equal t (lit_guess ~subst:ctx.env.subst s k kind)) then begin
moved := true;
Phys.replace s.decided k t
end
| Error _ -> ())
solved;
(solved, !moved)
in
let conflict solved =
List.find_map
(fun (k, name, r) -> match r with Error e -> Some (k, name, e) | Ok _ -> None)
solved
in
let log () =
if lit_has "log" then
Phys.iter
(fun k t ->
let d = lit_default k (Option.value (lit_kind k) ~default:`Int) in
if not (Types.equal t d) then
Printf.eprintf "LITINF %s:%d:%d %s -> %s\n" k.Ast.loc.Loc.file
k.Ast.loc.Loc.line k.Ast.loc.Loc.col (tyname loc d) (tyname loc t))
s.decided
in
let rec round n = let rec round n =
s.cons <- []; s.links <- []; s.seen <- []; Phys.reset s.ids; s.keys <- []; s.count <- 0;
Hashtbl.reset s.parent; Hashtbl.reset s.cons; s.dirty <- false;
s.recording <- true; s.recording <- true;
incr lit_recording; incr lit_recording;
Fun.protect (* A ref, because [trial] is monomorphic inside this recursive group. *)
~finally:(fun () -> decr lit_recording; s.recording <- false) let answer = ref None in
(fun () -> ignore (trial ctx (fun () -> ignore (run ()); raise (Loc.Error undo)))); let outcome =
let solved = lit_solve s in Fun.protect
let guess k = ~finally:(fun () -> decr lit_recording; s.recording <- false)
match List.assq_opt k s.decided with (fun () ->
| Some t -> t trial ctx (fun () ->
| None -> lit_default (Option.value (lit_kind k) ~default:`Int) let r = run () in
let solved, moved = settle () in
(* The guesses held: this check is the answer. *)
if moved || s.dirty || conflict solved <> None then
raise (Loc.Error unsettled);
answer := Some r;
poison loc))
in in
let decided = match outcome, !answer with
List.map (fun (k, _, r) -> (k, match r with Ok t -> t | Error _ -> guess k)) solved | Ok _, Some r -> log (); remember (); r
in | _ ->
let moved = List.exists (fun (k, t) -> not (Types.equal t (guess k))) decided in let solved, moved = settle () in
s.decided <- decided; (match conflict solved with
if moved && n < lit_rounds then round (n + 1) | Some (k, name, ((t1, l1), (t2, l2))) -> lit_conflict k name t1 l1 t2 l2
else | None -> ());
match List.find_opt (fun (_, _, r) -> Result.is_error r) solved with if moved && n < lit_rounds then round (n + 1)
| Some (k, name, Error ((t1, l1), (t2, l2))) -> lit_conflict k name t1 l1 t2 l2 else begin
| _ -> () (* Nothing left to learn: checked for real, so a refusal is the
ordinary one and a whole-file check goes on past it. *)
log ();
remember ();
run ()
end
in in
round 1; round 1
if lit_has "log" then
List.iter
(fun (k, t) ->
let d = lit_default (Option.value (lit_kind k) ~default:`Int) in
if not (Types.equal t d) then
Printf.eprintf "LITINF %s:%d:%d %s -> %s\n" k.Ast.loc.Loc.file
k.Ast.loc.Loc.line k.Ast.loc.Loc.col (tyname loc d) (tyname loc t))
s.decided;
run ()
end end
(* Two uses of a literal local that no one type satisfies. *) (* Two uses of a literal local that no one type satisfies. *)
@ -8804,12 +8987,7 @@ and arr_elem_type ctx (items : Ast.expr list) : Types.t option =
(fun acc i -> (fun acc i ->
if fits t i then acc if fits t i then acc
else else
Option.bind acc (fun a -> Option.bind acc (fun a -> Option.bind (natural i) (Types.join a)))
match Option.bind (natural i) (Types.join a), i.Ast.e with
(* A float literal is any float: beside an i32 it takes the
f64 the i32 widens into, not its own f32. *)
| None, Ast.Float _ -> Types.join a (Types.Float Types.F64)
| j, _ -> j))
(Some t) lits (Some t) lits
in in
(match t' with (match t' with
@ -14678,7 +14856,53 @@ and trial_at ctx (y : Ast.expr) (w : Types.t) =
and binary ctx ?(dyn_ok = false) ?(join = true) name loc ~want args = and binary ctx ?(dyn_ok = false) ?(join = true) name loc ~want args =
match args with match args with
| [ x; y ] -> | [ x; y ] -> lit_operands ctx x y (fun () -> binary_pair ctx ~dyn_ok ~join loc ~want x y)
| _ -> fail loc "%s takes two arguments" name
(* An operator's two operands, while literal locals' uses are recorded: one
beside a literal local says the type it meets it at ([Hint]), and two of
them are merged. Checked exactly as ever, so a round whose guesses hold is
the program. *)
and lit_operands ctx (x : Ast.expr) (y : Ast.expr) f =
let key (e : Ast.expr) =
match e.Ast.e with Ast.Var n -> lit_recorded ctx n | _ -> None
in
match ctx.lits, key x, key y with
| Some s, kx, ky when kx <> None || ky <> None ->
let float_lit (e : Ast.expr) = lit_kind e = Some `Float in
(* Before the check, which refuses a float literal beside an integer
guess. *)
(match kx, ky with
| Some k, _ when float_lit y -> lit_add s k (Hint, Types.Float (float_default ()), y.Ast.loc)
| _, Some k when float_lit x -> lit_add s k (Hint, Types.Float (float_default ()), x.Ast.loc)
| _ -> ());
let saved = !lit_operand_locs in
lit_operand_locs := x.Ast.loc :: y.Ast.loc :: saved;
let a, b =
try Fun.protect ~finally:(fun () -> lit_operand_locs := saved) f
with Loc.Error _ as ex ->
(* Refused at the guess, as (+ acc x) is over an i32 guess and an
i64 x: what the other operand is on its own terms is the use. *)
let own (k, (other : Ast.expr)) =
match trial ctx (fun () -> check ctx other) with
| Ok e -> lit_add s k (Hint, e.Tast.ty, other.Ast.loc)
| Error _ -> ()
in
(match kx, ky with
| Some k, None -> own (k, y)
| None, Some k -> own (k, x)
| _ -> ());
raise ex
in
(match kx, ky with
| Some k1, Some k2 -> lit_union s k1 k2
| Some k, None -> lit_add s k (Hint, b.Tast.ty, y.Ast.loc)
| None, Some k -> lit_add s k (Hint, a.Tast.ty, x.Ast.loc)
| None, None -> ());
a, b
| _ -> f ()
and binary_pair ctx ~dyn_ok ~join loc ~want (x : Ast.expr) (y : Ast.expr) =
let y_decides = let y_decides =
(is_literal x && not (is_literal y)) (is_literal x && not (is_literal y))
|| (match x.Ast.e, y.Ast.e with || (match x.Ast.e, y.Ast.e with
@ -14693,35 +14917,7 @@ and binary ctx ?(dyn_ok = false) ?(join = true) name loc ~want args =
let needs_want (f : Ast.expr) = let needs_want (f : Ast.expr) =
is_literal f || (match f.Ast.e with Ast.Kw _ -> true | _ -> false) is_literal f || (match f.Ast.e with Ast.Kw _ -> true | _ -> false)
in in
(* While a literal local's uses are recorded, the operand beside it if y_decides then begin
decides and the local is recorded as meeting it ([lit_session]). *)
let lv (f : Ast.expr) =
match f.Ast.e with Ast.Var n -> lit_recorded ctx n <> None | _ -> false
in
let hinted f =
lit_hint := true;
Fun.protect ~finally:(fun () -> lit_hint := false) f
in
let float_lit (f : Ast.expr) = lit_kind f = Some `Float in
if lv x && float_lit y then begin
let a = hinted (fun () -> check ctx ~want:(Types.Float (float_default ())) x) in
a, check ctx ~want:a.Tast.ty y
end
else if lv y && float_lit x then begin
let b = hinted (fun () -> check ctx ~want:(Types.Float (float_default ())) y) in
check ctx ~want:b.Tast.ty x, b
end
else if lv x && not (lv y) && not (needs_want y) then begin
let b = check ctx ?want y in
let a = hinted (fun () -> check ctx ~want:b.Tast.ty x) in
a, b
end
else if lv y && not (lv x) && not (needs_want x) then begin
let a = check ctx ?want x in
let b = hinted (fun () -> check ctx ~want:a.Tast.ty y) in
a, b
end
else if y_decides then begin
let b = check ctx ?want y in let b = check ctx ?want y in
let a = check ctx ~want:b.Tast.ty x in let a = check ctx ~want:b.Tast.ty x in
a, b a, b
@ -14817,7 +15013,6 @@ and binary ctx ?(dyn_ok = false) ?(join = true) name loc ~want args =
| _ -> raise (Loc.Error d)) | _ -> raise (Loc.Error d))
| _ -> raise (Loc.Error d) | _ -> raise (Loc.Error d)
end end
| _ -> fail loc "%s takes two arguments" name
(* ── The builtins, said out loud ─────────────────────────────────────── (* ── The builtins, said out loud ───────────────────────────────────────
A name, a signature and one line, for every name [named_call] and [var] A name, a signature and one line, for every name [named_call] and [var]

75
runtime/flan_rt.c
View File

@ -1125,13 +1125,82 @@ _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;
}
if (ok && used > 0)
flan_say(loc, loclen, "restart %.*s takes %.*s, given %.*s. Write %s",
(int)namelen, (const char *)name, (int)wantlen, (const char *)want,
(int)plen[0], (const char *)part[0], 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);
} }

19
test/programs/literal-locals.flan
View File

@ -42,6 +42,21 @@
(set acc (+ acc (at xs i)))) (set acc (+ acc (at xs i))))
acc)) 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 (defn main [] i32
(let [xs (the [3 i64] [3000000000 4 5]) (let [xs (the [3 i64] [3000000000 4 5])
fs (the [2 f64] [0.5 0.25]) fs (the [2 f64] [0.5 0.25])
@ -53,6 +68,10 @@
(println (sum-to 3)) ; 3000000000 (println (sum-to 3)) ; 3000000000
(println (sum-of (slice xs 0 3))) ; 3000000009 (println (sum-of (slice xs 0 3))) ; 3000000009
(println (sum-of (slice fs 0 2)))) ; 0.75 (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. ;; Nothing says otherwise: an i32 and an f64.
(let [n 7 f 1.5] (let [n 7 f 1.5]
(println n f)) ; 7 1.5 (println n f)) ; 7 1.5

6
test/programs/restarts.flan
View File

@ -101,6 +101,11 @@
(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 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 +115,7 @@
(= 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))
:else (println "?")) :else (println "?"))
(return 0))) (return 0)))

2
test/programs/x86-p12-handler-value.flan
View File

@ -88,7 +88,7 @@
(handler-bind [(Oops [c] (invoke-restart 'use-zero))] (handler-bind [(Oops [c] (invoke-restart 'use-zero))]
(println (deferred))) ; 9 (println (deferred))) ; 9
(println trace) ; 101 — the defer ran (println trace) ; 101 — the defer ran
(handler-bind [(Oops [c] (invoke-restart 'use-value (f64 2.5)))] (handler-bind [(Oops [c] (invoke-restart 'use-value 2.5))]
(println (floating))) ; 5 (println (floating))) ; 5
(handler-bind [(Oops [c] (invoke-restart 'use-value "supplied"))] (handler-bind [(Oops [c] (invoke-restart 'use-value "supplied"))]
(println (spelled))) ; supplied (println (spelled))) ; supplied

10
test/test_acceptance.ml
View File

@ -391,7 +391,7 @@ let () =
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 = let literal_locals_out =
"3000000009\n0.375\n5000000000\n3000000000\n3000000000\n3000000009\n\ "3000000009\n0.375\n5000000000\n3000000000\n3000000000\n3000000009\n\
0.75\n7 1.5\n" 0.75\n3000000005\n0.1 5000000000\ntrue\n7 1.5\n"
in in
outputs "literal locals take their uses' type" "programs/literal-locals.flan" outputs "literal locals take their uses' type" "programs/literal-locals.flan"
literal_locals_out; literal_locals_out;
@ -1400,6 +1400,8 @@ 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)";
(try Sys.remove exe with Sys_error _ -> ()) (try Sys.remove exe with Sys_error _ -> ())
in in
restart_mismatch (); restart_mismatch ();
@ -3614,7 +3616,7 @@ let () =
and each read used to make the call again. *) and each read used to make the call again. *)
let generic_struct_out = let generic_struct_out =
"60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n\ "60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n\
(Pair i32 {.a 2 .b 1}) (Pair f32 {.a 1 .b 2.5})\n6\n\ (Pair i32 {.a 2 .b 1}) (Pair f64 {.a 1 .b 2.5})\n6\n\
0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n" 0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n"
in in
outputs "generic structs" "programs/generic-struct.flan" generic_struct_out; outputs "generic structs" "programs/generic-struct.flan" generic_struct_out;
@ -3791,9 +3793,9 @@ let () =
requirement the author wrote down. What is asserted is that it names requirement the author wrote down. What is asserted is that it names
the type passed and the predicate it failed, and not the body. *) the type passed and the predicate it failed, and not the body. *)
refuses "a generic over maps, instantiated at a key that cannot be hashed" refuses "a generic over maps, instantiated at a key that cannot be hashed"
"programs/generic-map-reject.flan" "f32 is not hashable?"; "programs/generic-map-reject.flan" "f64 is not hashable?";
refuses "and it names the type the call site asked for" refuses "and it names the type the call site asked for"
"programs/generic-map-reject.flan" "at $t = f32"; "programs/generic-map-reject.flan" "at $t = f64";
(* This one is refused either way, so the guard is about *which* refusal: (* This one is refused either way, so the guard is about *which* refusal:
with sand.flan out of date the file stops at the import and the needle with sand.flan out of date the file stops at the import and the needle

4
test/test_dev.ml
View File

@ -3841,7 +3841,7 @@ let () =
"(defn use-sort [] ()\n (let [a [3 1 2]] (selection-sort (slice a 0 3)))\n \ "(defn use-sort [] ()\n (let [a [3 1 2]] (selection-sort (slice a 0 3)))\n \
(let [b [3.0 1.0]] (selection-sort (slice b 0 2))))" (let [b [3.0 1.0]] (selection-sort (slice b 0 2))))"
in in
if status r <> "ok" then fail "%s: calling the generic at f32: %s" backend (said r) if status r <> "ok" then fail "%s: calling the generic at f64: %s" backend (said r)
else begin else begin
let r = ask () in let r = ask () in
if status r <> "ok" then if status r <> "ok" then
@ -3852,7 +3852,7 @@ let () =
let types f = let types f =
Option.value ~default:"" (Wire.string_field f "types") Option.value ~default:"" (Wire.string_field f "types")
in in
if types a <> "$t = f32" || types b <> "$t = i32" then if types a <> "$t = f64" || types b <> "$t = i32" then
fail "%s: the copies are not headed by their types: %s, %s" fail "%s: the copies are not headed by their types: %s, %s"
backend (types a) (types b); backend (types a) (types b);
List.iter List.iter

34
test/test_flan.ml
View File

@ -1071,7 +1071,7 @@ let def_reading name src gname ~ty =
let () = let () =
(* ── Literal defaulting and inference ──────────────────────────── *) (* ── Literal defaulting and inference ──────────────────────────── *)
infers "int defaults to i32" "42" "i32"; infers "int defaults to i32" "42" "i32";
infers "float defaults to f32" "0.5" "f32"; infers "float defaults to f64" "0.5" "f64";
infers "byte is u8" "\\space" "u8"; infers "byte is u8" "\\space" "u8";
infers "string" "\"hi\"" "str"; infers "string" "\"hi\"" "str";
infers "bool" "true" "bool"; infers "bool" "true" "bool";
@ -1096,13 +1096,15 @@ let () =
"(defn f [n i64] i64 (loop [i 0 acc 0] (if (< i n) (recur (+ i 1) (+ acc n)) acc)))"; "(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" accepts "a set links two literal locals"
"(defn f [] i64 (let [a 0 b 0] (set b 3000000000) (set a b) a))"; "(defn f [] i64 (let [a 0 b 0] (set b 3000000000) (set a b) a))";
rejects_check "a float literal past f32's range is refused with the f64 spelling" accepts "a float literal local takes the f32 typed code wants"
~needle:"1e+39 does not fit in f32, whose largest value is about 3.4e38. \ "(defn f [x f32] f32 (let [s 0.0] (set s (+ s x)) s))";
Write (f64 1e+39)" 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)"; "(defn f [] f32 1e39)";
infers "a float literal converted is built at the target" "(f64 0.1)" "f64"; rejects_check "a literal f32 rounds to 0 where f32 is wanted"
infers "an f32 range literal beside others makes the array f64" ~needle:"1e-50 is too small for f32, which rounds it to 0"
"[2.5 1e300]" "[2 f64]"; "(defn f [] f32 1e-50)";
infers "a literal past f32's range is an f64 like any other" "(+ 1.0 1e300)" "f64";
rejects_check "two uses of a literal local disagree" 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. \ ~needle:"x is used as u32 and as i32, and 0 can have only one type. \
Write the one it should have: (u32 0)" Write the one it should have: (u32 0)"
@ -1115,7 +1117,7 @@ let () =
not a zero, which is what lets it be a defonce's initialiser — see not a zero, which is what lets it be a defonce's initialiser — see
programs/array-fill.flan for what it puts in the elements. *) programs/array-fill.flan for what it puts in the elements. *)
infers "array-fill, rank 1" "(array-fill [5] 7)" "[5 i32]"; infers "array-fill, rank 1" "(array-fill [5] 7)" "[5 i32]";
infers "array-fill, rank 2" "(array-fill [2 3] 0.5)" "[2 [3 f32]]"; infers "array-fill, rank 2" "(array-fill [2 3] 0.5)" "[2 [3 f64]]";
infers "array-fill, rank 3" "(array-fill [2 3 4] true)" "[2 [3 [4 bool]]]"; infers "array-fill, rank 3" "(array-fill [2 3 4] true)" "[2 [3 [4 bool]]]";
(* A zero dimension is a legal array with no elements, and the fill loop (* A zero dimension is a legal array with no elements, and the fill loop
runs no passes over it. *) runs no passes over it. *)
@ -1136,7 +1138,7 @@ let () =
(* An untyped integer constant is usable where a float is wanted, as in (* An untyped integer constant is usable where a float is wanted, as in
Odin; the reverse is not. *) Odin; the reverse is not. *)
infers "int literal into a float" "(+ 1 0.5)" "f32"; infers "int literal into a float" "(+ 1 0.5)" "f64";
rejects_check "float literal into an int" rejects_check "float literal into an int"
"(defn f [] i32 (+ 1 0.5))" ~needle:"expected i32"; "(defn f [] i32 (+ 1 0.5))" ~needle:"expected i32";
@ -3809,7 +3811,7 @@ let () =
rejects_check "an inline generator's body has to answer the element type" rejects_check "an inline generator's body has to answer the element type"
"(defonce grid [2 [3 u8]] (array-gen [2 3] (fn [i j] 1.5)))\n\ "(defonce grid [2 [3 u8]] (array-gen [2 3] (fn [i j] 1.5)))\n\
(defn f [] i32 0)" (defn f [] i32 0)"
~needle:"expected u8, found f32"; ~needle:"expected u8, found f64";
rejects_check "an inline generator takes one argument per dimension too" rejects_check "an inline generator takes one argument per dimension too"
"(defn f [] i32 (let [a (array-gen [2] (fn [i j] i))] 0))" "(defn f [] i32 (let [a (array-gen [2] (fn [i j] i))] 0))"
~needle:"this array-gen has 1 dimension, so its generator is called with \ ~needle:"this array-gen has 1 dimension, so its generator is called with \
@ -6699,7 +6701,7 @@ let () =
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 300))"; "(defn bump [x $t] $t {:where (integer? $t)} (+ x 300))";
(* A float at integer?, refused at the call that asked, naming the bound. *) (* A float at integer?, refused at the call that asked, naming the bound. *)
rejects_check "a float does not instantiate an integer?-bounded variable" rejects_check "a float does not instantiate an integer?-bounded variable"
~needle:"f32 is not integer?" ~needle:"f64 is not integer?"
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 1))\n\ "(defn bump [x $t] $t {:where (integer? $t)} (+ x 1))\n\
(defn main [] () (println (bump 1.5)))"; (defn main [] () (println (bump 1.5)))";
(* And dyn is refused by the bound too — the clause's own refusal, the more (* And dyn is refused by the bound too — the clause's own refusal, the more
@ -7657,7 +7659,7 @@ let () =
(* ── An array literal with nothing outside it naming a type ────── *) (* ── An array literal with nothing outside it naming a type ────── *)
infers "a literal takes the other elements' type" "[(f32 1.0) 2.5]" "[2 f32]"; infers "a literal takes the other elements' type" "[(f32 1.0) 2.5]" "[2 f32]";
infers "numbers meet at the wider" "[(u8 1) 256]" "[2 i32]"; infers "numbers meet at the wider" "[(u8 1) 256]" "[2 i32]";
infers "an int and a float literal meet at the float" "[1 2.5]" "[2 f32]"; infers "an int and a float literal meet at f64" "[1 2.5]" "[2 f64]";
infers "a wide literal makes the array u64" "[1 18446744073709551615]" "[2 u64]"; infers "a wide literal makes the array u64" "[1 18446744073709551615]" "[2 u64]";
infers "None takes the other element's Option" "[None (Some 1)]" "[2 (Option i32)]"; infers "None takes the other element's Option" "[None (Some 1)]" "[2 (Option i32)]";
infers "a number and a string are a dyn vector" "[10 \"Hi\"]" "dyn"; infers "a number and a string are a dyn vector" "[10 \"Hi\"]" "dyn";
@ -7711,10 +7713,10 @@ let () =
check "max-value at an unbounded type variable names the bound and only it" check "max-value at an unbounded type variable names the bound and only it"
(contains d.Loc.dmsg "write {:where (numeric? $t)}" (contains d.Loc.dmsg "write {:where (numeric? $t)}"
&& not (contains d.Loc.dmsg "Fn"))); && not (contains d.Loc.dmsg "Fn")));
infers "two literal if arms meet at the float" "(if true 1 2.5)" "f32"; infers "two literal if arms meet at the wider" "(if true 1 2.5)" "f64";
infers "two integer if arms stay i32" "(if true 1 2)" "i32"; infers "two integer if arms stay i32" "(if true 1 2)" "i32";
infers "two literal match arms meet at the float" infers "two literal match arms meet at the wider"
"(match (Some 1) (Some v) 1 None 2.5)" "f32"; "(match (Some 1) (Some v) 1 None 2.5)" "f64";
accepts "max-value at a type variable the bound admits" accepts "max-value at a type variable the bound admits"
"(defn f [x $t] $t {:where (integer? $t)} (max-value t))"; "(defn f [x $t] $t {:where (integer? $t)} (max-value t))";
rejects_check "max-value at a type that is not a number names the bound" rejects_check "max-value at a type that is not a number names the bound"
@ -7831,7 +7833,7 @@ let () =
reads_as "an inferred return follows a call to another" reads_as "an inferred return follows a call to another"
("(defn g [x f64] _ (f x))\n(defn f [x f64] _ (* x 2.0))" ^ main) "g" "g [f64] f64"; ("(defn g [x f64] _ (f x))\n(defn f [x f64] _ (* x 2.0))" ^ main) "g" "g [f64] f64";
reads_as "a literal return takes the other exit's type" reads_as "a literal return takes the other exit's type"
("(defn f [c bool] _ (when c (return 1)) 2.5)" ^ main) "f" "f [bool] f32"; ("(defn f [c bool] _ (when c (return 1)) 2.5)" ^ main) "f" "f [bool] f64";
reads_as "a literal return takes a parameter's type" reads_as "a literal return takes a parameter's type"
("(defn f [x i64] _ (when (< x 0) (return 0)) x)" ^ main) "f" "f [i64] i64"; ("(defn f [x i64] _ (when (< x 0) (return 0)) x)" ^ main) "f" "f [i64] i64";
reads_as "a literal return takes an f32" reads_as "a literal return takes an f32"

18
test/test_session.ml
View File

@ -212,7 +212,7 @@ let () =
"(defn scale [x i64] f64 (f64 (* x 2))) (defn other [] f64 (same 2.5))" "(defn scale [x i64] f64 (f64 (* x 2))) (defn other [] f64 (same 2.5))"
with with
| c -> | c ->
if not (List.mem "same-f32" c.Session.fns) then if not (List.mem "same-f64" c.Session.fns) then
fail "a copy a tolerated caller asked for was not generated again: %s" fail "a copy a tolerated caller asked for was not generated again: %s"
(String.concat " " c.Session.fns); (String.concat " " c.Session.fns);
if List.map (fun (x : Session.stale) -> x.Session.caller) c.Session.stale if List.map (fun (x : Session.stale) -> x.Session.caller) c.Session.stale
@ -434,7 +434,7 @@ let () =
not: the recovery half of the same claim. *) not: the recovery half of the same claim. *)
match Session.eval_expr xt "(println (pick (slice [1.5 0.5] 0 2)))" with match Session.eval_expr xt "(println (pick (slice [1.5 0.5] 0 2)))" with
| e -> | e ->
if not (has e.Session.ir "pick-f32") then if not (has e.Session.ir "pick-f64") then
fail "the expression after a refused one carried no copy" fail "the expression after a refused one carried no copy"
| exception Loc.Error { Loc.dmsg = m; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
fail "the session was poisoned by a bad expression: %s" m); fail "the session was poisoned by a bad expression: %s" m);
@ -1509,7 +1509,7 @@ let () =
if not (List.mem want c.Session.fns) then if not (List.mem want c.Session.fns) then
fail "redefining a generic did not install %s; it installed %s" fail "redefining a generic did not install %s; it installed %s"
want (String.concat " " c.Session.fns)) want (String.concat " " c.Session.fns))
[ "hold-i32"; "hold-f32" ]; [ "hold-i32"; "hold-f64" ];
(* And only its own copies: [put-at] did not change, and its copies are (* And only its own copies: [put-at] did not change, and its copies are
reached through their cells, so reinstalling them would be work with reached through their cells, so reinstalling them would be work with
no effect. *) no effect. *)
@ -1530,7 +1530,7 @@ let () =
if not (List.mem want c.Session.fns) then if not (List.mem want c.Session.fns) then
fail "redefining a called generic did not install %s; it \ fail "redefining a called generic did not install %s; it \
installed %s" want (String.concat " " c.Session.fns)) installed %s" want (String.concat " " c.Session.fns))
[ "put-at-i32"; "put-at-f32" ] [ "put-at-i32"; "put-at-f64" ]
| exception Loc.Error { Loc.dmsg = m; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
fail "redefining a generic: %s" m); fail "redefining a generic: %s" m);
@ -1561,9 +1561,9 @@ let () =
fail "a second redefinition of a generic installed nothing"); fail "a second redefinition of a generic installed nothing");
(* 3. A redefinition that needs a copy the process was never built with. The (* 3. A redefinition that needs a copy the process was never built with. The
fixture never calls [pick] at f32, so [pick-f32] exists in no program fixture never calls [pick] at f64, so [pick-f64] exists in no program
anywhere; redefining the *caller* to ask for it has to build and install anywhere; redefining the *caller* to ask for it has to build and install
it. Nothing in the form names [pick-f32] — it is found by being an it. Nothing in the form names [pick-f64] — it is found by being an
instantiation the host lacks. *) instantiation the host lacks. *)
(match (match
Session.eval (gen ()) Session.eval (gen ())
@ -1572,9 +1572,9 @@ let () =
(set counter (+ counter (i64 (pick (slice fs 0 3)))))))" (set counter (+ counter (i64 (pick (slice fs 0 3)))))))"
with with
| c -> | c ->
if not (List.mem "pick-f32" c.Session.fns) then if not (List.mem "pick-f64" c.Session.fns) then
fail "a redefinition needing a new instantiation did not install \ fail "a redefinition needing a new instantiation did not install \
pick-f32; it installed %s" (String.concat " " c.Session.fns) pick-f64; it installed %s" (String.concat " " c.Session.fns)
| exception Loc.Error { Loc.dmsg = m; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a redefinition needing a new instantiation: %s" m); fail "a redefinition needing a new instantiation: %s" m);
@ -1620,7 +1620,7 @@ let () =
(let t = gen () in (let t = gen () in
match Session.eval_expr t "(println (pick (slice [1.5 0.5] 0 2)))" with match Session.eval_expr t "(println (pick (slice [1.5 0.5] 0 2)))" with
| e -> | e ->
if not (has e.Session.ir "pick-f32") then if not (has e.Session.ir "pick-f64") then
fail "an expression that instantiated a generic did not carry the copy" fail "an expression that instantiated a generic did not carry the copy"
| exception Loc.Error { Loc.dmsg = m; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
fail "an expression that instantiates a generic: %s" m); fail "an expression that instantiates a generic: %s" m);