mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-12-05 09:44:10 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

[Ada] Fix couple of oversights in the implementation of AI12-0128

Browse Source 
2019-12-16  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* sem_prag.adb (Atomic_Components): Remove local variable and
	fix consistency issues.  Call Component_Type on the Etype of E.
	(Independent_Components): Remove local variable.
	* sem_util.adb (Is_Subcomponent_Of_Atomic_Object): Properly deal
	with prefixes that are access values.
	* gcc-interface/trans.c (atomic_acces_t): New enumeral type.
	(node_is_atomic) <N_Indexed_Component>: Test the prefix.
	(node_has_volatile_full_access): Rename into...
	(node_is_volatile_full_access): ...this.
	(node_is_component): New predicare.
	(gnat_strip_type_conversion): Delete.
	(outer_atomic_access_required_p): Likewise.
	(atomic_access_required_p): Rename into...
	(get_atomic_access): ...this.  Implement the 3 different semantics
	of Atomic and Volatile_Full_Access.
	(simple_atomic_access_required_p): New predicate.
	(Call_to_gnu): Remove outer_atomic_access parameter and change the
	type of atomic_access parameter to atomic_acces_t.  Replace call to
	atomic_access_required_p with simple_atomic_access_required_p for
	the in direction and call get_atomic_access for the out direction
	instead of [outer_]atomic_access_required_p.
	(lhs_or_actual_p): Constify local variables.
	(present_in_lhs_or_actual_p): Likewise.
	(gnat_to_gnu) <N_Identifier>: Replace call to atomic_access_required_p
	with simple_atomic_access_required_p.
	<N_Explicit_Dereference>: Likewise.
	<N_Indexed_Component>: Likewise.
	<N_Selected_Component>: Likewise.
	<N_Assignment_Statement>: Call get_atomic_access for the name instead
	of [outer_]atomic_access_required_p.  Adjust call to Call_to_gnu.
	<N_Function_Call>: Adjust call to Call_to_gnu.
	(get_controlling_type): Fix typo in comment.

From-SVN: r279427
This commit is contained in:
Eric Botcazou 2019-12-16 10:34:17 +00:00 committed by Pierre-Marie de Rodat
parent 2f31b36248
commit 17a98a3dbb
4 changed files with 206 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
gcc/ada/ChangeLog
View File

@ -1,3 +1,38 @@
2019-12-16 Eric Botcazou <ebotcazou@adacore.com>
* sem_prag.adb (Atomic_Components): Remove local variable and
fix consistency issues. Call Component_Type on the Etype of E.
(Independent_Components): Remove local variable.
* sem_util.adb (Is_Subcomponent_Of_Atomic_Object): Properly deal
with prefixes that are access values.
* gcc-interface/trans.c (atomic_acces_t): New enumeral type.
(node_is_atomic) <N_Indexed_Component>: Test the prefix.
(node_has_volatile_full_access): Rename into...
(node_is_volatile_full_access): ...this.
(node_is_component): New predicare.
(gnat_strip_type_conversion): Delete.
(outer_atomic_access_required_p): Likewise.
(atomic_access_required_p): Rename into...
(get_atomic_access): ...this. Implement the 3 different semantics
of Atomic and Volatile_Full_Access.
(simple_atomic_access_required_p): New predicate.
(Call_to_gnu): Remove outer_atomic_access parameter and change the
type of atomic_access parameter to atomic_acces_t. Replace call to
atomic_access_required_p with simple_atomic_access_required_p for
the in direction and call get_atomic_access for the out direction
instead of [outer_]atomic_access_required_p.
(lhs_or_actual_p): Constify local variables.
(present_in_lhs_or_actual_p): Likewise.
(gnat_to_gnu) <N_Identifier>: Replace call to atomic_access_required_p
with simple_atomic_access_required_p.
<N_Explicit_Dereference>: Likewise.
<N_Indexed_Component>: Likewise.
<N_Selected_Component>: Likewise.
<N_Assignment_Statement>: Call get_atomic_access for the name instead
of [outer_]atomic_access_required_p. Adjust call to Call_to_gnu.
<N_Function_Call>: Adjust call to Call_to_gnu.
(get_controlling_type): Fix typo in comment.
2019-12-16 Eric Botcazou <ebotcazou@adacore.com>
* fe.h (Ada_Version_Type): New typedef.

281
gcc/ada/gcc-interface/trans.c
View File

@ -3976,7 +3976,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
return gnu_result;
}
/* This page implements a form of Named Return Value optimization modelled
/* This page implements a form of Named Return Value optimization modeled
on the C++ optimization of the same name. The main difference is that
we disregard any semantical considerations when applying it here, the
counterpart being that we don't try to apply it to semantically loaded
@ -4792,7 +4792,13 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
rest_of_subprog_body_compilation (gnu_subprog_decl);
}
/* Return true if GNAT_NODE references an Atomic entity. */
/* The type of an atomic access. */
typedef enum { NOT_ATOMIC, SIMPLE_ATOMIC, OUTER_ATOMIC } atomic_acces_t;
/* Return true if GNAT_NODE references an Atomic entity. This is modeled on
the Is_Atomic_Object predicate of the front-end, but additionally handles
explicit dereferences. */
static bool
node_is_atomic (Node_Id gnat_node)
@ -4809,17 +4815,14 @@ node_is_atomic (Node_Id gnat_node)
return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
case N_Selected_Component:
gnat_entity = Entity (Selector_Name (gnat_node));
return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
return Is_Atomic (Etype (gnat_node))
|| Is_Atomic (Entity (Selector_Name (gnat_node)));
case N_Indexed_Component:
if (Has_Atomic_Components (Etype (Prefix (gnat_node))))
return true;
if (Is_Entity_Name (Prefix (gnat_node))
&& Has_Atomic_Components (Entity (Prefix (gnat_node))))
return true;
/* ... fall through ... */
return Is_Atomic (Etype (gnat_node))
|| Has_Atomic_Components (Etype (Prefix (gnat_node)))
|| (Is_Entity_Name (Prefix (gnat_node))
&& Has_Atomic_Components (Entity (Prefix (gnat_node))));
case N_Explicit_Dereference:
return Is_Atomic (Etype (gnat_node));
@ -4831,10 +4834,12 @@ node_is_atomic (Node_Id gnat_node)
return false;
}
/* Return true if GNAT_NODE references a Volatile_Full_Access entity. */
/* Return true if GNAT_NODE references a Volatile_Full_Access entity. This is
modeled on the Is_VFA_Object predicate of the front-end, but additionally
handles explicit dereferences. */
static bool
node_has_volatile_full_access (Node_Id gnat_node)
node_is_volatile_full_access (Node_Id gnat_node)
{
Entity_Id gnat_entity;
@ -4849,9 +4854,8 @@ node_has_volatile_full_access (Node_Id gnat_node)
|| Is_Volatile_Full_Access (Etype (gnat_entity));
case N_Selected_Component:
gnat_entity = Entity (Selector_Name (gnat_node));
return Is_Volatile_Full_Access (gnat_entity)
|| Is_Volatile_Full_Access (Etype (gnat_entity));
return Is_Volatile_Full_Access (Etype (gnat_node))
|| Is_Volatile_Full_Access (Entity (Selector_Name (gnat_node)));
case N_Indexed_Component:
case N_Explicit_Dereference:
@ -4864,73 +4868,42 @@ node_has_volatile_full_access (Node_Id gnat_node)
return false;
}
/* Strip any type conversion on GNAT_NODE and return the result. */
/* Return true if GNAT_NODE references a component of a larger object. */
static Node_Id
gnat_strip_type_conversion (Node_Id gnat_node)
static inline bool
node_is_component (Node_Id gnat_node)
{
Node_Kind kind = Nkind (gnat_node);
if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
gnat_node = Expression (gnat_node);
return gnat_node;
const Node_Kind k = Nkind (gnat_node);
return
(k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice);
}
/* Return true if GNAT_NODE requires outer atomic access, i.e. atomic access
of an object of which GNAT_NODE is a component. */
/* Compute whether GNAT_NODE requires atomic access and set TYPE to the type
of access and SYNC according to the associated synchronization setting.
static bool
outer_atomic_access_required_p (Node_Id gnat_node)
We implement 3 different semantics of atomicity in this function:
1. the Ada 95/2005/2012 semantics of the Atomic aspect/pragma,
2. the Ada 2020 semantics of the Atomic aspect/pragma,
3. the semantics of the Volatile_Full_Access GNAT aspect/pragma.
They are mutually exclusive and the FE should have rejected conflicts. */
static void
get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync)
{
gnat_node = gnat_strip_type_conversion (gnat_node);
while (true)
{
switch (Nkind (gnat_node))
{
case N_Identifier:
case N_Expanded_Name:
if (No (Renamed_Object (Entity (gnat_node))))
return false;
gnat_node
= gnat_strip_type_conversion (Renamed_Object (Entity (gnat_node)));
break;
case N_Indexed_Component:
case N_Selected_Component:
case N_Slice:
gnat_node = gnat_strip_type_conversion (Prefix (gnat_node));
if (node_has_volatile_full_access (gnat_node))
return true;
break;
default:
return false;
}
}
gcc_unreachable ();
}
/* Return true if GNAT_NODE requires atomic access and set SYNC according to
the associated synchronization setting. */
static bool
atomic_access_required_p (Node_Id gnat_node, bool *sync)
{
const Node_Id gnat_parent = Parent (gnat_node);
Node_Id gnat_parent, gnat_temp;
unsigned char attr_id;
bool as_a_whole = true;
/* First, scan the parent to find out cases where the flag is irrelevant. */
/* First, scan the parent to filter out irrelevant cases. */
gnat_parent = Parent (gnat_node);
switch (Nkind (gnat_parent))
{
case N_Attribute_Reference:
attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
/* Do not mess up machine code insertions. */
if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
return false;
goto not_atomic;
/* Nothing to do if we are the prefix of an attribute, since we do not
want an atomic access for things like 'Size. */
@ -4940,45 +4913,86 @@ atomic_access_required_p (Node_Id gnat_node, bool *sync)
case N_Reference:
/* The N_Reference node is like an attribute. */
if (Prefix (gnat_parent) == gnat_node)
return false;
break;
case N_Indexed_Component:
case N_Selected_Component:
case N_Slice:
/* If we are the prefix, then the access is only partial. */
if (Prefix (gnat_parent) == gnat_node)
as_a_whole = false;
goto not_atomic;
break;
case N_Object_Renaming_Declaration:
/* Nothing to do for the identifier in an object renaming declaration,
the renaming itself does not need atomic access. */
return false;
goto not_atomic;
default:
break;
}
/* Then, scan the node to find the atomic object. */
gnat_node = gnat_strip_type_conversion (gnat_node);
/* Now strip any type conversion from GNAT_NODE. */
if (Nkind (gnat_node) == N_Type_Conversion
|| Nkind (gnat_node) == N_Unchecked_Type_Conversion)
gnat_node = Expression (gnat_node);
/* For Atomic itself, only reads and updates of the object as a whole require
atomic access (RM C.6 (15)). But for Volatile_Full_Access, all reads and
updates require atomic access. */
if (!(as_a_whole && node_is_atomic (gnat_node))
&& !node_has_volatile_full_access (gnat_node))
return false;
/* Up to Ada 2012, for Atomic itself, only reads and updates of the object as
a whole require atomic access (RM C.6(15)). But, starting with Ada 2020,
reads of or writes to a nonatomic subcomponent of the object also require
atomic access (RM C.6(19)). */
if (node_is_atomic (gnat_node))
{
bool as_a_whole = true;
/* If an outer atomic access will also be required, it cancels this one. */
if (outer_atomic_access_required_p (gnat_node))
return false;
/* If we are the prefix of the parent, then the access is partial. */
for (gnat_temp = gnat_node, gnat_parent = Parent (gnat_temp);
node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_temp;
gnat_temp = gnat_parent, gnat_parent = Parent (gnat_temp))
if (Ada_Version < Ada_2020 || node_is_atomic (gnat_parent))
goto not_atomic;
else
as_a_whole = false;
*sync = Atomic_Sync_Required (gnat_node);
/* We consider that partial accesses are not sequential actions and,
therefore, do not require synchronization. */
*type = SIMPLE_ATOMIC;
*sync = as_a_whole ? Atomic_Sync_Required (gnat_node) : false;
return;
}
return true;
/* Look for an outer atomic access of a nonatomic subcomponent. Note that,
for VFA, we do this before looking at the node itself because we need to
access the outermost VFA object atomically, unlike for Atomic where it is
the innermost atomic object (RM C.6(19)). */
for (gnat_temp = gnat_node;
node_is_component (gnat_temp);
gnat_temp = Prefix (gnat_temp))
if ((Ada_Version >= Ada_2020 && node_is_atomic (Prefix (gnat_temp)))
|| node_is_volatile_full_access (Prefix (gnat_temp)))
{
*type = OUTER_ATOMIC;
*sync = false;
return;
}
/* Unlike Atomic, accessing a VFA object always requires atomic access. */
if (node_is_volatile_full_access (gnat_node))
{
*type = SIMPLE_ATOMIC;
*sync = false;
return;
}
not_atomic:
*type = NOT_ATOMIC;
*sync = false;
}
/* Return true if GNAT_NODE requires simple atomic access and, if so, set SYNC
according to the associated synchronization setting. */
static inline bool
simple_atomic_access_required_p (Node_Id gnat_node, bool *sync)
{
atomic_acces_t type;
get_atomic_access (gnat_node, &type, sync);
return type == SIMPLE_ATOMIC;
}
/* Create a temporary variable with PREFIX and TYPE, and return it. */
static tree
@ -5013,14 +5027,13 @@ create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
If GNU_TARGET is non-null, this must be a function call on the RHS of a
N_Assignment_Statement and the result is to be placed into that object.
If OUTER_ATOMIC_ACCESS is true, then the assignment to GNU_TARGET must be a
load-modify-store sequence. Otherwise, if ATOMIC_ACCESS is true, then the
assignment to GNU_TARGET must be atomic. If, in addition, ATOMIC_SYNC is
true, then the assignment to GNU_TARGET requires atomic synchronization. */
ATOMIC_ACCESS is the type of atomic access to be used for the assignment
to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment
to GNU_TARGET requires atomic synchronization. */
static tree
Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
bool outer_atomic_access, bool atomic_access, bool atomic_sync)
atomic_acces_t atomic_access, bool atomic_sync)
{
const bool function_call = (Nkind (gnat_node) == N_Function_Call);
const bool returning_value = (function_call && !gnu_target);
@ -5047,7 +5060,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
bool pushed_binding_level = false;
Entity_Id gnat_formal;
Node_Id gnat_actual;
bool sync;
atomic_acces_t aa_type;
bool aa_sync;
gcc_assert (FUNC_OR_METHOD_TYPE_P (gnu_subprog_type));
@ -5346,8 +5360,8 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
if (is_true_formal_parm
&& !is_by_ref_formal_parm
&& Ekind (gnat_formal) != E_Out_Parameter
&& atomic_access_required_p (gnat_actual, &sync))
gnu_actual = build_atomic_load (gnu_actual, sync);
&& simple_atomic_access_required_p (gnat_actual, &aa_sync))
gnu_actual = build_atomic_load (gnu_actual, aa_sync);
/* If this was a procedure call, we may not have removed any padding.
So do it here for the part we will use as an input, if any. */
@ -5647,16 +5661,19 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
}
get_atomic_access (gnat_actual, &aa_type, &aa_sync);
/* If an outer atomic access is required for an actual parameter,
build the load-modify-store sequence. */
if (outer_atomic_access_required_p (gnat_actual))
if (aa_type == OUTER_ATOMIC)
gnu_result
= build_load_modify_store (gnu_actual, gnu_result, gnat_node);
/* Or else, if simple atomic access is required, build the atomic
/* Or else, if a simple atomic access is required, build the atomic
store. */
else if (atomic_access_required_p (gnat_actual, &sync))
gnu_result = build_atomic_store (gnu_actual, gnu_result, sync);
else if (aa_type == SIMPLE_ATOMIC)
gnu_result
= build_atomic_store (gnu_actual, gnu_result, aa_sync);
/* Otherwise build a regular assignment. */
else
@ -5708,10 +5725,10 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
op_code = MODIFY_EXPR;
/* Use the required method to move the result to the target. */
if (outer_atomic_access)
if (atomic_access == OUTER_ATOMIC)
gnu_call
= build_load_modify_store (gnu_target, gnu_call, gnat_node);
else if (atomic_access)
else if (atomic_access == SIMPLE_ATOMIC)
gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync);
else
gnu_call
@ -6631,8 +6648,8 @@ common:
static bool
lhs_or_actual_p (Node_Id gnat_node)
{
Node_Id gnat_parent = Parent (gnat_node);
Node_Kind kind = Nkind (gnat_parent);
const Node_Id gnat_parent = Parent (gnat_node);
const Node_Kind kind = Nkind (gnat_parent);
if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
return true;
@ -6653,12 +6670,10 @@ lhs_or_actual_p (Node_Id gnat_node)
static bool
present_in_lhs_or_actual_p (Node_Id gnat_node)
{
Node_Kind kind;
if (lhs_or_actual_p (gnat_node))
return true;
kind = Nkind (Parent (gnat_node));
const Node_Kind kind = Nkind (Parent (gnat_node));
if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
&& lhs_or_actual_p (Parent (gnat_node)))
@ -6747,7 +6762,8 @@ gnat_to_gnu (Node_Id gnat_node)
tree gnu_result_type = void_type_node;
tree gnu_expr, gnu_lhs, gnu_rhs;
Node_Id gnat_temp;
bool sync = false;
atomic_acces_t aa_type;
bool aa_sync;
/* Save node number for error message and set location information. */
Current_Error_Node = gnat_node;
@ -6819,9 +6835,9 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
/* If atomic access is required on the RHS, build the atomic load. */
if (atomic_access_required_p (gnat_node, &sync)
if (simple_atomic_access_required_p (gnat_node, &aa_sync)
&& !present_in_lhs_or_actual_p (gnat_node))
gnu_result = build_atomic_load (gnu_result, sync);
gnu_result = build_atomic_load (gnu_result, aa_sync);
break;
case N_Integer_Literal:
@ -7153,9 +7169,9 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
/* If atomic access is required on the RHS, build the atomic load. */
if (atomic_access_required_p (gnat_node, &sync)
if (simple_atomic_access_required_p (gnat_node, &aa_sync)
&& !present_in_lhs_or_actual_p (gnat_node))
gnu_result = build_atomic_load (gnu_result, sync);
gnu_result = build_atomic_load (gnu_result, aa_sync);
break;
case N_Indexed_Component:
@ -7230,9 +7246,9 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* If atomic access is required on the RHS, build the atomic load. */
if (atomic_access_required_p (gnat_node, &sync)
if (simple_atomic_access_required_p (gnat_node, &aa_sync)
&& !present_in_lhs_or_actual_p (gnat_node))
gnu_result = build_atomic_load (gnu_result, sync);
gnu_result = build_atomic_load (gnu_result, aa_sync);
}
break;
@ -7308,9 +7324,9 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* If atomic access is required on the RHS, build the atomic load. */
if (atomic_access_required_p (gnat_node, &sync)
if (simple_atomic_access_required_p (gnat_node, &aa_sync)
&& !present_in_lhs_or_actual_p (gnat_node))
gnu_result = build_atomic_load (gnu_result, sync);
gnu_result = build_atomic_load (gnu_result, aa_sync);
}
break;
@ -7811,14 +7827,10 @@ gnat_to_gnu (Node_Id gnat_node)
N_Raise_Storage_Error);
else if (Nkind (Expression (gnat_node)) == N_Function_Call)
{
bool outer_atomic_access
= outer_atomic_access_required_p (Name (gnat_node));
bool atomic_access
= !outer_atomic_access
&& atomic_access_required_p (Name (gnat_node), &sync);
get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
gnu_result
= Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
outer_atomic_access, atomic_access, sync);
aa_type, aa_sync);
}
else
{
@ -7848,14 +7860,17 @@ gnat_to_gnu (Node_Id gnat_node)
gigi_checking_assert (!Do_Range_Check (gnat_expr));
get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
/* If an outer atomic access is required on the LHS, build the load-
modify-store sequence. */
if (outer_atomic_access_required_p (Name (gnat_node)))
if (aa_type == OUTER_ATOMIC)
gnu_result = build_load_modify_store (gnu_lhs, gnu_rhs, gnat_node);
/* Or else, if atomic access is required, build the atomic store. */
else if (atomic_access_required_p (Name (gnat_node), &sync))
gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, sync);
/* Or else, if a simple atomic access is required, build the atomic
store. */
else if (aa_type == SIMPLE_ATOMIC)
gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, aa_sync);
/* Or else, use memset when the conditions are met. This has already
been validated by Aggr_Assignment_OK_For_Backend in the front-end
@ -8176,7 +8191,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Function_Call:
case N_Procedure_Call_Statement:
gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE,
false, false, false);
NOT_ATOMIC, false);
break;
/************************/
@ -8476,7 +8491,7 @@ gnat_to_gnu (Node_Id gnat_node)
/* If the operand is going to end up in memory,
mark it addressable. Note that we don't test
allows_mem like in the input case below; this
is modelled on the C front-end. */
is modeled on the C front-end. */
if (!allows_reg)
{
output = remove_conversions (output, false);
@ -11123,7 +11138,7 @@ get_elaboration_procedure (void)
static Entity_Id
get_controlling_type (Entity_Id subprog)
{
/* This is modelled on Expand_Interface_Thunk. */
/* This is modeled on Expand_Interface_Thunk. */
Entity_Id controlling_type = Etype (First_Formal (subprog));
if (Is_Access_Type (controlling_type))
controlling_type = Directly_Designated_Type (controlling_type);

21
gcc/ada/sem_prag.adb
View File

@ -14039,7 +14039,6 @@ package body Sem_Prag is
D : Node_Id;
E : Entity_Id;
E_Id : Node_Id;
K : Node_Kind;
begin
Check_Ada_83_Warning;
@ -14068,18 +14067,19 @@ package body Sem_Prag is
end if;
D := Declaration_Node (E);
K := Nkind (D);
if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E))
or else
((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
and then Nkind (D) = N_Object_Declaration
(Nkind (D) = N_Object_Declaration
and then (Ekind (E) = E_Constant
or else
Ekind (E) = E_Variable)
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition)
then
-- The flag is set on the object, or on the base type
-- The flag is set on the base type, or on the object
if Nkind (D) /= N_Object_Declaration then
if Nkind (D) = N_Full_Type_Declaration then
E := Base_Type (E);
end if;
@ -14087,7 +14087,8 @@ package body Sem_Prag is
if Prag_Id = Pragma_Atomic_Components then
if Ada_Version >= Ada_2020 then
Check_Atomic_VFA (Component_Type (E), VFA => False);
Check_Atomic_VFA
(Component_Type (Etype (E)), VFA => False);
end if;
Set_Has_Atomic_Components (E);
Set_Has_Independent_Components (E);
@ -17963,7 +17964,6 @@ package body Sem_Prag is
D : Node_Id;
E_Id : Node_Id;
E : Entity_Id;
K : Node_Kind;
begin
Check_Ada_83_Warning;
@ -18030,11 +18030,10 @@ package body Sem_Prag is
end if;
D := Declaration_Node (E);
K := Nkind (D);
-- The flag is set on the base type, or on the object
if K = N_Full_Type_Declaration
if Nkind (D) = N_Full_Type_Declaration
and then (Is_Array_Type (E) or else Is_Record_Type (E))
then
Set_Has_Independent_Components (Base_Type (E));

15
gcc/ada/sem_util.adb
View File

@ -17890,11 +17890,22 @@ package body Sem_Util is
begin
R := Get_Referenced_Object (N);
while Nkind_In (R, N_Indexed_Component, N_Selected_Component, N_Slice)
loop
R := Get_Referenced_Object (Prefix (R));
if Is_Atomic_Object (R) then
return True;
-- If the prefix is an access value, only the designated type matters
if Is_Access_Type (Etype (R)) then
if Is_Atomic (Designated_Type (Etype (R))) then
return True;
end if;
else
if Is_Atomic (Etype (R)) or else Is_Atomic_Object (R) then
return True;
end if;
end if;
end loop;