From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1285) id 82E5A3858C62; Mon, 26 Feb 2024 12:24:40 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 82E5A3858C62 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1708950280; bh=Ib7qw/jQ9uSGLA0DIUqLHws49l03+5jFCWbvC/CfUAQ=; h=From:To:Subject:Date:From; b=yw8NeS+Wdi7nEa3wnk8KPdc7Ft/o+wVaoO5XHgY2uxLOiWDg4e/85zIm34mYMiYOj aSEXcLiAQrnjMX5HrQK0w5oK9S0WTS2M22iXLc4mXuIjuHf/IdC+CEk9k9/ZzThhaE rVAYLYSA0moylblkC+MJ67RNKhUGYaFJzlHs0npc= 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 r11-11255] Finalization of object allocated by anonymous access designating local type X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/releases/gcc-11 X-Git-Oldrev: 2cc402190cea1dd9d5280047117e264d4ac871c9 X-Git-Newrev: bbf799a972201e82f54ee17dc3bf7a093a98077a Message-Id: <20240226122440.82E5A3858C62@sourceware.org> Date: Mon, 26 Feb 2024 12:24:40 +0000 (GMT) List-Id: https://gcc.gnu.org/g:bbf799a972201e82f54ee17dc3bf7a093a98077a commit r11-11255-gbbf799a972201e82f54ee17dc3bf7a093a98077a Author: Eric Botcazou Date: Mon Feb 26 13:13:34 2024 +0100 Finalization of object allocated by anonymous access designating local type The finalization of objects dynamically allocated through an anonymous access type is deferred to the enclosing library unit in the current implementation and a warning is given on each of them. However this cannot be done if the designated type is local, because this would generate dangling references to the local finalization routine, so the finalization needs to be dropped in this case and the warning adjusted. gcc/ada/ PR ada/113893 * exp_ch7.adb (Build_Anonymous_Master): Do not build the master for a local designated type. * exp_util.adb (Build_Allocate_Deallocate_Proc): Force Needs_Fin to false if no finalization master is attached to an access type and assert that it is anonymous in this case. * sem_res.adb (Resolve_Allocator): Mention that the object might not be finalized at all in the warning given when the type is an anonymous access-to-controlled type. gcc/testsuite/ * gnat.dg/access10.adb: New test. Diff: --- gcc/ada/exp_ch7.adb | 13 +++++++++ gcc/ada/exp_util.adb | 15 ++++++---- gcc/ada/sem_res.adb | 14 ++++----- gcc/testsuite/gnat.dg/access10.adb | 58 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 88 insertions(+), 12 deletions(-) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 5d8ad7d505d6..99ac14ba54bb 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -802,6 +802,7 @@ package body Exp_Ch7 is Desig_Typ : Entity_Id; FM_Id : Entity_Id; Priv_View : Entity_Id; + Scop : Entity_Id; Unit_Decl : Node_Id; Unit_Id : Entity_Id; @@ -840,6 +841,18 @@ package body Exp_Ch7 is Desig_Typ := Priv_View; end if; + -- For a designated type not declared at library level, we cannot create + -- a finalization collection attached to an outer unit since this would + -- generate dangling references to the dynamic scope through access-to- + -- procedure values designating the local Finalize_Address primitive. + + Scop := Enclosing_Dynamic_Scope (Desig_Typ); + if Scop /= Standard_Standard + and then Scope_Depth (Scop) > Scope_Depth (Unit_Id) + then + return; + end if; + -- Determine whether the current semantic unit already has an anonymous -- master which services the designated type. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index cf4059a3d5c0..d35e94aa2535 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -856,6 +856,16 @@ package body Exp_Util is Needs_Finalization (Desig_Typ) and then not No_Heap_Finalization (Ptr_Typ); + -- The allocation/deallocation of a controlled object must be associated + -- with an attachment to/detachment from a finalization master, but the + -- implementation cannot guarantee this property for every anonymous + -- access tyoe, see Build_Anonymous_Collection. + + if Needs_Fin and then No (Finalization_Master (Ptr_Typ)) then + pragma Assert (Ekind (Ptr_Typ) = E_Anonymous_Access_Type); + Needs_Fin := False; + end if; + if Needs_Fin then -- Do nothing if the access type may never allocate / deallocate @@ -865,11 +875,6 @@ package body Exp_Util is return; end if; - -- The allocation / deallocation of a controlled object must be - -- chained on / detached from a finalization master. - - pragma Assert (Present (Finalization_Master (Ptr_Typ))); - -- The only other kind of allocation / deallocation supported by this -- routine is on / from a subpool. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f6e0eab84b7e..aa2a0019e506 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5574,19 +5574,19 @@ package body Sem_Res is Set_Is_Dynamic_Coextension (N, False); Set_Is_Static_Coextension (N, False); - -- Anonymous access-to-controlled objects are not finalized on - -- time because this involves run-time ownership and currently - -- this property is not available. In rare cases the object may - -- not be finalized at all. Warn on potential issues involving - -- anonymous access-to-controlled objects. + -- Objects allocated through anonymous access types are not + -- finalized on time because this involves run-time ownership + -- and currently this property is not available. In rare cases + -- the object might not be finalized at all. Warn on potential + -- issues involving anonymous access-to-controlled types. if Ekind (Typ) = E_Anonymous_Access_Type and then Is_Controlled_Active (Desig_T) then Error_Msg_N - ("??object designated by anonymous access object might " + ("??object designated by anonymous access value might " & "not be finalized until its enclosing library unit " - & "goes out of scope", N); + & "goes out of scope, or not be finalized at all", N); Error_Msg_N ("\use named access type instead", N); end if; end if; diff --git a/gcc/testsuite/gnat.dg/access10.adb b/gcc/testsuite/gnat.dg/access10.adb new file mode 100644 index 000000000000..189df464eefa --- /dev/null +++ b/gcc/testsuite/gnat.dg/access10.adb @@ -0,0 +1,58 @@ +-- PR ada/113893 +-- Testcase by Pascal Pignard + +-- { dg-do run } + +with Ada.Text_IO; +with Ada.Finalization; + +procedure Access10 is + + generic + type Element_Type is private; + with function Image (Item : Element_Type) return String is <>; + package Sanitize is + type Container is new Ada.Finalization.Controlled with record + Data : Element_Type; + end record; + overriding procedure Finalize (Object : in out Container); + end Sanitize; + + package body Sanitize is + overriding procedure Finalize (Object : in out Container) is + begin + Ada.Text_IO.Put_Line ("Current:" & Image (Object.Data)); + end Finalize; + end Sanitize; + + procedure Test01 is + package Float_Sanitized is new Sanitize (Float, Float'Image); + V : Float_Sanitized.Container; + C : constant Float_Sanitized.Container := + (Ada.Finalization.Controlled with 8.8); + A : access Float_Sanitized.Container := + new Float_Sanitized.Container'(Ada.Finalization.Controlled with 7.7); -- { dg-warning "not be finalized|named" } + AC : access constant Float_Sanitized.Container := + new Float_Sanitized.Container'(Ada.Finalization.Controlled with 6.6); -- { dg-warning "not be finalized|named" } + begin + V.Data := 9.9 + C.Data + A.Data; + Ada.Text_IO.Put_Line ("Value:" & Float'Image (V.Data)); + end Test01; + + procedure Test02 is + type Float_Sanitized is new Float; + V : Float_Sanitized; + C : constant Float_Sanitized := (8.8); + A : access Float_Sanitized := new Float_Sanitized'(7.7); + AC : access constant Float_Sanitized := new Float_Sanitized'(6.6); + begin + V := 9.9 + C + A.all; + Ada.Text_IO.Put_Line ("Value:" & Float_Sanitized'Image (V)); + end Test02; + +begin + Ada.Text_IO.Put_Line ("Test01:"); + Test01; + Ada.Text_IO.Put_Line ("Test02:"); + Test02; +end;