-------------------------------------------------------------------------------
-- (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 ExaminerConstants;
with SystemErrors;
with Statistics;

package body Cells is
   Initial_Heap_Capacity : constant := 2 ** 10;

   Null_Cell_Content : constant Cell_Content :=
     Cell_Content'
     (A_Ptr     => Null_Cell,
      B_Ptr     => Null_Cell,
      C_Ptr     => Null_Cell,
      Copy      => Null_Cell,
      Free      => False,
      Kind      => Cell_Storage.Unknown_Kind,
      Rank      => Unknown_Rank,
      Lex_Str   => LexTokenManager.Null_String,
      Marked    => False,
      Op_Symbol => SP_Symbols.RWnull,
      Val       => 0,
      Assoc_Var => Dictionary.NullSymbol);

   procedure Initialize (Heap : out Heap_Record) is
   begin
      Cell_Storage.Initialize (Initial_Heap_Capacity, Heap.List_Of_Cells);

      Heap.High_Mark      := Cell'First;
      Heap.Next_Free_Cell := Cell'First;

      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => Cell'First,
                                Value => Null_Cell_Content);
   end Initialize;

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

   function Are_Identical (Cell_1, Cell_2 : Cell) return Boolean is
   begin
      return Cell_1 = Cell_2;
   end Are_Identical;

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

   function Get_A_Ptr (Heap     : Heap_Record;
                       CellName : Cell) return Cell is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).A_Ptr;
   end Get_A_Ptr;

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

   function Get_B_Ptr (Heap     : Heap_Record;
                       CellName : Cell) return Cell is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).B_Ptr;
   end Get_B_Ptr;

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

   function Get_C_Ptr (Heap     : Heap_Record;
                       CellName : Cell) return Cell is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).C_Ptr;
   end Get_C_Ptr;

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

   function Get_Natural_Value (Heap     : Heap_Record;
                               CellName : Cell) return Natural is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Val;
   end Get_Natural_Value;

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

   function Get_Rank (Heap     : Heap_Record;
                      CellName : Cell) return Cell_Rank is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Rank;
   end Get_Rank;

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

   function Get_Copy (Heap     : Heap_Record;
                      CellName : Cell) return Cell is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Copy;
   end Get_Copy;

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

   function Is_Free (Heap     : Heap_Record;
                     CellName : Cell) return Boolean is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Free;
   end Is_Free;

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

   function Is_Marked (Heap     : Heap_Record;
                       CellName : Cell) return Boolean is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Marked;
   end Is_Marked;

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

   function Is_Null_Cell (CellName : Cell) return Boolean is
   begin
      return CellName = Null_Cell;
   end Is_Null_Cell;

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

   function Is_Const_Cell (Heap     : Heap_Record;
                           CellName : Cell) return Boolean is
   begin
      return (Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Kind = Cell_Storage.Manifest_Const)
        or else (Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Kind = Cell_Storage.Named_Const);
   end Is_Const_Cell;

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

   function Is_Reference_Cell (Heap     : Heap_Record;
                               CellName : Cell) return Boolean is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Kind = Cell_Storage.Reference;
   end Is_Reference_Cell;

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

   function Get_Kind (Heap     : Heap_Record;
                      CellName : Cell) return Cell_Kind is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Kind;
   end Get_Kind;

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

   function Get_Op_Symbol (Heap     : Heap_Record;
                           CellName : Cell) return SP_Symbols.SP_Symbol is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Op_Symbol;
   end Get_Op_Symbol;

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

   function Get_Lex_Str (Heap     : Heap_Record;
                         CellName : Cell) return LexTokenManager.Lex_String is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Lex_Str;
   end Get_Lex_Str;

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

   function Get_Symbol_Value (Heap     : Heap_Record;
                              CellName : Cell) return Dictionary.Symbol is
   begin
      return Dictionary.ConvertSymbolRef (ExaminerConstants.RefType (Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Val));
   end Get_Symbol_Value;

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

   function Cell_Ref (Cell_Name : in Cell) return Natural is
   begin
      return Natural (Cell_Name);
   end Cell_Ref;

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

   procedure Set_A_Ptr (Heap           : in out Heap_Record;
                        Cell_1, Cell_2 : in     Cell) is
      The_Cell : Cell_Content;
   begin
      The_Cell       := Cell_Storage.Get_Element (Heap.List_Of_Cells, Cell_1);
      The_Cell.A_Ptr := Cell_2;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => Cell_1,
                                Value => The_Cell);
   end Set_A_Ptr;

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

   procedure Set_B_Ptr (Heap           : in out Heap_Record;
                        Cell_1, Cell_2 : in     Cell) is
      The_Cell : Cell_Content;
   begin
      The_Cell       := Cell_Storage.Get_Element (Heap.List_Of_Cells, Cell_1);
      The_Cell.B_Ptr := Cell_2;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => Cell_1,
                                Value => The_Cell);
   end Set_B_Ptr;

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

   procedure Set_C_Ptr (Heap           : in out Heap_Record;
                        Cell_1, Cell_2 : in     Cell) is
      The_Cell : Cell_Content;
   begin
      The_Cell       := Cell_Storage.Get_Element (Heap.List_Of_Cells, Cell_1);
      The_Cell.C_Ptr := Cell_2;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => Cell_1,
                                Value => The_Cell);
   end Set_C_Ptr;

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

   procedure Copy_Contents (Heap                : in out Heap_Record;
                            Source, Destination : in     Cell) is
      Dest_Cell, Source_Cell : Cell_Content;
   begin
      Source_Cell := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                               Index => Source);
      Dest_Cell   := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                               Index => Destination);

      Dest_Cell :=
        Cell_Content'
        (A_Ptr     => Source_Cell.A_Ptr,
         B_Ptr     => Source_Cell.B_Ptr,
         C_Ptr     => Dest_Cell.C_Ptr,
         Copy      => Dest_Cell.Copy,
         Free      => Dest_Cell.Free,
         Kind      => Source_Cell.Kind,
         Rank      => Source_Cell.Rank,
         Lex_Str   => Source_Cell.Lex_Str,
         Marked    => Dest_Cell.Marked,
         Op_Symbol => Source_Cell.Op_Symbol,
         Val       => Source_Cell.Val,
         Assoc_Var => Source_Cell.Assoc_Var);

      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => Destination,
                                Value => Dest_Cell);
   end Copy_Contents;

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

   procedure Create_Cell (Heap     : in out Heap_Record;
                          CellName :    out Cell) is
      NewCell : Cell;
   begin
      if Heap.Next_Free_Cell /= Null_Cell then
         -- There are cells in the returned free list, so recycle
         -- the first Cell on the free list
         NewCell             := Heap.Next_Free_Cell;
         Heap.Next_Free_Cell := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                                          Index => Heap.Next_Free_Cell).A_Ptr;
         Cell_Storage.Set_Element (Heap.List_Of_Cells, NewCell, Null_Cell_Content);
         CellName := NewCell;
      elsif Heap.High_Mark < Cell_Storage.Last_Index (Heap.List_Of_Cells) then
         -- Free list empty but still room within the array
         Heap.High_Mark := Heap.High_Mark + 1;
         NewCell        := Heap.High_Mark;
         Cell_Storage.Set_Element (Heap.List_Of_Cells, NewCell, Null_Cell_Content);
         CellName := NewCell;
      elsif Heap.High_Mark < Cell_Storage.Cell'Last then
         -- All the current array elements have been used - extend by appending
         Heap.High_Mark := Heap.High_Mark + 1;
         NewCell        := Heap.High_Mark;
         Cell_Storage.Append (Heap.List_Of_Cells, Null_Cell_Content);
         CellName := NewCell;
      else
         -- Array and returned cells in free list both used up
         -- Set table use to 100%
         Statistics.SetTableUsage (Statistics.VCGHeap, Integer (Cell'Last));
         SystemErrors.Fatal_Error (Sys_Err => SystemErrors.VCG_Heap_Is_Exhausted,
                                   Msg     => "");
         CellName := Null_Cell;
      end if;
   exception
      --# hide Create_Cell;
      when Storage_Error =>
         -- Cell_Storage.Append really has run out of memory
         Statistics.SetTableUsage (Statistics.VCGHeap, Integer (Cell'Last));
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.VCG_Heap_Is_Exhausted,
            Msg     => "in Cells.Create_Cell - Storage_Error in attempt to extend");
         CellName := Null_Cell;

      when E : others =>
         -- Something else has gone wrong
         Statistics.SetTableUsage (Statistics.VCGHeap, Integer (Cell'Last));
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.VCG_Heap_Is_Exhausted,
            Msg     => "in Cells.Create_Cell - " &
              Ada.Exceptions.Exception_Name (E) &
              " - " &
              Ada.Exceptions.Exception_Message (E));
         CellName := Null_Cell;
   end Create_Cell;

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

   procedure Create_Copy (Heap     : in out Heap_Record;
                          CellName : in     Cell) is
      NewCell                : Cell;
      Dest_Cell, Source_Cell : Cell_Content;
   begin
      Create_Cell (Heap, NewCell);
      Source_Cell := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                               Index => CellName);
      Dest_Cell   := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                               Index => NewCell);

      Dest_Cell.Kind      := Source_Cell.Kind;
      Dest_Cell.Rank      := Source_Cell.Rank;
      Dest_Cell.Lex_Str   := Source_Cell.Lex_Str;
      Dest_Cell.Op_Symbol := Source_Cell.Op_Symbol;
      Dest_Cell.Val       := Source_Cell.Val;
      Dest_Cell.Assoc_Var := Source_Cell.Assoc_Var;

      Source_Cell.Copy := NewCell;

      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => NewCell,
                                Value => Dest_Cell);

      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => CellName,
                                Value => Source_Cell);
   end Create_Copy;

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

   procedure Dispose_Of_Cell (Heap     : in out Heap_Record;
                              CellName : in     Cell) is
      The_Cell : Cell_Content;
   begin
      The_Cell := Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName);
      if The_Cell.Free then
         SystemErrors.Fatal_Error (Sys_Err => SystemErrors.VCG_Heap_Is_Corrupted,
                                   Msg     => "in DisposeOfCell");
      else
         The_Cell.A_Ptr      := Heap.Next_Free_Cell;
         The_Cell.Free       := True;
         Heap.Next_Free_Cell := CellName;
         Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                   Index => CellName,
                                   Value => The_Cell);
      end if;
   end Dispose_Of_Cell;

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

   procedure Mark_Cell (Heap     : in out Heap_Record;
                        CellName : in     Cell) is
      The_Cell : Cell_Content;
   begin
      The_Cell        := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                                   Index => CellName);
      The_Cell.Marked := True;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => CellName,
                                Value => The_Cell);
   end Mark_Cell;

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

   procedure UnMark_Cell (Heap     : in out Heap_Record;
                          CellName : in     Cell) is
      The_Cell : Cell_Content;
   begin
      The_Cell        := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                                   Index => CellName);
      The_Cell.Marked := False;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => CellName,
                                Value => The_Cell);
   end UnMark_Cell;

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

   procedure Set_Kind (Heap      : in out Heap_Record;
                       CellName  : in     Cell;
                       KindConst : in     Cell_Kind) is
      The_Cell : Cell_Content;
   begin
      The_Cell      := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                                 Index => CellName);
      The_Cell.Kind := KindConst;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => CellName,
                                Value => The_Cell);
   end Set_Kind;

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

   procedure Set_Rank (Heap     : in out Heap_Record;
                       CellName : in     Cell;
                       Rank     : in     Cell_Rank) is
      The_Cell : Cell_Content;
   begin
      The_Cell      := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                                 Index => CellName);
      The_Cell.Rank := Rank;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => CellName,
                                Value => The_Cell);
   end Set_Rank;

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

   procedure Set_Op_Symbol (Heap     : in out Heap_Record;
                            CellName : in     Cell;
                            Sym      : in     SP_Symbols.SP_Symbol) is
      The_Cell : Cell_Content;
   begin
      The_Cell           := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                                      Index => CellName);
      The_Cell.Op_Symbol := Sym;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => CellName,
                                Value => The_Cell);
   end Set_Op_Symbol;

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

   procedure Set_Lex_Str (Heap     : in out Heap_Record;
                          CellName : in     Cell;
                          Str      : in     LexTokenManager.Lex_String) is
      The_Cell : Cell_Content;
   begin
      The_Cell         := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                                    Index => CellName);
      The_Cell.Lex_Str := Str;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => CellName,
                                Value => The_Cell);
   end Set_Lex_Str;

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

   procedure Set_Natural_Value (Heap     : in out Heap_Record;
                                CellName : in     Cell;
                                Value    : in     Natural) is
      The_Cell : Cell_Content;
   begin
      The_Cell     := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                                Index => CellName);
      The_Cell.Val := Value;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => CellName,
                                Value => The_Cell);
   end Set_Natural_Value;

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

   procedure Set_Symbol_Value (Heap     : in out Heap_Record;
                               CellName : in     Cell;
                               Sym      : in     Dictionary.Symbol) is
   begin
      Set_Natural_Value (Heap, CellName, Natural (Dictionary.SymbolRef (Sym)));
   end Set_Symbol_Value;

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

   procedure Report_Usage (TheHeap : in Heap_Record) is
   begin
      -- as the heap now uses the free list before increasing High_Mark,
      -- the max usage is High_Mark
      Statistics.SetTableUsage (Statistics.VCGHeap, Integer (TheHeap.High_Mark));
   end Report_Usage;

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

   procedure Set_Assoc_Var (Heap     : in out Heap_Record;
                            CellName : in     Cell;
                            VarSym   : in     Dictionary.Symbol) is
      The_Cell : Cell_Content;
   begin
      The_Cell           := Cell_Storage.Get_Element (V     => Heap.List_Of_Cells,
                                                      Index => CellName);
      The_Cell.Assoc_Var := VarSym;
      Cell_Storage.Set_Element (V     => Heap.List_Of_Cells,
                                Index => CellName,
                                Value => The_Cell);
   end Set_Assoc_Var;

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

   function Get_Assoc_Var (Heap     : in Heap_Record;
                           CellName : in Cell) return Dictionary.Symbol is
   begin
      return Cell_Storage.Get_Element (Heap.List_Of_Cells, CellName).Assoc_Var;
   end Get_Assoc_Var;

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

   function Get_Heap_Size (Heap : in Heap_Record) return Cell_Storage.Cell is
   begin
      return Cell_Storage.Last_Index (Heap.List_Of_Cells);
   end Get_Heap_Size;

end Cells;
