https://gcc.gnu.org/g:5bd03021271731b4260d06571e868f91740188d1

commit r15-9890-g5bd03021271731b4260d06571e868f91740188d1
Author: Eric Botcazou <ebotca...@adacore.com>
Date:   Tue May 6 19:03:19 2025 +0200

    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:
---
 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 5fec6915997d..9abdcc18a57c 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 2510b3f1f9b0..4fc0135e0bde 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -8703,6 +8703,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 --
    ------------------------------------------
@@ -12759,11 +12773,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 f90acc5b0f51..b8b752523c3c 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 e94b0434b90e..8246e6c9643f 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -5326,17 +5326,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 4b403e628581..835e61e3ab03 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -835,6 +835,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

Reply via email to