diff options
| -rw-r--r-- | gcc/ada/restrict.adb | 250 | ||||
| -rw-r--r-- | gcc/ada/restrict.ads | 38 | ||||
| -rw-r--r-- | gcc/ada/s-rident.ads | 39 |
3 files changed, 213 insertions, 114 deletions
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 2f1bd5d..99a20af 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -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; - 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; --------------- @@ -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; ---------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index bb81d85..2553e04 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -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 diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index b31d212..9dbaa73 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -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 |