rxada_0.1.1_dd9da799/src/bugs/finalize_leak.adb

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
with Ada.Finalization; use Ada.Finalization;
with Ada.Unchecked_Deallocation;
with Ada.Text_Io; use Ada.Text_Io;

procedure Finalize_Leak is
   generic
   package P is

      type Leftie  is interface;
      type Rightie is interface;

      type Left_Access is access Leftie'Class;
      type Holder is new Controlled with record
         Held : Left_Access;
      end record;
      overriding procedure Adjust (Op : in out Holder);
      overriding procedure Finalize (Op : in out Holder);
      function Hold (L : Leftie'Class) return Holder
        is (Holder'(Controlled with Held => new Leftie'Class'(L)));

      type Subscriber is new Rightie with record
         Parent : Holder;
      end record;
      procedure Set_Parent (S : in out Subscriber; Parent : Leftie'Class);

      type Operator is new Subscriber and Leftie with null record;

      function "&" (L : Leftie'Class; R : Operator'Class) return Operator'Class;

      type Nop is new Operator with null record;

      function N return Operator'Class is (Nop'(others => <>));

   end P;

   package body P is
      overriding procedure Adjust (Op : in out Holder) is
      begin
         if Op.Held /= null then
            Put_Line ("adjust");
            Op.Held := new Leftie'Class'(Op.Held.all);
         end if;
      end Adjust;
      overriding procedure Finalize (Op : in out Holder) is
         procedure Free is new Ada.Unchecked_Deallocation (Leftie'Class, Left_Access);
      begin
         Put_Line ("finalize");
         Free (Op.Held);
      end Finalize;

      procedure Set_Parent (S : in out Subscriber; Parent : Leftie'Class) is
      begin
         S.Parent := Hold (Parent);
      end Set_Parent;

      function "&" (L : Leftie'Class; R : Operator'Class) return Operator'Class is
         A : Operator'Class := R;
      begin
         A.Set_Parent (L);
         return A;
      end "&";
   end P;

   package PP is new P; use PP;

begin
   for I in 1 .. 1 loop
      Put_Line ("---8<---");
      declare
         Leak : Leftie'Class := N & N with Unreferenced;
      begin
         null;
      end;
      Put_Line ("--->8---");
   end loop;
   Put_Line ("END");
   -- Why are there finalizations past this point?
end Finalize_Leak;