mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 10:50:51 +08:00
Code Issues Packages Projects Releases Wiki Activity

restrict.adb: Improved messages for restriction warnings

Browse Source 
2008-08-04  Robert Dewar  <dewar@adacore.com>

	* restrict.adb: Improved messages for restriction warnings

	* restrict.ads: Improved messages for restriction messages

	* s-rident.ads (Profile_Name): Add No_Profile

From-SVN: r138575
This commit is contained in:
Robert Dewar 2008-08-04 10:37:31 +02:00 committed by Arnaud Charlet
parent d6b251539f
commit 9b7c38af5a
3 changed files with 210 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

244
gcc/ada/restrict.adb
View File

@ -52,22 +52,20 @@ package body Restrict is
-- Local Subprograms --
-----------------------
procedure Restriction_Msg (Msg : String; R : String; N : Node_Id);
-- Output error message at node N with given text, replacing the
-- '%' in the message with the name of the restriction given as R,
-- cased according to the current identifier casing. We do not use
-- the normal insertion mechanism, since this requires an entry
-- in the Names table, and this table will be locked if we are
-- generating a message from gigi.
procedure Restriction_Msg (R : Restriction_Id; N : Node_Id);
-- Called if a violation of restriction R at node N is found. This routine
-- outputs the appropriate message or messages taking care of warning vs
-- real violation, serious vs non-serious, implicit vs explicit, the second
-- message giving the profile name if needed, and the location information.
function Same_Unit (U1, U2 : Node_Id) return Boolean;
-- Returns True iff U1 and U2 represent the same library unit. Used for
-- handling of No_Dependence => Unit restriction case.
function Suppress_Restriction_Message (N : Node_Id) return Boolean;
-- N is the node for a possible restriction violation message, but
-- the message is to be suppressed if this is an internal file and
-- this file is not the main unit.
-- N is the node for a possible restriction violation message, but the
-- message is to be suppressed if this is an internal file and this file is
-- not the main unit. Returns True if message is to be suppressed.
-------------------
-- Abort_Allowed --
@ -148,7 +146,7 @@ package body Restrict is
if Name_Len < 5
or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
and then
Name_Buffer (Name_Len - 4 .. Name_Len) /= ".adb")
Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb")
then
return;
end if;
@ -194,8 +192,6 @@ package body Restrict is
N : Node_Id;
V : Uint := Uint_Minus_1)
is
Rimage : constant String := Restriction_Id'Image (R);
VV : Integer;
-- V converted to integer form. If V is greater than Integer'Last,
-- it is reset to minus 1 (unknown value).
@ -311,35 +307,7 @@ package body Restrict is
and then Restrictions.Value (R) = 0)
or else Restrictions.Count (R) > Restrictions.Value (R)
then
Error_Msg_Sloc := Restrictions_Loc (R);
-- If we have a location for the Restrictions pragma, output it
if Error_Msg_Sloc > No_Location
or else Error_Msg_Sloc = System_Location
then
if Restriction_Warnings (R) then
Restriction_Msg ("|violation of restriction %#?", Rimage, N);
else
-- Normally a restriction violation is a non-serious error,
-- but we treat violation of No_Finalization as a serious
-- error, since we want to turn off expansion in this case,
-- expansion just causes too many cascaded errors.
if R = No_Finalization then
Restriction_Msg ("violation of restriction %#", Rimage, N);
else
Restriction_Msg ("|violation of restriction %#", Rimage, N);
end if;
end if;
-- Otherwise we have the case of an implicit restriction
-- (e.g. a restriction implicitly set by another pragma)
else
Restriction_Msg
("|violation of implicit restriction %", Rimage, N);
end if;
Restriction_Msg (R, N);
end if;
end Check_Restriction;
@ -543,43 +511,147 @@ package body Restrict is
-- Restriction_Msg --
---------------------
procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is
B : String (1 .. Msg'Length + 2 * R'Length + 1);
P : Natural := 1;
procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
Msg : String (1 .. 100);
Len : Natural := 0;
procedure Add_Char (C : Character);
-- Append given character to Msg, bumping Len
procedure Add_Str (S : String);
-- Append given string to Msg, bumping Len appropriately
procedure Id_Case (S : String; Quotes : Boolean := True);
-- Given a string S, case it according to current identifier casing,
-- and store in Error_Msg_String. Then append `~` to the message buffer
-- to output the string unchanged surrounded in quotes. The quotes are
-- suppressed if Quotes = False.
--------------
-- Add_Char --
--------------
procedure Add_Char (C : Character) is
begin
Len := Len + 1;
Msg (Len) := C;
end Add_Char;
-------------
-- Add_Str --
-------------
procedure Add_Str (S : String) is
begin
Msg (Len + 1 .. Len + S'Length) := S;
Len := Len + S'Length;
end Add_Str;
-------------
-- Id_Case --
-------------
procedure Id_Case (S : String; Quotes : Boolean := True) is
begin
Name_Buffer (1 .. S'Last) := S;
Name_Len := S'Length;
Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
Error_Msg_Strlen := Name_Len;
Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
if Quotes then
Add_Str ("`~`");
else
Add_Char ('~');
end if;
end Id_Case;
-- Start of processing for Restriction_Msg
begin
Name_Buffer (1 .. R'Last) := R;
Name_Len := R'Length;
Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
-- Set warning message if warning
P := 0;
for J in Msg'Range loop
if Msg (J) = '%' then
P := P + 1;
B (P) := '`';
if Restriction_Warnings (R) then
Add_Char ('?');
-- Put characters of image in message, quoting upper case letters
-- If real violation (not warning), then mark it as non-serious unless
-- it is a violation of No_Finalization in which case we leave it as a
-- serious message, since otherwise we get crashes during attempts to
-- expand stuff that is not properly formed due to assumptions made
-- about no finalization being present.
for J in 1 .. Name_Len loop
if Name_Buffer (J) in 'A' .. 'Z' then
P := P + 1;
B (P) := ''';
end if;
elsif R /= No_Finalization then
Add_Char ('|');
end if;
P := P + 1;
B (P) := Name_Buffer (J);
end loop;
Error_Msg_Sloc := Restrictions_Loc (R);
P := P + 1;
B (P) := '`';
-- Set main message, adding implicit if no source location
else
P := P + 1;
B (P) := Msg (J);
if Error_Msg_Sloc > No_Location
or else Error_Msg_Sloc = System_Location
then
Add_Str ("violation of restriction ");
else
Add_Str ("violation of implicit restriction ");
Error_Msg_Sloc := No_Location;
end if;
-- Case of parametrized restriction
if R in All_Parameter_Restrictions then
Add_Char ('`');
Id_Case (Restriction_Id'Image (R), Quotes => False);
Add_Str (" = ^`");
Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
-- Case of boolean restriction
else
Id_Case (Restriction_Id'Image (R));
end if;
-- Case of no secondary profile continuation message
if Restriction_Profile_Name (R) = No_Profile then
if Error_Msg_Sloc /= No_Location then
Add_Char ('#');
end if;
end loop;
Error_Msg_N (B (1 .. P), N);
Add_Char ('!');
Error_Msg_N (Msg (1 .. Len), N);
-- Case of secondary profile continuation message present
else
Add_Char ('!');
Error_Msg_N (Msg (1 .. Len), N);
Len := 0;
Add_Char ('\');
-- Set as warning if warning case
if Restriction_Warnings (R) then
Add_Char ('?');
end if;
-- Set main message
Add_Str ("from profile ");
Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
-- Add location if we have one
if Error_Msg_Sloc /= No_Location then
Add_Char ('#');
end if;
-- Output unconditional message and we are done
Add_Char ('!');
Error_Msg_N (Msg (1 .. Len), N);
end if;
end Restriction_Msg;
---------------
@ -634,6 +706,10 @@ package body Restrict is
Set_Restriction (J, N, V (J));
end if;
-- Record that this came from a Profile[_Warnings] restriction
Restriction_Profile_Name (J) := P;
-- Set warning flag, except that we do not set the warning
-- flag if the restriction was already active and this is
-- the warning case. That avoids a warning overriding a real
@ -683,13 +759,17 @@ package body Restrict is
Restricted_Profile_Cached := False;
end if;
-- Set location, but preserve location of system
-- restriction for nice error msg with run time name
-- Set location, but preserve location of system restriction for nice
-- error msg with run time name.
if Restrictions_Loc (R) /= System_Location then
Restrictions_Loc (R) := Sloc (N);
end if;
-- Note restriction came from restriction pragma, not profile
Restriction_Profile_Name (R) := No_Profile;
-- Record the restriction if we are in the main unit, or in the extended
-- main unit. The reason that we test separately for Main_Unit is that
-- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
@ -731,12 +811,11 @@ package body Restrict is
Restrictions_Loc (R) := Sloc (N);
end if;
-- Record the restriction if we are in the main unit,
-- or in the extended main unit. The reason that we
-- test separately for Main_Unit is that gnat.adc is
-- processed with Current_Sem_Unit = Main_Unit, but
-- nodes in gnat.adc do not appear to be the extended
-- main source unit (they probably should do ???)
-- Record the restriction if we are in the main unit, or in the extended
-- main unit. The reason that we test separately for Main_Unit is that
-- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
-- gnat.adc do not appear to be the extended main source unit (they
-- probably should do ???)
if Current_Sem_Unit = Main_Unit
or else In_Extended_Main_Source_Unit (N)
@ -751,6 +830,10 @@ package body Restrict is
Main_Restrictions.Value (R) := V;
end if;
end if;
-- Note restriction came from restriction pragma, not profile
Restriction_Profile_Name (R) := No_Profile;
end Set_Restriction;
-----------------------------------
@ -758,8 +841,9 @@ package body Restrict is
-----------------------------------
procedure Set_Restriction_No_Dependence
(Unit : Node_Id;
Warn : Boolean)
(Unit : Node_Id;
Warn : Boolean;
Profile : Profile_Name := No_Profile)
is
begin
-- Loop to check for duplicate entry
@ -782,7 +866,7 @@ package body Restrict is
-- Entry is not currently in table
No_Dependence.Append ((Unit, Warn));
No_Dependence.Append ((Unit, Warn, Profile));
end Set_Restriction_No_Dependence;
----------------------------------

38
gcc/ada/restrict.ads
View File

@ -50,6 +50,12 @@ package Restrict is
-- pragma, and a value of System_Location is used for restrictions
-- set from package Standard by the processing in Targparm.
Restriction_Profile_Name : array (All_Restrictions) of Profile_Name;
-- Entries in this array are valid only if the corresponding restriction
-- in Restrictions set. The value is the corresponding profile name if the
-- restriction was set by a Profile or Profile_Warnings pragma. The value
-- is No_Profile in all other cases.
Main_Restrictions : Restrictions_Info := No_Restrictions;
-- This variable records only restrictions found in any units of the
-- main extended unit. These are the variables used for ali file output,
@ -154,6 +160,10 @@ package Restrict is
Warn : Boolean;
-- True if from Restriction_Warnings, False if from Restrictions
Profile : Profile_Name;
-- Set to name of profile from which No_Dependence entry came, or to
-- No_Profile if a pragma Restriction set the No_Dependence entry.
end record;
package No_Dependence is new Table.Table (
@ -190,14 +200,13 @@ package Restrict is
V : Uint := Uint_Minus_1);
-- Checks that the given restriction is not set, and if it is set, an
-- appropriate message is posted on the given node. Also records the
-- violation in the appropriate internal arrays. Note that it is
-- mandatory to always use this routine to check if a restriction
-- is violated. Such checks must never be done directly by the caller,
-- since otherwise violations in the absence of restrictions are not
-- properly recorded. The value of V is relevant only for parameter
-- restrictions, and in this case indicates the exact count for the
-- violation. If the exact count is not known, V is left at its
-- default value of -1 which indicates an unknown count.
-- violation in the appropriate internal arrays. Note that it is mandatory
-- to always use this routine to check if a restriction is violated. Such
-- checks must never be done directly by the caller, since otherwise
-- violations in the absence of restrictions are not properly recorded. The
-- value of V is relevant only for parameter restrictions, and in this case
-- indicates the exact count for the violation. If the exact count is not
-- known, V is left at its default of -1 which indicates an unknown count.
procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id);
-- Called when a dependence on a unit is created (either implicitly, or by
@ -302,18 +311,19 @@ package Restrict is
-- parameter restriction, and the corresponding value V is given.
procedure Set_Restriction_No_Dependence
(Unit : Node_Id;
Warn : Boolean);
(Unit : Node_Id;
Warn : Boolean;
Profile : Profile_Name := No_Profile);
-- Sets given No_Dependence restriction in table if not there already.
-- Warn is True if from Restriction_Warnings, or for Restrictions if flag
-- Treat_Restrictions_As_Warnings is set. False if from Restrictions and
-- this flag is not set.
-- this flag is not set. Profile is set to a non-default value if the
-- No_Dependence restriction comes from a Profile pragma.
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
-- Tests to see if tasking operations are allowed by the current
-- restrictions settings. For tasking to be allowed Max_Tasks must
-- be non-zero.
-- Tests if tasking operations are allowed by the current restrictions
-- settings. For tasking to be allowed Max_Tasks must be non-zero.
private
type Save_Cunit_Boolean_Restrictions is

39
gcc/ada/s-rident.ads
View File

@ -50,9 +50,9 @@ package System.Rident is
-- The following enumeration type defines the set of restriction
-- identifiers that are implemented in GNAT.
-- To add a new restriction identifier, add an entry with the name
-- to be used in the pragma, and add appropriate calls to the
-- Restrict.Check_Restriction routine.
-- To add a new restriction identifier, add an entry with the name to be
-- used in the pragma, and add calls to the Restrict.Check_Restriction
-- routine as appropriate.
type Restriction_Id is
@ -199,7 +199,7 @@ package System.Rident is
subtype All_Parameter_Restrictions is
Restriction_Id range
Max_Protected_Entries .. Max_Storage_At_Blocking;
-- All restrictions that are take a parameter
-- All restrictions that take a parameter
subtype Checked_Parameter_Restrictions is
All_Parameter_Restrictions range
@ -225,8 +225,8 @@ package System.Rident is
subtype Checked_Val_Parameter_Restrictions is
Checked_Parameter_Restrictions range
Max_Protected_Entries .. Max_Tasks;
-- Restrictions with parameter where the count is known at least in
-- some cases by the compiler/binder.
-- Restrictions with parameter where the count is known at least in some
-- cases by the compiler/binder.
subtype Checked_Zero_Parameter_Restrictions is
Checked_Parameter_Restrictions range
@ -307,24 +307,29 @@ package System.Rident is
-- Profile Definitions and Data --
----------------------------------
type Profile_Name is (Ravenscar, Restricted);
-- Names of recognized profiles
type Profile_Name is (No_Profile, Ravenscar, Restricted);
-- Names of recognized profiles. No_Profile is used to indicate that a
-- restriction came from pragma Restrictions[_Warning], as opposed to
-- pragma Profile[_Warning].
subtype Profile_Name_Actual is Profile_Name range Ravenscar .. Restricted;
-- Actual used profile names
type Profile_Data is record
Set : Restriction_Flags;
-- Set to True if given restriction must be set for the profile,
-- and False if it need not be set (False does not mean that it
-- must not be set, just that it need not be set). If the flag
-- is True for a parameter restriction, then the Value array
-- gives the maximum value permitted by the profile.
-- Set to True if given restriction must be set for the profile, and
-- False if it need not be set (False does not mean that it must not be
-- set, just that it need not be set). If the flag is True for a
-- parameter restriction, then the Value array gives the maximum value
-- permitted by the profile.
Value : Restriction_Values;
-- An entry in this array is meaningful only if the corresponding
-- flag in Set is True. In that case, the value in this array is
-- the maximum value of the parameter permitted by the profile.
-- An entry in this array is meaningful only if the corresponding flag
-- in Set is True. In that case, the value in this array is the maximum
-- value of the parameter permitted by the profile.
end record;
Profile_Info : array (Profile_Name) of Profile_Data :=
Profile_Info : array (Profile_Name_Actual) of Profile_Data :=
-- Restricted Profile