diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/memroot.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/memroot.adb | 616 |
1 files changed, 0 insertions, 616 deletions
diff --git a/gcc-4.2.1/gcc/ada/memroot.adb b/gcc-4.2.1/gcc/ada/memroot.adb deleted file mode 100644 index cdd4feb00..000000000 --- a/gcc-4.2.1/gcc/ada/memroot.adb +++ /dev/null @@ -1,616 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |