X-Git-Url: https://oss.titaniummirror.com/gitweb?a=blobdiff_plain;f=gcc%2Fada%2Fmemroot.adb;fp=gcc%2Fada%2Fmemroot.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=7e497b2307afb021a18503298b8398c63543b4a5;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/memroot.adb b/gcc/ada/memroot.adb deleted file mode 100644 index 7e497b23..00000000 --- a/gcc/ada/memroot.adb +++ /dev/null @@ -1,663 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M E M R O O T -- --- -- --- B o d y -- --- -- --- $Revision: 1.1 $ --- -- --- Copyright (C) 1997-2001 Ada Core Technologies, Inc. -- --- -- --- 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, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - -with GNAT.Table; -with GNAT.HTable; use GNAT.HTable; -with Ada.Text_IO; use Ada.Text_IO; - -package body Memroot is - - ------------- - -- 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) - return String; - -- Returns an image for F containing the file name, the Line number, - -- and 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 .. 513; - function H (N : Frame) 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 => Frame, - 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 (Name, File, Line : Name_Id) return Frame_Id is - Res : Frame_Id; - - begin - Frames.Increment_Last; - Frames.Table (Frames.Last) := Frame'(Name, File, Line); - Res := Frame_HTable.Get (Frames.Table (Frames.Last)); - - if Res /= No_Frame_Id then - Frames.Decrement_Last; - return Res; - - else - Frame_HTable.Set (Frames.Table (Frames.Last), Frames.Last); - return Frames.Last; - end if; - 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 : Frame) return Frame_Range is - begin - return Frame_Range (1 + (7 * N.Name + 13 * N.File + 17 * N.Line) - 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) - 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 => ' '); - - begin - return String (Chars.Table (Fil.First .. Fil.Last)) - & ':' - & String (Chars.Table (Lin.First .. Lin.Last)) - & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len) - & String (Chars.Table (Nam.First .. Nam.Last)); - 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) 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)); - end loop; - end Print_BT; - - ------------- - -- Read_BT -- - ------------- - - function Read_BT (BT_Depth : Integer; FT : File_Type) 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; - - No_File : Boolean := False; - Main_Found : Boolean := False; - - procedure 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; - -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains - -- the line number. - - procedure Find_Name; - -- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains - -- the subprogram name. - - procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural); - -- GMEM functionality binding - - --------------- - -- Find_File -- - --------------- - - procedure Find_File is - Match_Parent : Integer; - - begin - -- Skip parameters - - Curs1 := Curs2 + 3; - Match_Parent := 1; - while Curs1 <= Last loop - if Line (Curs1) = '(' then - Match_Parent := Match_Parent + 1; - elsif Line (Curs1) = ')' then - Match_Parent := Match_Parent - 1; - exit when Match_Parent = 0; - end if; - - Curs1 := Curs1 + 1; - end loop; - - -- Skip " at " - - Curs1 := Curs1 + 5; - - if Curs1 >= Last then - - -- Maybe the file reference is on one of the next lines - - Read : loop - Get_Line (FT, Line, Last); - - -- If we have another Frame or if the backtrace is finished - -- the file reference was just missing - - if Last <= 1 or else Line (1) = '#' then - No_File := True; - Curs2 := Curs1 - 1; - return; - - else - Curs1 := 1; - while Curs1 <= Last - 2 loop - if Line (Curs1) = '(' then - Match_Parent := Match_Parent + 1; - elsif Line (Curs1) = ')' then - Match_Parent := Match_Parent - 1; - end if; - - if Match_Parent = 0 - and then Line (Curs1 .. Curs1 + 1) = "at" - then - Curs1 := Curs1 + 3; - exit Read; - end if; - - Curs1 := Curs1 + 1; - end loop; - end if; - end loop Read; - end if; - - -- Let's assume that the filename length is greater than 1 - -- it simplifies dealing with the potential drive ':' on - -- windows systems - - Curs2 := Curs1 + 1; - while Line (Curs2 + 1) /= ':' loop Curs2 := Curs2 + 1; end loop; - end Find_File; - - --------------- - -- Find_Line -- - --------------- - - procedure Find_Line is - begin - Curs1 := Curs2 + 2; - Curs2 := Last; - if Curs2 - Curs1 > 5 then - raise Constraint_Error; - end if; - end Find_Line; - - --------------- - -- Find_Name -- - --------------- - - procedure Find_Name is - begin - Curs1 := 3; - - -- Skip Frame # - - while Line (Curs1) /= ' ' loop Curs1 := Curs1 + 1; end loop; - - -- Skip spaces - - while Line (Curs1) = ' ' loop Curs1 := Curs1 + 1; end loop; - - Curs2 := Curs1; - while Line (Curs2 + 1) /= ' ' loop Curs2 := Curs2 + 1; end loop; - end Find_Name; - - ------------------------ - -- Gmem_Read_BT_Frame -- - ------------------------ - - procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural) is - procedure Read_BT_Frame (buf : System.Address); - pragma Import (C, Read_BT_Frame, "__gnat_gmem_read_bt_frame"); - - function Strlen (chars : System.Address) return Natural; - pragma Import (C, Strlen, "strlen"); - - S : String (1 .. 1000); - begin - Read_BT_Frame (S'Address); - Last := Strlen (S'Address); - Buf (1 .. Last) := S (1 .. Last); - end Gmem_Read_BT_Frame; - - -- Start of processing for Read_BT - - begin - - if Gmem_Mode then - Gmem_Read_BT_Frame (Line, Last); - else - Line (1) := ' '; - while Line (1) /= '#' loop - Get_Line (FT, Line, Last); - end loop; - end if; - - while Last >= 1 and then Line (1) = '#' and then not Main_Found loop - if F <= BT_Depth then - Find_Name; - Nam := Enter_Name (Line (Curs1 .. Curs2)); - Main_Found := Line (Curs1 .. Curs2) = "main"; - - Find_File; - - if No_File then - Fil := No_Name_Id; - Lin := No_Name_Id; - else - Fil := Enter_Name (Line (Curs1 .. Curs2)); - - Find_Line; - Lin := Enter_Name (Line (Curs1 .. Curs2)); - end if; - - Frames (F) := Enter_Frame (Nam, Fil, Lin); - F := F + 1; - end if; - - if No_File then - - -- If no file reference was found, the next line has already - -- been read because, it may sometimes be found on the next - -- line - - No_File := False; - - else - if Gmem_Mode then - Gmem_Read_BT_Frame (Line, Last); - else - Get_Line (FT, Line, Last); - exit when End_Of_File (FT); - end if; - 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); -end Memroot;