From: Eric Botcazou <ebotca...@adacore.com>
This fixes a regression introduced by the overhaul of the implementation
of finalization. When the first subtype of an array type is declared as
constrained, the Finalize_Address primitive of the base type synthesized
by the compiler is tailored to this first subtype, which means that this
primitive cannot be used for other subtypes of the array type, which may
for example be generated when an aggregate is assigned to a slice of an
object of the first subtype.
The straightforward solution would be to synthesize the Finalize_Address
primitive for the base type instead, but its clean implementation would
require changing the way allocators are implemented to always allocate
the bounds alongside the data, which may turn out to be delicate.
This instead changes the compiler to synthesize a local Finalize_Address
primitive in the problematic cases, which should be rare in practice, and
also contains a fixlet for Find_Last_Init, which fails to get to the base
type again in the indirect case and, therefore, mishandles array subtypes.
gcc/ada/
* exp_ch7.adb (Attach_Object_To_Master_Node): Fix formatting.
(Build_Finalizer.Process_Object_Declaration): Synthesize a local
Finalize_Address primitive if the object's subtype is an array
that has a constrained first subtype and is not this first subtype.
* exp_util.adb (Find_Last_Init): Get again to the base type in the
indirect case.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch7.adb | 115 ++++++++++++++++++++++++++++++++++---------
gcc/ada/exp_util.adb | 2 +-
2 files changed, 93 insertions(+), 24 deletions(-)
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index b34b4c967fb..eacdd17fc4c 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -839,7 +839,7 @@ package body Exp_Ch7 is
and then Needs_BIP_Collection (Func_Id)
then
declare
- Ptr_Typ : constant Node_Id := Make_Temporary (Loc, 'P');
+ Ptr_Typ : constant Node_Id := Make_Temporary (Loc, 'P');
Param : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_V);
@@ -861,27 +861,26 @@ package body Exp_Ch7 is
Fin_Body :=
Make_Subprogram_Body (Loc,
Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Fin_Id,
-
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Param,
- Parameter_Type =>
- New_Occurrence_Of (RTE (RE_Address), Loc)))),
-
- Declarations => New_List (
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Typ,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Occurrence_Of (Obj_Typ, Loc)))),
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Fin_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Param,
+ Parameter_Type =>
+ New_Occurrence_Of (RTE (RE_Address), Loc)))),
+
+ Declarations => New_List (
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Obj_Typ, Loc)))),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Fin_Stmts));
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Fin_Stmts));
Insert_After_And_Analyze
(Master_Node_Ins, Fin_Body, Suppress => All_Checks);
@@ -2652,7 +2651,7 @@ package body Exp_Ch7 is
-- Processing for simple protected objects. Such objects require
-- manual finalization of their lock managers. Generate:
- -- procedure obj_type_nnFD (v :system__address) is
+ -- procedure obj_typ_nnFD (v : system__address) is
-- type Ptr_Typ is access all Obj_Typ;
-- Rnn : Obj_Typ renames Ptr_Typ!(v).all;
-- begin
@@ -2661,7 +2660,7 @@ package body Exp_Ch7 is
-- exception
-- when others =>
-- null;
- -- end obj_type_nnFD;
+ -- end obj_typ_nnFD;
if Is_Protected
or else (Has_Simple_Protected_Object (Obj_Typ)
@@ -2758,6 +2757,76 @@ package body Exp_Ch7 is
Master_Node_Ins := Fin_Body;
end;
+ -- If the object's subtype is an array that has a constrained first
+ -- subtype and is not this first subtype, we need to build a special
+ -- Finalize_Address primitive for the object's subtype because the
+ -- Finalize_Address primitive of the base type has been tailored to
+ -- the first subtype (see Make_Finalize_Address_Stmts). Generate:
+
+ -- procedure obj_typ_nnFD (v : system__address) is
+ -- type Ptr_Typ is access all Obj_Typ;
+ -- begin
+ -- obj_typBDF (Ptr_Typ!(v).all, f => true);
+ -- end obj_typ_nnFD;
+
+ elsif Is_Array_Type (Etype (Obj_Id))
+ and then Is_Constrained (First_Subtype (Etype (Obj_Id)))
+ and then Etype (Obj_Id) /= First_Subtype (Etype (Obj_Id))
+ then
+ declare
+ Ptr_Typ : constant Node_Id := Make_Temporary (Loc, 'P');
+ Param : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_V);
+
+ Fin_Body : Node_Id;
+
+ begin
+ Obj_Typ := Etype (Obj_Id);
+
+ Fin_Id :=
+ Make_Defining_Identifier (Loc,
+ Make_TSS_Name_Local
+ (Obj_Typ, TSS_Finalize_Address));
+
+ Fin_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Fin_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Param,
+ Parameter_Type =>
+ New_Occurrence_Of (RTE (RE_Address), Loc)))),
+
+ Declarations => New_List (
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Occurrence_Of (Obj_Typ, Loc)))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Ptr_Typ,
+ Make_Identifier (Loc, Name_V))),
+ Typ => Obj_Typ))));
+
+ Push_Scope (Scope (Obj_Id));
+ Insert_After_And_Analyze
+ (Master_Node_Ins, Fin_Body, Suppress => All_Checks);
+ Pop_Scope;
+
+ Master_Node_Ins := Fin_Body;
+ end;
+
else
Fin_Id := Finalize_Address (Obj_Typ);
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 6e2168a80e9..3307f816d15 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6433,7 +6433,7 @@ package body Exp_Util is
Obj_Typ := Base_Type (Etype (Obj_Id));
if Is_Access_Type (Obj_Typ) then
- Obj_Typ := Available_View (Designated_Type (Obj_Typ));
+ Obj_Typ := Base_Type (Available_View (Designated_Type (Obj_Typ)));
end if;
-- Handle the initialization type of the object declaration
--
2.45.1
