Aspect_Exclusive_Functions,
Aspect_Export,
Aspect_Favor_Top_Level, -- GNAT
+ Aspect_Full_Access_Only,
Aspect_Independent,
Aspect_Independent_Components,
Aspect_Import,
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,
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,
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,
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
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 --
------------------
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 --
-------------------
-- 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)
-- 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
-- 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)
-- 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)
-- 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
-- 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
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;
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;
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);
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);
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 <>
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;
-- 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
-- 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)
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;
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;
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
then
return True;
- elsif Is_Atomic_Or_VFA_Object (Prefix (Nam)) then
+ elsif Is_Full_Access_Object (Prefix (Nam)) then
return True;
else
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;
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;
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;
Set_Expression (Par, New_Occurrence_Of (Temp, Loc));
return True;
- end Is_Atomic_VFA_Aggregate;
+ end Is_Full_Access_Aggregate;
-----------------------------------------------
-- Explode_Initialization_Compound_Statement --
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
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 --
-- 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;
-- 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
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
}
/* 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
{
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.
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));
}
/* 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. */
{
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);
}
}
/* 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
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
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);
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)
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 ^}";
}
/* 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);
/* 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);
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;
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
|| 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)
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
-- 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)
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;
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;
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
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;
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);
& "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;
-- 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
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)
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;
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 --
--------------------
-- 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;
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
("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;
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
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;
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;
-- 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)))));
-- 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;
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
is
Args : List_Id := Pragma_Argument_Associations;
Aitem : Node_Id;
+
begin
-- We should never get here if aspect was disabled
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)
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.
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
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.
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.
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.
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
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;
-- 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;
-----------------------------------
-- 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 --
--------------------------------------------------
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
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
-- 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
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;
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 --
---------------------
------------------------------------------------
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
-- 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
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 --
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.
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
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;
-------------------------------------------
-- 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;
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)
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;
-- ^
-- Item
- if Has_Rep_Item (From_Typ, Next_Item) then
+ if Present_In_Rep_Item (From_Typ, Next_Item) then
exit;
end if;
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 --
-----------------------------
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 --
-------------------------------
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
-- 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 --
-- 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
-- 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.
-- 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
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 + $;
projects / gcc.git / commitdiff