Fix directive @warning("-102") not working

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)

compiler/frontend/bs_ast_invariant.ml

@@ -50,6 +50,21 @@ type iterator = Ast_iterator.iterator
 
 let super = Ast_iterator.default_iterator
 
+let warning_attribute_iterator =
+  let structure_item self (structure_item : Parsetree.structure_item) =
+    (match structure_item.pstr_desc with
+    | Pstr_attribute attr -> Builtin_attributes.warning_attribute attr
+    | _ -> ());
+    super.structure_item self structure_item
+  in
+  let signature_item self (signature_item : Parsetree.signature_item) =
+    (match signature_item.psig_desc with
+    | Psig_attribute attr -> Builtin_attributes.warning_attribute attr
+    | _ -> ());
+    super.signature_item self signature_item
+  in
+  {super with structure_item; signature_item}
+
 let check_constant loc (const : Parsetree.constant) =
   match const with
   | Pconst_string (_, Some s) ->
@@ -148,28 +163,14 @@ let emit_external_warnings : iterator =
         | _ -> super.pat self pat);
   }
 
-let rec iter_warnings_on_stru (stru : Parsetree.structure) =
-  match stru with
-  | [] -> ()
-  | head :: rest -> (
-    match head.pstr_desc with
-    | Pstr_attribute attr ->
-      Builtin_attributes.warning_attribute attr;
-      iter_warnings_on_stru rest
-    | _ -> ())
+let iter_warnings_on_structure (structure : Parsetree.structure) =
+  warning_attribute_iterator.structure warning_attribute_iterator structure
 
-let rec iter_warnings_on_sigi (stru : Parsetree.signature) =
-  match stru with
-  | [] -> ()
-  | head :: rest -> (
-    match head.psig_desc with
-    | Psig_attribute attr ->
-      Builtin_attributes.warning_attribute attr;
-      iter_warnings_on_sigi rest
-    | _ -> ())
+let iter_warnings_on_signature (signature : Parsetree.signature) =
+  warning_attribute_iterator.signature warning_attribute_iterator signature
 
-let emit_external_warnings_on_structure (stru : Parsetree.structure) =
-  emit_external_warnings.structure emit_external_warnings stru
+let emit_external_warnings_on_structure (structure : Parsetree.structure) =
+  emit_external_warnings.structure emit_external_warnings structure
 
-let emit_external_warnings_on_signature (sigi : Parsetree.signature) =
-  emit_external_warnings.signature emit_external_warnings sigi
+let emit_external_warnings_on_signature (signature : Parsetree.signature) =
+  emit_external_warnings.signature emit_external_warnings signature

compiler/frontend/bs_ast_invariant.mli

@@ -30,9 +30,9 @@ type iterator = Ast_iterator.iterator
 val warn_discarded_unused_attributes : Parsetree.attributes -> unit
 (** Ast invariant checking for detecting errors *)
 
-val iter_warnings_on_stru : Parsetree.structure -> unit
+val iter_warnings_on_structure : Parsetree.structure -> unit
 
-val iter_warnings_on_sigi : Parsetree.signature -> unit
+val iter_warnings_on_signature : Parsetree.signature -> unit
 
 val emit_external_warnings_on_structure : Parsetree.structure -> unit
 

compiler/frontend/ppx_entry.ml

@@ -25,7 +25,7 @@
 let unsafe_mapper = Bs_builtin_ppx.mapper
 
 let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature =
-  Bs_ast_invariant.iter_warnings_on_sigi ast;
+  Bs_ast_invariant.iter_warnings_on_signature ast;
   Ast_config.process_sig ast;
   let ast =
     match !Js_config.jsx_version with
@@ -44,7 +44,7 @@ let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature =
     result
 
 let rewrite_implementation (ast : Parsetree.structure) : Parsetree.structure =
-  Bs_ast_invariant.iter_warnings_on_stru ast;
+  Bs_ast_invariant.iter_warnings_on_structure ast;
   Ast_config.process_str ast;
   let ast =
     match !Js_config.jsx_version with

compiler/ml/builtin_attributes.ml

@@ -182,17 +182,20 @@ let rec deprecated_of_str = function
     | Some _ as r -> r)
   | _ -> None
 
-let warning_attribute ?(ppwarning = true) =
+let warning_attribute ?(ppwarning = true) ?(report_attribute_errors = true) =
   let process loc txt errflag payload =
     match string_of_payload payload with
     | Some s -> (
       try Warnings.parse_options errflag s
       with Arg.Bad _ ->
-        Location.prerr_warning loc
-          (Warnings.Attribute_payload (txt, "Ill-formed list of warnings")))
+        if report_attribute_errors then
+          Location.prerr_warning loc
+            (Warnings.Attribute_payload (txt, "Ill-formed list of warnings")))
     | None ->
-      Location.prerr_warning loc
-        (Warnings.Attribute_payload (txt, "A single string literal is expected"))
+      if report_attribute_errors then
+        Location.prerr_warning loc
+          (Warnings.Attribute_payload
+             (txt, "A single string literal is expected"))
   in
   function
   | {txt = ("ocaml.warning" | "warning") as txt; loc}, payload ->
@@ -212,17 +215,22 @@ let warning_attribute ?(ppwarning = true) =
     Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
   | _ -> ()
 
-let warning_scope ?ppwarning attrs f =
+let warning_scope ?ppwarning ?report_attribute_errors attrs f =
   let prev = Warnings.backup () in
   try
-    List.iter (warning_attribute ?ppwarning) (List.rev attrs);
+    List.iter
+      (warning_attribute ?ppwarning ?report_attribute_errors)
+      (List.rev attrs);
     let ret = f () in
     Warnings.restore prev;
     ret
   with exn ->
     Warnings.restore prev;
     raise exn
 
+let warning_scope_without_attribute_diagnostics attrs f =
+  warning_scope ~ppwarning:false ~report_attribute_errors:false attrs f
+
 let warn_on_literal_pattern =
   List.exists (function
     | {txt = "ocaml.warn_on_literal_pattern" | "warn_on_literal_pattern"; _}, _

compiler/ml/builtin_attributes.mli

@@ -67,17 +67,29 @@ val check_duplicated_labels :
   (Parsetree.label_declaration list -> string Asttypes.loc option) ref
 val error_of_extension : Parsetree.extension -> Location.error
 
-val warning_attribute : ?ppwarning:bool -> Parsetree.attribute -> unit
+val warning_attribute :
+  ?ppwarning:bool ->
+  ?report_attribute_errors:bool ->
+  Parsetree.attribute ->
+  unit
 (** Apply warning settings from the specified attribute.
       "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix)
       are processed and other attributes are ignored.
 
       Also implement ocaml.ppwarning (unless ~ppwarning:false is
       passed).
+
+      [report_attribute_errors] only controls whether malformed warning
+      attributes emit diagnostics; valid warning settings are still applied
+      regardless.
   *)
 
 val warning_scope :
-  ?ppwarning:bool -> Parsetree.attributes -> (unit -> 'a) -> 'a
+  ?ppwarning:bool ->
+  ?report_attribute_errors:bool ->
+  Parsetree.attributes ->
+  (unit -> 'a) ->
+  'a
 (** Execute a function in a new scope for warning settings.  This
       means that the effect of any call to [warning_attribute] during
       the execution of this function will be discarded after
@@ -88,6 +100,14 @@ val warning_scope :
       is executed.
   *)
 
+val warning_scope_without_attribute_diagnostics :
+  Parsetree.attributes -> (unit -> 'a) -> 'a
+(** Like [warning_scope], but suppresses diagnostics that have already been
+      emitted during the frontend warning-attribute pass (such as
+      [@@ppwarning] and malformed warning payloads). The warning settings are
+      still applied to the nested computation.
+  *)
+
 val warn_on_literal_pattern : Parsetree.attributes -> bool
 val explicit_arity : Parsetree.attributes -> bool
 

compiler/ml/translcore.ml

@@ -404,6 +404,37 @@ let primitives_table =
 
 let find_primitive prim_name = Hashtbl.find primitives_table prim_name
 
+let is_null_undefined_constant (exp : Typedtree.expression) =
+  match exp.exp_desc with
+  | Texp_ident
+      ( _,
+        _,
+        {
+          val_kind =
+            Val_prim
+              {prim_name = "%null" | "%undefined" | "#null" | "#undefined"; _};
+          _;
+        } ) ->
+    true
+  | _ -> false
+
+let warn_on_polymorphic_comparison loc prim_name args = function
+  (* Skip warning 102 for `==` / `!=` when one side is a nullish constant:
+     those cases lower to dedicated null/undefined checks, not object comparison. *)
+  | Pobjcomp (Ceq | Cneq)
+    when prim_name = "%equal_null"
+         || prim_name = "%equal_undefined"
+         || prim_name = "%equal_nullable"
+         || List.exists is_null_undefined_constant args ->
+    ()
+  | Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax ->
+    Location.prerr_warning loc Warnings.Bs_polymorphic_comparison
+  | _ -> ()
+
+let emit_primitive_warnings loc prim_name args primitive =
+  warn_on_polymorphic_comparison loc prim_name args primitive;
+  primitive
+
 let specialize_comparison
     ({objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp} :
       specialized) env ty =
@@ -444,8 +475,9 @@ let specialize_primitive p env ty (* ~has_constant_constructor *) =
 let transl_primitive loc p env ty =
   (* Printf.eprintf "----transl_primitive %s----\n" p.prim_name; *)
   let prim =
-    try specialize_primitive p env ty (* ~has_constant_constructor:false *)
-    with Not_found -> Pccall p
+    (try specialize_primitive p env ty (* ~has_constant_constructor:false *)
+     with Not_found -> Pccall p)
+    |> emit_primitive_warnings loc p.prim_name []
   in
   match prim with
   | Ploc kind -> (
@@ -492,7 +524,7 @@ let transl_primitive_application loc prim env ty args =
     | [arg1] | [arg1; _] -> translate_unified_ops prim env arg1.exp_type
     | _ -> None
   in
-  match unified with
+  (match unified with
   | Some primitive -> primitive
   | None -> (
     try
@@ -524,7 +556,8 @@ let transl_primitive_application loc prim env ty args =
     with Not_found ->
       if String.length prim_name > 0 && prim_name.[0] = '%' then
         raise (Error (loc, Unknown_builtin_primitive prim_name));
-      Pccall prim)
+      Pccall prim))
+  |> emit_primitive_warnings loc prim_name args
 
 (* To propagate structured constants *)
 
@@ -653,8 +686,10 @@ 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_without_attribute_diagnostics
+    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

compiler/ml/translmod.ml

@@ -446,9 +446,11 @@ and transl_structure loc fields cc rootpath final_env = function
             transl_module Tcoerce_none None modl,
             body ),
         size )
-    | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _
-    | Tstr_attribute _ ->
-      transl_structure loc fields cc rootpath final_env rem)
+    | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ ->
+      transl_structure loc fields cc rootpath final_env rem
+    | Tstr_attribute x ->
+      Builtin_attributes.warning_scope_without_attribute_diagnostics [x]
+        (fun () -> transl_structure loc fields cc rootpath final_env rem))
 
 (* Update forward declaration in Translcore *)
 let _ = Translcore.transl_module := transl_module

compiler/ml/typemod.ml

@@ -870,9 +870,10 @@ and transl_signature env sg =
         let trem, rem, final_env = transl_sig newenv srem in
         (mksig (Tsig_include incl) env loc :: trem, sg @ rem, final_env)
       | Psig_attribute x ->
-        Builtin_attributes.warning_attribute x;
-        let trem, rem, final_env = transl_sig env srem in
-        (mksig (Tsig_attribute x) env loc :: trem, rem, final_env)
+        Builtin_attributes.warning_scope_without_attribute_diagnostics [x]
+          (fun () ->
+            let trem, rem, final_env = transl_sig env srem in
+            (mksig (Tsig_attribute x) env loc :: trem, rem, final_env))
       | Psig_extension (ext, _attrs) ->
         raise (Error_forward (Builtin_attributes.error_of_extension ext)))
   in
@@ -1590,14 +1591,24 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
       (Tstr_include incl, sg, new_env)
     | Pstr_extension (ext, _attrs) ->
       raise (Error_forward (Builtin_attributes.error_of_extension ext))
-    | Pstr_attribute x ->
-      Builtin_attributes.warning_attribute x;
-      (Tstr_attribute x, [], env)
+    | Pstr_attribute x -> (Tstr_attribute x, [], env)
   in
   let rec type_struct env sstr =
     Ctype.init_def (Ident.current_time ());
     match sstr with
     | [] -> ([], [], env)
+    | {pstr_desc = Pstr_attribute x; pstr_loc; _} :: srem ->
+      let previous_saved_types = Cmt_format.get_saved_types () in
+      let str =
+        {str_desc = Tstr_attribute x; str_loc = pstr_loc; str_env = env}
+      in
+      Cmt_format.set_saved_types
+        (Cmt_format.Partial_structure_item str :: previous_saved_types);
+      let str_rem, sig_rem, final_env =
+        Builtin_attributes.warning_scope_without_attribute_diagnostics [x]
+          (fun () -> type_struct env srem)
+      in
+      (str :: str_rem, sig_rem, final_env)
     | pstr :: srem ->
       let previous_saved_types = Cmt_format.get_saved_types () in
       let desc, sg, new_env = type_str_item env srem pstr in

tests/build_tests/super_errors/expected/malformed_warning_attribute.res.expected

@@ -0,0 +1,10 @@
+
+  Warning number 47
+  /.../fixtures/malformed_warning_attribute.res:1:1-9
+
+  1 │ @@warning(123)
+  2 │ 
+  3 │ let x = 1
+
+  illegal payload for attribute 'warning'.
+A single string literal is expected

tests/build_tests/super_errors/expected/malformed_warning_attribute.resi.expected

@@ -0,0 +1,10 @@
+
+  Warning number 47
+  /.../fixtures/malformed_warning_attribute.resi:1:1-9
+
+  1 │ @@warning(123)
+  2 │ 
+  3 │ let x: int
+
+  illegal payload for attribute 'warning'.
+A single string literal is expected

tests/build_tests/super_errors/expected/nested_malformed_warning_signature_attribute.resi.expected

@@ -0,0 +1,12 @@
+
+  Warning number 47
+  /.../fixtures/nested_malformed_warning_signature_attribute.resi:3:3-11
+
+  1 │ module M: {
+  2 │   let y: int
+  3 │   @@warning(123)
+  4 │ }
+  5 │ 
+
+  illegal payload for attribute 'warning'.
+A single string literal is expected