diff mbox series

[Ada] Completion of support for AI12-0409 (attribute Preelaborable_Initialization)

Message ID 20211004084817.GA1538524@adacore.com
State New
Headers show
Series [Ada] Completion of support for AI12-0409 (attribute Preelaborable_Initialization) | expand

Commit Message

Pierre-Marie de Rodat Oct. 4, 2021, 8:48 a.m. UTC 
This set of changes implements proper checking of types completing
private types in a generic unit where the full type has components of
formal types of the generic and the private type has a
Preelaborable_Initialization aspect given by a conjunction of one or
more references to Preelab_Initialization attributes whose prefixes name
formal types. Also done as part of this work is the replacement of
Preelaborable_Initialization pragmas in the Ada bounded containers units
with the corresponding aspect, defining the aspect's expression with
references to P_I attributes applied to formal types of the generic
units as now specified in AI12-0409 and the Ada 2022 RM (and also
replacing the pragma with the aspect on Cursor types).

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

gcc/ada/

	* sem_ch7.adb (Analyze_Package_Specification): For types marked
	as Must_Have_Preelab_Init, we now check for the presence of a
	Preelaborable_Initialization aspect on the type, and pass the
	aspect's expression (if any) on the call to
	Has_Preelaborable_Initialization (or pass Empty if the type has
	no such aspect or the aspect has no associated expression).
	* sem_util.ads (Has_Preelaborable_Initialization): Change
	Boolean formal parameter Formal_Types_Have_Preelab_Init to
	instead be a formal of type Node_Id (named Preelab_Init_Expr),
	to allow passing an expression that may be a conjunction of
	Preelaborable_Initialization aspects. Revise spec comment
	accordingly (and remove ??? comment).
	* sem_util.adb (Type_Named_In_Preelab_Init_Expression): New
	nested function with a result indicating whether a given type is
	named as the prefix of a Preelaborable_Initialization attribute
	in the expression of a corresponding P_I aspect.
	(Has_Preelaborable_Initialization): For generic formal derived
	and private types, test whether the type is named in the
	expression Preelab_Init_Expr (by calling
	Type_Named_In_Preelab_Init_Expression), and if so, treat the
	formal type as having preelaborable initialization (returning
	True).
	* libgnat/a-cobove.ads (Vector): Replace pragma
	Preelaborable_Initialization with the aspect, specifying its
	value as Element_Type'Preelaborable_Initialization.
	(Cursor): Replace pragma P_I with the aspect (defaulting to
	True).
	* libgnat/a-cbdlli.ads (List): Replace pragma
	Preelaborable_Initialization with the aspect, specifying its
	value as Element_Type'Preelaborable_Initialization.
	(Cursor): Replace pragma P_I with the aspect (defaulting to
	True).
	* libgnat/a-cbhama.ads (Map): Replace pragma
	Preelaborable_Initialization with the aspect, specifying its
	value as (Element_Type'Preelaborable_Initialization and
	Key_Type'Preelaborable_Initialization).
	(Cursor): Replace pragma P_I with the aspect (defaulting to
	True).
	* libgnat/a-cborma.ads (Map): Replace pragma
	Preelaborable_Initialization with the aspect, specifying its
	value as (Element_Type'Preelaborable_Initialization and
	Key_Type'Preelaborable_Initialization).
	(Cursor): Replace pragma P_I with the aspect (defaulting to
	True).
	* libgnat/a-cbhase.ads (Set): Replace pragma
	Preelaborable_Initialization with the aspect, specifying its
	value as Element_Type'Preelaborable_Initialization.
	(Cursor): Replace pragma P_I with the aspect (defaulting to
	True).
	* libgnat/a-cborse.ads (Set): Replace pragma
	Preelaborable_Initialization with the aspect, specifying its
	value as Element_Type'Preelaborable_Initialization.
	(Cursor): Replace pragma P_I with the aspect (defaulting to
	True).
	* libgnat/a-cbmutr.ads (Tree): Replace pragma
	Preelaborable_Initialization with the aspect, specifying its
	value as Element_Type'Preelaborable_Initialization.
	(Cursor): Replace pragma P_I with the aspect (defaulting to
	True).
	* libgnat/a-coboho.ads (Holder): Replace pragma
	Preelaborable_Initialization with the aspect, specifying its
	value as Element_Type'Preelaborable_Initialization.
	(Cursor): Replace pragma P_I with the aspect (defaulting to
	True).
diff mbox series

Patch

diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads
--- a/gcc/ada/libgnat/a-cbdlli.ads
+++ b/gcc/ada/libgnat/a-cbdlli.ads
@@ -57,11 +57,11 @@  is
       Default_Iterator  => Iterate,
       Iterator_Element  => Element_Type,
       Aggregate         => (Empty        => Empty,
-                            Add_Unnamed  => Append);
-   pragma Preelaborable_Initialization (List);
+                            Add_Unnamed  => Append),
+      Preelaborable_Initialization
+                        => Element_Type'Preelaborable_Initialization;
 
-   type Cursor is private;
-   pragma Preelaborable_Initialization (Cursor);
+   type Cursor is private with Preelaborable_Initialization;
 
    Empty_List : constant List;
 


diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads
--- a/gcc/ada/libgnat/a-cbhama.ads
+++ b/gcc/ada/libgnat/a-cbhama.ads
@@ -59,12 +59,13 @@  is
       Default_Iterator  => Iterate,
       Iterator_Element  => Element_Type,
       Aggregate         => (Empty     => Empty,
-                            Add_Named => Insert);
+                            Add_Named => Insert),
+      Preelaborable_Initialization
+                        => Element_Type'Preelaborable_Initialization
+                             and
+                           Key_Type'Preelaborable_Initialization;
 
-   pragma Preelaborable_Initialization (Map);
-
-   type Cursor is private;
-   pragma Preelaborable_Initialization (Cursor);
+   type Cursor is private with Preelaborable_Initialization;
 
    Empty_Map : constant Map;
    --  Map objects declared without an initialization expression are


diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads
--- a/gcc/ada/libgnat/a-cbhase.ads
+++ b/gcc/ada/libgnat/a-cbhase.ads
@@ -61,12 +61,11 @@  is
           Default_Iterator  => Iterate,
           Iterator_Element  => Element_Type,
           Aggregate         => (Empty       => Empty,
-                                Add_Unnamed => Include);
+                                Add_Unnamed => Include),
+          Preelaborable_Initialization
+                            => Element_Type'Preelaborable_Initialization;
 
-   pragma Preelaborable_Initialization (Set);
-
-   type Cursor is private;
-   pragma Preelaborable_Initialization (Cursor);
+   type Cursor is private with Preelaborable_Initialization;
 
    Empty_Set : constant Set;
    --  Set objects declared without an initialization expression are


diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads
--- a/gcc/ada/libgnat/a-cbmutr.ads
+++ b/gcc/ada/libgnat/a-cbmutr.ads
@@ -53,11 +53,11 @@  is
      with Constant_Indexing => Constant_Reference,
           Variable_Indexing => Reference,
           Default_Iterator  => Iterate,
-          Iterator_Element  => Element_Type;
-   pragma Preelaborable_Initialization (Tree);
+          Iterator_Element  => Element_Type,
+          Preelaborable_Initialization
+                            => Element_Type'Preelaborable_Initialization;
 
-   type Cursor is private;
-   pragma Preelaborable_Initialization (Cursor);
+   type Cursor is private with Preelaborable_Initialization;
 
    Empty_Tree : constant Tree;
 


diff --git a/gcc/ada/libgnat/a-cborma.ads b/gcc/ada/libgnat/a-cborma.ads
--- a/gcc/ada/libgnat/a-cborma.ads
+++ b/gcc/ada/libgnat/a-cborma.ads
@@ -60,12 +60,13 @@  is
       Default_Iterator  => Iterate,
       Iterator_Element  => Element_Type,
       Aggregate         => (Empty     => Empty,
-                            Add_Named => Insert);
+                            Add_Named => Insert),
+      Preelaborable_Initialization
+                        => Element_Type'Preelaborable_Initialization
+                             and
+                           Key_Type'Preelaborable_Initialization;
 
-   pragma Preelaborable_Initialization (Map);
-
-   type Cursor is private;
-   pragma Preelaborable_Initialization (Cursor);
+   type Cursor is private with Preelaborable_Initialization;
 
    Empty_Map : constant Map;
 


diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads
--- a/gcc/ada/libgnat/a-cborse.ads
+++ b/gcc/ada/libgnat/a-cborse.ads
@@ -59,12 +59,11 @@  is
         Default_Iterator  => Iterate,
         Iterator_Element  => Element_Type,
         Aggregate         => (Empty       => Empty,
-                              Add_Unnamed => Include);
+                              Add_Unnamed => Include),
+        Preelaborable_Initialization
+                          => Element_Type'Preelaborable_Initialization;
 
-   pragma Preelaborable_Initialization (Set);
-
-   type Cursor is private;
-   pragma Preelaborable_Initialization (Cursor);
+   type Cursor is private with Preelaborable_Initialization;
 
    Empty_Set : constant Set;
 


diff --git a/gcc/ada/libgnat/a-coboho.ads b/gcc/ada/libgnat/a-coboho.ads
--- a/gcc/ada/libgnat/a-coboho.ads
+++ b/gcc/ada/libgnat/a-coboho.ads
@@ -70,7 +70,9 @@  package Ada.Containers.Bounded_Holders is
    --  System.Storage_Unit; e.g. creating Holders from 5-bit objects won't
    --  work.
 
-   type Holder is private;
+   type Holder is private
+     with Preelaborable_Initialization
+            => Element_Type'Preelaborable_Initialization;
 
    function "=" (Left, Right : Holder) return Boolean;
 


diff --git a/gcc/ada/libgnat/a-cobove.ads b/gcc/ada/libgnat/a-cobove.ads
--- a/gcc/ada/libgnat/a-cobove.ads
+++ b/gcc/ada/libgnat/a-cobove.ads
@@ -63,12 +63,11 @@  package Ada.Containers.Bounded_Vectors is
       Aggregate         => (Empty          => Empty,
                             Add_Unnamed    => Append,
                             New_Indexed    => New_Vector,
-                            Assign_Indexed => Replace_Element);
+                            Assign_Indexed => Replace_Element),
+      Preelaborable_Initialization
+                        => Element_Type'Preelaborable_Initialization;
 
-   pragma Preelaborable_Initialization (Vector);
-
-   type Cursor is private;
-   pragma Preelaborable_Initialization (Cursor);
+   type Cursor is private with Preelaborable_Initialization;
 
    Empty_Vector : constant Vector;
 


diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -1768,19 +1768,34 @@  package body Sem_Ch7 is
          end if;
 
          --  Check preelaborable initialization for full type completing a
-         --  private type when aspect Preelaborable_Initialization is True.
-         --  We pass True for the parameter Formal_Types_Have_Preelab_Init
-         --  to take into account the rule that presumes that subcomponents
-         --  of generic formal types mentioned in the type's P_I aspect have
-         --  preelaborable initialization (see RM 10.2.1(11.8/5)).
-
-         if Is_Type (E)
-           and then Must_Have_Preelab_Init (E)
-           and then not Has_Preelaborable_Initialization
-                          (E, Formal_Types_Have_Preelab_Init => True)
-         then
-            Error_Msg_N
-              ("full view of & does not have preelaborable initialization", E);
+         --  private type when aspect Preelaborable_Initialization is True
+         --  or is specified by Preelaborable_Initialization attributes
+         --  (in the case of a private type in a generic unit). We pass
+         --  the expression of the aspect (when present) to the parameter
+         --  Preelab_Init_Expr to take into account the rule that presumes
+         --  that subcomponents of generic formal types mentioned in the
+         --  type's P_I aspect have preelaborable initialization (see
+         --  AI12-0409 and RM 10.2.1(11.8/5)).
+
+         if Is_Type (E) and then Must_Have_Preelab_Init (E) then
+            declare
+               PI_Aspect : constant Node_Id :=
+                             Find_Aspect
+                               (E, Aspect_Preelaborable_Initialization);
+               PI_Expr   : Node_Id := Empty;
+            begin
+               if Present (PI_Aspect) then
+                  PI_Expr := Expression (PI_Aspect);
+               end if;
+
+               if not Has_Preelaborable_Initialization
+                        (E, Preelab_Init_Expr => PI_Expr)
+               then
+                  Error_Msg_N
+                    ("full view of & does not have "
+                     & "preelaborable initialization", E);
+               end if;
+            end;
          end if;
 
          Next_Entity (E);


diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -13331,8 +13331,8 @@  package body Sem_Util is
    --------------------------------------
 
    function Has_Preelaborable_Initialization
-     (E                              : Entity_Id;
-      Formal_Types_Have_Preelab_Init : Boolean := False) return Boolean
+     (E                 : Entity_Id;
+      Preelab_Init_Expr : Node_Id := Empty) return Boolean
    is
       Has_PE : Boolean;
 
@@ -13340,6 +13340,12 @@  package body Sem_Util is
       --  Check component/discriminant chain, sets Has_PE False if a component
       --  or discriminant does not meet the preelaborable initialization rules.
 
+      function Type_Named_In_Preelab_Init_Expression
+        (Typ  : Entity_Id;
+         Expr : Node_Id) return Boolean;
+      --  Returns True iff Typ'Preelaborable_Initialization occurs in Expr
+      --  (where Expr may be a conjunction of one or more P_I attributes).
+
       ----------------------
       -- Check_Components --
       ----------------------
@@ -13388,7 +13394,7 @@  package body Sem_Util is
 
             if No (Exp) then
                if not Has_Preelaborable_Initialization
-                        (Etype (Ent), Formal_Types_Have_Preelab_Init)
+                        (Etype (Ent), Preelab_Init_Expr)
                then
                   Has_PE := False;
                   exit;
@@ -13406,6 +13412,44 @@  package body Sem_Util is
          end loop;
       end Check_Components;
 
+      --------------------------------------
+      -- Type_Named_In_Preelab_Expression --
+      --------------------------------------
+
+      function Type_Named_In_Preelab_Init_Expression
+        (Typ  : Entity_Id;
+         Expr : Node_Id) return Boolean
+      is
+      begin
+         --  Return True if Expr is a Preelaborable_Initialization attribute
+         --  and the prefix is a subtype that has the same type as Typ.
+
+         if Nkind (Expr) = N_Attribute_Reference
+           and then Attribute_Name (Expr) = Name_Preelaborable_Initialization
+           and then Is_Entity_Name (Prefix (Expr))
+           and then Base_Type (Entity (Prefix (Expr))) = Base_Type (Typ)
+         then
+            return True;
+
+         --  In the case where Expr is a conjunction, test whether either
+         --  operand is a Preelaborable_Initialization attribute whose prefix
+         --  has the same type as Typ, and return True if so.
+
+         elsif Nkind (Expr) = N_Op_And
+           and then
+            (Type_Named_In_Preelab_Init_Expression (Typ, Left_Opnd (Expr))
+              or else
+             Type_Named_In_Preelab_Init_Expression (Typ, Right_Opnd (Expr)))
+         then
+            return True;
+
+         --  Typ not named in a Preelaborable_Initialization attribute of Expr
+
+         else
+            return False;
+         end if;
+      end Type_Named_In_Preelab_Init_Expression;
+
    --  Start of processing for Has_Preelaborable_Initialization
 
    begin
@@ -13436,7 +13480,7 @@  package body Sem_Util is
 
       elsif Is_Array_Type (E) then
          Has_PE := Has_Preelaborable_Initialization
-                     (Component_Type (E), Formal_Types_Have_Preelab_Init);
+                     (Component_Type (E), Preelab_Init_Expr);
 
       --  A derived type has preelaborable initialization if its parent type
       --  has preelaborable initialization and (in the case of a derived record
@@ -13451,7 +13495,11 @@  package body Sem_Util is
          --  of a generic formal derived type has preelaborable initialization.
          --  (See comment on spec of Has_Preelaborable_Initialization.)
 
-         if Is_Generic_Type (E) and then Formal_Types_Have_Preelab_Init then
+         if Is_Generic_Type (E)
+           and then Present (Preelab_Init_Expr)
+           and then
+             Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
+         then
             return True;
          end if;
 
@@ -13464,7 +13512,8 @@  package body Sem_Util is
 
          --  First check whether ancestor type has preelaborable initialization
 
-         Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
+         Has_PE := Has_Preelaborable_Initialization
+                     (Etype (Base_Type (E)), Preelab_Init_Expr);
 
          --  If OK, check extension components (if any)
 
@@ -13495,7 +13544,11 @@  package body Sem_Util is
          --  of a generic formal private type has preelaborable initialization.
          --  (See comment on spec of Has_Preelaborable_Initialization.)
 
-         if Is_Generic_Type (E) and then Formal_Types_Have_Preelab_Init then
+         if Is_Generic_Type (E)
+           and then Present (Preelab_Init_Expr)
+           and then
+             Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
+         then
             return True;
          else
             return False;


diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1526,17 +1526,15 @@  package Sem_Util is
    --  initialization.
 
    function Has_Preelaborable_Initialization
-     (E                              : Entity_Id;
-      Formal_Types_Have_Preelab_Init : Boolean := False) return Boolean;
+     (E                 : Entity_Id;
+      Preelab_Init_Expr : Node_Id := Empty) return Boolean;
    --  Return True iff type E has preelaborable initialization as defined in
    --  Ada 2005 (see AI-161 for details of the definition of this attribute).
-   --  If Formal_Types_Have_Preelab_Init is True, indicates that the function
-   --  should presume that for any subcomponents of formal private or derived
-   --  types, the types have preelaborable initialization (RM 10.2.1(11.8/5)).
-   --  NOTE: The treatment of subcomponents of formal types should only apply
-   --  for types actually specified in the P_I aspect of the outer type, but
-   --  for now we take a more liberal interpretation. This needs addressing,
-   --  perhaps by passing the outermost type instead of the simple flag. ???
+   --  If Preelab_Init_Expr is present, indicates that the function should
+   --  presume that for any subcomponent of E that is of a formal private or
+   --  derived type that is referenced by a Preelaborable_Initialization
+   --  attribute within the expression Preelab_Init_Expr, the formal type has
+   --  preelaborable initialization (RM 10.2.1(11.8/5) and AI12-0409).
 
    function Has_Prefix (N : Node_Id) return Boolean;
    --  Return True if N has attribute Prefix