diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index 2ac731013512a11722d58c44e88ca5fbd985382b..e594a53424454a1829e4266b668ed377afe290de 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 31cd47de7d2f8ac12fe091af4676ac312b0d54e3..04d114694ab658395a33cf05da965313431eee9e 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 8e9714c1c86c59ae397fdf0d6cf1e09bbf7ad583..075c0d85ccd96a28fb4489e92a1b3730624558ba 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 0000000000000000000000000000000000000000..189df464eefa3c60c3687c34d12b46c3fdd5d9c4
--- /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;