par-prag.adb (Pragma_Warnings): Update for extended form of pragma Warnings.

2015-02-05  Yannick Moy  <moy@adacore.com>

	* par-prag.adb (Pragma_Warnings): Update for extended form
	of pragma Warnings. The "one" argument case may now have 2 or
	3 arguments.
	* sem_prag.adb (Analyze_Pragma/Pragma_Warnings): Update for
	extended form of pragma Warnings. Pragma with tool name is either
	rewritten as null or as an equivalent form without tool name,
	before reanalysis.
	* snames.ads-tmpl (Name_Gnatprove): New name.

From-SVN: r220447

4 files changed, 210 insertions, 50 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index bd6f02a..1282072 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,14 @@
+2015-02-05  Yannick Moy  <moy@adacore.com>
+
+	* par-prag.adb (Pragma_Warnings): Update for extended form
+	of pragma Warnings. The "one" argument case may now have 2 or
+	3 arguments.
+	* sem_prag.adb (Analyze_Pragma/Pragma_Warnings): Update for
+	extended form of pragma Warnings. Pragma with tool name is either
+	rewritten as null or as an equivalent form without tool name,
+	before reanalysis.
+	* snames.ads-tmpl (Name_Gnatprove): New name.
+
 2015-02-05  Robert Dewar  <dewar@adacore.com>
 
 	* sem_ch13.adb (Add_Invariants): Don't assume invariant is
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 93cbf94..1b72a29 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1047,10 +1047,13 @@ begin
       -- Warnings (GNAT) --
       ---------------------
 
-      --  pragma Warnings (On | Off [,REASON]);
-      --  pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
-      --  pragma Warnings (static_string_EXPRESSION [,REASON]);
-      --  pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
+      --  pragma Warnings ([TOOL_NAME,] On | Off [,REASON]);
+      --  pragma Warnings ([TOOL_NAME,] On | Off, LOCAL_NAME [,REASON]);
+      --  pragma Warnings ([TOOL_NAME,] static_string_EXPRESSION [,REASON]);
+      --  pragma Warnings ([TOOL_NAME,] On | Off,
+      --                                static_string_EXPRESSION [,REASON]);
+
+      --  REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
 
       --  The one argument ON/OFF case is processed by the parser, since it may
       --  control parser warnings as well as semantic warnings, and in any case
@@ -1058,50 +1061,132 @@ begin
       --  set well before any semantic analysis is performed. Note that we
       --  ignore this pragma if debug flag -gnatd.i is set.
 
-      --  Also note that the "one argument" case may have two arguments if the
-      --  second one is a reason argument.
+      --  Also note that the "one argument" case may have two or three
+      --  arguments if the first one is a tool name, and/or the last one is a
+      --  reason argument.
 
-      when Pragma_Warnings =>
-         if not Debug_Flag_Dot_I
-           and then (Arg_Count = 1
-                      or else (Arg_Count = 2
-                                and then Chars (Arg2) = Name_Reason))
-         then
-            Check_No_Identifier (Arg1);
+      --  Need documentation and syntax for TOOL_NAME ???
 
-            declare
-               Argx : constant Node_Id := Expression (Arg1);
+      when Pragma_Warnings => Warnings : declare
+         function First_Arg_Is_Matching_Tool_Name return Boolean;
+         --  Returns True if the first argument is a tool name matching the
+         --  current tool being run.
 
-               function Get_Reason return String_Id;
-               --  Analyzes Reason argument and returns corresponding String_Id
-               --  value, or null if there is no Reason argument, or if the
-               --  argument is not of the required form.
+         function Last_Arg return Node_Id;
+         --  Returns the last argument
 
-               ----------------
-               -- Get_Reason --
-               ----------------
+         function Last_Arg_Is_Reason return Boolean;
+         --  Returns True if the last argument is a reason argument
 
-               function Get_Reason return String_Id is
-               begin
-                  if Arg_Count = 1 then
-                     return Null_String_Id;
-                  else
-                     Start_String;
-                     Get_Reason_String (Expression (Arg2));
-                     return End_String;
-                  end if;
-               end Get_Reason;
+         function Get_Reason return String_Id;
+         --  Analyzes Reason argument and returns corresponding String_Id
+         --  value, or null if there is no Reason argument, or if the
+         --  argument is not of the required form.
 
-            begin
-               if Nkind (Argx) = N_Identifier then
-                  if Chars (Argx) = Name_On then
-                     Set_Warnings_Mode_On (Pragma_Sloc);
-                  elsif Chars (Argx) = Name_Off then
-                     Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason);
-                  end if;
+         -------------------------------------
+         -- First_Arg_Is_Matching_Tool_Name --
+         -------------------------------------
+
+         --  Comments needed for these complex conditionals ???
+
+         function First_Arg_Is_Matching_Tool_Name return Boolean is
+         begin
+            return Nkind (Arg1) = N_Identifier
+              and then ((Chars (Arg1) = Name_Gnat
+                          and then not
+                            (CodePeer_Mode or GNATprove_Mode or ASIS_Mode))
+                        or else
+                        (Chars (Arg1) = Name_Gnatprove
+                          and then GNATprove_Mode));
+         end First_Arg_Is_Matching_Tool_Name;
+
+         ----------------
+         -- Get_Reason --
+         ----------------
+
+         function Get_Reason return String_Id is
+            Arg : constant Node_Id := Last_Arg;
+         begin
+            if Last_Arg_Is_Reason then
+               Start_String;
+               Get_Reason_String (Expression (Arg));
+               return End_String;
+            else
+               return Null_String_Id;
+            end if;
+         end Get_Reason;
+
+         --------------
+         -- Last_Arg --
+         --------------
+
+         function Last_Arg return Node_Id is
+               Last_Arg : Node_Id;
+
+         begin
+            if Arg_Count = 1 then
+               Last_Arg := Arg1;
+            elsif Arg_Count = 2 then
+               Last_Arg := Arg2;
+            elsif Arg_Count = 3 then
+               Last_Arg := Arg3;
+            elsif Arg_Count = 4 then
+               Last_Arg := Next (Arg3);
+
+            --  Illegal case, error issued in semantic analysis
+
+            else
+               Last_Arg := Empty;
+            end if;
+
+            return Last_Arg;
+         end Last_Arg;
+
+         ------------------------
+         -- Last_Arg_Is_Reason --
+         ------------------------
+
+         function Last_Arg_Is_Reason return Boolean is
+            Arg : constant Node_Id := Last_Arg;
+         begin
+            return Nkind (Arg) in N_Has_Chars
+              and then Chars (Arg) = Name_Reason;
+         end Last_Arg_Is_Reason;
+
+         The_Arg : Node_Id;  --  On/Off argument
+         Argx    : Node_Id;
+
+      --  Start of processing for Warnings
+
+      begin
+         if not Debug_Flag_Dot_I
+           and then (Arg_Count = 1
+                       or else (Arg_Count = 2
+                                  and then (First_Arg_Is_Matching_Tool_Name
+                                              or else
+                                            Last_Arg_Is_Reason))
+                       or else (Arg_Count = 3
+                                  and then First_Arg_Is_Matching_Tool_Name
+                                  and then Last_Arg_Is_Reason))
+         then
+            if First_Arg_Is_Matching_Tool_Name then
+               The_Arg := Arg2;
+            else
+               The_Arg := Arg1;
+            end if;
+
+            Check_No_Identifier (The_Arg);
+            Argx := Expression (The_Arg);
+
+            if Nkind (Argx) = N_Identifier then
+               if Chars (Argx) = Name_On then
+                  Set_Warnings_Mode_On (Pragma_Sloc);
+               elsif Chars (Argx) = Name_Off then
+                  Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason);
                end if;
-            end;
+            end if;
          end if;
+      end Warnings;
 
       -----------------------------
       -- Wide_Character_Encoding --
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 0567c17..ab72e0d 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -21323,12 +21323,18 @@ package body Sem_Prag is
          -- Warnings --
          --------------
 
-         --  pragma Warnings (On | Off [,REASON]);
-         --  pragma Warnings (On | Off, LOCAL_NAME [,REASON]);
-         --  pragma Warnings (static_string_EXPRESSION [,REASON]);
-         --  pragma Warnings (On | Off, STRING_LITERAL [,REASON]);
+         --  pragma Warnings ([TOOL_NAME,] On | Off [,REASON]);
+         --  pragma Warnings ([TOOL_NAME,] On | Off, LOCAL_NAME [,REASON]);
+         --  pragma Warnings ([TOOL_NAME,] static_string_EXPRESSION [,REASON]);
+         --  pragma Warnings ([TOOL_NAME,] On | Off,
+         --                                static_string_EXPRESSION [,REASON]);
 
-         --  REASON ::= Reason => Static_String_Expression
+         --  REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
+
+         --  If present, TOOL_NAME refers to a tool, currently either GNAT
+         --  or GNATprove. If an identifier is a static string expression,
+         --  the form of pragma Warnings that starts with a static string
+         --  expression is used.
 
          when Pragma_Warnings => Warnings : declare
             Reason : String_Id;
@@ -21338,9 +21344,10 @@ package body Sem_Prag is
             Check_At_Least_N_Arguments (1);
 
             --  See if last argument is labeled Reason. If so, make sure we
-            --  have a static string expression, and acquire the REASON string.
-            --  Then remove the REASON argument by decreasing Num_Args by one;
-            --  Remaining processing looks only at first Num_Args arguments).
+            --  have a string literal or a concatenation of string literals,
+            --  and acquire the REASON string. Then remove the REASON argument
+            --  by decreasing Num_Args by one; Remaining processing looks only
+            --  at first Num_Args arguments).
 
             declare
                Last_Arg : constant Node_Id :=
@@ -21380,8 +21387,64 @@ package body Sem_Prag is
 
             declare
                Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
+               Shifted_Args : List_Id;
 
             begin
+               --  See if first argument is a tool name, currently either
+               --  GNAT or GNATprove. If so, either ignore the pragma if the
+               --  tool used does not match, or continue as if no tool name
+               --  was given otherwise, by shifting the arguments.
+
+               if Nkind (Argx) = N_Identifier
+                 and then not Nam_In (Chars (Argx), Name_On, Name_Off)
+                 and then not Is_Static_String_Expression (Arg1)
+                 --  How can this possibly work e.g. for GNATprove???
+               then
+                  if Chars (Argx) = Name_Gnat then
+                     if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
+                        Rewrite (N, Make_Null_Statement (Loc));
+                        Analyze (N);
+                        raise Pragma_Exit;
+                     end if;
+
+                  elsif Chars (Argx) = Name_Gnatprove then
+                     if not GNATprove_Mode then
+                        Rewrite (N, Make_Null_Statement (Loc));
+                        Analyze (N);
+                        raise Pragma_Exit;
+                     end if;
+
+                  else
+                     Error_Pragma_Arg
+                       ("argument of pragma% must be On/Off or tool name "
+                        & "or static string expression", Arg1);
+                  end if;
+
+                  --  At this point, the pragma Warnings applies to the tool,
+                  --  so continue with shifted arguments.
+
+                  Arg_Count := Arg_Count - 1;
+
+                  if Arg_Count = 1 then
+                     Shifted_Args := New_List (New_Copy (Arg2));
+                  elsif Arg_Count = 2 then
+                     Shifted_Args := New_List (New_Copy (Arg2),
+                                               New_Copy (Arg3));
+                  elsif Arg_Count = 3 then
+                     Shifted_Args := New_List (New_Copy (Arg2),
+                                               New_Copy (Arg3),
+                                               New_Copy (Arg4));
+                  else
+                     raise Program_Error;
+                  end if;
+
+                  Rewrite (N, Make_Pragma (Loc,
+                                Chars => Name_Warnings,
+                                Pragma_Argument_Associations => Shifted_Args));
+                  Analyze (N);
+                  raise Pragma_Exit;
+               end if;
+
                --  One argument case
 
                if Arg_Count = 1 then
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index fec0545..47a8ccd 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -713,6 +713,7 @@ package Snames is
    Name_Gcc                            : constant Name_Id := N + $;
    Name_General                        : constant Name_Id := N + $;
    Name_Gnat                           : constant Name_Id := N + $;
+   Name_Gnatprove                      : constant Name_Id := N + $;
    Name_GPL                            : constant Name_Id := N + $;
    Name_High_Order_First               : constant Name_Id := N + $;
    Name_IEEE_Float                     : constant Name_Id := N + $;