From f5e1ab76ad3a16183a9da05d37bc33d198dfc5a6 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 24 Apr 2026 09:49:55 +0200 Subject: [PATCH 1/2] Fix warning 102 suppression for polymorphic comparisons --- compiler/core/lam_compile_primitive.ml | 4 --- compiler/ml/translcore.ml | 30 ++++++++++++++++--- .../expected/warning102.res.expected | 20 +++++++++++++ .../super_errors/fixtures/warning102.res | 11 +++++++ 4 files changed, 57 insertions(+), 8 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/warning102.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/warning102.res diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index e7c377e97a7..47aabff81a3 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -389,23 +389,19 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) || E.is_null_undefined_constant e2) -> E.neq_null_undefined_boolean e1 e2 | [e1; e2] -> - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; E.runtime_call Primitive_modules.object_ (Lam_compile_util.runtime_of_comp cmp) args | _ -> assert false) | Pobjorder -> ( - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; match args with | [a; b] -> E.runtime_call Primitive_modules.object_ "compare" args | _ -> assert false) | Pobjmin -> ( - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; match args with | [a; b] -> E.runtime_call Primitive_modules.object_ "min" args | _ -> assert false) | Pobjmax -> ( - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; match args with | [a; b] -> E.runtime_call Primitive_modules.object_ "max" args | _ -> assert false) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index dc7f8aa1a91..44006f4dad3 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -439,6 +439,19 @@ let specialize_primitive p env ty (* ~has_constant_constructor *) = | None -> table.objcomp with Not_found -> find_primitive p.prim_name) +let is_null_undefined_constant = function + | Lprim ((Pnull | Pundefined), [], _) -> true + | _ -> false + +let warn_polymorphic_comparison loc prim args = + match (prim, args) with + | Pobjcomp (Ceq | Cneq), [arg1; arg2] + when is_null_undefined_constant arg1 || is_null_undefined_constant arg2 -> + () + | (Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax), _ -> + Location.prerr_warning loc Warnings.Bs_polymorphic_comparison + | _ -> () + (* Eta-expand a primitive *) let transl_primitive loc p env ty = @@ -447,6 +460,7 @@ let transl_primitive loc p env ty = try specialize_primitive p env ty (* ~has_constant_constructor:false *) with Not_found -> Pccall p in + warn_polymorphic_comparison loc prim []; match prim with | Ploc kind -> ( let lam = lam_of_loc kind loc in @@ -653,8 +667,9 @@ let extract_directive_for_fn exp = else None) let rec transl_exp e = - List.iter (Translattribute.check_attribute e) e.exp_attributes; - transl_exp0 e + Builtin_attributes.warning_scope ~ppwarning:false e.exp_attributes (fun () -> + List.iter (Translattribute.check_attribute e) e.exp_attributes; + transl_exp0 e) and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match e.exp_desc with @@ -734,6 +749,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let prim = transl_primitive_application e.exp_loc p e.exp_env prim_type args in + warn_polymorphic_comparison e.exp_loc prim argl; match (prim, args) with | Praise k, [_] -> let targ = List.hd argl in @@ -1082,7 +1098,10 @@ and transl_let rec_flag pat_expr_list body = let rec transl = function | [] -> body | {vb_pat = pat; vb_expr = expr; vb_attributes = attr; vb_loc} :: rem -> - let lam = transl_exp expr in + let lam = + Builtin_attributes.warning_scope ~ppwarning:false attr (fun () -> + transl_exp expr) + in let lam = Translattribute.add_inline_attribute lam vb_loc attr in Matching.for_let pat.pat_loc lam pat (transl rem) in @@ -1098,7 +1117,10 @@ and transl_let rec_flag pat_expr_list body = Only variables are allowed as left-hand side of `let rec' *) in - let lam = transl_exp expr in + let lam = + Builtin_attributes.warning_scope ~ppwarning:false vb_attributes + (fun () -> transl_exp expr) + in let lam = Translattribute.add_inline_attribute lam vb_loc vb_attributes in (id, lam) in diff --git a/tests/build_tests/super_errors/expected/warning102.res.expected b/tests/build_tests/super_errors/expected/warning102.res.expected new file mode 100644 index 00000000000..5b306de467e --- /dev/null +++ b/tests/build_tests/super_errors/expected/warning102.res.expected @@ -0,0 +1,20 @@ + + Warning number 22 + /.../fixtures/warning102.res:1:32-38 + + 1 │ let ppwarningOnce = @ppwarning("hello") 1 + 2 │ + 3 │ @warning("-102") + + hello + + + Warning number 102 + /.../fixtures/warning102.res:11:13-22 + + 9 │ let comparesToNull = x => x == Nullable.null + 10 │ + 11 │ let warns = [3] == [3] + 12 │ + + Polymorphic comparison introduced (maybe unsafe) \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/warning102.res b/tests/build_tests/super_errors/fixtures/warning102.res new file mode 100644 index 00000000000..457c5a46d91 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/warning102.res @@ -0,0 +1,11 @@ +let ppwarningOnce = @ppwarning("hello") 1 + +@warning("-102") +let suppressedBinding = + [1] == [1] + +let suppressedExpression = @warning("-102") ([2] == [2]) + +let comparesToNull = x => x == Nullable.null + +let warns = [3] == [3] From e75a7bdd10b0dd5aa8c302d5ca1fec89ff989416 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 24 Apr 2026 11:38:50 +0200 Subject: [PATCH 2/2] CHANGELOG --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7b8cc95990f..0304bdd0661 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,6 +20,8 @@ #### :bug: Bug fix +- Fix directive `@warning("-102")` not working. https://github.com/rescript-lang/rescript/pull/8322 + #### :memo: Documentation #### :nail_care: Polish