with Ada.Finalization;         use Ada.Finalization;
with Ada.Text_IO;              use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with GNATCOLL.Asserts;
with GNATCOLL.Storage_Pools.Headers;  use GNATCOLL.Storage_Pools.Headers;
with System.Memory;
with System.Storage_Elements;  use System.Storage_Elements;
with System.Storage_Pools;     use System.Storage_Pools;
with System.Address_Image;

procedure Main is

   type On_Error is new GNATCOLL.Asserts.Error_Reporter with null record;
   overriding procedure On_Assertion_Failed
      (Self     : On_Error;
       Msg      : String;
       Details  : String;
       Location : String;
       Entity   : String);

   Report : On_Error;

   type Print_Pool is new Root_Storage_Pool with null record;
   overriding procedure Allocate
      (Pool       : in out Print_Pool;
       Addr       : out System.Address;
       Size       : Storage_Count;
       Alignment  : Storage_Count);
   overriding procedure Deallocate
      (Pool       : in out Print_Pool;
       Addr       : System.Address;
       Size       : Storage_Count;
       Alignment  : Storage_Count);
   overriding function Storage_Size
      (Pool       : Print_Pool) return Storage_Count is (0);

   Allocated : Storage_Count;

   overriding procedure Allocate
      (Pool       : in out Print_Pool;
       Addr       : out System.Address;
       Size       : Storage_Count;
       Alignment  : Storage_Count)
   is
   begin
      Addr := System.Memory.Alloc (System.Memory.size_t (Size));
      Allocated := Size;
   end Allocate;

   overriding procedure Deallocate
      (Pool       : in out Print_Pool;
       Addr       : System.Address;
       Size       : Storage_Count;
       Alignment  : Storage_Count)
   is
   begin
      System.Memory.Free (Addr);
   end Deallocate;

   package Asserts is new GNATCOLL.Asserts.Asserts (Report);

   package Equals_Offset is new Asserts.Equals
      (Storage_Offset, Storage_Offset'Image);
   use Equals_Offset;

   -----------
   -- Pools --
   -----------

   Pool      : Print_Pool;

   package Refcount_Pools is new Header_Pools (Storage_Offset);

   type Controlled_Header is new Controlled with record
      Refcount : Storage_Offset;
   end record;
   package Controlled_Pools is new Header_Pools (Controlled_Header);

   -------------------------
   -- On_Assertion_Failed --
   -------------------------

   overriding procedure On_Assertion_Failed
      (Self     : On_Error;
       Msg      : String;
       Details  : String;
       Location : String;
       Entity   : String)
   is
      pragma Unreferenced (Self);
   begin
      Put_Line
         ((if Msg = "" then "" else Msg & " ")
          & "(at " & Location & ", in " & Entity & ")"
          & ASCII.LF & "   " & Details);
   end On_Assertion_Failed;

   type A is array (1 .. 10) of Integer;
   type A_Access is access A;
   for A_Access'Storage_Pool use Pool;
   V_A_Access : A_Access;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
      (A, A_Access);

   type B is array (Natural range <>) of Integer;
   type B_Access is access B;
   for B_Access'Storage_Pool use Pool;
   V_B_Access : B_Access;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
      (B, B_Access);

   type B_Access_Flattened is access B;
   for B_Access_Flattened'Size use Standard'Address_Size;
   for B_Access_Flattened'Storage_Pool use Pool;
   V_B_Access_Flattened : B_Access_Flattened;
   --  For bounds to be stored before the array's data rather than
   --  in a separate data

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
      (B, B_Access_Flattened);

   package B2_Pools is new Refcount_Pools.Typed (B);
   B2_Access : B2_Pools.Element_Access;

   package B3_Pools is new Controlled_Pools.Typed (B);
   B3_Access : B3_Pools.Element_Access;


   ------------
   -- Record --
   ------------

   type R is record
      A : Integer;
   end record;
   type R_Access is access R;
   for R_Access'Storage_Pool use Pool;
   V_R_Access : R_Access;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
      (R, R_Access);

   ---------
   -- Tag --
   ---------

   type Tag is tagged record
      A : Storage_Offset;
   end record;
   type Tag_Access is access Tag;
   for Tag_Access'Storage_Pool use Pool;
   V_Tag_Access : Tag_Access;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
      (Tag, Tag_Access);

   package Tag2_Pools is new Refcount_Pools.Typed (Tag);
   V2_Tag_Access : Tag2_Pools.Element_Access;

   package Tag3_Pools is new Controlled_Pools.Typed (Tag);
   V3_Tag_Access : Tag3_Pools.Element_Access;

   ----------------
   -- Controlled --
   ----------------

   type C is new Controlled with record
      A : Storage_Offset;
   end record;
   type C_Access is access C;
   for C_Access'Storage_Pool use Pool;
   V_C_Access : C_Access;
   V_C : C with Warnings => Off;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
      (C, C_Access);

   package C2_Pools is new Refcount_Pools.Typed (C);
   V2_C_Access : C2_Pools.Element_Access;

   package C3_Pools is new Controlled_Pools.Typed (C);
   V3_C_Access : C3_Pools.Element_Access;

   ---------------------------
   -- Indefinite controlled --
   ---------------------------

   type CD (Size : Natural) is new Controlled with record
      A : Integer;
      F : B (1 .. Size);
   end record;
   type CD_Access is access CD;
   for CD_Access'Storage_Pool use Pool;
   V_CD_Access : CD_Access;

   procedure Unchecked_Free is new Ada.Unchecked_Deallocation
      (CD, CD_Access);

   SE : constant Storage_Offset := Storage_Element'Size;

begin
   --  constrained array

   Assert (A'Size, 10 * Integer'Size);
   Assert (A'Object_Size, 10 * Integer'Size);
   Assert (A'Descriptor_Size, 0);

   --  access to constrained array

   Assert (A_Access'Size, System.Word_Size);
   Assert (A_Access'Descriptor_Size, 0);
   V_A_Access := new A;
   Assert (V_A_Access.all'Size, 10 * Integer'Size);
   Assert (Allocated, 10 * Integer'Size / SE);

   Unchecked_Free (V_A_Access);

   --  unconstrained array
   --  The compiler will allocate extra memory for the bounds

   Assert (B'Descriptor_Size, 2 * Natural'Object_Size);

   --  access to unconstrained array
   --  This is a fat pointer and include the bounds First and Last

   Assert (B_Access'Size, System.Word_Size + 2 * Natural'Object_Size);
   Assert (B_Access'Descriptor_Size, 0);
   V_B_Access := new B (1 .. 10);
   Assert (V_B_Access.all'Size, 10 * Integer'Size);
   Assert (Allocated, 10 * Integer'Size / SE + 2 * Natural'Object_Size / SE);

   Unchecked_Free (V_B_Access);

   --  flattened access type.
   --  The size of bounds is added to the pointed data, but are not part
   --  of the access type.

   Assert (B_Access_Flattened'Size, System.Word_Size);
   Assert (B_Access_Flattened'Descriptor_Size, 0);
   V_B_Access_Flattened := new B (1 .. 10);
   Assert (V_B_Access_Flattened.all'Size, 10 * Integer'Size);
   Assert (Allocated, 10 * Integer'Size / SE + 2 * Natural'Object_Size / SE);

   Unchecked_Free (V_B_Access_Flattened);

   --  Header pool on an unconstrained array

   B2_Access := new B (1 .. 10);
   B2_Pools.Header_Of (B2_Access).all := 1;  --  refcount
   B2_Access (1) := 2;
   Assert (B2_Pools.Header_Of (B2_Access).all, 1);
   B2_Pools.Header_Of (B2_Access).all := 3;
   Assert (Storage_Offset (B2_Access (1)), 2);

   B2_Pools.Free (B2_Access);

   B3_Access := new B (1 .. 10);
   B3_Pools.Header_Of (B3_Access).Refcount := 1;
   B3_Access (1) := 2;
   Assert (B3_Pools.Header_Of (B3_Access).Refcount, 1);
   B3_Pools.Header_Of (B3_Access).Refcount := 3;
   Assert (Storage_Offset (B3_Access (1)), 2);

   B3_Pools.Free (B3_Access);

   --  record type

   Assert (R'Descriptor_Size, 0);
   Assert (R_Access'Size, System.Word_Size);
   Assert (R_Access'Descriptor_Size, 0);
   Assert (R'Size, Integer'Size);
   Assert (R'Object_Size, 32);  --  actual size
   Assert (R'Value_Size, 32);   --  minimal size
   V_R_Access := new R;
   Assert (V_R_Access.all'Size, Integer'Size);
   Assert (Allocated, Integer'Size / SE);

   Assert (R'Max_Size_In_Storage_Elements - (R'Object_Size / SE),
           0);

   Unchecked_Free (V_R_Access);

   --  tagged record type
   --  The pointed object size is twice the word size because of
   --  alignment (the integer is represented on 64 bits on 64 bits systems)

   Assert (Tag'Descriptor_Size, 0);
   Assert (Tag_Access'Size, System.Word_Size);
   Assert (Tag_Access'Descriptor_Size, 0);
   V_Tag_Access := new Tag;
   Assert (V_Tag_Access.all'Size, 2 *  System.Word_Size);
   Assert (Allocated, 2 * System.Word_Size / SE);

   Unchecked_Free (V_Tag_Access);

   --  Header pool on a tagged record type.
   --  Try changing the header and the record to make sure they do not
   --  interfer with each other.

   V2_Tag_Access := new Tag;
   Assert (V2_Tag_Access.all'Size, 2 * System.Word_Size);
   Tag2_Pools.Header_Of (V2_Tag_Access).all := 1;  --  refcount
   V2_Tag_Access.A := 2;
   Assert (Tag2_Pools.Header_Of (V2_Tag_Access).all, 1);
   Tag2_Pools.Header_Of (V2_Tag_Access).all := 3;
   Assert (V2_Tag_Access.A, 2);

   Tag2_Pools.Free (V2_Tag_Access);

   V3_Tag_Access := new Tag;
   Assert (V3_Tag_Access.all'Size, 2 * System.Word_Size);
   Tag3_Pools.Header_Of (V3_Tag_Access).Refcount := 1;
   V3_Tag_Access.A := 2;
   Assert (Tag3_Pools.Header_Of (V3_Tag_Access).Refcount, 1);
   Tag3_Pools.Header_Of (V3_Tag_Access).Refcount := 3;
   Assert (V3_Tag_Access.A, 2);

   Tag3_Pools.Free (V3_Tag_Access);

   Assert (Tag'Max_Size_In_Storage_Elements - (Tag'Object_Size / SE),
           0);

   --  controlled type
   --  The size is the tag + the integer

   Assert (V_C'Size, 2 * System.Word_Size);

   --  access to controlled type
   --  The Allocated size takes into account the Next and Previous pointers
   --  used for controlled types.

   Assert (C'Descriptor_Size, 0);
   Assert (C_Access'Size, System.Word_Size);
   Assert (C_Access'Descriptor_Size, 0);
   V_C_Access := new C;
   Assert (V_C_Access.all'Size, 2 * System.Word_Size);
   Assert (Allocated, 4 * System.Word_Size / SE);

   Assert (C'Max_Size_In_Storage_Elements - (C'Object_Size / SE),
           2 * System.Word_Size / SE);

   Unchecked_Free (V_C_Access);

   --  Header pools with a controlled type

   V2_C_Access := new C;
   Assert (V2_C_Access.all'Size, 2 * System.Word_Size);
   C2_Pools.Header_Of (V2_C_Access).all := 1;  --  refcount
   V2_C_Access.A := 2;
   Assert (C2_Pools.Header_Of (V2_C_Access).all, 1);
   C2_Pools.Header_Of (V2_C_Access).all := 3;
   Assert (V2_C_Access.A, 2);

   C2_Pools.Free (V2_C_Access);

   --  Header pools with controlled header and controlled type

   V3_C_Access := new C;
   Assert (V3_C_Access.all'Size, 2 * System.Word_Size);
   C3_Pools.Header_Of (V3_C_Access).Refcount := 1;
   V3_C_Access.A := 2;
   Assert (C3_Pools.Header_Of (V3_C_Access).Refcount, 1);
   C3_Pools.Header_Of (V3_C_Access).Refcount := 3;
   Assert (V3_C_Access.A, 2);

   C3_Pools.Free (V3_C_Access);

   --  indefinite controlled type

   Assert (CD'Descriptor_Size, 0);
   Assert (CD_Access'Size, System.Word_Size);
   Assert (CD_Access'Descriptor_Size, 0);
   V_CD_Access := new CD (Size => 10);
   Assert (V_CD_Access.all'Size, 2 * System.Word_Size + 10 * Integer'Size);
   Assert (Allocated, 4 * System.Word_Size / SE + 10 * Integer'Size / SE);

   Unchecked_Free (V_CD_Access);

end Main;
