From: Eric Botcazou <ebotca...@adacore.com>
Dynamically allocated objects of a constrained subtype of an unconstrained
array type with a controlled component type have not been properly finalized
since the first rewrite of the finalization machinery more than a decade
ago. The reason is that the Finalize_Address routine is that of the base
type, which is unconstrained, and thus requires the bounds, which are not
present for the subtype in the allocation.
This is fixed by setting Is_Constr_Array_Subt_With_Bounds for allocators the
same way it is set for object declarations. The rest is just refactoring.
gcc/ada/ChangeLog:
* exp_ch7.adb (Shift_Address_For_Descriptor): New function.
(Make_Address_For_Finalize): Call above function.
(Make_Finalize_Address_Stmts): Likewise.
* exp_util.ads (Is_Constr_Array_Subt_Of_Unc_With_Controlled): New
predicate.
* exp_util.adb (Is_Constr_Array_Subt_Of_Unc_With_Controlled): Ditto.
(Remove_Side_Effects): Call above predicate.
* sem_ch3.adb (Analyze_Object_Declaration): Likewise.
* sem_ch4.adb (Analyze_Allocator): Allocate the bounds by setting
Is_Constr_Array_Subt_With_Bounds when appropriate.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch7.adb | 140 +++++++++++++++++++------------------------
gcc/ada/exp_util.adb | 21 +++++--
gcc/ada/exp_util.ads | 5 ++
gcc/ada/sem_ch3.adb | 15 ++---
gcc/ada/sem_ch4.adb | 8 +++
5 files changed, 96 insertions(+), 93 deletions(-)
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 5fec6915997..9abdcc18a57 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -696,6 +696,15 @@ package body Exp_Ch7 is
-- Set the Finalize_Address primitive for the object that has been
-- attached to a finalization Master_Node.
+ function Shift_Address_For_Descriptor
+ (Addr : Node_Id;
+ Typ : Entity_Id;
+ Op_Nam : Name_Id) return Node_Id
+ with Pre => Is_Array_Type (Typ)
+ and then not Is_Constrained (Typ)
+ and then Op_Nam in Name_Op_Add | Name_Op_Subtract;
+ -- Add to Addr, or subtract from Addr, the size of the descriptor of Typ
+
----------------------------------
-- Attach_Object_To_Master_Node --
----------------------------------
@@ -5546,35 +5555,14 @@ package body Exp_Ch7 is
-- an object with a dope vector (see Make_Finalize_Address_Stmts).
-- This is achieved by setting Is_Constr_Array_Subt_With_Bounds,
-- but the address of the object is still that of its elements,
- -- so we need to shift it.
+ -- so we need to shift it back to skip the dope vector.
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 - (Utyp'Descriptor_Size / Storage_Unit)
-
Obj_Addr :=
- Make_Function_Call (Loc,
- Name =>
- Make_Expanded_Name (Loc,
- Chars => Name_Op_Subtract,
- Prefix =>
- New_Occurrence_Of
- (RTU_Entity (System_Storage_Elements), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Op_Subtract)),
- Parameter_Associations => New_List (
- Obj_Addr,
- Make_Op_Divide (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Utyp, Loc),
- Attribute_Name => Name_Descriptor_Size),
- Right_Opnd =>
- Make_Integer_Literal (Loc, System_Storage_Unit))));
+ Shift_Address_For_Descriptor
+ (Obj_Addr, First_Subtype (Utyp), Name_Op_Subtract);
end if;
return Obj_Addr;
@@ -8183,6 +8171,10 @@ package body Exp_Ch7 is
Ptr_Typ : Entity_Id;
begin
+ -- Array types: picking the (unconstrained) base type as designated type
+ -- requires allocating the bounds alongside the data, so we only do this
+ -- when the first subtype itself was declared as unconstrained.
+
if Is_Array_Type (Typ) then
if Is_Constrained (First_Subtype (Typ)) then
Desig_Typ := First_Subtype (Typ);
@@ -8278,63 +8270,18 @@ package body Exp_Ch7 is
-- lays in front of the elements and then use a thin pointer to perform
-- the address-to-access conversion.
- if Is_Array_Type (Typ)
- and then not Is_Constrained (First_Subtype (Typ))
- then
- declare
- Dope_Id : Entity_Id;
+ if Is_Array_Type (Typ) and then not Is_Constrained (Desig_Typ) then
+ Obj_Expr :=
+ Shift_Address_For_Descriptor (Obj_Expr, Desig_Typ, Name_Op_Add);
- begin
- -- Ensure that Ptr_Typ is a thin pointer; generate:
- -- for Ptr_Typ'Size use System.Address'Size;
+ -- Ensure that Ptr_Typ is a thin pointer; generate:
+ -- for Ptr_Typ'Size use System.Address'Size;
- Append_To (Decls,
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (Ptr_Typ, Loc),
- Chars => Name_Size,
- Expression =>
- Make_Integer_Literal (Loc, System_Address_Size)));
-
- -- Generate:
- -- Dnn : constant Storage_Offset :=
- -- Desig_Typ'Descriptor_Size / Storage_Unit;
-
- Dope_Id := Make_Temporary (Loc, 'D');
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Dope_Id,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
- Expression =>
- Make_Op_Divide (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Desig_Typ, Loc),
- Attribute_Name => Name_Descriptor_Size),
- Right_Opnd =>
- Make_Integer_Literal (Loc, System_Storage_Unit))));
-
- -- Shift the address from the start of the dope vector to the
- -- start of the elements:
- --
- -- V + Dnn
-
- Obj_Expr :=
- Make_Function_Call (Loc,
- Name =>
- Make_Expanded_Name (Loc,
- Chars => Name_Op_Add,
- Prefix =>
- New_Occurrence_Of
- (RTU_Entity (System_Storage_Elements), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Op_Add)),
- Parameter_Associations => New_List (
- Obj_Expr,
- New_Occurrence_Of (Dope_Id, Loc)));
- end;
+ Append_To (Decls,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (Ptr_Typ, Loc),
+ Chars => Name_Size,
+ Expression => Make_Integer_Literal (Loc, System_Address_Size)));
end if;
Fin_Call :=
@@ -8912,6 +8859,41 @@ package body Exp_Ch7 is
return Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped;
end Node_To_Be_Wrapped;
+ ----------------------------------
+ -- Shift_Address_For_Descriptor --
+ ----------------------------------
+
+ function Shift_Address_For_Descriptor
+ (Addr : Node_Id;
+ Typ : Entity_Id;
+ Op_Nam : Name_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Addr);
+
+ begin
+ -- Generate:
+ -- Addr +/- (Typ'Descriptor_Size / Storage_Unit)
+
+ return
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Expanded_Name (Loc,
+ Chars => Op_Nam,
+ Prefix =>
+ New_Occurrence_Of
+ (RTU_Entity (System_Storage_Elements), Loc),
+ Selector_Name => Make_Identifier (Loc, Op_Nam)),
+ Parameter_Associations => New_List (
+ Addr,
+ Make_Op_Divide (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Descriptor_Size),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, System_Storage_Unit))));
+ end Shift_Address_For_Descriptor;
+
----------------------------
-- Store_Actions_In_Scope --
----------------------------
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 811f9ab742f..90778910e99 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -8813,6 +8813,20 @@ package body Exp_Util is
end if;
end Is_Captured_Function_Call;
+ -------------------------------------------------
+ -- Is_Constr_Array_Subt_Of_Unc_With_Controlled --
+ -------------------------------------------------
+
+ function Is_Constr_Array_Subt_Of_Unc_With_Controlled (Typ : Entity_Id)
+ return Boolean
+ is
+ begin
+ return Is_Array_Type (Typ)
+ and then Is_Constrained (Typ)
+ and then Has_Controlled_Component (Typ)
+ and then not Is_Constrained (First_Subtype (Typ));
+ end Is_Constr_Array_Subt_Of_Unc_With_Controlled;
+
------------------------------------------
-- Is_Conversion_Or_Reference_To_Formal --
------------------------------------------
@@ -12868,11 +12882,8 @@ package body Exp_Util is
if Nkind (Exp) = N_Function_Call
and then (Is_Build_In_Place_Result_Type (Exp_Type)
- or else (Is_Array_Type (Exp_Type)
- and then Has_Controlled_Component (Exp_Type)
- and then Is_Constrained (Exp_Type)
- and then not
- Is_Constrained (First_Subtype (Exp_Type))))
+ or else
+ Is_Constr_Array_Subt_Of_Unc_With_Controlled (Exp_Type))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
and then not Is_Expression_Of_Func_Return (Exp)
then
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index f90acc5b0f5..b8b752523c3 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -816,6 +816,11 @@ package Exp_Util is
-- Rnn : constant Ann := Func (...)'reference;
-- Rnn.all
+ function Is_Constr_Array_Subt_Of_Unc_With_Controlled (Typ : Entity_Id)
+ return Boolean;
+ -- Return True if Typ is a constrained subtype of an array type with an
+ -- unconstrained first subtype and a controlled component type.
+
function Is_Conversion_Or_Reference_To_Formal (N : Node_Id) return Boolean;
-- Return True if N is a type conversion, or a dereference thereof, or a
-- reference to a formal parameter.
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index b39a3514031..2673874a6bf 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -5328,17 +5328,14 @@ package body Sem_Ch3 is
else
Validate_Controlled_Object (Id);
end if;
+ end if;
- -- If the type of a constrained array has an unconstrained first
- -- subtype, its Finalize_Address primitive expects the address of
- -- an object with a dope vector (see Make_Finalize_Address_Stmts).
+ -- If the type of a constrained array has an unconstrained first
+ -- subtype, its Finalize_Address primitive expects the address of
+ -- an object with a dope vector (see Make_Finalize_Address_Stmts).
- if Is_Array_Type (Etype (Id))
- and then Is_Constrained (Etype (Id))
- and then not Is_Constrained (First_Subtype (Etype (Id)))
- then
- Set_Is_Constr_Array_Subt_With_Bounds (Etype (Id));
- end if;
+ if Is_Constr_Array_Subt_Of_Unc_With_Controlled (Etype (Id)) then
+ Set_Is_Constr_Array_Subt_With_Bounds (Etype (Id));
end if;
if Has_Task (Etype (Id)) then
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index f5b05191035..dc814676675 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -834,6 +834,14 @@ package body Sem_Ch4 is
Error_Msg_N ("cannot allocate abstract object", E);
end if;
+ -- If the type of a constrained array has an unconstrained first
+ -- subtype, its Finalize_Address primitive expects the address of
+ -- an object with a dope vector (see Make_Finalize_Address_Stmts).
+
+ if Is_Constr_Array_Subt_Of_Unc_With_Controlled (Type_Id) then
+ Set_Is_Constr_Array_Subt_With_Bounds (Type_Id);
+ end if;
+
Set_Etype (N, Acc_Type);
-- If this is an allocator for the return stack, then no restriction may
--
2.43.0
