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/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,10 +215,12 @@ 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

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

compiler/ml/translcore.ml

@@ -404,6 +404,15 @@ let primitives_table =
 
 let find_primitive prim_name = Hashtbl.find primitives_table prim_name
 
+let warn_on_polymorphic_comparison loc = function
+  | Pobjcomp _ | Pobjorder | Pobjmin | Pobjmax ->
+    Location.prerr_warning loc Warnings.Bs_polymorphic_comparison
+  | _ -> ()
+
+let emit_primitive_warnings loc primitive =
+  warn_on_polymorphic_comparison loc primitive;
+  primitive
+
 let specialize_comparison
     ({objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp} :
       specialized) env ty =
@@ -444,8 +453,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
   in
   match prim with
   | Ploc kind -> (
@@ -492,7 +502,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 +534,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
 
 (* To propagate structured constants *)
 
@@ -653,8 +664,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 ~ppwarning:false
+    ~report_attribute_errors: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

compiler/ml/translmod.ml

@@ -446,8 +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 _ ->
+    | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ ->
+      transl_structure loc fields cc rootpath final_env rem
+    | Tstr_attribute x ->
+      Builtin_attributes.warning_attribute ~ppwarning:false
+        ~report_attribute_errors:false x;
       transl_structure loc fields cc rootpath final_env rem)
 
 (* Update forward declaration in Translcore *)

tests/build_tests/super_errors/expected/warning102_expr_attribute.res.expected

@@ -0,0 +1 @@
+

tests/build_tests/super_errors/expected/warning102_structure_attribute.res.expected

@@ -0,0 +1 @@
+

tests/build_tests/super_errors/expected/warning102_value_attribute.res.expected

@@ -0,0 +1 @@
+

tests/build_tests/super_errors/fixtures/warning102_expr_attribute.res

@@ -0,0 +1,3 @@
+let x = (a, b) => {
+  @warning("-102") (a->Pair.second > b->Pair.second)
+}

tests/build_tests/super_errors/fixtures/warning102_structure_attribute.res

@@ -0,0 +1,3 @@
+@@warning("-102")
+
+let x = (a, b) => a->Pair.second > b->Pair.second

tests/build_tests/super_errors/fixtures/warning102_value_attribute.res

@@ -0,0 +1 @@
+let v = @warning("-102") compare