[Ada] AI12-0282: shared variable control aspects on formal types

Message ID 20191218072800.GA102837@adacore.com
State New
Headers show
Series
  • [Ada] AI12-0282: shared variable control aspects on formal types
Related show

Commit Message

Pierre-Marie de Rodat Dec. 18, 2019, 7:28 a.m.
Ada202X allows some aspects related to shared variable control to appear
on formal type declarations. These aspects represent new enforceable
parts of the contract between generic units and instantiations.

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

2019-12-18  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* par-ch12.adb (P_Formal_Derived_Type_Definition): In Ada_2020
	the keyword WITH can indicate the start of aspect specifications
	and not a private type extension.
	* sem_ch12.adb (Analyze_Formal_Type): Indicate that it is a
	first subtype.
	(Instantiate_Type): New procedure
	Check_Shared_Variable_Control_Aspects to verify matching rules
	between formal and actual types. Note that an array type with
	aspect Atomic_Components is considered compatible with an array
	type whose component type is Atomic, even though the array types
	do not carry the same aspect.
	* sem_ch13.adb (Analyze_One_Aspect): Allow shared variable
	control aspects to appear on formal types.
	(Rep_Item_Too_Early): Exclude aspects on formal types.
	* sem_prag.adb (Mark_Type): Handle properly pragmas that come
	from aspects on formal types.
	(Analyze_Pragma, case Atomic_Components): Handle formal types.

Patch

--- gcc/ada/par-ch12.adb
+++ gcc/ada/par-ch12.adb
@@ -971,9 +971,16 @@  package body Ch12 is
       end if;
 
       if Token = Tok_With then
-         Scan; -- past WITH
-         Set_Private_Present (Def_Node, True);
-         T_Private;
+
+         if Ada_Version >= Ada_2020 and Token /= Tok_Private then
+            --  Formal type has aspect specifications, parsed later.
+            return Def_Node;
+
+         else
+            Scan; -- past WITH
+            Set_Private_Present (Def_Node, True);
+            T_Private;
+         end if;
 
       elsif Token = Tok_Tagged then
          Scan;

--- gcc/ada/sem_ch12.adb
+++ gcc/ada/sem_ch12.adb
@@ -3410,7 +3410,11 @@  package body Sem_Ch12 is
             raise Program_Error;
       end case;
 
+      --  A formal type declaration declares a type and its first
+      --  subtype.
+
       Set_Is_Generic_Type (T);
+      Set_Is_First_Subtype (T);
 
       if Has_Aspects (N) then
          Analyze_Aspect_Specifications (N, T);
@@ -12178,6 +12182,10 @@  package body Sem_Ch12 is
       Loc        : Source_Ptr;
       Subt       : Entity_Id;
 
+      procedure Check_Shared_Variable_Control_Aspects;
+      --  Ada_2020: Verify that shared variable control aspects (RM C.6)
+      --  that may be specified for a formal type are obeyed by the actual.
+
       procedure Diagnose_Predicated_Actual;
       --  There are a number of constructs in which a discrete type with
       --  predicates is illegal, e.g. as an index in an array type declaration.
@@ -12202,6 +12210,79 @@  package body Sem_Ch12 is
       --  Check that base types are the same and that the subtypes match
       --  statically. Used in several of the above.
 
+      --------------------------------------------
+      --  Check_Shared_Variable_Control_Aspects --
+      --------------------------------------------
+
+      --  Ada_2020: Verify that shared variable control aspects (RM C.6)
+      --  that may be specified for the formal are obeyed by the actual.
+
+      procedure Check_Shared_Variable_Control_Aspects is
+      begin
+         if Ada_Version >= Ada_2020 then
+            if Is_Atomic (A_Gen_T) and then not Is_Atomic (Act_T) then
+               Error_Msg_NE
+                  ("actual for& must be an atomic type", Actual, A_Gen_T);
+            end if;
+
+            if Is_Volatile (A_Gen_T) and then not Is_Volatile (Act_T) then
+               Error_Msg_NE
+                  ("actual for& must be a Volatile type", Actual, A_Gen_T);
+            end if;
+
+            if
+              Is_Independent (A_Gen_T) and then not Is_Independent (Act_T)
+            then
+               Error_Msg_NE
+                 ("actual for& must be an Independent type", Actual, A_Gen_T);
+            end if;
+
+            --  We assume that an array type whose atomic component type
+            --  is Atomic is equivalent to an array type with the explicit
+            --  aspect Has_Atomic_Components. This is a reasonable inference
+            --  from the intent of AI12-0282, and makes it legal to use an
+            --  actual that does not have the identical aspect as the formal.
+
+            if Has_Atomic_Components (A_Gen_T)
+               and then not Has_Atomic_Components (Act_T)
+            then
+               if Is_Array_Type (Act_T)
+                 and then Is_Atomic (Component_Type (Act_T))
+               then
+                  null;
+
+               else
+                  Error_Msg_NE
+                    ("actual for& must have atomic components",
+                       Actual, A_Gen_T);
+               end if;
+            end if;
+
+            if Has_Independent_Components (A_Gen_T)
+               and then not Has_Independent_Components (Act_T)
+            then
+               Error_Msg_NE
+                 ("actual for& must have independent components",
+                    Actual, A_Gen_T);
+            end if;
+
+            if Has_Volatile_Components (A_Gen_T)
+               and then not Has_Volatile_Components (Act_T)
+            then
+               if Is_Array_Type (Act_T)
+                 and then Is_Volatile (Component_Type (Act_T))
+               then
+                  null;
+
+               else
+                  Error_Msg_NE
+                    ("actual for& must have volatile components",
+                       Actual, A_Gen_T);
+               end if;
+            end if;
+         end if;
+      end Check_Shared_Variable_Control_Aspects;
+
       ---------------------------------
       --  Diagnose_Predicated_Actual --
       ---------------------------------
@@ -12820,12 +12901,21 @@  package body Sem_Ch12 is
          --  Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
          --  removes the second instance of the phrase "or allow pass by copy".
 
-         if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
+         --  In Ada_2020 the aspect may be specified explicitly for the formal
+         --  regardless of whether an ancestor obeys it.
+
+         if Is_Atomic (Act_T)
+             and then not Is_Atomic (Ancestor)
+             and then not Is_Atomic (A_Gen_T)
+         then
             Error_Msg_N
               ("cannot have atomic actual type for non-atomic formal type",
                Actual);
 
-         elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then
+         elsif Is_Volatile (Act_T)
+           and then not Is_Volatile (Ancestor)
+           and then not Is_Volatile (A_Gen_T)
+         then
             Error_Msg_N
               ("cannot have volatile actual type for non-volatile formal type",
                Actual);
@@ -13504,6 +13594,8 @@  package body Sem_Ch12 is
          end if;
       end if;
 
+      Check_Shared_Variable_Control_Aspects;
+
       if Error_Posted (Act_T) then
          null;
       else

--- gcc/ada/sem_ch13.adb
+++ gcc/ada/sem_ch13.adb
@@ -2131,12 +2131,27 @@  package body Sem_Ch13 is
                      Aspect);
                end if;
 
-               --  Not allowed for formal type declarations
+               --  Not allowed for formal type declarations in previous
+               --  versions of the language. Allowed for them only for
+               --  shared variable control aspects.
 
                if Nkind (N) = N_Formal_Type_Declaration then
-                  Error_Msg_N
-                    ("aspect % not allowed for formal type declaration",
-                     Aspect);
+                  if Ada_Version < Ada_2020 then
+                     Error_Msg_N
+                       ("aspect % not allowed for formal type declaration",
+                        Aspect);
+
+                  elsif A_Id /= Aspect_Atomic
+                     and then A_Id /= Aspect_Volatile
+                     and then A_Id /= Aspect_Independent
+                     and then A_Id /= Aspect_Atomic_Components
+                     and then A_Id /= Aspect_Independent_Components
+                     and then A_Id /= Aspect_Volatile_Components
+                  then
+                     Error_Msg_N
+                       ("aspect % not allowed for formal type declaration",
+                        Aspect);
+                  end if;
                end if;
             end if;
 
@@ -12837,8 +12852,13 @@  package body Sem_Ch13 is
         and then (Nkind (N) /= N_Pragma
                    or else Get_Pragma_Id (N) /= Pragma_Convention)
       then
-         Error_Msg_N ("representation item not allowed for generic type", N);
-         return True;
+         if Ada_Version < Ada_2020 then
+            Error_Msg_N
+              ("representation item not allowed for generic type", N);
+            return True;
+         else
+            return False;
+         end if;
       end if;
 
       --  Otherwise check for incomplete type

--- gcc/ada/sem_prag.adb
+++ gcc/ada/sem_prag.adb
@@ -7562,13 +7562,19 @@  package body Sem_Prag is
             --  Attribute belongs on the base type. If the view of the type is
             --  currently private, it also belongs on the underlying type.
 
+            --  In Ada_2020, the pragma can apply to a formal type, for which
+            --  there may be no 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));
+
+               if not Is_Generic_Type (Ent) then
+                  Set_Atomic_VFA (Underlying_Type (Ent));
+               end if;
             end if;
 
             --  Atomic/Shared/Volatile_Full_Access imply Independent
@@ -7576,10 +7582,13 @@  package body Sem_Prag is
             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));
+               if not Is_Generic_Type (Ent) then
+                  Set_Is_Independent (Underlying_Type (Ent));
+
+                  if Prag_Id = Pragma_Independent then
+                     Record_Independence_Check (N, Base_Type (Ent));
+                  end if;
                end if;
             end if;
 
@@ -7588,10 +7597,13 @@  package body Sem_Prag is
             if Prag_Id /= Pragma_Independent then
                Set_Is_Volatile (Ent);
                Set_Is_Volatile (Base_Type (Ent));
-               Set_Is_Volatile (Underlying_Type (Ent));
+
+               if not Is_Generic_Type (Ent) then
+                  Set_Is_Volatile (Underlying_Type (Ent));
+                  Set_Treat_As_Volatile (Underlying_Type (Ent));
+               end if;
 
                Set_Treat_As_Volatile (Ent);
-               Set_Treat_As_Volatile (Underlying_Type (Ent));
             end if;
 
             --  Apply Volatile to the composite type's individual components,
@@ -14076,6 +14088,9 @@  package body Sem_Prag is
                              Ekind (E) = E_Variable)
                    and then Nkind (Object_Definition (D)) =
                                        N_Constrained_Array_Definition)
+              or else
+                 (Ada_Version >= Ada_2020
+                   and then Nkind (D) = N_Formal_Type_Declaration)
             then
                --  The flag is set on the base type, or on the object
 
@@ -14090,6 +14105,7 @@  package body Sem_Prag is
                      Check_Atomic_VFA
                        (Component_Type (Etype (E)), VFA => False);
                   end if;
+
                   Set_Has_Atomic_Components (E);
                   Set_Has_Independent_Components (E);
                end if;