From 70aec3a1b8efd09a951e4d52f396345a740879d3 Mon Sep 17 00:00:00 2001 From: Gary Dismukes Date: Wed, 1 Sep 2021 19:58:14 -0400 Subject: [PATCH] [Ada] Completion of support for AI12-0409 (attribute Preelaborable_Initialization) 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). --- gcc/ada/libgnat/a-cbdlli.ads | 8 +++--- gcc/ada/libgnat/a-cbhama.ads | 11 ++++---- gcc/ada/libgnat/a-cbhase.ads | 9 +++--- gcc/ada/libgnat/a-cbmutr.ads | 8 +++--- gcc/ada/libgnat/a-cborma.ads | 11 ++++---- gcc/ada/libgnat/a-cborse.ads | 9 +++--- gcc/ada/libgnat/a-coboho.ads | 4 ++- gcc/ada/libgnat/a-cobove.ads | 9 +++--- gcc/ada/sem_ch7.adb | 41 ++++++++++++++++++--------- gcc/ada/sem_util.adb | 67 +++++++++++++++++++++++++++++++++++++++----- gcc/ada/sem_util.ads | 16 +++++------ 11 files changed, 130 insertions(+), 63 deletions(-) diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads index ab55086..f4086ea 100644 --- 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 index 8be64c8..cdd4135 100644 --- 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 index 92926c1..78b31cf 100644 --- 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 index c7e221a..3712039 100644 --- 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 index f87522a..9d40a51 100644 --- 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 index 06bd20f..31b8b91 100644 --- 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 index 086f194..44269f0 100644 --- 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 index 67c4419..5f3e1a7 100644 --- 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 index 095bcda..3852a9a 100644 --- 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 index dfd2504..e5f3589 100644 --- 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 index 7a77715..63f1d6b 100644 --- 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 -- 2.7.4