------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              M E M R O O T                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 1997-2005, AdaCore                     --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT 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 GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with GNAT.Table;
with GNAT.HTable; use GNAT.HTable;
with Ada.Text_IO; use Ada.Text_IO;

package body Memroot is

   Main_Name_Id : Name_Id;
   --  The constant "main" where we should stop the backtraces

   -------------
   -- Name_Id --
   -------------

   package Chars is new GNAT.Table (
     Table_Component_Type => Character,
     Table_Index_Type     => Integer,
     Table_Low_Bound      => 1,
     Table_Initial        => 10_000,
     Table_Increment      => 100);
   --  The actual character container for names

   type Name is  record
      First, Last : Integer;
   end record;

   package Names is new GNAT.Table (
     Table_Component_Type => Name,
     Table_Index_Type     => Name_Id,
     Table_Low_Bound      => 0,
     Table_Initial        => 400,
     Table_Increment      => 100);

   type Name_Range is range 1 .. 1023;

   function Name_Eq (N1, N2 : Name) return Boolean;
   --  compare 2 names

   function H (N : Name) return Name_Range;

   package Name_HTable is new GNAT.HTable.Simple_HTable (
     Header_Num => Name_Range,
     Element    => Name_Id,
     No_Element => No_Name_Id,
     Key        => Name,
     Hash       => H,
     Equal      => Name_Eq);

   --------------
   -- Frame_Id --
   --------------

   type Frame is record
      Name, File, Line : Name_Id;
   end record;

   function Image
     (F       : Frame_Id;
      Max_Fil : Integer;
      Max_Lin : Integer;
      Short   : Boolean := False) return String;
   --  Returns an image for F containing the file name, the Line number,
   --  and if 'Short' is not true, the subprogram name. When possible, spaces
   --  are inserted between the line number and the subprogram name in order
   --  to align images of the same frame. Alignement is cimputed with Max_Fil
   --  & Max_Lin representing the max number of character in a filename or
   --  length in a given frame.

   package Frames is new GNAT.Table (
     Table_Component_Type => Frame,
     Table_Index_Type     => Frame_Id,
     Table_Low_Bound      => 1,
     Table_Initial        => 400,
     Table_Increment      => 100);

   type Frame_Range is range 1 .. 10000;
   function H (N : Integer_Address) return Frame_Range;

   package Frame_HTable is new GNAT.HTable.Simple_HTable (
     Header_Num => Frame_Range,
     Element    => Frame_Id,
     No_Element => No_Frame_Id,
     Key        => Integer_Address,
     Hash       => H,
     Equal      => "=");

   -------------
   -- Root_Id --
   -------------

   type Root is  record
     First, Last     : Integer;
     Nb_Alloc        : Integer;
     Alloc_Size      : Storage_Count;
     High_Water_Mark : Storage_Count;
   end record;

   package Frames_In_Root is new GNAT.Table (
     Table_Component_Type => Frame_Id,
     Table_Index_Type     => Integer,
     Table_Low_Bound      => 1,
     Table_Initial        => 400,
     Table_Increment      => 100);

   package Roots is new GNAT.Table (
     Table_Component_Type => Root,
     Table_Index_Type     => Root_Id,
     Table_Low_Bound      => 1,
     Table_Initial        => 200,
     Table_Increment      => 100);
   type Root_Range is range 1 .. 513;

   function Root_Eq (N1, N2 : Root) return Boolean;
   function H     (B : Root)     return Root_Range;

   package Root_HTable is new GNAT.HTable.Simple_HTable (
     Header_Num => Root_Range,
     Element    => Root_Id,
     No_Element => No_Root_Id,
     Key        => Root,
     Hash       => H,
     Equal      => Root_Eq);

   ----------------
   -- Alloc_Size --
   ----------------

   function Alloc_Size (B : Root_Id) return Storage_Count is
   begin
      return Roots.Table (B).Alloc_Size;
   end Alloc_Size;

   -----------------
   -- Enter_Frame --
   -----------------

   function Enter_Frame
     (Addr : System.Address;
      Name : Name_Id;
      File : Name_Id;
      Line : Name_Id)
      return Frame_Id
   is
   begin
      Frames.Increment_Last;
      Frames.Table (Frames.Last) := Frame'(Name, File, Line);

      Frame_HTable.Set (To_Integer (Addr), Frames.Last);
      return Frames.Last;
   end Enter_Frame;

   ----------------
   -- Enter_Name --
   ----------------

   function Enter_Name (S : String) return Name_Id is
      Old_L : constant Integer := Chars.Last;
      Len   : constant Integer := S'Length;
      F     : constant Integer := Chars.Allocate (Len);
      Res   : Name_Id;

   begin
      Chars.Table (F .. F + Len - 1) := Chars.Table_Type (S);
      Names.Increment_Last;
      Names.Table (Names.Last) := Name'(F, F + Len - 1);
      Res := Name_HTable.Get (Names.Table (Names.Last));

      if Res /= No_Name_Id then
         Names.Decrement_Last;
         Chars.Set_Last (Old_L);
         return Res;

      else
         Name_HTable.Set (Names.Table (Names.Last), Names.Last);
         return Names.Last;
      end if;
   end Enter_Name;

   ----------------
   -- Enter_Root --
   ----------------

   function Enter_Root (Fr : Frame_Array) return Root_Id is
      Old_L : constant Integer  := Frames_In_Root.Last;
      Len   : constant Integer  := Fr'Length;
      F     : constant Integer  := Frames_In_Root.Allocate (Len);
      Res   : Root_Id;

   begin
      Frames_In_Root.Table (F .. F + Len - 1) :=
        Frames_In_Root.Table_Type (Fr);
      Roots.Increment_Last;
      Roots.Table (Roots.Last) := Root'(F, F + Len - 1, 0, 0, 0);
      Res := Root_HTable.Get (Roots.Table (Roots.Last));

      if Res /= No_Root_Id then
         Frames_In_Root.Set_Last (Old_L);
         Roots.Decrement_Last;
         return Res;

      else
         Root_HTable.Set (Roots.Table (Roots.Last), Roots.Last);
         return Roots.Last;
      end if;
   end Enter_Root;

   ---------------
   -- Frames_Of --
   ---------------

   function Frames_Of (B : Root_Id) return Frame_Array is
   begin
      return Frame_Array (
        Frames_In_Root.Table (Roots.Table (B).First .. Roots.Table (B).Last));
   end Frames_Of;

   ---------------
   -- Get_First --
   ---------------

   function Get_First return Root_Id is
   begin
      return  Root_HTable.Get_First;
   end Get_First;

   --------------
   -- Get_Next --
   --------------

   function Get_Next return Root_Id is
   begin
      return Root_HTable.Get_Next;
   end Get_Next;

   -------
   -- H --
   -------

   function H (B : Root) return Root_Range is

      type Uns is mod 2 ** 32;

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

      Tmp : Uns := 0;

   begin
      for J in B.First .. B.Last loop
         Tmp := Rotate_Left (Tmp, 1) + Uns (Frames_In_Root.Table (J));
      end loop;

      return Root_Range'First
        + Root_Range'Base (Tmp mod Root_Range'Range_Length);
   end H;

   function H (N : Name) return Name_Range is
      function H is new Hash (Name_Range);

   begin
      return H (String (Chars.Table (N.First .. N.Last)));
   end H;

   function H (N : Integer_Address) return Frame_Range is
   begin
      return Frame_Range (1 + N mod Frame_Range'Range_Length);
   end H;

   ---------------------
   -- High_Water_Mark --
   ---------------------

   function High_Water_Mark (B : Root_Id) return Storage_Count is
   begin
      return Roots.Table (B).High_Water_Mark;
   end High_Water_Mark;

   -----------
   -- Image --
   -----------

   function Image (N : Name_Id) return String is
      Nam : Name renames Names.Table (N);

   begin
      return String (Chars.Table (Nam.First .. Nam.Last));
   end Image;

   function Image
     (F       : Frame_Id;
      Max_Fil : Integer;
      Max_Lin : Integer;
      Short   : Boolean := False) return String
   is
      Fram : Frame renames Frames.Table (F);
      Fil  : Name renames Names.Table (Fram.File);
      Lin  : Name renames Names.Table (Fram.Line);
      Nam  : Name renames Names.Table (Fram.Name);

      Fil_Len  : constant Integer := Fil.Last - Fil.First + 1;
      Lin_Len  : constant Integer := Lin.Last - Lin.First + 1;

      use type Chars.Table_Type;

      Spaces : constant String (1 .. 80) := (1 .. 80 => ' ');

      Result : constant String :=
        String (Chars.Table (Fil.First .. Fil.Last))
        & ':'
        & String (Chars.Table (Lin.First .. Lin.Last));
   begin
      if Short then
         return Result;
      else
         return Result
           & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len)
           & String (Chars.Table (Nam.First .. Nam.Last));
      end if;
   end Image;

   -------------
   -- Name_Eq --
   -------------

   function Name_Eq (N1, N2 : Name) return Boolean is
      use type Chars.Table_Type;
   begin
      return
        Chars.Table (N1.First .. N1.Last) = Chars.Table (N2.First .. N2.Last);
   end Name_Eq;

   --------------
   -- Nb_Alloc --
   --------------

   function Nb_Alloc (B : Root_Id) return Integer is
   begin
      return Roots.Table (B).Nb_Alloc;
   end Nb_Alloc;

   --------------
   -- Print_BT --
   --------------

   procedure Print_BT (B  : Root_Id; Short : Boolean := False) is
      Max_Col_Width : constant := 35;
      --  Largest filename length for which backtraces will be
      --  properly aligned. Frames containing longer names won't be
      --  truncated but they won't be properly aligned either.

      F : constant Frame_Array := Frames_Of (B);

      Max_Fil : Integer;
      Max_Lin : Integer;

   begin
      Max_Fil := 0;
      Max_Lin := 0;

      for J in F'Range loop
         declare
            Fram : Frame renames Frames.Table (F (J));
            Fil  : Name renames Names.Table (Fram.File);
            Lin  : Name renames Names.Table (Fram.Line);

         begin
            Max_Fil := Integer'Max (Max_Fil, Fil.Last - Fil.First + 1);
            Max_Lin := Integer'Max (Max_Lin, Lin.Last - Lin.First + 1);
         end;
      end loop;

      Max_Fil := Integer'Min (Max_Fil, Max_Col_Width);

      for J in F'Range loop
         Put ("   ");
         Put_Line (Image (F (J), Max_Fil, Max_Lin, Short));
      end loop;
   end Print_BT;

   -------------
   -- Read_BT --
   -------------

   function Read_BT (BT_Depth : Integer) return Root_Id is
      Max_Line : constant Integer := 500;
      Curs1    : Integer;
      Curs2    : Integer;
      Line     : String (1 .. Max_Line);
      Last     : Integer := 0;
      Frames   : Frame_Array (1 .. BT_Depth);
      F        : Integer := Frames'First;
      Nam      : Name_Id;
      Fil      : Name_Id;
      Lin      : Name_Id;
      Add      : System.Address;
      Int_Add  : Integer_Address;
      Fr       : Frame_Id;
      Main_Found : Boolean := False;
      pragma Warnings (Off, Line);

      procedure Find_File;
      pragma Inline (Find_File);
      --  Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
      --  the file name. The file name may not be on the current line since
      --  a frame may be printed on more than one line when there is a lot
      --  of parameters or names are long, so this subprogram can read new
      --  lines of input.

      procedure Find_Line;
      pragma Inline (Find_Line);
      --  Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
      --  the line number.

      procedure Find_Name;
      pragma Inline (Find_Name);
      --  Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
      --  the subprogram name.

      function Skip_To_Space (Pos : Integer) return Integer;
      pragma Inline (Skip_To_Space);
      --  Scans Line starting with position Pos, returning the position
      --  immediately before the first space, or the value of Last if no
      --  spaces were found

      ---------------
      -- Find_File --
      ---------------

      procedure Find_File is
      begin
         --  Skip " at "

         Curs1 := Curs2 + 5;
         Curs2 := Last;

         --  Scan backwards from end of line until ':' is encountered

         for J in reverse Curs1 .. Last loop
            if Line (J) = ':' then
               Curs2 := J - 1;
            end if;
         end loop;
      end Find_File;

      ---------------
      -- Find_Line --
      ---------------

      procedure Find_Line is
      begin
         Curs1 := Curs2 + 2;
         Curs2 := Last;

         --  Check for Curs1 too large. Should never happen with non-corrupt
         --  output. If it does happen, just reset it to the highest value.

         if Curs1 > Last then
            Curs1 := Last;
         end if;
      end Find_Line;

      ---------------
      -- Find_Name --
      ---------------

      procedure Find_Name is
      begin
         --  Skip the address value and " in "

         Curs1 := Skip_To_Space (1) + 5;
         Curs2 := Skip_To_Space (Curs1);
      end Find_Name;

      -------------------
      -- Skip_To_Space --
      -------------------

      function Skip_To_Space (Pos : Integer) return Integer is
      begin
         for Cur in Pos .. Last loop
            if Line (Cur) = ' ' then
               return Cur - 1;
            end if;
         end loop;

         return Last;
      end Skip_To_Space;

      procedure Gmem_Read_Next_Frame (Addr : out System.Address);
      pragma Import (C, Gmem_Read_Next_Frame, "__gnat_gmem_read_next_frame");
      --  Read the next frame in the current traceback. Addr is set to 0 if
      --  there are no more addresses in this traceback. The pointer is moved
      --  to the next frame.

      procedure Gmem_Symbolic
        (Addr : System.Address; Buf : String; Last : out Natural);
      pragma Import (C, Gmem_Symbolic, "__gnat_gmem_symbolic");
      --  Get the symbolic traceback for Addr. Note: we cannot use
      --  GNAT.Tracebacks.Symbolic, since the latter will only work with the
      --  current executable.
      --
      --  "__gnat_gmem_symbolic" will work with the executable whose name is
      --  given in gnat_argv[0], as initialized by Gnatmem.Gmem_A21_Initialize.

   --  Start of processing for Read_BT

   begin
      while F <= BT_Depth and then not Main_Found loop
         Gmem_Read_Next_Frame (Add);
         Int_Add := To_Integer (Add);
         exit when Int_Add = 0;

         Fr := Frame_HTable.Get (Int_Add);

         if Fr = No_Frame_Id then
            Gmem_Symbolic (Add, Line, Last);
            Last := Last - 1; -- get rid of the trailing line-feed
            Find_Name;

            --  Skip the __gnat_malloc frame itself

            if Line (Curs1 .. Curs2) /= "<__gnat_malloc>" then
               Nam := Enter_Name (Line (Curs1 .. Curs2));
               Main_Found := (Nam = Main_Name_Id);

               Find_File;
               Fil := Enter_Name (Line (Curs1 .. Curs2));
               Find_Line;
               Lin := Enter_Name (Line (Curs1 .. Curs2));

               Frames (F) := Enter_Frame (Add, Nam, Fil, Lin);
               F := F + 1;
            end if;

         else
            Frames (F) := Fr;
            Main_Found := (Memroot.Frames.Table (Fr).Name = Main_Name_Id);
            F := F + 1;
         end if;
      end loop;

      return Enter_Root (Frames (1 .. F - 1));
   end Read_BT;

   -------------
   -- Root_Eq --
   -------------

   function Root_Eq (N1, N2 : Root) return Boolean is
      use type Frames_In_Root.Table_Type;

   begin
      return
        Frames_In_Root.Table (N1.First .. N1.Last)
          = Frames_In_Root.Table (N2.First .. N2.Last);
   end Root_Eq;

   --------------------
   -- Set_Alloc_Size --
   --------------------

   procedure Set_Alloc_Size (B : Root_Id; V : Storage_Count) is
   begin
      Roots.Table (B).Alloc_Size := V;
   end Set_Alloc_Size;

   -------------------------
   -- Set_High_Water_Mark --
   -------------------------

   procedure Set_High_Water_Mark (B : Root_Id; V : Storage_Count) is
   begin
      Roots.Table (B).High_Water_Mark := V;
   end Set_High_Water_Mark;

   ------------------
   -- Set_Nb_Alloc --
   ------------------

   procedure Set_Nb_Alloc (B : Root_Id; V : Integer) is
   begin
      Roots.Table (B).Nb_Alloc := V;
   end Set_Nb_Alloc;

begin
   --  Initialize name for No_Name_ID

   Names.Increment_Last;
   Names.Table (Names.Last) := Name'(1, 0);
   Main_Name_Id := Enter_Name ("main");
end Memroot;