From 7c3e76b8dc4c51741e2e710aa0abe81507487f1c Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Mon, 23 Mar 2020 16:20:17 -0700 Subject: [PATCH] [Ada] Implement AI12-0369 2020-06-12 Steve Baird gcc/ada/ * sem_util.ads, sem_util.adb: Define 3 new Boolean-valued functions - Statically_Denotes_Entity, Statically_Denotes_Object, and Statically_Names_Object. The first two were taken from sem_attr.adb. The term "statically names" is defined in the Ada RM and the new function Statically_Names_Object is intended to reflect that definition, or more precisely, as described in a comment in the code, to reflect the expected future definition of that term. * sem_attr.adb: Delete functions Statically_Denotes_Object and Statically_Denotes_Entity; these two functions have been moved to package Sem_Util. Replace call to Statically_Denotes_Object with a call to Statically_Names_Object as per AI12-0217 (a binding interpretation, so no Ada_Version check). * exp_ch9.adb (Expand_Entry_Barrier.Is_Simple_Barrier): Change name of function (it was previously Is_Simple_Barrier_Name) because the function should return True in the case of a static expression; implement this requirement. Change function to include a call to Statically_Names_Object so that, for Ada_2020 and later, it will return True for appropriate subcomponent names. (Expand_Entry_Barrier.Is_Pure_Barrier): Handle N_Indexed_Component and N_Selected_Component cases by calling Statically_Names_Object. (Expand_Entry_Barrier): Reorganize to treat Simple_Barriers and Pure_Barriers more uniformly. Prevent cascaded errors. --- gcc/ada/exp_ch9.adb | 96 +++++++++++++++++------------- gcc/ada/sem_attr.adb | 89 +--------------------------- gcc/ada/sem_util.adb | 138 +++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 9 +++ 4 files changed, 205 insertions(+), 127 deletions(-) diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 83717115ee8..5162118e46c 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -5961,12 +5961,12 @@ package body Exp_Ch9 is -- If so, barrier may not be properly synchronized. function Is_Pure_Barrier (N : Node_Id) return Traverse_Result; - -- Check whether N follows the Pure_Barriers restriction. Return OK if + -- Check whether N meets the Pure_Barriers restriction. Return OK if -- so. - function Is_Simple_Barrier_Name (N : Node_Id) return Boolean; - -- Check whether entity name N denotes a component of the protected - -- object. This is used to check the Simple_Barrier restriction. + function Is_Simple_Barrier (N : Node_Id) return Boolean; + -- Check whether N meets the Simple_Barriers restriction. Return OK if + -- so. ---------------------- -- Is_Global_Entity -- @@ -6018,14 +6018,25 @@ package body Exp_Ch9 is procedure Check_Unprotected_Barrier is new Traverse_Proc (Is_Global_Entity); - ---------------------------- - -- Is_Simple_Barrier_Name -- - ---------------------------- + ----------------------- + -- Is_Simple_Barrier -- + ----------------------- - function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is + function Is_Simple_Barrier (N : Node_Id) return Boolean is Renamed : Node_Id; begin + if Is_Static_Expression (N) then + return True; + elsif Ada_Version >= Ada_2020 + and then Nkind_In (N, N_Selected_Component, N_Indexed_Component) + and then Statically_Names_Object (N) + then + -- Restriction relaxed in Ada2020 to allow statically named + -- subcomponents. + return Is_Simple_Barrier (Prefix (N)); + end if; + -- Check if the name is a component of the protected object. If -- the expander is active, the component has been transformed into a -- renaming of _object.all.component. Original_Node is needed in case @@ -6048,10 +6059,12 @@ package body Exp_Ch9 is Present (Renamed) and then Nkind (Renamed) = N_Selected_Component and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; + elsif not Is_Entity_Name (N) then + return False; else return Is_Protected_Component (Entity (N)); end if; - end Is_Simple_Barrier_Name; + end Is_Simple_Barrier; --------------------- -- Is_Pure_Barrier -- @@ -6092,7 +6105,7 @@ package body Exp_Ch9 is return Skip; when E_Variable => - if Is_Simple_Barrier_Name (N) then + if Is_Simple_Barrier (N) then return Skip; end if; @@ -6137,6 +6150,13 @@ package body Exp_Ch9 is => return OK; + when N_Indexed_Component | N_Selected_Component => + if Statically_Names_Object (N) then + return Is_Pure_Barrier (Prefix (N)); + else + return Abandon; + end if; + when N_Case_Expression_Alternative => -- do not traverse Discrete_Choices subtree if Is_Pure_Barrier (Expression (N)) /= Abandon then @@ -6195,6 +6215,12 @@ package body Exp_Ch9 is return; end if; + -- Prevent cascaded errors + + if Nkind (Cond) = N_Error then + return; + end if; + -- The body of the entry barrier must be analyzed in the context of the -- protected object, but its scope is external to it, just as any other -- unprotected version of a protected operation. The specification has @@ -6224,22 +6250,25 @@ package body Exp_Ch9 is Analyze_And_Resolve (Cond, Any_Boolean); end if; - -- Check Pure_Barriers restriction + -- Check Simple_Barriers and Pure_Barriers restrictions. + -- Note that it is safe to be calling Check_Restriction from here, even + -- though this is part of the expander, since Expand_Entry_Barrier is + -- called from Sem_Ch9 even in -gnatc mode. - if Check_Pure_Barriers (Cond) = Abandon then - Check_Restriction (Pure_Barriers, Cond); + if not Is_Simple_Barrier (Cond) then + -- flag restriction violation + Check_Restriction (Simple_Barriers, Cond); end if; - -- The Ravenscar profile restricts barriers to simple variables declared - -- within the protected object. We also allow Boolean constants, since - -- these appear in several published examples and are also allowed by - -- other compilers. + if Check_Pure_Barriers (Cond) = Abandon then + -- flag restriction violation + Check_Restriction (Pure_Barriers, Cond); - -- Note that after analysis variables in this context will be replaced - -- by the corresponding prival, that is to say a renaming of a selected - -- component of the form _Object.Var. If expansion is disabled, as - -- within a generic, we check that the entity appears in the current - -- scope. + -- Emit warning if barrier contains global entities and is thus + -- potentially unsynchronized (if Pure_Barriers restrictions + -- are met then no need to check for this). + Check_Unprotected_Barrier (Cond); + end if; if Is_Entity_Name (Cond) then Cond_Id := Entity (Cond); @@ -6260,25 +6289,12 @@ package body Exp_Ch9 is Set_Declarations (Func_Body, Empty_List); end if; - if Cond_Id = Standard_False or else Cond_Id = Standard_True then - return; - - elsif Is_Simple_Barrier_Name (Cond) then - return; - end if; + -- Note that after analysis variables in this context will be + -- replaced by the corresponding prival, that is to say a renaming + -- of a selected component of the form _Object.Var. If expansion is + -- disabled, as within a generic, we check that the entity appears in + -- the current scope. end if; - - -- It is not a boolean variable or literal, so check the restriction. - -- Note that it is safe to be calling Check_Restriction from here, even - -- though this is part of the expander, since Expand_Entry_Barrier is - -- called from Sem_Ch9 even in -gnatc mode. - - Check_Restriction (Simple_Barriers, Cond); - - -- Emit warning if barrier contains global entities and is thus - -- potentially unsynchronized. - - Check_Unprotected_Barrier (Cond); end Expand_Entry_Barrier; ------------------------------ diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index ce57b308025..86772d64a06 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -220,15 +220,6 @@ package body Sem_Attr is -- Standard_True, depending on the value of the parameter B. The -- result is marked as a static expression. - function Statically_Denotes_Object (N : Node_Id) return Boolean; - -- Predicate used to check the legality of the prefix to 'Loop_Entry and - -- 'Old, when the prefix is not an entity name. Current RM specfies that - -- the prefix must be a direct or expanded name, but it has been proposed - -- that the prefix be allowed to be a selected component that does not - -- depend on a discriminant, or an indexed component with static indices. - -- Current code for this predicate implements this more permissive - -- implementation. - ----------------------- -- Analyze_Attribute -- ----------------------- @@ -2790,7 +2781,7 @@ package body Sem_Attr is when 'E' => Error_Attr_P ("prefix of attribute % that is potentially " - & "unevaluated must denote an entity"); + & "unevaluated must statically name an entity"); when 'W' => Error_Msg_Name_1 := Aname; @@ -5056,7 +5047,7 @@ package body Sem_Attr is -- is potentially unevaluated (6.1.1 (27/3)). if Is_Potentially_Unevaluated (N) - and then not Statically_Denotes_Object (P) + and then not Statically_Names_Object (P) then Uneval_Old_Msg; @@ -7324,10 +7315,6 @@ package body Sem_Attr is -- Static is reset to False if the type or index type is not statically -- constrained. - function Statically_Denotes_Entity (N : Node_Id) return Boolean; - -- Verify that the prefix of a potentially static array attribute - -- satisfies the conditions of 4.9 (14). - ----------------------------------- -- Check_Concurrent_Discriminant -- ----------------------------------- @@ -7604,25 +7591,6 @@ package body Sem_Attr is end if; end Set_Bounds; - ------------------------------- - -- Statically_Denotes_Entity -- - ------------------------------- - - function Statically_Denotes_Entity (N : Node_Id) return Boolean is - E : Entity_Id; - - begin - if not Is_Entity_Name (N) then - return False; - else - E := Entity (N); - end if; - - return - Nkind (Parent (E)) /= N_Object_Renaming_Declaration - or else Statically_Denotes_Entity (Renamed_Object (E)); - end Statically_Denotes_Entity; - -- Start of processing for Eval_Attribute begin @@ -12066,59 +12034,6 @@ package body Sem_Attr is end if; end Set_Boolean_Result; - ------------------------------- - -- Statically_Denotes_Object -- - ------------------------------- - - function Statically_Denotes_Object (N : Node_Id) return Boolean is - Indx : Node_Id; - - begin - if Is_Entity_Name (N) then - return True; - - elsif Nkind (N) = N_Selected_Component - and then Statically_Denotes_Object (Prefix (N)) - and then Present (Entity (Selector_Name (N))) - then - declare - Sel_Id : constant Entity_Id := Entity (Selector_Name (N)); - Comp_Decl : constant Node_Id := Parent (Sel_Id); - - begin - if Depends_On_Discriminant (Sel_Id) then - return False; - - elsif Nkind (Parent (Parent (Comp_Decl))) = N_Variant then - return False; - - else - return True; - end if; - end; - - elsif Nkind (N) = N_Indexed_Component - and then Statically_Denotes_Object (Prefix (N)) - and then Is_Constrained (Etype (Prefix (N))) - then - Indx := First (Expressions (N)); - while Present (Indx) loop - if not Compile_Time_Known_Value (Indx) - or else Do_Range_Check (Indx) - then - return False; - end if; - - Next (Indx); - end loop; - - return True; - - else - return False; - end if; - end Statically_Denotes_Object; - -------------------------------- -- Stream_Attribute_Available -- -------------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 2661517e760..76afdb01577 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -26439,6 +26439,34 @@ package body Sem_Util is end if; end Static_Integer; + ------------------------------- + -- Statically_Denotes_Entity -- + ------------------------------- + function Statically_Denotes_Entity (N : Node_Id) return Boolean is + E : Entity_Id; + begin + if not Is_Entity_Name (N) then + return False; + else + E := Entity (N); + end if; + + return + Nkind (Parent (E)) /= N_Object_Renaming_Declaration + or else Is_Prival (E) + or else Statically_Denotes_Entity (Renamed_Object (E)); + end Statically_Denotes_Entity; + + ------------------------------- + -- Statically_Denotes_Object -- + ------------------------------- + + function Statically_Denotes_Object (N : Node_Id) return Boolean is + begin + return Statically_Denotes_Entity (N) + and then Is_Object_Reference (N); + end Statically_Denotes_Object; + -------------------------- -- Statically_Different -- -------------------------- @@ -26454,6 +26482,116 @@ package body Sem_Util is and then not Is_Formal (Entity (R2)); end Statically_Different; + ----------------------------- + -- Statically_Names_Object -- + ----------------------------- + function Statically_Names_Object (N : Node_Id) return Boolean is + begin + if Statically_Denotes_Object (N) then + return True; + elsif Is_Entity_Name (N) then + declare + E : constant Entity_Id := Entity (N); + begin + return Nkind (Parent (E)) = N_Object_Renaming_Declaration + and then Statically_Names_Object (Renamed_Object (E)); + end; + end if; + + case Nkind (N) is + when N_Indexed_Component => + if Is_Access_Type (Etype (Prefix (N))) then + -- treat implicit dereference same as explicit + return False; + end if; + + if not Is_Constrained (Etype (Prefix (N))) then + return False; + end if; + + declare + Indx : Node_Id := First_Index (Etype (Prefix (N))); + Expr : Node_Id := First (Expressions (N)); + Index_Subtype : Node_Id; + begin + loop + Index_Subtype := Etype (Indx); + + if not Is_Static_Subtype (Index_Subtype) then + return False; + end if; + if not Is_OK_Static_Expression (Expr) then + return False; + end if; + + declare + Index_Value : constant Uint := Expr_Value (Expr); + Low_Value : constant Uint := + Expr_Value (Type_Low_Bound (Index_Subtype)); + High_Value : constant Uint := + Expr_Value (Type_High_Bound (Index_Subtype)); + begin + if (Index_Value < Low_Value) + or (Index_Value > High_Value) + then + return False; + end if; + end; + + Next_Index (Indx); + Expr := Next (Expr); + pragma Assert ((Present (Indx) = Present (Expr)) + or else (Serious_Errors_Detected > 0)); + exit when not (Present (Indx) and Present (Expr)); + end loop; + end; + + when N_Selected_Component => + if Is_Access_Type (Etype (Prefix (N))) then + -- treat implicit dereference same as explicit + return False; + end if; + + if not Ekind_In (Entity (Selector_Name (N)), E_Component, + E_Discriminant) + then + return False; + end if; + declare + Comp : constant Entity_Id := + Original_Record_Component (Entity (Selector_Name (N))); + begin + -- In not calling Has_Discriminant_Dependent_Constraint here, + -- we are anticipating a language definition fixup. The + -- current definition of "statically names" includes the + -- wording "the selector_name names a component that does + -- not depend on a discriminant", which suggests that this + -- call should not be commented out. But it appears likely + -- that this wording will be updated to only apply to a + -- component declared in a variant part. There is no need + -- to disallow something like + -- with Post => ... and then + -- Some_Record.Some_Discrim_Dep_Array_Component'Old (I) + -- since the evaluation of the 'Old prefix cannot raise an + -- exception. If the language is not updated, then the call + -- below to H_D_C_C will need to be uncommented. + + if Is_Declared_Within_Variant (Comp) + -- or else Has_Discriminant_Dependent_Constraint (Comp) + then + return False; + end if; + end; + + when others => -- includes N_Slice, N_Explicit_Dereference + return False; + end case; + + pragma Assert (Present (Prefix (N))); + + return Statically_Names_Object (Prefix (N)); + end Statically_Names_Object; + -------------------------------------- -- Subject_To_Loop_Entry_Attributes -- -------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 34379f9405f..c096170ed89 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2909,10 +2909,19 @@ package Sem_Util is -- universal expression is returned, otherwise an error message is output -- and a value of No_Uint is returned. + function Statically_Denotes_Entity (N : Node_Id) return Boolean; + -- Return True iff N is a name that "statically denotes" an entity. + + function Statically_Denotes_Object (N : Node_Id) return Boolean; + -- Return True iff N is a name that "statically denotes" an object. + function Statically_Different (E1, E2 : Node_Id) return Boolean; -- Return True if it can be statically determined that the Expressions -- E1 and E2 refer to different objects + function Statically_Names_Object (N : Node_Id) return Boolean; + -- Return True iff N is a name that "statically names" an object. + function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean; -- Determine whether node N is a loop statement subject to at least one -- 'Loop_Entry attribute. -- 2.30.2