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

An unconstrained float literal is an f32, and an integer literal meeting a float literal meets it at the float

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 09:49:51 +07:00
parent 697c016231
commit 5f1b9b9e7e
8 changed files with 140 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
TODO.org
View File

@ -33,9 +33,10 @@ disagree are refused with a request for an annotation. Vector, map and text lite
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
operator gives dyn. Dyn integers stay i64 and dyn floats f64.
Local inference is in (check.ml [lit_session]). The f32 default and dyn text and vector
literals wait on the author's answers to the phase-1 measurements; =FLAN_LIT=f32,dyn= in
check.ml is the measuring switch, to be deleted with them.
Done: local inference (check.ml [lit_session]), the f32 float default, 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
CLOSED: [2026-09-20]
An unannotated parameter or return is =dyn=: a NaN-boxed value over a mark-sweep

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"
(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 = f64$" text)
(string-match-p "^;; selection-sort at \\$t = f32$" text)
(string-match-p "^define .*flan\\.selection-sort-i32" text)
(string-match-p "^define .*flan\\.selection-sort-f64" text)))
(string-match-p "^define .*flan\\.selection-sort-f32" text)))
(test-flan--check "each copy names the file the generic was sent from"
(string-match-p (regexp-quote file) text)))))

126
lib/check.ml
View File

@ -769,6 +769,15 @@ let lit_recording = ref 0
so its use is recorded as a [Hint] and not an [Up]. *)
let lit_hint = ref false
(* 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
use wants. *)
let typed_literals = ref false
let with_typed_literals f =
let was = !typed_literals in
typed_literals := true;
Fun.protect ~finally:(fun () -> typed_literals := was) f
(* Per-function state. Slots are never reused, so [slots] is also the frame
size — the interpreter allocates one array of this length per call. *)
type ctx = {
@ -3631,13 +3640,15 @@ let restart_sig tys =
let dyn_i64 = Types.Int Types.I64
let dyn_f64 = Types.Float Types.F64
(* The switch the literal rules of TODO.org's "Dyn unless annotated" were
measured with: [f32] makes an unconstrained float literal f32, [dyn] makes
an unwanted text or vector literal dyn, [log] prints each literal local
inference moved off its default. Deleted once those rules are decided. *)
(* The switch the unfinished half of TODO.org's "Dyn unless annotated" is
measured with: [dyn] makes an unwanted text or bracket literal dyn (a
let-bound one stays typed when a use wants it, [lit_session]), and [log]
prints each literal local inference moved off its default. Deleted when
that half lands. *)
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 float_default () = if lit_has "f32" then Types.F32 else Types.F64
(* An unconstrained float literal is an f32, as an integer one is an i32. *)
let float_default () = Types.F32
(* ── Literal locals ([lit_session]) ────────────────────────────────── *)
@ -3651,13 +3662,18 @@ let lit_kind (e : Ast.expr) =
| Ast.Float _ -> Some `Float
| Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ { Ast.e = Ast.Int _; _ } ]) -> Some `Int
| Ast.Call ({ Ast.e = Ast.Var "-"; _ }, [ { Ast.e = Ast.Float _; _ } ]) -> Some `Float
| Ast.Str _ | Ast.Arr (_ :: _) when lit_has "dyn" -> Some `Box
| _ -> None
(* What the literal is with no use to say otherwise. *)
(* 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 is the literal's own and not one a use names. *)
let lit_default = function
| `Int -> Types.Int Types.I32
| `Char -> Types.Int Types.U8
| `Float -> Types.Float (float_default ())
| `Box -> Types.Dyn
(* The types a use can give it: any number for an integer or a character,
since an untyped integer constant is usable where a float is wanted, and
@ -3669,6 +3685,7 @@ let lit_admits kind (t : Types.t) =
match kind, t with
| (`Int | `Char), (Types.Int _ | Types.Float _ | Types.Var _) -> true
| `Float, (Types.Float _ | Types.Var _) -> true
| `Box, t -> not (Types.equal t Types.Dyn)
| _ -> false
let lit_rounds = 3
@ -3701,7 +3718,8 @@ let lit_solve (s : lit_session) =
(fun (k, name) ->
let members = List.filter (fun m -> List.exists (fun (k', _) -> k' == m) keys) (group k) in
let kind =
if List.exists (fun m -> lit_kind m = Some `Float) members then `Float
if lit_kind k = Some `Box then `Box
else if List.exists (fun m -> lit_kind m = Some `Float) members then `Float
else Option.value (lit_kind k) ~default:`Int
in
let cons =
@ -3712,6 +3730,7 @@ let lit_solve (s : lit_session) =
|> List.rev
in
let pick c = List.filter_map (fun (c', t, l) -> if c' = c then Some (t, l) else None) cons in
if kind = `Box then (k, name, Ok (if cons = [] then Types.Dyn else Types.Unit)) else
let ups = pick Up and downs = pick Down and hints = pick Hint in
let res =
match ups with
@ -4861,6 +4880,16 @@ let arm_join (a : Types.t) (b : Types.t) =
(match a, b with
| Types.Dyn, _ | _, Types.Dyn -> Some Types.Dyn
| _ -> None)
(* The type two untyped literals meet at: the wider of their own types, and
an integer beside a float at the float — [(if c 1 2.5)] is an f32, though
i32 does not widen into f32, because the 1 was never an i32 to lose. Only
for literals: a typed i32 beside a float literal still has to be converted. *)
let literal_meet (a : Types.t) (b : Types.t) =
match Types.join a b, a, b with
| Some j, _, _ -> Some j
| None, Types.Int _, Types.Float _ -> Some b
| None, Types.Float _, Types.Int _ -> Some a
| None, _, _ -> None
let infer_seen : (Types.t * Loc.t * bool) list ref = ref []
(* What a refused subexpression stands as while recovering. [Zero] of [Never]
is a value nothing else builds, so it is recognisable; see [check]. *)
@ -5870,8 +5899,14 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
(tyname loc other) x
| _ -> float_default ()
in
(* Past f32's largest value the literal would be infinity, silently. *)
if k = Types.F32 && Float.is_finite x && Float.abs x > 3.4028234663852886e38 then
Loc.failk literal_at_want loc
"%g does not fit in f32, whose largest value is about 3.4e38. Write \
%s"
x (if fln_source loc then Printf.sprintf "f64(%g)" x else Printf.sprintf "(f64 %g)" x);
mk loc (Types.Float k) (Tast.Float (x, k))
| Ast.Str s when want = None && lit_has "dyn" -> 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.Kw k ->
(* Two keywords in one spelling, told apart by the expectation. Where an
@ -6171,7 +6206,7 @@ and check_value ctx ?want (e : Ast.expr) : Tast.expr =
fixed-array literal they always were. *)
| Ast.Arr items when want = Some Types.Dyn ->
dyn_vec ctx loc (map_lr (fun x -> check ctx ~want:Types.Dyn x) items)
| Ast.Arr items when want = None && lit_has "dyn" ->
| Ast.Arr items when want = None && lit_has "dyn" && not !typed_literals ->
dyn_vec ctx loc (map_lr (fun x -> check ctx ~want:Types.Dyn x) items)
| Ast.Arr items -> check_arr ctx ~want loc items
(* (array 4 rl/Vector2). Parse already assembled the whole array type, so
@ -6536,7 +6571,8 @@ and var ctx ?(qualified = false) loc ~want name =
| _ -> false) ->
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;
mk loc t (Tast.Local b.slot)
if lit_kind key = Some `Box then expect ctx loc ~want (mk loc b.bty (Tast.Local b.slot))
else mk loc t (Tast.Local b.slot)
| Some b ->
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:
@ -7249,6 +7285,17 @@ and defer_counter_zero slot loc =
(* [defer_ok] says whether *this* let has the function's extent. If it does, so
does every form in its body, including a nested let — which is why the flag
is handed to the body rather than consumed here. *)
(* A text or bracket literal local used where only its typed reading works —
sliced, its address taken, cloned, destructured: a typed use, recorded. *)
and lit_typed_use ctx (e : Ast.expr) =
match e.Ast.e, ctx.lits with
| Ast.Var n, Some s when s.recording ->
(match lookup ctx n with
| Some { blit = Some key; _ } when lit_kind key = Some `Box ->
s.cons <- (key, (Up, Types.Unit, e.Ast.loc)) :: s.cons
| _ -> ())
| _ -> ()
(* The literal local [n] names, while its uses are being recorded. *)
and lit_recorded ctx n =
match ctx.lits, lookup ctx n with
@ -7299,6 +7346,12 @@ and lit_local ctx name (e : Ast.expr) =
Some (match List.assq_opt e s.decided with Some t -> t | None -> lit_default kind)
| _ -> None
(* A literal local's initialiser, at the type [lit_local] gave it: [Unit] is
a text or bracket literal's typed reading ([lit_default]). *)
and lit_init ctx t (e : Ast.expr) =
if Types.equal t Types.Unit then with_typed_literals (fun () -> check ctx e)
else check ctx ~want:t e
(* [run] is a [let] or a [loop] with some of [inits] literals, and the
outermost such form of this function: the session opens here. See
[lit_session]. *)
@ -7385,8 +7438,11 @@ and check_let ctx ?(tail = false) ?want ?(defer_ok = false) loc bs body =
(fun (b : Ast.binding) ->
let want = Option.map (resolve ctx.env) b.Ast.bty in
let lit = if b.Ast.bty = None then lit_local ctx b.Ast.bname b.Ast.bval else None in
let want = match lit with Some t -> Some t | None -> want in
let v = check ctx ?want b.Ast.bval in
let v =
match lit with
| Some t -> lit_init ctx t b.Ast.bval
| None -> check ctx ?want b.Ast.bval
in
(match v.Tast.ty with
(* A refused initialiser, already reported: the name is bound to
the poison so that what follows is still checked. *)
@ -7624,7 +7680,9 @@ and check_loop ctx ?want loc bs body =
map_lr
(fun (n, v0) ->
let lit = lit_local ctx n v0 in
let v = check ctx ?want:lit v0 in
let v =
match lit with Some t -> lit_init ctx t v0 | None -> check ctx v0
in
(match v.Tast.ty with
(* A refused initialiser, already reported: the name is bound to
the poison so that what follows is still checked. *)
@ -8129,7 +8187,7 @@ and literal_join ctx (a : Ast.expr) (b : Ast.expr) =
| _ -> probe ctx x.Ast.loc (fun () -> (check ctx x).Tast.ty)
in
match own a, own b with
| Some x, Some y -> Types.join x y
| Some x, Some y -> literal_meet x y
| _ -> None
(* Whether a name would reach a callee if it were called — a global function, a
@ -8239,7 +8297,7 @@ and generic_ctor ctx ~want loc name given =
(match List.assoc_opt v !subst with
| None -> subst := (v, t) :: !subst; lit_only := v :: !lit_only
| Some b ->
(match Types.join b t with
(match literal_meet b t with
| Some j -> subst := (v, j) :: List.remove_assoc v !subst
| None ->
fail a.Ast.loc "%s's .%s is %s here, and this is %s"
@ -8707,12 +8765,13 @@ and arr_elem_type ctx (items : Ast.expr list) : Types.t option =
List.filter (fun t -> t <> Types.Never) (List.map snd typed)
in
let lit_tys = List.filter_map natural lits in
let join_all = function
let join_with meet = function
| [] -> None
| t :: ts ->
List.fold_left
(fun acc t -> Option.bind acc (fun a -> Types.join a t)) (Some t) ts
(fun acc t -> Option.bind acc (fun a -> meet a t)) (Some t) ts
in
let join_all = join_with Types.join in
let mixed_dyn =
List.mem Types.Dyn tys
&& (List.exists (fun t -> t <> Types.Dyn) tys || lits <> [])
@ -8728,7 +8787,13 @@ and arr_elem_type ctx (items : Ast.expr list) : Types.t option =
List.fold_left
(fun acc i ->
if fits t i then acc
else Option.bind acc (fun a -> Option.bind (natural i) (Types.join a)))
else
Option.bind acc (fun 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
in
(match t' with
@ -8737,7 +8802,7 @@ and arr_elem_type ctx (items : Ast.expr list) : Types.t option =
in
let candidates =
if tys <> [] then [ join_all tys ]
else join_all lit_tys :: List.map Option.some lit_tys
else join_with literal_meet lit_tys :: List.map Option.some lit_tys
in
if mixed_dyn then None
else if tys = [] && lits = [] then
@ -9511,7 +9576,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
List.fold_left
(fun acc x ->
Option.bind acc (fun a ->
Option.bind (literal_join ctx first x) (Types.join a)))
Option.bind (literal_join ctx first x) (literal_meet a)))
(literal_join ctx first first) rest
in
(match j with
@ -11568,6 +11633,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
{ Ast.e = Ast.Int i; _ }; { Ast.e = Ast.Int n; _ };
{ Ast.e = Ast.Int exact; _ } ] ->
let plural k = if Int64.equal k 1L then "" else "s" in
lit_typed_use ctx target;
let target = check ctx target in
(match target.Tast.ty with
| Types.Array (m, elem) ->
@ -12049,6 +12115,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
| "clone" ->
(match args with
| target :: rest when List.length rest <= 1 ->
lit_typed_use ctx target;
(* Checked once, then dispatched on what it turned out to be: checking
it inside a guard as well would allocate the target's slots twice and
evaluate whatever it was written as twice. *)
@ -12795,6 +12862,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
"slice is (slice a), (slice a lo) or (slice a lo hi) — given %d \
arguments" (List.length args)
| target :: bounds ->
lit_typed_use ctx target;
let target = check_target ctx target in
let ty = target.Tast.ty in
match ty with
@ -12998,6 +13066,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
| "addr" ->
arity ctx loc name 1 args;
let a = List.hd args in
lit_typed_use ctx a;
(match place_of_expr a with
| None ->
fail a.Ast.loc
@ -13506,6 +13575,11 @@ and named_call ?(qualified = false) ctx ~want loc name args =
when Int64.compare n (-2147483648L) < 0
|| Int64.compare n 2147483647L > 0 -> Some target
| Ast.UInt _, (Types.Int _ | Types.Float _) -> Some target
(* A float literal likewise: (f64 0.1) is the f64 nearest 0.1 and not
the f32 one widened, and (u64 1.8e19) converts the f64 it says. *)
| _, Types.Float _ when lit_kind (List.hd args) = Some `Float -> Some target
| _, Types.Int _ when lit_kind (List.hd args) = Some `Float ->
Some (Types.Float Types.F64)
| _ -> None
in
let a = check ctx ?want (List.hd args) in
@ -15269,7 +15343,9 @@ let check_parents env =
that still does not check once no progress is left has a real error, so
the last round is run without swallowing it. *)
let settle_consts env consts =
let infer (_, v) = (check (invented_ctx env Types.Unit) v).Tast.ty in
let infer (_, v) =
with_typed_literals (fun () -> (check (invented_ctx env Types.Unit) v).Tast.ty)
in
let pending = ref consts in
let rec settle () =
let left =
@ -16309,12 +16385,12 @@ and read_return env (fn : Ast.fn) params =
| (t0, l0, _) :: _ ->
(* Where no join exists the first typed exit's type is the one checked
against, so the refusal is the one [if] gives its else arm. *)
let meet = function
let meet ?(join = arm_join) = function
| [] -> None
| ((t, l, _) :: _) as xs ->
let j =
List.fold_left
(fun acc (u, _, _) -> Option.bind acc (fun a -> arm_join a u))
(fun acc (u, _, _) -> Option.bind acc (fun a -> join a u))
(Some t) xs
in
let at =
@ -16330,7 +16406,9 @@ and read_return env (fn : Ast.fn) params =
let decided =
match meet (List.filter (fun (_, _, lit) -> not lit) arrive) with
| Some d -> d
| None -> Option.value (meet arrive) ~default:(t0, l0)
| None ->
(* Every exit a literal: they meet as two literals do. *)
Option.value (meet ~join:literal_meet arrive) ~default:(t0, l0)
in
ignore (attempt (fst decided));
decided
@ -16905,7 +16983,7 @@ let check_global env (d : Ast.decl) : Tast.global option =
~pattern:(match v.Ast.e with Ast.Int _ -> false | _ -> true)
v.Ast.loc kind k, kind); ty;
loc = d.Ast.dloc }
| _ -> check (ctx ()) ~want:ty v
| _ -> with_typed_literals (fun () -> check (ctx ()) ~want:ty v)
in
no_union_const env d.Ast.dloc n ginit;
(* After the union's own refusal, so a computed union member keeps the

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

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

6
test/test_acceptance.ml
View File

@ -3614,7 +3614,7 @@ let () =
and each read used to make the call again. *)
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\
(Pair i32 {.a 2 .b 1}) (Pair f64 {.a 1 .b 2.5})\n6\n\
(Pair i32 {.a 2 .b 1}) (Pair f32 {.a 1 .b 2.5})\n6\n\
0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n"
in
outputs "generic structs" "programs/generic-struct.flan" generic_struct_out;
@ -3791,9 +3791,9 @@ let () =
requirement the author wrote down. What is asserted is that it names
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"
"programs/generic-map-reject.flan" "f64 is not hashable?";
"programs/generic-map-reject.flan" "f32 is not hashable?";
refuses "and it names the type the call site asked for"
"programs/generic-map-reject.flan" "at $t = f64";
"programs/generic-map-reject.flan" "at $t = f32";
(* 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

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

27
test/test_flan.ml
View File

@ -1071,7 +1071,7 @@ let def_reading name src gname ~ty =
let () =
(* ── Literal defaulting and inference ──────────────────────────── *)
infers "int defaults to i32" "42" "i32";
infers "float defaults to f64" "0.5" "f64";
infers "float defaults to f32" "0.5" "f32";
infers "byte is u8" "\\space" "u8";
infers "string" "\"hi\"" "str";
infers "bool" "true" "bool";
@ -1096,6 +1096,13 @@ let () =
"(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))";
rejects_check "a float literal past f32's range is refused with the f64 spelling"
~needle:"1e+39 does not fit in f32, whose largest value is about 3.4e38. \
Write (f64 1e+39)"
"(defn f [] f32 1e39)";
infers "a float literal converted is built at the target" "(f64 0.1)" "f64";
infers "an f32 range literal beside others makes the array f64"
"[2.5 1e300]" "[2 f64]";
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)"
@ -1108,7 +1115,7 @@ let () =
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. *)
infers "array-fill, rank 1" "(array-fill [5] 7)" "[5 i32]";
infers "array-fill, rank 2" "(array-fill [2 3] 0.5)" "[2 [3 f64]]";
infers "array-fill, rank 2" "(array-fill [2 3] 0.5)" "[2 [3 f32]]";
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
runs no passes over it. *)
@ -1129,7 +1136,7 @@ let () =
(* An untyped integer constant is usable where a float is wanted, as in
Odin; the reverse is not. *)
infers "int literal into a float" "(+ 1 0.5)" "f64";
infers "int literal into a float" "(+ 1 0.5)" "f32";
rejects_check "float literal into an int"
"(defn f [] i32 (+ 1 0.5))" ~needle:"expected i32";
@ -3828,7 +3835,7 @@ let () =
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\
(defn f [] i32 0)"
~needle:"expected u8, found f64";
~needle:"expected u8, found f32";
rejects_check "an inline generator takes one argument per dimension too"
"(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 \
@ -6718,7 +6725,7 @@ let () =
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 300))";
(* A float at integer?, refused at the call that asked, naming the bound. *)
rejects_check "a float does not instantiate an integer?-bounded variable"
~needle:"f64 is not integer?"
~needle:"f32 is not integer?"
"(defn bump [x $t] $t {:where (integer? $t)} (+ x 1))\n\
(defn main [] () (println (bump 1.5)))";
(* And dyn is refused by the bound too — the clause's own refusal, the more
@ -7676,7 +7683,7 @@ let () =
(* ── 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 "numbers meet at the wider" "[(u8 1) 256]" "[2 i32]";
infers "an int and a float literal meet at f64" "[1 2.5]" "[2 f64]";
infers "an int and a float literal meet at the float" "[1 2.5]" "[2 f32]";
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 "a number and a string are a dyn vector" "[10 \"Hi\"]" "dyn";
@ -7726,10 +7733,10 @@ let () =
check "max-value at an unbounded type variable names the bound and only it"
(contains d.Loc.dmsg "write {:where (numeric? $t)}"
&& not (contains d.Loc.dmsg "Fn")));
infers "two literal if arms meet at the wider" "(if true 1 2.5)" "f64";
infers "two literal if arms meet at the float" "(if true 1 2.5)" "f32";
infers "two integer if arms stay i32" "(if true 1 2)" "i32";
infers "two literal match arms meet at the wider"
"(match (Some 1) (Some v) 1 None 2.5)" "f64";
infers "two literal match arms meet at the float"
"(match (Some 1) (Some v) 1 None 2.5)" "f32";
accepts "max-value at a type variable the bound admits"
"(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"
@ -7846,7 +7853,7 @@ let () =
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";
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] f64";
("(defn f [c bool] _ (when c (return 1)) 2.5)" ^ main) "f" "f [bool] f32";
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";
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))"
with
| c ->
if not (List.mem "same-f64" c.Session.fns) then
if not (List.mem "same-f32" c.Session.fns) then
fail "a copy a tolerated caller asked for was not generated again: %s"
(String.concat " " c.Session.fns);
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. *)
match Session.eval_expr xt "(println (pick (slice [1.5 0.5] 0 2)))" with
| e ->
if not (has e.Session.ir "pick-f64") then
if not (has e.Session.ir "pick-f32") then
fail "the expression after a refused one carried no copy"
| exception Loc.Error { Loc.dmsg = 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
fail "redefining a generic did not install %s; it installed %s"
want (String.concat " " c.Session.fns))
[ "hold-i32"; "hold-f64" ];
[ "hold-i32"; "hold-f32" ];
(* 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
no effect. *)
@ -1530,7 +1530,7 @@ let () =
if not (List.mem want c.Session.fns) then
fail "redefining a called generic did not install %s; it \
installed %s" want (String.concat " " c.Session.fns))
[ "put-at-i32"; "put-at-f64" ]
[ "put-at-i32"; "put-at-f32" ]
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "redefining a generic: %s" m);
@ -1561,9 +1561,9 @@ let () =
fail "a second redefinition of a generic installed nothing");
(* 3. A redefinition that needs a copy the process was never built with. The
fixture never calls [pick] at f64, so [pick-f64] exists in no program
fixture never calls [pick] at f32, so [pick-f32] exists in no program
anywhere; redefining the *caller* to ask for it has to build and install
it. Nothing in the form names [pick-f64] — it is found by being an
it. Nothing in the form names [pick-f32] — it is found by being an
instantiation the host lacks. *)
(match
Session.eval (gen ())
@ -1572,9 +1572,9 @@ let () =
(set counter (+ counter (i64 (pick (slice fs 0 3)))))))"
with
| c ->
if not (List.mem "pick-f64" c.Session.fns) then
if not (List.mem "pick-f32" c.Session.fns) then
fail "a redefinition needing a new instantiation did not install \
pick-f64; it installed %s" (String.concat " " c.Session.fns)
pick-f32; it installed %s" (String.concat " " c.Session.fns)
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a redefinition needing a new instantiation: %s" m);
@ -1620,7 +1620,7 @@ let () =
(let t = gen () in
match Session.eval_expr t "(println (pick (slice [1.5 0.5] 0 2)))" with
| e ->
if not (has e.Session.ir "pick-f64") then
if not (has e.Session.ir "pick-f32") then
fail "an expression that instantiated a generic did not carry the copy"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "an expression that instantiates a generic: %s" m);