From 76b2ab31139fe07846d2f43bb2750c2a4b7471d3 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 21:01:15 +0700 Subject: [PATCH] A duplicate literal arm is one whose value equals an earlier arm's at the scrutinee's type, and a literal no dyn holds is refused with a pattern fix --- lib/check.ml | 127 ++++++++++++++++++++++++++++++---------------- test/test_flan.ml | 21 +++++++- 2 files changed, 103 insertions(+), 45 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index bd8ab9e8..6b340ded 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -8110,8 +8110,15 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = match e.Ast.e with | Ast.Int n -> Int64.to_string n | Ast.UInt (_, t) -> t - | Ast.Float x when Float.is_integer x -> Printf.sprintf "%.1f" x - | Ast.Float x -> Printf.sprintf "%g" x + | Ast.Float x when Float.is_integer x && Float.abs x < 1e15 -> + Printf.sprintf "%.1f" x + | Ast.Float x -> + (* The shortest spelling that reads back as the same float. *) + let rec go p = + let t = Printf.sprintf "%.*g" p x in + if p >= 17 || float_of_string t = x then t else go (p + 1) + in + go 1 | Ast.Byte b when b > 32 && b < 127 -> Printf.sprintf "\\%c" (Char.chr b) | Ast.Byte b -> string_of_int b | Ast.Str t -> Printf.sprintf "%S" t @@ -8132,6 +8139,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = in (* The checked literal of each literal arm, by the key [resolve_pat] gave it. *) let lits : (string, Tast.expr) Hashtbl.t = Hashtbl.create 8 in + let lit_values = ref [] in (* Which case each arm names, and the type of each name it binds. This is the whole of what differs between the two subjects; everything below it is shared. *) @@ -8165,54 +8173,87 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms = (String.concat " " (List.map (fun (m, _) -> ":" ^ m) members)) | `Lit t, Ast.Plit e -> let v = - match t with (* [=]'s dyn pair checks its literal at dyn, which boxes it. *) - | Types.Dyn -> check ctx ~want:Types.Dyn e - | t -> - (match trial ctx (fun () -> check ctx ~want:t e) with - | Ok v -> v - | Error _ -> - (* A literal that does not fit is refused, where [=] would widen - the pair and let the arm quietly never match. The literal's - own refusal is not repeated: its fixes are casts, and a cast - is not a pattern. *) - let tn = Types.to_string t in - let an = - match tn.[0] with - | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn - | _ -> "a " ^ tn - in - let why = - match e.Ast.e, t with - | Ast.Str _, _ -> "is a string" - | _, Types.String -> "is a number" - | Ast.Float x, Types.Int _ when not (Float.is_integer x) -> - "is not a whole number" - | Ast.Float _, Types.Int _ -> "is a float" - | _ -> "does not fit in one" - in + match trial ctx (fun () -> check ctx ~want:t e) with + | Ok v -> v + | Error _ -> + (* A literal that does not fit is refused, where [=] would widen + the pair and let the arm quietly never match. The literal's + own refusal is not repeated: its fixes are casts, and a cast + is not a pattern. *) + (match t with + | Types.Dyn -> fail a.Ast.aloc - "this match is over %s, so each arm has to be %s, and %s %s. \ - Change the arm to a value %s holds, or remove it" - tn an (spell e) why an) + "this match is over a dyn, which holds a number as an i64 or \ + an f64, and %s fits in neither. Change the arm to a value an \ + i64 holds, or remove it" (spell e) + | _ -> ()); + let tn = Types.to_string t in + let an = + match tn.[0] with + | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn + | _ -> "a " ^ tn + in + let why = + match e.Ast.e, t with + | Ast.Str _, _ -> "is a string" + | _, Types.String -> "is a number" + | Ast.Float x, Types.Int _ when not (Float.is_integer x) -> + "is not a whole number" + | Ast.Float _, Types.Int _ -> "is a float" + | _ -> "does not fit in one" + in + fail a.Ast.aloc + "this match is over %s, so each arm has to be %s, and %s %s. \ + Change the arm to a value %s holds, or remove it" + tn an (spell e) why an in - (* One key per value [=] cannot tell apart, so a second arm that could - never be reached is refused: 97 and \\a are one u8, and over a dyn - 1 and 1.0 are equal, as they are over a float. *) - let key = + (* The arm's value at the scrutinee's type, and a second arm [=] could + not tell from an earlier one is refused, since it can never be + reached: 97 and \a are one u8, 0.1 and 0.10000000001 are one f32, + and over a dyn 1 and 1.0 are equal. Compared pairwise rather than + hashed, because dyn = between an integer and a float goes through + the float and is not transitive past 2^53. *) + let value = + let f32 x = Int32.float_of_bits (Int32.bits_of_float x) in let num x = - if Float.is_integer x && Float.abs x < 0x1p62 then - Printf.sprintf "i%Ld" (Int64.of_float x) - else Printf.sprintf "f%h" x + match t with Types.Float Types.F32 -> `F (f32 x) | _ -> `F x in - match e.Ast.e with - | Ast.Int n -> Printf.sprintf "i%Ld" n - | Ast.Byte b -> Printf.sprintf "i%d" b - | Ast.UInt (n, _) -> Printf.sprintf "u%Lu" n - | Ast.Float x -> num x - | Ast.Str t -> "s" ^ t + match e.Ast.e, t with + | Ast.Str s, _ -> `S s + | (Ast.Int n | Ast.UInt (n, _)), Types.Float _ -> num (Int64.to_float n) + | Ast.Byte b, Types.Float _ -> num (float_of_int b) + | (Ast.Int n | Ast.UInt (n, _)), _ -> `I n + | Ast.Byte b, _ -> `I (Int64.of_int b) + | Ast.Float x, _ -> num x | _ -> assert false in + let same x y = + match x, y with + | `I a, `I b -> Int64.equal a b + | `F a, `F b -> a = b + | `I a, `F b | `F b, `I a -> Int64.to_float a = b + | `S a, `S b -> String.equal a b + | _ -> false + in + (match List.find_opt (fun (w, _) -> same value w) !lit_values with + | Some (_, earlier) when earlier = spell e -> + fail a.Ast.aloc "this match has two %s arms" earlier + | Some (_, earlier) -> + fail a.Ast.aloc + "this match has two %s arms — %s equals it as %s, so this arm is \ + never reached. Remove it" + earlier (spell e) + (match t with + | Types.Dyn -> "a dyn" + | t -> + let tn = Types.to_string t in + (match tn.[0] with + | 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn + | _ -> "a " ^ tn)) + | None -> ()); + lit_values := (value, spell e) :: !lit_values; + let key = string_of_int (Hashtbl.length lits) in Hashtbl.replace lits key v; Some key, [] | `Lit t, Ast.Pkw k -> diff --git a/test/test_flan.ml b/test/test_flan.ml index 69dadbed..5a85d2b4 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -4624,10 +4624,27 @@ let () = ~needle:"this match has two 5 arms"; rejects_check "a char and a number that are one u8" "(defn f [c u8] i32 (match c \\a 1 97 2 _ 0))" - ~needle:"this match has two 97 arms"; + ~needle:"this match has two \\a arms — 97 equals it as a u8"; rejects_check "1 and 1.0 are one arm over a dyn, as dyn = says" "(defn f [d dyn] i32 (match d 1 1 1.0 2 _ 0))" - ~needle:"this match has two 1.0 arms"; + ~needle:"this match has two 1 arms — 1.0 equals it as a dyn"; + rejects_check "two literals that round to one f32" + "(defn f [x f32] i32 (match x 0.1 1 0.10000000001 2 _ 0))" + ~needle:"this match has two 0.1 arms — 0.10000000001 equals it as an f32"; + rejects_check "two integers that round to one f32" + "(defn f [x f32] i32 (match x 16777216 1 16777217 2 _ 0))" + ~needle:"two 16777216 arms — 16777217 equals it as an f32"; + rejects_check "an integer and a float that are one f64" + "(defn f [x f64] i32 \ + (match x 4611686018427387904 1 4611686018427387904.0 2 _ 0))" + ~needle:"equals it as an f64"; + accepts "two f64 literals that differ" + "(defn f [x f64] i32 (match x 0.1 1 0.10000000001 2 _ 0))"; + rejects_check "a literal no dyn holds" + "(defn f [x dyn] i32 (match x 18446744073709551615 1 _ 0))" + ~needle:"this match is over a dyn, which holds a number as an i64 or an \ + f64, and 18446744073709551615 fits in neither. Change the arm to \ + a value an i64 holds, or remove it"; rejects_check "a keyword arm among literal arms" "(defn f [n i32] i32 (match n 5 1 :lo 2 _ 0))" ~needle:":lo is an enum member, and this match is over i32, whose arms are \