MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Implement new legality rules introduced in C.6(12) by AI12-0363

Browse Source 
gcc/ada/

	* doc/gnat_rm/implementation_defined_pragmas.rst (VFA): Remove uage
	restrictions in conjunction with Atomic and Aliased.
	* gnat_rm.texi: Regenerate.
	* aspects.ads (Aspect_Id): Add Aspect_Full_Access_Only.
	(Is_Representation_Aspect): Likewise.
	(Aspect_Names): Likewise.
	(Aspect_Delay): Likewise.
	* einfo.ads (Is_Atomic_Or_VFA): Rename into...
	(Is_Full_Access): ...this.
	(Is_Volatile_Full_Access): Document new usage for Full_Access_Only.
	* einfo.adb (Is_Atomic_Or_VFA): Rename into...
	(Is_Full_Access): ...this.
	* freeze.ads (Is_Atomic_VFA_Aggregate): Rename into...
	(Is_Full_Access_Aggregate): ...this.
	* freeze.adb (Is_Atomic_VFA_Aggregate): Rename into...
	(Is_Full_Access_Aggregate): ...this.  Adjust to above renaming.
	(Freeze_Array_Type): Likewise.
	(Freeze_Entity): Likewise.
	* exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Likewise.
	(Expand_Record_Aggregate): Likewise.
	* exp_ch4.adb (Expand_N_Op_Eq): Likewise.
	* exp_ch5.adb (Expand_Assign_Array): Likewise.
	* exp_ch8.adb (Evaluation_Required): Likewise.
	* layout.adb (Layout_Type): Likewise.
	(Set_Composite_Alignment): Likewise.
	* sem_aux.ads (Has_Rep_Item): Delete.
	* sem_aux.adb (Has_Rep_Item): Likewise.
	* sem_attr.adb (Resolve_Attribute) <Attribute_Access>: Implement
	new legality rules in C.6(12).
	* sem_ch12.adb (Instantiate_Object): Likewise.
	* sem_res.adb (Resolve_Actuals): Likewise.
	* sem_ch13.adb (Inherit_Delayed_Rep_Aspects): Deal with aspect
	Full_Access_Only.
	(Check_False_Aspect_For_Derived_Type): Likewise.
	(Make_Pragma_From_Boolean_Aspect): Test for the presence of Expr.
	Deal with aspect Full_Access_Only.
	(Analyze_Aspects_At_Freeze_Point): Likewise.
	(Analyze_One_Aspect): Do not set Delay_Required to true even for
	Always_Delay boolean aspects if they have no expression.  Force
	Delay_Required to true for aspect Full_Access_Only in all cases.
	Reject aspect Full_Access_Only if not in Ada 2020 mode.
	(Check_Aspect_At_End_Of_Declarations): Deal with empty expression.
	(Check_Aspect_At_Freeze_Point): Likewise.
	(Rep_Item_Entity): Delete.
	(Inherit_Aspects_At_Freeze_Point): Align handling for Bit_Order
	with that for Scalar_Storage_Order.
	* sem_prag.adb (Check_Atomic_VFA): Delete.
	(Check_VFA_Conflicts): Likewise.
	(Check_Full_Access_Only): New procedure.
	(Process_Atomic_Independent_Shared_Volatile): Call to implement
	the new legality checks in C.6(8/2) and mark the entity last.
	(Analyze_Pragma) <Pragma_Atomic_Components>: Remove obsolete check.
	* sem_util.ads (Is_Atomic_Or_VFA_Object): Rename into...
	(Is_Full_Access_Object): ...this.
	(Is_Subcomponent_Of_Atomic_Object): Rename into...
	(Is_Subcomponent_Of_Full_Access_Object): ...this.
	* sem_util.adb (Inherit_Rep_Item_Chain): Use Present_In_Rep_Item.
	(Is_Atomic_Or_VFA_Object): Rename into...
	(Is_Full_Access_Object): ...this.
	(Is_Subcomponent_Of_Atomic_Object): Rename into...
	(Is_Subcomponent_Of_Full_Access_Object): ...this and adjust.
	* snames.ads-tmpl (Name_Full_Access_Only): New name of aspect.
	* gcc-interface/decl.c (gnat_to_gnu_entity): Adjust for renaming.
	(promote_object_alignment): Likewise.
	(gnat_to_gnu_field): Likewise.  Rename local variable and use
	specific qualifier in error message for Volatile_Full_Access.
	* gcc-interface/trans.c (lvalue_required_p): Likewise.
This commit is contained in:
Eric Botcazou 2020-09-07 18:25:23 +02:00 committed by Pierre-Marie de Rodat
parent 84a5809c72
commit b120ca616f
24 changed files with 397 additions and 483 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/aspects.ads
View File

@ -188,6 +188,7 @@ package Aspects is
Aspect_Exclusive_Functions,
Aspect_Export,
Aspect_Favor_Top_Level, -- GNAT
Aspect_Full_Access_Only,
Aspect_Independent,
Aspect_Independent_Components,
Aspect_Import,
@ -554,6 +555,7 @@ package Aspects is
Aspect_Discard_Names => True,
Aspect_Export => True,
Aspect_Favor_Top_Level => False,
Aspect_Full_Access_Only => True,
Aspect_Independent => True,
Aspect_Independent_Components => True,
Aspect_Import => True,
@ -634,6 +636,7 @@ package Aspects is
Aspect_External_Name => Name_External_Name,
Aspect_External_Tag => Name_External_Tag,
Aspect_Favor_Top_Level => Name_Favor_Top_Level,
Aspect_Full_Access_Only => Name_Full_Access_Only,
Aspect_Ghost => Name_Ghost,
Aspect_Global => Name_Global,
Aspect_Implicit_Dereference => Name_Implicit_Dereference,
@ -976,6 +979,7 @@ package Aspects is
Aspect_Atomic_Components => Rep_Aspect,
Aspect_Bit_Order => Rep_Aspect,
Aspect_Component_Size => Rep_Aspect,
Aspect_Full_Access_Only => Rep_Aspect,
Aspect_Machine_Radix => Rep_Aspect,
Aspect_Object_Size => Rep_Aspect,
Aspect_Pack => Rep_Aspect,

6
gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
View File

@ -7285,12 +7285,6 @@ there is no guarantee that all the bits will be accessed if the reference
is not to the whole object; the compiler is allowed (and generally will)
access only part of the object in this case.
It is not permissible to specify ``Atomic`` and ``Volatile_Full_Access`` for
the same type or object.
It is not permissible to specify ``Volatile_Full_Access`` for a composite
(record or array) type or object that has an ``Aliased`` subcomponent.
.. _Pragma-Volatile_Function:
Pragma Volatile_Function

18
gcc/ada/einfo.adb
View File

@ -8046,15 +8046,6 @@ package body Einfo is
return Empty;
end Invariant_Procedure;
----------------------
-- Is_Atomic_Or_VFA --
----------------------
function Is_Atomic_Or_VFA (Id : E) return B is
begin
return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id);
end Is_Atomic_Or_VFA;
------------------
-- Is_Base_Type --
------------------
@ -8213,6 +8204,15 @@ package body Einfo is
return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
end Is_Finalizer;
----------------------
-- Is_Full_Access --
----------------------
function Is_Full_Access (Id : E) return B is
begin
return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id);
end Is_Full_Access;
-------------------
-- Is_Null_State --
-------------------

28
gcc/ada/einfo.ads
View File

@ -2374,12 +2374,11 @@ package Einfo is
-- In the case of private and incomplete types, this flag is set in
-- both the partial view and the full view.
-- Is_Atomic_Or_VFA (synth)
-- Is_Full_Access (synth)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if a pragma Atomic or Shared or Volatile_Full_Access
-- applies to the entity. For many purposes VFA objects should be treated
-- the same as Atomic objects, and this predicate is intended for that
-- usage. In the case of private and incomplete types, the predicate
-- variables. Set if an aspect/pragma Atomic/Shared, or an aspect/pragma
-- Volatile_Full_Access or an Ada 2020 aspect Full_Access_Only applies
-- to the entity. In the case of private and incomplete types, the flag
-- applies to both the partial view and the full view.
-- Is_Base_Type (synthesized)
@ -3418,9 +3417,10 @@ package Einfo is
-- Is_Volatile_Full_Access (Flag285)
-- Defined in all type entities, and also in constants, components, and
-- variables. Set if a pragma Volatile_Full_Access applies to the entity.
-- In the case of private and incomplete types, this flag is set in
-- both the partial view and the full view.
-- variables. Set if an aspect/pragma Volatile_Full_Access or an Ada 2020
-- aspect Full_Access_Only applies to the entity. In the case of private
-- and incomplete types, this flag is set in both the partial view and
-- the full view.
-- Is_Wrapper_Package (synthesized)
-- Defined in package entities. Indicates that the package has been
@ -5815,7 +5815,7 @@ package Einfo is
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Is_Atomic_Or_VFA (synth)
-- Is_Full_Access (synth)
-- Is_Controlled (synth)
-- Object_Size_Clause (synth)
-- Partial_Invariant_Procedure (synth)
@ -5982,7 +5982,7 @@ package Einfo is
-- Is_Volatile (Flag16)
-- Is_Volatile_Full_Access (Flag285)
-- Treat_As_Volatile (Flag41)
-- Is_Atomic_Or_VFA (synth)
-- Is_Full_Access (synth)
-- Next_Component (synth)
-- Next_Component_Or_Discriminant (synth)
@ -6036,8 +6036,8 @@ package Einfo is
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Is_Atomic_Or_VFA (synth)
-- Is_Elaboration_Target (synth)
-- Is_Full_Access (synth)
-- Size_Clause (synth)
-- E_Decimal_Fixed_Point_Type
@ -6856,8 +6856,8 @@ package Einfo is
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Is_Atomic_Or_VFA (synth)
-- Is_Elaboration_Target (synth)
-- Is_Full_Access (synth)
-- Size_Clause (synth)
-- E_Void
@ -7677,7 +7677,6 @@ package Einfo is
function Has_Null_Abstract_State (Id : E) return B;
function Has_Null_Visible_Refinement (Id : E) return B;
function Implementation_Base_Type (Id : E) return E;
function Is_Atomic_Or_VFA (Id : E) return B;
function Is_Base_Type (Id : E) return B;
function Is_Boolean_Type (Id : E) return B;
function Is_Constant_Object (Id : E) return B;
@ -7687,6 +7686,7 @@ package Einfo is
function Is_Elaboration_Target (Id : E) return B;
function Is_External_State (Id : E) return B;
function Is_Finalizer (Id : E) return B;
function Is_Full_Access (Id : E) return B;
function Is_Null_State (Id : E) return B;
function Is_Package_Or_Generic_Package (Id : E) return B;
function Is_Packed_Array (Id : E) return B;
@ -8889,7 +8889,6 @@ package Einfo is
pragma Inline (Is_Assignable);
pragma Inline (Is_Asynchronous);
pragma Inline (Is_Atomic);
pragma Inline (Is_Atomic_Or_VFA);
pragma Inline (Is_Bit_Packed_Array);
pragma Inline (Is_Called);
pragma Inline (Is_Character_Type);
@ -8940,6 +8939,7 @@ package Einfo is
pragma Inline (Is_Formal_Object);
pragma Inline (Is_Formal_Subprogram);
pragma Inline (Is_Frozen);
pragma Inline (Is_Full_Access);
pragma Inline (Is_Generic_Actual_Subprogram);
pragma Inline (Is_Generic_Actual_Type);
pragma Inline (Is_Generic_Instance);

8
gcc/ada/exp_aggr.adb
View File

@ -426,6 +426,8 @@ package body Exp_Aggr is
return Nkind (First (Assoc)) /= N_Iterated_Component_Association;
end Is_OK_Aggregate;
-- Start of processing for Aggr_Assignment_OK_For_Backend
begin
-- Back end doesn't know about <>
@ -474,7 +476,7 @@ package body Exp_Aggr is
Csiz := Component_Size (Ctyp);
Ctyp := Component_Type (Ctyp);
if Is_Atomic_Or_VFA (Ctyp) then
if Is_Full_Access (Ctyp) then
return False;
end if;
end loop;
@ -8289,13 +8291,13 @@ package body Exp_Aggr is
-- Start of processing for Expand_Record_Aggregate
begin
-- If the aggregate is to be assigned to an atomic/VFA variable, we have
-- If the aggregate is to be assigned to a full access variable, we have
-- to prevent a piecemeal assignment even if the aggregate is to be
-- expanded. We create a temporary for the aggregate, and assign the
-- temporary instead, so that the back end can generate an atomic move
-- for it.
if Is_Atomic_VFA_Aggregate (N) then
if Is_Full_Access_Aggregate (N) then
return;
-- No special management required for aggregates used to initialize

4
gcc/ada/exp_ch4.adb
View File

@ -8334,12 +8334,12 @@ package body Exp_Ch4 is
-- Where the component type is elementary we can use a block bit
-- comparison (if supported on the target) exception in the case
-- of floating-point (negative zero issues require element by
-- element comparison), and atomic/VFA types (where we must be sure
-- element comparison), and full access types (where we must be sure
-- to load elements independently) and possibly unaligned arrays.
elsif Is_Elementary_Type (Component_Type (Typl))
and then not Is_Floating_Point_Type (Component_Type (Typl))
and then not Is_Atomic_Or_VFA (Component_Type (Typl))
and then not Is_Full_Access (Component_Type (Typl))
and then not Is_Possibly_Unaligned_Object (Lhs)
and then not Is_Possibly_Unaligned_Slice (Lhs)
and then not Is_Possibly_Unaligned_Object (Rhs)

10
gcc/ada/exp_ch5.adb
View File

@ -523,11 +523,11 @@ package body Exp_Ch5 is
elsif Has_Controlled_Component (L_Type) then
Loop_Required := True;
-- If object is atomic/VFA, we cannot tolerate a loop
-- If object is full access, we cannot tolerate a loop
elsif Is_Atomic_Or_VFA_Object (Act_Lhs)
elsif Is_Full_Access_Object (Act_Lhs)
or else
Is_Atomic_Or_VFA_Object (Act_Rhs)
Is_Full_Access_Object (Act_Rhs)
then
return;
@ -536,8 +536,8 @@ package body Exp_Ch5 is
elsif Has_Atomic_Components (L_Type)
or else Has_Atomic_Components (R_Type)
or else Is_Atomic_Or_VFA (Component_Type (L_Type))
or else Is_Atomic_Or_VFA (Component_Type (R_Type))
or else Is_Full_Access (Component_Type (L_Type))
or else Is_Full_Access (Component_Type (R_Type))
then
Loop_Required := True;

4
gcc/ada/exp_ch8.adb
View File

@ -129,7 +129,7 @@ package body Exp_Ch8 is
if Is_Packed (Etype (Prefix (Nam))) then
return True;
elsif Is_Atomic_Or_VFA_Object (Prefix (Nam)) then
elsif Is_Full_Access_Object (Prefix (Nam)) then
return True;
else
@ -152,7 +152,7 @@ package body Exp_Ch8 is
then
return True;
elsif Is_Atomic_Or_VFA_Object (Prefix (Nam)) then
elsif Is_Full_Access_Object (Prefix (Nam)) then
return True;
else

30
gcc/ada/freeze.adb
View File

@ -1737,11 +1737,11 @@ package body Freeze is
end loop;
end Check_Unsigned_Type;
-----------------------------
-- Is_Atomic_VFA_Aggregate --
-----------------------------
------------------------------
-- Is_Full_Access_Aggregate --
------------------------------
function Is_Atomic_VFA_Aggregate (N : Node_Id) return Boolean is
function Is_Full_Access_Aggregate (N : Node_Id) return Boolean is
Loc : constant Source_Ptr := Sloc (N);
New_N : Node_Id;
Par : Node_Id;
@ -1765,9 +1765,9 @@ package body Freeze is
when N_Assignment_Statement =>
Typ := Etype (Name (Par));
if not Is_Atomic_Or_VFA (Typ)
if not Is_Full_Access (Typ)
and then not (Is_Entity_Name (Name (Par))
and then Is_Atomic_Or_VFA (Entity (Name (Par))))
and then Is_Full_Access (Entity (Name (Par))))
then
return False;
end if;
@ -1775,8 +1775,8 @@ package body Freeze is
when N_Object_Declaration =>
Typ := Etype (Defining_Identifier (Par));
if not Is_Atomic_Or_VFA (Typ)
and then not Is_Atomic_Or_VFA (Defining_Identifier (Par))
if not Is_Full_Access (Typ)
and then not Is_Full_Access (Defining_Identifier (Par))
then
return False;
end if;
@ -1797,7 +1797,7 @@ package body Freeze is
Set_Expression (Par, New_Occurrence_Of (Temp, Loc));
return True;
end Is_Atomic_VFA_Aggregate;
end Is_Full_Access_Aggregate;
-----------------------------------------------
-- Explode_Initialization_Compound_Statement --
@ -2639,12 +2639,12 @@ package body Freeze is
end;
end if;
-- Check for Aliased or Atomic_Components/Atomic/VFA with
-- Check for Aliased or Atomic_Components or Full Access with
-- unsuitable packing or explicit component size clause given.
if (Has_Aliased_Components (Arr)
or else Has_Atomic_Components (Arr)
or else Is_Atomic_Or_VFA (Ctyp))
or else Is_Full_Access (Ctyp))
and then
(Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
then
@ -2652,8 +2652,8 @@ package body Freeze is
procedure Complain_CS (T : String);
-- Outputs error messages for incorrect CS clause or pragma
-- Pack for aliased or atomic/VFA components (T is "aliased"
-- or "atomic/vfa");
-- Pack for aliased or full access components (T is either
-- "aliased" or "atomic" or "volatile full access");
-----------------
-- Complain_CS --
@ -5518,11 +5518,11 @@ package body Freeze is
-- than component-wise (the assignment to the temp may be done
-- component-wise, but that is harmless).
elsif Is_Atomic_Or_VFA (E)
elsif Is_Full_Access (E)
and then Nkind (Parent (E)) = N_Object_Declaration
and then Present (Expression (Parent (E)))
and then Nkind (Expression (Parent (E))) = N_Aggregate
and then Is_Atomic_VFA_Aggregate (Expression (Parent (E)))
and then Is_Full_Access_Aggregate (Expression (Parent (E)))
then
null;
end if;

4
gcc/ada/freeze.ads
View File

@ -174,8 +174,8 @@ package Freeze is
-- do not allow a size clause if the size would not otherwise be known at
-- compile time in any case.
function Is_Atomic_VFA_Aggregate (N : Node_Id) return Boolean;
-- If an atomic/VFA object is initialized with an aggregate or is assigned
function Is_Full_Access_Aggregate (N : Node_Id) return Boolean;
-- If a full access object is initialized with an aggregate or is assigned
-- an aggregate, we have to prevent a piecemeal access or assignment to the
-- object, even if the aggregate is to be expanded. We create a temporary
-- for the aggregate, and assign the temporary instead, so that the back

46
gcc/ada/gcc-interface/decl.c
View File

@ -896,13 +896,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnu_size = bitsize_unit_node;
/* If this is an object with no specified size and alignment, and
if either it is atomic or we are not optimizing alignment for
if either it is full access or we are not optimizing alignment for
space and it is composite and not an exception, an Out parameter
or a reference to another object, and the size of its type is a
constant, set the alignment to the smallest one which is not
smaller than the size, with an appropriate cap. */
if (!gnu_size && align == 0
&& (Is_Atomic_Or_VFA (gnat_entity)
&& (Is_Full_Access (gnat_entity)
|| (!Optimize_Alignment_Space (gnat_entity)
&& kind != E_Exception
&& kind != E_Out_Parameter
@ -1014,7 +1014,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
/* Now check if the type of the object allows atomic access. */
if (Is_Atomic_Or_VFA (gnat_entity))
if (Is_Full_Access (gnat_entity))
check_ok_for_atomic_type (gnu_type, gnat_entity, false);
/* If this is a renaming, avoid as much as possible to create a new
@ -2876,7 +2876,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
{
const int quals
= TYPE_QUAL_VOLATILE
| (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
| (Is_Full_Access (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
gnu_type = change_qualified_type (gnu_type, quals);
}
/* Make it artificial only if the base type was artificial too.
@ -4362,12 +4362,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
gnat_entity);
}
}
else if (Is_Atomic_Or_VFA (gnat_entity) && !gnu_size
else if (Is_Full_Access (gnat_entity) && !gnu_size
&& tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
&& integer_pow2p (TYPE_SIZE (gnu_type)))
align = MIN (BIGGEST_ALIGNMENT,
tree_to_uhwi (TYPE_SIZE (gnu_type)));
else if (Is_Atomic_Or_VFA (gnat_entity) && gnu_size
else if (Is_Full_Access (gnat_entity) && gnu_size
&& tree_fits_uhwi_p (gnu_size)
&& integer_pow2p (gnu_size))
align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size));
@ -4603,7 +4603,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
}
/* Now check if the type allows atomic access. */
if (Is_Atomic_Or_VFA (gnat_entity))
if (Is_Full_Access (gnat_entity))
check_ok_for_atomic_type (gnu_type, gnat_entity, false);
/* If this is not an unconstrained array type, set some flags. */
@ -4721,7 +4721,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
{
const int quals
= TYPE_QUAL_VOLATILE
| (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
| (Is_Full_Access (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
gnu_type = change_qualified_type (gnu_type, quals);
}
@ -5250,7 +5250,7 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
}
/* Now check if the type of the component allows atomic access. */
if (Has_Atomic_Components (gnat_array) || Is_Atomic_Or_VFA (gnat_type))
if (Has_Atomic_Components (gnat_array) || Is_Full_Access (gnat_type))
check_ok_for_atomic_type (gnu_type, gnat_array, true);
/* If the component type is a padded type made for a non-bit-packed array
@ -7105,9 +7105,9 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
const Entity_Id gnat_field_type = Etype (gnat_field);
tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
tree gnu_field_id = get_entity_name (gnat_field);
const bool is_atomic
= (Is_Atomic_Or_VFA (gnat_field) || Is_Atomic_Or_VFA (gnat_field_type));
const bool is_aliased = Is_Aliased (gnat_field);
const bool is_full_access
= (Is_Full_Access (gnat_field) || Is_Full_Access (gnat_field_type));
const bool is_independent
= (Is_Independent (gnat_field) || Is_Independent (gnat_field_type));
const bool is_volatile
@ -7122,7 +7122,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
only constraint is the implementation advice whereby only the bits of
the components should be accessed if they both start and end on byte
boundaries, but that should be guaranteed by the GCC memory model.
Note that we have some redundancies (is_atomic => is_independent,
Note that we have some redundancies (is_full_access => is_independent,
is_aliased => is_independent and is_by_ref => is_strict_alignment)
so the following formula is sufficient. */
const bool needs_strict_alignment = (is_independent || is_strict_alignment);
@ -7131,10 +7131,16 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
bool is_bitfield;
/* The qualifier to be used in messages. */
if (is_atomic)
field_s = "atomic&";
else if (is_aliased)
if (is_aliased)
field_s = "aliased&";
else if (is_full_access)
{
if (Is_Volatile_Full_Access (gnat_field)
|| Is_Volatile_Full_Access (gnat_field_type))
field_s = "volatile full access&";
else
field_s = "atomic&";
}
else if (is_independent)
field_s = "independent&";
else if (is_by_ref)
@ -7145,7 +7151,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
field_s = "&";
/* The message to be used for incompatible size. */
if (is_atomic || is_aliased)
if (is_aliased || is_full_access)
size_s = "size for %s must be ^";
else if (field_s)
size_s = "size for %s too small{, minimum allowed is ^}";
@ -7237,7 +7243,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
}
/* Now check if the type of the field allows atomic access. */
if (Is_Atomic_Or_VFA (gnat_field))
if (Is_Full_Access (gnat_field))
{
const unsigned int align
= promote_object_alignment (gnu_field_type, gnat_field);
@ -7333,7 +7339,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
/* If the size is lower than that of the type, or greater for
atomic and aliased, then error out and reset the size. */
else if ((cmp = tree_int_cst_compare (gnu_size, type_size)) < 0
|| (cmp > 0 && (is_atomic || is_aliased)))
|| (cmp > 0 && (is_aliased || is_full_access)))
{
char s[128];
snprintf (s, sizeof (s), size_s, field_s);
@ -9278,8 +9284,8 @@ promote_object_alignment (tree gnu_type, Entity_Id gnat_entity)
the NRV optimization for it. No point in jumping through all the hoops
needed in order to support BIGGEST_ALIGNMENT if we don't really have to.
So we cap to the smallest alignment that corresponds to a known efficient
memory access pattern, except for Atomic and Volatile_Full_Access. */
if (Is_Atomic_Or_VFA (gnat_entity))
memory access pattern, except for a full access entity. */
if (Is_Full_Access (gnat_entity))
{
size_cap = UINT_MAX;
align_cap = BIGGEST_ALIGNMENT;

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

@ -901,7 +901,7 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
the actual assignment might end up being done component-wise. */
return (!constant
||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
&& Is_Atomic_Or_VFA (Defining_Entity (gnat_parent)))
&& Is_Full_Access (Defining_Entity (gnat_parent)))
/* We don't use a constructor if this is a class-wide object
because the effective type of the object is the equivalent
type of the class-wide subtype and it smashes most of the
@ -916,7 +916,7 @@ lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
|| Name (gnat_parent) == gnat_node
|| (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
&& Is_Entity_Name (Name (gnat_parent))
&& Is_Atomic_Or_VFA (Entity (Name (gnat_parent)))));
&& Is_Full_Access (Entity (Name (gnat_parent)))));
case N_Unchecked_Type_Conversion:
if (!constant)

6
gcc/ada/gnat_rm.texi
View File

@ -8776,12 +8776,6 @@ there is no guarantee that all the bits will be accessed if the reference
is not to the whole object; the compiler is allowed (and generally will)
access only part of the object in this case.
It is not permissible to specify @code{Atomic} and @code{Volatile_Full_Access} for
the same type or object.
It is not permissible to specify @code{Volatile_Full_Access} for a composite
(record or array) type or object that has an @code{Aliased} subcomponent.
@node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas
@anchor{gnat_rm/implementation_defined_pragmas id56}@anchor{11a}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{11b}
@section Pragma Volatile_Function

28
gcc/ada/layout.adb
View File

@ -470,7 +470,7 @@ package body Layout is
-- For non-packed arrays set the alignment of the array to the
-- alignment of the component type if it is unknown. Skip this
-- in atomic/VFA case since a larger alignment may be needed.
-- in full access case since a larger alignment may be needed.
if Is_Array_Type (E)
and then not Is_Packed (E)
@ -479,7 +479,7 @@ package body Layout is
and then Known_Static_Component_Size (E)
and then Known_Static_Esize (Component_Type (E))
and then Component_Size (E) = Esize (Component_Type (E))
and then not Is_Atomic_Or_VFA (E)
and then not Is_Full_Access (E)
then
Set_Alignment (E, Alignment (Component_Type (E)));
end if;
@ -505,11 +505,11 @@ package body Layout is
elsif Is_Array_Type (E) then
-- For arrays that are required to be atomic/VFA, we do the same
-- processing as described above for short records, since we
-- really need to have the alignment set for the whole array.
-- For arrays that are required to be full access, we do the same
-- processing as described above for short records, since we really
-- need to have the alignment set for the whole array.
if Is_Atomic_Or_VFA (E) and then not Debug_Flag_Q then
if Is_Full_Access (E) and then not Debug_Flag_Q then
Set_Composite_Alignment (E);
end if;
@ -615,9 +615,9 @@ package body Layout is
and then Is_Record_Type (E)
and then Is_Packed (E)
then
-- No effect for record with atomic/VFA components
-- No effect for record with full access components
if Is_Atomic_Or_VFA (E) then
if Is_Full_Access (E) then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
if Is_Atomic (E) then
@ -640,7 +640,7 @@ package body Layout is
return;
end if;
-- No effect if any component is atomic/VFA or is a by-reference type
-- No effect if a component is full access or of a by-reference type
declare
Ent : Entity_Id;
@ -649,8 +649,8 @@ package body Layout is
Ent := First_Component_Or_Discriminant (E);
while Present (Ent) loop
if Is_By_Reference_Type (Etype (Ent))
or else Is_Atomic_Or_VFA (Etype (Ent))
or else Is_Atomic_Or_VFA (Ent)
or else Is_Full_Access (Etype (Ent))
or else Is_Full_Access (Ent)
then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
@ -660,7 +660,7 @@ package body Layout is
& "components present??", E);
else
Error_Msg_N
("\pragma is ignored if bolatile full access "
("\pragma is ignored if volatile full access "
& "components present??", E);
end if;
@ -756,9 +756,9 @@ package body Layout is
-- Further processing for record types only to reduce the alignment
-- set by the above processing in some specific cases. We do not
-- do this for atomic/VFA records, since we need max alignment there,
-- do this for full access records, since we need max alignment there,
if Is_Record_Type (E) and then not Is_Atomic_Or_VFA (E) then
if Is_Record_Type (E) and then not Is_Full_Access (E) then
-- For records, there is generally no point in setting alignment
-- higher than word size since we cannot do better than move by

23
gcc/ada/sem_attr.adb
View File

@ -11505,7 +11505,7 @@ package body Sem_Attr is
Set_Etype (N, Btyp);
-- Check for incorrect atomic/volatile reference (RM C.6(12))
-- Check for incorrect atomic/volatile/VFA reference (RM C.6(12))
if Attr_Id /= Attribute_Unrestricted_Access then
if Is_Atomic_Object (P)
@ -11521,6 +11521,27 @@ package body Sem_Attr is
Error_Msg_F
("access to volatile object cannot yield access-to-" &
"non-volatile type", P);
elsif Is_Volatile_Full_Access_Object (P)
and then not Is_Volatile_Full_Access (Designated_Type (Typ))
then
Error_Msg_F
("access to full access object cannot yield access-to-" &
"non-full-access type", P);
end if;
-- Check for nonatomic subcomponent of a full access object
-- in Ada 2020 (RM C.6 (12)).
if Ada_Version >= Ada_2020
and then Is_Subcomponent_Of_Full_Access_Object (P)
and then not Is_Atomic_Object (P)
then
Error_Msg_NE
("cannot have access attribute with prefix &", N, P);
Error_Msg_N
("\nonatomic subcomponent of full access object "
& "(RM C.6(12))", N);
end if;
end if;

23
gcc/ada/sem_aux.adb
View File

@ -704,29 +704,6 @@ package body Sem_Aux is
return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
end Has_Rep_Item;
function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
Item : Node_Id;
begin
pragma Assert
(Nkind (N) in N_Aspect_Specification
| N_Attribute_Definition_Clause
| N_Enumeration_Representation_Clause
| N_Pragma
| N_Record_Representation_Clause);
Item := First_Rep_Item (E);
while Present (Item) loop
if Item = N then
return True;
end if;
Next_Rep_Item (Item);
end loop;
return False;
end Has_Rep_Item;
--------------------
-- Has_Rep_Pragma --
--------------------

4
gcc/ada/sem_aux.ads
View File

@ -240,10 +240,6 @@ package Sem_Aux is
-- not inherited from its parents, if any). If found then True is returned,
-- otherwise False indicates that no matching entry was found.
function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
-- Determine whether the Rep_Item chain of arbitrary entity E contains item
-- N. N must denote a valid rep item.
function Has_Rep_Pragma
(E : Entity_Id;
Nam : Name_Id;

27
gcc/ada/sem_ch12.adb
View File

@ -11379,8 +11379,8 @@ package body Sem_Ch12 is
Note_Possible_Modification (Actual, Sure => True);
-- Check for instantiation with atomic/volatile object actual for
-- nonatomic/nonvolatile formal (RM C.6 (12)).
-- Check for instantiation with atomic/volatile/VFA object actual for
-- nonatomic/nonvolatile/nonVFA formal (RM C.6 (12)).
if Is_Atomic_Object (Actual) and then not Is_Atomic (Orig_Ftyp) then
Error_Msg_NE
@ -11394,20 +11394,29 @@ package body Sem_Ch12 is
("cannot instantiate nonvolatile formal & of mode in out",
Actual, Gen_Obj);
Error_Msg_N ("\with volatile object actual (RM C.6(12))", Actual);
elsif Is_Volatile_Full_Access_Object (Actual)
and then not Is_Volatile_Full_Access (Orig_Ftyp)
then
Error_Msg_NE
("cannot instantiate nonfull access formal & of mode in out",
Actual, Gen_Obj);
Error_Msg_N
("\with full access object actual (RM C.6(12))", Actual);
end if;
-- Check for instantiation on nonatomic subcomponent of an atomic
-- object in Ada 2020 (RM C.6 (13)).
-- Check for instantiation on nonatomic subcomponent of a full access
-- object in Ada 2020 (RM C.6 (12)).
if Ada_Version >= Ada_2020
and then Is_Subcomponent_Of_Atomic_Object (Actual)
and then Is_Subcomponent_Of_Full_Access_Object (Actual)
and then not Is_Atomic_Object (Actual)
then
Error_Msg_NE
("cannot instantiate formal & of mode in out with actual",
Actual, Gen_Obj);
Error_Msg_N
("\nonatomic subcomponent of atomic object (RM C.6(13))",
("\nonatomic subcomponent of full access object (RM C.6(12))",
Actual);
end if;
@ -12699,15 +12708,15 @@ package body Sem_Ch12 is
if Is_Volatile (A_Gen_T) and then not Is_Volatile (Act_T) then
Error_Msg_NE
("actual for& has different Volatile aspect",
Actual, A_Gen_T);
("actual for& must have Volatile aspect",
Actual, A_Gen_T);
elsif Is_Derived_Type (A_Gen_T)
and then Is_Volatile (A_Gen_T) /= Is_Volatile (Act_T)
then
Error_Msg_NE
("actual for& has different Volatile aspect",
Actual, A_Gen_T);
Actual, A_Gen_T);
end if;
-- We assume that an array type whose atomic component type

159
gcc/ada/sem_ch13.adb
View File

@ -1210,9 +1210,11 @@ package body Sem_Ch13 is
Set_Is_Volatile (E);
end if;
-- Volatile_Full_Access
-- Volatile_Full_Access (also Full_Access_Only)
when Aspect_Volatile_Full_Access =>
when Aspect_Volatile_Full_Access
| Aspect_Full_Access_Only
=>
if Is_Volatile_Full_Access (P) then
Set_Is_Volatile_Full_Access (E);
end if;
@ -1308,7 +1310,9 @@ package body Sem_Ch13 is
return;
end if;
when Aspect_Volatile_Full_Access =>
when Aspect_Volatile_Full_Access
| Aspect_Full_Access_Only
=>
if not Is_Volatile_Full_Access (Par) then
return;
end if;
@ -1326,23 +1330,28 @@ package body Sem_Ch13 is
-- Local variables
Prag : Node_Id;
Prag : Node_Id;
P_Name : Name_Id;
-- Start of processing for Make_Pragma_From_Boolean_Aspect
begin
-- Note that we know Expr is present, because for a missing Expr
-- argument, we knew it was True and did not need to delay the
-- evaluation to the freeze point.
if Is_False (Static_Boolean (Expr)) then
if Present (Expr) and then Is_False (Static_Boolean (Expr)) then
Check_False_Aspect_For_Derived_Type;
else
-- There is no Full_Access_Only pragma so use VFA instead
if A_Name = Name_Full_Access_Only then
P_Name := Name_Volatile_Full_Access;
else
P_Name := A_Name;
end if;
Prag :=
Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Ident), Chars (Ident)),
Make_Identifier (Sloc (Ident), P_Name),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ident),
Expression => New_Occurrence_Of (Ent, Sloc (Ident)))));
@ -1427,12 +1436,13 @@ package body Sem_Ch13 is
-- Analyze_Aspect_Export_Import, but is not analyzed as
-- the complete analysis must happen now.
if A_Id = Aspect_Export or else A_Id = Aspect_Import then
null;
-- Aspect Full_Access_Only must be analyzed last so that
-- aspects Volatile and Atomic, if any, are analyzed.
-- Otherwise create a corresponding pragma
else
if A_Id /= Aspect_Export
and then A_Id /= Aspect_Import
and then A_Id /= Aspect_Full_Access_Only
then
Make_Pragma_From_Boolean_Aspect (ASN);
end if;
@ -1499,6 +1509,25 @@ package body Sem_Ch13 is
Next_Rep_Item (ASN);
end loop;
-- Make a second pass for a Full_Access_Only entry
ASN := First_Rep_Item (E);
while Present (ASN) loop
if Nkind (ASN) = N_Aspect_Specification then
exit when Entity (ASN) /= E;
if Get_Aspect_Id (ASN) = Aspect_Full_Access_Only then
Make_Pragma_From_Boolean_Aspect (ASN);
Ritem := Aspect_Rep_Item (ASN);
if Present (Ritem) then
Analyze (Ritem);
end if;
end if;
end if;
Next_Rep_Item (ASN);
end loop;
-- This is where we inherit delayed rep aspects from our parent. Note
-- that if we fell out of the above loop with ASN non-empty, it means
-- we hit an aspect for an entity other than E, and it must be the
@ -2683,6 +2712,7 @@ package body Sem_Ch13 is
is
Args : List_Id := Pragma_Argument_Associations;
Aitem : Node_Id;
begin
-- We should never get here if aspect was disabled
@ -2870,23 +2900,33 @@ package body Sem_Ch13 is
case Aspect_Delay (A_Id) is
when Always_Delay =>
Delay_Required := True;
-- For Boolean aspects, do not delay if no expression
if A_Id in Boolean_Aspects | Library_Unit_Aspects then
Delay_Required := Present (Expr);
else
Delay_Required := True;
end if;
when Never_Delay =>
Delay_Required := False;
when Rep_Aspect =>
-- If expression has the form of an integer literal, then
-- do not delay, since we know the value cannot change.
-- This optimization catches most rep clause cases.
-- For Boolean aspects, do not delay if no expression except
-- for Full_Access_Only because we need to process it after
-- Volatile and Atomic, which can be independently delayed.
-- For Boolean aspects, don't delay if no expression
if A_Id in Boolean_Aspects and then No (Expr) then
if A_Id in Boolean_Aspects
and then A_Id /= Aspect_Full_Access_Only
and then No (Expr)
then
Delay_Required := False;
-- For non-Boolean aspects, don't delay if integer literal
-- For non-Boolean aspects, if the expression has the form
-- of an integer literal, then do not delay, since we know
-- the value cannot change. This optimization catches most
-- rep clause cases.
elsif A_Id not in Boolean_Aspects
and then Present (Expr)
@ -2894,7 +2934,7 @@ package body Sem_Ch13 is
then
Delay_Required := False;
-- For Alignment and various Size aspects, don't delay for
-- For Alignment and various Size aspects, do not delay for
-- an attribute reference whose prefix is Standard, for
-- example Standard'Maximum_Alignment or Standard'Word_Size.
@ -4491,6 +4531,15 @@ package body Sem_Ch13 is
goto Continue;
-- Ada 202x (AI12-0363): Full_Access_Only
elsif A_Id = Aspect_Full_Access_Only then
if Ada_Version < Ada_2020 then
Error_Msg_N
("aspect % is an Ada 202x feature", Aspect);
Error_Msg_N ("\compile with -gnat2020", Aspect);
end if;
-- Ada 202x (AI12-0075): static expression functions
elsif A_Id = Aspect_Static then
@ -4525,10 +4574,9 @@ package body Sem_Ch13 is
goto Continue;
end if;
-- Cases where we do not delay, includes all cases where the
-- expression is missing other than the above cases.
-- Cases where we do not delay
if not Delay_Required or else No (Expr) then
if not Delay_Required then
-- Exclude aspects Export and Import because their pragma
-- syntax does not map directly to a Boolean aspect.
@ -4543,8 +4591,6 @@ package body Sem_Ch13 is
Pragma_Name => Chars (Id));
end if;
Delay_Required := False;
-- In general cases, the corresponding pragma/attribute
-- definition clause will be inserted later at the freezing
-- point, and we do not need to build it now.
@ -10447,7 +10493,10 @@ package body Sem_Ch13 is
Freeze_Expr : constant Node_Id := Expression (ASN);
-- Expression from call to Check_Aspect_At_Freeze_Point.
T : constant Entity_Id := Etype (Original_Node (Freeze_Expr));
T : constant Entity_Id :=
(if Present (Freeze_Expr)
then Etype (Original_Node (Freeze_Expr))
else Empty);
-- Type required for preanalyze call. We use the original expression to
-- get the proper type, to prevent cascaded errors when the expression
-- is constant-folded.
@ -10591,12 +10640,12 @@ package body Sem_Ch13 is
Set_Parent (End_Decl_Expr, ASN);
-- In a generic context the original aspect expressions have not
-- In a generic context the original aspect expressions have not
-- been preanalyzed, so do it now. There are no conformance checks
-- to perform in this case. As before, we have to make components
-- visible for aspects that may reference them.
if No (T) then
if Present (Freeze_Expr) and then No (T) then
if A_Id = Aspect_Dynamic_Predicate
or else A_Id = Aspect_Predicate
or else A_Id = Aspect_Priority
@ -10636,7 +10685,7 @@ package body Sem_Ch13 is
elsif A_Id = Aspect_Predicate_Failure then
Preanalyze_Spec_Expression (End_Decl_Expr, Standard_String);
else
elsif Present (End_Decl_Expr) then
Preanalyze_Spec_Expression (End_Decl_Expr, T);
end if;
@ -10926,7 +10975,9 @@ package body Sem_Ch13 is
-- Do the preanalyze call
Preanalyze_Spec_Expression (Expression (ASN), T);
if Present (Expression (ASN)) then
Preanalyze_Spec_Expression (Expression (ASN), T);
end if;
end Check_Aspect_At_Freeze_Point;
-----------------------------------
@ -13129,9 +13180,6 @@ package body Sem_Ch13 is
-- specification node whose correponding pragma (if any) is present in
-- the Rep Item chain of the entity it has been specified to.
function Rep_Item_Entity (Rep_Item : Node_Id) return Entity_Id;
-- Return the entity for which Rep_Item is specified
--------------------------------------------------
-- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item --
--------------------------------------------------
@ -13142,26 +13190,10 @@ package body Sem_Ch13 is
begin
return
Nkind (Rep_Item) = N_Pragma
or else Present_In_Rep_Item
(Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
or else
Present_In_Rep_Item (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item));
end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item;
---------------------
-- Rep_Item_Entity --
---------------------
function Rep_Item_Entity (Rep_Item : Node_Id) return Entity_Id is
begin
if Nkind (Rep_Item) = N_Aspect_Specification then
return Entity (Rep_Item);
else
pragma Assert
(Nkind (Rep_Item) in N_Attribute_Definition_Clause | N_Pragma);
return Entity (Name (Rep_Item));
end if;
end Rep_Item_Entity;
-- Start of processing for Inherit_Aspects_At_Freeze_Point
begin
@ -13287,10 +13319,12 @@ package body Sem_Ch13 is
Set_Treat_As_Volatile (Typ);
end if;
-- Volatile_Full_Access
-- Volatile_Full_Access and Full_Access_Only
if not Has_Rep_Item (Typ, Name_Volatile_Full_Access, False)
and then Has_Rep_Pragma (Typ, Name_Volatile_Full_Access)
and then not Has_Rep_Item (Typ, Name_Full_Access_Only, False)
and then (Has_Rep_Item (Typ, Name_Volatile_Full_Access)
or else Has_Rep_Item (Typ, Name_Full_Access_Only))
and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
(Get_Rep_Item (Typ, Name_Volatile_Full_Access))
then
@ -13347,23 +13381,20 @@ package body Sem_Ch13 is
-- Bit_Order
if Is_Record_Type (Typ) then
if Is_Record_Type (Typ) and then Typ = Bas_Typ then
if not Has_Rep_Item (Typ, Name_Bit_Order, False)
and then Has_Rep_Item (Typ, Name_Bit_Order)
then
Set_Reverse_Bit_Order (Bas_Typ,
Reverse_Bit_Order (Rep_Item_Entity
(Get_Rep_Item (Typ, Name_Bit_Order))));
Reverse_Bit_Order
(Implementation_Base_Type (Etype (Bas_Typ))));
end if;
end if;
-- Scalar_Storage_Order
-- Note: the aspect is specified on a first subtype, but recorded
-- in a flag of the base type!
if (Is_Record_Type (Typ) or else Is_Array_Type (Typ))
and then Typ = Bas_Typ
and then Typ = Bas_Typ
then
-- For a type extension, always inherit from parent; otherwise
-- inherit if no default applies. Note: we do not check for

374
gcc/ada/sem_prag.adb
View File

@ -3944,10 +3944,6 @@ package body Sem_Prag is
procedure Check_At_Most_N_Arguments (N : Nat);
-- Check there are no more than N arguments present
procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean);
-- Apply legality checks to type or object E subject to an Atomic aspect
-- in Ada 2020 (RM C.6(13)) or to a Volatile_Full_Access aspect.
procedure Check_Component
(Comp : Node_Id;
UU_Typ : Entity_Id;
@ -5627,165 +5623,6 @@ package body Sem_Prag is
end if;
end Check_At_Most_N_Arguments;
------------------------
-- Check_Atomic_VFA --
------------------------
procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean) is
Aliased_Subcomponent : exception;
-- Exception raised if an aliased subcomponent is found in E
Independent_Subcomponent : exception;
-- Exception raised if an independent subcomponent is found in E
procedure Check_Subcomponents (Typ : Entity_Id);
-- Apply checks to subcomponents for Atomic and Volatile_Full_Access
-------------------------
-- Check_Subcomponents --
-------------------------
procedure Check_Subcomponents (Typ : Entity_Id) is
Comp : Entity_Id;
begin
if Is_Array_Type (Typ) then
Comp := Component_Type (Typ);
-- For Atomic we accept any atomic subcomponents
if not VFA
and then (Has_Atomic_Components (Typ)
or else Is_Atomic (Comp))
then
null;
-- Give an error if the components are aliased
elsif Has_Aliased_Components (Typ)
or else Is_Aliased (Comp)
then
raise Aliased_Subcomponent;
-- For VFA we accept non-aliased VFA subcomponents
elsif VFA
and then Is_Volatile_Full_Access (Comp)
then
null;
-- Give an error if the components are independent
elsif Has_Independent_Components (Typ)
or else Is_Independent (Comp)
then
raise Independent_Subcomponent;
end if;
-- Recurse on the component type
Check_Subcomponents (Comp);
-- Note: Has_Aliased_Components, like Has_Atomic_Components,
-- and Has_Independent_Components, applies only to arrays.
-- However, this flag does not have a corresponding pragma, so
-- perhaps it should be possible to apply it to record types as
-- well. Should this be done ???
elsif Is_Record_Type (Typ) then
-- It is possible to have an aliased discriminant, so they
-- must be checked along with normal components.
Comp := First_Component_Or_Discriminant (Typ);
while Present (Comp) loop
-- For Atomic we accept any atomic subcomponents
if not VFA
and then (Is_Atomic (Comp)
or else Is_Atomic (Etype (Comp)))
then
null;
-- Give an error if the component is aliased
elsif Is_Aliased (Comp)
or else Is_Aliased (Etype (Comp))
then
raise Aliased_Subcomponent;
-- For VFA we accept non-aliased VFA subcomponents
elsif VFA
and then (Is_Volatile_Full_Access (Comp)
or else Is_Volatile_Full_Access (Etype (Comp)))
then
null;
-- Give an error if the component is independent
elsif Is_Independent (Comp)
or else Is_Independent (Etype (Comp))
then
raise Independent_Subcomponent;
end if;
-- Recurse on the component type
Check_Subcomponents (Etype (Comp));
Next_Component_Or_Discriminant (Comp);
end loop;
end if;
end Check_Subcomponents;
Typ : Entity_Id;
begin
-- Fetch the type in case we are dealing with an object or component
if Is_Type (E) then
Typ := E;
else
pragma Assert (Is_Object (E)
or else
Nkind (Declaration_Node (E)) = N_Component_Declaration);
Typ := Etype (E);
end if;
-- Check all the subcomponents of the type recursively, if any
Check_Subcomponents (Typ);
exception
when Aliased_Subcomponent =>
if VFA then
Error_Pragma
("cannot apply Volatile_Full_Access with aliased "
& "subcomponent ");
else
Error_Pragma
("cannot apply Atomic with aliased subcomponent "
& "(RM C.6(13))");
end if;
when Independent_Subcomponent =>
if VFA then
Error_Pragma
("cannot apply Volatile_Full_Access with independent "
& "subcomponent ");
else
Error_Pragma
("cannot apply Atomic with independent subcomponent "
& "(RM C.6(13))");
end if;
when others =>
raise Program_Error;
end Check_Atomic_VFA;
---------------------
-- Check_Component --
---------------------
@ -7371,8 +7208,9 @@ package body Sem_Prag is
------------------------------------------------
procedure Process_Atomic_Independent_Shared_Volatile is
procedure Check_VFA_Conflicts (Ent : Entity_Id);
-- Check that Volatile_Full_Access and VFA do not conflict
procedure Check_Full_Access_Only (Ent : Entity_Id);
-- Apply legality checks to type or object Ent subject to the
-- Full_Access_Only aspect in Ada 2020 (RM C.6(8.2)).
procedure Mark_Component_Or_Object (Ent : Entity_Id);
-- Appropriately set flags on the given entity, either an array or
@ -7389,15 +7227,68 @@ package body Sem_Prag is
-- full access arrays. Note: this is necessary for derived types.
-------------------------
-- Check_VFA_Conflicts --
-- Check_Full_Access_Only --
-------------------------
procedure Check_VFA_Conflicts (Ent : Entity_Id) is
Comp : Entity_Id;
procedure Check_Full_Access_Only (Ent : Entity_Id) is
Typ : Entity_Id;
VFA_And_Atomic : Boolean := False;
-- Set True if both VFA and Atomic present
Full_Access_Subcomponent : exception;
-- Exception raised if a full access subcomponent is found
Generic_Type_Subcomponent : exception;
-- Exception raised if a subcomponent with generic type is found
procedure Check_Subcomponents (Typ : Entity_Id);
-- Apply checks to subcomponents recursively
-------------------------
-- Check_Subcomponents --
-------------------------
procedure Check_Subcomponents (Typ : Entity_Id) is
Comp : Entity_Id;
begin
if Is_Array_Type (Typ) then
Comp := Component_Type (Typ);
if Has_Atomic_Components (Typ)
or else Is_Full_Access (Comp)
then
raise Full_Access_Subcomponent;
elsif Is_Generic_Type (Comp) then
raise Generic_Type_Subcomponent;
end if;
-- Recurse on the component type
Check_Subcomponents (Comp);
elsif Is_Record_Type (Typ) then
Comp := First_Component_Or_Discriminant (Typ);
while Present (Comp) loop
if Is_Full_Access (Comp)
or else Is_Full_Access (Etype (Comp))
then
raise Full_Access_Subcomponent;
elsif Is_Generic_Type (Etype (Comp)) then
raise Generic_Type_Subcomponent;
end if;
-- Recurse on the component type
Check_Subcomponents (Etype (Comp));
Next_Component_Or_Discriminant (Comp);
end loop;
end if;
end Check_Subcomponents;
-- Start of processing for Check_Full_Access_Only
begin
-- Fetch the type in case we are dealing with an object or
@ -7413,49 +7304,29 @@ package body Sem_Prag is
Typ := Etype (Ent);
end if;
-- Check Atomic and VFA used together
if Prag_Id = Pragma_Volatile_Full_Access
or else Is_Volatile_Full_Access (Ent)
then
if Prag_Id = Pragma_Atomic
or else Prag_Id = Pragma_Shared
or else Is_Atomic (Ent)
then
VFA_And_Atomic := True;
elsif Is_Array_Type (Typ) then
VFA_And_Atomic := Has_Atomic_Components (Typ);
-- Note: Has_Atomic_Components is not used below, as this flag
-- represents the pragma of the same name, Atomic_Components,
-- which only applies to arrays.
elsif Is_Record_Type (Typ) then
-- Attributes cannot be applied to discriminants, only
-- regular record components.
Comp := First_Component (Typ);
while Present (Comp) loop
if Is_Atomic (Comp)
or else Is_Atomic (Typ)
then
VFA_And_Atomic := True;
exit;
end if;
Next_Component (Comp);
end loop;
end if;
if VFA_And_Atomic then
Error_Pragma
("cannot have Volatile_Full_Access and Atomic for same "
& "entity");
end if;
if not Is_Volatile (Ent) and then not Is_Volatile (Typ) then
Error_Pragma
("cannot have Full_Access_Only without Volatile/Atomic "
& "(RM C.6(8.2))");
return;
end if;
end Check_VFA_Conflicts;
-- Check all the subcomponents of the type recursively, if any
Check_Subcomponents (Typ);
exception
when Full_Access_Subcomponent =>
Error_Pragma
("cannot have Full_Access_Only with full access subcomponent "
& "(RM C.6(8.2))");
when Generic_Type_Subcomponent =>
Error_Pragma
("cannot have Full_Access_Only with subcomponent of generic "
& "type (RM C.6(8.2))");
end Check_Full_Access_Only;
------------------------------
-- Mark_Component_Or_Object --
@ -7611,6 +7482,7 @@ package body Sem_Prag is
end if;
E := Entity (E_Arg);
Decl := Declaration_Node (E);
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
@ -7621,9 +7493,43 @@ package body Sem_Prag is
Check_Duplicate_Pragma (E);
-- Check appropriateness of the entity
-- Check the constraints of Full_Access_Only in Ada 2020. Note that
-- they do not apply to GNAT's Volatile_Full_Access because 1) this
-- aspect subsumes the Volatile aspect and 2) nesting is supported
-- for this aspect and the outermost enclosing VFA object prevails.
Decl := Declaration_Node (E);
-- Note also that we used to forbid specifying both Atomic and VFA on
-- the same type or object, but the restriction has been lifted in
-- light of the semantics of Full_Access_Only and Atomic in Ada 2020.
if Prag_Id = Pragma_Volatile_Full_Access
and then From_Aspect_Specification (N)
and then
Get_Aspect_Id (Corresponding_Aspect (N)) = Aspect_Full_Access_Only
then
Check_Full_Access_Only (E);
end if;
-- The following check is only relevant when SPARK_Mode is on as
-- this is not a standard Ada legality rule. Pragma Volatile can
-- only apply to a full type declaration or an object declaration
-- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
-- untagged derived types that are rewritten as subtypes of their
-- respective root types.
if SPARK_Mode = On
and then Prag_Id = Pragma_Volatile
and then Nkind (Original_Node (Decl)) not in
N_Full_Type_Declaration |
N_Formal_Type_Declaration |
N_Object_Declaration |
N_Single_Protected_Declaration |
N_Single_Task_Declaration
then
Error_Pragma_Arg
("argument of pragma % must denote a full type or object "
& "declaration", Arg1);
end if;
-- Deal with the case where the pragma/attribute is applied to a type
@ -7656,41 +7562,6 @@ package body Sem_Prag is
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
-- Check that Volatile_Full_Access and Atomic do not conflict
Check_VFA_Conflicts (E);
-- Check for the application of Atomic or Volatile_Full_Access to
-- an entity that has [nonatomic] aliased, or else specified to be
-- independently addressable, subcomponents.
if (Prag_Id = Pragma_Atomic and then Ada_Version >= Ada_2020)
or else Prag_Id = Pragma_Volatile_Full_Access
then
Check_Atomic_VFA (E, VFA => Prag_Id = Pragma_Volatile_Full_Access);
end if;
-- The following check is only relevant when SPARK_Mode is on as
-- this is not a standard Ada legality rule. Pragma Volatile can
-- only apply to a full type declaration or an object declaration
-- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
-- untagged derived types that are rewritten as subtypes of their
-- respective root types.
if SPARK_Mode = On
and then Prag_Id = Pragma_Volatile
and then Nkind (Original_Node (Decl)) not in
N_Full_Type_Declaration |
N_Formal_Type_Declaration |
N_Object_Declaration |
N_Single_Protected_Declaration |
N_Single_Task_Declaration
then
Error_Pragma_Arg
("argument of pragma % must denote a full type or object "
& "declaration", Arg1);
end if;
end Process_Atomic_Independent_Shared_Volatile;
-------------------------------------------
@ -13591,11 +13462,6 @@ package body Sem_Prag is
-- Atomic implies both Independent and Volatile
if Prag_Id = Pragma_Atomic_Components then
if Ada_Version >= Ada_2020 then
Check_Atomic_VFA
(Component_Type (Etype (E)), VFA => False);
end if;
Set_Has_Atomic_Components (E);
Set_Has_Independent_Components (E);
end if;

22
gcc/ada/sem_res.adb
View File

@ -4726,7 +4726,7 @@ package body Sem_Res is
end if;
end if;
-- Check illegal cases of atomic/volatile actual (RM C.6(12,13))
-- Check illegal cases of atomic/volatile/VFA actual (RM C.6(12))
if (Is_By_Reference_Type (Etype (F)) or else Is_Aliased (F))
and then Comes_From_Source (N)
@ -4748,17 +4748,29 @@ package body Sem_Res is
A, F);
Error_Msg_N
("\which is passed by reference (RM C.6(12))", A);
elsif Is_Volatile_Full_Access_Object (A)
and then not Is_Volatile_Full_Access (Etype (F))
then
Error_Msg_NE
("cannot pass full access object to nonfull access "
& "formal&", A, F);
Error_Msg_N
("\which is passed by reference (RM C.6(12))", A);
end if;
-- Check for nonatomic subcomponent of a full access object
-- in Ada 2020 (RM C.6 (12)).
if Ada_Version >= Ada_2020
and then Is_Subcomponent_Of_Atomic_Object (A)
and then Is_Subcomponent_Of_Full_Access_Object (A)
and then not Is_Atomic_Object (A)
then
Error_Msg_N
("cannot pass nonatomic subcomponent of atomic object",
A);
("cannot pass nonatomic subcomponent of full access "
& "object", A);
Error_Msg_NE
("\to formal & which is passed by reference (RM C.6(13))",
("\to formal & which is passed by reference (RM C.6(12))",
A, F);
end if;
end if;

35
gcc/ada/sem_util.adb
View File

@ -14566,7 +14566,7 @@ package body Sem_Util is
-- ^
-- Item
if Has_Rep_Item (From_Typ, Next_Item) then
if Present_In_Rep_Item (From_Typ, Next_Item) then
exit;
end if;
@ -15187,15 +15187,6 @@ package body Sem_Util is
and then (Is_Atomic (Id) or else Is_Atomic (Etype (Id)));
end Is_Atomic_Object_Entity;
-----------------------------
-- Is_Atomic_Or_VFA_Object --
-----------------------------
function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is
begin
return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N);
end Is_Atomic_Or_VFA_Object;
-----------------------------
-- Is_Attribute_Loop_Entry --
-----------------------------
@ -16797,6 +16788,15 @@ package body Sem_Util is
return R;
end Is_Fixed_Model_Number;
-----------------------------
-- Is_Full_Access_Object --
-----------------------------
function Is_Full_Access_Object (N : Node_Id) return Boolean is
begin
return Is_Atomic_Object (N) or else Is_Volatile_Full_Access_Object (N);
end Is_Full_Access_Object;
-------------------------------
-- Is_Fully_Initialized_Type --
-------------------------------
@ -19746,11 +19746,12 @@ package body Sem_Util is
and then Has_All_Static_Actuals (Call);
end Is_Static_Function_Call;
----------------------------------------
-- Is_Subcomponent_Of_Atomic_Object --
----------------------------------------
-------------------------------------------
-- Is_Subcomponent_Of_Full_Access_Object --
-------------------------------------------
function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean is
function Is_Subcomponent_Of_Full_Access_Object (N : Node_Id) return Boolean
is
R : Node_Id;
begin
@ -19763,19 +19764,19 @@ package body Sem_Util is
-- 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
if Is_Full_Access (Designated_Type (Etype (R))) then
return True;
end if;
else
if Is_Atomic_Object (R) then
if Is_Full_Access_Object (R) then
return True;
end if;
end if;
end loop;
return False;
end Is_Subcomponent_Of_Atomic_Object;
end Is_Subcomponent_Of_Full_Access_Object;
---------------------------------------
-- Is_Subprogram_Contract_Annotation --

12
gcc/ada/sem_util.ads
View File

@ -1670,10 +1670,6 @@ package Sem_Util is
-- Determine whether arbitrary node N denotes a reference to an atomic
-- object as per RM C.6(7) and the crucial remark in RM C.6(8).
function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a reference to an object
-- which is either atomic or Volatile_Full_Access.
function Is_Attribute_Loop_Entry (N : Node_Id) return Boolean;
-- Determine whether node N denotes attribute 'Loop_Entry
@ -1909,6 +1905,10 @@ package Sem_Util is
-- Returns True iff the number U is a model number of the fixed-point type
-- T, i.e. if it is an exact multiple of Small.
function Is_Full_Access_Object (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a reference to a full access
-- object as per Ada 2020 RM C.6(8.2).
function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean;
-- Typ is a type entity. This function returns true if this type is fully
-- initialized, meaning that an object of the type is fully initialized.
@ -2173,9 +2173,9 @@ package Sem_Util is
-- meaning that the name of the call denotes a static function
-- and all of the call's actual parameters are given by static expressions.
function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean;
function Is_Subcomponent_Of_Full_Access_Object (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a reference to a subcomponent
-- of an atomic object as per RM C.6(7).
-- of a full access object as per RM C.6(7).
function Is_Subprogram_Contract_Annotation (Item : Node_Id) return Boolean;
-- Determine whether aspect specification or pragma Item is one of the

1
gcc/ada/snames.ads-tmpl
View File

@ -143,6 +143,7 @@ package Snames is
Name_Disable_Controlled : constant Name_Id := N + $;
Name_Dynamic_Predicate : constant Name_Id := N + $;
Name_Exclusive_Functions : constant Name_Id := N + $;
Name_Full_Access_Only : constant Name_Id := N + $;
Name_Integer_Literal : constant Name_Id := N + $;
Name_Real_Literal : constant Name_Id := N + $;
Name_Relaxed_Initialization : constant Name_Id := N + $;