diff options
Diffstat (limited to 'gcc/ada/restrict.adb')
| -rw-r--r-- | gcc/ada/restrict.adb | 278 |
1 files changed, 79 insertions, 199 deletions
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 8a8e2fa..c63c881 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2020, 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- -- @@ -35,37 +35,14 @@ with Opt; use Opt; with Sinfo; use Sinfo; with Sinput; use Sinput; with Stand; use Stand; +with Targparm; use Targparm; with Uname; use Uname; package body Restrict is - ------------------------------- - -- SPARK Restriction Control -- - ------------------------------- - - -- SPARK HIDE directives allow the effect of the SPARK_05 restriction to be - -- turned off for a specified region of code, and the following tables are - -- the data structures used to keep track of these regions. - - -- The table contains pairs of source locations, the first being the start - -- location for hidden region, and the second being the end location. - - -- Note that the start location is included in the hidden region, while - -- the end location is excluded from it. (It typically corresponds to the - -- next token during scanning.) - - type SPARK_Hide_Entry is record - Start : Source_Ptr; - Stop : Source_Ptr; - end record; - - package SPARK_Hides is new Table.Table ( - Table_Component_Type => SPARK_Hide_Entry, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 100, - Table_Increment => 200, - Table_Name => "SPARK Hides"); + Global_Restriction_No_Tasking : Boolean := False; + -- Set to True when No_Tasking is set in the run-time package System + -- or in a configuration pragmas file (for example, gnat.adc). -------------------------------- -- Package Local Declarations -- @@ -260,7 +237,7 @@ package body Restrict is -- For type conversion, check converted expression - elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then + elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then Check_No_Implicit_Aliasing (Expression (Obj)); return; @@ -511,13 +488,6 @@ package body Restrict is return; end if; - -- In SPARK 05 mode, issue an error for any use of class-wide, even if - -- the No_Dispatch restriction is not set. - - if R = No_Dispatch then - Check_SPARK_05_Restriction ("class-wide is not allowed", N); - end if; - if UI_Is_In_Int_Range (V) then VV := Integer (UI_To_Int (V)); else @@ -656,7 +626,14 @@ package body Restrict is return; end if; - Id := Identifier (N); + if Nkind (N) = N_Pragma then + Id := Pragma_Identifier (N); + elsif Nkind (N) = N_Attribute_Definition_Clause then + Id := N; + else + Id := Identifier (N); + end if; + A_Id := Get_Aspect_Id (Chars (Id)); pragma Assert (A_Id /= No_Aspect); @@ -769,7 +746,7 @@ package body Restrict is and then Chars (Scope (Ent)) = Name_Ada and then Scope (Scope (Ent)) = Standard_Standard) then - if Nkind_In (Expr, N_Identifier, N_Operator_Symbol) + if Nkind (Expr) in N_Identifier | N_Operator_Symbol and then Chars (Ent) = Chars (Expr) then Error_Msg_Node_1 := N; @@ -786,7 +763,7 @@ package body Restrict is -- Here if at outer level of entity name in table - elsif Nkind_In (Expr, N_Identifier, N_Operator_Symbol) then + elsif Nkind (Expr) in N_Identifier | N_Operator_Symbol then exit; -- Here if neither at the outer level @@ -846,94 +823,6 @@ package body Restrict is end if; end Check_Restriction_No_Use_Of_Pragma; - -------------------------------- - -- Check_SPARK_05_Restriction -- - -------------------------------- - - procedure Check_SPARK_05_Restriction - (Msg : String; - N : Node_Id; - Force : Boolean := False) - is - Msg_Issued : Boolean; - Save_Error_Msg_Sloc : Source_Ptr; - Onode : constant Node_Id := Original_Node (N); - - begin - -- Output message if Force set - - if Force - - -- Or if this node comes from source - - or else Comes_From_Source (N) - - -- Or if this is a range node which rewrites a range attribute and - -- the range attribute comes from source. - - or else (Nkind (N) = N_Range - and then Nkind (Onode) = N_Attribute_Reference - and then Attribute_Name (Onode) = Name_Range - and then Comes_From_Source (Onode)) - - -- Or this is an expression that does not come from source, which is - -- a rewriting of an expression that does come from source. - - or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode)) - then - if Restriction_Check_Required (SPARK_05) - and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) - then - return; - end if; - - -- Since the call to Restriction_Msg from Check_Restriction may set - -- Error_Msg_Sloc to the location of the pragma restriction, save and - -- restore the previous value of the global variable around the call. - - Save_Error_Msg_Sloc := Error_Msg_Sloc; - Check_Restriction (Msg_Issued, SPARK_05, First_Node (N)); - Error_Msg_Sloc := Save_Error_Msg_Sloc; - - if Msg_Issued then - Error_Msg_F ("\\| " & Msg, N); - end if; - end if; - end Check_SPARK_05_Restriction; - - procedure Check_SPARK_05_Restriction - (Msg1 : String; - Msg2 : String; - N : Node_Id) - is - Msg_Issued : Boolean; - Save_Error_Msg_Sloc : Source_Ptr; - - begin - pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\'); - - if Comes_From_Source (Original_Node (N)) then - if Restriction_Check_Required (SPARK_05) - and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) - then - return; - end if; - - -- Since the call to Restriction_Msg from Check_Restriction may set - -- Error_Msg_Sloc to the location of the pragma restriction, save and - -- restore the previous value of the global variable around the call. - - Save_Error_Msg_Sloc := Error_Msg_Sloc; - Check_Restriction (Msg_Issued, SPARK_05, First_Node (N)); - Error_Msg_Sloc := Save_Error_Msg_Sloc; - - if Msg_Issued then - Error_Msg_F ("\\| " & Msg1, N); - Error_Msg_F (Msg2, N); - end if; - end if; - end Check_SPARK_05_Restriction; - -------------------------------------- -- Check_Wide_Character_Restriction -- -------------------------------------- @@ -1021,24 +910,15 @@ package body Restrict is return Not_A_Restriction_Id; end Get_Restriction_Id; - -------------------------------- - -- Is_In_Hidden_Part_In_SPARK -- - -------------------------------- + ----------------------- + -- Global_No_Tasking -- + ----------------------- - function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is + function Global_No_Tasking return Boolean is begin - -- Loop through table of hidden ranges - - for J in SPARK_Hides.First .. SPARK_Hides.Last loop - if SPARK_Hides.Table (J).Start <= Loc - and then Loc < SPARK_Hides.Table (J).Stop - then - return True; - end if; - end loop; - - return False; - end Is_In_Hidden_Part_In_SPARK; + return Global_Restriction_No_Tasking + or else Targparm.Restrictions_On_Target.Set (No_Tasking); + end Global_No_Tasking; ------------------------------- -- No_Exception_Handlers_Set -- @@ -1097,7 +977,7 @@ package body Restrict is and then OK_No_Use_Of_Entity_Name (Selector_Name (N)); - elsif Nkind_In (N, N_Identifier, N_Operator_Symbol) then + elsif Nkind (N) in N_Identifier | N_Operator_Symbol then return True; else @@ -1134,21 +1014,11 @@ package body Restrict is when Name_No_Task_Attributes => New_Name := Name_No_Task_Attributes_Package; - -- SPARK is special in that we unconditionally warn - - when Name_SPARK => - Error_Msg_Name_1 := Name_SPARK; - Error_Msg_N ("restriction identifier % is obsolescent??", N); - Error_Msg_Name_1 := Name_SPARK_05; - Error_Msg_N ("|use restriction identifier % instead??", N); - return Name_SPARK_05; - when others => return Old_Name; end case; - -- Output warning if we are warning on obsolescent features for all - -- cases other than SPARK. + -- Output warning if we are warning on obsolescent features. if Warn_On_Obsolescent_Feature then Error_Msg_Name_1 := Old_Name; @@ -1250,8 +1120,7 @@ package body Restrict is -- 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, - -- except for SPARK_05 (an acronym) which is set all upper case, and + -- 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. @@ -1284,13 +1153,7 @@ package body Restrict is begin Name_Buffer (1 .. S'Last) := S; Name_Len := S'Length; - - if R = SPARK_05 then - Set_All_Upper_Case; - else - Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N)))); - end if; - + 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); @@ -1395,15 +1258,15 @@ package body Restrict is function Same_Entity (E1, E2 : Node_Id) return Boolean is begin - if Nkind_In (E1, N_Identifier, N_Operator_Symbol) + if Nkind (E1) in N_Identifier | N_Operator_Symbol and then - Nkind_In (E2, N_Identifier, N_Operator_Symbol) + Nkind (E2) in N_Identifier | N_Operator_Symbol then return Chars (E1) = Chars (E2); - elsif Nkind_In (E1, N_Selected_Component, N_Expanded_Name) + elsif Nkind (E1) in N_Selected_Component | N_Expanded_Name and then - Nkind_In (E2, N_Selected_Component, N_Expanded_Name) + Nkind (E2) in N_Selected_Component | N_Expanded_Name then return Same_Unit (Prefix (E1), Prefix (E2)) and then @@ -1422,9 +1285,9 @@ package body Restrict is if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then return Chars (U1) = Chars (U2); - elsif Nkind_In (U1, N_Selected_Component, N_Expanded_Name) + elsif Nkind (U1) in N_Selected_Component | N_Expanded_Name and then - Nkind_In (U2, N_Selected_Component, N_Expanded_Name) + Nkind (U2) in N_Selected_Component | N_Expanded_Name then return Same_Unit (Prefix (U1), Prefix (U2)) and then @@ -1444,17 +1307,6 @@ package body Restrict is end Save_Config_Cunit_Boolean_Restrictions; ------------------------------ - -- Set_Hidden_Part_In_SPARK -- - ------------------------------ - - procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is - begin - SPARK_Hides.Increment_Last; - SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1; - SPARK_Hides.Table (SPARK_Hides.Last).Stop := Loc2; - end Set_Hidden_Part_In_SPARK; - - ------------------------------ -- Set_Profile_Restrictions -- ------------------------------ @@ -1502,8 +1354,6 @@ package body Restrict is -- Set_Restriction -- --------------------- - -- Case of Boolean restriction - procedure Set_Restriction (R : All_Boolean_Restrictions; N : Node_Id) @@ -1543,8 +1393,6 @@ package body Restrict is end if; end Set_Restriction; - -- Case of parameter restriction - procedure Set_Restriction (R : All_Parameter_Restrictions; N : Node_Id; @@ -1594,6 +1442,29 @@ package body Restrict is Restriction_Profile_Name (R) := No_Profile; end Set_Restriction; + procedure Set_Restriction + (R : All_Restrictions; + N : Node_Id; + Warn : Boolean; + V : Integer := Integer'First) + is + Set : Boolean := True; + begin + if Warn and then Restriction_Active (R) then + Set := False; + end if; + + if Set then + if R in All_Boolean_Restrictions then + Set_Restriction (R, N); + else + Set_Restriction (R, N, V); + end if; + + Restriction_Warnings (R) := Warn; + end if; + end Set_Restriction; + ----------------------------------- -- Set_Restriction_No_Dependence -- ----------------------------------- @@ -1633,7 +1504,7 @@ package body Restrict is procedure Set_Restriction_No_Use_Of_Entity (Entity : Node_Id; - Warning : Boolean; + Warn : Boolean; Profile : Profile_Name := No_Profile) is Nam : Node_Id; @@ -1649,7 +1520,7 @@ package body Restrict is -- Error has precedence over warning - if not Warning then + if not Warn then No_Use_Of_Entity.Table (J).Warn := False; end if; @@ -1659,17 +1530,17 @@ package body Restrict is -- Entry is not currently in table - No_Use_Of_Entity.Append ((Entity, Warning, Profile)); + No_Use_Of_Entity.Append ((Entity, Warn, Profile)); -- Now we need to find the direct name and set Boolean2 flag - if Nkind_In (Entity, N_Identifier, N_Operator_Symbol) then + if Nkind (Entity) in N_Identifier | N_Operator_Symbol then Nam := Entity; else pragma Assert (Nkind (Entity) = N_Selected_Component); Nam := Selector_Name (Entity); - pragma Assert (Nkind_In (Nam, N_Identifier, N_Operator_Symbol)); + pragma Assert (Nkind (Nam) in N_Identifier | N_Operator_Symbol); end if; Set_Name_Table_Boolean2 (Chars (Nam), True); @@ -1680,15 +1551,15 @@ package body Restrict is ------------------------------------------------ procedure Set_Restriction_No_Specification_Of_Aspect - (N : Node_Id; - Warning : Boolean) + (N : Node_Id; + Warn : Boolean) is A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N)); begin No_Specification_Of_Aspect_Set := True; No_Specification_Of_Aspects (A_Id) := Sloc (N); - No_Specification_Of_Aspect_Warning (A_Id) := Warning; + No_Specification_Of_Aspect_Warning (A_Id) := Warn; end Set_Restriction_No_Specification_Of_Aspect; procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is @@ -1703,15 +1574,15 @@ package body Restrict is ----------------------------------------- procedure Set_Restriction_No_Use_Of_Attribute - (N : Node_Id; - Warning : Boolean) + (N : Node_Id; + Warn : Boolean) is A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); begin No_Use_Of_Attribute_Set := True; No_Use_Of_Attribute (A_Id) := Sloc (N); - No_Use_Of_Attribute_Warning (A_Id) := Warning; + No_Use_Of_Attribute_Warning (A_Id) := Warn; end Set_Restriction_No_Use_Of_Attribute; procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is @@ -1726,15 +1597,15 @@ package body Restrict is -------------------------------------- procedure Set_Restriction_No_Use_Of_Pragma - (N : Node_Id; - Warning : Boolean) + (N : Node_Id; + Warn : Boolean) is A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N)); begin No_Use_Of_Pragma_Set := True; No_Use_Of_Pragma (A_Id) := Sloc (N); - No_Use_Of_Pragma_Warning (A_Id) := Warning; + No_Use_Of_Pragma_Warning (A_Id) := Warn; end Set_Restriction_No_Use_Of_Pragma; procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is @@ -1744,6 +1615,15 @@ package body Restrict is No_Use_Of_Pragma_Warning (A_Id) := False; end Set_Restriction_No_Use_Of_Pragma; + --------------------------- + -- Set_Global_No_Tasking -- + --------------------------- + + procedure Set_Global_No_Tasking is + begin + Global_Restriction_No_Tasking := True; + end Set_Global_No_Tasking; + ---------------------------------- -- Suppress_Restriction_Message -- ---------------------------------- |