diff options
-rw-r--r-- | gcc/ada/exp_attr.adb | 15 | ||||
-rw-r--r-- | gcc/ada/exp_disp.adb | 29 | ||||
-rw-r--r-- | gcc/ada/sem_attr.adb | 93 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 11 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 42 | ||||
-rw-r--r-- | gcc/ada/sem_ch7.adb | 9 | ||||
-rw-r--r-- | gcc/ada/sem_util.adb | 101 | ||||
-rw-r--r-- | gcc/ada/sem_util.ads | 22 | ||||
-rw-r--r-- | gcc/ada/snames.adb-tmpl | 3 | ||||
-rw-r--r-- | gcc/ada/snames.ads-tmpl | 27 |
10 files changed, 295 insertions, 57 deletions
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index fc6b0ef..e86cb8f 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5530,6 +5530,21 @@ package body Exp_Attr is end if; end Pred; + ---------------------------------- + -- Preelaborable_Initialization -- + ---------------------------------- + + when Attribute_Preelaborable_Initialization => + + -- This attribute should already be folded during analysis, but if + -- for some reason it hasn't been, we fold it now. + + Fold_Uint + (N, + UI_From_Int + (Boolean'Pos (Has_Preelaborable_Initialization (Ptyp))), + Static => False); + -------------- -- Priority -- -------------- diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index e9d6e74..4db883c 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -93,10 +93,6 @@ package body Exp_Disp is -- Duplicate_Subexpr with an explicit dereference when From is an access -- parameter. - function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; - -- Check if the type has a private view or if the public view appears in - -- the visible part of a package spec. - function Prim_Op_Kind (Prim : Entity_Id; Typ : Entity_Id) return Node_Id; @@ -7394,31 +7390,6 @@ package body Exp_Disp is end if; end New_Value; - ----------------------------------- - -- Original_View_In_Visible_Part -- - ----------------------------------- - - function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean is - Scop : constant Entity_Id := Scope (Typ); - - begin - -- The scope must be a package - - if not Is_Package_Or_Generic_Package (Scop) then - return False; - end if; - - -- A type with a private declaration has a private view declared in - -- the visible part. - - if Has_Private_Declaration (Typ) then - return True; - end if; - - return List_Containing (Parent (Typ)) = - Visible_Declarations (Package_Specification (Scop)); - end Original_View_In_Visible_Part; - ------------------ -- Prim_Op_Kind -- ------------------ diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index d1a91d8..e37b61a 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -175,6 +175,7 @@ package body Sem_Attr is Attribute_22 : constant Attribute_Class_Array := Attribute_Class_Array'( Attribute_Enum_Rep | Attribute_Enum_Val => True, + Attribute_Preelaborable_Initialization => True, others => False); -- The following array contains all attributes that imply a modification @@ -5408,6 +5409,45 @@ package body Sem_Attr is end if; end if; + ---------------------------------- + -- Preelaborable_Initialization -- + ---------------------------------- + + when Attribute_Preelaborable_Initialization => + Check_E0; + Check_Type; + + -- If we're in an instance, we know that the legality of the + -- attribute prefix type was already checked in the generic. + + if not In_Instance then + + -- If the prefix type is a generic formal type, then it must be + -- either a formal private type or a formal derived type. + + if Is_Generic_Type (P_Type) then + if not Is_Private_Type (P_Type) + and then not Is_Derived_Type (P_Type) + then + Error_Attr_P ("formal type prefix of % attribute must be " + & "formal private or formal derived type"); + end if; + + -- Otherwise, the prefix type must be a nonformal composite + -- type declared within the visible part of a package or + -- generic package. + + elsif not Is_Composite_Type (P_Type) + or else not Original_View_In_Visible_Part (P_Type) + then + Error_Attr_P + ("prefix of % attribute must be composite type declared " + & "in visible part of a package or generic package"); + end if; + end if; + + Set_Etype (N, Standard_Boolean); + -------------- -- Priority -- -------------- @@ -8182,15 +8222,16 @@ package body Sem_Attr is -- is to say if we are within an instantiation. Same processing applies -- to selected GNAT attributes. - elsif (Id = Attribute_Atomic_Always_Lock_Free or else - Id = Attribute_Definite or else - Id = Attribute_Descriptor_Size or else - Id = Attribute_Has_Access_Values or else - Id = Attribute_Has_Discriminants or else - Id = Attribute_Has_Tagged_Values or else - Id = Attribute_Lock_Free or else - Id = Attribute_Type_Class or else - Id = Attribute_Unconstrained_Array or else + elsif (Id = Attribute_Atomic_Always_Lock_Free or else + Id = Attribute_Definite or else + Id = Attribute_Descriptor_Size or else + Id = Attribute_Has_Access_Values or else + Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values or else + Id = Attribute_Lock_Free or else + Id = Attribute_Preelaborable_Initialization or else + Id = Attribute_Type_Class or else + Id = Attribute_Unconstrained_Array or else Id = Attribute_Max_Alignment_For_Allocation) and then not Is_Generic_Type (P_Entity) then @@ -8315,15 +8356,20 @@ package body Sem_Attr is -- unconstrained arrays. Furthermore, it is essential to fold this -- in the packed case, since otherwise the value will be incorrect. - elsif Id = Attribute_Atomic_Always_Lock_Free or else - Id = Attribute_Definite or else - Id = Attribute_Descriptor_Size or else - Id = Attribute_Has_Access_Values or else - Id = Attribute_Has_Discriminants or else - Id = Attribute_Has_Tagged_Values or else - Id = Attribute_Lock_Free or else - Id = Attribute_Type_Class or else - Id = Attribute_Unconstrained_Array or else + -- Folding can also be done for Preelaborable_Initialization based on + -- whether the prefix type has preelaborable initialization, even though + -- the attribute is nonstatic. + + elsif Id = Attribute_Atomic_Always_Lock_Free or else + Id = Attribute_Definite or else + Id = Attribute_Descriptor_Size or else + Id = Attribute_Has_Access_Values or else + Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values or else + Id = Attribute_Lock_Free or else + Id = Attribute_Preelaborable_Initialization or else + Id = Attribute_Type_Class or else + Id = Attribute_Unconstrained_Array or else Id = Attribute_Component_Size then Static := False; @@ -9609,6 +9655,17 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (E1) - 1, Static); end if; + ---------------------------------- + -- Preelaborable_Initialization -- + ---------------------------------- + + when Attribute_Preelaborable_Initialization => + Fold_Uint + (N, + UI_From_Int + (Boolean'Pos (Has_Preelaborable_Initialization (P_Type))), + Static); + ----------- -- Range -- ----------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 76859c5..db6a4a4 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1455,9 +1455,17 @@ package body Sem_Ch13 is -- Aspect Full_Access_Only must be analyzed last so that -- aspects Volatile and Atomic, if any, are analyzed. + -- Skip creation of pragma Preelaborable_Initialization + -- in the case where the aspect has an expression, + -- because the pragma is only needed for setting flag + -- Known_To_Have_Preelab_Init, which is set by other + -- means following resolution of the aspect expression. + if A_Id not in Aspect_Export | Aspect_Full_Access_Only | Aspect_Import + and then (A_Id /= Aspect_Preelaborable_Initialization + or else not Present (Expression (ASN))) then Make_Pragma_From_Boolean_Aspect (ASN); end if; @@ -2915,6 +2923,7 @@ package body Sem_Ch13 is | Aspect_Async_Writers | Aspect_Effective_Reads | Aspect_Effective_Writes + | Aspect_Preelaborable_Initialization then Error_Msg_Name_1 := Nam; @@ -2951,6 +2960,7 @@ package body Sem_Ch13 is | Aspect_Async_Writers | Aspect_Effective_Reads | Aspect_Effective_Writes + | Aspect_Preelaborable_Initialization then Error_Msg_N ("aspect % not allowed for formal type declaration", @@ -13700,6 +13710,7 @@ package body Sem_Ch13 is | Attribute_Iterable | Attribute_Iterator_Element | Attribute_Output + | Attribute_Put_Image | Attribute_Read | Attribute_Variable_Indexing | Attribute_Write; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index dbcb0ba..c0983f5 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2648,6 +2648,48 @@ package body Sem_Ch3 is E := First_Entity (Current_Scope); while Present (E) loop Resolve_Aspect_Expressions (E); + + -- Now that the aspect expressions have been resolved, if this is + -- at the end of the visible declarations, we can set the flag + -- Known_To_Have_Preelab_Init properly on types declared in the + -- visible part, which is needed for checking whether full types + -- in the private part satisfy the Preelaborable_Initialization + -- aspect of the partial view. We can't wait for the creation of + -- the pragma by Analyze_Aspects_At_Freeze_Point, because the + -- freeze point may occur after the end of the package declaration + -- (in the case of nested packages). + + if Is_Type (E) + and then L = Visible_Declarations (Parent (L)) + and then Has_Aspect (E, Aspect_Preelaborable_Initialization) + then + declare + ASN : constant Node_Id := + Find_Aspect (E, Aspect_Preelaborable_Initialization); + Expr : constant Node_Id := Expression (ASN); + begin + -- Set Known_To_Have_Preelab_Init to True if aspect has no + -- expression, or if the expression is True (or was folded + -- to True), or if the expression is a conjunction of one or + -- more Preelaborable_Initialization attributes applied to + -- formal types and wasn't folded to False. (Note that + -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes goes to + -- Original_Node if needed, hence test for Standard_False.) + + if not Present (Expr) + or else (Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_True) + or else + (Is_Conjunction_Of_Formal_Preelab_Init_Attributes (Expr) + and then + not (Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False)) + then + Set_Known_To_Have_Preelab_Init (E); + end if; + end; + end if; + Next_Entity (E); end loop; end Resolve_Aspects; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index f30a9aa..30eade2 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1768,11 +1768,16 @@ package body Sem_Ch7 is end if; -- Check preelaborable initialization for full type completing a - -- private type for which pragma Preelaborable_Initialization given. + -- 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) + 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); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 01a4e2b..78cf674 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13399,7 +13399,10 @@ package body Sem_Util is -- Has_Preelaborable_Initialization -- -------------------------------------- - function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is + function Has_Preelaborable_Initialization + (E : Entity_Id; + Formal_Types_Have_Preelab_Init : Boolean := False) return Boolean + is Has_PE : Boolean; procedure Check_Components (E : Entity_Id); @@ -13453,7 +13456,9 @@ package body Sem_Util is -- component type has PI. if No (Exp) then - if not Has_Preelaborable_Initialization (Etype (Ent)) then + if not Has_Preelaborable_Initialization + (Etype (Ent), Formal_Types_Have_Preelab_Init) + then Has_PE := False; exit; end if; @@ -13499,7 +13504,8 @@ package body Sem_Util is -- Array types have PI if the component type has PI elsif Is_Array_Type (E) then - Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); + Has_PE := Has_Preelaborable_Initialization + (Component_Type (E), Formal_Types_Have_Preelab_Init); -- A derived type has preelaborable initialization if its parent type -- has preelaborable initialization and (in the case of a derived record @@ -13510,6 +13516,14 @@ package body Sem_Util is elsif Is_Derived_Type (E) then + -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component + -- 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 + return True; + end if; + -- If the derived type is a private extension then it doesn't have -- preelaborable initialization. @@ -13545,7 +13559,16 @@ package body Sem_Util is -- have preelaborable initialization. elsif Is_Private_Type (E) then - return False; + + -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component + -- 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 + return True; + else + return False; + end if; -- Record type has PI if it is non private and all components have PI @@ -16277,6 +16300,49 @@ package body Sem_Util is or else Is_Task_Interface (T); end Is_Concurrent_Interface; + ------------------------------------------------------ + -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes -- + ------------------------------------------------------ + + function Is_Conjunction_Of_Formal_Preelab_Init_Attributes + (Expr : Node_Id) return Boolean + is + + function Is_Formal_Preelab_Init_Attribute + (N : Node_Id) return Boolean; + -- Returns True if N is a Preelaborable_Initialization attribute + -- applied to a generic formal type, or N's Original_Node is such + -- an attribute. + + -------------------------------------- + -- Is_Formal_Preelab_Init_Attribute -- + -------------------------------------- + + function Is_Formal_Preelab_Init_Attribute + (N : Node_Id) return Boolean + is + Orig_N : constant Node_Id := Original_Node (N); + + begin + return Nkind (Orig_N) = N_Attribute_Reference + and then Attribute_Name (Orig_N) = Name_Preelaborable_Initialization + and then Is_Entity_Name (Prefix (Orig_N)) + and then Is_Generic_Type (Entity (Prefix (Orig_N))); + end Is_Formal_Preelab_Init_Attribute; + + -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes + + begin + return Is_Formal_Preelab_Init_Attribute (Expr) + or else (Nkind (Expr) = N_Op_And + and then + Is_Conjunction_Of_Formal_Preelab_Init_Attributes + (Left_Opnd (Expr)) + and then + Is_Conjunction_Of_Formal_Preelab_Init_Attributes + (Right_Opnd (Expr))); + end Is_Conjunction_Of_Formal_Preelab_Init_Attributes; + ----------------------- -- Is_Constant_Bound -- ----------------------- @@ -25996,6 +26062,33 @@ package body Sem_Util is end if; end Original_Corresponding_Operation; + ----------------------------------- + -- Original_View_In_Visible_Part -- + ----------------------------------- + + function Original_View_In_Visible_Part + (Typ : Entity_Id) return Boolean + is + Scop : constant Entity_Id := Scope (Typ); + + begin + -- The scope must be a package + + if not Is_Package_Or_Generic_Package (Scop) then + return False; + end if; + + -- A type with a private declaration has a private view declared in + -- the visible part. + + if Has_Private_Declaration (Typ) then + return True; + end if; + + return List_Containing (Parent (Typ)) = + Visible_Declarations (Package_Specification (Scop)); + end Original_View_In_Visible_Part; + ------------------- -- Output_Entity -- ------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b0d6a2a..2c5b2866 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1530,9 +1530,18 @@ package Sem_Util is -- non-null), which causes the type to not have preelaborable -- initialization. - function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; + function Has_Preelaborable_Initialization + (E : Entity_Id; + Formal_Types_Have_Preelab_Init : Boolean := False) 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. ??? function Has_Prefix (N : Node_Id) return Boolean; -- Return True if N has attribute Prefix @@ -1828,6 +1837,13 @@ package Sem_Util is -- Returns true if the two specifications of the given -- nonoverridable aspect are compatible. + function Is_Conjunction_Of_Formal_Preelab_Init_Attributes + (Expr : Node_Id) return Boolean; + -- Returns True if Expr is a Preelaborable_Initialization attribute applied + -- to a formal type, or a sequence of two or more such attributes connected + -- by "and" operators, or if the Original_Node of Expr or its constituents + -- is such an attribute. + function Is_Constant_Bound (Exp : Node_Id) return Boolean; -- Exp is the expression for an array bound. Determines whether the -- bound is a compile-time known value, or a constant entity, or an @@ -2845,6 +2861,10 @@ package Sem_Util is -- corresponding operation of S is the original corresponding operation of -- S2. Otherwise, it is S itself. + function Original_View_In_Visible_Part (Typ : Entity_Id) return Boolean; + -- Returns True if the type Typ has a private view or if the public view + -- appears in the visible part of a package spec. + procedure Output_Entity (Id : Entity_Id); -- Print entity Id to standard output. The name of the entity appears in -- fully qualified form. diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl index a1ea3ee..8701ea9 100644 --- a/gcc/ada/snames.adb-tmpl +++ b/gcc/ada/snames.adb-tmpl @@ -258,6 +258,8 @@ package body Snames is return Pragma_Interrupt_Priority; when Name_Lock_Free => return Pragma_Lock_Free; + when Name_Preelaborable_Initialization => + return Pragma_Preelaborable_Initialization; when Name_Priority => return Pragma_Priority; when Name_Secondary_Stack_Size => @@ -488,6 +490,7 @@ package body Snames is or else N = Name_Interface or else N = Name_Interrupt_Priority or else N = Name_Lock_Free + or else N = Name_Preelaborable_Initialization or else N = Name_Priority or else N = Name_Secondary_Stack_Size or else N = Name_Storage_Size diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index a67623b..34f1cef 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -37,6 +37,17 @@ package Snames is -- some exceptions). See the body of Get_Attribute_Id for details. The -- same is true of other enumeration types declared in this package. + -- ALSO NOTE: In the case of a name that corresponds to both an attribute + -- and a pragma, the Name_Id must be defined in the attribute section + -- (between First_Attribute_Name and Last_Attribute_Name). Also, please + -- add a comment in the list of Name_Ids at the point where the name would + -- normally appear alphabetically (for an example, see comment starting + -- "Note: CPU ..."). The Pragma_Id with that name must be defined in the + -- last section of literals for type Pragma_Id (see set of Pragma_Ids that + -- require special processing due to matching an attribute name). Finally, + -- the bodies of functions Get_Pragma_Id and Is_Pragma_Name must be updated + -- to test for each such pragma that shares a name with an attribute. + ------------------ -- Preset Names -- ------------------ @@ -624,7 +635,13 @@ package Snames is Name_Precondition : constant Name_Id := N + $; -- GNAT Name_Predicate : constant Name_Id := N + $; -- GNAT Name_Predicate_Failure : constant Name_Id := N + $; -- Ada 12 - Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 05 + + -- Note: Preelaborable_Initialization is not in this list because its name + -- matches the name of the corresponding attribute. However, it is included + -- in the definition of the type Pragma_Id, and the functions Get_Pragma_Id + -- and Is_Pragma_Name correctly recognize and process that pragma name. + -- Preelaborable_Initialization is a standard Ada 2005 pragma. + Name_Preelaborate : constant Name_Id := N + $; Name_Pre_Class : constant Name_Id := N + $; -- GNAT @@ -1007,6 +1024,7 @@ package Snames is Name_Pool_Address : constant Name_Id := N + $; -- GNAT Name_Pos : constant Name_Id := N + $; Name_Position : constant Name_Id := N + $; + Name_Preelaborable_Initialization : constant Name_Id := N + $; -- Ada 22 Name_Priority : constant Name_Id := N + $; -- Ada 05 Name_Range : constant Name_Id := N + $; Name_Range_Length : constant Name_Id := N + $; -- GNAT @@ -1536,6 +1554,7 @@ package Snames is Attribute_Pool_Address, Attribute_Pos, Attribute_Position, + Attribute_Preelaborable_Initialization, Attribute_Priority, Attribute_Range, Attribute_Range_Length, @@ -1921,7 +1940,6 @@ package Snames is Pragma_Precondition, Pragma_Predicate, Pragma_Predicate_Failure, - Pragma_Preelaborable_Initialization, Pragma_Preelaborate, Pragma_Pre_Class, Pragma_Provide_Shift_Operators, @@ -1974,7 +1992,9 @@ package Snames is -- The following pragmas are on their own, out of order, because of the -- special processing required to deal with the fact that their names - -- match existing attribute names. + -- match existing attribute names. Note that when a pragma is added in + -- this section, functions Get_Pragma_Id and Is_Pragma_Name must be + -- updated to account for the new pragma. Pragma_CPU, Pragma_Default_Scalar_Storage_Order, @@ -1983,6 +2003,7 @@ package Snames is Pragma_Interface, Pragma_Interrupt_Priority, Pragma_Lock_Free, + Pragma_Preelaborable_Initialization, Pragma_Priority, Pragma_Secondary_Stack_Size, Pragma_Storage_Size, |