diff options
author | Eric Botcazou <ebotcazou@adacore.com> | 2019-12-16 10:33:08 +0000 |
---|---|---|
committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2019-12-16 10:33:08 +0000 |
commit | d6c7e020cffa8570c77e80da755c8963034657fb (patch) | |
tree | 3775aa45161e641db67e8c155cf2b3a4d137d437 /gcc | |
parent | 070fa48b0a4fbdc754e18962d586f41cc263dad7 (diff) | |
download | gcc-d6c7e020cffa8570c77e80da755c8963034657fb.zip gcc-d6c7e020cffa8570c77e80da755c8963034657fb.tar.gz gcc-d6c7e020cffa8570c77e80da755c8963034657fb.tar.bz2 |
[Ada] Implement new legality rules introduced in C.6(13) by AI12-0128
2019-12-16 Eric Botcazou <ebotcazou@adacore.com>
gcc/ada/
* doc/gnat_rm/implementation_defined_pragmas.rst (VFA): Document
extension of the no-aliasing rule to any subcomponent.
* freeze.adb (Freeze_Object_Declaration): Small comment tweak.
(Freeze_Record_Type): Do not deal with delayed aspect
specifications for components here but...
(Freeze_Entity): ...here instead.
* sem_ch12.adb (Instantiate_Object): Improve wording of errors
given for legality rules in C.6(12) and implement the new rule
in C.6(13).
* sem_res.adb (Resolve_Actuals): Likewise.
* sem_prag.adb (Check_Atomic_VFA): New procedure implementing
the new legality rules in C.6(13).
(Process_Atomic_Independent_Shared_Volatile): Call
Check_Atomic_VFA to check the legality rules. Factor out code
marking types into...
(Mark_Type): ...this new procedure.
(Check_VFA_Conflicts): Do not check the legality rules here.
(Pragma_Atomic_Components): Call Check_Atomic_VFA on component
type.
* sem_util.ads (Is_Subcomponent_Of_Atomic_Object): Declare.
* sem_util.adb (Is_Subcomponent_Of_Atomic_Object): New
predicate.
* gnat_rm.texi: Regenerate.
From-SVN: r279412
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/ChangeLog | 26 | ||||
-rw-r--r-- | gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst | 2 | ||||
-rw-r--r-- | gcc/ada/freeze.adb | 99 | ||||
-rw-r--r-- | gcc/ada/gnat_rm.texi | 2 | ||||
-rw-r--r-- | gcc/ada/sem_ch12.adb | 31 | ||||
-rw-r--r-- | gcc/ada/sem_prag.adb | 349 | ||||
-rw-r--r-- | gcc/ada/sem_res.adb | 22 | ||||
-rw-r--r-- | gcc/ada/sem_util.adb | 20 | ||||
-rw-r--r-- | gcc/ada/sem_util.ads | 4 |
9 files changed, 394 insertions, 161 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1fea353..58517e6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2019-12-16 Eric Botcazou <ebotcazou@adacore.com> + + * doc/gnat_rm/implementation_defined_pragmas.rst (VFA): Document + extension of the no-aliasing rule to any subcomponent. + * freeze.adb (Freeze_Object_Declaration): Small comment tweak. + (Freeze_Record_Type): Do not deal with delayed aspect + specifications for components here but... + (Freeze_Entity): ...here instead. + * sem_ch12.adb (Instantiate_Object): Improve wording of errors + given for legality rules in C.6(12) and implement the new rule + in C.6(13). + * sem_res.adb (Resolve_Actuals): Likewise. + * sem_prag.adb (Check_Atomic_VFA): New procedure implementing + the new legality rules in C.6(13). + (Process_Atomic_Independent_Shared_Volatile): Call + Check_Atomic_VFA to check the legality rules. Factor out code + marking types into... + (Mark_Type): ...this new procedure. + (Check_VFA_Conflicts): Do not check the legality rules here. + (Pragma_Atomic_Components): Call Check_Atomic_VFA on component + type. + * sem_util.ads (Is_Subcomponent_Of_Atomic_Object): Declare. + * sem_util.adb (Is_Subcomponent_Of_Atomic_Object): New + predicate. + * gnat_rm.texi: Regenerate. + 2019-12-13 Gary Dismukes <dismukes@adacore.com> * doc/gnat_rm/implementation_defined_pragmas.rst: Minor diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst index 6d0bdd8..42087ad 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst @@ -7443,7 +7443,7 @@ 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 at least one ``Aliased`` component. +(record or array) type or object that has an ``Aliased`` subcomponent. .. _Pragma-Volatile_Function: diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index add4153..de5f8f7 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3569,7 +3569,8 @@ package body Freeze is Error_Msg_N ("\??use explicit size clause to set size", E); end if; - -- Declaring a too-big array in disabled ghost code is OK + -- Declaring too big an array in disabled ghost code is OK + if Is_Array_Type (Typ) and then not Is_Ignored_Ghost_Entity (E) then Check_Large_Modular_Array (Typ); end if; @@ -3998,11 +3999,6 @@ package body Freeze is -- clause (used to warn about useless Bit_Order pragmas, and also -- to detect cases where Implicit_Packing may have an effect). - Rec_Pushed : Boolean := False; - -- Set True if the record type scope Rec has been pushed on the scope - -- stack. Needed for the analysis of delayed aspects specified to the - -- components of Rec. - Sized_Component_Total_RM_Size : Uint := Uint_0; -- Accumulates total RM_Size values of all sized components. Used -- for processing of Implicit_Packing. @@ -4141,47 +4137,6 @@ package body Freeze is -- Start of processing for Freeze_Record_Type begin - -- Deal with delayed aspect specifications for components. The - -- analysis of the aspect is required to be delayed to the freeze - -- point, thus we analyze the pragma or attribute definition - -- clause in the tree at this point. We also analyze the aspect - -- specification node at the freeze point when the aspect doesn't - -- correspond to pragma/attribute definition clause. - - Comp := First_Entity (Rec); - while Present (Comp) loop - if Ekind (Comp) = E_Component - and then Has_Delayed_Aspects (Comp) - then - if not Rec_Pushed then - Push_Scope (Rec); - Rec_Pushed := True; - - -- The visibility to the discriminants must be restored in - -- order to properly analyze the aspects. - - if Has_Discriminants (Rec) then - Install_Discriminants (Rec); - end if; - end if; - - Analyze_Aspects_At_Freeze_Point (Comp); - end if; - - Next_Entity (Comp); - end loop; - - -- Pop the scope if Rec scope has been pushed on the scope stack - -- during the delayed aspect analysis process. - - if Rec_Pushed then - if Has_Discriminants (Rec) then - Uninstall_Discriminants (Rec); - end if; - - Pop_Scope; - end if; - -- Freeze components and embedded subtypes Comp := First_Entity (Rec); @@ -5492,6 +5447,56 @@ package body Freeze is -- In addition, a derived type may have inherited aspects that were -- delayed in the parent, so these must also be captured now. + -- For a record type, we deal with the delayed aspect specifications on + -- components first, which is consistent with the non-delayed case and + -- makes it possible to have a single processing to detect conflicts. + + if Is_Record_Type (E) then + declare + Comp : Entity_Id; + + Rec_Pushed : Boolean := False; + -- Set True if the record type E has been pushed on the scope + -- stack. Needed for the analysis of delayed aspects specified + -- to the components of Rec. + + begin + Comp := First_Entity (E); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Has_Delayed_Aspects (Comp) + then + if not Rec_Pushed then + Push_Scope (E); + Rec_Pushed := True; + + -- The visibility to the discriminants must be restored + -- in order to properly analyze the aspects. + + if Has_Discriminants (E) then + Install_Discriminants (E); + end if; + end if; + + Analyze_Aspects_At_Freeze_Point (Comp); + end if; + + Next_Entity (Comp); + end loop; + + -- Pop the scope if Rec scope has been pushed on the scope stack + -- during the delayed aspect analysis process. + + if Rec_Pushed then + if Has_Discriminants (E) then + Uninstall_Discriminants (E); + end if; + + Pop_Scope; + end if; + end; + end if; + if Has_Delayed_Aspects (E) or else May_Inherit_Delayed_Rep_Aspects (E) then diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index f7c2923..6476591 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -8949,7 +8949,7 @@ It is not permissible to specify @code{Atomic} and @code{Volatile_Full_Access} f 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 at least one @code{Aliased} component. +(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{11e}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{11f} diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 6932368..d405297 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -11111,19 +11111,36 @@ package body Sem_Ch12 is Note_Possible_Modification (Actual, Sure => True); - -- Check for instantiation of atomic/volatile actual for - -- non-atomic/volatile formal (RM C.6 (12)). + -- Check for instantiation with atomic/volatile object actual for + -- nonatomic/nonvolatile formal (RM C.6 (12)). if Is_Atomic_Object (Actual) and then not Is_Atomic (Orig_Ftyp) then - Error_Msg_N - ("cannot instantiate non-atomic formal object " - & "with atomic actual", Actual); + Error_Msg_NE + ("cannot instantiate nonatomic formal & of mode in out", + Actual, Gen_Obj); + Error_Msg_N ("\with atomic object actual (RM C.6(12))", Actual); elsif Is_Volatile_Object (Actual) and then not Is_Volatile (Orig_Ftyp) then + Error_Msg_NE + ("cannot instantiate nonvolatile formal & of mode in out", + Actual, Gen_Obj); + Error_Msg_N ("\with volatile 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)). + + if Ada_Version >= Ada_2020 + and then Is_Subcomponent_Of_Atomic_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 - ("cannot instantiate non-volatile formal object " - & "with volatile actual", Actual); + ("\nonatomic subcomponent of atomic object (RM C.6(13))", + Actual); end if; -- Formal in-parameter diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index db4b1b4..1b07a84 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3927,6 +3927,10 @@ 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; @@ -5680,6 +5684,165 @@ 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 -- --------------------- @@ -7260,13 +7423,16 @@ package body Sem_Prag is procedure Process_Atomic_Independent_Shared_Volatile is procedure Check_VFA_Conflicts (Ent : Entity_Id); - -- Apply additional checks for the GNAT pragma Volatile_Full_Access + -- Check that Volatile_Full_Access and VFA do not conflict procedure Mark_Component_Or_Object (Ent : Entity_Id); - -- Appropriately set flags on the given entity (either an array or + -- Appropriately set flags on the given entity, either an array or -- record component, or an object declaration) according to the -- current pragma. + procedure Mark_Type (Ent : Entity_Id); + -- Appropriately set flags on the given entity, a type + procedure Set_Atomic_VFA (Ent : Entity_Id); -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if -- no explicit alignment was given, set alignment to unknown, since @@ -7282,10 +7448,7 @@ package body Sem_Prag is Typ : Entity_Id; VFA_And_Atomic : Boolean := False; - -- Set True if atomic component present - - VFA_And_Aliased : Boolean := False; - -- Set True if aliased component present + -- Set True if both VFA and Atomic present begin -- Fetch the type in case we are dealing with an object or @@ -7343,48 +7506,6 @@ package body Sem_Prag is & "entity"); end if; end if; - - -- Check for the application of VFA to an entity that has aliased - -- components. - - if Prag_Id = Pragma_Volatile_Full_Access then - if Is_Array_Type (Typ) - and then Has_Aliased_Components (Typ) - then - VFA_And_Aliased := True; - - -- 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 - if Is_Aliased (Comp) - or else Is_Aliased (Etype (Comp)) - then - VFA_And_Aliased := True; - Check_SPARK_05_Restriction - ("aliased is not allowed", Comp); - - exit; - end if; - - Next_Component_Or_Discriminant (Comp); - end loop; - end if; - - if VFA_And_Aliased then - Error_Pragma - ("cannot apply Volatile_Full_Access (aliased component " - & "present)"); - end if; - end if; end Check_VFA_Conflicts; ------------------------------ @@ -7432,6 +7553,66 @@ package body Sem_Prag is end if; end Mark_Component_Or_Object; + --------------- + -- Mark_Type -- + --------------- + + procedure Mark_Type (Ent : Entity_Id) is + begin + -- Attribute belongs on the base type. If the view of the type is + -- currently private, it also belongs on the underlying type. + + if Prag_Id = Pragma_Atomic + or else Prag_Id = Pragma_Shared + or else Prag_Id = Pragma_Volatile_Full_Access + then + Set_Atomic_VFA (Ent); + Set_Atomic_VFA (Base_Type (Ent)); + Set_Atomic_VFA (Underlying_Type (Ent)); + end if; + + -- Atomic/Shared/Volatile_Full_Access imply Independent + + if Prag_Id /= Pragma_Volatile then + Set_Is_Independent (Ent); + Set_Is_Independent (Base_Type (Ent)); + Set_Is_Independent (Underlying_Type (Ent)); + + if Prag_Id = Pragma_Independent then + Record_Independence_Check (N, Base_Type (Ent)); + end if; + end if; + + -- Atomic/Shared/Volatile_Full_Access imply Volatile + + if Prag_Id /= Pragma_Independent then + Set_Is_Volatile (Ent); + Set_Is_Volatile (Base_Type (Ent)); + Set_Is_Volatile (Underlying_Type (Ent)); + + Set_Treat_As_Volatile (Ent); + Set_Treat_As_Volatile (Underlying_Type (Ent)); + end if; + + -- Apply Volatile to the composite type's individual components, + -- (RM C.6(8/3)). + + if Prag_Id = Pragma_Volatile + and then Is_Record_Type (Etype (Ent)) + then + declare + Comp : Entity_Id; + begin + Comp := First_Component (Ent); + while Present (Comp) loop + Mark_Component_Or_Object (Comp); + + Next_Component (Comp); + end loop; + end; + end if; + end Mark_Type; + -------------------- -- Set_Atomic_VFA -- -------------------- @@ -7494,58 +7675,7 @@ package body Sem_Prag is Check_First_Subtype (Arg1); end if; - -- Attribute belongs on the base type. If the view of the type is - -- currently private, it also belongs on the underlying type. - - if Prag_Id = Pragma_Atomic - or else Prag_Id = Pragma_Shared - or else Prag_Id = Pragma_Volatile_Full_Access - then - Set_Atomic_VFA (E); - Set_Atomic_VFA (Base_Type (E)); - Set_Atomic_VFA (Underlying_Type (E)); - end if; - - -- Atomic/Shared/Volatile_Full_Access imply Independent - - if Prag_Id /= Pragma_Volatile then - Set_Is_Independent (E); - Set_Is_Independent (Base_Type (E)); - Set_Is_Independent (Underlying_Type (E)); - - if Prag_Id = Pragma_Independent then - Record_Independence_Check (N, Base_Type (E)); - end if; - end if; - - -- Atomic/Shared/Volatile_Full_Access imply Volatile - - if Prag_Id /= Pragma_Independent then - Set_Is_Volatile (E); - Set_Is_Volatile (Base_Type (E)); - Set_Is_Volatile (Underlying_Type (E)); - - Set_Treat_As_Volatile (E); - Set_Treat_As_Volatile (Underlying_Type (E)); - end if; - - -- Apply Volatile to the composite type's individual components, - -- (RM C.6(8/3)). - - if Prag_Id = Pragma_Volatile - and then Is_Record_Type (Etype (E)) - then - declare - Comp : Entity_Id; - begin - Comp := First_Component (E); - while Present (Comp) loop - Mark_Component_Or_Object (Comp); - - Next_Component (Comp); - end loop; - end; - end if; + Mark_Type (E); -- Deal with the case where the pragma/attribute applies to a -- component or object declaration. @@ -7559,15 +7689,27 @@ package body Sem_Prag is end if; Mark_Component_Or_Object (E); + + -- In other cases give an error + else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; - -- Perform the checks needed to assure the proper use of the GNAT - -- pragma Volatile_Full_Access. + -- 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 @@ -13944,6 +14086,9 @@ 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 (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 1c5ae36..2628a5a 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4715,7 +4715,7 @@ package body Sem_Res is end if; end if; - -- Check bad case of atomic/volatile argument (RM C.6(12)) + -- Check illegal cases of atomic/volatile actual (RM C.6(12,13)) if (Is_By_Reference_Type (Etype (F)) or else Is_Aliased (F)) and then Comes_From_Source (N) @@ -4724,14 +4724,30 @@ package body Sem_Res is and then not Is_Atomic (Etype (F)) then Error_Msg_NE - ("cannot pass atomic argument to non-atomic formal&", + ("cannot pass atomic object to nonatomic formal&", A, F); + Error_Msg_N + ("\which is passed by reference (RM C.6(12))", A); elsif Is_Volatile_Object (A) and then not Is_Volatile (Etype (F)) then Error_Msg_NE - ("cannot pass volatile argument to non-volatile formal&", + ("cannot pass volatile object to nonvolatile formal&", + A, F); + Error_Msg_N + ("\which is passed by reference (RM C.6(12))", A); + end if; + + if Ada_Version >= Ada_2020 + and then Is_Subcomponent_Of_Atomic_Object (A) + and then not Is_Atomic_Object (A) + then + Error_Msg_N + ("cannot pass nonatomic subcomponent of atomic object", + A); + Error_Msg_NE + ("\to formal & which is passed by reference (RM C.6(13))", A, F); end if; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 30a2273..7ed717d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17844,6 +17844,26 @@ package body Sem_Util is or else Nkind (N) = N_Procedure_Call_Statement; end Is_Statement; + ---------------------------------------- + -- Is_Subcomponent_Of_Atomic_Object -- + ---------------------------------------- + + function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean is + R : Node_Id; + + begin + R := Get_Referenced_Object (N); + while Nkind_In (R, N_Indexed_Component, N_Selected_Component, N_Slice) + loop + R := Get_Referenced_Object (Prefix (R)); + if Is_Atomic_Object (R) then + return True; + end if; + end loop; + + return False; + end Is_Subcomponent_Of_Atomic_Object; + --------------------------------------- -- Is_Subprogram_Contract_Annotation -- --------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c354d7e..c156651 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1996,6 +1996,10 @@ package Sem_Util is -- the N_Statement_Other_Than_Procedure_Call subtype from Sinfo). -- Note that a label is *not* a statement, and will return False. + function Is_Subcomponent_Of_Atomic_Object (N : Node_Id) return Boolean; + -- Determine whether arbitrary node N denotes a reference to a subcomponent + -- of an atomic object as per Ada 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 -- following subprogram contract annotations: |