From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1285) id 9D3383875425; Wed, 27 Sep 2023 08:28:26 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 9D3383875425 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1695803306; bh=XHeseqsLvlOkwDMeqrIxdI5BFuw12/BH/z4dfVInuPc=; h=From:To:Subject:Date:From; b=xISU64eLmzZFOq9gJyavaChMLemN6YJuvEuQC+eGxNDGQwshjCJtC0U3+YdBa4j37 1fDp1yIHwBfH3stVWYWw7p4Ukh8zQNzzUXiqp9ZFrqvr/zKbDSnCz7CWmjJXXlyH9p yihK1ji59DWw6k8tBTj8tVYFTRUpVLLNZC2SbYpA= MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Eric Botcazou To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-7905] ada: Fix premature finalization in loop over limited iterable container X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/releases/gcc-13 X-Git-Oldrev: 7657ee448e247b9be548408ca69f31b9f10cd646 X-Git-Newrev: dfbca296ef561124d9931d6ceeaca5b21ab1d17e Message-Id: <20230927082826.9D3383875425@sourceware.org> Date: Wed, 27 Sep 2023 08:28:26 +0000 (GMT) List-Id: https://gcc.gnu.org/g:dfbca296ef561124d9931d6ceeaca5b21ab1d17e commit r13-7905-gdfbca296ef561124d9931d6ceeaca5b21ab1d17e Author: Eric Botcazou 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