From f1bc74bcc807ff7096769e961d26632128cd8323 Mon Sep 17 00:00:00 2001
From: Alain Frisch <alain@frisch.fr>
Date: Oct 04 2013 08:18:50 +0000
Subject: #5445: interpret warning attribute on expressions, and as floating signature/structure items.


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14214 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

---

diff --git a/typing/typecore.ml b/typing/typecore.ml
index 2649430..729a460 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1892,7 +1892,9 @@ let rec type_exp env sexp =
 
 and type_expect ?in_function env sexp ty_expected =
   let previous_saved_types = Cmt_format.get_saved_types () in
+  let prev_warnings = Typetexp.warning_attribute sexp.pexp_attributes in
   let exp = type_expect_ ?in_function env sexp ty_expected in
+  begin match prev_warnings with Some x -> Warnings.restore x | None -> () end;
   Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types);
   exp
 
diff --git a/typing/typemod.ml b/typing/typemod.ml
index c97fab2..ec63ae8 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -636,6 +636,7 @@ and transl_signature env sg =
                  classes [rem]),
             final_env
         | Psig_attribute x ->
+            let _back = Typetexp.warning_attribute [x] in
             let (trem,rem, final_env) = transl_sig env srem in
             mksig (Tsig_attribute x) env loc :: trem, rem, final_env
         | Psig_extension ((s, _), _) ->
@@ -1209,6 +1210,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
     | Pstr_extension ((s, _), _) ->
         raise (Error (s.loc, env, Extension s.txt))
     | Pstr_attribute x ->
+        let _back = Typetexp.warning_attribute [x] in
         Tstr_attribute x, [], env
   in
   let rec type_struct env sstr =
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 79aefb1..f7c1acb 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -63,6 +63,35 @@ let check_deprecated loc attrs s =
   then
     Location.prerr_warning loc (Warnings.Deprecated s)
 
+let warning_attribute attrs =
+  let prev_warnings = ref None in
+  List.iter
+    (function
+      | ({txt = "warning"; loc}, payload) ->
+          begin match payload with
+          | PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Const_string(s, _))}, _)}] ->
+              if !prev_warnings = None then
+                prev_warnings := Some (Warnings.backup ());
+              begin try Warnings.parse_options false s
+              with Arg.Bad _ ->
+                Location.prerr_warning loc
+                  (Warnings.Attribute_payload
+                     ("warning",
+                      "Ill-formed list of warnings"))
+              end
+          | _ ->
+              Location.prerr_warning loc
+                (Warnings.Attribute_payload
+                   ("warning",
+                    "A single string literal is expected"))
+          end
+      | _ ->
+          ()
+    )
+    attrs;
+  !prev_warnings
+
+
 
 type variable_context = int * (string, type_expr) Tbl.t
 
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index a661e23..d475b03 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -112,3 +112,4 @@ val spellcheck_simple:
 
 val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit
 
+val warning_attribute: Parsetree.attributes -> Warnings.state option
diff --git a/utils/warnings.ml b/utils/warnings.ml
index b543f08..3a4e091 100644
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -64,6 +64,7 @@ type t =
   | Open_shadow_identifier of string * string (* 44 *)
   | Open_shadow_label_constructor of string * string (* 45 *)
   | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -119,9 +120,10 @@ let number = function
   | Open_shadow_identifier _ -> 44
   | Open_shadow_label_constructor _ -> 45
   | Bad_env_variable _ -> 46
+  | Attribute_payload _ -> 47
 ;;
 
-let last_warning_number = 46
+let last_warning_number = 47
 (* Must be the max number returned by the [number] function. *)
 
 let letter = function
@@ -159,6 +161,14 @@ let letter = function
 let active = Array.create (last_warning_number + 1) true;;
 let error = Array.create (last_warning_number + 1) false;;
 
+type state = bool array * bool array
+let backup () = (Array.copy active, Array.copy error)
+let restore (a, e) =
+  assert(Array.length a = Array.length active);
+  assert(Array.length e = Array.length error);
+  Array.blit a 0 active 0 (Array.length active);
+  Array.blit e 0 error 0 (Array.length error)
+
 let is_active x = active.(number x);;
 let is_error x = error.(number x);;
 
@@ -347,7 +357,9 @@ let message = function
         "this open statement shadows the %s %s (which is later used)"
         kind s
   | Bad_env_variable (var, s) ->
-    Printf.sprintf "illegal environment variable %s : %s" var s
+      Printf.sprintf "illegal environment variable %s : %s" var s
+  | Attribute_payload (a, s) ->
+      Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s
 ;;
 
 let nerrors = ref 0;;
@@ -439,6 +451,8 @@ let descriptions =
    43, "Nonoptional label applied as optional.";
    44, "Open statement shadows an already defined identifier.";
    45, "Open statement shadows an already defined label or constructor.";
+   46, "Illegal environment variable";
+   47, "Illegal attribute payload";
   ]
 ;;
 
diff --git a/utils/warnings.mli b/utils/warnings.mli
index fa48065..a7c3abd 100644
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -58,7 +58,8 @@ type t =
   | Nonoptional_label of string             (* 43 *)
   | Open_shadow_identifier of string * string (* 44 *)
   | Open_shadow_label_constructor of string * string (* 45 *)
-  | Bad_env_variable of string * string
+  | Bad_env_variable of string * string     (* 46 *)
+  | Attribute_payload of string * string    (* 47 *)
 ;;
 
 val parse_options : bool -> string -> unit;;
@@ -78,3 +79,7 @@ exception Errors of int;;
 val check_fatal : unit -> unit;;
 
 val help_warnings: unit -> unit
+
+type state
+val backup: unit -> state
+val restore: state -> unit