Re: Finalization and class-wide views

["Alejandro R. Mosteo" <alejandro@mosteo.com>]

As a follow-up I've modified the example with actual memory 
allocation/deallocation, and valgrind seems to confirm the brokenness of 
the third assignment in the original example.

valgrind --leak-check=full output:

==21058== HEAP SUMMARY:
==21058==     in use at exit: 2,664 bytes in 666 blocks
==21058==   total heap usage: 2,670 allocs, 2,004 frees, 10,680 bytes 
allocated
==21058==
==21058== 2,664 bytes in 666 blocks are definitely lost in loss record 1 
of 1
==21058==    at 0x4C2DB8F: malloc (in 
/usr/lib/valgrind/vgpreload_memcheck-amd64-linux.so)
==21058==    by 0x41623C: __gnat_malloc (in 
/home/jano/local/rxada/obj/finalize_leak)
==21058==    by 0x402B0A: finalize_leak__pp__adjust.3673 
(finalize_leak.adb:30)
==21058==    by 0x402B4D: finalize_leak__pp__twoDA.3946 
(finalize_leak.adb:32)
==21058==    by 0x404D96: _ada_finalize_leak (finalize_leak.adb:67)
==21058==    by 0x405887: main (b__finalize_leak.adb:241)
==21058==
==21058== LEAK SUMMARY:
==21058==    definitely lost: 2,664 bytes in 666 blocks
==21058==    indirectly lost: 0 bytes in 0 blocks
==21058==      possibly lost: 0 bytes in 0 blocks
==21058==    still reachable: 0 bytes in 0 blocks
==21058==         suppressed: 0 bytes in 0 blocks
==21058==
==21058== For counts of detected and suppressed errors, rerun with: -v
==21058== ERROR SUMMARY: 1 errors from 1 contexts (suppressed: 0 from 0)

With this I feel confident enough to file a bug report. Here is the 
modified program. The type Managed now holds a heap-allocated integer.

with Ada.Finalization; use Ada.Finalization;
with Ada.Text_Io; use Ada.Text_Io;
with Ada.Unchecked_Deallocation;

procedure Finalize_Leak is
    generic
    package P is

       type One is interface;

       type Int_Access is access Integer;

       type Managed is new Controlled with record
          X : Int_Access;
       end record;
       overriding procedure Adjust (M : in out Managed);
       overriding procedure Finalize (M : in out Managed);
       function Build (I : Integer) return Managed;

       type Two is new One with record
          M : Managed := Build (1);
       end record;

    end P;

    package body P is
       overriding procedure Adjust (M : in out Managed) is
       begin
          if M.X /= null then
             M.X := new Integer'(M.X.all);
          end if;
       end Adjust;

       overriding procedure Finalize (M : in out Managed) is
          procedure Free is
            new Ada.Unchecked_Deallocation (Integer, Int_Access);
       begin
          if M.X /= null then
             Free (M.X);
             Put_Line ("finalize M with free");
          else
             Put_Line ("finalize M");
          end if;
       end Finalize;

       function Build (I : Integer) return Managed
       is (Managed'(Controlled with X => new Integer'(I)));
    end P;

    package PP is new P; use PP;

    function Pass (X : Two'Class) return One'Class is (X);
    function "not" (X : Two'Class) return One'Class is (X);

    A : Two;
begin
    A.M := Build (1);

    for I in 1 .. 666 loop
       Put_Line ("----------------------------");
       declare
          B : One'Class := Pass (A); -- This is properly finalized
       begin
          Put_Line ("......");
       end;
       Put_Line ("......");

       declare
          B : One'Class := not A; -- This is not
       begin
          Put_Line ("---8<---");
       end;
       Put_Line ("--->8---");
    end loop;

    New_Line; Put_Line ("Now A is going to finalize");
end Finalize_Leak;