This patch adds a warning to alert the user to the fact that GNAT currently
mishandles finalization of anonymous access-to-controlled objects and that
they may not be finalized or deallocated within their respective scope.
------------
-- Source --
------------
-- main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Sessions;
procedure Main is
procedure Nested is
package S is new Sessions;
C : access S.C_Type := new S.C_Type;
-- Workaround:
--type Ptr is access all S.C_Type;
--C : Ptr := new S.C_Type;
begin
null;
end Nested;
begin
Nested;
Put_Line ("After nested, before global finalize");
end Main;
-- sessions.ads
with Ada.Finalization;
generic
package Sessions is
type C_Type is new Ada.Finalization.Controlled with null record;
procedure Finalize (Self : in out C_Type);
end Sessions;
-- sessions.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Sessions is
procedure Finalize (Self : in out C_Type) is
begin
Put_Line ("Finalize called");
end Finalize;
end Sessions;
----------------------------
-- Compilation and output --
----------------------------
& gnatmake -gnatws -q main.adb
& main
main.adb:7:30: warning: anonymous access-to-controlled object will be
finalized when its enclosing unit goes out of scope
After nested, before global finalize
raised PROGRAM_ERROR : main.adb:4 finalize/adjust raised exception
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
2017-11-09 Justin Squirek <squi...@adacore.com>
* sem_res.adb (Resolve_Allocator): Add warning messages corresponding
to the allocation of an anonymous access-to-controlled object.
gcc/testsuite/
2017-11-09 Pierre-Marie de Rodat <dero...@adacore.com>
* gnat.dg/controlled2.adb, gnat.dg/controlled4.adb, gnat.dg/finalized.adb:
Disable the new warning from GNAT.
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 254566)
+++ sem_res.adb (working copy)
@@ -5161,11 +5161,11 @@
(Parent (Associated_Node_For_Itype (Typ))))
then
Error_Msg_N
- ("info: coextension will not be finalized when its "
+ ("??coextension will not be finalized when its "
& "associated owner is finalized", N);
else
Error_Msg_N
- ("info: coextension will not be finalized when its "
+ ("??coextension will not be finalized when its "
& "associated owner is deallocated", N);
end if;
else
@@ -5174,12 +5174,12 @@
(Parent (Associated_Node_For_Itype (Typ))))
then
Error_Msg_N
- ("info: coextension will not be deallocated when its "
- & "associated owner is finalized", N);
+ ("??coextension will not be deallocated when "
+ & "its associated owner is finalized", N);
else
Error_Msg_N
- ("info: coextension will not be deallocated when its "
- & "associated owner is deallocated", N);
+ ("??coextension will not be deallocated when "
+ & "its associated owner is deallocated", N);
end if;
end if;
end if;
@@ -5189,6 +5189,19 @@
else
Set_Is_Dynamic_Coextension (N, False);
Set_Is_Static_Coextension (N, False);
+
+ -- ??? It seems we also do not properly finalize anonymous
+ -- access-to-controlled objects within their declared scope and
+ -- instead finalize them with their associated unit. Warn the
+ -- user about it here.
+
+ if Ekind (Typ) = E_Anonymous_Access_Type
+ and then Is_Controlled_Active (Desig_T)
+ then
+ Error_Msg_N ("??anonymous access-to-controlled object will "
+ & "be finalized when its enclosing unit goes out "
+ & "of scope", N);
+ end if;
end if;
end if;
Index: ../testsuite/gnat.dg/controlled2.adb
===================================================================
--- ../testsuite/gnat.dg/controlled2.adb (revision 254563)
+++ ../testsuite/gnat.dg/controlled2.adb (working copy)
@@ -1,5 +1,8 @@
-- { dg-do compile }
+pragma Warnings
+ (Off, "anonymous access-to-controlled object will be finalized when its
enclosing unit goes out of scope");
+
with controlled1; use controlled1;
package body controlled2 is
procedure Test_Suite is
Index: ../testsuite/gnat.dg/controlled4.adb
===================================================================
--- ../testsuite/gnat.dg/controlled4.adb (revision 254563)
+++ ../testsuite/gnat.dg/controlled4.adb (working copy)
@@ -1,5 +1,8 @@
-- { dg-do compile }
+pragma Warnings
+ (Off, "anonymous access-to-controlled object will be finalized when its
enclosing unit goes out of scope");
+
package body controlled4 is
procedure Test_Suite is
begin
Index: ../testsuite/gnat.dg/finalized.adb
===================================================================
--- ../testsuite/gnat.dg/finalized.adb (revision 254563)
+++ ../testsuite/gnat.dg/finalized.adb (working copy)
@@ -1,5 +1,8 @@
-- { dg-do compile }
+pragma Warnings
+ (Off, "anonymous access-to-controlled object will be finalized when its
enclosing unit goes out of scope");
+
with Ada.Finalization; use Ada.Finalization;
procedure finalized is
type Rec is new Controlled with null record;
