diff options
-rw-r--r-- | gcc/ada/exp_ch7.adb | 13 | ||||
-rw-r--r-- | gcc/ada/exp_util.adb | 15 | ||||
-rw-r--r-- | gcc/ada/sem_res.adb | 14 | ||||
-rw-r--r-- | 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 2ac7310..e594a53 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -749,6 +749,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; @@ -787,6 +788,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 31cd47d..04d1146 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -936,6 +936,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 @@ -945,11 +955,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 8e9714c..075c0d8 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5679,19 +5679,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 0000000..189df46 --- /dev/null +++ b/gcc/testsuite/gnat.dg/access10.adb @@ -0,0 +1,58 @@ +-- PR ada/113893 +-- Testcase by Pascal Pignard <p.p11@orange.fr> + +-- { 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; |