===================================================================
@@ -429,11 +429,11 @@
elsif Has_Controlled_Component (L_Type) then
Loop_Required := True;
- -- If object is atomic, we cannot tolerate a loop
+ -- If object is atomic/VFA, we cannot tolerate a loop
- elsif Is_Atomic_Object (Act_Lhs)
+ elsif Is_Atomic_Or_VFA_Object (Act_Lhs)
or else
- Is_Atomic_Object (Act_Rhs)
+ Is_Atomic_Or_VFA_Object (Act_Rhs)
then
return;
@@ -442,8 +442,8 @@
elsif Has_Atomic_Components (L_Type)
or else Has_Atomic_Components (R_Type)
- or else Is_Atomic (Component_Type (L_Type))
- or else Is_Atomic (Component_Type (R_Type))
+ or else Is_Atomic_Or_VFA (Component_Type (L_Type))
+ or else Is_Atomic_Or_VFA (Component_Type (R_Type))
then
Loop_Required := True;
@@ -3395,7 +3395,7 @@
Next_Elmt (Prim);
end loop;
- -- default iterator must exist.
+ -- Default iterator must exist
pragma Assert (False);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2684,11 +2684,11 @@
elsif Is_Array_Type (E) then
- -- For arrays that are required to be atomic, we do the same
+ -- 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.
- if Is_Atomic (E) and then not Debug_Flag_Q then
+ if Is_Atomic_Or_VFA (E) and then not Debug_Flag_Q then
Set_Composite_Alignment (E);
end if;
@@ -2903,11 +2903,19 @@
and then Is_Record_Type (E)
and then Is_Packed (E)
then
- -- No effect for record with atomic components
+ -- No effect for record with atomic/VFA components
- if Is_Atomic (E) then
+ if Is_Atomic_Or_VFA (E) then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
- Error_Msg_N ("\pragma ignored for atomic record??", E);
+
+ if Is_Atomic (E) then
+ Error_Msg_N
+ ("\pragma ignored for atomic record??", E);
+ else
+ Error_Msg_N
+ ("\pragma ignored for bolatile full access record??", E);
+ end if;
+
return;
end if;
@@ -2920,20 +2928,30 @@
return;
end if;
- -- No effect if any component is atomic or is a by reference type
+ -- No effect if any component is atomic/VFA or is a by reference type
declare
Ent : Entity_Id;
+
begin
Ent := First_Component_Or_Discriminant (E);
while Present (Ent) loop
if Is_By_Reference_Type (Etype (Ent))
- or else Is_Atomic (Etype (Ent))
- or else Is_Atomic (Ent)
+ or else Is_Atomic_Or_VFA (Etype (Ent))
+ or else Is_Atomic_Or_VFA (Ent)
then
Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
- Error_Msg_N
- ("\pragma is ignored if atomic components present??", E);
+
+ if Is_Atomic (Etype (Ent)) or else Is_Atomic (Ent) then
+ Error_Msg_N
+ ("\pragma is ignored if atomic "
+ & "components present??", E);
+ else
+ Error_Msg_N
+ ("\pragma is ignored if bolatile full access "
+ & "components present??", E);
+ end if;
+
return;
else
Next_Component_Or_Discriminant (Ent);
@@ -3026,9 +3044,9 @@
-- 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 records, since we need max alignment there,
+ -- do this for atomic/VFA records, since we need max alignment there,
- if Is_Record_Type (E) and then not Is_Atomic (E) then
+ if Is_Record_Type (E) and then not Is_Atomic_Or_VFA (E) then
-- For records, there is generally no point in setting alignment
-- higher than word size since we cannot do better than move by
===================================================================
@@ -7329,6 +7329,15 @@
end if;
end Invariant_Procedure;
+ ----------------------
+ -- Is_Atomic_Or_VFA --
+ ----------------------
+
+ function Is_Atomic_Or_VFA (Id : E) return B is
+ begin
+ return Is_Atomic (Id) or else Has_Volatile_Full_Access (Id);
+ end Is_Atomic_Or_VFA;
+
------------------
-- Is_Base_Type --
------------------
===================================================================
@@ -2218,6 +2218,14 @@
-- 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)
+-- 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
+-- applies to both the partial view and the full view.
+
-- Is_Array_Type (synthesized)
-- Applies to all entities, true for array types and subtypes
@@ -5476,6 +5484,7 @@
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
+ -- Is_Atomic_Or_VFA (synth)
-- Predicate_Function (synth)
-- Predicate_Function_M (synth)
-- Root_Type (synth)
@@ -5628,6 +5637,7 @@
-- Is_Tag (Flag78)
-- Is_Volatile (Flag16)
-- Treat_As_Volatile (Flag41)
+ -- Is_Atomic_Or_VFA (synth)
-- Next_Component (synth)
-- Next_Component_Or_Discriminant (synth)
@@ -5676,6 +5686,7 @@
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
+ -- Is_Atomic_Or_VFA (synth)
-- Size_Clause (synth)
-- E_Decimal_Fixed_Point_Type
@@ -6413,6 +6424,7 @@
-- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
+ -- Is_Atomic_Or_VFA (synth)
-- Size_Clause (synth)
-- E_Void
@@ -6869,6 +6881,7 @@
function Is_Aliased (Id : E) return B;
function Is_Asynchronous (Id : E) return B;
function Is_Atomic (Id : E) return B;
+ function Is_Atomic_Or_VFA (Id : E) return B;
function Is_Bit_Packed_Array (Id : E) return B;
function Is_Called (Id : E) return B;
function Is_Character_Type (Id : E) return B;
@@ -9041,6 +9054,7 @@
-- be handled by xeinfo.
pragma Inline (Base_Type);
+ pragma Inline (Is_Atomic_Or_VFA);
pragma Inline (Is_Base_Type);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
===================================================================
@@ -5842,17 +5842,17 @@
K : Node_Kind;
Utyp : Entity_Id;
- procedure Set_Atomic_Full (E : Entity_Id);
+ procedure Set_Atomic_VFA (E : Entity_Id);
-- Set given type as Is_Atomic or Has_Volatile_Full_Access. Also, if
-- no explicit alignment was given, set alignment to unknown, since
-- back end knows what the alignment requirements are for atomic and
-- full access arrays. Note: this is necessary for derived types.
- ---------------------
- -- Set_Atomic_Full --
- ---------------------
+ --------------------
+ -- Set_Atomic_VFA --
+ --------------------
- procedure Set_Atomic_Full (E : Entity_Id) is
+ procedure Set_Atomic_VFA (E : Entity_Id) is
begin
if Prag_Id = Pragma_Volatile_Full_Access then
Set_Has_Volatile_Full_Access (E);
@@ -5863,7 +5863,7 @@
if not Has_Alignment_Clause (E) then
Set_Alignment (E, Uint_0);
end if;
- end Set_Atomic_Full;
+ end Set_Atomic_VFA;
-- Start of processing for Process_Atomic_Independent_Shared_Volatile
@@ -5956,9 +5956,9 @@
or else
Prag_Id = Pragma_Volatile_Full_Access
then
- Set_Atomic_Full (E);
- Set_Atomic_Full (Base_Type (E));
- Set_Atomic_Full (Underlying_Type (E));
+ 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
===================================================================
@@ -942,13 +942,13 @@
Packed_Size_Known := False;
end if;
- -- We do not know the packed size if we have an atomic type
+ -- We do not know the packed size for an atomic/VFA type
-- or component, or an independent type or component, or a
-- by reference type or aliased component (because packing
-- does not touch these).
- if Is_Atomic (Ctyp)
- or else Is_Atomic (Comp)
+ if Is_Atomic_Or_VFA (Ctyp)
+ or else Is_Atomic_Or_VFA (Comp)
or else Is_Independent (Ctyp)
or else Is_Independent (Comp)
or else Is_By_Reference_Type (Ctyp)
@@ -1036,11 +1036,11 @@
and then Is_Modular_Integer_Type
(Packed_Array_Impl_Type (Ctyp)))
then
- -- Packed size unknown if we have an atomic type
- -- or a by reference type, since the back end
- -- knows how these are layed out.
+ -- Packed size unknown if we have an atomic/VFA type
+ -- or a by reference type, since the back end knows
+ -- how these are layed out.
- if Is_Atomic (Ctyp)
+ if Is_Atomic_Or_VFA (Ctyp)
or else Is_By_Reference_Type (Ctyp)
then
Packed_Size_Known := False;
@@ -1455,11 +1455,11 @@
end loop;
end Check_Unsigned_Type;
- -------------------------
- -- Is_Atomic_Aggregate --
- -------------------------
+ -----------------------------
+ -- Is_Atomic_VFA_Aggregate --
+ -----------------------------
- function Is_Atomic_Aggregate
+ function Is_Atomic_VFA_Aggregate
(E : Entity_Id;
Typ : Entity_Id) return Boolean
is
@@ -1495,7 +1495,7 @@
else
return False;
end if;
- end Is_Atomic_Aggregate;
+ end Is_Atomic_VFA_Aggregate;
-----------------------------------------------
-- Explode_Initialization_Compound_Statement --
@@ -2423,12 +2423,12 @@
end if;
end;
- -- Check for Aliased or Atomic_Components/Atomic with unsuitable
- -- packing or explicit component size clause given.
+ -- Check for Aliased or Atomic_Components/Atomic/VFA with
+ -- unsuitable packing or explicit component size clause given.
if (Has_Aliased_Components (Arr)
or else Has_Atomic_Components (Arr)
- or else Is_Atomic (Ctyp))
+ or else Is_Atomic_Or_VFA (Ctyp))
and then
(Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
then
@@ -2436,8 +2436,8 @@
procedure Complain_CS (T : String);
-- Outputs error messages for incorrect CS clause or pragma
- -- Pack for aliased or atomic components (T is "aliased" or
- -- "atomic");
+ -- Pack for aliased or atomic/VFA components (T is "aliased"
+ -- or "atomic/vfa");
-----------------
-- Complain_CS --
@@ -2498,9 +2498,13 @@
elsif Has_Aliased_Components (Arr) then
Complain_CS ("aliased");
- elsif Has_Atomic_Components (Arr) or else Is_Atomic (Ctyp)
+ elsif Has_Atomic_Components (Arr)
+ or else Is_Atomic (Ctyp)
then
Complain_CS ("atomic");
+
+ elsif Has_Volatile_Full_Access (Ctyp) then
+ Complain_CS ("volatile full access");
end if;
end Alias_Atomic_Check;
end if;
@@ -2509,8 +2513,8 @@
-- packing or explicit component size clause given.
if (Has_Independent_Components (Arr) or else Is_Independent (Ctyp))
- and then
- (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
+ and then
+ (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
then
begin
-- If object size of component type isn't known, we cannot
@@ -2772,7 +2776,7 @@
-- 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 case (atomic arrays may need larger alignments).
+ -- in atomic/VFA case (atomic/VFA arrays may need larger alignments).
if not Is_Packed (Arr)
and then Unknown_Alignment (Arr)
@@ -2780,7 +2784,7 @@
and then Known_Static_Component_Size (Arr)
and then Known_Static_Esize (Ctyp)
and then Esize (Ctyp) = Component_Size (Arr)
- and then not Is_Atomic (Arr)
+ and then not Is_Atomic_Or_VFA (Arr)
then
Set_Alignment (Arr, Alignment (Component_Type (Arr)));
end if;
@@ -4813,11 +4817,12 @@
-- than component-wise (the assignment to the temp may be done
-- component-wise, but that is harmless).
- elsif Is_Atomic (E)
+ elsif Is_Atomic_Or_VFA (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_Aggregate (Expression (Parent (E)), Etype (E))
+ and then
+ Is_Atomic_VFA_Aggregate (Expression (Parent (E)), Etype (E))
then
null;
end if;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -174,12 +174,11 @@
-- do not allow a size clause if the size would not otherwise be known at
-- compile time in any case.
- function Is_Atomic_Aggregate
+ function Is_Atomic_VFA_Aggregate
(E : Entity_Id;
Typ : Entity_Id) return Boolean;
-
- -- If an atomic object is initialized with an aggregate or is assigned an
- -- aggregate, we have to prevent a piecemeal access or assignment to the
+ -- If an atomic/VFA 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
-- end can generate an atomic move for it. This is only done in the context
===================================================================
@@ -10276,6 +10276,20 @@
end if;
end Is_Atomic_Object;
+ -----------------------------
+ -- 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_Object_Reference (N)
+ and then Is_Entity_Name (N)
+ and then (Has_Volatile_Full_Access (Entity (N))
+ or else
+ Has_Volatile_Full_Access (Etype (Entity (N)))));
+ end Is_Atomic_Or_VFA_Object;
+
-------------------------
-- Is_Attribute_Result --
-------------------------
===================================================================
@@ -1168,6 +1168,10 @@
-- Determines if the given node denotes an atomic object in the sense of
-- the legality checks described in RM C.6(12).
+ function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean;
+ -- Determines if the given node is an atomic object (Is_Atomic_Object true)
+ -- or else is an object for which VFA is present.
+
function Is_Attribute_Result (N : Node_Id) return Boolean;
-- Determine whether node N denotes attribute 'Result
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -396,7 +396,8 @@
Write_Eol;
end if;
- -- Set Atomic_Sync_Required if necessary for atomic variable
+ -- Set Atomic_Sync_Required if necessary for atomic variable. Note that
+ -- this processing does NOT apply to Volatile_Full_Access variables.
if Nkind_In (N, N_Identifier, N_Expanded_Name)
and then Ekind (E) = E_Variable
===================================================================
@@ -7313,12 +7313,12 @@
-- 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 types (where we must be sure
+ -- element comparison), and atomic/VFA 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 (Component_Type (Typl))
+ and then not Is_Atomic_Or_VFA (Component_Type (Typl))
and then not Is_Possibly_Unaligned_Object (Lhs)
and then not Is_Possibly_Unaligned_Object (Rhs)
and then Support_Composite_Compare_On_Target
===================================================================
@@ -3159,6 +3159,16 @@
return True;
end if;
+ -- Similar processing for "volatile full access cannot be guaranteed"
+
+ elsif Msg = "volatile full access to & cannot be guaranteed" then
+ if Is_Type (E)
+ and then Has_Volatile_Full_Access (E)
+ and then No (Get_Rep_Pragma (E, Name_Volatile_Full_Access))
+ then
+ return True;
+ end if;
+
-- Processing for "Size too small" messages
elsif Msg = "size for& too small, minimum allowed is ^" then
===================================================================
@@ -4175,7 +4175,7 @@
Ctyp := Component_Type (Ctyp);
- if Is_Atomic (Ctyp) then
+ if Is_Atomic_Or_VFA (Ctyp) then
return False;
end if;
end loop;
@@ -5935,15 +5935,15 @@
-- Start of processing for Expand_Record_Aggregate
begin
- -- If the aggregate is to be assigned to an atomic variable, we have
+ -- If the aggregate is to be assigned to an atomic/VFA 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 (Typ)
+ if Is_Atomic_Or_VFA (Typ)
and then Comes_From_Source (Parent (N))
- and then Is_Atomic_Aggregate (N, Typ)
+ and then Is_Atomic_VFA_Aggregate (N, Typ)
then
return;
===================================================================
@@ -965,6 +965,13 @@
Set_Is_Volatile (E);
end if;
+ -- Volatile_Full_Access
+
+ when Aspect_Volatile_Full_Access =>
+ if Has_Volatile_Full_Access (P) then
+ Set_Has_Volatile_Full_Access (E);
+ end if;
+
-- Volatile_Components
when Aspect_Volatile_Components =>
@@ -1057,6 +1064,11 @@
return;
end if;
+ when Aspect_Volatile_Full_Access =>
+ if not Has_Volatile_Full_Access (Par) then
+ return;
+ end if;
+
when others =>
return;
end case;
@@ -1066,7 +1078,6 @@
Error_Msg_Name_1 := A_Name;
Error_Msg_NE
("derived type& inherits aspect%, cannot cancel", Expr, E);
-
end Check_False_Aspect_For_Derived_Type;
-- Start of processing for Make_Pragma_From_Boolean_Aspect
@@ -11164,6 +11175,18 @@
Set_Is_Volatile (Typ);
end if;
+ -- Volatile_Full_Access
+
+ if not Has_Rep_Item (Typ, Name_Volatile_Full_Access, False)
+ and then Has_Rep_Pragma (Typ, Name_Volatile_Full_Access)
+ and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
+ (Get_Rep_Item (Typ, Name_Volatile_Full_Access))
+ then
+ Set_Has_Volatile_Full_Access (Typ);
+ Set_Treat_As_Volatile (Typ);
+ Set_Is_Volatile (Typ);
+ end if;
+
-- Inheritance for derived types only
if Is_Derived_Type (Typ) then