[Bug ada/11795] New: Memory management: fails when using storage pools

["valdand at soften dot ktu dot lt" <gcc-bugzilla at gcc dot gnu dot org>]

PLEASE REPLY TO gcc-bugzilla@gcc.gnu.org ONLY, *NOT* gcc-bugs@gcc.gnu.org.

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=11795

           Summary: Memory management: fails when using storage pools
           Product: gcc
           Version: 3.3.1
            Status: UNCONFIRMED
          Severity: normal
          Priority: P2
         Component: ada
        AssignedTo: unassigned at gcc dot gnu dot org
        ReportedBy: valdand at soften dot ktu dot lt
                CC: gcc-bugs at gcc dot gnu dot org

Fails to operate with memory storage pools.

Steps to Reproduce:

gnatchop m.ada (m.ada provided)
gnatmake  -c memory_management-test
./memory_management-test

Application gets exception, print error "Memory Management Test Fails" and
terminates.
Should pass all tests and print "Memory Management Test Passes".



Build Date & Platform: in gcc 3.0, currently gcc 3.3.1 (Mandrake Linux 9.2
3.3.1-0.7mdk)
Occurs on all 3.x versions of gcc.

Generated program executes as expected when build with GNAT released compiler
version 3.15p  (20020523) and earlier.

--
m.ada
--
with Ada.Exceptions;
with Ada.Text_Io;
with System.Storage_Elements;
with System.Address_To_Access_Conversions;

package body Memory_Management is

   use Ada;
   use Text_Io;
   use type System.Storage_Elements.Storage_Count;

   Package_Name : constant String := "Memory_Management.";

   -- Used to turn on/off the debug information
   Debug_On : Boolean := True;

   type Holder is record
      Next_Address : System.Address := System.Null_Address;
   end record;

   package Addr_To_Acc is new Address_To_Access_Conversions (Holder);

   -- Keep track of the size of memory block for reuse
   Free_Storage_Keeper : array (Storage_Elements.Storage_Count range 1.. 100)
     of System.Address := (others => System.Null_Address);

   procedure Display_Info (Message : string; With_New_Line : Boolean  := True)
is
   begin
      if Debug_On then
         if With_New_Line then
            Put_Line (Message);
         else
            Put (Message);
         end if;
      end if;
   end Display_Info;

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

      Procedure_Name : constant String := "Allocate";
      Temp_Address : System.Address := System.Null_Address;
      Marker : Storage_Elements.Storage_Count;
   begin

      Marker := (Size_In_Storage_Elements + Alignment - 1) / Alignment;

      if Free_Storage_Keeper (Marker) /= System.Null_Address then
         Storage_Address := Free_Storage_Keeper (Marker);
         Free_Storage_Keeper (Marker) :=
           Addr_To_Acc.To_Pointer (Free_Storage_Keeper(Marker)).Next_Address;
      else
         Temp_Address := Pool.Data (Pool.Addr_Index)'Address;
        
         Pool.Addr_Index := Pool.Addr_Index + Alignment *
                     ((Size_In_Storage_Elements + Alignment - 1) / Alignment);

         -- make sure memory is available as requested
         if Pool.Addr_Index > Pool.Size then
            Exceptions.Raise_Exception (Storage_Error'Identity,
               "Storage exhausted in " & Package_Name & Procedure_Name);
         else
            Storage_Address := Temp_Address;
         end if;
      end if;

      Display_Info  ("Address allocated from pool: " &
        System.Storage_Elements.Integer_Address'Image
(System.Storage_Elements.To_Integer(Storage_Address)));

      Display_Info ("storage elements allocated from pool: " &
         System.Storage_Elements.Storage_Count'Image
(Size_In_Storage_Elements));

      Display_Info ("Alignment in allocation operation: " &
         System.Storage_Elements.Storage_Count'Image (Alignment));

   exception
      when Error : others => -- Object too big or memory exhausted
         Display_Info (Exceptions.Exception_Information (Error));
         raise;

   end Allocate;

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

      Marker : Storage_Elements.Storage_Count;

   begin

      Marker := (Size_In_Storage_Elements + Alignment - 1) /
Alignment;
      Addr_To_Acc.To_Pointer (Storage_Address).Next_Address :=
                                         Free_Storage_Keeper (Marker);
      Free_Storage_Keeper (Marker) := Storage_Address;

      Display_Info  ("Address returned to pool: " &
        System.Storage_Elements.Integer_Address'Image (
                             System.Storage_Elements.To_Integer
(Storage_Address)));

      Display_Info ("storage elements returned to pool: " &
         System.Storage_Elements.Storage_Count'Image
(Size_In_Storage_Elements));

      Display_Info ("Alignment used in deallocation: " &
         System.Storage_Elements.Storage_Count'Image (Alignment));

   end Deallocate;

   function Storage_Size (Pool : in User_Pool)
         return Storage_Elements.Storage_Count is
   begin
      return Pool.Size;
   end Storage_Size;

begin

   null;

end Memory_Management;
with System.Storage_Pools;
with System.Storage_Elements;

package Memory_Management is

   use System;

   type User_Pool (Size : Storage_Elements.Storage_Count) is new
      System.Storage_Pools.Root_Storage_Pool with private;

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

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

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

   -- Exeption declaration
   Memory_Exhausted : exception;

   Item_Too_Big : exception;

private
   type User_Pool (Size : Storage_Elements.Storage_Count) is new
      System.Storage_Pools.Root_Storage_Pool with record
      Data       : Storage_Elements.Storage_Array (1 .. Size);
      Addr_Index : Storage_Elements.Storage_Count := 1;
   end record;

end Memory_Management;
with Ada.Unchecked_Deallocation;

package body Memory_Management.Support is

   procedure Free is new Ada.Unchecked_Deallocation (Integer, Int_Acc);
   procedure Free is new Ada.Unchecked_Deallocation (String, Str_Acc);

   procedure Initialize (Object : in out General_Data) is
   begin
      null;
   end Initialize;

   procedure Finalize (Object : in out General_Data) is
   begin
      Free (Object.Id);
      Free (Object.Name);
   end Finalize;

end Memory_Management.Support;

with Ada.Finalization;

package Memory_Management.Support is

   use Ada;

   -- Adjust the storage size according to the application
   Big_Pool : User_Pool (Size => 100);

   type Int_Acc is access Integer;
   for Int_Acc'Storage_Pool use Big_Pool;

   type Str_Acc is access all String;
   for Str_Acc'Storage_Pool use Int_Acc'Storage_Pool;

   type General_Data is new Finalization.Controlled with record
      Id : Int_Acc;
      Name : Str_Acc;
   end record;

   procedure Initialize (Object : in out General_Data);

   procedure Finalize (Object : in out General_Data);

end Memory_Management.Support;
with Ada.Finalization;
with Ada.Text_Io;
with Memory_Management.Support;

procedure Memory_Management.Test is
   use Ada;
   use Text_Io;

begin

   Put_Line ("********* Memory Control Testing Starts **********");

   for Index in 1 .. 10 loop
      declare
         David_Botton : Support.General_Data;
         Nick_Roberts : Support.General_Data;
         Anh_Vo : Support.General_Data;

      begin
         David_Botton := (Finalization.Controlled with
            Id => new Integer' (111), Name => new String' ("David Botton"));
         Nick_Roberts := (Finalization.Controlled with
            Id => new Integer' (222), Name => new String' ("Nick Roberts"));
         Anh_Vo := (Finalization.Controlled with
            Id => new Integer' (333), Name => new String' ("Anh Vo"));
      end;
   end loop;

   Put_Line ("Memory Management Test Passes");

exception
   when others =>
      Put_Line ("Memory Management Test Fails");

end Memory_Management.Test;