From ae035e3437c1ec7d96773b31e631ec121bb4153f Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sun, 17 Jul 2022 12:38:15 +0200 Subject: [Ada] Fix crash for Default_Initial_Condition on derived enumeration type This fixes a crash on the declaration of a private derived enumeration type with the Default_Initial_Condition aspect and in the process makes a couple of related adjustments: 1) removes the early freezing of implicit character and numeric base types and 2) fixes an oversight in the implementation of delayed representation aspects. gcc/ada/ * aspects.ads (Delaying Evaluation of Aspect): Fix typos. * exp_ch3.adb (Freeze_Type): Do not generate Invariant and DIC procedures for internal types. * exp_util.adb (Build_DIC_Procedure_Body): Adjust comment. * freeze.adb (Freeze_Entity): Call Inherit_Delayed_Rep_Aspects for subtypes and derived types only after the base or parent type has been frozen. Remove useless freezing for first subtype. (Freeze_Fixed_Point_Type): Call Inherit_Delayed_Rep_Aspects too. * layout.adb (Set_Elem_Alignment): Deal with private types. * sem_ch3.adb (Build_Derived_Enumeration_Type): Build the implicit base as an itype and do not insert its declaration in the tree. (Build_Derived_Numeric_Type): Do not freeze the implicit base. (Derived_Standard_Character): Likewise. (Constrain_Enumeration): Inherit the chain of representation items instead of replacing it. * sem_ch13.ads (Inherit_Aspects_At_Freeze_Point): Add ??? comment. (Inherit_Delayed_Rep_Aspects): Declare. * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Do not invoke Inherit_Delayed_Rep_Aspects. (Inherit_Aspects_At_Freeze_Point): Deal with private types. (Inherit_Delayed_Rep_Aspects): Move to library level. --- gcc/ada/aspects.ads | 6 +- gcc/ada/exp_ch3.adb | 7 +- gcc/ada/exp_util.adb | 2 +- gcc/ada/freeze.adb | 18 +- gcc/ada/layout.adb | 12 +- gcc/ada/sem_ch13.adb | 472 +++++++++++++++++++++++++-------------------------- gcc/ada/sem_ch13.ads | 30 ++++ gcc/ada/sem_ch3.adb | 83 +++------ 8 files changed, 319 insertions(+), 311 deletions(-) (limited to 'gcc') diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 6559cda..2edb608 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -822,11 +822,11 @@ package Aspects is -- set on the parent type if it has delayed representation aspects. This -- flag Has_Delayed_Rep_Aspects indicates that if we derive from this type -- we have to worry about making sure we inherit any delayed aspects. The - -- second flag is set on a derived type: May_Have_Inherited_Rep_Aspects + -- second flag is set on a derived type: May_Inherit_Delayed_Rep_Aspects -- is set if the parent type has Has_Delayed_Rep_Aspects set. - -- When we freeze a derived type, if the May_Have_Inherited_Rep_Aspects - -- flag is set, then we call Freeze.Inherit_Delayed_Rep_Aspects when + -- When we freeze a derived type, if the May_Inherit_Delayed_Rep_Aspects + -- flag is set, then we call Sem_Ch13.Inherit_Delayed_Rep_Aspects when -- the derived type is frozen, which deals with the necessary copying of -- information from the parent type, which must be frozen at that point -- (since freezing the derived type first freezes the parent type). diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 38552ef..eee5823 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -9182,9 +9182,12 @@ package body Exp_Ch3 is -- the runtime verification of all invariants that pertain to the type. -- This includes invariants on the partial and full view, inherited -- class-wide invariants from parent types or interfaces, and invariants - -- on array elements or record components. + -- on array elements or record components. But skip internal types. - if Is_Interface (Def_Id) then + if Is_Itype (Def_Id) then + null; + + elsif Is_Interface (Def_Id) then -- Interfaces are treated as the partial view of a private type in -- order to achieve uniformity with the general case. As a result, an diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 0a0ae93..2be81a5 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2042,7 +2042,7 @@ package body Exp_Util is elsif Is_Underlying_Full_View (Work_Typ) then return; - -- Use the first subtype when dealing with various base types + -- Use the first subtype when dealing with implicit base types elsif Is_Itype (Work_Typ) then Work_Typ := First_Subtype (Work_Typ); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index f970f91..52858e2 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6366,9 +6366,7 @@ package body Freeze is end; end if; - if Has_Delayed_Aspects (E) - or else May_Inherit_Delayed_Rep_Aspects (E) - then + if Has_Delayed_Aspects (E) then Analyze_Aspects_At_Freeze_Point (E); end if; @@ -6799,18 +6797,25 @@ package body Freeze is -- A subtype inherits all the type-related representation aspects -- from its parents (RM 13.1(8)). + if May_Inherit_Delayed_Rep_Aspects (E) then + Inherit_Delayed_Rep_Aspects (E); + end if; + Inherit_Aspects_At_Freeze_Point (E); -- For a derived type, freeze its parent type first (RM 13.14(15)) elsif Is_Derived_Type (E) then Freeze_And_Append (Etype (E), N, Result); - Freeze_And_Append (First_Subtype (Etype (E)), N, Result); -- A derived type inherits each type-related representation aspect -- of its parent type that was directly specified before the -- declaration of the derived type (RM 13.1(15)). + if May_Inherit_Delayed_Rep_Aspects (E) then + Inherit_Delayed_Rep_Aspects (E); + end if; + Inherit_Aspects_At_Freeze_Point (E); end if; @@ -9089,6 +9094,11 @@ package body Freeze is Set_Has_Delayed_Aspects (Ftyp, False); end if; + if May_Inherit_Delayed_Rep_Aspects (Ftyp) then + Inherit_Delayed_Rep_Aspects (Ftyp); + Set_May_Inherit_Delayed_Rep_Aspects (Ftyp, False); + end if; + -- Inherit the Small value from the first subtype in any case if Typ /= Ftyp then diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index b6cdee0..e4187dd 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -1053,8 +1053,6 @@ package body Layout is -- derived types. declare - FST : constant Entity_Id := First_Subtype (E); - function Has_Attribute_Clause (E : Entity_Id; Id : Attribute_Id) return Boolean; @@ -1072,7 +1070,17 @@ package body Layout is return Present (Get_Attribute_Definition_Clause (E, Id)); end Has_Attribute_Clause; + FST : Entity_Id; + begin + FST := First_Subtype (E); + + -- Deal with private types + + if Is_Private_Type (FST) then + FST := Full_View (FST); + end if; + -- If the alignment comes from a clause, then we respect it. -- Consider for example: diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a64a3cd..79add0b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -944,29 +944,6 @@ package body Sem_Ch13 is -- aspect node N for the given type (entity) of the aspect does not -- appear too late according to the rules in RM 13.1(9) and 13.1(10). - procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id); - -- As discussed in the spec of Aspects (see Aspect_Delay declaration), - -- a derived type can inherit aspects from its parent which have been - -- specified at the time of the derivation using an aspect, as in: - -- - -- type A is range 1 .. 10 - -- with Size => Not_Defined_Yet; - -- .. - -- type B is new A; - -- .. - -- Not_Defined_Yet : constant := 64; - -- - -- In this example, the Size of A is considered to be specified prior - -- to the derivation, and thus inherited, even though the value is not - -- known at the time of derivation. To deal with this, we use two entity - -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A - -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in - -- the derived type (B here). If this flag is set when the derived type - -- is frozen, then this procedure is called to ensure proper inheritance - -- of all delayed aspects from the parent type. The derived type is E, - -- the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first - -- aspect specification node in the Rep_Item chain for the parent type. - procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id); -- Given an aspect specification node ASN whose expression is an -- optional Boolean, this routines creates the corresponding pragma @@ -1084,199 +1061,6 @@ package body Sem_Ch13 is end if; end Check_Aspect_Too_Late; - --------------------------------- - -- Inherit_Delayed_Rep_Aspects -- - --------------------------------- - - procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is - A_Id : constant Aspect_Id := Get_Aspect_Id (ASN); - P : constant Entity_Id := Entity (ASN); - -- Entity for parent type - - N : Node_Id; - -- Item from Rep_Item chain - - A : Aspect_Id; - - begin - -- Loop through delayed aspects for the parent type - - N := ASN; - while Present (N) loop - if Nkind (N) = N_Aspect_Specification then - exit when Entity (N) /= P; - - if Is_Delayed_Aspect (N) then - A := Get_Aspect_Id (Chars (Identifier (N))); - - -- Process delayed rep aspect. For Boolean attributes it is - -- not possible to cancel an attribute once set (the attempt - -- to use an aspect with xxx => False is an error) for a - -- derived type. So for those cases, we do not have to check - -- if a clause has been given for the derived type, since it - -- is harmless to set it again if it is already set. - - case A is - - -- Alignment - - when Aspect_Alignment => - if not Has_Alignment_Clause (E) then - Set_Alignment (E, Alignment (P)); - end if; - - -- Atomic - - when Aspect_Atomic => - if Is_Atomic (P) then - Set_Is_Atomic (E); - end if; - - -- Atomic_Components - - when Aspect_Atomic_Components => - if Has_Atomic_Components (P) then - Set_Has_Atomic_Components (Base_Type (E)); - end if; - - -- Bit_Order - - when Aspect_Bit_Order => - if Is_Record_Type (E) - and then No (Get_Attribute_Definition_Clause - (E, Attribute_Bit_Order)) - and then Reverse_Bit_Order (P) - then - Set_Reverse_Bit_Order (Base_Type (E)); - end if; - - -- Component_Size - - when Aspect_Component_Size => - if Is_Array_Type (E) - and then not Has_Component_Size_Clause (E) - then - Set_Component_Size - (Base_Type (E), Component_Size (P)); - end if; - - -- Machine_Radix - - when Aspect_Machine_Radix => - if Is_Decimal_Fixed_Point_Type (E) - and then not Has_Machine_Radix_Clause (E) - then - Set_Machine_Radix_10 (E, Machine_Radix_10 (P)); - end if; - - -- Object_Size (also Size which also sets Object_Size) - - when Aspect_Object_Size - | Aspect_Size - => - if not Has_Size_Clause (E) - and then - No (Get_Attribute_Definition_Clause - (E, Attribute_Object_Size)) - then - Set_Esize (E, Esize (P)); - end if; - - -- Pack - - when Aspect_Pack => - if not Is_Packed (E) then - Set_Is_Packed (Base_Type (E)); - - if Is_Bit_Packed_Array (P) then - Set_Is_Bit_Packed_Array (Base_Type (E)); - Set_Packed_Array_Impl_Type - (E, Packed_Array_Impl_Type (P)); - end if; - end if; - - -- Scalar_Storage_Order - - when Aspect_Scalar_Storage_Order => - if (Is_Record_Type (E) or else Is_Array_Type (E)) - and then No (Get_Attribute_Definition_Clause - (E, Attribute_Scalar_Storage_Order)) - and then Reverse_Storage_Order (P) - then - Set_Reverse_Storage_Order (Base_Type (E)); - - -- Clear default SSO indications, since the aspect - -- overrides the default. - - Set_SSO_Set_Low_By_Default (Base_Type (E), False); - Set_SSO_Set_High_By_Default (Base_Type (E), False); - end if; - - -- Small - - when Aspect_Small => - if Is_Fixed_Point_Type (E) - and then not Has_Small_Clause (E) - then - Set_Small_Value (E, Small_Value (P)); - end if; - - -- Storage_Size - - when Aspect_Storage_Size => - if (Is_Access_Type (E) or else Is_Task_Type (E)) - and then not Has_Storage_Size_Clause (E) - then - Set_Storage_Size_Variable - (Base_Type (E), Storage_Size_Variable (P)); - end if; - - -- Value_Size - - when Aspect_Value_Size => - - -- Value_Size is never inherited, it is either set by - -- default, or it is explicitly set for the derived - -- type. So nothing to do here. - - null; - - -- Volatile - - when Aspect_Volatile => - if Is_Volatile (P) then - Set_Is_Volatile (E); - end if; - - -- Volatile_Full_Access (also Full_Access_Only) - - when Aspect_Volatile_Full_Access - | Aspect_Full_Access_Only - => - if Is_Volatile_Full_Access (P) then - Set_Is_Volatile_Full_Access (E); - end if; - - -- Volatile_Components - - when Aspect_Volatile_Components => - if Has_Volatile_Components (P) then - Set_Has_Volatile_Components (Base_Type (E)); - end if; - - -- That should be all the Rep Aspects - - when others => - pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect); - null; - end case; - end if; - end if; - - Next_Rep_Item (N); - end loop; - end Inherit_Delayed_Rep_Aspects; - ------------------------------------- -- Make_Pragma_From_Boolean_Aspect -- ------------------------------------- @@ -1600,15 +1384,6 @@ package body Sem_Ch13 is Next_Rep_Item (ASN); end loop; - -- This is where we inherit delayed rep aspects from our parent. Note - -- that if we fell out of the above loop with ASN non-empty, it means - -- we hit an aspect for an entity other than E, and it must be the - -- type from which we were derived. - - if May_Inherit_Delayed_Rep_Aspects (E) then - Inherit_Delayed_Rep_Aspects (ASN); - end if; - if In_Instance and then E /= Base_Type (E) and then Is_First_Subtype (E) @@ -13738,14 +13513,6 @@ package body Sem_Ch13 is -- representation aspect in the rep item chain of Typ, if any, isn't -- directly specified to Typ but to one of its parents. - -- ??? Note that, for now, just a limited number of representation - -- aspects have been inherited here so far. Many of them are - -- still inherited in Sem_Ch3. This will be fixed soon. Here is - -- a non- exhaustive list of aspects that likely also need to - -- be moved to this routine: Alignment, Component_Alignment, - -- Component_Size, Machine_Radix, Object_Size, Pack, Predicates, - -- Preelaborable_Initialization, RM_Size and Small. - -- In addition, Convention must be propagated from base type to subtype, -- because the subtype may have been declared on an incomplete view. @@ -13813,9 +13580,21 @@ package body Sem_Ch13 is and then not Has_Rep_Item (Typ, Name_Default_Component_Value, False) and then Has_Rep_Item (Typ, Name_Default_Component_Value) then - Set_Default_Aspect_Component_Value (Typ, - Default_Aspect_Component_Value - (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value)))); + declare + E : Entity_Id; + + begin + E := Entity (Get_Rep_Item (Typ, Name_Default_Component_Value)); + + -- Deal with private types + + if Is_Private_Type (E) then + E := Full_View (E); + end if; + + Set_Default_Aspect_Component_Value (Typ, + Default_Aspect_Component_Value (E)); + end; end if; -- Default_Value @@ -13826,9 +13605,21 @@ package body Sem_Ch13 is and then Has_Rep_Item (Typ, Name_Default_Value) then Set_Has_Default_Aspect (Typ); - Set_Default_Aspect_Value (Typ, - Default_Aspect_Value - (Entity (Get_Rep_Item (Typ, Name_Default_Value)))); + + declare + E : Entity_Id; + + begin + E := Entity (Get_Rep_Item (Typ, Name_Default_Value)); + + -- Deal with private types + + if Is_Private_Type (E) then + E := Full_View (E); + end if; + + Set_Default_Aspect_Value (Typ, Default_Aspect_Value (E)); + end; end if; -- Discard_Names @@ -13956,6 +13747,209 @@ package body Sem_Ch13 is end if; end Inherit_Aspects_At_Freeze_Point; + --------------------------------- + -- Inherit_Delayed_Rep_Aspects -- + --------------------------------- + + procedure Inherit_Delayed_Rep_Aspects (Typ : Entity_Id) is + A : Aspect_Id; + N : Node_Id; + P : Entity_Id; + + begin + -- Find the first aspect that has been inherited + + N := First_Rep_Item (Typ); + while Present (N) loop + if Nkind (N) = N_Aspect_Specification then + exit when Entity (N) /= Typ; + end if; + + Next_Rep_Item (N); + end loop; + + -- There must be one if we reach here + + pragma Assert (Present (N)); + P := Entity (N); + + -- Loop through delayed aspects for the parent type + + while Present (N) loop + if Nkind (N) = N_Aspect_Specification then + exit when Entity (N) /= P; + + if Is_Delayed_Aspect (N) then + A := Get_Aspect_Id (N); + + -- Process delayed rep aspect. For Boolean attributes it is + -- not possible to cancel an attribute once set (the attempt + -- to use an aspect with xxx => False is an error) for a + -- derived type. So for those cases, we do not have to check + -- if a clause has been given for the derived type, since it + -- is harmless to set it again if it is already set. + + case A is + + -- Alignment + + when Aspect_Alignment => + if not Has_Alignment_Clause (Typ) then + Set_Alignment (Typ, Alignment (P)); + end if; + + -- Atomic + + when Aspect_Atomic => + if Is_Atomic (P) then + Set_Is_Atomic (Typ); + end if; + + -- Atomic_Components + + when Aspect_Atomic_Components => + if Has_Atomic_Components (P) then + Set_Has_Atomic_Components (Base_Type (Typ)); + end if; + + -- Bit_Order + + when Aspect_Bit_Order => + if Is_Record_Type (Typ) + and then No (Get_Attribute_Definition_Clause + (Typ, Attribute_Bit_Order)) + and then Reverse_Bit_Order (P) + then + Set_Reverse_Bit_Order (Base_Type (Typ)); + end if; + + -- Component_Size + + when Aspect_Component_Size => + if Is_Array_Type (Typ) + and then not Has_Component_Size_Clause (Typ) + then + Set_Component_Size + (Base_Type (Typ), Component_Size (P)); + end if; + + -- Machine_Radix + + when Aspect_Machine_Radix => + if Is_Decimal_Fixed_Point_Type (Typ) + and then not Has_Machine_Radix_Clause (Typ) + then + Set_Machine_Radix_10 (Typ, Machine_Radix_10 (P)); + end if; + + -- Object_Size (also Size which also sets Object_Size) + + when Aspect_Object_Size + | Aspect_Size + => + if not Has_Size_Clause (Typ) + and then + No (Get_Attribute_Definition_Clause + (Typ, Attribute_Object_Size)) + then + Set_Esize (Typ, Esize (P)); + end if; + + -- Pack + + when Aspect_Pack => + if not Is_Packed (Typ) then + Set_Is_Packed (Base_Type (Typ)); + + if Is_Bit_Packed_Array (P) then + Set_Is_Bit_Packed_Array (Base_Type (Typ)); + Set_Packed_Array_Impl_Type + (Typ, Packed_Array_Impl_Type (P)); + end if; + end if; + + -- Scalar_Storage_Order + + when Aspect_Scalar_Storage_Order => + if (Is_Record_Type (Typ) or else Is_Array_Type (Typ)) + and then No (Get_Attribute_Definition_Clause + (Typ, Attribute_Scalar_Storage_Order)) + and then Reverse_Storage_Order (P) + then + Set_Reverse_Storage_Order (Base_Type (Typ)); + + -- Clear default SSO indications, since the aspect + -- overrides the default. + + Set_SSO_Set_Low_By_Default (Base_Type (Typ), False); + Set_SSO_Set_High_By_Default (Base_Type (Typ), False); + end if; + + -- Small + + when Aspect_Small => + if Is_Fixed_Point_Type (Typ) + and then not Has_Small_Clause (Typ) + then + Set_Small_Value (Typ, Small_Value (P)); + end if; + + -- Storage_Size + + when Aspect_Storage_Size => + if (Is_Access_Type (Typ) or else Is_Task_Type (Typ)) + and then not Has_Storage_Size_Clause (Typ) + then + Set_Storage_Size_Variable + (Base_Type (Typ), Storage_Size_Variable (P)); + end if; + + -- Value_Size + + when Aspect_Value_Size => + + -- Value_Size is never inherited, it is either set by + -- default, or it is explicitly set for the derived + -- type. So nothing to do here. + + null; + + -- Volatile + + when Aspect_Volatile => + if Is_Volatile (P) then + Set_Is_Volatile (Typ); + end if; + + -- Volatile_Full_Access (also Full_Access_Only) + + when Aspect_Volatile_Full_Access + | Aspect_Full_Access_Only + => + if Is_Volatile_Full_Access (P) then + Set_Is_Volatile_Full_Access (Typ); + end if; + + -- Volatile_Components + + when Aspect_Volatile_Components => + if Has_Volatile_Components (P) then + Set_Has_Volatile_Components (Base_Type (Typ)); + end if; + + -- That should be all the Rep Aspects + + when others => + pragma Assert (Aspect_Delay (A) /= Rep_Aspect); + null; + end case; + end if; + end if; + + Next_Rep_Item (N); + end loop; + end Inherit_Delayed_Rep_Aspects; + ---------------- -- Initialize -- ---------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index e0d84c9..1405f89 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -324,6 +324,36 @@ package Sem_Ch13 is -- Given an entity Typ that denotes a derived type or a subtype, this -- routine performs the inheritance of aspects at the freeze point. + -- ??? Note that, for now, just a limited number of representation aspects + -- have been inherited here so far. Many of them are still inherited in + -- Sem_Ch3 and need to be dealt with. Here is a non-exhaustive list of + -- aspects that likely also need to be moved to this routine: Alignment, + -- Component_Alignment, Component_Size, Machine_Radix, Object_Size, Pack, + -- Predicates, Preelaborable_Initialization, Size and Small. + + procedure Inherit_Delayed_Rep_Aspects (Typ : Entity_Id); + -- As discussed in the spec of Aspects (see Aspect_Delay declaration), + -- a derived type can inherit aspects from its parent which have been + -- specified at the time of the derivation using an aspect, as in: + -- + -- type A is range 1 .. 10 + -- with Size => Not_Defined_Yet; + -- .. + -- type B is new A; + -- .. + -- Not_Defined_Yet : constant := 64; + -- + -- In this example, the Size of A is considered to be specified prior + -- to the derivation, and thus inherited, even though the value is not + -- known at the time of derivation. To deal with this, we use two entity + -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A + -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in + -- the derived type (B here). If this flag is set when the derived type + -- is frozen, then this procedure is called to ensure proper inheritance + -- of all delayed aspects from the parent type. + + -- ??? Obviously we ought not to have two mechanisms to do the same thing + procedure Resolve_Aspect_Expressions (E : Entity_Id); -- Name resolution of an aspect expression happens at the end of the -- current declarative part or at the freeze point for the entity, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 223849c..00c2e67 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -7412,12 +7412,13 @@ package body Sem_Ch3 is Analyze (High_Bound (Range_Expression (Constraint (Indic)))); end if; - -- Introduce an implicit base type for the derived type even if there + -- Create an implicit base type for the derived type even if there -- is no constraint attached to it, since this seems closer to the - -- Ada semantics. Build a full type declaration tree for the derived - -- type using the implicit base type as the defining identifier. Then - -- build a subtype declaration tree which applies the constraint (if - -- any) have it replace the derived type declaration. + -- Ada semantics. Use an Itype like for the implicit base type of + -- other kinds of derived type, but build a full type declaration + -- for it so as to analyze the new literals properly. Then build a + -- subtype declaration tree which applies the constraint (if any) + -- and have it replace the derived type declaration. Literal := First_Literal (Parent_Type); Literals_List := New_List; @@ -7450,8 +7451,7 @@ package body Sem_Ch3 is end loop; Implicit_Base := - Make_Defining_Identifier (Sloc (Derived_Type), - Chars => New_External_Name (Chars (Derived_Type), 'B')); + Create_Itype (E_Enumeration_Type, N, Derived_Type, 'B'); -- Indicate the proper nature of the derived type. This must be done -- before analysis of the literals, to recognize cases when a literal @@ -7464,12 +7464,12 @@ package body Sem_Ch3 is Type_Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => Implicit_Base, - Discriminant_Specifications => No_List, Type_Definition => Make_Enumeration_Type_Definition (Loc, Literals_List)); - Mark_Rewrite_Insertion (Type_Decl); - Insert_Before (N, Type_Decl); + -- Do not insert the declarationn, just analyze it in the context + + Set_Parent (Type_Decl, Parent (N)); Analyze (Type_Decl); -- The anonymous base now has a full declaration, but this base @@ -7770,35 +7770,6 @@ package body Sem_Ch3 is -- must be converted to the derived type. Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); - - -- The implicit_base should be frozen when the derived type is frozen, - -- but note that it is used in the conversions of the bounds. For fixed - -- types we delay the determination of the bounds until the proper - -- freezing point. For other numeric types this is rejected by GCC, for - -- reasons that are currently unclear (???), so we choose to freeze the - -- implicit base now. In the case of integers and floating point types - -- this is harmless because subsequent representation clauses cannot - -- affect anything, but it is still baffling that we cannot use the - -- same mechanism for all derived numeric types. - - -- There is a further complication: actually some representation - -- clauses can affect the implicit base type. For example, attribute - -- definition clauses for stream-oriented attributes need to set the - -- corresponding TSS entries on the base type, and this normally - -- cannot be done after the base type is frozen, so the circuitry in - -- Sem_Ch13.New_Stream_Subprogram must account for this possibility - -- and not use Set_TSS in this case. - - -- There are also consequences for the case of delayed representation - -- aspects for some cases. For example, a Size aspect is delayed and - -- should not be evaluated to the freeze point. This early freezing - -- means that the size attribute evaluation happens too early??? - - if Is_Fixed_Point_Type (Parent_Type) then - Conditional_Delay (Implicit_Base, Parent_Type); - else - Freeze_Before (N, Implicit_Base); - end if; end Build_Derived_Numeric_Type; -------------------------------- @@ -14443,14 +14414,18 @@ package body Sem_Ch3 is begin Mutate_Ekind (Def_Id, E_Enumeration_Subtype); - Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); + Set_First_Literal (Def_Id, First_Literal (Base_Type (T))); + Set_Etype (Def_Id, Base_Type (T)); + Set_Size_Info (Def_Id, (T)); + Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); - Set_Etype (Def_Id, Base_Type (T)); - Set_Size_Info (Def_Id, (T)); - Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Is_Character_Type (Def_Id, Is_Character_Type (T)); + -- Inherit the chain of representation items instead of replacing it + -- because Build_Derived_Enumeration_Type rewrites the declaration of + -- the derived type as a subtype declaration and the former needs to + -- preserve existing representation items (see Build_Derived_Type). - Set_Scalar_Range_For_Subtype (Def_Id, Range_Expression (C), T); + Inherit_Rep_Item_Chain (Def_Id, T); Set_Discrete_RM_Size (Def_Id); end Constrain_Enumeration; @@ -16992,11 +16967,9 @@ package body Sem_Ch3 is Low_Bound => Lo, High_Bound => Hi)); - Conditional_Delay (Derived_Type, Parent_Type); - - Mutate_Ekind (Derived_Type, E_Enumeration_Subtype); - Set_Etype (Derived_Type, Implicit_Base); - Set_Size_Info (Derived_Type, Parent_Type); + Mutate_Ekind (Derived_Type, E_Enumeration_Subtype); + Set_Etype (Derived_Type, Implicit_Base); + Set_Size_Info (Derived_Type, Parent_Type); if not Known_RM_Size (Derived_Type) then Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); @@ -17015,16 +16988,6 @@ package body Sem_Ch3 is end if; Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc); - - -- Because the implicit base is used in the conversion of the bounds, we - -- have to freeze it now. This is similar to what is done for numeric - -- types, and it equally suspicious, but otherwise a nonstatic bound - -- will have a reference to an unfrozen type, which is rejected by Gigi - -- (???). This requires specific care for definition of stream - -- attributes. For details, see comments at the end of - -- Build_Derived_Numeric_Type. - - Freeze_Before (N, Implicit_Base); end Derived_Standard_Character; ------------------------------ -- cgit v1.1