MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
9cabb1d829
8sa1-gcc/gcc/ada/memroot.adb
Geoffrey Keating 6cbcc54138 Delete all lines containing "$Revision:". 
* xeinfo.adb: Don't look for revision numbers.
	* xnmake.adb: Likewise.
	* xsinfo.adb: Likewise.
	* xsnames.adb: Likewise.
	* xtreeprs.adb: Likewise.

From-SVN: r50768
2002-03-14 11:00:22 +00:00

666 lines
19 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- 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;
Reference in New Issue View Git Blame Copy Permalink