===================================================================
@@ -21323,13 +21323,19 @@
-- 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 @@
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 @@
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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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,61 +1047,146 @@
-- 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
-- we want to be absolutely sure that the range in the warnings table is
-- 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 =>
+ -- Need documentation and syntax for TOOL_NAME ???
+
+ 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 Last_Arg return Node_Id;
+ -- Returns the last argument
+
+ function Last_Arg_Is_Reason return Boolean;
+ -- Returns True if the last argument is a reason argument
+
+ 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.
+
+ -------------------------------------
+ -- 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 Chars (Arg2) = Name_Reason))
+ 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
- Check_No_Identifier (Arg1);
+ if First_Arg_Is_Matching_Tool_Name then
+ The_Arg := Arg2;
+ else
+ The_Arg := Arg1;
+ end if;
- declare
- Argx : constant Node_Id := Expression (Arg1);
+ Check_No_Identifier (The_Arg);
+ Argx := Expression (The_Arg);
- 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.
-
- ----------------
- -- Get_Reason --
- ----------------
-
- 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;
-
- 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;
+ 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 --
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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 @@
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 + $;