From: Eric Botcazou Date: Mon, 7 Sep 2020 16:25:23 +0000 (+0200) Subject: [Ada] Implement new legality rules introduced in C.6(12) by AI12-0363 X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b120ca616fc820e352a19523dae34f5c53bfe859;p=gcc.git [Ada] Implement new legality rules introduced in C.6(12) by AI12-0363 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) : 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) : 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. --- diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 72f3638c3b2..1470efebab9 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -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, diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index a5aff66c47b..e1e6853e02c 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -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 diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 6cae8e9a6bd..f39b3bcd1a1 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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 -- ------------------- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index bb5ab07790e..be195ab23c5 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index a3b03c38e4f..469777f1b09 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index da2c629896d..4d5486057aa 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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) diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 55766451dfa..85b5bb8c38a 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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; diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 630d62f459e..9f4c65c89ba 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 2118307406d..f3abba1538d 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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; diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index 2d70ec65693..448d1edb14f 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -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 diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index cd0a50b2083..4e6dc84beea 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -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; diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 6babbd41d52..059e1a4f677 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -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) diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index d4016aaa223..e1a5568549f 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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 diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 6fde60a5012..ad808495e60 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 7a488a77203..104796f1f80 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index f4d7f6f1edb..36fd6ad0987 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -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 -- -------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 3db68104891..1d820458a36 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 16b42bd0cc1..06b3bec3b5c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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 diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 27faac2de12..1a80b3aafec 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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; - - -- Otherwise create a corresponding pragma + -- Aspect Full_Access_Only must be analyzed last so that + -- aspects Volatile and Atomic, if any, are analyzed. - 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, don't delay if no expression + -- 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. - 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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 3c9c748f9af..4edb67dff33 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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); + 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; - -- 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. + -- Check all the subcomponents of the type recursively, if any - elsif Is_Record_Type (Typ) then - -- Attributes cannot be applied to discriminants, only - -- regular record components. + Check_Subcomponents (Typ); - Comp := First_Component (Typ); - while Present (Comp) loop - if Is_Atomic (Comp) - or else Is_Atomic (Typ) - then - VFA_And_Atomic := True; + exception + when Full_Access_Subcomponent => + Error_Pragma + ("cannot have Full_Access_Only with full access subcomponent " + & "(RM C.6(8.2))"); - exit; - end if; + when Generic_Type_Subcomponent => + Error_Pragma + ("cannot have Full_Access_Only with subcomponent of generic " + & "type (RM C.6(8.2))"); - 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; - end if; - end Check_VFA_Conflicts; + 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; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3a3c93dd3c1..33206eb685e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d4a259f2a1d..5557328062f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2b49a44db7a..f38d0f5ad1c 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index abdd00b4c7f..a9fd7c5c9f5 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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 + $;