@@ -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:
@@ -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
@@ -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}
@@ -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
@@ -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;
@@ -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;
@@ -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 --
---------------------------------------
@@ -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: