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
This commit is contained in:
Yannick Moy
Arnaud Charlet
parent
ef2c20e73c
commit
6d13d38e28
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =>
|
||||
-- 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 --
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 + $;
|
||||
|
|
|
|||
Loading…
Reference in New Issue