Simplify

Author: cknitt

compiler/ml/builtin_attributes.ml

@@ -228,6 +228,9 @@ let warning_scope ?ppwarning ?report_attribute_errors attrs f =
     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

@@ -100,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

@@ -686,8 +686,8 @@ let extract_directive_for_fn exp =
          else None)
 
 let rec transl_exp e =
-  Builtin_attributes.warning_scope ~ppwarning:false
-    ~report_attribute_errors:false e.exp_attributes (fun () ->
+  Builtin_attributes.warning_scope_without_attribute_diagnostics
+    e.exp_attributes (fun () ->
       List.iter (Translattribute.check_attribute e) e.exp_attributes;
       transl_exp0 e)
 

compiler/ml/translmod.ml

@@ -449,9 +449,8 @@ and transl_structure loc fields cc rootpath final_env = function
     | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ ->
       transl_structure loc fields cc rootpath final_env rem
     | Tstr_attribute x ->
-      Builtin_attributes.warning_scope ~ppwarning:false
-        ~report_attribute_errors:false [x] (fun () ->
-          transl_structure loc fields cc rootpath final_env rem))
+      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,11 +870,8 @@ 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 ->
-        (* The frontend pre-pass already emitted @@ppwarning and malformed
-           @@warning diagnostics; only thread the warning state here so the
-           remaining signature items see the right settings. *)
-        Builtin_attributes.warning_scope ~ppwarning:false
-          ~report_attribute_errors:false [x] (fun () ->
+        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) ->
@@ -1608,10 +1605,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
       Cmt_format.set_saved_types
         (Cmt_format.Partial_structure_item str :: previous_saved_types);
       let str_rem, sig_rem, final_env =
-        (* Floating warning-attribute diagnostics are handled in the frontend
-           pass; this scope only applies their effect to following items. *)
-        Builtin_attributes.warning_scope ~ppwarning:false
-          ~report_attribute_errors:false [x] (fun () -> type_struct env srem)
+        Builtin_attributes.warning_scope_without_attribute_diagnostics [x]
+          (fun () -> type_struct env srem)
       in
       (str :: str_rem, sig_rem, final_env)
     | pstr :: srem ->