Allow to control which alerts are enable through attributes

parsing/builtin_attributes.ml

@@ -165,11 +165,32 @@ let warning_attribute ?(ppwarning = true) =
           (Warnings.Attribute_payload
              (txt, "A single string literal is expected"))
   in
+  let process_alert loc txt = function
+  | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_apply
+                                   ({pexp_desc=Pexp_ident{txt=Longident.Lident "~+"}},
+                                    [Nolabel,{pexp_desc=Pexp_ident{txt=Longident.Lident id}}])
+                              },_)}] ->
+      Warnings.set_alert id true
+  | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_apply
+                                   ({pexp_desc=Pexp_ident{txt=Longident.Lident "~-"}},
+                                    [Nolabel,{pexp_desc=Pexp_ident{txt=Longident.Lident id}}])
+                              },_)}] ->
+      Warnings.set_alert id false
+  | k ->
+      match kind_and_message k with
+      | Some _ -> ()
+      | None ->
+          Location.prerr_warning loc
+            (Warnings.Attribute_payload
+               (txt, "Invalid payload"))
+  in
   function
   | ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) ->
       process loc txt false payload
   | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) ->
       process loc txt true payload
+  | ({txt = ("ocaml.alert"|"alert") as txt; loc}, payload) ->
+      process_alert loc txt payload
   | {txt="ocaml.ppwarning"|"ppwarning"},
     PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
                                    (Pconst_string (s, _))},_);

utils/warnings.ml

@@ -205,13 +205,15 @@ type state =
   {
     active: bool array;
     error: bool array;
+    alerts: (Misc.StringSet.t * bool); (* true/false: positive/negative set *)
   }
 
 let current =
   ref
     {
       active = Array.make (last_warning_number + 1) true;
       error = Array.make (last_warning_number + 1) false;
+      alerts = (Misc.StringSet.empty, false);
     }
 
 let disabled = ref false
@@ -223,7 +225,15 @@ let backup () = !current
 
 let restore x = current := x
 
-let is_active x = not !disabled && (!current).active.(number x);;
+let is_active x =
+  not !disabled && (!current).active.(number x) &&
+  match x with
+  | Alert {kind; _} ->
+      let (set, pos) = (!current).alerts in
+      Misc.StringSet.mem kind set = pos
+  | _ ->
+      true
+
 let is_error x = not !disabled && (!current).error.(number x);;
 
 let mk_lazy f =
@@ -296,7 +306,7 @@ let parse_options errflag s =
   let error = Array.copy (!current).error in
   let active = Array.copy (!current).active in
   parse_opt error active (if errflag then error else active) s;
-  current := {error; active}
+  current := {error; active; alerts = (!current).alerts}
 
 (* If you change these, don't forget to change them in man/ocamlc.m *)
 let defaults_w = "+a-4-6-7-9-27-29-32..42-44-45-48-50-60";;
@@ -305,6 +315,18 @@ let defaults_warn_error = "-a+31";;
 let () = parse_options false defaults_w;;
 let () = parse_options true defaults_warn_error;;
 
+let set_alert s b =
+  let alerts =
+    match s with
+    | "all" ->
+        (Misc.StringSet.empty, not b)
+    | s ->
+        let (set, pos) = (!current).alerts in
+        let f = if b = pos then Misc.StringSet.add else Misc.StringSet.remove in
+        (f s set, pos)
+  in
+  current := {(!current) with alerts}
+
 let ref_manual_explanation () =
   (* manual references are checked a posteriori by the manual
      cross-reference consistency check in manual/tests*)

utils/warnings.mli

@@ -117,3 +117,8 @@ val restore: state -> unit
 val mk_lazy: (unit -> 'a) -> 'a Lazy.t
     (** Like [Lazy.of_fun], but the function is applied with
         the warning settings at the time [mk_lazy] is called. *)
+
+
+val set_alert: string -> bool -> unit
+  (** Enable(=true) or disable(=false) a given alert,
+      or all alerts (if the string argument is "all"). *)