Hidden Finalizers in Ada

Posted on 2011-09-11

“It’s not a bug, it’s a feature!”

Often you want to execute specific code when a object is destroyed – for example free all pointers in it. In Ada you need the Ada.Finalization package for this, which provides you with the Controlled and the Limited_Controlled tagged types; they allow custom action for “Initialize”, “Adjust” (not for limited) and “Finalize”.

Example:

 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
with Ada.Finalization;
with Ada.Unchecked_Deallocation;

procedure Example is
   package X is
      type Container is limited private; --  limited, so you don't accidentally copy a container

   private
      type Tree;
      type Tree_Access is access Tree;
      type Tree is null record;  --  this obviously needs more details :)

      type Container is new Ada.Finalization.Limited_Controlled with record
         Root : Tree_Access;
      end record;

      overriding procedure Initialize (C : in out Container);
      overriding procedure Finalize (C : in out Container);
   end X;

   package body X is
      procedure Initialize (C : in out Container) is
      begin
         C.Root := null;
      end Initialize;

      procedure Finalize (C : in out Container) is
         procedure Free is
            new Ada.Unchecked_Deallocation (Tree, Tree_Access);
      begin
         Free (C.Root);
      end Finalize;
   end X;
begin
   null;
end Example;

This solution has a drawback: Container becomes a tagged type (you could say tagged types are the object-orientation in Ada), but you only see the negative effects on the outside: you can’t use methods that “dispatch” in one more than one tagged type like this:

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
procedure Example is
   package X is
      type A is tagged null record;
      type B is tagged null record;

      procedure Foo (x : in out A; y : in out B);
   end X;

   package body X is
      procedure Foo (x : in out A; y : in out B) is
      begin
         null;
      end;
   end X;

begin
   null;
end Example;

results in:

1
2
3
4
$ gnatmake example.adb
gcc-4.4 -c example.adb
example.adb:6:17: operation can be dispatching in only one type
gnatmake: "example.adb" compilation error

Now you could for example replace the parameter “B” with “B’Class” in Foo; it then would only dispatch in x, not in y. But as the taggedness is private in the Container example above (and there is no reason to make it public), you cannot use Container’Class outside the private part of the package.

The solution is mix-in I found in a forum:

 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
with Ada.Finalization;
with Ada.Unchecked_Deallocation;

procedure Example is
   package X is
      type Container is limited private;

   private
      type Tree;
      type Tree_Access is access Tree;
      type Tree is null record;  --  this obviously needs more details :)

      type Container_Control (Enclosing : access Container) is
         new Ada.Finalization.Limited_Controlled with null record;

      type Container is limited record
         Root : Tree_Access;
         Control : Container_Control (Container'Access);
      end record;

      overriding procedure Initialize (C : in out Container_Control);
      overriding procedure Finalize (C : in out Container_Control);
   end X;

   package body X is
      procedure Initialize (C : in out Container_Control) is
      begin
         C.Enclosing.all.Root := null;
      end Initialize;

      procedure Finalize (C : in out Container_Control) is
         procedure Free is
            new Ada.Unchecked_Deallocation (Tree, Tree_Access);
      begin
         Free (C.Enclosing.all.Root);
      end Finalize;
   end X;
begin
   null;
end Example;

The access discriminant “Enclosing” and “Container’Access” is a hack with a special syntax; I couldn’t find it in the Ada reference manual, but wikibooks knows it too and explains why this only works for limited types too (and more).

References

Generated using nanoc and bootstrap - Last content change: 2013-08-16 14:47