AI12-0369 relaxes the rules for the Static_Barriers and Pure_Barriers
restrictions so that subcomponents of a protected object can be named
(subject to some restrictions) in a barrier expression. Note that one
effect of this is to undo a change that was made recently for AI12-0290.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-12 Steve Baird <ba...@adacore.com>
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
+++ 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;
------------------------------
--- gcc/ada/sem_attr.adb
+++ 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 --
--------------------------------
--- gcc/ada/sem_util.adb
+++ 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 --
--------------------------------------
--- gcc/ada/sem_util.ads
+++ 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.
