diff options
author | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:57:59 -0400 |
---|---|---|
committer | Richard Kenner <kenner@gcc.gnu.org> | 2001-10-02 10:57:59 -0400 |
commit | 415dddc81c99f37554902cbe0d838060b62a2548 (patch) | |
tree | 4ef27cb0e7d117a7b5941427f004d4d06fc8675b /gcc/ada/xref_lib.adb | |
parent | 996ae0b0aeb9e07a4d7d7ff2926625fd0a58349e (diff) | |
download | gcc-415dddc81c99f37554902cbe0d838060b62a2548.tar.gz |
New Language: Ada
From-SVN: r45960
Diffstat (limited to 'gcc/ada/xref_lib.adb')
-rw-r--r-- | gcc/ada/xref_lib.adb | 1676 |
1 files changed, 1676 insertions, 0 deletions
diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb new file mode 100644 index 00000000000..d3dfe37859a --- /dev/null +++ b/gcc/ada/xref_lib.adb @@ -0,0 +1,1676 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- X R E F _ L I B -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.55 $ +-- -- +-- Copyright (C) 1998-2001 Free Software Foundation, 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with GNAT.Command_Line; use GNAT.Command_Line; +with GNAT.IO_Aux; use GNAT.IO_Aux; +with Osint; +with Output; use Output; +with Types; use Types; +with Unchecked_Deallocation; + +package body Xref_Lib is + + Type_Position : constant := 50; + -- Column for label identifying type of entity + + --------------------- + -- Local Variables -- + --------------------- + + D : constant Character := 'D'; + X : constant Character := 'X'; + W : constant Character := 'W'; + Dot : constant Character := '.'; + + Pipe : constant Character := '|'; + -- First character on xref lines in the .ali file + + EOF : constant Character := ASCII.SUB; + -- Special character to signal end of file. Not required in input file, + -- but should be properly treated if present. See also Read_File. + + No_Xref_Information : exception; + -- Exception raised when there is no cross-referencing information in + -- the .ali files + + subtype File_Offset is Natural; + + function End_Of_Line_Index (File : ALI_File) return Integer; + -- Returns the index of the last character of the current_line + + procedure Read_File + (FD : File_Descriptor; + Contents : out String_Access; + Success : out Boolean); + -- Reads file associated with FS into the newly allocated + -- string Contents. An EOF character will be added to the + -- returned Contents to simplify parsing. + -- [VMS] Success is true iff the number of bytes read is less than or + -- equal to the file size. + -- [Other] Success is true iff the number of bytes read is equal to + -- the file size. + + procedure Parse_EOL (Source : access String; Ptr : in out Positive); + -- On return Source (Ptr) is the first character of the next line + -- or EOF. Source.all must be terminated by EOF. + + procedure Parse_Identifier_Info + (Pattern : Search_Pattern; + File : in out ALI_File; + Local_Symbols : Boolean; + Der_Info : Boolean := False; + Type_Tree : Boolean := False; + Wide_Search : Boolean := True); + -- Output the file and the line where the identifier was referenced, + -- If Local_Symbols is False then only the publicly visible symbols + -- will be processed + + procedure Parse_Token + (Source : access String; + Ptr : in out Positive; + Token_Ptr : out Positive); + -- Skips any separators and stores the start of the token in Token_Ptr. + -- Then stores the position of the next separator in Ptr. + -- On return Source (Token_Ptr .. Ptr - 1) is the token. + -- Separators are space and ASCII.HT. + -- Parse_Token will never skip to the next line. + + procedure Parse_Number + (Source : access String; + Ptr : in out Positive; + Number : out Natural); + -- Skips any separators and parses Source upto the first character that + -- is not a decimal digit. Returns value of parsed digits or 0 if none. + + procedure Parse_X_Filename (File : in out ALI_File); + -- Reads and processes "X..." lines in the ALI file + -- and updates the File.X_File information. + + ---------------- + -- Add_Entity -- + ---------------- + + procedure Add_Entity + (Pattern : in out Search_Pattern; + Entity : String; + Glob : Boolean := False) + is + File_Start : Natural; + Line_Start : Natural; + Col_Start : Natural; + Line_Num : Natural := 0; + Col_Num : Natural := 0; + File_Ref : File_Reference := Empty_File; + File_Existed : Boolean; + Has_Pattern : Boolean := False; + + begin + -- Find the end of the first item in Entity (pattern or file?) + -- If there is no ':', we only have a pattern + + File_Start := Index (Entity, ":"); + if File_Start = 0 then + + -- If the regular expression is invalid, just consider it as a string + + begin + Pattern.Entity := Compile (Entity, Glob, False); + Pattern.Initialized := True; + + exception + when Error_In_Regexp => + + -- The basic idea is to insert a \ before every character + + declare + Tmp_Regexp : String (1 .. 2 * Entity'Length); + Index : Positive := 1; + + begin + for J in Entity'Range loop + Tmp_Regexp (Index) := '\'; + Tmp_Regexp (Index + 1) := Entity (J); + Index := Index + 2; + end loop; + + Pattern.Entity := Compile (Tmp_Regexp, True, False); + Pattern.Initialized := True; + end; + end; + + Set_Default_Match (True); + return; + end if; + + -- If there is a dot in the pattern, then it is a file name + + if (Glob and then + Index (Entity (Entity'First .. File_Start - 1), ".") /= 0) + or else + (not Glob + and then Index (Entity (Entity'First .. File_Start - 1), + "\.") /= 0) + then + Pattern.Entity := Compile (".*", False); + Pattern.Initialized := True; + File_Start := Entity'First; + + else + -- If the regular expression is invalid, + -- just consider it as a string + + begin + Pattern.Entity := + Compile (Entity (Entity'First .. File_Start - 1), Glob, False); + Pattern.Initialized := True; + + exception + when Error_In_Regexp => + + -- The basic idea is to insert a \ before every character + + declare + Tmp_Regexp : String (1 .. 2 * (File_Start - Entity'First)); + Index : Positive := 1; + + begin + for J in Entity'First .. File_Start - 1 loop + Tmp_Regexp (Index) := '\'; + Tmp_Regexp (Index + 1) := Entity (J); + Index := Index + 2; + end loop; + + Pattern.Entity := Compile (Tmp_Regexp, True, False); + Pattern.Initialized := True; + end; + end; + + File_Start := File_Start + 1; + Has_Pattern := True; + end if; + + -- Parse the file name + + Line_Start := Index (Entity (File_Start .. Entity'Last), ":"); + + -- Check if it was a disk:\directory item (for NT and OS/2) + + if File_Start = Line_Start - 1 + and then Line_Start < Entity'Last + and then Entity (Line_Start + 1) = '\' + then + Line_Start := Index (Entity (Line_Start + 1 .. Entity'Last), ":"); + end if; + + if Line_Start = 0 then + Line_Start := Entity'Length + 1; + + elsif Line_Start /= Entity'Last then + Col_Start := Index (Entity (Line_Start + 1 .. Entity'Last), ":"); + + if Col_Start = 0 then + Col_Start := Entity'Last + 1; + end if; + + if Col_Start > Line_Start + 1 then + begin + Line_Num := Natural'Value + (Entity (Line_Start + 1 .. Col_Start - 1)); + + exception + when Constraint_Error => + raise Invalid_Argument; + end; + end if; + + if Col_Start < Entity'Last then + begin + Col_Num := Natural'Value (Entity + (Col_Start + 1 .. Entity'Last)); + + exception + when Constraint_Error => raise Invalid_Argument; + end; + end if; + end if; + + Add_File (Entity (File_Start .. Line_Start - 1), + File_Existed, + File_Ref, + Visited => True); + Add_Line (File_Ref, Line_Num, Col_Num); + Add_File + (ALI_File_Name (Entity (File_Start .. Line_Start - 1)), + File_Existed, File_Ref, + Visited => False, + Emit_Warning => True); + end Add_Entity; + + -------------- + -- Add_File -- + -------------- + + procedure Add_File (File : String) is + File_Ref : File_Reference := Empty_File; + File_Existed : Boolean; + Iterator : Expansion_Iterator; + + procedure Add_File_Internal (File : String); + -- Do the actual addition of the file + + ----------------------- + -- Add_File_Internal -- + ----------------------- + + procedure Add_File_Internal (File : String) is + begin + -- Case where we have an ALI file, accept it even though this is + -- not official usage, since the intention is obvious + + if Tail (File, 4) = ".ali" then + Add_File + (File, + File_Existed, + File_Ref, + Visited => False, + Emit_Warning => True); + + -- Normal non-ali file case + + else + Add_File + (File, + File_Existed, + File_Ref, + Visited => True); + + Add_File + (ALI_File_Name (File), + File_Existed, + File_Ref, + Visited => False, + Emit_Warning => True); + end if; + end Add_File_Internal; + + -- Start of processing for Add_File + + begin + -- Check if we need to do the expansion + + if Ada.Strings.Fixed.Index (File, "*") /= 0 + or else Ada.Strings.Fixed.Index (File, "?") /= 0 + then + Start_Expansion (Iterator, File); + + loop + declare + S : constant String := Expansion (Iterator); + + begin + exit when S'Length = 0; + Add_File_Internal (S); + end; + end loop; + + else + Add_File_Internal (File); + end if; + end Add_File; + + ----------------------- + -- Current_Xref_File -- + ----------------------- + + function Current_Xref_File (File : ALI_File) return File_Reference is + begin + return File.X_File; + end Current_Xref_File; + + -------------------------- + -- Default_Project_File -- + -------------------------- + + function Default_Project_File + (Dir_Name : String) + return String + is + My_Dir : Dir_Type; + Dir_Ent : File_Name_String; + Last : Natural; + + begin + Open (My_Dir, Dir_Name); + + loop + Read (My_Dir, Dir_Ent, Last); + exit when Last = 0; + + if Tail (Dir_Ent (1 .. Last), 4) = ".adp" then + + -- The first project file found is the good one. + + Close (My_Dir); + return Dir_Ent (1 .. Last); + end if; + end loop; + + Close (My_Dir); + return String'(1 .. 0 => ' '); + + exception + when Directory_Error => return String'(1 .. 0 => ' '); + end Default_Project_File; + + ----------------------- + -- End_Of_Line_Index -- + ----------------------- + + function End_Of_Line_Index (File : ALI_File) return Integer is + Index : Integer := File.Current_Line; + begin + while Index <= File.Buffer'Last + and then File.Buffer (Index) /= ASCII.LF + loop + Index := Index + 1; + end loop; + + return Index; + end End_Of_Line_Index; + + --------------- + -- File_Name -- + --------------- + + function File_Name + (File : ALI_File; + Num : Positive) + return File_Reference + is + begin + return File.Dep.Table (Num); + end File_Name; + + -------------------- + -- Find_ALI_Files -- + -------------------- + + procedure Find_ALI_Files is + My_Dir : Rec_DIR; + Dir_Ent : File_Name_String; + Last : Natural; + File_Existed : Boolean; + File_Ref : File_Reference; + + function Open_Next_Dir return Boolean; + -- Tries to open the next object directory, and return False if + -- the directory cannot be opened. + + ------------------- + -- Open_Next_Dir -- + ------------------- + + function Open_Next_Dir return Boolean is + begin + -- Until we are able to open a new directory + + loop + declare + Obj_Dir : constant String := Next_Obj_Dir; + + begin + -- If there was no more Obj_Dir line + + if Obj_Dir'Length = 0 then + return False; + end if; + + Open (My_Dir.Dir, Obj_Dir); + exit; + + exception + -- Could not open the directory + + when Directory_Error => null; + end; + end loop; + + return True; + end Open_Next_Dir; + + -- Start of processing for Find_ALI_Files + + begin + if Open_Next_Dir then + loop + Read (My_Dir.Dir, Dir_Ent, Last); + + if Last = 0 then + Close (My_Dir.Dir); + + if not Open_Next_Dir then + return; + end if; + + elsif Last > 4 and then Dir_Ent (Last - 3 .. Last) = ".ali" then + Add_File (Dir_Ent (1 .. Last), File_Existed, File_Ref, + Visited => False); + Set_Directory (File_Ref, Current_Obj_Dir); + end if; + end loop; + end if; + end Find_ALI_Files; + + ------------------- + -- Get_Full_Type -- + ------------------- + + function Get_Full_Type (Abbrev : Character) return String is + begin + case Abbrev is + when 'A' => return "array type"; + when 'B' => return "boolean type"; + when 'C' => return "class-wide type"; + when 'D' => return "decimal type"; + when 'E' => return "enumeration type"; + when 'F' => return "float type"; + when 'I' => return "integer type"; + when 'M' => return "modular type"; + when 'O' => return "fixed type"; + when 'P' => return "access type"; + when 'R' => return "record type"; + when 'S' => return "string type"; + when 'T' => return "task type"; + when 'W' => return "protected type"; + + when 'a' => return "array type"; + when 'b' => return "boolean object"; + when 'c' => return "class-wide object"; + when 'd' => return "decimal object"; + when 'e' => return "enumeration object"; + when 'f' => return "float object"; + when 'i' => return "integer object"; + when 'm' => return "modular object"; + when 'o' => return "fixed object"; + when 'p' => return "access object"; + when 'r' => return "record object"; + when 's' => return "string object"; + when 't' => return "task object"; + when 'w' => return "protected object"; + + when 'K' => return "package"; + when 'k' => return "generic package"; + when 'L' => return "statement label"; + when 'l' => return "loop label"; + when 'N' => return "named number"; + when 'n' => return "enumeration literal"; + when 'q' => return "block label"; + when 'U' => return "procedure"; + when 'u' => return "generic procedure"; + when 'V' => return "function"; + when 'v' => return "generic function"; + when 'X' => return "exception"; + when 'Y' => return "entry"; + + -- The above should be the only possibilities, but for a + -- tool like this we don't want to bomb if we find something + -- else, so just return ??? when we have an unknown Abbrev value + + when others => + return "???"; + end case; + end Get_Full_Type; + + ----------- + -- Match -- + ----------- + + function Match + (Pattern : Search_Pattern; + Symbol : String) + return Boolean + is + begin + -- Get the entity name + + return Match (Symbol, Pattern.Entity); + end Match; + + ---------- + -- Open -- + ---------- + + procedure Open + (Name : String; + File : out ALI_File; + Dependencies : Boolean := False) + is + Name_0 : constant String := Name & ASCII.NUL; + Num_Dependencies : Natural := 0; + File_Existed : Boolean; + File_Ref : File_Reference; + FD : File_Descriptor; + Success : Boolean := False; + Ali : String_Access renames File.Buffer; + Token : Positive; + Ptr : Positive; + File_Start : Positive; + File_End : Positive; + Gnatchop_Offset : Integer; + Gnatchop_Name : Positive; + + begin + if File.Buffer /= null then + Free (File.Buffer); + end if; + + Init (File.Dep); + + FD := Open_Read (Name_0'Address, Binary); + + if FD = Invalid_FD then + raise No_Xref_Information; + end if; + + Read_File (FD, Ali, Success); + Close (FD); + + Ptr := Ali'First; + + -- Read all the lines possibly processing with-clauses and dependency + -- information and exit on finding the first Xref line. + -- A fall-through of the loop means that there is no xref information + -- which is an error condition. + + while Ali (Ptr) /= EOF loop + + if Ali (Ptr) = D then + -- Found dependency information. Format looks like: + -- D source-name time-stamp checksum [subunit-name] \ + -- [line:file-name] + + -- Skip the D and parse the filename + + Ptr := Ptr + 1; + Parse_Token (Ali, Ptr, Token); + File_Start := Token; + File_End := Ptr - 1; + + Num_Dependencies := Num_Dependencies + 1; + Set_Last (File.Dep, Num_Dependencies); + + Parse_Token (Ali, Ptr, Token); -- Skip time-stamp + Parse_Token (Ali, Ptr, Token); -- Skip checksum + Parse_Token (Ali, Ptr, Token); -- Read next entity on the line + + if not (Ali (Token) in '0' .. '9') then + Parse_Token (Ali, Ptr, Token); -- Was a subunit name + end if; + + -- Did we have a gnatchop-ed file with a pragma Source_Reference ? + Gnatchop_Offset := 0; + + if Ali (Token) in '0' .. '9' then + Gnatchop_Name := Token; + while Ali (Gnatchop_Name) /= ':' loop + Gnatchop_Name := Gnatchop_Name + 1; + end loop; + Gnatchop_Offset := + 2 - Natural'Value (Ali (Token .. Gnatchop_Name - 1)); + Token := Gnatchop_Name + 1; + end if; + + Add_File + (Ali (File_Start .. File_End), + File_Existed, + File.Dep.Table (Num_Dependencies), + Gnatchop_File => Ali (Token .. Ptr - 1), + Gnatchop_Offset => Gnatchop_Offset); + + elsif Dependencies and then Ali (Ptr) = W then + -- Found with-clause information. Format looks like: + -- "W debug%s debug.adb debug.ali" + + -- Skip the W and parse the .ali filename (3rd token) + + Parse_Token (Ali, Ptr, Token); + Parse_Token (Ali, Ptr, Token); + Parse_Token (Ali, Ptr, Token); + + Add_File + (Ali (Token .. Ptr - 1), + File_Existed, File_Ref, + Visited => False); + + elsif Ali (Ptr) = X then + -- Found a cross-referencing line - stop processing + + File.Current_Line := Ptr; + File.Xref_Line := Ptr; + return; + end if; + + Parse_EOL (Ali, Ptr); + end loop; + + raise No_Xref_Information; + end Open; + + --------------- + -- Parse_EOL -- + --------------- + + procedure Parse_EOL (Source : access String; Ptr : in out Positive) is + begin + -- Skip to end of line + + while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF + and then Source (Ptr) /= EOF + loop + Ptr := Ptr + 1; + end loop; + + if Source (Ptr) /= EOF then + Ptr := Ptr + 1; -- skip CR or LF + end if; + + -- Skip past CR/LF or LF/CR combination + + if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF) + and then Source (Ptr) /= Source (Ptr - 1) + then + Ptr := Ptr + 1; + end if; + end Parse_EOL; + + --------------------------- + -- Parse_Identifier_Info -- + --------------------------- + + procedure Parse_Identifier_Info + (Pattern : Search_Pattern; + File : in out ALI_File; + Local_Symbols : Boolean; + Der_Info : Boolean := False; + Type_Tree : Boolean := False; + Wide_Search : Boolean := True) + is + Ptr : Positive renames File.Current_Line; + Ali : String_Access renames File.Buffer; + + E_Line : Natural; -- Line number of current entity + E_Col : Natural; -- Column number of current entity + E_Type : Character; -- Type of current entity + E_Name : Positive; -- Pointer to begin of entity name + E_Global : Boolean; -- True iff entity is global + + R_Line : Natural; -- Line number of current reference + R_Col : Natural; -- Column number of current reference + R_Type : Character; -- Type of current reference + + Decl_Ref : Declaration_Reference; + File_Ref : File_Reference := Current_Xref_File (File); + + function Get_Symbol_Name (Eun, Line, Col : Natural) return String; + -- Returns the symbol name for the entity defined at the specified + -- line and column in the dependent unit number Eun. For this we need + -- to parse the ali file again because the parent entity is not in + -- the declaration table if it did not match the search pattern. + + --------------------- + -- Get_Symbol_Name -- + --------------------- + + function Get_Symbol_Name (Eun, Line, Col : Natural) return String is + Ptr : Positive := 1; + E_Eun : Positive; -- Unit number of current entity + E_Line : Natural; -- Line number of current entity + E_Col : Natural; -- Column number of current entity + E_Name : Positive; -- Pointer to begin of entity name + E_Type : Character; -- Type of current entity + + procedure Skip_Line; + -- skip current line and continuation line + + procedure Skip_Line is + begin + loop + Parse_EOL (Ali, Ptr); + exit when Ali (Ptr) /= '.'; + end loop; + end Skip_Line; + + -- Start of processing for Get_Symbol_Name + + begin + -- Look for the X lines corresponding to unit Eun + + loop + if Ali (Ptr) = 'X' then + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, E_Eun); + exit when E_Eun = Eun; + end if; + + Skip_Line; + end loop; + + -- Here we are in the right Ali section, we now look for the entity + -- declared at position (Line, Col). + + loop + Parse_Number (Ali, Ptr, E_Line); + E_Type := Ali (Ptr); + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, E_Col); + Ptr := Ptr + 1; + + if Line = E_Line and then Col = E_Col then + Parse_Token (Ali, Ptr, E_Name); + return Ali (E_Name .. Ptr - 1); + end if; + + Skip_Line; + end loop; + + -- We were not able to find the symbol, this should not happend but + -- since we don't want to stop here we return a string of three + -- question marks as the symbol name. + + return "???"; + end Get_Symbol_Name; + + -- Start of processing for Parse_Identifier_Info + + begin + -- The identifier info looks like: + -- "38U9*Debug 12|36r6 36r19" + + -- Extract the line, column and entity name information + + Parse_Number (Ali, Ptr, E_Line); + + if Ali (Ptr) > ' ' then + E_Type := Ali (Ptr); + Ptr := Ptr + 1; + end if; + + Parse_Number (Ali, Ptr, E_Col); + + E_Global := False; + if Ali (Ptr) >= ' ' then + E_Global := (Ali (Ptr) = '*'); + Ptr := Ptr + 1; + end if; + + Parse_Token (Ali, Ptr, E_Name); + + -- Exit if the symbol does not match + -- or if we have a local symbol and we do not want it + + if (not Local_Symbols and not E_Global) + or else (Pattern.Initialized + and then not Match (Pattern, Ali (E_Name .. Ptr - 1))) + or else (E_Name >= Ptr) + then + -- Skip rest of this line and all continuation lines + + loop + Parse_EOL (Ali, Ptr); + exit when Ali (Ptr) /= '.'; + end loop; + return; + end if; + + -- Insert the declaration in the table + + Decl_Ref := Add_Declaration + (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type); + + if Ali (Ptr) = '<' then + + -- Here we have a type derivation information. The format is + -- <3|12I45> which means that the current entity is derived from the + -- type defined in unit number 3, line 12 column 45. The pipe and + -- unit number is optional. It is specified only if the parent type + -- is not defined in the current unit. + + Ptr := Ptr + 1; + + Parse_Derived_Info : declare + P_Line : Natural; -- parent entity line + P_Column : Natural; -- parent entity column + P_Type : Character; -- parent entity type + P_Eun : Positive; -- parent entity file number + + begin + Parse_Number (Ali, Ptr, P_Line); + + -- If we have a pipe then the first number was the unit number + + if Ali (Ptr) = '|' then + P_Eun := P_Line; + Ptr := Ptr + 1; + + -- Now we have the line number + + Parse_Number (Ali, Ptr, P_Line); + + else + -- We don't have a unit number specified, so we set P_Eun to + -- the current unit. + + for K in Dependencies_Tables.First .. Last (File.Dep) loop + P_Eun := K; + exit when File.Dep.Table (K) = File_Ref; + end loop; + end if; + + -- Then parse the type and column number + + P_Type := Ali (Ptr); + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, P_Column); + + -- Skip '>' + + Ptr := Ptr + 1; + + -- The derived info is needed only is the derived info mode is on + -- or if we want to output the type hierarchy + + if Der_Info or else Type_Tree then + Add_Parent + (Decl_Ref, + Get_Symbol_Name (P_Eun, P_Line, P_Column), + P_Line, + P_Column, + File.Dep.Table (P_Eun)); + end if; + + if Type_Tree then + Search_Parent_Tree : declare + Pattern : Search_Pattern; -- Parent type pattern + File_Pos_Backup : Positive; + + begin + Add_Entity + (Pattern, + Get_Symbol_Name (P_Eun, P_Line, P_Column) + & ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun)) + & ':' & Get_Line (Get_Parent (Decl_Ref)) + & ':' & Get_Column (Get_Parent (Decl_Ref)), + False); + + -- No default match is needed to look for the parent type + -- since we are using the fully qualified symbol name: + -- symbol:file:line:column + + Set_Default_Match (False); + + -- The parent type is defined in the same unit as the + -- derived type. So we want to revisit the unit. + + File_Pos_Backup := File.Current_Line; + + if File.Dep.Table (P_Eun) = File_Ref then + + -- set file pointer at the start of the xref lines + + File.Current_Line := File.Xref_Line; + + Revisit_ALI_File : declare + File_Existed : Boolean; + File_Ref : File_Reference; + begin + Add_File + (ALI_File_Name (Get_File (File.Dep.Table (P_Eun))), + File_Existed, + File_Ref, + Visited => False); + Set_Unvisited (File_Ref); + end Revisit_ALI_File; + end if; + + Search (Pattern, + Local_Symbols, False, False, Der_Info, Type_Tree); + + File.Current_Line := File_Pos_Backup; + + -- in this mode there is no need to parse the remaining of + -- the lines. + + return; + end Search_Parent_Tree; + end if; + end Parse_Derived_Info; + end if; + + -- To find the body, we will have to parse the file too + + if Wide_Search then + declare + File_Existed : Boolean; + File_Ref : File_Reference; + File_Name : constant String := + Get_Gnatchop_File (File.X_File); + + begin + Add_File (ALI_File_Name (File_Name), + File_Existed, File_Ref, False); + end; + end if; + + -- Parse references to this entity. + -- Ptr points to next reference with leading blanks + + loop + -- Process references on current line + + while Ali (Ptr) = ' ' or Ali (Ptr) = ASCII.HT loop + + -- For every reference read the line, type and column, + -- optionally preceded by a file number and a pipe symbol. + + Parse_Number (Ali, Ptr, R_Line); + + if Ali (Ptr) = Pipe then + Ptr := Ptr + 1; + File_Ref := File_Name (File, R_Line); + + Parse_Number (Ali, Ptr, R_Line); + end if; + + if Ali (Ptr) > ' ' then + R_Type := Ali (Ptr); + Ptr := Ptr + 1; + end if; + + Parse_Number (Ali, Ptr, R_Col); + + -- Insert the reference or body in the table + + Add_Reference (Decl_Ref, File_Ref, R_Line, R_Col, R_Type); + + end loop; + + Parse_EOL (Ali, Ptr); + + -- Loop until new line is no continuation line + + exit when Ali (Ptr) /= '.'; + Ptr := Ptr + 1; + end loop; + end Parse_Identifier_Info; + + ------------------ + -- Parse_Number -- + ------------------ + + procedure Parse_Number + (Source : access String; + Ptr : in out Positive; + Number : out Natural) + is + begin + -- Skip separators + + while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop + Ptr := Ptr + 1; + end loop; + + Number := 0; + while Source (Ptr) in '0' .. '9' loop + Number := 10 * Number + + (Character'Pos (Source (Ptr)) - Character'Pos ('0')); + Ptr := Ptr + 1; + end loop; + end Parse_Number; + + ----------------- + -- Parse_Token -- + ----------------- + + procedure Parse_Token + (Source : access String; + Ptr : in out Positive; + Token_Ptr : out Positive) + is + In_Quotes : Boolean := False; + + begin + -- Skip separators + + while Source (Ptr) = ' ' or else Source (Ptr) = ASCII.HT loop + Ptr := Ptr + 1; + end loop; + + Token_Ptr := Ptr; + + -- Find end-of-token + + while (In_Quotes or else + not (Source (Ptr) = ' ' + or else Source (Ptr) = ASCII.HT + or else Source (Ptr) = '<')) + and then Source (Ptr) >= ' ' + loop + if Source (Ptr) = '"' then + In_Quotes := not In_Quotes; + end if; + + Ptr := Ptr + 1; + end loop; + end Parse_Token; + + ---------------------- + -- Parse_X_Filename -- + ---------------------- + + procedure Parse_X_Filename (File : in out ALI_File) is + Ali : String_Access renames File.Buffer; + Ptr : Positive renames File.Current_Line; + File_Nr : Natural; + + begin + while Ali (Ptr) = X loop + + -- The current line is the start of a new Xref file section, + -- whose format looks like: + + -- " X 1 debug.ads" + + -- Skip the X and read the file number for the new X_File + + Ptr := Ptr + 1; + Parse_Number (Ali, Ptr, File_Nr); + + if File_Nr > 0 then + File.X_File := File.Dep.Table (File_Nr); + end if; + + Parse_EOL (Ali, Ptr); + end loop; + + end Parse_X_Filename; + + -------------------- + -- Print_Gnatfind -- + -------------------- + + procedure Print_Gnatfind + (References : Boolean; + Full_Path_Name : Boolean) + is + Decl : Declaration_Reference := First_Declaration; + Ref1 : Reference; + Ref2 : Reference; + + procedure Print_Ref + (Ref : Reference; + Msg : String := " "); + -- Print a reference, according to the extended tag of the output + + --------------- + -- Print_Ref -- + --------------- + + procedure Print_Ref + (Ref : Reference; + Msg : String := " ") + is + Buffer : constant String := + Osint.To_Host_File_Spec + (Get_Gnatchop_File (Ref, Full_Path_Name)).all + & ":" & Get_Line (Ref) + & ":" & Get_Column (Ref) + & ": "; + Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length; + + begin + Num_Blanks := Integer'Max (0, Num_Blanks); + Write_Line + (Buffer + & String'(1 .. Num_Blanks => ' ') + & Msg & " " & Get_Symbol (Decl)); + if Get_Source_Line (Ref)'Length /= 0 then + Write_Line (" " & Get_Source_Line (Ref)); + end if; + end Print_Ref; + + -- Start of processing for Print_Gnatfind + + begin + while Decl /= Empty_Declaration loop + if Match (Decl) then + + -- Output the declaration + + declare + Parent : constant Declaration_Reference := Get_Parent (Decl); + Buffer : constant String := + Osint.To_Host_File_Spec + (Get_Gnatchop_File (Decl, Full_Path_Name)).all + & ":" & Get_Line (Decl) + & ":" & Get_Column (Decl) + & ": "; + Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length; + + begin + Num_Blanks := Integer'Max (0, Num_Blanks); + Write_Line + (Buffer & String'(1 .. Num_Blanks => ' ') + & "(spec) " & Get_Symbol (Decl)); + + if Parent /= Empty_Declaration then + Write_Line + (Buffer & String'(1 .. Num_Blanks => ' ') + & " derived from " & Get_Symbol (Parent) + & " (" + & Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent)).all + & ':' & Get_Line (Parent) + & ':' & Get_Column (Parent) & ')'); + end if; + end; + + if Get_Source_Line (Decl)'Length /= 0 then + Write_Line (" " & Get_Source_Line (Decl)); + end if; + + -- Output the body (sorted) + + Ref1 := First_Body (Decl); + while Ref1 /= Empty_Reference loop + Print_Ref (Ref1, "(body)"); + Ref1 := Next (Ref1); + end loop; + + if References then + Ref1 := First_Modif (Decl); + Ref2 := First_Reference (Decl); + while Ref1 /= Empty_Reference + or else Ref2 /= Empty_Reference + loop + if Compare (Ref1, Ref2) = LessThan then + Print_Ref (Ref1); + Ref1 := Next (Ref1); + else + Print_Ref (Ref2); + Ref2 := Next (Ref2); + end if; + end loop; + end if; + end if; + + Decl := Next (Decl); + end loop; + end Print_Gnatfind; + + ------------------ + -- Print_Unused -- + ------------------ + + procedure Print_Unused (Full_Path_Name : in Boolean) is + Decl : Declaration_Reference := First_Declaration; + Ref : Reference; + + begin + while Decl /= Empty_Declaration loop + if First_Modif (Decl) = Empty_Reference + and then First_Reference (Decl) = Empty_Reference + then + Write_Str (Get_Symbol (Decl) + & " " + & Get_Type (Decl) + & " " + & Osint.To_Host_File_Spec + (Get_Gnatchop_File (Decl, Full_Path_Name)).all + & ':' + & Get_Line (Decl) + & ':' + & Get_Column (Decl)); + + -- Print the body if any + + Ref := First_Body (Decl); + + if Ref /= Empty_Reference then + Write_Line (' ' + & Osint.To_Host_File_Spec + (Get_Gnatchop_File (Ref, Full_Path_Name)).all + & ':' & Get_Line (Ref) + & ':' & Get_Column (Ref)); + else + Write_Eol; + end if; + end if; + + Decl := Next (Decl); + end loop; + end Print_Unused; + + -------------- + -- Print_Vi -- + -------------- + + procedure Print_Vi (Full_Path_Name : in Boolean) is + Tab : constant Character := ASCII.HT; + Decl : Declaration_Reference := First_Declaration; + Ref : Reference; + + begin + while Decl /= Empty_Declaration loop + Write_Line (Get_Symbol (Decl) & Tab + & Get_File (Decl, Full_Path_Name) & Tab + & Get_Line (Decl)); + + -- Print the body if any + + Ref := First_Body (Decl); + + if Ref /= Empty_Reference then + Write_Line (Get_Symbol (Decl) & Tab + & Get_File (Ref, Full_Path_Name) + & Tab + & Get_Line (Ref)); + end if; + + -- Print the modifications + + Ref := First_Modif (Decl); + + while Ref /= Empty_Reference loop + Write_Line (Get_Symbol (Decl) & Tab + & Get_File (Ref, Full_Path_Name) + & Tab + & Get_Line (Ref)); + Ref := Next (Ref); + end loop; + + Decl := Next (Decl); + end loop; + end Print_Vi; + + ---------------- + -- Print_Xref -- + ---------------- + + procedure Print_Xref (Full_Path_Name : in Boolean) is + Decl : Declaration_Reference := First_Declaration; + Ref : Reference; + File : File_Reference; + + Margin : constant := 10; + -- Column where file names start + + procedure New_Line80; + -- Go to start of new line + + procedure Print80 (S : in String); + -- Print the text, respecting the 80 columns rule. + + procedure Print_Ref (Line, Column : String); + -- The beginning of the output is aligned on a column multiple of 9 + + ---------------- + -- New_Line80 -- + ---------------- + + procedure New_Line80 is + begin + Write_Eol; + Write_Str (String'(1 .. Margin - 1 => ' ')); + end New_Line80; + + ------------- + -- Print80 -- + ------------- + + procedure Print80 (S : in String) is + Align : Natural := Margin - (Integer (Column) mod Margin); + begin + if Align = Margin then + Align := 0; + end if; + + Write_Str (String'(1 .. Align => ' ') & S); + end Print80; + + --------------- + -- Print_Ref -- + --------------- + + procedure Print_Ref (Line, Column : String) is + Line_Align : constant Integer := 4 - Line'Length; + + S : constant String := String'(1 .. Line_Align => ' ') + & Line & ':' & Column; + + Align : Natural := Margin - (Integer (Output.Column) mod Margin); + + begin + if Align = Margin then + Align := 0; + end if; + + if Integer (Output.Column) + Align + S'Length > 79 then + New_Line80; + Align := 0; + end if; + + Write_Str (String'(1 .. Align => ' ') & S); + end Print_Ref; + + -- Start of processing for Print_Xref + + begin + while Decl /= Empty_Declaration loop + Write_Str (Get_Symbol (Decl)); + + while Column < Type_Position loop + Write_Char (' '); + end loop; + + Write_Line (Get_Full_Type (Get_Type (Decl))); + + Write_Parent_Info : declare + Parent : constant Declaration_Reference := Get_Parent (Decl); + begin + if Parent /= Empty_Declaration then + Write_Str (" Ptype: "); + Print80 + (Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent)).all); + Print_Ref (Get_Line (Parent), Get_Column (Parent)); + Print80 (" " & Get_Symbol (Parent)); + Write_Eol; + end if; + end Write_Parent_Info; + + Write_Str (" Decl: "); + Print80 + (Osint.To_Host_File_Spec + (Get_Gnatchop_File (Decl, Full_Path_Name)).all & ' '); + Print_Ref (Get_Line (Decl), Get_Column (Decl)); + + -- Print the body if any + + Ref := First_Body (Decl); + + if Ref /= Empty_Reference then + Write_Eol; + Write_Str (" Body: "); + Print80 + (Osint.To_Host_File_Spec + (Get_Gnatchop_File (Ref, Full_Path_Name)).all & ' '); + Print_Ref (Get_Line (Ref), Get_Column (Ref)); + end if; + + -- Print the modifications if any + + Ref := First_Modif (Decl); + + if Ref /= Empty_Reference then + Write_Eol; + Write_Str (" Modi: "); + end if; + + File := Empty_File; + + while Ref /= Empty_Reference loop + if Get_File_Ref (Ref) /= File then + if File /= Empty_File then + New_Line80; + end if; + + File := Get_File_Ref (Ref); + Write_Str + (Get_Gnatchop_File (Ref, Full_Path_Name) & ' '); + Print_Ref (Get_Line (Ref), Get_Column (Ref)); + + else + Print_Ref (Get_Line (Ref), Get_Column (Ref)); + end if; + + Ref := Next (Ref); + end loop; + + -- Print the references + + Ref := First_Reference (Decl); + + if Ref /= Empty_Reference then + Write_Eol; + Write_Str (" Ref: "); + end if; + + File := Empty_File; + + while Ref /= Empty_Reference loop + if Get_File_Ref (Ref) /= File then + if File /= Empty_File then + New_Line80; + end if; + + File := Get_File_Ref (Ref); + Write_Str + (Osint.To_Host_File_Spec + (Get_Gnatchop_File (Ref, Full_Path_Name)).all & ' '); + Print_Ref (Get_Line (Ref), Get_Column (Ref)); + + else + Print_Ref (Get_Line (Ref), Get_Column (Ref)); + end if; + + Ref := Next (Ref); + end loop; + + Write_Eol; + Decl := Next (Decl); + end loop; + end Print_Xref; + + --------------- + -- Read_File -- + --------------- + + procedure Read_File + (FD : File_Descriptor; + Contents : out String_Access; + Success : out Boolean) + is + Length : constant File_Offset := File_Offset (File_Length (FD)); + -- Include room for EOF char + + Buffer : String (1 .. Length + 1); + + This_Read : Integer; + Read_Ptr : File_Offset := 1; + + begin + + loop + This_Read := Read (FD, + A => Buffer (Read_Ptr)'Address, + N => Length + 1 - Read_Ptr); + Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0); + exit when This_Read <= 0; + end loop; + + Buffer (Read_Ptr) := EOF; + Contents := new String'(Buffer (1 .. Read_Ptr)); + + -- Things aren't simple on VMS due to the plethora of file types + -- and organizations. It seems clear that there shouldn't be more + -- bytes read than are contained in the file though. + + if Hostparm.OpenVMS then + Success := Read_Ptr <= Length + 1; + else + Success := Read_Ptr = Length + 1; + end if; + end Read_File; + + ------------ + -- Search -- + ------------ + + procedure Search + (Pattern : Search_Pattern; + Local_Symbols : Boolean; + Wide_Search : Boolean; + Read_Only : Boolean; + Der_Info : Boolean; + Type_Tree : Boolean) + is + type String_Access is access String; + procedure Free is new Unchecked_Deallocation (String, String_Access); + + ALIfile : ALI_File; + File_Ref : File_Reference; + Strip_Num : Natural := 0; + Ali_Name : String_Access; + + begin + -- If we want all the .ali files, then find them + + if Wide_Search then + Find_ALI_Files; + end if; + + loop + -- Get the next unread ali file + + File_Ref := Next_Unvisited_File; + + exit when File_Ref = Empty_File; + + -- Find the ALI file to use. Most of the time, it will be the unit + -- name, with a different extension. However, when dealing with + -- separates the ALI file is in fact the parent's ALI file (and this + -- is recursive, in case the parent itself is a separate). + + Strip_Num := 0; + loop + Free (Ali_Name); + Ali_Name := new String' + (Get_File (File_Ref, With_Dir => True, Strip => Strip_Num)); + + -- Striped too many things... + if Ali_Name.all = "" then + if Get_Emit_Warning (File_Ref) then + Set_Standard_Error; + Write_Line + ("warning : file " & Get_File (File_Ref, With_Dir => True) + & " not found"); + Set_Standard_Output; + end if; + Free (Ali_Name); + exit; + + -- If not found, try the parent's ALI file (this is needed for + -- separate units and subprograms). + elsif not File_Exists (Ali_Name.all) then + Strip_Num := Strip_Num + 1; + + -- Else we finally found it + else + exit; + end if; + end loop; + + -- Now that we have a file name, parse it to find any reference to + -- the entity. + + if Ali_Name /= null + and then (Read_Only or else Is_Writable_File (Ali_Name.all)) + then + begin + Open (Ali_Name.all, ALIfile); + while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop + Parse_X_Filename (ALIfile); + Parse_Identifier_Info (Pattern, ALIfile, Local_Symbols, + Der_Info, Type_Tree, Wide_Search); + end loop; + + exception + when No_Xref_Information => + if Get_Emit_Warning (File_Ref) then + Set_Standard_Error; + Write_Line + ("warning : No cross-referencing information in " + & Ali_Name.all); + Set_Standard_Output; + end if; + end; + end if; + end loop; + + Free (Ali_Name); + end Search; + + ----------------- + -- Search_Xref -- + ----------------- + + procedure Search_Xref + (Local_Symbols : Boolean; + Read_Only : Boolean; + Der_Info : Boolean) + is + ALIfile : ALI_File; + File_Ref : File_Reference; + Null_Pattern : Search_Pattern; + begin + loop + -- Find the next unvisited file + + File_Ref := Next_Unvisited_File; + exit when File_Ref = Empty_File; + + -- Search the object directories for the .ali file + + if Read_Only + or else Is_Writable_File (Get_File (File_Ref, With_Dir => True)) + then + begin + Open (Get_File (File_Ref, With_Dir => True), ALIfile, True); + + while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop + Parse_X_Filename (ALIfile); + Parse_Identifier_Info + (Null_Pattern, ALIfile, Local_Symbols, Der_Info); + end loop; + + exception + when No_Xref_Information => null; + end; + end if; + end loop; + end Search_Xref; + +end Xref_Lib; |