ada: Fix wrong finalization of constrained subtype of unconstrained array type

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.

diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 5fec6915997da4a2b56bc023f41e33276e6fad82..9abdcc18a57c7ed287fe5cc6162f96b641a5824d 100644 (file)
--- 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 811f9ab742f3c6c632740ed66b043214577ee613..90778910e997117237a2341ae1db236d88d64941 100644 (file)
--- 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 f90acc5b0f51ff17f576e249a36bd0e6eaa2da07..b8b752523c3cb9b9112ab8e753159dcef5bce28f 100644 (file)
--- 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 b39a35140314430d83e9e9e06e4ff1ccb707c0e1..2673874a6bf5cd54a0390999372754037173137f 100644 (file)
--- 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 f5b0519103530798513bfee3aa19146c81c4e64a..dc814676675db9579ac838ab44bac28b28d44743 100644 (file)
--- 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