[gcc r13-7905] ada: Fix premature finalization in loop over limited iterable container

[gcc r13-7905] ada: Fix premature finalization in loop over limited iterable container

[Eric Botcazou]

https://gcc.gnu.org/g:dfbca296ef561124d9931d6ceeaca5b21ab1d17e

commit r13-7905-gdfbca296ef561124d9931d6ceeaca5b21ab1d17e
Author: Eric Botcazou <ebotcazou@adacore.com>
Date:   Fri Aug 25 10:47:30 2023 +0200

    ada: Fix premature finalization in loop over limited iterable container
    
    This happens when the iterable container is obtained as the result of a
    call to a function that is a subprogram parameter of a generic construct.
    
    gcc/ada/
    
            * exp_util.adb (Initialized_By_Aliased_BIP_Func_Call): Make the name
            matching more robust.

Diff:
---
 gcc/ada/exp_util.adb | 88 ++++++++++++++++++++++++++++------------------------
 1 file changed, 48 insertions(+), 40 deletions(-)

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 52c5753ab93..6ae671c43a6 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -8340,65 +8340,73 @@ package body Exp_Util is
 
          Call := Unqual_Conv (Call);
 
+         --  We search for a formal with a matching suffix. We can't search
+         --  for the full name, because of the code at the end of Sem_Ch6.-
+         --  Create_Extra_Formals, which copies the Extra_Formals over to
+         --  the Alias of an instance, which will cause the formals to have
+         --  "incorrect" names. See also Exp_Ch6.Build_In_Place_Formal.
+
          if Is_Build_In_Place_Function_Call (Call) then
             declare
                Caller_Allocation_Val : constant Uint :=
                  UI_From_Int (BIP_Allocation_Form'Pos (Caller_Allocation));
+               Access_Suffix         : constant String :=
+                 BIP_Formal_Suffix (BIP_Object_Access);
+               Alloc_Suffix          : constant String :=
+                 BIP_Formal_Suffix (BIP_Alloc_Form);
+
+               function Has_Suffix (Name, Suffix : String) return Boolean;
+               --  Return True if Name has suffix Suffix
+
+               ----------------
+               -- Has_Suffix --
+               ----------------
+
+               function Has_Suffix (Name, Suffix : String) return Boolean is
+                  Len : constant Natural := Suffix'Length;
+
+               begin
+                  return Name'Length > Len
+                    and then Name (Name'Last - Len + 1 .. Name'Last) = Suffix;
+               end Has_Suffix;
 
-               Access_Nam : Name_Id := No_Name;
                Access_OK  : Boolean := False;
-               Actual     : Node_Id;
-               Alloc_Nam  : Name_Id := No_Name;
                Alloc_OK   : Boolean := True;
-               Formal     : Node_Id;
-               Func_Id    : Entity_Id;
                Param      : Node_Id;
 
             begin
                --  Examine all parameter associations of the function call
 
                Param := First (Parameter_Associations (Call));
+
                while Present (Param) loop
                   if Nkind (Param) = N_Parameter_Association
                     and then Nkind (Selector_Name (Param)) = N_Identifier
                   then
-                     Actual := Explicit_Actual_Parameter (Param);
-                     Formal := Selector_Name (Param);
-
-                     --  Construct the names of formals BIPaccess and BIPalloc
-                     --  using the function name retrieved from an arbitrary
-                     --  formal.
-
-                     if Access_Nam = No_Name
-                       and then Alloc_Nam = No_Name
-                       and then Present (Entity (Formal))
-                     then
-                        Func_Id := Scope (Entity (Formal));
-
-                        Access_Nam :=
-                          New_External_Name (Chars (Func_Id),
-                            BIP_Formal_Suffix (BIP_Object_Access));
-
-                        Alloc_Nam :=
-                          New_External_Name (Chars (Func_Id),
-                            BIP_Formal_Suffix (BIP_Alloc_Form));
-                     end if;
+                     declare
+                        Actual : constant Node_Id
+                          := Explicit_Actual_Parameter (Param);
+                        Formal : constant Node_Id
+                          := Selector_Name (Param);
+                        Name   : constant String
+                          := Get_Name_String (Chars (Formal));
 
-                     --  A nonnull BIPaccess has been found
+                     begin
+                        --  A nonnull BIPaccess has been found
 
-                     if Chars (Formal) = Access_Nam
-                       and then Nkind (Actual) /= N_Null
-                     then
-                        Access_OK := True;
-                     end if;
+                        if Has_Suffix (Name, Access_Suffix)
+                          and then Nkind (Actual) /= N_Null
+                        then
+                           Access_OK := True;
 
-                     --  A BIPalloc has been found
+                        --  A BIPalloc has been found
 
-                     if Chars (Formal) = Alloc_Nam
-                       and then Nkind (Actual) = N_Integer_Literal
-                     then
-                        Alloc_OK := Intval (Actual) = Caller_Allocation_Val;
-                     end if;
+                        elsif Has_Suffix (Name, Alloc_Suffix)
+                          and then Nkind (Actual) = N_Integer_Literal
+                        then
+                           Alloc_OK := Intval (Actual) = Caller_Allocation_Val;
+                        end if;
+                     end;
                   end if;
 
                   Next (Param);
@@ -8615,7 +8623,7 @@ package body Exp_Util is
             --  first parameter is the transient. Such a call appears as:
 
             --     It : Access_To_Constant_Reference_Type :=
-            --            Constant_Indexing (Tran_Id.all, ...)'reference;
+            --            Constant_Indexing (Trans_Id.all, ...)'reference;
 
             Stmt := First_Stmt;
             while Present (Stmt) loop
@@ -8700,7 +8708,7 @@ package body Exp_Util is
             --  first parameter is the transient. Such a call appears as:
 
             --     It : Access_To_CW_Iterator :=
-            --            Iterate (Tran_Id.all, ...)'reference;
+            --            Iterate (Trans_Id.all, ...)'reference;
 
             Stmt := First_Stmt;
             while Present (Stmt) loop