deallocating class-wide objects

[Stephen Leake <Stephen.Leake@gsfc.nasa.gov>]

When I run the code below (compiled with GNAT 3.10p, Windows NT 4.0),
I get the following output (the Test_Storage_Pools package just adds
debug statments to 'new' and 'free') :

./test_allocate.exe 
allocating   12 from Puppet_Storage_Pool
deallocating 4 from Puppet_Storage_Pool

allocating   8 from Puppet_Storage_Pool
deallocating 4 from Puppet_Storage_Pool

allocating   12 from Muppet_Storage_Pool
deallocating 12 from Muppet_Storage_Pool

The first two cases are wrong; it should deallocate the same amount it
allocates. It appears that GNAT is deallocating just enough for the
root type, rather than for the derived type. The third case
deallocates the derived type directly, and works as expected.

I can't bring myself to believe that GNAT has a bug this
basic at this stage in the game. On the other hand, ObjectAda won't
even compile this code (bug report in the works). Can anyone confirm
that GNAT is wrong, or am I doing something erroneous?

-- Stephe.

with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with Test_Storage_Pools;
procedure Test_Allocate is
   type Puppet_Type is abstract tagged null record;
   type Puppet_Access_Type is access Puppet_Type'Class;

   Puppet_Storage_Pool_Name : aliased String := "Puppet_Storage_Pool";
   Puppet_Storage_Pool : Test_Storage_Pools.Storage_Pool_Type
      (1000, Puppet_Storage_Pool_Name'access);
   for Puppet_Access_Type'Storage_Pool use Puppet_Storage_Pool;

   procedure Free_Puppet is new Ada.Unchecked_Deallocation
      (Puppet_Type'Class, Puppet_Access_Type);

   Muppet_Storage_Pool_Name : aliased String := "Muppet_Storage_Pool";
   Muppet_Storage_Pool : Test_Storage_Pools.Storage_Pool_Type
         (1000, Muppet_Storage_Pool_Name'access);

   type Muppet_Type is new Puppet_Type with record
      Arms : Integer;
      Fingers : Integer;
   end record;

   type Muppet_Access_Type is access Muppet_Type'Class;
   for Muppet_Access_Type'Storage_Pool use Muppet_Storage_Pool;

   procedure Free_Muppet is new Ada.Unchecked_Deallocation
       (Muppet_Type'Class, Muppet_Access_Type);

   type Beanie_Type is new Puppet_Type with record
      Legs : Integer;
   end record;

   Puppet_1 : Puppet_Access_Type;
   Puppet_2 : Puppet_Access_Type;

   Muppet_3 : Muppet_Access_Type;
begin
   Test_Storage_Pools.Set_Debug (Puppet_Storage_Pool, True);
   Test_Storage_Pools.Set_Debug (Muppet_Storage_Pool, True);

   Puppet_1 := new Muppet_Type'(2, 5);
   Free_Puppet (Puppet_1);

   New_Line;
   Puppet_2 := new Beanie_Type'(Legs => 4);
   Free_Puppet (Puppet_2);

   New_Line;
   Muppet_3 := new Muppet_Type'(3, 4);
   Free_Muppet (Muppet_3);
end Test_Allocate;

with Ada.Text_IO;
with System.Address_To_Access_Conversions;
with Ada.Exceptions;
package body Test_Storage_Pools is

   Block_Header_Size : constant System.Storage_Elements.Storage_Count :=
      System.Storage_Elements.Storage_Count
        (Block_Header_Type'Size /
         System.Storage_Elements.Storage_Element'Size);

   -- This would be cleaner if Address_To_Access_Conversions took the
   -- pointer type as parameter, instead of declaring it!
   package Address_To_Block_Access is
      new System.Address_To_Access_Conversions (Block_Header_Type);

   function To_Block_Access (Address : in System.Address)
      return Block_Access_Type
   is begin
      return Block_Access_Type (Address_To_Block_Access.To_Pointer (Address));
   end To_Block_Access;

   function To_Address (Value : in Block_Access_Type) return System.Address
   is begin
      return Address_To_Block_Access.To_Address
        (Address_To_Block_Access.Object_Pointer (Value));
   end To_Address;

   function Aligned_Address
      (Address     : in System.Address;
       Alignment   : in System.Storage_Elements.Storage_Count)
      return System.Address
      -- Adjust Address upwards to next Alignment.
   is
      use System.Storage_Elements;
      Aligned : Integer_Address := To_Integer (Address) + To_Integer
         (Address) rem Integer_Address (Alignment);
   begin
      return To_Address (Aligned);
   end Aligned_Address;

   -----------
   -- Override Root_Storage_Pool operations

   procedure Allocate
      (Pool                     : in out Storage_Pool_Type;
       Storage_Address          :    out System.Address;
       Size_In_Storage_Elements : in     System.Storage_Elements.Storage_Count;
       Alignment                : in     System.Storage_Elements.Storage_Count)
   is
      use System.Storage_Elements;
      use Ada.Exceptions;
      Block           : Block_Access_Type := Pool.First_Free;
      Remaining_Block : Block_Access_Type;
      Aligned         : System.Address;
      Prev            : Block_Access_Type := null;
   begin
      if Pool.Debug then
         Ada.Text_Io.Put_Line ("allocating  " &
                               Storage_Count'Image (Size_In_Storage_Elements) &
                               " from " &
                               Pool.Name.all);
      end if;

      if Size_In_Storage_Elements < Block_Header_Size  then
         Raise_Exception (Storage_Error'Identity,
                          "Allocate: block size < header size");
      end if;

      Find_Free_Fit :
      loop
         if Block = null then
            Raise_Exception (Storage_Error'Identity,
                             "Allocate: pool full (or fragmented)");
         end if;
         exit Find_Free_Fit when Block.Size >= Size_In_Storage_Elements;
         Prev := Block;
         Block := Block.Next;
      end loop Find_Free_Fit;

      Aligned := Aligned_Address
          (Address => To_Address (Block) + Size_In_Storage_Elements,
           Alignment => 8);

      if To_Integer (Aligned) + Integer_Address (Block_Header_Size) <
         To_Integer (To_Address (Block)) + Integer_Address (Block.Size)
      then
         Remaining_Block := To_Block_Access (Aligned);
         if Prev = null then
            -- Allocated from first free block.
            Pool.First_Free := Remaining_Block;
         else
            Prev.Next := Remaining_Block;
         end if;

         Remaining_Block.all :=
            (Size => Block.Size - Size_In_Storage_Elements,
             Next => Block.Next);
      else
         -- Remaining space too small for a block.
         -- Just link to next free block.
         if Prev = null then
            -- Allocated from first free block.
            Pool.First_Free := Pool.First_Free.Next;
         else
            Prev.Next := Block.Next;
         end if;

      end if;

      Storage_Address := To_Address (Block);
   end Allocate;

   procedure Deallocate
      (Pool                     : in out Storage_Pool_Type;
       Storage_Address          : in     System.Address;
       Size_In_Storage_Elements : in     System.Storage_Elements.Storage_Count;
       Alignment                : in     System.Storage_Elements.Storage_Count)
   is
      use System.Storage_Elements;
      Block : Block_Access_Type := To_Block_Access (Storage_Address);
   begin
      if Pool.Debug then
         Ada.Text_Io.Put_Line ("deallocating" &
                               Storage_Count'Image (Size_In_Storage_Elements) &
                               " from " &
                               Pool.Name.all);
      end if;
      -- Add block to head of free list

      Block.all :=
         (Size => Size_In_Storage_Elements,
          Next => Pool.First_Free);
      Pool.First_Free := Block;

   end Deallocate;

   function Storage_Size (Pool : Storage_Pool_Type)
    return System.Storage_Elements.Storage_Count
   is begin
      return Pool.Pool_Size;
   end Storage_Size;

   -----------
   -- New operations

   procedure Set_Debug (Pool : in out Storage_Pool_Type; Debug : in Boolean)
   is begin
      Pool.Debug := Debug;
   end Set_Debug;

   procedure Initialize (Pool : in out Storage_Pool_Type)
   is
      use type System.Storage_Elements.Storage_Offset;
      use Ada.Exceptions;
   begin
      if Pool.Pool_Size < Block_Header_Size then
         Raise_Exception (Storage_Error'Identity,
                          "Initialize: pool_size < header_size");
      end if;

      Pool.Debug := False;
      Pool.First_Free := To_Block_Access
         (Aligned_Address
          (Address => Pool.Storage'Address,
           Alignment => 8));
      Pool.First_Free.all := (Pool.Pool_Size, null);
   end Initialize;

end Test_Storage_Pools;

with System.Storage_Pools;
with System.Storage_Elements;
package Test_Storage_Pools is

   type Storage_Pool_Type
      (Pool_Size : System.Storage_Elements.Storage_Count;
       Name      : access String) -- for debug messages
   is new System.Storage_Pools.Root_Storage_Pool with private;

   -----------
   -- Override Root_Storage_Pool operations

   procedure Allocate
      (Pool                     : in out Storage_Pool_Type;
       Storage_Address          :    out System.Address;
       Size_In_Storage_Elements : in     System.Storage_Elements.Storage_Count;
       Alignment                : in     System.Storage_Elements.Storage_Count);

   procedure Deallocate
      (Pool                     : in out Storage_Pool_Type;
       Storage_Address          : in     System.Address;
       Size_In_Storage_Elements : in     System.Storage_Elements.Storage_Count;
       Alignment                : in     System.Storage_Elements.Storage_Count);

   function Storage_Size (Pool : in Storage_Pool_Type)
    return System.Storage_Elements.Storage_Count;

   -----------
   -- New operations

   procedure Set_Debug (Pool : in out Storage_Pool_Type; Debug : in Boolean);
   -- If Debug is True, Allocate and Deallocate print helpful messages to
   -- Standard_Output.

private

   procedure Initialize (Pool : in out Storage_Pool_Type);

   type Block_Header_Type;
   type Block_Access_Type is access all Block_Header_Type;
   type Block_Header_Type is record
      Size : System.Storage_Elements.Storage_Count;
      Next : Block_Access_Type;
   end record;

   type Storage_Pool_Type
      (Pool_Size : System.Storage_Elements.Storage_Count;
       Name      : access String)
   is new System.Storage_Pools.Root_Storage_Pool with record
         Debug                  : Boolean;
         First_Free             : Block_Access_Type;
         Storage                : System.Storage_Elements.Storage_Array
                                    (1 .. Pool_Size);
         -- The first few elements of each free block contain the block header.
         -- Storage_Error is raised if a free block is smaller than the
         -- block header size.
         -- All blocks have alignment 8, to keep things simple.
      end record;

end Test_Storage_Pools;