===================================================================
@@ -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
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 <squirek@adacore.com> * sem_res.adb (Resolve_Allocator): Add info messages corresponding to the owner and corresponding coextension.