From: Ronan Desplanques Date: Wed, 9 Jul 2025 08:19:00 +0000 (+0200) Subject: ada: Fix generation of Initialize and Adjust calls X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=381d0146e71fb8066d4058083b535848746feec3;p=thirdparty%2Fgcc.git ada: Fix generation of Initialize and Adjust calls Before this patch, Make_Init_Call and Make_Adjust_Call made the assumption that if the type they were called with was untagged and a derived type, it was the untagged private view of a tagged type. That assumption made it possible to inspect the root type's primitives to handle the case where the underlying type was implicitly generated by the compiler without all inherited primitives. The introduction of the Finalizable aspect broke that assumption, so this patch adds a new field to type entities that make the generated full view stand out, and updates Make_Init_Call and Make_Adjust_Call to only jump to the root type when they're passed one of those generated types. Make_Final_Call and Finalize_Address are two other subprograms that perform the same test on the types they're passed. They did not suffer from the same bug as Make_Init_Call and Make_Adjust_Call because of an earlier, more ad hoc fix, but this patch switches them over to the newly introduced mechanism for the sake of consistency. gcc/ada/ChangeLog: * gen_il-fields.ads (Is_Implicit_Full_View): New field. * gen_il-gen-gen_entities.adb (Type_Kind): Use new field. * einfo.ads (Is_Implicit_Full_View): Document new field. * exp_ch7.adb (Make_Adjust_Call, Make_Init_Call, Make_Final_Call): Use new field. * exp_util.adb (Finalize_Address): Likewise. * sem_ch3.adb (Copy_And_Build): Set new field. --- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7c05e532aea..e3fcb13b649 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2781,6 +2781,10 @@ package Einfo is -- identifiers in standard library packages, and to implement the -- restriction No_Implementation_Identifiers. +-- Is_Implicit_Full_View +-- Defined in types. Set on types that the compiler generates to act as +-- full views of types that are derivations of private types. + -- Is_Imported -- Defined in all entities. Set if the entity is imported. For now we -- only allow the import of exceptions, functions, procedures, packages, diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 0f534af8a32..ea7af3e449c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -5598,7 +5598,10 @@ package body Exp_Ch7 is -- Deal with untagged derivation of private views - if Present (Utyp) and then Is_Untagged_Derivation (Typ) then + if Present (Utyp) + and then Is_Untagged_Derivation (Typ) + and then Is_Implicit_Full_View (Utyp) + then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); Ref := Unchecked_Convert_To (Utyp, Ref); Set_Assignment_OK (Ref); @@ -7906,16 +7909,12 @@ package body Exp_Ch7 is if Is_Untagged_Derivation (Typ) then if Is_Protected_Type (Typ) then Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); + elsif Is_Implicit_Full_View (Utyp) then + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); - else - declare - Root : constant Entity_Id := - Underlying_Type (Root_Type (Base_Type (Typ))); - begin - if Is_Protected_Type (Root) then - Utyp := Corresponding_Record_Type (Root); - end if; - end; + if Is_Protected_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; end if; Ref := Unchecked_Convert_To (Utyp, Ref); @@ -8480,7 +8479,10 @@ package body Exp_Ch7 is -- Deal with untagged derivation of private views - if Is_Untagged_Derivation (Typ) and then not Is_Conc then + if Is_Untagged_Derivation (Typ) + and then not Is_Conc + and then Is_Implicit_Full_View (Utyp) + then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); Ref := Unchecked_Convert_To (Utyp, Ref); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 3dcf98001ec..5f644ef2503 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6079,23 +6079,12 @@ package body Exp_Util is if Is_Protected_Type (Btyp) then Utyp := Corresponding_Record_Type (Root_Type (Btyp)); - else - declare - Root : constant Entity_Id := - Underlying_Type (Root_Type (Btyp)); - Prev_Utyp : Entity_Id := Empty; - begin - if Is_Protected_Type (Root) then - Utyp := Corresponding_Record_Type (Root); - else - while No (TSS (Utyp, TSS_Finalize_Address)) - and then Utyp /= Prev_Utyp - loop - Prev_Utyp := Utyp; - Utyp := Underlying_Type (Base_Type (Etype (Utyp))); - end loop; - end if; - end; + elsif Is_Implicit_Full_View (Utyp) then + Utyp := Underlying_Type (Root_Type (Btyp)); + + if Is_Protected_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; end if; end if; diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index c293e0fa63f..8c37f3fefa2 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -729,6 +729,7 @@ package Gen_IL.Fields is Is_Ignored_Ghost_Entity, Is_Immediately_Visible, Is_Implementation_Defined, + Is_Implicit_Full_View, Is_Imported, Is_Independent, Is_Initial_Condition_Procedure, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 37ddd851d7c..d81ff5c0240 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -505,6 +505,7 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Fixed_Lower_Bound_Array_Subtype, Flag), Sm (Is_Fixed_Lower_Bound_Index_Subtype, Flag), Sm (Is_Generic_Actual_Type, Flag), + Sm (Is_Implicit_Full_View, Flag), Sm (Is_Mutably_Tagged_Type, Flag), Sm (Is_Non_Static_Subtype, Flag), Sm (Is_Private_Composite, Flag), diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 794e4204d84..b68dcda4c54 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8387,15 +8387,17 @@ package body Sem_Ch3 is Set_Has_Private_Declaration (Full_Der); Set_Has_Private_Declaration (Derived_Type); - Set_Scope (Full_Der, Scope (Derived_Type)); - Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type)); - Set_Has_Size_Clause (Full_Der, False); - Set_Has_Alignment_Clause (Full_Der, False); - Set_Has_Delayed_Freeze (Full_Der); - Set_Is_Frozen (Full_Der, False); - Set_Freeze_Node (Full_Der, Empty); - Set_Depends_On_Private (Full_Der, Has_Private_Component (Full_Der)); - Set_Is_Public (Full_Der, Is_Public (Derived_Type)); + Set_Scope (Full_Der, Scope (Derived_Type)); + Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type)); + Set_Has_Size_Clause (Full_Der, False); + Set_Has_Alignment_Clause (Full_Der, False); + Set_Has_Delayed_Freeze (Full_Der); + Set_Is_Frozen (Full_Der, False); + Set_Freeze_Node (Full_Der, Empty); + Set_Depends_On_Private + (Full_Der, Has_Private_Component (Full_Der)); + Set_Is_Public (Full_Der, Is_Public (Derived_Type)); + Set_Is_Implicit_Full_View (Full_Der); -- The convention on the base type may be set in the private part -- and not propagated to the subtype until later, so we obtain the