--  Extended locations for iir nodes
--  Copyright (C) 2017-2021 Tristan Gingold
--
--  This program 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, see <gnu.org/licenses>.

with Tables;
with Vhdl.Nodes_Priv;
with Vhdl.Elocations_Meta; use Vhdl.Elocations_Meta;

package body Vhdl.Elocations is

   --  Format of a node.
   type Format_Type is
     (
      Format_None,
      Format_L1,
      Format_L2,
      Format_L3,
      Format_L4,
      Format_L5,
      Format_L6
     );

   -- Common fields are:

   -- Fields of Format_None:

   -- Fields of Format_L1:
   --   Field1 : Location_Type

   -- Fields of Format_L2:
   --   Field1 : Location_Type
   --   Field2 : Location_Type

   -- Fields of Format_L3:
   --   Field1 : Location_Type
   --   Field2 : Location_Type
   --   Field3 : Location_Type

   -- Fields of Format_L4:
   --   Field1 : Location_Type
   --   Field2 : Location_Type
   --   Field3 : Location_Type
   --   Field4 : Location_Type

   -- Fields of Format_L5:
   --   Field1 : Location_Type
   --   Field2 : Location_Type
   --   Field3 : Location_Type
   --   Field4 : Location_Type
   --   Field5 : Location_Type

   -- Fields of Format_L6:
   --   Field1 : Location_Type
   --   Field2 : Location_Type
   --   Field3 : Location_Type
   --   Field4 : Location_Type
   --   Field5 : Location_Type
   --   Field6 : Location_Type

   function Get_Format (Kind : Iir_Kind) return Format_Type;

   type Location_Index_Type is new Types.Nat32;
   No_Location_Index : constant Location_Index_Type := 0;

   package Elocations_Index_Table is new Tables
     (Table_Component_Type => Location_Index_Type,
      Table_Index_Type => Iir,
      Table_Low_Bound => 2,
      Table_Initial => 1024);

   package Elocations_Table is new Tables
     (Table_Component_Type => Location_Type,
      Table_Index_Type => Location_Index_Type,
      Table_Low_Bound => 2,
      Table_Initial => 1024);

   procedure Create_Elocations (N : Iir)
   is
      use Vhdl.Nodes_Priv;
      Format : constant Format_Type := Get_Format (Get_Kind (N));
      El : constant Iir := Elocations_Index_Table.Last;
      Len : Location_Index_Type;
      Idx : Location_Index_Type;
   begin
      pragma Assert (Format /= Format_None);

      if El < N then
         Elocations_Index_Table.Set_Last (N);
         Elocations_Index_Table.Table (El + 1 .. N) :=
           (others => No_Location_Index);
      end if;

      --  Must be called once.
      pragma Assert (Elocations_Index_Table.Table (N) = No_Location_Index);

      case Format is
         when Format_None =>
            raise Program_Error;
         when Format_L1 =>
            Len := 1;
         when Format_L2 =>
            Len := 2;
         when Format_L3 =>
            Len := 3;
         when Format_L4 =>
            Len := 4;
         when Format_L5 =>
            Len := 5;
         when Format_L6 =>
            Len := 6;
      end case;

      Idx := Elocations_Table.Last + 1;
      Elocations_Index_Table.Table (N) := Idx;
      Elocations_Table.Set_Last (Idx + Len - 1);
      Elocations_Table.Table (Idx .. Idx + Len - 1) := (others => No_Location);
   end Create_Elocations;

   procedure Delete_Elocations (N : Iir)
   is
      use Vhdl.Nodes_Priv;
      Old : Location_Index_Type;
   begin
      --  Cannot delete an already deleted location.
      if N > Elocations_Index_Table.Last then
         return;
      end if;
      Old := Elocations_Index_Table.Table (N);
      if Old = No_Location_Index then
         return;
      end if;

      --  Clear the corresponding index.
      Elocations_Index_Table.Table (N) := No_Location_Index;

      --  FIXME: keep free slots in chained list ?
   end Delete_Elocations;

   procedure Free_Hook (N : Iir) is
   begin
      Delete_Elocations (N);
   end Free_Hook;

   generic
      Off : Location_Index_Type;
   function Get_FieldX (N : Iir) return Location_Type;

   generic
      Off : Location_Index_Type;
   procedure Set_FieldX (N : Iir; Loc : Location_Type);

   function Get_FieldX (N : Iir) return Location_Type
   is
      use Vhdl.Nodes_Priv;
      Idx : Location_Index_Type;
   begin
      pragma Assert (N <= Elocations_Index_Table.Last);
      Idx := Elocations_Index_Table.Table (N);
      return Elocations_Table.Table (Idx + Off - 1);
   end Get_FieldX;

   procedure Set_FieldX (N : Iir; Loc : Location_Type)
   is
      use Vhdl.Nodes_Priv;
      Idx : Location_Index_Type;
   begin
      pragma Assert (N <= Elocations_Index_Table.Last);
      Idx := Elocations_Index_Table.Table (N);
      Elocations_Table.Table (Idx + Off - 1) := Loc;
   end Set_FieldX;

   function Get_Field1 is new Get_FieldX (1);
   procedure Set_Field1 is new Set_FieldX (1);

   function Get_Field2 is new Get_FieldX (2);
   procedure Set_Field2 is new Set_FieldX (2);

   function Get_Field3 is new Get_FieldX (3);
   procedure Set_Field3 is new Set_FieldX (3);

   function Get_Field4 is new Get_FieldX (4);
   procedure Set_Field4 is new Set_FieldX (4);

   function Get_Field5 is new Get_FieldX (5);
   procedure Set_Field5 is new Set_FieldX (5);

   function Get_Field6 is new Get_FieldX (6);
   procedure Set_Field6 is new Set_FieldX (6);

   --  Subprograms

begin
   Vhdl.Nodes.Register_Free_Hook (Free_Hook'Access);
end Vhdl.Elocations;