-----------------------------------------------------------------------
--                          G N A T C O L L                          --
--                                                                   --
--                 Copyright (C) 2005-2008, AdaCore                  --
--                                                                   --
-- GPS 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 program 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 program; --
-- if not,  write to the  Free Software Foundation, Inc.,  59 Temple --
-- Place - Suite 330, Boston, MA 02111-1307, USA.                    --
-----------------------------------------------------------------------

with System.Storage_Pools;       use System, System.Storage_Pools;
with System.Storage_Elements;    use System.Storage_Elements;
with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;

package body GNATCOLL.Storage_Pools.Alignment is

   type Storage_Element_Access is access Storage_Element;
   function Convert is new Ada.Unchecked_Conversion
     (System.Address, Storage_Element_Access);

   --------------
   -- Allocate --
   --------------

   procedure Allocate
     (Pool         : in out Unbounded_No_Reclaim_Align_Pool;
      Address      : out System.Address;
      Storage_Size : Storage_Count;
      Alignment    : Storage_Count)
   is
      pragma Unreferenced (Alignment);

      --   We need to allocate more memory than actually requested, so that
      --   even if "new" returns an incorrect alignment, we have enough spare
      --   memory to return the correct alignment. We also always need a buffer
      --   of at least two Storage_Element to store the offset between the
      --   address from "new" and the one returned by the use, so that
      --   Deallocates works appropriately.
      --   Worst case is when "new" returned a correctly aligned chunk, and we
      --   then need to offset by Pool.Alignment bytes.

      Bytes_For_Offset : constant := 3;

      Align : constant Storage_Count  := Pool.Alignment;
      Size  : constant Storage_Offset :=
        Storage_Size + Align + Bytes_For_Offset - 1;

      subtype Local_Storage_Array is Storage_Array (1 .. Size);
      type Ptr is access Local_Storage_Array;

      Allocated : constant Ptr := new Local_Storage_Array;
      Offset    : constant Storage_Count :=
        Align - Allocated.all'Address mod Align;

   begin
      Allocated (Offset - 2) := Storage_Element (Offset / 65_536);
      Allocated (Offset - 1) := Storage_Element ((Offset mod 65_536) / 256);
      Allocated (Offset) := Storage_Element (Offset mod 256);
      Address := Allocated.all'Address + Offset;
   end Allocate;

   ----------------
   -- Deallocate --
   ----------------

   procedure Deallocate
     (Pool         : in out Unbounded_No_Reclaim_Align_Pool;
      Address      : System.Address;
      Storage_Size : Storage_Count;
      Alignment    : Storage_Count)
   is
      pragma Unreferenced (Alignment);

      Size : constant Storage_Offset :=
        Storage_Size + Pool.Alignment;
      subtype Local_Storage_Array is Storage_Array (1 .. Size);
      type Ptr is access Local_Storage_Array;

      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
        (Local_Storage_Array, Ptr);
      function Convert is new Ada.Unchecked_Conversion
        (System.Address, Ptr);

      Offset_High2 : constant Storage_Element := Convert (Address - 3).all;
      Offset_High  : constant Storage_Element := Convert (Address - 2).all;
      Offset_Low   : constant Storage_Element := Convert (Address - 1).all;
      Offset : constant Storage_Count :=
         Storage_Count (Offset_High2) * 65_536
         + Storage_Count (Offset_High) * 256
         + Storage_Count (Offset_Low);

      Real_Address : constant System.Address := Address - Offset;
      Var : Ptr := Convert (Real_Address);

   begin
      Unchecked_Free (Var);
   end Deallocate;

   ------------------
   -- Storage_Size --
   ------------------

   function Storage_Size
     (Pool  : Unbounded_No_Reclaim_Align_Pool) return Storage_Count
   is
      pragma Unreferenced (Pool);
   begin
      --  Intuitively, should return System.Memory_Size. But on Sun/Alsys,
      --  System.Memory_Size > System.Max_Int, which means all you can do with
      --  it is raise CONSTRAINT_ERROR...
      return Storage_Count'Last;
   end Storage_Size;
end GNATCOLL.Storage_Pools.Alignment;
