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

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.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 11:04:32 +07:00
parent c4452fc500
commit 5712d4bdc0
2 changed files with 91 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
lib/check.ml
View File

@ -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 () ->
bool_operands ctx name args;
fold_left_prim ctx ~want loc name p ~needs:"integer?" Types.is_integer
"integers" args)
"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

73
test/test_flan.ml
View File

@ -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. \
"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)";
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"