From 5712d4bdc07e8d048aa797a0c2cb9b9bdb0dc614 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 11:04:32 +0700 Subject: [PATCH] A bool operand of a bit operator is refused with its and, or or not hint in a whole-file check, whichever operand it is. --- lib/check.ml | 55 +++++++++++++++++++--------------- test/test_flan.ml | 75 +++++++++++++++++++++++++++++++++++++---------- 2 files changed, 91 insertions(+), 39 deletions(-) diff --git a/lib/check.ml b/lib/check.ml index 4b3590f3..bf61092b 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -10262,23 +10262,32 @@ and bits_operand ctx loc name (v : Tast.expr) = | Types.Bool -> bool_bits v.Tast.loc name | other -> fail loc "%s takes integers, found %s" name (tyname loc other) -(* A pair with a bool in it is usually refused before [bits_operand] sees it, - as a mismatch between the bool and the other operand. When the pair is - refused, each operand is checked on its own terms, and a bool among them is - the refusal given. The compile is already failing, so the second check - costs nothing that matters. *) -and bool_first : 'a. ctx -> string -> Ast.expr list -> (unit -> 'a) -> 'a = - fun ctx name args k -> - try k () with - | Loc.Error _ as e -> - List.iter - (fun a -> - match check ctx a with - | v when v.Tast.ty = Types.Bool -> bool_bits v.Tast.loc name - | _ -> () - | exception Loc.Error _ -> ()) - (List.filteri (fun i _ -> i < 2) args); - raise e +(* A bool operand is refused before the operands are joined, and not left to + [bits_operand]: the join sees a bool beside an integer as a plain mismatch, + "expected i32, found bool", which says nothing of [and]. Only the operands + that are plainly bools are asked about, because asking is a second check + and these are free of side effects: a comparison or a [not], a name, a + field of one. Any other bool still arrives at [bits_operand]. *) +and bool_operands ctx name (args : Ast.expr list) = + let rec plain (a : Ast.expr) = + match a.Ast.e with + | Ast.Var _ -> true + | Ast.Field (t, _) -> plain t + | _ -> false + in + let is_bool (a : Ast.expr) = + match a.Ast.e with + | Ast.Call ({ Ast.e = Ast.Var h; _ }, _) + when List.mem h [ "="; "!="; "<"; "<="; ">"; ">="; "not" ] + && not (shadows_builtin ctx a.Ast.loc h) -> + true + | _ when plain a -> + (match speculate ctx.env (fun () -> check ctx a) with + | v -> v.Tast.ty = Types.Bool + | exception Loc.Error _ -> false) + | _ -> false + in + List.iter (fun a -> if is_bool a then bool_bits a.Ast.loc name) args and bool_bits loc name = let fln = fln_source loc in @@ -11061,9 +11070,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = | _ -> Tast.BitXor in fold_arity loc name args; - bool_first ctx name args (fun () -> - fold_left_prim ctx ~want loc name p ~needs:"integer?" Types.is_integer - "integers" args) + bool_operands ctx name args; + fold_left_prim ctx ~want loc name p ~needs:"integer?" Types.is_integer + "integers" args (* The .fln operators, which the indented reader already spells as the words above; a form built some other way may still carry them. [~qualified] skips the shadowing arm, because a program that means its own [&&] has @@ -11076,6 +11085,7 @@ and named_call ?(qualified = false) ctx ~want loc name args = named_call ~qualified:true ctx ~want loc canon args | "bit-not" | "popcount" | "leading-zeros" | "trailing-zeros" -> arity ctx loc name 1 args; + bool_operands ctx name args; let v = check ctx ?want:(numeric_want want) (List.hd args) in if v.Tast.ty = Types.Dyn then expect ctx loc ~want (rt loc Types.Dyn (dyn_bits_sym name) [ v; here loc ]) @@ -11109,10 +11119,9 @@ and named_call ?(qualified = false) ctx ~want loc name args = | _ -> Tast.Rotr in arity ctx loc name 2 args; + bool_operands ctx name args; let a, b = - bool_first ctx name args (fun () -> - binary ctx ~dyn_ok:true ~join:false name loc - ~want:(numeric_want want) args) + binary ctx ~dyn_ok:true ~join:false name loc ~want:(numeric_want want) args in if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then begin (* The typed side of a mixed pair still has to be an integer: the dyn diff --git a/test/test_flan.ml b/test/test_flan.ml index a4990919..cc745989 100644 --- a/test/test_flan.ml +++ b/test/test_flan.ml @@ -1384,23 +1384,66 @@ let () = infers "a bit operation with a dyn operand is dyn" "(bit-and (the dyn 6) (i32 3))" "dyn"; infers "a shift with a dyn operand is dyn" "(<< (the dyn 1) 3)" "dyn"; - rejects_check "bit-and over bools points at and" + (* Through the whole-file check [flan check] and the editor run, which + records a refusal and goes on rather than raising at the first: a hint + that only a raised refusal could give would be lost there. [.fln] text is + checked from a file, since the operator's spelling follows the syntax. *) + let refuses_all name ?(fln = false) src needle = + let diags = + match + if fln then begin + let path = Test_support.tmp "bits-" (string_of_int (Hashtbl.hash name) ^ ".fln") in + Out_channel.with_open_bin path (fun oc -> output_string oc src); + let r = snd (Front.checked ~all:true path) in + Sys.remove path; r + end + else Check.program_all (Parse.program_all (read src)) + with + | _ -> [] + | exception Loc.Errors ds -> List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds + | exception Loc.Error d -> [ d.Loc.dmsg ] + in + if not (List.exists (fun m -> contains m needle) diags) then begin + incr failures; + Printf.printf "FAIL %s\n wanted: %s\n got: %s\n" name needle + (String.concat " | " diags) + end + in + refuses_all "bit-and over bools points at and" "(defn f [a bool b bool] bool (= (bit-and a b) 0))" - ~needle:"bit-and works on the bits of an integer, and this is a bool. \ - For true and false, write (and a b)"; - rejects_check "bit-not over a bool points at not" - "(defn f [a bool] i32 (bit-not a) 0)" ~needle:"write (not a)"; - rejects_check "bit-xor over bools points at !=" - "(defn f [a bool b bool] i32 (bit-xor a b) 0)" ~needle:"write (!= a b)"; - rejects_check "a typed bool beside a dyn is refused before it runs" - "(defn f [a bool d dyn] dyn (bit-or a d))" ~needle:"write (or a b)"; - rejects_check "a shift of a bool" - "(defn f [a bool] i32 (<< a 1) 0)" - ~needle:"combined with and, or and not"; - rejects_check "a bool beside an integer" - "(defn f [x i32 flag bool] i32 (bit-and x flag))" ~needle:"write (and a b)"; - rejects_check "a bool beside a literal" - "(defn f [flag bool] i32 (bit-or flag 1))" ~needle:"write (or a b)"; + "bit-and works on the bits of an integer, and this is a bool. \ + For true and false, write (and a b)"; + refuses_all "bit-not over a bool points at not" + "(defn f [a bool] i32 (bit-not a) 0)" "write (not a)"; + refuses_all "bit-xor over bools points at !=" + "(defn f [a bool b bool] i32 (bit-xor a b) 0)" "write (!= a b)"; + refuses_all "a typed bool beside a dyn is refused before it runs" + "(defn f [a bool d dyn] dyn (bit-or a d))" "write (or a b)"; + refuses_all "a shift of a bool" + "(defn f [a bool] i32 (<< a 1) 0)" "combined with and, or and not"; + refuses_all "a bool shift count" "(defn f [flag bool] i32 (<< 1 flag))" + "combined with and, or and not"; + refuses_all "a bool beside an integer, an integer wanted" + "(defn f [flag bool x i32] i32 (bit-and flag x))" "write (and a b)"; + refuses_all "a bool beside a literal, an integer wanted" + "(defn f [flag bool] i32 (bit-or flag 1))" "write (or a b)"; + refuses_all "a literal beside a bool" "(defn f [flag bool] i32 (bit-or 1 flag))" + "write (or a b)"; + refuses_all "a bool third" "(defn f [x i32 flag bool] i32 (bit-and x x flag))" + "write (and a b)"; + refuses_all "a comparison as an operand" + "(defn f [x i32 y i32] i32 (bit-and x (= x y)))" "write (and a b)"; + refuses_all "a bool field" "(defstruct S [on bool]) (defn f [s S] i32 (bit-or 1 (.on s)))" + "write (or a b)"; + refuses_all ~fln:true "&& in .fln, the bool first" + "fn f(flag: bool, x: i32) -> i32\n flag && x\n" "For true and false, write a and b"; + refuses_all ~fln:true "&& in .fln, a literal first" + "fn f(flag: bool) -> i32\n 1 && flag\n" "write a and b"; + refuses_all ~fln:true "&& in .fln, the bool last of three" + "fn f(flag: bool, x: i32) -> i32\n x && x && flag\n" "write a and b"; + refuses_all ~fln:true "~~ in .fln" "fn f(a: bool) -> i32\n ~~a\n" "~~ works on the bits"; + refuses_all ~fln:true "^^ in .fln" "fn f(a: bool, b: bool) -> bool\n a ^^ b == 0\n" + "write a != b"; rejects_check "popcount of a float" "(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64"; rejects_check "a rotation's count does not widen the value"