This patch adds an informational warning to alert the user to the fact that
GNAT currently mishandles coextensions and that they will not be finalized or
deallocated with their respective owners in some as they should according
to RM 13.11.2 (9/3).
------------
-- Source --
------------
-- types.ads
with Ada.Finalization; use Ada.Finalization;
package Types is
type Ctrl_Discr is new Controlled with record
Id : Natural;
end record;
type Ctrl_Discr_Ptr is access all Ctrl_Discr;
procedure Finalize (Obj : in out Ctrl_Discr);
procedure Initialize (Obj : in out Ctrl_Discr);
type Discr_B is null record;
type Discr_B_Ptr is access all Discr_B;
type Ctrl_Owner_B (Discr : access Discr_B) is new Controlled with record
Id : Natural;
end record;
type Ctrl_Owner_B_Ptr is access all Ctrl_Owner_B;
procedure Finalize (Obj : in out Ctrl_Owner_B);
procedure Initialize (Obj : in out Ctrl_Owner_B);
type Ctrl_Owner (Discr : access Ctrl_Discr) is new Controlled with record
Id : Natural;
end record;
type Ctrl_Owner_Ptr is access all Ctrl_Owner;
procedure Finalize (Obj : in out Ctrl_Owner);
procedure Initialize (Obj : in out Ctrl_Owner);
type Owner (Discr : access Ctrl_Discr) is null record;
type Owner_Ptr is access all Owner;
type Owner_B (Discr : access Discr_B) is null record;
type Owner_B_Ptr is access all Owner_B;
function New_Id return Natural;
end Types;
-- types.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Types is
Id_Gen : Natural := 0;
procedure Finalize (Obj : in out Ctrl_Discr) is
begin
Put_Line (" fin Discr:" & Obj.Id'Img);
Obj.Id := 0;
end Finalize;
procedure Finalize (Obj : in out Ctrl_Owner) is
begin
Put_Line (" fin Ctrl_Owner:" & Obj.Id'Img);
Obj.Id := 0;
end Finalize;
procedure Finalize (Obj : in out Ctrl_Owner_B) is
begin
Put_Line (" fin Ctrl_Owner_B:" & Obj.Id'Image);
Obj.Id := 0;
end;
procedure Initialize (Obj : in out Ctrl_Discr) is
begin
Obj.Id := New_Id;
Put_Line (" ini Discr:" & Obj.Id'Img);
end Initialize;
procedure Initialize (Obj : in out Ctrl_Owner) is
begin
Obj.Id := New_Id;
Put_Line (" ini Ctrl_Owner:" & Obj.Id'Img);
end Initialize;
procedure Initialize (Obj : in out Ctrl_Owner_B) is
begin
Obj.Id := New_Id;
Put_Line (" ini Ctrl_Owner_B:" & Obj.Id'Img);
end Initialize;
function New_Id return Natural is
begin
Id_Gen := Id_Gen + 1;
return Id_Gen;
end New_Id;
end Types;
-- main.adb
with Ada.Finalization; use Ada.Finalization;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with Types; use Types;
procedure Main is
procedure Free is
new Ada.Unchecked_Deallocation (Ctrl_Owner, Ctrl_Owner_Ptr);
procedure Free is
new Ada.Unchecked_Deallocation (Owner, Owner_Ptr);
procedure Free is
new Ada.Unchecked_Deallocation (Ctrl_Owner_B, Ctrl_Owner_B_Ptr);
procedure Free is
new Ada.Unchecked_Deallocation (Owner_B, Owner_B_Ptr);
begin
Put_Line ("Ctrl_Owner named access - non-controlled discr");
declare
D_Ptr_1 : constant Discr_B_Ptr := new Discr_B;
D_Ptr_2 : constant access Discr_B := new Discr_B;
O_Ptr_1 : Ctrl_Owner_B_Ptr :=
new Ctrl_Owner_B'(Controlled with Discr => new Discr_B,
Id => New_Id);
O_Ptr_2 : Ctrl_Owner_B_Ptr :=
new Ctrl_Owner_B'(Controlled with Discr => D_Ptr_1,
Id => New_Id);
O_Ptr_3 : Ctrl_Owner_B_Ptr :=
new Ctrl_Owner_B'(Controlled with Discr => D_Ptr_2,
Id => New_Id);
begin
Free (O_Ptr_1);
Free (O_Ptr_2);
Free (O_Ptr_3);
end;
Put_Line ("Ctrl_Owner anonymous access - non-controlled discr");
declare
D_Ptr_1 : constant Discr_B_Ptr := new Discr_B;
D_Ptr_2 : constant access Discr_B := new Discr_B;
O_Ptr_1 : access Ctrl_Owner_B :=
new Ctrl_Owner_B'(Controlled with Discr => new Discr_B,
Id => New_Id);
O_Ptr_2 : access Ctrl_Owner_B :=
new Ctrl_Owner_B'(Controlled with Discr => D_Ptr_1,
Id => New_Id);
O_Ptr_3 : access Ctrl_Owner_B :=
new Ctrl_Owner_B'(Controlled with Discr => D_Ptr_2,
Id => New_Id);
begin
Free (O_Ptr_1);
Free (O_Ptr_2);
Free (O_Ptr_3);
end;
Put_Line ("Owner named access - non-controlled discr");
declare
D_Ptr_1 : constant Discr_B_Ptr := new Discr_B;
D_Ptr_2 : constant access Discr_B := new Discr_B;
O_Ptr_1 : Owner_B_Ptr := new Owner_B'(Discr => new Discr_B);
O_Ptr_2 : Owner_B_Ptr := new Owner_B'(Discr => D_Ptr_1);
O_Ptr_3 : Owner_B_Ptr := new Owner_B'(Discr => D_Ptr_2);
begin
Free (O_Ptr_1);
Free (O_Ptr_2);
Free (O_Ptr_3);
end;
Put_Line ("Owner anonymous access - non-controlled discr");
declare
D_Ptr_1 : constant Discr_B_Ptr := new Discr_B;
D_Ptr_2 : constant access Discr_B := new Discr_B;
O_Ptr_1 : access Owner_B := new Owner_B'(Discr => new Discr_B);
O_Ptr_2 : access Owner_B := new Owner_B'(Discr => D_Ptr_1);
O_Ptr_3 : access Owner_B := new Owner_B'(Discr => D_Ptr_2);
begin
Free (O_Ptr_1);
Free (O_Ptr_2);
Free (O_Ptr_3);
end;
Put_Line ("Ctrl_Owner named access - controlled discr");
declare
D_Ptr_1 : constant Ctrl_Discr_Ptr := new Ctrl_Discr;
D_Ptr_2 : constant access Ctrl_Discr := new Ctrl_Discr;
O_Ptr_1 : Ctrl_Owner_Ptr :=
new Ctrl_Owner'(Controlled with Discr => new Ctrl_Discr,
Id => New_Id);
O_Ptr_2 : Ctrl_Owner_Ptr :=
new Ctrl_Owner'(Controlled with Discr => D_Ptr_1,
Id => New_Id);
O_Ptr_3 : Ctrl_Owner_Ptr :=
new Ctrl_Owner'(Controlled with Discr => D_Ptr_2,
Id => New_Id);
begin
Free (O_Ptr_1);
Free (O_Ptr_2);
Free (O_Ptr_3);
end;
Put_Line ("Ctrl_Owner anonymous access - controlled discr");
declare
D_Ptr_1 : constant Ctrl_Discr_Ptr := new Ctrl_Discr;
D_Ptr_2 : constant access Ctrl_Discr := new Ctrl_Discr;
O_Ptr_1 : access Ctrl_Owner :=
new Ctrl_Owner'(Controlled with Discr => new Ctrl_Discr,
Id => New_Id);
O_Ptr_2 : access Ctrl_Owner :=
new Ctrl_Owner'(Controlled with Discr => D_Ptr_1,
Id => New_Id);
O_Ptr_3 : access Ctrl_Owner :=
new Ctrl_Owner'(Controlled with Discr => D_Ptr_2,
Id => New_Id);
begin
Free (O_Ptr_1);
Free (O_Ptr_2);
Free (O_Ptr_3);
end;
Put_Line ("Owner named access - controlled discr");
declare
D_Ptr_1 : constant Ctrl_Discr_Ptr := new Ctrl_Discr;
D_Ptr_2 : constant access Ctrl_Discr := new Ctrl_Discr;
O_Ptr_1 : Owner_Ptr := new Owner'(Discr => new Ctrl_Discr);
O_Ptr_2 : Owner_Ptr := new Owner'(Discr => D_Ptr_1);
O_Ptr_3 : Owner_Ptr := new Owner'(Discr => D_Ptr_2);
begin
Free (O_Ptr_1);
Free (O_Ptr_2);
Free (O_Ptr_3);
end;
Put_Line ("Owner anonymous access - controlled discr");
declare
D_Ptr_1 : constant Ctrl_Discr_Ptr := new Ctrl_Discr;
D_Ptr_2 : constant access Ctrl_Discr := new Ctrl_Discr;
O_Ptr_1 : access Owner := new Owner'(Discr => new Ctrl_Discr);
O_Ptr_2 : access Owner := new Owner'(Discr => D_Ptr_1);
O_Ptr_3 : access Owner := new Owner'(Discr => D_Ptr_2);
begin
Free (O_Ptr_1);
Free (O_Ptr_2);
Free (O_Ptr_3);
end;
end Main;
----------------------------
-- Compilation and output --
----------------------------
& gnatmake -q main.adb
main.adb:24:62: info: coextension will not be deallocated when its associated
owner is finalized
main.adb:47:62: info: coextension will not be deallocated when its associated
owner is finalized
main.adb:69:54: info: coextension will not be deallocated when its associated
owner is deallocated
main.adb:85:57: info: coextension will not be deallocated when its associated
owner is deallocated
main.adb:102:60: info: coextension will not be finalized when its associated
owner is finalized
main.adb:125:60: info: coextension will not be finalized when its associated
owner is finalized
main.adb:147:50: info: coextension will not be finalized when its associated
owner is deallocated
main.adb:163:53: info: coextension will not be finalized when its associated
owner is deallocated
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-11-08 Justin Squirek <squi...@adacore.com>
* sem_res.adb (Resolve_Allocator): Add info messages corresponding to
the owner and corresponding coextension.
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 254544)
+++ sem_res.adb (working copy)
@@ -5143,6 +5143,38 @@
if not Is_Static_Coextension (N) then
Set_Is_Dynamic_Coextension (N);
+
+ -- ??? We currently do not handle finalization and deallocation
+ -- of coextensions properly so let's at least warn the user
+ -- about it.
+
+ if Is_Controlled_Active (Desig_T) then
+ if Is_Controlled_Active
+ (Defining_Identifier
+ (Parent (Associated_Node_For_Itype (Typ))))
+ then
+ Error_Msg_N
+ ("info: coextension will not be finalized when its "
+ & "associated owner is finalized", N);
+ else
+ Error_Msg_N
+ ("info: coextension will not be finalized when its "
+ & "associated owner is deallocated", N);
+ end if;
+ else
+ if Is_Controlled_Active
+ (Defining_Identifier
+ (Parent (Associated_Node_For_Itype (Typ))))
+ then
+ Error_Msg_N
+ ("info: 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);
+ end if;
+ end if;
end if;
-- Cleanup for potential static coextensions
