https://gcc.gnu.org/g:ca0145281f9573781686cba821eceab7a659f750
commit r15-6137-gca0145281f9573781686cba821eceab7a659f750
Author: Eric Botcazou <ebotca...@adacore.com>
Date: Fri Nov 15 18:40:02 2024 +0100
ada: Fix wrong finalization with private unconstrained array type
The address passed to the routine attaching a controlled object to the
finalization master must be that of its dope vector for an object whose
nominal subtype is an unconstrained array type, but this is not the case
when this subtype has a private declaration.
gcc/ada/ChangeLog:
* exp_ch7.adb (Make_Address_For_Finalize): Look at the underlying
subtype to detect the unconstrained array type case.
* sprint.adb (Write_Itype) <E_Private_Subtype>: New case.
Diff:
---
gcc/ada/exp_ch7.adb | 10 ++++++----
gcc/ada/sprint.adb | 4 ++++
2 files changed, 10 insertions(+), 4 deletions(-)
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index d3cc6c70d974..be281e3519df 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -5514,6 +5514,8 @@ package body Exp_Ch7 is
Obj_Ref : Node_Id;
Obj_Typ : Entity_Id) return Node_Id
is
+ Utyp : constant Entity_Id := Underlying_Type (Obj_Typ);
+
Obj_Addr : Node_Id;
begin
@@ -5529,13 +5531,13 @@ package body Exp_Ch7 is
-- but the address of the object is still that of its elements,
-- so we need to shift it.
- if Is_Array_Type (Obj_Typ)
- and then not Is_Constrained (First_Subtype (Obj_Typ))
+ if Is_Array_Type (Utyp)
+ and then not Is_Constrained (First_Subtype (Utyp))
then
-- Shift the address from the start of the elements to the
-- start of the dope vector:
- -- V - (Obj_Typ'Descriptor_Size / Storage_Unit)
+ -- V - (Utyp'Descriptor_Size / Storage_Unit)
Obj_Addr :=
Make_Function_Call (Loc,
@@ -5552,7 +5554,7 @@ package body Exp_Ch7 is
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Obj_Typ, Loc),
+ Prefix => New_Occurrence_Of (Utyp, Loc),
Attribute_Name => Name_Descriptor_Size),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit))));
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 614bcc17b14e..67259b9831cf 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -4712,6 +4712,10 @@ package body Sprint is
Write_Str (");");
end;
+ when E_Private_Subtype =>
+ Write_Header (False);
+ Write_Name_With_Col_Check (Chars (Full_View (Typ)));
+
-- For all other Itypes, print a triple ? (fill in later
-- if needed).
