https://gcc.gnu.org/g:381d0146e71fb8066d4058083b535848746feec3
commit r15-10055-g381d0146e71fb8066d4058083b535848746feec3
Author: Ronan Desplanques <desplanq...@adacore.com>
Date: Wed Jul 9 10:19:00 2025 +0200
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:
---
gcc/ada/einfo.ads | 4 ++++
gcc/ada/exp_ch7.adb | 24 +++++++++++++-----------
gcc/ada/exp_util.adb | 23 ++++++-----------------
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_entities.adb | 1 +
gcc/ada/sem_ch3.adb | 20 +++++++++++---------
6 files changed, 36 insertions(+), 37 deletions(-)
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 7c05e532aea7..e3fcb13b649c 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 0f534af8a32f..ea7af3e449c2 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 3dcf98001eca..5f644ef2503c 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 c293e0fa63fb..8c37f3fefa27 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 37ddd851d7c3..d81ff5c02406 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 794e4204d842..b68dcda4c549 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
