-- 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 --
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;
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).
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;
-- 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;
- begin
- Name_Buffer (1 .. R'Last) := R;
- Name_Len := R'Length;
- Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
-
- P := 0;
- for J in Msg'Range loop
- if Msg (J) = '%' then
- P := P + 1;
- B (P) := '`';
-
- -- Put characters of image in message, quoting upper case letters
-
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) in 'A' .. 'Z' then
- P := P + 1;
- B (P) := ''';
- end if;
+ procedure Add_Char (C : Character);
+ -- Append given character to Msg, bumping Len
- P := P + 1;
- B (P) := Name_Buffer (J);
- end loop;
+ 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 --
+ -------------
- P := P + 1;
- B (P) := '`';
+ 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
- P := P + 1;
- B (P) := Msg (J);
+ Add_Char ('~');
+ end if;
+ end Id_Case;
+
+ -- Start of processing for Restriction_Msg
+
+ begin
+ -- Set warning message if warning
+
+ if Restriction_Warnings (R) then
+ Add_Char ('?');
+
+ -- 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.
+
+ elsif R /= No_Finalization then
+ Add_Char ('|');
+ end if;
+
+ Error_Msg_Sloc := Restrictions_Loc (R);
+
+ -- Set main message, adding implicit if no source location
+
+ 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;
+
+ 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;
- end loop;
- Error_Msg_N (B (1 .. P), N);
+ -- 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;
---------------
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
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
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)
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;
-----------------------------------
-----------------------------------
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
-- Entry is not currently in table
- No_Dependence.Append ((Unit, Warn));
+ No_Dependence.Append ((Unit, Warn, Profile));
end Set_Restriction_No_Dependence;
----------------------------------
-- 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,
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 (
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
-- 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
-- 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
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
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
-- 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
projects / platform / upstream / gcc.git / commitdiff