------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- M E M R O O T -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 1997-2002 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; -- Skip the __gnat_malloc frame itself if Line (Curs1 .. Curs2) /= "<__gnat_malloc>" then 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; 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;