From: Eric Botcazou <ebotca...@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
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 d3cc6c70d97..be281e3519d 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 614bcc17b14..67259b9831c 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).
--
2.43.0
