------------------------------------------------------------------------------
--                                                                          --
--                           GNATELIM COMPONENTS                            --
--                                                                          --
--                       G N A T E L I M . N O D E S                        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                    Copyright (C) 1998-2005 AdaCore.                      --
--                                                                          --
-- GNATELIM  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 or (at your option) any later --
-- version. GNATELIM is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of  MERCHANTABI- --
-- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public Li- --
-- cense for  more details.  You should  have  received  a copy of the  GNU --
-- General Public License distributed with GNAT; see file COPYING.  If not, --
-- write to  the  Free  Software  Foundation,  59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA.                                              --
--                                                                          --
-- The original version  of  Gnatelim  was developed by  Alain  Le  Guennec --
-- It is now maintained by AdaCore (http://www.adacore.com)                 --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Text_IO;             use Ada.Text_IO;

with Asis;                    use Asis;
with Asis.Compilation_Units;  use Asis.Compilation_Units;
with Asis.Elements;           use Asis.Elements;

with GNAT.HTable;

with Gnatelim.Asis_Utilities; use Gnatelim.Asis_Utilities;
with Gnatelim.Strings;        use Gnatelim.Strings;

package body Gnatelim.Nodes is

   type Node_Range is range 0 .. 2**16 - 1;
   function Hash  (F : Node_Key) return Node_Range;
   function Equal (F1, F2 : Node_Key) return Boolean;

   type Node_Wrapper is record
      N    : Node;
      Next : Natural;
   end record;

   package Node_Table is new GNAT.Table
     (Table_Component_Type => Node_Wrapper,
      Table_Index_Type     => Natural,
      Table_Low_Bound      => 1,
      Table_Initial        => 10_000,
      Table_Increment      => 10_000);

   procedure Set_Next (Pos : Natural; Next : Natural);
   function  Next     (Pos : Natural) return Natural;
   function  Get_Key  (Pos : Natural) return Node_Key;

   package Tab is new GNAT.HTable.Static_HTable
     (Header_Num => Node_Range,
      Element    => Node_Wrapper,
      Elmt_Ptr   => Natural,
      Null_Ptr   => 0,
      Set_Next   => Set_Next,
      Next       => Next,
      Key        => Node_Key,
      Get_Key    => Get_Key,
      Hash       => Hash,
      Equal      => Equal);

   -----------------------
   -- Local subprograms --
   -----------------------

   function Node_Key_Image (NK : Node_Key) return String;
   function SLOC_Image (SLOC : Source_Loc) return String;
   --  Generate the debug image for their arguments to be used in the tables
   --  debug output procedures

   ------------------------
   -- Corresponding_Node --
   ------------------------

   function Corresponding_Node (Element : Asis.Element) return Natural is
      Base      : constant Asis.Element := Corresponding_Element (Element);
      E         : Asis.Element;
      N         : Natural;
      Key       : Node_Key;
      Last_Char : Natural;

   begin
      if Is_Nil (Base) then
         return 0;
      else
         Key.Scope := Corresponding_Node
           (Corresponding_Instance (Enclosing_Element (Base)));

         if Is_Part_Of_Instance (Base) then
            begin
               E := Corresponding_Generic_Element_Unwinded (Base);
            exception
               when others =>
                  return 0;
            end;
         else
            E := Base;
         end if;

         --  Temporarily store the filename

         Last_Char := Chars.Last;
         Key.File := Enter_String
           (Text_Name (Enclosing_Compilation_Unit (E)));
         Key.SLOC := SLOC (E);

         N := Tab.Get (Key);

         Chars.Set_Last (Last_Char);
         --  This will release the temporary storage of a file name

         return N; --  Will return 0 if this node isn't registered
      end if;

   end Corresponding_Node;

   ------------------------
   -- Corresponding_Node --
   ------------------------

   function Corresponding_Node (Element : Asis.Element) return Node is
      N : constant Natural := Corresponding_Node (Element);
   begin
      if N = 0 then
         return Empty_Node;
      else
         return Node_Table.Table (N).N;
      end if;
   end Corresponding_Node;

   ---------------
   -- Enter_TOC --
   ---------------

   function Enter_TOC (TOC : TOC_Node) return Natural is
   begin
      TOC_Table.Increment_Last;
      TOCs (Last_TOC) := TOC;
      return Last_TOC;
   end Enter_TOC;

   -----------
   -- Equal --
   -----------

   function Equal (F1, F2 : Node_Key) return Boolean is
   begin
      --  First come simplest tests, so that we are as fast as possible
      if F1.SLOC /= F2.SLOC or else F1.Scope /= F2.Scope then
         return False;

      elsif F1.File.Last - F1.File.First /= F2.File.Last - F2.File.First then
         return False;

      else
         for J in F1.File.First .. F1.File.Last loop
            if Chars.Table (J) /=
               Chars.Table (F2.File.First + J - F1.File.First)
            then
               return False;
            end if;
         end loop;

         return True;
      end if;
   end Equal;

   -------------
   -- Get_Key --
   -------------

   function Get_Key (Pos : Natural) return Node_Key is
   begin
      return Node_Table.Table (Pos).N.Key;
   end Get_Key;

   ----------
   -- Hash --
   ----------

   function Hash (F : Node_Key) return Node_Range is

      type Uns is mod 2 ** 32;

      function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
      pragma Import (Intrinsic, Rotate_Left);

      function Shift_Left (Value : Uns; Amount : Natural) return Uns;
      pragma Import (Intrinsic, Shift_Left);

      Tmp : Uns := Shift_Left (Uns (F.SLOC.Line), 16) xor Uns (F.SLOC.Col);
      --  First use the source coordinates for hash value

   begin
      pragma Assert (F /= Empty_Key);

      --  Now add the node file name in the mix
      for J in F.File.First .. F.File.Last loop
         Tmp := Rotate_Left (Tmp, 3) + Wide_Character'Pos (Chars.Table (J));
      end loop;

      --  And finally some extra permutation from Scope
      Tmp := Rotate_Left (Tmp, F.Scope mod 7);

      --  Trim the result
      Tmp := Tmp mod Uns (Node_Range'Last);

      return Node_Range (Tmp);
   end Hash;

   -------------
   -- Iterate --
   -------------

   procedure Iterate is
      use Node_Table;
   begin
      for Pos in 1 .. Last loop
         if not Action (Table (Pos). N) then
            return;
         end if;
      end loop;
   end Iterate;

   ----------
   -- Next --
   ----------

   function Next (Pos : Natural) return Natural is
   begin
      return Node_Table.Table (Pos).Next;
   end Next;

   --------------------
   -- Node_Key_Image --
   --------------------

   function Node_Key_Image (NK : Node_Key) return String is
   begin
      if NK = Empty_Key then
         return "EMPTY KEY!!!";
      else
         return
           To_String (Get_String (NK.File)) &
           "(" & NK.File.First'Img & NK.File.Last'Img & ")" &
           ":"
         & SLOC_Image (NK.SLOC) & "("
         & NK.Scope'Img & ")";
      end if;

   end Node_Key_Image;

   ---------------
   -- Node_Kind --
   ---------------

   function Node_Kind (E : Asis.Element) return Node_Kinds is
      Element : Asis.Element;
   begin
      if Is_Nil (E) then
         return Empty;
      end if;

      if Element_Kind (E) = A_Defining_Name then
         Element := Enclosing_Element (E);
      else
         Element := E;
      end if;

      case Declaration_Kind (Element) is
         when A_Procedure_Declaration
           |  A_Function_Declaration
           |  A_Procedure_Body_Declaration
           |  A_Function_Body_Declaration
           |  A_Procedure_Body_Stub
           |  A_Function_Body_Stub
           |  A_Procedure_Renaming_Declaration
           |  A_Function_Renaming_Declaration =>
            return A_Subprogram;

         when A_Procedure_Instantiation
           |  A_Function_Instantiation =>
            return A_Subprogram_Instance;

         when A_Package_Declaration
           |  A_Package_Body_Declaration
           |  A_Package_Renaming_Declaration =>
            return A_Package;

         when A_Package_Instantiation =>
            return A_Package_Instance;

         when A_Task_Type_Declaration
           |  A_Protected_Type_Declaration
           |  A_Single_Task_Declaration
           |  A_Single_Protected_Declaration
           |  A_Task_Body_Declaration
           |  A_Protected_Body_Declaration =>
            return A_Task;

         when others =>
            return Other;
      end case;

   end Node_Kind;

   ----------------------
   -- Print_Node_Table --
   ----------------------

   procedure Print_Node_Table is
      NT : Node_Table.Table_Ptr renames Node_Table.Table;
   begin

      Set_Output (Standard_Error);

      for J in 1 .. Node_Table.Last loop
         Put ("Node=" & J'Img & " (" & NT (J).N.Kind'Img &  ")");
         Put ("Next =>" &  NT (J).Next'Img);
         New_Line;

         Put ("   Parent_Link =>" & Node_Key_Image (NT (J).N.Parent_Link));
         New_Line;

         Put ("   TOC_Head =>" &  NT (J).N.TOC_Head'Img);
         New_Line;

         Put ("   Name => " & To_String (Get_String (NT (J).N.Name)));
         New_Line;

         Put ("   Flags => (FLAG_USED            => " &
                            NT (J).N.Flags (FLAG_USED)'Img);
         New_Line;
         Put ("             FLAG_ANALYZED        => " &
                            NT (J).N.Flags (FLAG_ANALYZED)'Img);
         New_Line;
         Put ("             FLAG_NEVER_ELIMINATE => " &
                            NT (J).N.Flags (FLAG_NEVER_ELIMINATE)'Img & ")");
         New_Line;

         Put ("   Key => " & Node_Key_Image (NT (J).N.Key));
         New_Line;

      end loop;

      Set_Output (Standard_Output);

   end Print_Node_Table;

   ---------------------
   -- Print_TOC_Table --
   ---------------------

   procedure Print_TOC_Table is
      TOCT : TOC_Table.Table_Ptr renames TOC_Table.Table;
   begin

      Set_Output (Standard_Error);

      for J in 1 .. TOC_Table.Last loop
         Put ("TOC_Id=" & J'Img);
         New_Line;
         Put ("   " & "Node =>" & Node_Key_Image (TOCT (J).Node));
         New_Line;
         Put ("   " & "Next =>" & TOCT (J).Next'Img);
         New_Line;
      end loop;

      Set_Output (Standard_Output);

   end Print_TOC_Table;

   -------------------
   -- Register_Node --
   -------------------

   procedure Register_Node (N : Node; Create : Boolean := False) is
      use Node_Table;
      Pos : constant Natural := Tab.Get (N.Key);
   begin
      pragma Assert (N /= Empty_Node);
      pragma Unreferenced (Create);
      --  pragma Assert ((Pos = 0) = Create);

      if Pos = 0 then
         --  New element should be created
         Increment_Last;
         Table (Last) := Node_Wrapper'(N, 0);
         Tab.Set (Last);
      else
         Table (Pos).N := N;
      end if;
   end Register_Node;

   -------------------
   -- Retrieve_Node --
   -------------------

   function Retrieve_Node (Key : Node_Key) return Node is
      Pos : Natural;
   begin
      if Key = Empty_Key then
         return Empty_Node;
      else

         Pos := Tab.Get (Key);

         if Pos = 0 then
            return Empty_Node;
         else
            return Node_Table.Table (Pos).N;
         end if;

      end if;
   end Retrieve_Node;

   --------------
   -- Set_Next --
   --------------

   procedure Set_Next (Pos : Natural; Next : Natural) is
   begin
      Node_Table.Table (Pos).Next := Next;
   end Set_Next;

   ----------------
   -- SLOC_Image --
   ----------------

   function SLOC_Image (SLOC : Source_Loc) return String is
   begin
      return SLOC.Line'Img & SLOC.Col'Img;
   end SLOC_Image;

   ------------------------
   -- Transitive_Closure --
   ------------------------

   procedure Transitive_Closure is

      function Process_Node (N : Node) return Boolean;
      --  Actual for generic procedure Iterate

      procedure Transitive_Closure (N : Node);
      --  Performs the closure of a given node

      ------------------
      -- Process_Node --
      ------------------

      function Process_Node (N : Node) return Boolean is
      begin

         if not N.Flags (FLAG_ANALYZED) and then N.Flags (FLAG_USED) then
            Transitive_Closure (N);
         end if;

         return True;

      end Process_Node;

      ------------------------
      -- Transitive_Closure --
      ------------------------

      procedure Transitive_Closure (N : Node) is
         NN  : Node := N;
         Pos : Natural;
      begin
         if N = Empty_Node then
            return;
         end if;

         if not N.Flags (FLAG_ANALYZED) then
            NN.Flags (FLAG_ANALYZED) := True;
            NN.Flags (FLAG_USED)     := True;

            Register_Node (NN);

            Pos := N.TOC_Head;

            while Pos /= 0 loop
               Transitive_Closure (Retrieve_Node (TOCs (Pos).Node));
               Pos := TOCs (Pos).Next;
            end loop;

         end if;

      end Transitive_Closure;

      procedure Closure is new Iterate (Process_Node);

   begin

      Closure;

   end Transitive_Closure;

begin
   Tab.Reset;
end Gnatelim.Nodes;
