-------------------------------------------------------------------------------
-- (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.
--
--=============================================================================

--------------------------------------------------------------------------------
--Synopsis:                                                                   --
--                                                                            --
--Package combining Heap and VCDetails to give an ordered list of VC details. --
--                                                                            --
--------------------------------------------------------------------------------

with FatalErrors;
with HeapIndex;

use type HeapIndex.IndexType;

package body VCHeap
--# own I_State is Longest_VC_End_Length,
--#                Longest_VC_Name_Length,
--#                Longest_VC_Start_Length,
--#                VC_Name_Prefix &
--#     State is Start_Of_Pointers_List,
--#              The_Details,
--#              The_Pointers;
is

   The_Pointers           : Heap.HeapRecord;
   The_Details            : VCDetails.Data_Type;
   Start_Of_Pointers_List : Heap.Atom;

   -- this one is used to record the prefix name for the VCs
   VC_Name_Prefix : E_Strings.T;

   -- the following are used as VC are added to the heap to record information
   -- used later for displaying the results as a table
   Longest_VC_Name_Length  : Integer;
   Longest_VC_Start_Length : Integer;
   Longest_VC_End_Length   : Integer;

   function First_Entry return  Heap.Atom
   --# global in Start_Of_Pointers_List;
   is
   begin
      return Start_Of_Pointers_List;
   end First_Entry;

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

   procedure Add
     (Start_Index : in Heap.Atom;
      New_Name    : in E_Strings.T;
      Path_Start  : in E_Strings.T;
      Path_End    : in E_Strings.T;
      End_Type    : in VCDetails.Terminal_Point_Type;
      VC_State    : in VCDetails.VC_State_T;
      DPC_State   : in VCDetails.DPC_State_T)
   --# global in out FatalErrors.State;
   --#        in out Longest_VC_End_Length;
   --#        in out Longest_VC_Name_Length;
   --#        in out Longest_VC_Start_Length;
   --#        in out The_Details;
   --#        in out The_Pointers;
   --# derives FatalErrors.State,
   --#         The_Details,
   --#         The_Pointers            from *,
   --#                                      DPC_State,
   --#                                      End_Type,
   --#                                      New_Name,
   --#                                      Path_End,
   --#                                      Path_Start,
   --#                                      Start_Index,
   --#                                      The_Details,
   --#                                      The_Pointers,
   --#                                      VC_State &
   --#         Longest_VC_End_Length   from *,
   --#                                      Path_End &
   --#         Longest_VC_Name_Length  from *,
   --#                                      New_Name &
   --#         Longest_VC_Start_Length from *,
   --#                                      Path_Start;
   is
      Existing_Name       : E_Strings.T;
      Existing_Path_Start : E_Strings.T;
      Existing_Path_End   : E_Strings.T;
      Existing_End_Type   : VCDetails.Terminal_Point_Type;

      Existing_VC_State  : VCDetails.VC_State_T;
      Existing_DPC_State : VCDetails.DPC_State_T;

      List_Index         : Heap.Atom;
      Loop_Finished      : Boolean := False;
      Next_Entry_In_List : Heap.Atom;
      Order_Result       : E_Strings.Order_Types;
      Retrieve_Success   : Boolean;

      procedure Insert_In_List
        (List_Index         : in Heap.Atom;
         Next_Entry_In_List : in Heap.Atom;
         Name               : in E_Strings.T;
         Path_Start         : in E_Strings.T;
         Path_End           : in E_Strings.T;
         End_Type           : in VCDetails.Terminal_Point_Type;
         VC_State           : in VCDetails.VC_State_T;
         DPC_State          : in VCDetails.DPC_State_T)
      --# global in out FatalErrors.State;
      --#        in out The_Details;
      --#        in out The_Pointers;
      --# derives FatalErrors.State from *,
      --#                                The_Details,
      --#                                The_Pointers &
      --#         The_Details       from *,
      --#                                DPC_State,
      --#                                End_Type,
      --#                                Name,
      --#                                Path_End,
      --#                                Path_Start,
      --#                                VC_State &
      --#         The_Pointers      from *,
      --#                                List_Index,
      --#                                Next_Entry_In_List,
      --#                                The_Details;
      is
         Create_Atom_Success : Boolean;
         Details_Add_Success : Boolean;
         New_Details_Index   : HeapIndex.IndexType;
         New_Pointers_Index  : Heap.Atom;
      begin
         -- allocate heap atom
         Heap.CreateAtom (The_Pointers, New_Pointers_Index, Create_Atom_Success);

         -- allocate file details entry
         VCDetails.Add
           (Details    => The_Details,
            Index      => New_Details_Index,
            Success    => Details_Add_Success,
            Name       => Name,
            Path_Start => Path_Start,
            Path_End   => Path_End,
            End_Type   => End_Type,
            VC_State   => VC_State,
            DPC_State  => DPC_State);

         if not (Create_Atom_Success and Details_Add_Success) then
            FatalErrors.Process (FatalErrors.VC_Heap_Full, E_Strings.Empty_String);
         end if;

         -- point heap atom to file details entry
         Heap.UpdateAValue (The_Pointers, New_Pointers_Index, New_Details_Index);

         -- link heap atom into list
         Heap.UpdateAPointer (The_Pointers, List_Index, New_Pointers_Index);
         Heap.UpdateAPointer (The_Pointers, New_Pointers_Index, Next_Entry_In_List);

      end Insert_In_List;

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

      function Longest_Of (First_Length  : Integer;
                           Second_Length : Integer) return Integer is
         Result : Integer;
      begin
         if First_Length > Second_Length then
            Result := First_Length;
         else
            Result := Second_Length;
         end if;

         return Result;
      end Longest_Of;

   begin -- Add

      -- start at point specified in linked list
      List_Index := Start_Index;

      while not Loop_Finished loop
         -- if current item is last then add after it
         Next_Entry_In_List := Heap.APointer (The_Pointers, List_Index);

         if Next_Entry_In_List = 0 then
            Insert_In_List
              (List_Index         => List_Index,
               Next_Entry_In_List => Next_Entry_In_List,
               Name               => New_Name,
               Path_Start         => Path_Start,
               Path_End           => Path_End,
               End_Type           => End_Type,
               VC_State           => VC_State,
               DPC_State          => DPC_State);
            Loop_Finished := True;
         else
            -- otherwise get relative order of next item in list and the new item
            --# accept F, 10, Existing_Path_Start, "Existing_Path_Start not used here" &
            --#        F, 10, Existing_Path_End, "Existing_Path_End not used here" &
            --#        F, 10, Existing_End_Type, "Existing_End_Type not used here" &
            --#        F, 10, Existing_VC_State, "Existing_VC_State not used here" &
            --#        F, 10, Existing_DPC_State, "Existing_DPC_State not used here" ;
            VCDetails.Retrieve
              (The_Details,
               Heap.AValue (The_Pointers, Next_Entry_In_List),
               Retrieve_Success,
               Existing_Name,
               Existing_Path_Start,
               Existing_Path_End,
               Existing_End_Type,
               Existing_VC_State,
               Existing_DPC_State);
            --# end accept;

            if not Retrieve_Success then
               FatalErrors.Process (FatalErrors.VC_Data_Structure_Inconsistency, E_Strings.Empty_String);
            end if;

            VCDetails.Order (Existing_Name, New_Name, Order_Result);

            case Order_Result is
               when E_Strings.First_One_First =>
                  -- next item in list is first, keep going down list
                  List_Index := Next_Entry_In_List;

               when E_Strings.Second_One_First =>
                  -- new item is first, insert here
                  Insert_In_List
                    (List_Index         => List_Index,
                     Next_Entry_In_List => Next_Entry_In_List,
                     Name               => New_Name,
                     Path_Start         => Path_Start,
                     Path_End           => Path_End,
                     End_Type           => End_Type,
                     VC_State           => VC_State,
                     DPC_State          => DPC_State);
                  Loop_Finished := True;

               when E_Strings.Neither_First =>
                  -- items identical: do nothing
                  Loop_Finished := True;

            end case;
         end if;
      end loop;

      Longest_VC_Name_Length  :=
        Longest_Of (First_Length  => E_Strings.Get_Length (E_Str => New_Name),
                    Second_Length => Longest_VC_Name_Length);
      Longest_VC_Start_Length :=
        Longest_Of (First_Length  => E_Strings.Get_Length (E_Str => Path_Start),
                    Second_Length => Longest_VC_Start_Length);

      Longest_VC_End_Length :=
        Longest_Of
        (First_Length  => E_Strings.Get_Length (E_Str => Path_End) + VCDetails.End_Type_Image_Length,
         Second_Length => Longest_VC_End_Length);
      --# accept F, 33, Existing_Path_Start, "Existing_Path_Start not used here" &
      --#        F, 33, Existing_Path_End, "Existing_Path_End not used here" &
      --#        F, 33, Existing_End_Type, "Existing_End_Type not used here" &
      --#        F, 33, Existing_VC_State, "Existing_VC_State not used here" &
      --#        F, 33, Existing_DPC_State,"Existing_DPC_State not used here";
   end Add;

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

   -- this procedure returns the file details for the specified entry in the
   -- linked list.
   procedure Details
     (List_Index : in     Heap.Atom;
      VC_Name    :    out E_Strings.T;
      Path_Start :    out E_Strings.T;
      Path_End   :    out E_Strings.T;
      End_Type   :    out VCDetails.Terminal_Point_Type;
      VC_State   :    out VCDetails.VC_State_T;
      DPC_State  :    out VCDetails.DPC_State_T)
   --# global in The_Details;
   --#        in The_Pointers;
   --# derives DPC_State,
   --#         End_Type,
   --#         Path_End,
   --#         Path_Start,
   --#         VC_Name,
   --#         VC_State   from List_Index,
   --#                         The_Details,
   --#                         The_Pointers;
   is
      Details_Index : HeapIndex.IndexType;
      Dummy         : Boolean;
   begin

      -- dereference linked list pointer
      Details_Index := Heap.AValue (The_Pointers, List_Index);

      -- if not null pointer then follow it
      if Details_Index /= 0 then
         --# accept F, 10, Dummy, "Dummy not used here";
         VCDetails.Retrieve (The_Details, Details_Index, Dummy, VC_Name, Path_Start, Path_End, End_Type, VC_State, DPC_State);
         --# end accept;
      else
         -- if null pointer then return failure
         VC_Name    := E_Strings.Empty_String;
         Path_Start := E_Strings.Empty_String;
         Path_End   := E_Strings.Empty_String;
         End_Type   := VCDetails.Undetermined_Point;
         VC_State   := VCDetails.VC_Not_Present;
         DPC_State  := VCDetails.DPC_Not_Present;
      end if;
      --# accept F, 33, Dummy, "Dummy not used here";
   end Details;

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

   procedure Initialize
   --# global out Longest_VC_End_Length;
   --#        out Longest_VC_Name_Length;
   --#        out Longest_VC_Start_Length;
   --#        out Start_Of_Pointers_List;
   --#        out The_Details;
   --#        out The_Pointers;
   --#        out VC_Name_Prefix;
   --# derives Longest_VC_End_Length,
   --#         Longest_VC_Name_Length,
   --#         Longest_VC_Start_Length,
   --#         Start_Of_Pointers_List,
   --#         The_Details,
   --#         The_Pointers,
   --#         VC_Name_Prefix          from ;
   is
   begin
      Heap.Initialize (The_Pointers);
      VCDetails.Initialize (The_Details);
      Start_Of_Pointers_List := 0;

      VC_Name_Prefix          := E_Strings.Empty_String;
      Longest_VC_Name_Length  := 0;
      Longest_VC_Start_Length := 0;
      Longest_VC_End_Length   := 0;
   end Initialize;

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

   procedure Raise_Error (Error_Kind : in VCDetails.Error_Type)
   --# global in out The_Details;
   --# derives The_Details from *,
   --#                          Error_Kind;
   is
   begin
      VCDetails.Raise_Error (Error_Kind => Error_Kind,
                             Details    => The_Details);
   end Raise_Error;

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

   function Error_Raised (Error_Kind : in VCDetails.Error_Type) return Boolean
   --# global in The_Details;
   is
   begin
      return VCDetails.Error_Raised (Error_Kind => Error_Kind,
                                     Details    => The_Details);
   end Error_Raised;

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

   procedure Reinitialize
     (First_Element    : in E_Strings.T;
      First_Path_Start : in E_Strings.T;
      First_Path_End   : in E_Strings.T;
      First_End_Type   : in VCDetails.Terminal_Point_Type)
   --# global out Longest_VC_End_Length;
   --#        out Longest_VC_Name_Length;
   --#        out Longest_VC_Start_Length;
   --#        out Start_Of_Pointers_List;
   --#        out The_Details;
   --#        out The_Pointers;
   --#        out VC_Name_Prefix;
   --# derives Longest_VC_End_Length   from First_Path_End &
   --#         Longest_VC_Name_Length,
   --#         VC_Name_Prefix          from First_Element &
   --#         Longest_VC_Start_Length from First_Path_Start &
   --#         Start_Of_Pointers_List,
   --#         The_Pointers            from  &
   --#         The_Details             from First_Element,
   --#                                      First_End_Type,
   --#                                      First_Path_End,
   --#                                      First_Path_Start;
   is
      Dummy                : Boolean;
      First_Details_Index  : HeapIndex.IndexType;
      First_Pointers_Index : Heap.Atom;
   begin -- Reinitialize
      Heap.Initialize (The_Pointers);
      VCDetails.Initialize (The_Details);

      -- insert first item
      --# accept F, 10, Dummy, "Dummy unused here";
      VCDetails.Add
        (The_Details,
         First_Details_Index,
         Dummy,
         First_Element,
         First_Path_Start,
         First_Path_End,
         First_End_Type,
         VCDetails.VC_Not_Present,
         VCDetails.DPC_Not_Present);
      Heap.CreateAtom (The_Pointers, First_Pointers_Index, Dummy);
      --# end accept;

      Heap.UpdateAValue (The_Pointers, First_Pointers_Index, First_Details_Index);
      Heap.UpdateAPointer (The_Pointers, First_Pointers_Index, 0);

      Start_Of_Pointers_List := First_Pointers_Index;

      Longest_VC_Name_Length  := E_Strings.Get_Length (E_Str => First_Element);
      Longest_VC_Start_Length := E_Strings.Get_Length (E_Str => First_Path_Start);
      Longest_VC_End_Length   := E_Strings.Get_Length (E_Str => First_Path_End) + VCDetails.End_Type_Image_Length;

      VC_Name_Prefix := E_Strings.Section (First_Element, 1, E_Strings.Get_Length (E_Str => First_Element) - 2);
      --# accept F, 33, Dummy, "Dummy unused here";
   end Reinitialize;

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

   -- this procedure returns the 'Next_One' ordered element in FH after
   -- 'After_This'. It is successful if the Next_One is not a 'null' pointer
   procedure Next (After_This : in     Heap.Atom;
                   Success    :    out Boolean;
                   Next_One   :    out Heap.Atom)
   --# global in The_Pointers;
   --# derives Next_One,
   --#         Success  from After_This,
   --#                       The_Pointers;
   is
      Next_In_List : Heap.Atom;
   begin -- Next
      Next_In_List := Heap.APointer (The_Pointers, After_This);
      if Next_In_List = 0 then
         Success  := False;
         Next_One := 0;
      else
         Success  := True;
         Next_One := Next_In_List;
      end if;
   end Next;

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

   procedure Find_VC_By_Name (VC_Name  : in     E_Strings.T;
                              VC_Index :    out HeapIndex.IndexType)
   --# global in     Start_Of_Pointers_List;
   --#        in     The_Details;
   --#        in     The_Pointers;
   --#        in out FatalErrors.State;
   --# derives FatalErrors.State from *,
   --#                                Start_Of_Pointers_List,
   --#                                The_Details,
   --#                                The_Pointers,
   --#                                VC_Name &
   --#         VC_Index          from Start_Of_Pointers_List,
   --#                                The_Details,
   --#                                The_Pointers,
   --#                                VC_Name;
   is
      List_Index            : Heap.Atom;
      Found                 : Boolean;
      Loop_Finished         : Boolean;
      Retrieve_Success      : Boolean;
      Current_VC_Name       : E_Strings.T;
      Current_VC_Path_Start : E_Strings.T;
      Current_VC_Path_End   : E_Strings.T;
      Current_VC_End_Type   : VCDetails.Terminal_Point_Type;
      Current_VC_State      : VCDetails.VC_State_T;
      Current_DPC_State     : VCDetails.DPC_State_T;
   begin
      List_Index    := Start_Of_Pointers_List;
      Found         := False;
      Loop_Finished := False;

      while not Heap.IsNullPointer (List_Index) and not Loop_Finished loop
         --# accept F, 10, Current_VC_Path_Start, "Current_VC_Path_Start not used here" &
         --#        F, 10, Current_VC_Path_End, "Current_VC_Path_End not used here" &
         --#        F, 10, Current_VC_End_Type, "Current_VC_End_Type not used here" &
         --#        F, 10, Current_VC_State, "Current_VC_State not used here" &
         --#        F, 10, Current_DPC_State, "Current_DPC_State not used here";
         VCDetails.Retrieve
           (The_Details,
            Heap.AValue (The_Pointers, List_Index),
            Retrieve_Success,
            Current_VC_Name,
            Current_VC_Path_Start,
            Current_VC_Path_End,
            Current_VC_End_Type,
            Current_VC_State,
            Current_DPC_State);
         --# end accept;
         if not Retrieve_Success then
            FatalErrors.Process (FatalErrors.VC_Data_Structure_Inconsistency, E_Strings.Empty_String);
         end if;

         if E_Strings.Eq_String (E_Str1 => VC_Name,
                                 E_Str2 => Current_VC_Name) then
            Found         := True;
            Loop_Finished := True;
         else
            List_Index := Heap.APointer (The_Pointers, List_Index);
         end if;
      end loop;

      if Found then
         VC_Index := Heap.AValue (The_Pointers, List_Index);
      else
         VC_Index := 0;
      end if;
      --# accept F, 33, Current_VC_Path_Start, "Current_VC_Path_Start not used here" &
      --#        F, 33, Current_VC_Path_End, "Current_VC_Path_End not used here" &
      --#        F, 33, Current_VC_End_Type, "Current_VC_End_Type not used here" &
      --#        F, 33, Current_VC_State, "Current_VC_State not used here" &
      --#        F, 33, Current_DPC_State, "Current_DPC_State not used here";
   end Find_VC_By_Name;

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

   procedure Set_VC_State (VC_Name  : in E_Strings.T;
                           VC_State : in VCDetails.VC_State_T)
   --# global in     Start_Of_Pointers_List;
   --#        in     The_Pointers;
   --#        in out FatalErrors.State;
   --#        in out The_Details;
   --# derives FatalErrors.State from *,
   --#                                Start_Of_Pointers_List,
   --#                                The_Details,
   --#                                The_Pointers,
   --#                                VC_Name &
   --#         The_Details       from *,
   --#                                Start_Of_Pointers_List,
   --#                                The_Pointers,
   --#                                VC_Name,
   --#                                VC_State;
   is
      Details_Index : HeapIndex.IndexType;
   begin
      Find_VC_By_Name (VC_Name  => VC_Name,
                       VC_Index => Details_Index);

      if Details_Index /= 0 then
         VCDetails.Set_VC_State (The_Details, Details_Index, VC_State);
      end if;
   end Set_VC_State;

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

   function Get_VC_State (VC_Name : E_Strings.T) return VCDetails.VC_State_T
   --# global in Start_Of_Pointers_List;
   --#        in The_Details;
   --#        in The_Pointers;
   is
      -- Hide this function to hide the (unfortunate and downright
      -- annoying) side-effect that Find_VC_By_Name can have on FatalErrors.State

      --# hide Get_VC_State
      Details_Index : HeapIndex.IndexType;
   begin
      Find_VC_By_Name (VC_Name  => VC_Name,
                       VC_Index => Details_Index);
      return VCDetails.Get_VC_State (The_Details, Details_Index);
   end Get_VC_State;

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

   procedure Set_DPC_State (DPC_Name  : in E_Strings.T;
                            DPC_State : in VCDetails.DPC_State_T)
   --# global in     Start_Of_Pointers_List;
   --#        in     The_Pointers;
   --#        in out FatalErrors.State;
   --#        in out The_Details;
   --# derives FatalErrors.State from *,
   --#                                DPC_Name,
   --#                                Start_Of_Pointers_List,
   --#                                The_Details,
   --#                                The_Pointers &
   --#         The_Details       from *,
   --#                                DPC_Name,
   --#                                DPC_State,
   --#                                Start_Of_Pointers_List,
   --#                                The_Pointers;
   is
      Details_Index : HeapIndex.IndexType;
   begin
      Find_VC_By_Name (VC_Name  => DPC_Name,
                       VC_Index => Details_Index);

      if Details_Index /= 0 then
         VCDetails.Set_DPC_State (The_Details, Details_Index, DPC_State);
      end if;
   end Set_DPC_State;

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

   function Exists (VC_Name : E_Strings.T) return Boolean
   --# global in Start_Of_Pointers_List;
   --#        in The_Details;
   --#        in The_Pointers;
   is
      -- Hide this function to hide the (unfortunate and downright
      -- annoying) side-effect that Find_VC_By_Name can have on FatalErrors.State

      --# hide Exists;
      Details_Index : HeapIndex.IndexType;
   begin
      Find_VC_By_Name (VC_Name  => VC_Name,
                       VC_Index => Details_Index);
      return (Details_Index /= 0);
   end Exists;

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

   procedure Get_VC_Name_End_Type (VC_Name : in     E_Strings.T;
                                   VC_Type :    out VCDetails.Terminal_Point_Type)
   --# global in     Start_Of_Pointers_List;
   --#        in     The_Details;
   --#        in     The_Pointers;
   --#        in out FatalErrors.State;
   --# derives FatalErrors.State from *,
   --#                                Start_Of_Pointers_List,
   --#                                The_Details,
   --#                                The_Pointers,
   --#                                VC_Name &
   --#         VC_Type           from Start_Of_Pointers_List,
   --#                                The_Details,
   --#                                The_Pointers,
   --#                                VC_Name;
   is
      VC_Index : HeapIndex.IndexType;
   begin
      Find_VC_By_Name (VC_Name  => VC_Name,
                       VC_Index => VC_Index);
      VC_Type := VCDetails.End_Point_Type (Details => The_Details,
                                           Index   => VC_Index);
   end Get_VC_Name_End_Type;

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

   function Get_Longest_VC_Name_Length return Integer
   --# global in Longest_VC_Name_Length;
   is
   begin
      return Longest_VC_Name_Length;
   end Get_Longest_VC_Name_Length;

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

   function Get_Longest_VC_Start_Length return Integer
   --# global in Longest_VC_Start_Length;
   is
   begin
      return Longest_VC_Start_Length;
   end Get_Longest_VC_Start_Length;

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

   function Get_Longest_VC_End_Length return Integer
   --# global in Longest_VC_End_Length;
   is
   begin
      return Longest_VC_End_Length;
   end Get_Longest_VC_End_Length;

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

   function Get_VC_Name_Prefix return  E_Strings.T
   --# global in VC_Name_Prefix;
   is
   begin
      return VC_Name_Prefix;
   end Get_VC_Name_Prefix;

end VCHeap;
