Deallocating list of polymorphic objects?

["Michael Rohan" <mrohan@ACM.ORG>]

Hi Folks,

I would like to construct a list of polymorphic objects that,
as part of the list's finalization, deallocates the objects on
the list.  Basically, I have a vector of pointers to Object'Class.
The objects are added to the list via procedures defined for
the list, e.g., append an integer, append a floating point.
These append procedures allocate objects derived from the
base Object type for the type being appended, e.g.,
Integer_Object, which is private to the list package.

Since I want the deallocation to be dispatching, it needs to take an
access parameter which is then converted to a pointer for the object
being deallocated, e.g., an Integer_Pointer, and then passed to an
Unchecked_Deallocation procedure.

The code below (formatted to minimize the size of this posting) does
what I expect:

   $ gnatmake -gnat05 list_test
   gcc -c -gnat05 list_test.adb
   gcc -c -gnat05 lists.adb
   gnatbind -x list_test.ali
   gnatlink list_test.ali
   $ ./list_test
   Finalizing a list
   Integer object:  1
   Float object: -1.00000E+00
   Integer object:  2
   Float object: -2.00000E+00

However, I have a feeling there is something "bad" about this type of
deallocation, probably related to storage pool but I'm not familiar
enough with storage pools to be sure.

Would anyone care to comment on how safe/unsafe this deallocation
scheme is?

Take care,
Michael

---
list_test.adb
---------------------------------------------------------------------------
with Lists;
procedure List_Test is
   L : Lists.List_Type;
begin
   Lists.Append (L, 1);
   Lists.Append (L, -1.0);
   Lists.Append (L, 2);
   Lists.Append (L, -2.0);
end List_Test;

---
lists.ads
---------------------------------------------------------------------------
with Ada.Finalization;
with Ada.Containers.Vectors;
package Lists is
   type List_Type is limited private;
   procedure Append (L : in out List_Type; I : Integer);
   procedure Append (L : in out List_Type; F : Float);
private
   type Object is abstract tagged null record;
   type Object_Pointer is access all Object'Class;
   procedure Print (Pointer : access Object) is abstract;
   procedure Deallocate (Pointer : access Object) is abstract;
   package List_Vector_Package is
      new Ada.Containers.Vectors (Index_Type => Natural,
                                  Element_Type => Object_Pointer);
   type List_Type is new Ada.Finalization.Limited_Controlled with
record
      Contents : List_Vector_Package.Vector;
   end record;
   overriding procedure Finalize (L : in out List_Type);
end Lists;

---
lists.adb
---------------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
package body Lists is
   use Ada.Containers;
   use List_Vector_Package;

   package Integer_Objects is
      type Integer_Object is new Object with record
         I : Integer;
      end record;
      overriding procedure Print (Pointer : access Integer_Object);
      overriding procedure Deallocate (Pointer : access
Integer_Object);
   end Integer_Objects;

   package Float_Objects is
      type Float_Object is new Object with record
         F : Float;
      end record;
      overriding procedure Print (Pointer : access Float_Object);
      overriding procedure Deallocate (Pointer : access Float_Object);
   end Float_Objects;

   use Float_Objects;
   use Integer_Objects;

   package body Integer_Objects is
      type Integer_Pointer is access all Integer_Object;
      procedure Free is
         new Ada.Unchecked_Deallocation (Integer_Object,
Integer_Pointer);
      procedure Print (Pointer : access Integer_Object) is
      begin
         Ada.Text_IO.Put_Line ("Integer object: " & Pointer.I'Img);
      end Print;
      procedure Deallocate (Pointer : access Integer_Object) is
         I_Pointer : Integer_Pointer := Integer_Pointer (Pointer);
      begin
         Print (Pointer);
         Free (I_Pointer);
      end Deallocate;
   end Integer_Objects;

   package body Float_Objects is
      type Float_Pointer is access all Float_Object;
      procedure Free is
         new Ada.Unchecked_Deallocation (Float_Object, Float_Pointer);
      procedure Print (Pointer : access Float_Object) is
      begin
         Ada.Text_IO.Put_Line ("Float object: " & Pointer.F'Img);
      end Print;
      procedure Deallocate (Pointer : access Float_Object) is
         I_Pointer : Float_Pointer := Float_Pointer (Pointer);
      begin
         Print (Pointer);
         Free (I_Pointer);
      end Deallocate;
   end Float_Objects;

   procedure Append (L : in out List_Type; I : Integer) is
   begin
      Append (L.Contents, new Integer_Object'(I => I));
   end Append;
   procedure Append (L : in out List_Type; F : Float) is
   begin
      Append (L.Contents, new Float_Object'(F => F));
   end Append;
   procedure Finalize (L : in out List_Type) is
      Pointer : Object_Pointer;
   begin
      Ada.Text_IO.Put_Line ("Finalizing a list");
      if L.Contents.Length > 0 then
         for I in 0 .. Integer (L.Contents.Length - 1) loop
            Pointer := Element (L.Contents, I);
            Deallocate (Pointer);
         end loop;
      end if;
   end Finalize;
end Lists;