https://gcc.gnu.org/g:6037cf8093eff77aa094ee759b3f3f02f31b9776
commit r16-2415-g6037cf8093eff77aa094ee759b3f3f02f31b9776
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 11e3dd0254e4..b23cd9e8c27c 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -2787,6 +2787,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 5d406a3416a2..9b88491d58f1 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -5601,7 +5601,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);
@@ -7909,16 +7912,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);
@@ -8483,7 +8482,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 769e0c01c243..5a6fca081a69 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6189,23 +6189,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 18edec26742c..dd4b1a081b30 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -733,6 +733,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 44995452b10a..e05d8b50430b 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -502,6 +502,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 227dda25d042..55d2795f2b12 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -8452,15 +8452,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
