-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 3, or (at your option) any later
-- version. The SPARK toolset 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 distributed with the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

with Ada.Exceptions;
with Statistics;
with SystemErrors;

package body Heap is

   Initial_Heap_Capacity : constant := 2 ** 10;

   Empty_Atom : constant Heap_Storage.Atom_Descriptor :=
     Heap_Storage.Atom_Descriptor'(PointerA => NullAtom,
                                   PointerB => NullAtom,
                                   ValueA   => 0,
                                   ValueB   => 0);

   Empty_Heap : constant HeapRecord :=
     HeapRecord'(ListOfAtoms  => Heap_Storage.Empty_Vector,
                 HighMark     => NullAtom,
                 NextFreeAtom => NullAtom);

   --------------------------------------------------------------------

   procedure Reset (TheHeap : in out HeapRecord) is
   begin
      -- Rest content ready for IFA of a fresh program unit
      TheHeap.HighMark     := NullAtom;
      TheHeap.NextFreeAtom := NullAtom;

      Heap_Storage.Set_Element (V     => TheHeap.ListOfAtoms,
                                Index => Atom'First,
                                Value => Empty_Atom);
   end Reset;

   procedure Initialize (TheHeap : out HeapRecord) is
   begin
      -- Complete initialization to make IFA happy.
      TheHeap := Empty_Heap;

      -- Now allocate some storage
      Heap_Storage.Initialize (Initial_Heap_Capacity, TheHeap.ListOfAtoms);

      -- and reset the initial content
      Reset (TheHeap);
   end Initialize;

   --------------------------------------------------------------------

   procedure CreateAtom (TheHeap : in out HeapRecord;
                         NewAtom :    out Atom) is
      A : Atom;
   begin
      if TheHeap.NextFreeAtom /= NullAtom then
         -- There are atoms in the returned free list,
         -- so recycle the first Atom off the free list.
         A                    := TheHeap.NextFreeAtom;
         TheHeap.NextFreeAtom := Heap_Storage.Get_Element (TheHeap.ListOfAtoms, TheHeap.NextFreeAtom).PointerA;

         Heap_Storage.Set_Element (V     => TheHeap.ListOfAtoms,
                                   Index => A,
                                   Value => Empty_Atom);
         NewAtom := A;
      elsif TheHeap.HighMark < Heap_Storage.Last_Index (TheHeap.ListOfAtoms) then
         -- Still rooom in the array no need to extend
         TheHeap.HighMark := TheHeap.HighMark + 1;
         A                := TheHeap.HighMark;
         Heap_Storage.Set_Element (TheHeap.ListOfAtoms, A, Empty_Atom);
         NewAtom := A;
      elsif TheHeap.HighMark < Atom'Last then
         --All the current array elements have been used - extend by appending
         TheHeap.HighMark := TheHeap.HighMark + 1;
         A                := TheHeap.HighMark;
         Heap_Storage.Append (TheHeap.ListOfAtoms, Empty_Atom);
         NewAtom := A;
      else
         -- TheHeap.HighMark = Atom'Last, so
         -- Array and returned atoms in free list both used up
         -- and set usage to 100% before exiting
         Statistics.SetTableUsage (Statistics.RelationTable, Integer (Atom'Last));
         SystemErrors.Fatal_Error (Sys_Err => SystemErrors.Empty_Heap,
                                   Msg     => "in Heap.CreateAtom");
         NewAtom := NullAtom;
      end if;
   exception
      --# hide CreateAtom;
      when Storage_Error =>
         -- Heap_Storage.Append really has run out of memory
         Statistics.SetTableUsage (Statistics.RelationTable, Integer (Atom'Last));
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Empty_Heap,
            Msg     => "in Heap.CreateAtom - Storage_Error in attempt to extend Heap");
         NewAtom := NullAtom;

      when E : others =>
         -- Something else has gone wrong
         Statistics.SetTableUsage (Statistics.RelationTable, Integer (Atom'Last));
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Empty_Heap,
            Msg     => "in Heap.CreateAtom - " &
              Ada.Exceptions.Exception_Name (E) &
              " - " &
              Ada.Exceptions.Exception_Message (E));
         NewAtom := NullAtom;
   end CreateAtom;

   --------------------------------------------------------------------

   procedure DisposeOfAtom (TheHeap : in out HeapRecord;
                            OldAtom : in     Atom) is
      The_Atom : Heap_Storage.Atom_Descriptor;
   begin
      The_Atom          := Heap_Storage.Get_Element (TheHeap.ListOfAtoms, OldAtom);
      The_Atom.PointerA := TheHeap.NextFreeAtom;
      Heap_Storage.Set_Element (TheHeap.ListOfAtoms, OldAtom, The_Atom);
      TheHeap.NextFreeAtom := OldAtom;
   end DisposeOfAtom;

   --------------------------------------------------------------------

   function APointer (TheHeap : HeapRecord;
                      A       : Atom) return Atom is
   begin
      return Heap_Storage.Get_Element (TheHeap.ListOfAtoms, A).PointerA;
   end APointer;

   --------------------------------------------------------------------

   function BPointer (TheHeap : HeapRecord;
                      A       : Atom) return Atom is
   begin
      return Heap_Storage.Get_Element (TheHeap.ListOfAtoms, A).PointerB;
   end BPointer;

   --------------------------------------------------------------------

   function AValue (TheHeap : HeapRecord;
                    A       : Atom) return Natural is
   begin
      return Heap_Storage.Get_Element (TheHeap.ListOfAtoms, A).ValueA;
   end AValue;

   --------------------------------------------------------------------

   function BValue (TheHeap : HeapRecord;
                    A       : Atom) return Natural is
   begin
      return Heap_Storage.Get_Element (TheHeap.ListOfAtoms, A).ValueB;
   end BValue;

   --------------------------------------------------------------------

   procedure UpdateAPointer (TheHeap    : in out HeapRecord;
                             A, Pointer : in     Atom) is
      The_Atom : Heap_Storage.Atom_Descriptor;
   begin
      The_Atom          := Heap_Storage.Get_Element (TheHeap.ListOfAtoms, A);
      The_Atom.PointerA := Pointer;
      Heap_Storage.Set_Element (TheHeap.ListOfAtoms, A, The_Atom);
   end UpdateAPointer;

   --------------------------------------------------------------------

   procedure UpdateBPointer (TheHeap    : in out HeapRecord;
                             A, Pointer : in     Atom) is
      The_Atom : Heap_Storage.Atom_Descriptor;
   begin
      The_Atom          := Heap_Storage.Get_Element (TheHeap.ListOfAtoms, A);
      The_Atom.PointerB := Pointer;
      Heap_Storage.Set_Element (TheHeap.ListOfAtoms, A, The_Atom);
   end UpdateBPointer;

   --------------------------------------------------------------------

   procedure UpdateAValue (TheHeap : in out HeapRecord;
                           A       : in     Atom;
                           Value   : in     Natural) is
      The_Atom : Heap_Storage.Atom_Descriptor;
   begin
      The_Atom        := Heap_Storage.Get_Element (TheHeap.ListOfAtoms, A);
      The_Atom.ValueA := Value;
      Heap_Storage.Set_Element (TheHeap.ListOfAtoms, A, The_Atom);
   end UpdateAValue;

   --------------------------------------------------------------------

   procedure UpdateBValue (TheHeap : in out HeapRecord;
                           A       : in     Atom;
                           Value   : in     Natural) is
      The_Atom : Heap_Storage.Atom_Descriptor;
   begin
      The_Atom        := Heap_Storage.Get_Element (TheHeap.ListOfAtoms, A);
      The_Atom.ValueB := Value;
      Heap_Storage.Set_Element (TheHeap.ListOfAtoms, A, The_Atom);
   end UpdateBValue;

   --------------------------------------------------------------------

   function IsNullPointer (A : Atom) return Boolean is
   begin
      return A = NullAtom;
   end IsNullPointer;

   procedure ReportUsage (TheHeap : in HeapRecord) is
   begin
      -- As the heap now uses the free list before increasing HighMark,
      -- the max usage is HighMark
      Statistics.SetTableUsage (Statistics.RelationTable, Integer (TheHeap.HighMark));
   end ReportUsage;

end Heap;
