diff mbox series

[Ada] Volatile component not treated as such

Message ID 20170906125839.GA117525@adacore.com
State New
Headers show
Series [Ada] Volatile component not treated as such | expand

Commit Message

Arnaud Charlet Sept. 6, 2017, 12:58 p.m. UTC 
This patch corrects an issue where attributes applied to records were not
propagated to components within the records - causing incorrect code to be
generated by the backend. Additionally, this ticket fixes another issue with
pragma Volatile_Full_Access that allowed the attribute to be applied to a type
with aliased components.

------------
-- Source --
------------

--  p.ads

with System; use System;

package P is
   type Int8_t is mod 2**8;
   type Rec is record
     A,B,C,D : aliased Int8_t;
   end record;
   type VFA_Rec is new Rec with Volatile_Full_Access; --  ERROR

   R : Rec with Volatile_Full_Access; --  ERROR

   type Arr is array (1 .. 4) of aliased Int8_t;
   type VFA_Arr is new Arr with Volatile_Full_Access; --  ERROR

   A : Arr with Volatile_Full_Access; --  ERROR

   type Priv_VFA_Rec is private
     with Volatile_Full_Access; --  ERROR

   type Priv_Ind_Rec is private
     with Independent; --  ERROR

   type Priv_Vol_Rec is private
     with Volatile; --  ERROR

   type Priv_Atomic_Rec is private
     with Atomic; --  ERROR

   type Aliased_Rec is tagged  record
      X : aliased Integer;
   end record with Volatile_Full_Access; --  OK

   type Atomic_And_VFA_Int is new Integer
     with Atomic, Volatile_Full_Access; --  ERROR

   type Atomic_And_VFA_Rec is record
      X : Integer with Atomic;
   end record with Volatile_Full_Access; --  ERROR

   type Atomic_T is tagged record
      X : Integer with Atomic; --  OK
   end record;

   type Atomic_And_VFA_T is new Atomic_T with record
      Y : Integer;
   end record with Volatile_Full_Access; --  ERROR

   type Aliased_And_VFA_T is new Aliased_Rec with record
      Y : Integer;
   end record with Volatile_Full_Access; --  ERROR

   Aliased_And_VFA_Obj   : aliased Integer with Volatile_Full_Access; --  ERROR
   Atomic_And_VFA_Obj    : Integer with Atomic, Volatile_Full_Access; --  ERROR
   Aliased_And_VFA_Obj_B : Aliased_Rec with Volatile_Full_Access;     --  ERROR
   Atomic_And_VFA_Obj_B  : Atomic_T with Volatile_Full_Access;        --  ERROR

private
   type Priv_VFA_Rec is record
      X : Integer;
   end record;

   type Priv_Ind_Rec is record
      X : Integer;
   end record;

   type Priv_Vol_Rec is record
      X : Integer;
   end record;

   type Priv_Atomic_Rec is record
      X : Integer;
   end record;
end;

--  p2.adb

with System;

procedure P2 is

   type Type1_T is record
      Field_1 : Integer;
      Field_2 : Integer;
      Field_3 : Integer;
      Field_4 : Short_Integer;
   end record;

   for Type1_T use record
      Field_1 at 0 range 0 .. 31;
      Field_2 at 4 range 0 .. 31;
      Field_3 at 8 range 0 .. 31;
      Field_4 at 12 range 0 .. 15;
   end record;
   for Type1_T'Size use (14) * System.Storage_Unit;
   pragma Volatile(Type1_T);

   type Type2_T is record
      Type1   : Type1_T;
      Field_1 : Integer;
      Field_2 : Integer;
      Field_3 : Integer;
      Field_4 : Short_Integer;
   end record;

   for Type2_T use record
      Type1   at 0 range 0 .. 111;
      Field_1 at 14 range 0 .. 31;
      Field_2 at 18 range 0 .. 31;
      Field_3 at 22 range 0 .. 31;
      Field_4 at 26 range 0 .. 15;
   end record;
   for Type2_T'Size use (28) * System.Storage_Unit;
   pragma Volatile(Type2_T); --  ERROR

   Type1 : Type1_T := (0,0,0,0);

   Type2 : Type2_T:= ((0,0,0,0),0,0,0,0);
begin
   Type1.Field_1 :=  Type1.Field_1 +1;

   Type2.Field_1 := Type2.Field_1 +1;
end;

----------------------------
-- Compilation and output --
----------------------------

& gcc -c p.ads
& gnatmake -q p2.adb
p.ads:8:33: cannot apply Volatile_Full_Access (aliased component present)
p.ads:10:17: cannot apply Volatile_Full_Access (aliased component present)
p.ads:13:33: cannot apply Volatile_Full_Access (aliased component present)
p.ads:15:17: cannot apply Volatile_Full_Access (aliased component present)
p.ads:18:11: representation item must be after full type declaration
p.ads:21:11: representation item must be after full type declaration
p.ads:24:11: representation item must be after full type declaration
p.ads:27:11: representation item must be after full type declaration
p.ads:31:20: cannot apply Volatile_Full_Access (aliased component present)
p.ads:34:19: cannot have Volatile_Full_Access and Atomic for same entity
p.ads:38:20: cannot have Volatile_Full_Access and Atomic for same entity
p.ads:46:20: cannot have Volatile_Full_Access and Atomic for same entity
p.ads:50:20: cannot apply Volatile_Full_Access (aliased component present)
p.ads:53:49: cannot have Volatile_Full_Access and Atomic for same entity
p.ads:54:45: cannot apply Volatile_Full_Access (aliased component present)
p.ads:55:42: cannot have Volatile_Full_Access and Atomic for same entity
p2.adb:30:31: size of volatile field "Type1" must be at least 128 bits
p2.adb:31:27: position of volatile field "Field_1" must be multiple of 32 bits
p2.adb:32:27: position of volatile field "Field_2" must be multiple of 32 bits
p2.adb:33:27: position of volatile field "Field_3" must be multiple of 32 bits
p2.adb:36:30: size for "Type2_T" too small, minimum allowed is 448
gnatmake: "p2.adb" compilation error

Tested on x86_64-pc-linux-gnu, committed on trunk

2017-09-06  Justin Squirek  <squirek@adacore.com>

	* sem_prag.adb (Check_VFA_Conflicts): Created
	to group all Volatile_Full_Access checks relating to other
	representation pragmas (Mark_Component_Or_Object): Created
	to centeralize the flagging of attributes for the record type
	component case, a pragma applied individually to a component, and
	the object case.
	(Process_Atomic_Independent_Shared_Volatile):
	Add propagation of certain pragmas to record components and move
	evaluation of VFA checks
diff mbox series

Patch

Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 251789)
+++ sem_prag.adb	(working copy)
@@ -6873,26 +6873,193 @@ 
       ------------------------------------------------
 
       procedure Process_Atomic_Independent_Shared_Volatile is
-         procedure Set_Atomic_VFA (E : Entity_Id);
+         procedure Check_VFA_Conflicts (Ent : Entity_Id);
+         --  Apply additional checks for the GNAT pragma Volatile_Full_Access
+
+         procedure Mark_Component_Or_Object (Ent : Entity_Id);
+         --  Appropriately set flags on the given entity (either an array or
+         --  record component, or an object declaration) according to the
+         --  current pragma.
+
+         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
          --  back end knows what the alignment requirements are for atomic and
          --  full access arrays. Note: this is necessary for derived types.
 
+         -------------------------
+         -- Check_VFA_Conflicts --
+         -------------------------
+
+         procedure Check_VFA_Conflicts (Ent : Entity_Id) is
+            Comp : Entity_Id;
+            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
+
+         begin
+            --  Fetch the type in case we are dealing with an object or
+            --  component.
+
+            if Is_Type (Ent) then
+               Typ := Ent;
+            else
+               pragma Assert (Is_Object (Ent)
+                 or else
+                   Nkind (Declaration_Node (Ent)) = N_Component_Declaration);
+
+               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);
+
+               --  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.
+
+               elsif Is_Record_Type (Typ) then
+                  --  Attributes cannot be applied to discriminants, only
+                  --  regular record components.
+
+                  Comp := First_Component (Typ);
+                  while Present (Comp) loop
+                     if Is_Atomic (Comp)
+                       or else Is_Atomic (Typ)
+                     then
+                        VFA_And_Atomic := True;
+
+                        exit;
+                     end if;
+
+                     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;
+
+            --  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;
+
+         ------------------------------
+         -- Mark_Component_Or_Object --
+         ------------------------------
+
+         procedure Mark_Component_Or_Object (Ent : Entity_Id) is
+         begin
+            if Prag_Id = Pragma_Atomic
+              or else Prag_Id = Pragma_Shared
+              or else Prag_Id = Pragma_Volatile_Full_Access
+            then
+               if Prag_Id = Pragma_Volatile_Full_Access then
+                  Set_Is_Volatile_Full_Access (Ent);
+               else
+                  Set_Is_Atomic (Ent);
+               end if;
+
+               --  If the object declaration has an explicit initialization, a
+               --  temporary may have to be created to hold the expression, to
+               --  ensure that access to the object remains atomic.
+
+               if Nkind (Parent (Ent)) = N_Object_Declaration
+                 and then Present (Expression (Parent (Ent)))
+               then
+                  Set_Has_Delayed_Freeze (Ent);
+               end if;
+            end if;
+
+            --  Atomic/Shared/Volatile_Full_Access imply Independent
+
+            if Prag_Id /= Pragma_Volatile then
+               Set_Is_Independent (Ent);
+
+               if Prag_Id = Pragma_Independent then
+                  Record_Independence_Check (N, Ent);
+               end if;
+            end if;
+
+            --  Atomic/Shared/Volatile_Full_Access imply Volatile
+
+            if Prag_Id /= Pragma_Independent then
+               Set_Is_Volatile (Ent);
+               Set_Treat_As_Volatile (Ent);
+            end if;
+         end Mark_Component_Or_Object;
+
          --------------------
          -- Set_Atomic_VFA --
          --------------------
 
-         procedure Set_Atomic_VFA (E : Entity_Id) is
+         procedure Set_Atomic_VFA (Ent : Entity_Id) is
          begin
             if Prag_Id = Pragma_Volatile_Full_Access then
-               Set_Is_Volatile_Full_Access (E);
+               Set_Is_Volatile_Full_Access (Ent);
             else
-               Set_Is_Atomic (E);
+               Set_Is_Atomic (Ent);
             end if;
 
-            if not Has_Alignment_Clause (E) then
-               Set_Alignment (E, Uint_0);
+            if not Has_Alignment_Clause (Ent) then
+               Set_Alignment (Ent, Uint_0);
             end if;
          end Set_Atomic_VFA;
 
@@ -6926,63 +7093,15 @@ 
 
          Check_Duplicate_Pragma (E);
 
-         --  Check Atomic and VFA used together
+         --  Check appropriateness of the entity
 
-         if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access)
-           or else (Is_Volatile_Full_Access (E)
-                     and then (Prag_Id = Pragma_Atomic
-                                 or else
-                               Prag_Id = Pragma_Shared))
-         then
-            Error_Pragma
-              ("cannot have Volatile_Full_Access and Atomic for same entity");
-         end if;
+         Decl := Declaration_Node (E);
 
-         --  Check for applying VFA to an entity which has aliased component
+         --  Deal with the case where the pragma/attribute is applied to a type
 
-         if Prag_Id = Pragma_Volatile_Full_Access then
-            declare
-               Comp         : Entity_Id;
-               Aliased_Comp : Boolean := False;
-               --  Set True if aliased component present
-
-            begin
-               if Is_Array_Type (Etype (E)) then
-                  Aliased_Comp := Has_Aliased_Components (Etype (E));
-
-               --  Record case, too bad Has_Aliased_Components is not also
-               --  set for records, should it be ???
-
-               elsif Is_Record_Type (Etype (E)) then
-                  Comp := First_Component_Or_Discriminant (Etype (E));
-                  while Present (Comp) loop
-                     if Is_Aliased (Comp)
-                       or else Is_Aliased (Etype (Comp))
-                     then
-                        Aliased_Comp := True;
-                        exit;
-                     end if;
-
-                     Next_Component_Or_Discriminant (Comp);
-                  end loop;
-               end if;
-
-               if Aliased_Comp then
-                  Error_Pragma
-                    ("cannot apply Volatile_Full_Access (aliased component "
-                     & "present)");
-               end if;
-            end;
-         end if;
-
-         --  Now check appropriateness of the entity
-
-         Decl := Declaration_Node (E);
-
          if Is_Type (E) then
             if Rep_Item_Too_Early (E, N)
-                 or else
-               Rep_Item_Too_Late (E, N)
+              or else Rep_Item_Too_Late (E, N)
             then
                return;
             else
@@ -6993,10 +7112,8 @@ 
             --  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
+              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));
@@ -7026,6 +7143,9 @@ 
                Set_Treat_As_Volatile (Underlying_Type (E));
             end if;
 
+         --  Deal with the case where the pragma/attribute applies to a
+         --  component or object declaration.
+
          elsif Nkind (Decl) = N_Object_Declaration
            or else (Nkind (Decl) = N_Component_Declaration
                      and then Original_Record_Component (E) = E)
@@ -7034,50 +7154,16 @@ 
                return;
             end if;
 
-            if Prag_Id = Pragma_Atomic
-                 or else
-               Prag_Id = Pragma_Shared
-                 or else
-               Prag_Id = Pragma_Volatile_Full_Access
-            then
-               if Prag_Id = Pragma_Volatile_Full_Access then
-                  Set_Is_Volatile_Full_Access (E);
-               else
-                  Set_Is_Atomic (E);
-               end if;
-
-               --  If the object declaration has an explicit initialization, a
-               --  temporary may have to be created to hold the expression, to
-               --  ensure that access to the object remain atomic.
-
-               if Nkind (Parent (E)) = N_Object_Declaration
-                 and then Present (Expression (Parent (E)))
-               then
-                  Set_Has_Delayed_Freeze (E);
-               end if;
-            end if;
-
-            --  Atomic/Shared/Volatile_Full_Access imply Independent
-
-            if Prag_Id /= Pragma_Volatile then
-               Set_Is_Independent (E);
-
-               if Prag_Id = Pragma_Independent then
-                  Record_Independence_Check (N, E);
-               end if;
-            end if;
-
-            --  Atomic/Shared/Volatile_Full_Access imply Volatile
-
-            if Prag_Id /= Pragma_Independent then
-               Set_Is_Volatile (E);
-               Set_Treat_As_Volatile (E);
-            end if;
-
+            Mark_Component_Or_Object (E);
          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_VFA_Conflicts (E);
+
          --  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