File : asl-leak_detect_pool.adb


-- The Ada Structured Library - A set of container classes and general
--   tools for use with Ada95.
-- Copyright (C) 1998-1999  Corey Minyard (minyard@acm.org)
--
-- This library is free software; you can redistribute it and/or modify it
-- under the terms of the GNU General Public License as published by the
-- Free Software Foundation; either version 2 of the License, or (at your
-- option) any later version.
--
-- This library is distributed in the hope that it will be useful, but
-- WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License along
-- with this library; if not, write to the Free Software Foundation, Inc.,
-- 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
--
-- As a special exception, if other files instantiate generics from this
-- unit, or you link this unit with other files to produce an executable,
-- this unit does not by itself cause the resulting executable to be
-- covered by the GNU General Public License.  This exception does not
-- however invalidate any other reasons why the executable file might be
-- covered by the GNU Public License.
--

with Ada.Unchecked_Deallocation;
with System.Address_To_Access_Conversions;

package body Asl.Leak_Detect_Pool is

   package Conv is new System.Address_To_Access_Conversions(Pool_Element);

   -- The size of the header in storage elements.
   Header_Size : System.Storage_Elements.Storage_Count
     := Pool_Element'Size / System.Storage_Elements.Storage_Element'Size;

   -- The offset back from the data address we return of the header.
   Header_Offset : System.Storage_Elements.Storage_Count;


   ------------------------------------------------------------------------
   procedure Allocate
     (Pool         : in out Leak_Pool;
      Address      : out System.Address;
      Storage_Size : in System.Storage_Elements.Storage_Count;
      Alignment    : in System.Storage_Elements.Storage_Count)
   is
      My_Alignment  : System.Storage_Elements.Storage_Count := Alignment;
      Total_Header  : System.Storage_Elements.Storage_Count;
      Alloc_Size    : System.Storage_Elements.Storage_Count;
      Ret_Address   : System.Address;
   begin
      -- Make sure the alignment is at least 4 storage elements.
      if ((My_Alignment mod 4) /= 0) then
         My_Alignment := My_Alignment + (4 - (My_Alignment mod 4));
      end if;

      -- Now calculate the amount of data to allocate.  First we need the
      -- size for the header, being careful to allow for any alignment.
      if ((Header_Size mod My_Alignment) /= 0) then
         Total_Header := (Header_Size
                          + (My_Alignment - (Header_Size mod My_Alignment)));
      else
         Total_Header := Header_Size;
      end if;

      -- Now the size to allocate.
      Alloc_Size := Storage_Size + Total_Header;

      declare
         -- Create local fixed types to allocate the data with.  We can't
         -- use unconstrained pointers because the array sizes might be
         -- carried in the data pointed to.  Make sure it uses the standard
         -- global storage pool.
         subtype Real_Data is Alloc_Data(0 .. (Alloc_Size - 1));
         type Real_Data_Ptr is access all Real_Data;
         for Real_Data_Ptr'Storage_Pool use Alloc_Data_Ptr'Storage_Pool;

         -- Here is the data from the standard global storage pool
         Alloc_Block  : Real_Data_Ptr := new Real_Data;
         Header       : Conv.Object_Pointer
           := Conv.To_Pointer(Alloc_Block(Total_Header-Header_Offset)'Address);
      begin
         Header.Magic := Leak_Pool_Magic;
         Header.Size := Storage_Size;
         Header.Real_Size := Alloc_Size;

         -- put the element into the list
         if (Pool.Elements /= null) then
            Pool.Elements.Prev := Pool_Element_Ptr(Header);
         end if;
         Header.Next := Pool.Elements;
         Header.Prev := null;
         Pool.Elements := Pool_Element_Ptr(Header);
         Ret_Address := Alloc_Block(Total_Header)'Address;
         Address := Ret_Address;
      end;
   end Allocate;


   ------------------------------------------------------------------------
   procedure Deallocate
     (Pool         : in out Leak_Pool;
      Address      : in System.Address;
      Storage_Size : in System.Storage_Elements.Storage_Count;
      Alignment    : in System.Storage_Elements.Storage_Count)
   is
      Header      : Conv.Object_Pointer
        := Conv.To_Pointer(Address - Header_Offset);
   begin
      if (Header.Magic /= Leak_Pool_Magic) then
         raise Deallocate_Of_Invalid_Data;
      end if;

      -- Remove the element from the list.
      if (Header.Prev /= null) then
         Header.Prev.Next := Header.Next;
      else
         Pool.Elements := Header.Next;
      end if;
      if (Header.Next /= null) then
         Header.Next.Prev := Header.Prev;
      end if;

      -- Create a bunch of types to create a data pointer to free.
      declare
         subtype Real_Data is Alloc_Data(0 .. (Header.Real_Size - 1));
         type Real_Data_Ptr is access all Real_Data;
         for Real_Data_Ptr'Storage_Pool use Alloc_Data_Ptr'Storage_Pool;
         procedure Free is
           new Ada.Unchecked_Deallocation(Real_Data, Real_Data_Ptr);

         -- I'd like to use access to address conversions, but we can't
         -- define storage pools for those pointers.
         Alloc_Block  : aliased Real_Data;
         for Alloc_Block'Address
           use Address - (Header.Real_Size - Header.Size);
         To_Free : Real_Data_Ptr := Alloc_Block'Unchecked_Access;
      begin
         Free(To_Free);
      end;
   end Deallocate;


   ------------------------------------------------------------------------
   function Storage_Size (Pool : Leak_Pool)
                          return System.Storage_Elements.Storage_Count is
   begin
      -- We use the default pool's size.
      return System.Storage_Pools.Storage_Size
        (System.Storage_Pools.Root_Storage_Pool'Class
         (Alloc_Data_Ptr'Storage_Pool));
   end Storage_Size;


   ------------------------------------------------------------------------
   procedure First (Pool    : in Leak_Pool;
                    Iter    : in out Iterator;
                    Is_End  : out End_Marker;
                    Address : out System.Address;
                    Size    : out System.Storage_Elements.Storage_Count) is
   begin
      Iter.Curr := Pool.Elements;
      if (Iter.Curr = null) then
         Is_End := Past_End;
      else
         Is_End := Not_Past_End;
         Address := Iter.Curr.all'Address + Header_Offset;
         Size := Iter.Curr.Size;
      end if;
   end First;


   ------------------------------------------------------------------------
   procedure Next (Iter    : in out Iterator;
                   Is_End  : out End_Marker;
                   Address : out System.Address;
                   Size    : out System.Storage_Elements.Storage_Count) is
   begin
      Iter.Curr := Iter.Curr.Next;
      if (Iter.Curr = null) then
         Is_End := Past_End;
      else
         Is_End := Not_Past_End;
         Address := Iter.Curr.all'Address + Header_Offset;
         Size := Iter.Curr.Size;
      end if;
   end Next;

begin
   -- Calculate the actual starting place of the header relative to the
   -- data we are returning.
   if ((Header_Size mod 4) /= 0) then
      Header_Offset := Header_Size + (4 - (Header_Size mod 4));
   else
      Header_Offset := Header_Size;
   end if;
end Asl.Leak_Detect_Pool;