Better direct support for ocaml.ppwarning attribute.

Previously, there was a dedicated traversal of the Parsetree to
collect and report all ocaml.ppwarning attributes.  This approach has
the drawback that ocaml.warning settings for the current scope around
the ocaml.ppwarnign attribute were not taken into account.

Thanks to previous commits, we have a specific place in the code were
all attributes go through.  So we re-use it to detect ocaml.ppwarning
attributes, completely avoiding the dedicated traversal and the
drawback mentioned above.

Author: alainfrisch

.depend

@@ -200,6 +200,11 @@ Working version
   with an OPAM package called "num".
   (Xavier Leroy)
 
+- GPR#1248: support "ocaml.warning" in all attribute contexts, and
+  arrange so that "ocaml.ppwarning" is correctly scoped by surrounding
+  "ocaml.warning" attributes
+  (Alain Frisch, review by ...)
+
 ### Manual and documentation:
 
 - MPR#6548: remove obsolete limitation in the description of private
@@ -242,9 +247,9 @@ Working version
 
 - GPR#1187: Minimal documentation for compiler plugins
   (Florian Angeletti)
-  
+
 - GPR#1202: Fix Typos in comments as well as basic grammar errors.
-  (JP Rodi, review and suggestions by David Allsopp, Max Mouratov, 
+  (JP Rodi, review and suggestions by David Allsopp, Max Mouratov,
   Florian Angeletti, Xavier Leroy, Mark Shinwell and Damien Doligez)
 
 - GPR#1220: Fix "-keep-docs" option in ocamlopt manpage

Changes

@@ -117,30 +117,6 @@ let rec deprecated_of_str = function
   | _ -> None
 
 
-let emit_external_warnings =
-  (* Note: this is run as a preliminary pass when type-checking an
-     interface or implementation.  This allows to cover all kinds of
-     attributes, but the drawback is that it doesn't take local
-     configuration of warnings (with '@@warning'/'@@warnerror'
-     attributes) into account.  We should rather check for
-     'ppwarning' attributes during the actual type-checking, making
-     sure to cover all contexts (easier and more ugly alternative:
-     duplicate here the logic which control warnings locally). *)
-  let open Ast_iterator in
-  {
-    default_iterator with
-    attribute = (fun _ a ->
-        match a with
-        | {txt="ocaml.ppwarning"|"ppwarning"},
-          PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
-                                         (Pconst_string (s, _))},_);
-                pstr_loc}] ->
-            Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
-        | _ -> ()
-      )
-  }
-
-
 let warning_attribute =
   let process loc txt errflag payload =
     match string_of_payload payload with
@@ -161,13 +137,18 @@ let warning_attribute =
       process loc txt false payload
   | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) ->
       process loc txt true payload
+  | {txt="ocaml.ppwarning"|"ppwarning"},
+    PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant
+                                   (Pconst_string (s, _))},_);
+          pstr_loc}] ->
+      Location.prerr_warning pstr_loc (Warnings.Preprocessor s)
   | _ ->
       ()
 
 let warning_scope attrs f =
   let prev = Warnings.backup () in
   try
-    List.iter warning_attribute attrs;
+    List.iter warning_attribute (List.rev attrs);
     let ret = f () in
     Warnings.restore prev;
     ret

parsing/builtin_attributes.ml

@@ -47,7 +47,10 @@ val error_of_extension: Parsetree.extension -> Location.error
 val warning_attribute: 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. *)
+      are processed and other attributes are ignored.
+
+      Also implement ocaml.ppwarning.
+  *)
 
 val warning_scope: Parsetree.attributes -> (unit -> 'a) -> 'a
   (** Execute a function in a new scope for warning settings.  This
@@ -60,8 +63,6 @@ val warning_scope: Parsetree.attributes -> (unit -> 'a) -> 'a
       is executed.
   *)
 
-val emit_external_warnings: Ast_iterator.iterator
-
 val warn_on_literal_pattern: Parsetree.attributes -> bool
 val explicit_arity: Parsetree.attributes -> bool
 

parsing/builtin_attributes.mli

@@ -415,3 +415,70 @@ Line _, characters 10-13:
 Warning 3: deprecated: X.t
 type t = [ `A of X.t | `B of X.s | `C of X.u ]
 |}]
+
+
+(* Test for ocaml.ppwarning, and its interactions with ocaml.warning *)
+
+
+[@@@ocaml.ppwarning "Pp warning!"]
+;;
+[%%expect{|
+Line _, characters 20-33:
+Warning 22: Pp warning!
+|}]
+
+
+let x = () [@ocaml.ppwarning "Pp warning 1!"]
+    [@@ocaml.ppwarning  "Pp warning 2!"]
+;;
+[%%expect{|
+Line _, characters 24-39:
+Warning 22: Pp warning 2!
+Line _, characters 29-44:
+Warning 22: Pp warning 1!
+val x : unit = ()
+|}]
+
+type t = unit
+    [@ocaml.ppwarning "Pp warning!"]
+;;
+[%%expect{|
+Line _, characters 22-35:
+Warning 22: Pp warning!
+type t = unit
+|}]
+
+module X = struct
+  [@@@ocaml.warning "-22"]
+
+  [@@@ocaml.ppwarning "Pp warning1!"]
+
+  [@@@ocaml.warning "+22"]
+
+  [@@@ocaml.ppwarning "Pp warning2!"]
+end
+;;
+[%%expect{|
+Line _, characters 22-36:
+Warning 22: Pp warning2!
+module X : sig  end
+|}]
+
+let x = ((() [@ocaml.ppwarning "Pp warning 1!"]) [@ocaml.warning "-22"])  [@ocaml.ppwarning  "Pp warning 2!"]
+;;
+[%%expect{|
+Line _, characters 31-46:
+Warning 22: Pp warning 1!
+val x : unit = ()
+|}]
+
+type t = ((unit [@ocaml.ppwarning "Pp warning 1!"]) [@ocaml.warning "-22"])  [@ocaml.ppwarning  "Pp warning 2!"]
+  [@@ocaml.ppwarning "Pp warning 3!"]
+;;
+[%%expect{|
+Line _, characters 21-36:
+Warning 22: Pp warning 3!
+Line _, characters 34-49:
+Warning 22: Pp warning 1!
+type t = unit
+|}]

testsuite/tests/typing-deprecated/deprecated.ml

@@ -1515,10 +1515,6 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
 
 let type_toplevel_phrase env s =
   Env.reset_required_globals ();
-  begin
-    let iter = Builtin_attributes.emit_external_warnings in
-    iter.Ast_iterator.structure iter s
-  end;
   let (str, sg, env) =
     type_structure ~toplevel:true false None env s Location.none in
   let (str, _coerce) = ImplementationHooks.apply_hooks
@@ -1628,11 +1624,6 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
   try
   Typecore.reset_delayed_checks ();
   Env.reset_required_globals ();
-  begin
-    let iter = Builtin_attributes.emit_external_warnings in
-    iter.Ast_iterator.structure iter ast
-  end;
-
   let (str, sg, finalenv) =
     type_structure initial_env ast (Location.in_file sourcefile) in
   let simple_sg = simplify_signature sg in
@@ -1700,10 +1691,6 @@ let save_signature modname tsg outputprefix source_file initial_env cmi =
     (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi)
 
 let type_interface sourcefile env ast =
-  begin
-    let iter = Builtin_attributes.emit_external_warnings in
-    iter.Ast_iterator.signature iter ast
-  end;
   InterfaceHooks.apply_hooks { Misc.sourcefile } (transl_signature env ast)
 
 (* "Packaging" of several compilation units into one unit