:switch:`-gnatx`
Normally the compiler generates full cross-referencing information in
- the :file:`ALI` file. This information is used by a number of tools,
- including ``gnatfind`` and ``gnatxref``. The :switch:`-gnatx` switch
- suppresses this information. This saves some space and may slightly
- speed up compilation, but means that these tools cannot be used.
+ the :file:`ALI` file. This information is used by a number of tools.
+ The :switch:`-gnatx` switch suppresses this information. This saves some space
+ and may slightly speed up compilation, but means that tools depending
+ on this information cannot be used.
.. index:: -fgnat-encodings (gcc)
if any of these units are modified.
* Cross-reference data. Contains information on all entities referenced
- in the unit. Used by tools like ``gnatxref`` and ``gnatfind`` to
- provide cross-reference information.
+ in the unit. Used by some tools to provide cross-reference information.
For a full detailed description of the format of the :file:`ALI` file,
see the source of the body of unit ``Lib.Writ``, contained in file
You can also specify a new default path to the run-time library at compilation
time with the switch :switch:`--RTS=rts-path`. You can thus choose / change
the run-time library you want your program to be compiled with. This switch is
-recognized by ``gcc``, ``gnatmake``, ``gnatbind``,
-``gnatls``, ``gnatfind`` and ``gnatxref``.
+recognized by ``gcc``, ``gnatmake``, ``gnatbind``, ``gnatls``, and all
+project aware tools.
It is possible to install a library before or after the standard GNAT
library, by reordering the lines in the configuration files. In general, a
-- Do not generate an ALI file in this case, because it would
-- become obsolete when the parent is compiled, and thus
- -- confuse tools such as gnatfind.
+ -- confuse some tools.
elsif Main_Unit_Kind = N_Subprogram_Declaration then
Write_Str (" (subprogram spec)");
@item
Cross-reference data. Contains information on all entities referenced
-in the unit. Used by tools like @code{gnatxref} and @code{gnatfind} to
-provide cross-reference information.
+in the unit. Used by some tools to provide cross-reference information.
@end itemize
For a full detailed description of the format of the @code{ALI} file,
You can also specify a new default path to the run-time library at compilation
time with the switch @code{--RTS=rts-path}. You can thus choose / change
the run-time library you want your program to be compiled with. This switch is
-recognized by @code{gcc}, @code{gnatmake}, @code{gnatbind},
-@code{gnatls}, @code{gnatfind} and @code{gnatxref}.
+recognized by @code{gcc}, @code{gnatmake}, @code{gnatbind}, @code{gnatls}, and all
+project aware tools.
It is possible to install a library before or after the standard GNAT
library, by reordering the lines in the configuration files. In general, a
@item @code{-gnatx}
Normally the compiler generates full cross-referencing information in
-the @code{ALI} file. This information is used by a number of tools,
-including @code{gnatfind} and @code{gnatxref}. The @code{-gnatx} switch
-suppresses this information. This saves some space and may slightly
-speed up compilation, but means that these tools cannot be used.
+the @code{ALI} file. This information is used by a number of tools.
+The @code{-gnatx} switch suppresses this information. This saves some space
+and may slightly speed up compilation, but means that tools depending
+on this information cannot be used.
@end table
@geindex -fgnat-encodings (gcc)
Compile,
Check,
Elim,
- Find,
Krunch,
Link,
List,
Stack,
Stub,
Test,
- Xref,
Undefined);
- subtype Real_Command_Type is Command_Type range Bind .. Xref;
+ subtype Real_Command_Type is Command_Type range Bind .. Test;
-- All real command types (excludes only Undefined).
type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
Unixcmd => new String'("gnatelim"),
Unixsws => null),
- Find =>
- (Cname => new String'("FIND"),
- Unixcmd => new String'("gnatfind"),
- Unixsws => null),
-
Krunch =>
(Cname => new String'("KRUNCH"),
Unixcmd => new String'("gnatkr"),
Test =>
(Cname => new String'("TEST"),
Unixcmd => new String'("gnattest"),
- Unixsws => null),
-
- Xref =>
- (Cname => new String'("XREF"),
- Unixcmd => new String'("gnatxref"),
Unixsws => null)
);
end loop;
end if;
- -- For FIND and XREF, look for switch -P. If it is specified, then
- -- report an error indicating that the command does not support project
- -- files.
-
- if The_Command in Find | Xref then
- declare
- Argv : String_Access;
- begin
- for Arg_Num in 1 .. Last_Switches.Last loop
- Argv := Last_Switches.Table (Arg_Num);
-
- if Argv'Length >= 2
- and then Argv (Argv'First .. Argv'First + 1) = "-P"
- then
- if The_Command = Find then
- Fail ("'gnat find -P' is not supported;");
- else
- Fail ("'gnat xref -P' is not supported;");
- end if;
- end if;
- end loop;
- end;
- end if;
-
-- Gather all the arguments and invoke the executable
declare
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T F I N D --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2022, 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 3, 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 COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Opt;
-with Osint; use Osint;
-with Switch; use Switch;
-with Types; use Types;
-with Xr_Tabls;
-with Xref_Lib; use Xref_Lib;
-
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Strings.Fixed; use Ada.Strings.Fixed;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Command_Line; use GNAT.Command_Line;
-
-with System.Strings; use System.Strings;
-
---------------
--- Gnatfind --
---------------
-
-procedure Gnatfind is
- Output_Ref : Boolean := False;
- Pattern : Xref_Lib.Search_Pattern;
- Local_Symbols : Boolean := True;
- Prj_File : File_Name_String;
- Prj_File_Length : Natural := 0;
- Nb_File : Natural := 0;
- Usage_Error : exception;
- Full_Path_Name : Boolean := False;
- Have_Entity : Boolean := False;
- Wide_Search : Boolean := True;
- Glob_Mode : Boolean := True;
- Der_Info : Boolean := False;
- Type_Tree : Boolean := False;
- Read_Only : Boolean := False;
- Source_Lines : Boolean := False;
-
- Has_File_In_Entity : Boolean := False;
- -- Will be true if a file name was specified in the entity
-
- RTS_Specified : String_Access := null;
- -- Used to detect multiple use of --RTS= switch
-
- EXT_Specified : String_Access := null;
- -- Used to detect multiple use of --ext= switch
-
- procedure Parse_Cmd_Line;
- -- Parse every switch on the command line
-
- procedure Usage;
- -- Display the usage
-
- procedure Write_Usage;
- pragma No_Return (Write_Usage);
- -- Print a small help page for program usage and exit program
-
- --------------------
- -- Parse_Cmd_Line --
- --------------------
-
- procedure Parse_Cmd_Line is
-
- procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
-
- -- Start of processing for Parse_Cmd_Line
-
- begin
- -- First check for --version or --help
-
- Check_Version_And_Help ("GNATFIND", "1998");
-
- -- Now scan the other switches
-
- GNAT.Command_Line.Initialize_Option_Scan;
-
- loop
- case
- GNAT.Command_Line.Getopt
- ("a aI: aO: d e f g h I: nostdinc nostdlib p: r s t -RTS= -ext=")
- is
- when ASCII.NUL =>
- exit;
-
- when 'a' =>
- if GNAT.Command_Line.Full_Switch = "a" then
- Read_Only := True;
- elsif GNAT.Command_Line.Full_Switch = "aI" then
- Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter);
- else
- Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
- end if;
-
- when 'd' =>
- Der_Info := True;
-
- when 'e' =>
- Glob_Mode := False;
-
- when 'f' =>
- Full_Path_Name := True;
-
- when 'g' =>
- Local_Symbols := False;
-
- when 'h' =>
- Write_Usage;
-
- when 'I' =>
- Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter);
- Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
-
- when 'n' =>
- if GNAT.Command_Line.Full_Switch = "nostdinc" then
- Opt.No_Stdinc := True;
- elsif GNAT.Command_Line.Full_Switch = "nostdlib" then
- Opt.No_Stdlib := True;
- end if;
-
- when 'p' =>
- declare
- S : constant String := GNAT.Command_Line.Parameter;
- begin
- Prj_File_Length := S'Length;
- Prj_File (1 .. Prj_File_Length) := S;
- end;
-
- when 'r' =>
- Output_Ref := True;
-
- when 's' =>
- Source_Lines := True;
-
- when 't' =>
- Type_Tree := True;
-
- -- Only switch starting with -- recognized is --RTS
-
- when '-' =>
- if GNAT.Command_Line.Full_Switch = "-RTS" then
-
- -- Check that it is the first time we see this switch
-
- if RTS_Specified = null then
- RTS_Specified := new String'(GNAT.Command_Line.Parameter);
- elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then
- Osint.Fail ("--RTS cannot be specified multiple times");
- end if;
-
- Opt.No_Stdinc := True;
- Opt.RTS_Switch := True;
-
- declare
- Src_Path_Name : constant String_Ptr :=
- Get_RTS_Search_Dir
- (GNAT.Command_Line.Parameter,
- Include);
- Lib_Path_Name : constant String_Ptr :=
- Get_RTS_Search_Dir
- (GNAT.Command_Line.Parameter,
- Objects);
-
- begin
- if Src_Path_Name /= null
- and then Lib_Path_Name /= null
- then
- Add_Search_Dirs (Src_Path_Name, Include);
- Add_Search_Dirs (Lib_Path_Name, Objects);
-
- elsif Src_Path_Name = null
- and then Lib_Path_Name = null
- then
- Osint.Fail ("RTS path not valid: missing " &
- "adainclude and adalib directories");
-
- elsif Src_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adainclude directory");
-
- elsif Lib_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adalib directory");
- end if;
- end;
-
- -- Process -ext switch
-
- elsif GNAT.Command_Line.Full_Switch = "-ext" then
-
- -- Check that it is the first time we see this switch
-
- if EXT_Specified = null then
- EXT_Specified := new String'(GNAT.Command_Line.Parameter);
- elsif EXT_Specified.all /= GNAT.Command_Line.Parameter then
- Osint.Fail ("--ext cannot be specified multiple times");
- end if;
-
- if
- EXT_Specified'Length = Osint.ALI_Default_Suffix'Length
- then
- Osint.ALI_Suffix := EXT_Specified.all'Access;
- else
- Osint.Fail ("--ext argument must have 3 characters");
- end if;
-
- end if;
-
- when others =>
- Try_Help;
- raise Usage_Error;
- end case;
- end loop;
-
- -- Get the other arguments
-
- loop
- declare
- S : constant String := GNAT.Command_Line.Get_Argument;
-
- begin
- exit when S'Length = 0;
-
- -- First argument is the pattern
-
- if not Have_Entity then
- Add_Entity (Pattern, S, Glob_Mode);
- Have_Entity := True;
-
- if not Has_File_In_Entity
- and then Index (S, ":") /= 0
- then
- Has_File_In_Entity := True;
- end if;
-
- -- Next arguments are the files to search
-
- else
- Add_Xref_File (S);
- Wide_Search := False;
- Nb_File := Nb_File + 1;
- end if;
- end;
- end loop;
-
- exception
- when GNAT.Command_Line.Invalid_Switch =>
- Ada.Text_IO.Put_Line ("Invalid switch : "
- & GNAT.Command_Line.Full_Switch);
- Try_Help;
- raise Usage_Error;
-
- when GNAT.Command_Line.Invalid_Parameter =>
- Ada.Text_IO.Put_Line ("Parameter missing for : "
- & GNAT.Command_Line.Full_Switch);
- Try_Help;
- raise Usage_Error;
-
- when Xref_Lib.Invalid_Argument =>
- Ada.Text_IO.Put_Line ("Invalid line or column in the pattern");
- Try_Help;
- raise Usage_Error;
- end Parse_Cmd_Line;
-
- -----------
- -- Usage --
- -----------
-
- procedure Usage is
- begin
- Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] "
- & "[file1 file2 ...]");
- New_Line;
- Put_Line (" pattern Name of the entity to look for (can have "
- & "wildcards)");
- Put_Line (" sourcefile Only find entities referenced from this "
- & "file");
- Put_Line (" line Only find entities referenced from this line "
- & "of file");
- Put_Line (" column Only find entities referenced from this columns"
- & " of file");
- Put_Line (" file ... Set of Ada source files to search for "
- & "references. This parameters are optional");
- New_Line;
- Put_Line ("gnatfind switches:");
- Display_Usage_Version_And_Help;
- Put_Line (" -a Consider all files, even when the ali file is "
- & "readonly");
- Put_Line (" -aIdir Specify source files search path");
- Put_Line (" -aOdir Specify library/object files search path");
- Put_Line (" -d Output derived type information");
- Put_Line (" -e Use the full regular expression set for "
- & "pattern");
- Put_Line (" -f Output full path name");
- Put_Line (" -g Output information only for global symbols");
- Put_Line (" -Idir Like -aIdir -aOdir");
- Put_Line (" -nostdinc Don't look for sources in the system default"
- & " directory");
- Put_Line (" -nostdlib Don't look for library files in the system"
- & " default directory");
- Put_Line (" --ext=xxx Specify alternate ali file extension");
- Put_Line (" --RTS=dir specify the default source and object search"
- & " path");
- Put_Line (" -p file Use file as the configuration file");
- Put_Line (" -r Find all references (default to find declaration"
- & " only)");
- Put_Line (" -s Print source line");
- Put_Line (" -t Print type hierarchy");
- end Usage;
-
- -----------------
- -- Write_Usage --
- -----------------
-
- procedure Write_Usage is
- begin
- Display_Version ("GNATFIND", "1998");
- New_Line;
-
- Usage;
-
- raise Usage_Error;
- end Write_Usage;
-
--- Start of processing for Gnatfind
-
-begin
- Put_Line
- ("WARNING: gnatfind is obsolete and will be removed in the next release");
- Put_Line
- ("Consider using Libadalang or GNAT Studio python scripting instead");
-
- Parse_Cmd_Line;
-
- if not Have_Entity then
- if Argument_Count = 0 then
- Write_Usage;
- else
- Try_Help;
- raise Usage_Error;
- end if;
- end if;
-
- -- Special case to speed things up: if the user has a command line of the
- -- form 'gnatfind entity:file', i.e. has specified a file and only wants
- -- the bodies and specs, then we can restrict the search to the .ali file
- -- associated with 'file'.
-
- if Has_File_In_Entity
- and then not Output_Ref
- then
- Wide_Search := False;
- end if;
-
- -- Find the project file
-
- if Prj_File_Length = 0 then
- Xr_Tabls.Create_Project_File (Default_Project_File ("."));
- else
- Xr_Tabls.Create_Project_File (Prj_File (1 .. Prj_File_Length));
- end if;
-
- -- Fill up the table
-
- if Type_Tree and then Nb_File > 1 then
- Ada.Text_IO.Put_Line ("Error: for type hierarchy output you must "
- & "specify only one file.");
- Ada.Text_IO.New_Line;
- Try_Help;
- raise Usage_Error;
- end if;
-
- Search (Pattern, Local_Symbols, Wide_Search, Read_Only,
- Der_Info, Type_Tree);
-
- if Source_Lines then
- Xr_Tabls.Grep_Source_Files;
- end if;
-
- Print_Gnatfind (Output_Ref, Full_Path_Name);
-
-exception
- when Usage_Error =>
- null;
-end Gnatfind;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T X R E F --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2022, 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 3, 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 COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Opt;
-with Osint; use Osint;
-with Types; use Types;
-with Switch; use Switch;
-with Xr_Tabls;
-with Xref_Lib; use Xref_Lib;
-
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Strings.Fixed;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Command_Line; use GNAT.Command_Line;
-
-with System.Strings; use System.Strings;
-
-procedure Gnatxref is
- Search_Unused : Boolean := False;
- Local_Symbols : Boolean := True;
- Prj_File : File_Name_String;
- Prj_File_Length : Natural := 0;
- Usage_Error : exception;
- Full_Path_Name : Boolean := False;
- Vi_Mode : Boolean := False;
- Read_Only : Boolean := False;
- Have_File : Boolean := False;
- Der_Info : Boolean := False;
-
- RTS_Specified : String_Access := null;
- -- Used to detect multiple use of --RTS= switch
-
- EXT_Specified : String_Access := null;
- -- Used to detect multiple use of --ext= switch
-
- procedure Parse_Cmd_Line;
- -- Parse every switch on the command line
-
- procedure Usage;
- -- Display the usage
-
- procedure Write_Usage;
- pragma No_Return (Write_Usage);
- -- Print a small help page for program usage
-
- --------------------
- -- Parse_Cmd_Line --
- --------------------
-
- procedure Parse_Cmd_Line is
-
- procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
-
- -- Start of processing for Parse_Cmd_Line
-
- begin
- -- First check for --version or --help
-
- Check_Version_And_Help ("GNATXREF", "1998");
-
- loop
- case
- GNAT.Command_Line.Getopt
- ("a aI: aO: d f g h I: nostdinc nostdlib p: u v -RTS= -ext=")
- is
- when ASCII.NUL =>
- exit;
-
- when 'a' =>
- if GNAT.Command_Line.Full_Switch = "a" then
- Read_Only := True;
-
- elsif GNAT.Command_Line.Full_Switch = "aI" then
- Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter);
-
- else
- Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
- end if;
-
- when 'd' =>
- Der_Info := True;
-
- when 'f' =>
- Full_Path_Name := True;
-
- when 'g' =>
- Local_Symbols := False;
-
- when 'h' =>
- Write_Usage;
-
- when 'I' =>
- Osint.Add_Src_Search_Dir (GNAT.Command_Line.Parameter);
- Osint.Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
-
- when 'n' =>
- if GNAT.Command_Line.Full_Switch = "nostdinc" then
- Opt.No_Stdinc := True;
- elsif GNAT.Command_Line.Full_Switch = "nostdlib" then
- Opt.No_Stdlib := True;
- end if;
-
- when 'p' =>
- declare
- S : constant String := GNAT.Command_Line.Parameter;
- begin
- Prj_File_Length := S'Length;
- Prj_File (1 .. Prj_File_Length) := S;
- end;
-
- when 'u' =>
- Search_Unused := True;
- Vi_Mode := False;
-
- when 'v' =>
- Vi_Mode := True;
- Search_Unused := False;
-
- -- The only switch starting with -- recognized is --RTS
-
- when '-' =>
-
- -- Check that it is the first time we see this switch
-
- if Full_Switch = "-RTS" then
- if RTS_Specified = null then
- RTS_Specified := new String'(GNAT.Command_Line.Parameter);
-
- elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then
- Osint.Fail ("--RTS cannot be specified multiple times");
- end if;
-
- Opt.No_Stdinc := True;
- Opt.RTS_Switch := True;
-
- declare
- Src_Path_Name : constant String_Ptr :=
- Get_RTS_Search_Dir
- (GNAT.Command_Line.Parameter,
- Include);
-
- Lib_Path_Name : constant String_Ptr :=
- Get_RTS_Search_Dir
- (GNAT.Command_Line.Parameter,
- Objects);
-
- begin
- if Src_Path_Name /= null
- and then Lib_Path_Name /= null
- then
- Add_Search_Dirs (Src_Path_Name, Include);
- Add_Search_Dirs (Lib_Path_Name, Objects);
-
- elsif Src_Path_Name = null
- and then Lib_Path_Name = null
- then
- Osint.Fail
- ("RTS path not valid: missing adainclude and "
- & "adalib directories");
-
- elsif Src_Path_Name = null then
- Osint.Fail
- ("RTS path not valid: missing adainclude directory");
-
- elsif Lib_Path_Name = null then
- Osint.Fail
- ("RTS path not valid: missing adalib directory");
- end if;
- end;
-
- elsif GNAT.Command_Line.Full_Switch = "-ext" then
-
- -- Check that it is the first time we see this switch
-
- if EXT_Specified = null then
- EXT_Specified := new String'(GNAT.Command_Line.Parameter);
-
- elsif EXT_Specified.all /= GNAT.Command_Line.Parameter then
- Osint.Fail ("--ext cannot be specified multiple times");
- end if;
-
- if EXT_Specified'Length = Osint.ALI_Default_Suffix'Length
- then
- Osint.ALI_Suffix := EXT_Specified.all'Access;
- else
- Osint.Fail ("--ext argument must have 3 characters");
- end if;
- end if;
-
- when others =>
- Try_Help;
- raise Usage_Error;
- end case;
- end loop;
-
- -- Get the other arguments
-
- loop
- declare
- S : constant String := GNAT.Command_Line.Get_Argument;
-
- begin
- exit when S'Length = 0;
-
- if Ada.Strings.Fixed.Index (S, ":") /= 0 then
- Ada.Text_IO.Put_Line
- ("Only file names are allowed on the command line");
- Try_Help;
- raise Usage_Error;
- end if;
-
- Add_Xref_File (S);
- Have_File := True;
- end;
- end loop;
-
- exception
- when GNAT.Command_Line.Invalid_Switch =>
- Ada.Text_IO.Put_Line ("Invalid switch : "
- & GNAT.Command_Line.Full_Switch);
- Try_Help;
- raise Usage_Error;
-
- when GNAT.Command_Line.Invalid_Parameter =>
- Ada.Text_IO.Put_Line ("Parameter missing for : "
- & GNAT.Command_Line.Full_Switch);
- Try_Help;
- raise Usage_Error;
- end Parse_Cmd_Line;
-
- -----------
- -- Usage --
- -----------
-
- procedure Usage is
- begin
- Put_Line ("Usage: gnatxref [switches] file1 file2 ...");
- New_Line;
- Put_Line (" file ... list of source files to xref, " &
- "including with'ed units");
- New_Line;
- Put_Line ("gnatxref switches:");
- Display_Usage_Version_And_Help;
- Put_Line (" -a Consider all files, even when the ali file is"
- & " readonly");
- Put_Line (" -aIdir Specify source files search path");
- Put_Line (" -aOdir Specify library/object files search path");
- Put_Line (" -d Output derived type information");
- Put_Line (" -f Output full path name");
- Put_Line (" -g Output information only for global symbols");
- Put_Line (" -Idir Like -aIdir -aOdir");
- Put_Line (" -nostdinc Don't look for sources in the system default"
- & " directory");
- Put_Line (" -nostdlib Don't look for library files in the system"
- & " default directory");
- Put_Line (" --ext=xxx Specify alternate ali file extension");
- Put_Line (" --RTS=dir specify the default source and object search"
- & " path");
- Put_Line (" -p file Use file as the configuration file");
- Put_Line (" -u List unused entities");
- Put_Line (" -v Print a 'tags' file for vi");
- New_Line;
-
- end Usage;
-
- -----------------
- -- Write_Usage --
- -----------------
-
- procedure Write_Usage is
- begin
- Display_Version ("GNATXREF", "1998");
- New_Line;
- Usage;
- raise Usage_Error;
- end Write_Usage;
-
-begin
- Put_Line
- ("WARNING: gnatxref is obsolete and will be removed in the next release");
- Put_Line
- ("Consider using Libadalang or GNAT Studio python scripting instead");
-
- Parse_Cmd_Line;
-
- if not Have_File then
- if Argument_Count = 0 then
- Write_Usage;
- else
- Try_Help;
- raise Usage_Error;
- end if;
- end if;
-
- Xr_Tabls.Set_Default_Match (True);
-
- -- Find the project file
-
- if Prj_File_Length = 0 then
- Xr_Tabls.Create_Project_File
- (Default_Project_File (Osint.To_Host_Dir_Spec (".", False).all));
- else
- Xr_Tabls.Create_Project_File (Prj_File (1 .. Prj_File_Length));
- end if;
-
- -- Fill up the table
-
- Search_Xref (Local_Symbols, Read_Only, Der_Info);
-
- if Search_Unused then
- Print_Unused (Full_Path_Name);
- elsif Vi_Mode then
- Print_Vi (Full_Path_Name);
- else
- Print_Xref (Full_Path_Name);
- end if;
-
-exception
- when Usage_Error =>
- null;
-end Gnatxref;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- X R _ T A B L S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2022, 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 3, 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 COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Types; use Types;
-with Osint;
-
-with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
-with Ada.Strings.Fixed;
-with Ada.Strings;
-with Ada.Text_IO;
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.HTable;
-with GNAT.Heap_Sort_G;
-
-package body Xr_Tabls is
-
- type HTable_Headers is range 1 .. 10000;
-
- procedure Set_Next (E : File_Reference; Next : File_Reference);
- function Next (E : File_Reference) return File_Reference;
- function Get_Key (E : File_Reference) return Cst_String_Access;
- function Hash (F : Cst_String_Access) return HTable_Headers;
- function Equal (F1, F2 : Cst_String_Access) return Boolean;
- -- The five subprograms above are used to instantiate the static
- -- htable to store the files that should be processed.
-
- package File_HTable is new GNAT.HTable.Static_HTable
- (Header_Num => HTable_Headers,
- Element => File_Record,
- Elmt_Ptr => File_Reference,
- Null_Ptr => null,
- Set_Next => Set_Next,
- Next => Next,
- Key => Cst_String_Access,
- Get_Key => Get_Key,
- Hash => Hash,
- Equal => Equal);
- -- A hash table to store all the files referenced in the
- -- application. The keys in this htable are the name of the files
- -- themselves, therefore it is assumed that the source path
- -- doesn't contain twice the same source or ALI file name
-
- type Unvisited_Files_Record;
- type Unvisited_Files_Access is access Unvisited_Files_Record;
- type Unvisited_Files_Record is record
- File : File_Reference;
- Next : Unvisited_Files_Access;
- end record;
- -- A special list, in addition to File_HTable, that only stores
- -- the files that haven't been visited so far. Note that the File
- -- list points to some data in File_HTable, and thus should never be freed.
-
- function Next (E : Declaration_Reference) return Declaration_Reference;
- procedure Set_Next (E, Next : Declaration_Reference);
- function Get_Key (E : Declaration_Reference) return Cst_String_Access;
- -- The subprograms above are used to instantiate the static
- -- htable to store the entities that have been found in the application
-
- package Entities_HTable is new GNAT.HTable.Static_HTable
- (Header_Num => HTable_Headers,
- Element => Declaration_Record,
- Elmt_Ptr => Declaration_Reference,
- Null_Ptr => null,
- Set_Next => Set_Next,
- Next => Next,
- Key => Cst_String_Access,
- Get_Key => Get_Key,
- Hash => Hash,
- Equal => Equal);
- -- A hash table to store all the entities defined in the
- -- application. For each entity, we store a list of its reference
- -- locations as well.
- -- The keys in this htable should be created with Key_From_Ref,
- -- and are the file, line and column of the declaration, which are
- -- unique for every entity.
-
- Entities_Count : Natural := 0;
- -- Number of entities in Entities_HTable. This is used in the end
- -- when sorting the table.
-
- Longest_File_Name_In_Table : Natural := 0;
- -- The length of the longest file name stored
-
- Unvisited_Files : Unvisited_Files_Access := null;
- -- Linked list of unvisited files
-
- Directories : Project_File_Ptr;
- -- Store the list of directories to visit
-
- Default_Match : Boolean := False;
- -- Default value for match in declarations
-
- function Parse_Gnatls_Src return String;
- -- Return the standard source directories (taking into account the
- -- ADA_INCLUDE_PATH environment variable, if Osint.Add_Default_Search_Dirs
- -- was called first).
-
- function Parse_Gnatls_Obj return String;
- -- Return the standard object directories (taking into account the
- -- ADA_OBJECTS_PATH environment variable).
-
- function Key_From_Ref
- (File_Ref : File_Reference;
- Line : Natural;
- Column : Natural)
- return String;
- -- Return a key for the symbol declared at File_Ref, Line,
- -- Column. This key should be used for lookup in Entity_HTable
-
- function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean;
- -- Compare two declarations (the comparison is case-insensitive)
-
- function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean;
- -- Compare two references
-
- procedure Store_References
- (Decl : Declaration_Reference;
- Get_Writes : Boolean := False;
- Get_Reads : Boolean := False;
- Get_Bodies : Boolean := False;
- Get_Declaration : Boolean := False;
- Arr : in out Reference_Array;
- Index : in out Natural);
- -- Store in Arr, starting at Index, all the references to Decl. The Get_*
- -- parameters can be used to indicate which references should be stored.
- -- Constraint_Error will be raised if Arr is not big enough.
-
- procedure Sort (Arr : in out Reference_Array);
- -- Sort an array of references (Arr'First must be 1)
-
- --------------
- -- Set_Next --
- --------------
-
- procedure Set_Next (E : File_Reference; Next : File_Reference) is
- begin
- E.Next := Next;
- end Set_Next;
-
- procedure Set_Next
- (E : Declaration_Reference; Next : Declaration_Reference) is
- begin
- E.Next := Next;
- end Set_Next;
-
- -------------
- -- Get_Key --
- -------------
-
- function Get_Key (E : File_Reference) return Cst_String_Access is
- begin
- return E.File;
- end Get_Key;
-
- function Get_Key (E : Declaration_Reference) return Cst_String_Access is
- begin
- return E.Key;
- end Get_Key;
-
- ----------
- -- Hash --
- ----------
-
- function Hash (F : Cst_String_Access) return HTable_Headers is
- function H is new GNAT.HTable.Hash (HTable_Headers);
-
- begin
- return H (F.all);
- end Hash;
-
- -----------
- -- Equal --
- -----------
-
- function Equal (F1, F2 : Cst_String_Access) return Boolean is
- begin
- return F1.all = F2.all;
- end Equal;
-
- ------------------
- -- Key_From_Ref --
- ------------------
-
- function Key_From_Ref
- (File_Ref : File_Reference;
- Line : Natural;
- Column : Natural)
- return String
- is
- begin
- return File_Ref.File.all & Natural'Image (Line) & Natural'Image (Column);
- end Key_From_Ref;
-
- ---------------------
- -- Add_Declaration --
- ---------------------
-
- function Add_Declaration
- (File_Ref : File_Reference;
- Symbol : String;
- Line : Natural;
- Column : Natural;
- Decl_Type : Character;
- Is_Parameter : Boolean := False;
- Remove_Only : Boolean := False;
- Symbol_Match : Boolean := True)
- return Declaration_Reference
- is
- procedure Unchecked_Free is new Ada.Unchecked_Deallocation
- (Declaration_Record, Declaration_Reference);
-
- Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
-
- New_Decl : Declaration_Reference :=
- Entities_HTable.Get (Key'Unchecked_Access);
-
- Is_Param : Boolean := Is_Parameter;
-
- begin
- -- Insert the Declaration in the table. There might already be a
- -- declaration in the table if the entity is a parameter, so we
- -- need to check that first.
-
- if New_Decl /= null and then New_Decl.Symbol_Length = 0 then
- Is_Param := Is_Parameter or else New_Decl.Is_Parameter;
- Entities_HTable.Remove (Key'Unrestricted_Access);
- Entities_Count := Entities_Count - 1;
- Free (New_Decl.Key);
- Unchecked_Free (New_Decl);
- New_Decl := null;
- end if;
-
- -- The declaration might also already be there for parent types. In
- -- this case, we should keep the entry, since some other entries are
- -- pointing to it.
-
- if New_Decl = null
- and then not Remove_Only
- then
- New_Decl :=
- new Declaration_Record'
- (Symbol_Length => Symbol'Length,
- Symbol => Symbol,
- Key => new String'(Key),
- Decl => new Reference_Record'
- (File => File_Ref,
- Line => Line,
- Column => Column,
- Source_Line => null,
- Next => null),
- Is_Parameter => Is_Param,
- Decl_Type => Decl_Type,
- Body_Ref => null,
- Ref_Ref => null,
- Modif_Ref => null,
- Match => Symbol_Match
- and then
- (Default_Match
- or else Match (File_Ref, Line, Column)),
- Par_Symbol => null,
- Next => null);
-
- Entities_HTable.Set (New_Decl);
- Entities_Count := Entities_Count + 1;
-
- if New_Decl.Match then
- Longest_File_Name_In_Table :=
- Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
- end if;
-
- elsif New_Decl /= null
- and then not New_Decl.Match
- then
- New_Decl.Match := Default_Match
- or else Match (File_Ref, Line, Column);
- New_Decl.Is_Parameter := New_Decl.Is_Parameter or Is_Param;
-
- elsif New_Decl /= null then
- New_Decl.Is_Parameter := New_Decl.Is_Parameter or Is_Param;
- end if;
-
- return New_Decl;
- end Add_Declaration;
-
- ----------------------
- -- Add_To_Xref_File --
- ----------------------
-
- function Add_To_Xref_File
- (File_Name : String;
- Visited : Boolean := True;
- Emit_Warning : Boolean := False;
- Gnatchop_File : String := "";
- Gnatchop_Offset : Integer := 0) return File_Reference
- is
- Base : aliased constant String := Base_Name (File_Name);
- Dir : constant String := Dir_Name (File_Name);
- Dir_Acc : GNAT.OS_Lib.String_Access := null;
- Ref : File_Reference;
-
- begin
- -- Do we have a directory name as well?
-
- if File_Name /= Base then
- Dir_Acc := new String'(Dir);
- end if;
-
- Ref := File_HTable.Get (Base'Unchecked_Access);
- if Ref = null then
- Ref := new File_Record'
- (File => new String'(Base),
- Dir => Dir_Acc,
- Lines => null,
- Visited => Visited,
- Emit_Warning => Emit_Warning,
- Gnatchop_File => new String'(Gnatchop_File),
- Gnatchop_Offset => Gnatchop_Offset,
- Next => null);
- File_HTable.Set (Ref);
-
- if not Visited then
-
- -- Keep a separate list for faster access
-
- Set_Unvisited (Ref);
- end if;
- end if;
- return Ref;
- end Add_To_Xref_File;
-
- --------------
- -- Add_Line --
- --------------
-
- procedure Add_Line
- (File : File_Reference;
- Line : Natural;
- Column : Natural)
- is
- begin
- File.Lines := new Ref_In_File'(Line => Line,
- Column => Column,
- Next => File.Lines);
- end Add_Line;
-
- ----------------
- -- Add_Parent --
- ----------------
-
- procedure Add_Parent
- (Declaration : in out Declaration_Reference;
- Symbol : String;
- Line : Natural;
- Column : Natural;
- File_Ref : File_Reference)
- is
- begin
- Declaration.Par_Symbol :=
- Add_Declaration
- (File_Ref, Symbol, Line, Column,
- Decl_Type => ' ',
- Symbol_Match => False);
- end Add_Parent;
-
- -------------------
- -- Add_Reference --
- -------------------
-
- procedure Add_Reference
- (Declaration : Declaration_Reference;
- File_Ref : File_Reference;
- Line : Natural;
- Column : Natural;
- Ref_Type : Character;
- Labels_As_Ref : Boolean)
- is
- New_Ref : Reference;
- New_Decl : Declaration_Reference;
- pragma Unreferenced (New_Decl);
-
- begin
- case Ref_Type is
- when ' ' | 'b' | 'c' | 'H' | 'i' | 'm' | 'o' | 'r' | 'R' | 's' | 'x'
- =>
- null;
-
- when 'l' | 'w' =>
- if not Labels_As_Ref then
- return;
- end if;
-
- when '=' | '<' | '>' | '^' =>
-
- -- Create dummy declaration in table to report it as a parameter
-
- -- In a given ALI file, the declaration of the subprogram comes
- -- before the declaration of the parameter. However, it is
- -- possible that another ALI file has been parsed that also
- -- references the parameter (for instance a named parameter in
- -- a call), so we need to check whether there already exists a
- -- declaration for the parameter.
-
- New_Decl :=
- Add_Declaration
- (File_Ref => File_Ref,
- Symbol => "",
- Line => Line,
- Column => Column,
- Decl_Type => ' ',
- Is_Parameter => True);
-
- when 'd' | 'e' | 'E' | 'k' | 'p' | 'P' | 't' | 'z' =>
- return;
-
- when others =>
- Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type);
- return;
- end case;
-
- New_Ref := new Reference_Record'
- (File => File_Ref,
- Line => Line,
- Column => Column,
- Source_Line => null,
- Next => null);
-
- -- We can insert the reference into the list directly, since all the
- -- references will appear only once in the ALI file corresponding to the
- -- file where they are referenced. This saves a lot of time compared to
- -- checking the list to check if it exists.
-
- case Ref_Type is
- when 'b' | 'c' =>
- New_Ref.Next := Declaration.Body_Ref;
- Declaration.Body_Ref := New_Ref;
-
- when ' ' | 'H' | 'i' | 'l' | 'o' | 'r' | 'R' | 's' | 'w' | 'x' =>
- New_Ref.Next := Declaration.Ref_Ref;
- Declaration.Ref_Ref := New_Ref;
-
- when 'm' =>
- New_Ref.Next := Declaration.Modif_Ref;
- Declaration.Modif_Ref := New_Ref;
-
- when others =>
- null;
- end case;
-
- if not Declaration.Match then
- Declaration.Match := Match (File_Ref, Line, Column);
- end if;
-
- if Declaration.Match then
- Longest_File_Name_In_Table :=
- Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
- end if;
- end Add_Reference;
-
- -------------------
- -- ALI_File_Name --
- -------------------
-
- function ALI_File_Name (Ada_File_Name : String) return String is
- -- Should ideally be based on the naming scheme defined in
- -- project files but this is too late for an obsolescent feature.
-
- Index : constant Natural :=
- Ada.Strings.Fixed.Index
- (Ada_File_Name, ".", Going => Ada.Strings.Backward);
-
- begin
- if Index /= 0 then
- return Ada_File_Name (Ada_File_Name'First .. Index)
- & Osint.ALI_Suffix.all;
- else
- return Ada_File_Name & "." & Osint.ALI_Suffix.all;
- end if;
- end ALI_File_Name;
-
- ------------------
- -- Is_Less_Than --
- ------------------
-
- function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean is
- begin
- if Ref1 = null then
- return False;
- elsif Ref2 = null then
- return True;
- end if;
-
- if Ref1.File.File.all < Ref2.File.File.all then
- return True;
-
- elsif Ref1.File.File.all = Ref2.File.File.all then
- return (Ref1.Line < Ref2.Line
- or else (Ref1.Line = Ref2.Line
- and then Ref1.Column < Ref2.Column));
- end if;
-
- return False;
- end Is_Less_Than;
-
- ------------------
- -- Is_Less_Than --
- ------------------
-
- function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean
- is
- -- We cannot store the data case-insensitive in the table,
- -- since we wouldn't be able to find the right casing for the
- -- display later on.
-
- S1 : constant String := To_Lower (Decl1.Symbol);
- S2 : constant String := To_Lower (Decl2.Symbol);
-
- begin
- if S1 < S2 then
- return True;
- elsif S1 > S2 then
- return False;
- end if;
-
- return Decl1.Key.all < Decl2.Key.all;
- end Is_Less_Than;
-
- -------------------------
- -- Create_Project_File --
- -------------------------
-
- procedure Create_Project_File (Name : String) is
- Obj_Dir : Unbounded_String := Null_Unbounded_String;
- Src_Dir : Unbounded_String := Null_Unbounded_String;
- Build_Dir : GNAT.OS_Lib.String_Access := new String'("");
-
- F : File_Descriptor;
- Len : Positive;
- File_Name : aliased String := Name & ASCII.NUL;
-
- begin
- -- Read the size of the file
-
- F := Open_Read (File_Name'Address, Text);
-
- -- Project file not found
-
- if F /= Invalid_FD then
- Len := Positive (File_Length (F));
-
- declare
- Buffer : String (1 .. Len);
- Index : Positive := Buffer'First;
- Last : Positive;
-
- begin
- Len := Read (F, Buffer'Address, Len);
- Close (F);
-
- -- First, look for Build_Dir, since all the source and object
- -- path are relative to it.
-
- while Index <= Buffer'Last loop
-
- -- Find the end of line
-
- Last := Index;
- while Last <= Buffer'Last
- and then Buffer (Last) /= ASCII.LF
- and then Buffer (Last) /= ASCII.CR
- loop
- Last := Last + 1;
- end loop;
-
- if Index <= Buffer'Last - 9
- and then Buffer (Index .. Index + 9) = "build_dir="
- then
- Index := Index + 10;
- while Index <= Last
- and then (Buffer (Index) = ' '
- or else Buffer (Index) = ASCII.HT)
- loop
- Index := Index + 1;
- end loop;
-
- Free (Build_Dir);
- Build_Dir := new String'(Buffer (Index .. Last - 1));
- end if;
-
- Index := Last + 1;
-
- -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
- -- remaining symbol
-
- if Index <= Buffer'Last
- and then Buffer (Index) = ASCII.LF
- then
- Index := Index + 1;
- end if;
- end loop;
-
- -- Now parse the source and object paths
-
- Index := Buffer'First;
- while Index <= Buffer'Last loop
-
- -- Find the end of line
-
- Last := Index;
- while Last <= Buffer'Last
- and then Buffer (Last) /= ASCII.LF
- and then Buffer (Last) /= ASCII.CR
- loop
- Last := Last + 1;
- end loop;
-
- if Index <= Buffer'Last - 7
- and then Buffer (Index .. Index + 7) = "src_dir="
- then
- Append (Src_Dir, Normalize_Pathname
- (Name => Ada.Strings.Fixed.Trim
- (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
- Directory => Build_Dir.all) & Path_Separator);
-
- elsif Index <= Buffer'Last - 7
- and then Buffer (Index .. Index + 7) = "obj_dir="
- then
- Append (Obj_Dir, Normalize_Pathname
- (Name => Ada.Strings.Fixed.Trim
- (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
- Directory => Build_Dir.all) & Path_Separator);
- end if;
-
- -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
- -- remaining symbol
- Index := Last + 1;
-
- if Index <= Buffer'Last
- and then Buffer (Index) = ASCII.LF
- then
- Index := Index + 1;
- end if;
- end loop;
- end;
- end if;
-
- Osint.Add_Default_Search_Dirs;
-
- declare
- Src : constant String := Parse_Gnatls_Src;
- Obj : constant String := Parse_Gnatls_Obj;
-
- begin
- Directories := new Project_File'
- (Src_Dir_Length => Length (Src_Dir) + Src'Length,
- Obj_Dir_Length => Length (Obj_Dir) + Obj'Length,
- Src_Dir => To_String (Src_Dir) & Src,
- Obj_Dir => To_String (Obj_Dir) & Obj,
- Src_Dir_Index => 1,
- Obj_Dir_Index => 1,
- Last_Obj_Dir_Start => 0);
- end;
-
- Free (Build_Dir);
- end Create_Project_File;
-
- ---------------------
- -- Current_Obj_Dir --
- ---------------------
-
- function Current_Obj_Dir return String is
- begin
- return Directories.Obj_Dir
- (Directories.Last_Obj_Dir_Start .. Directories.Obj_Dir_Index - 2);
- end Current_Obj_Dir;
-
- ----------------
- -- Get_Column --
- ----------------
-
- function Get_Column (Decl : Declaration_Reference) return String is
- begin
- return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Column),
- Ada.Strings.Left);
- end Get_Column;
-
- function Get_Column (Ref : Reference) return String is
- begin
- return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Column),
- Ada.Strings.Left);
- end Get_Column;
-
- ---------------------
- -- Get_Declaration --
- ---------------------
-
- function Get_Declaration
- (File_Ref : File_Reference;
- Line : Natural;
- Column : Natural)
- return Declaration_Reference
- is
- Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
-
- begin
- return Entities_HTable.Get (Key'Unchecked_Access);
- end Get_Declaration;
-
- ----------------------
- -- Get_Emit_Warning --
- ----------------------
-
- function Get_Emit_Warning (File : File_Reference) return Boolean is
- begin
- return File.Emit_Warning;
- end Get_Emit_Warning;
-
- --------------
- -- Get_File --
- --------------
-
- function Get_File
- (Decl : Declaration_Reference;
- With_Dir : Boolean := False) return String
- is
- begin
- return Get_File (Decl.Decl.File, With_Dir);
- end Get_File;
-
- function Get_File
- (Ref : Reference;
- With_Dir : Boolean := False) return String
- is
- begin
- return Get_File (Ref.File, With_Dir);
- end Get_File;
-
- function Get_File
- (File : File_Reference;
- With_Dir : Boolean := False;
- Strip : Natural := 0) return String
- is
- pragma Annotate (CodePeer, Skip_Analysis);
- -- Disable CodePeer false positives
-
- Tmp : GNAT.OS_Lib.String_Access;
-
- function Internal_Strip (Full_Name : String) return String;
- -- Internal function to process the Strip parameter
-
- --------------------
- -- Internal_Strip --
- --------------------
-
- function Internal_Strip (Full_Name : String) return String is
- Unit_End : Natural;
- Extension_Start : Natural;
- S : Natural;
-
- begin
- if Strip = 0 then
- return Full_Name;
- end if;
-
- -- Isolate the file extension
-
- Extension_Start := Full_Name'Last;
- while Extension_Start >= Full_Name'First
- and then Full_Name (Extension_Start) /= '.'
- loop
- Extension_Start := Extension_Start - 1;
- end loop;
-
- -- Strip the right number of subunit_names
-
- S := Strip;
- Unit_End := Extension_Start - 1;
- while Unit_End >= Full_Name'First
- and then S > 0
- loop
- if Full_Name (Unit_End) = '-' then
- S := S - 1;
- end if;
-
- Unit_End := Unit_End - 1;
- end loop;
-
- if Unit_End < Full_Name'First then
- return "";
- else
- return Full_Name (Full_Name'First .. Unit_End)
- & Full_Name (Extension_Start .. Full_Name'Last);
- end if;
- end Internal_Strip;
-
- -- Start of processing for Get_File
-
- begin
- -- If we do not want the full path name
-
- if not With_Dir then
- return Internal_Strip (File.File.all);
- end if;
-
- if File.Dir = null then
- if Ada.Strings.Fixed.Tail (File.File.all, 3) =
- Osint.ALI_Suffix.all
- then
- Tmp := Locate_Regular_File
- (Internal_Strip (File.File.all), Directories.Obj_Dir);
- else
- Tmp := Locate_Regular_File
- (File.File.all, Directories.Src_Dir);
- end if;
-
- if Tmp = null then
- File.Dir := new String'("");
- else
- File.Dir := new String'(Dir_Name (Tmp.all));
- Free (Tmp);
- end if;
- end if;
-
- return Internal_Strip (File.Dir.all & File.File.all);
- end Get_File;
-
- ------------------
- -- Get_File_Ref --
- ------------------
-
- function Get_File_Ref (Ref : Reference) return File_Reference is
- begin
- return Ref.File;
- end Get_File_Ref;
-
- -----------------------
- -- Get_Gnatchop_File --
- -----------------------
-
- function Get_Gnatchop_File
- (File : File_Reference;
- With_Dir : Boolean := False)
- return String
- is
- begin
- if File.Gnatchop_File.all = "" then
- return Get_File (File, With_Dir);
- else
- return File.Gnatchop_File.all;
- end if;
- end Get_Gnatchop_File;
-
- function Get_Gnatchop_File
- (Ref : Reference;
- With_Dir : Boolean := False)
- return String
- is
- begin
- return Get_Gnatchop_File (Ref.File, With_Dir);
- end Get_Gnatchop_File;
-
- function Get_Gnatchop_File
- (Decl : Declaration_Reference;
- With_Dir : Boolean := False)
- return String
- is
- begin
- return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
- end Get_Gnatchop_File;
-
- --------------
- -- Get_Line --
- --------------
-
- function Get_Line (Decl : Declaration_Reference) return String is
- begin
- return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line),
- Ada.Strings.Left);
- end Get_Line;
-
- function Get_Line (Ref : Reference) return String is
- begin
- return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line),
- Ada.Strings.Left);
- end Get_Line;
-
- ----------------
- -- Get_Parent --
- ----------------
-
- function Get_Parent
- (Decl : Declaration_Reference)
- return Declaration_Reference
- is
- begin
- return Decl.Par_Symbol;
- end Get_Parent;
-
- ---------------------
- -- Get_Source_Line --
- ---------------------
-
- function Get_Source_Line (Ref : Reference) return String is
- begin
- if Ref.Source_Line /= null then
- return Ref.Source_Line.all;
- else
- return "";
- end if;
- end Get_Source_Line;
-
- function Get_Source_Line (Decl : Declaration_Reference) return String is
- begin
- if Decl.Decl.Source_Line /= null then
- return Decl.Decl.Source_Line.all;
- else
- return "";
- end if;
- end Get_Source_Line;
-
- ----------------
- -- Get_Symbol --
- ----------------
-
- function Get_Symbol (Decl : Declaration_Reference) return String is
- begin
- return Decl.Symbol;
- end Get_Symbol;
-
- --------------
- -- Get_Type --
- --------------
-
- function Get_Type (Decl : Declaration_Reference) return Character is
- begin
- return Decl.Decl_Type;
- end Get_Type;
-
- ----------
- -- Sort --
- ----------
-
- procedure Sort (Arr : in out Reference_Array) is
- Tmp : Reference;
-
- function Lt (Op1, Op2 : Natural) return Boolean;
- procedure Move (From, To : Natural);
- -- See GNAT.Heap_Sort_G
-
- --------
- -- Lt --
- --------
-
- function Lt (Op1, Op2 : Natural) return Boolean is
- begin
- if Op1 = 0 then
- return Is_Less_Than (Tmp, Arr (Op2));
- elsif Op2 = 0 then
- return Is_Less_Than (Arr (Op1), Tmp);
- else
- return Is_Less_Than (Arr (Op1), Arr (Op2));
- end if;
- end Lt;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (From, To : Natural) is
- begin
- if To = 0 then
- Tmp := Arr (From);
- elsif From = 0 then
- Arr (To) := Tmp;
- else
- Arr (To) := Arr (From);
- end if;
- end Move;
-
- package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt);
-
- -- Start of processing for Sort
-
- begin
- Ref_Sort.Sort (Arr'Last);
- end Sort;
-
- -----------------------
- -- Grep_Source_Files --
- -----------------------
-
- procedure Grep_Source_Files is
- Length : Natural := 0;
- Decl : Declaration_Reference := Entities_HTable.Get_First;
- Arr : Reference_Array_Access;
- Index : Natural;
- End_Index : Natural := 0;
- Current_File : File_Reference;
- Current_Line : Cst_String_Access;
- Buffer : GNAT.OS_Lib.String_Access;
- Ref : Reference;
- Line : Natural := Natural'Last;
-
- begin
- -- Create a temporary array, where all references will be
- -- sorted by files. This way, we only have to read the source
- -- files once.
-
- while Decl /= null loop
-
- -- Add 1 for the declaration itself
-
- Length := Length + References_Count (Decl, True, True, True) + 1;
- Decl := Entities_HTable.Get_Next;
- end loop;
-
- Arr := new Reference_Array (1 .. Length);
- Index := Arr'First;
-
- Decl := Entities_HTable.Get_First;
- while Decl /= null loop
- Store_References (Decl, True, True, True, True, Arr.all, Index);
- Decl := Entities_HTable.Get_Next;
- end loop;
-
- Sort (Arr.all);
-
- -- Now traverse the whole array and find the appropriate source
- -- lines.
-
- for R in Arr'Range loop
- Ref := Arr (R);
-
- if Ref.File /= Current_File then
- Free (Buffer);
- begin
- Read_File (Get_File (Ref.File, With_Dir => True), Buffer);
- End_Index := Buffer'First - 1;
- Line := 0;
- exception
- when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
- Line := Natural'Last;
- end;
- Current_File := Ref.File;
- end if;
-
- if Ref.Line > Line then
-
- -- Do not free Current_Line, it is referenced by the last
- -- Ref we processed.
-
- loop
- Index := End_Index + 1;
-
- loop
- End_Index := End_Index + 1;
- exit when End_Index > Buffer'Last
- or else Buffer (End_Index) = ASCII.LF;
- end loop;
-
- -- Skip spaces at beginning of line
-
- while Index < End_Index and then
- (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT)
- loop
- Index := Index + 1;
- end loop;
-
- Line := Line + 1;
- exit when Ref.Line = Line;
- end loop;
-
- Current_Line := new String'(Buffer (Index .. End_Index - 1));
- end if;
-
- Ref.Source_Line := Current_Line;
- end loop;
-
- Free (Buffer);
- Free (Arr);
- end Grep_Source_Files;
-
- ---------------
- -- Read_File --
- ---------------
-
- procedure Read_File
- (File_Name : String;
- Contents : out GNAT.OS_Lib.String_Access)
- is
- Name_0 : constant String := File_Name & ASCII.NUL;
- FD : constant File_Descriptor := Open_Read (Name_0'Address, Binary);
- Length : Natural;
-
- begin
- if FD = Invalid_FD then
- raise Ada.Text_IO.Name_Error;
- end if;
-
- -- Include room for EOF char
-
- Length := Natural (File_Length (FD));
-
- declare
- Buffer : String (1 .. Length + 1);
- This_Read : Integer;
- Read_Ptr : Natural := 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));
-
- if Read_Ptr /= Length + 1 then
- raise Ada.Text_IO.End_Error;
- end if;
-
- Close (FD);
- end;
- end Read_File;
-
- -----------------------
- -- Longest_File_Name --
- -----------------------
-
- function Longest_File_Name return Natural is
- begin
- return Longest_File_Name_In_Table;
- end Longest_File_Name;
-
- -----------
- -- Match --
- -----------
-
- function Match
- (File : File_Reference;
- Line : Natural;
- Column : Natural)
- return Boolean
- is
- Ref : Ref_In_File_Ptr := File.Lines;
-
- begin
- while Ref /= null loop
- if (Ref.Line = 0 or else Ref.Line = Line)
- and then (Ref.Column = 0 or else Ref.Column = Column)
- then
- return True;
- end if;
-
- Ref := Ref.Next;
- end loop;
-
- return False;
- end Match;
-
- -----------
- -- Match --
- -----------
-
- function Match (Decl : Declaration_Reference) return Boolean is
- begin
- return Decl.Match;
- end Match;
-
- ----------
- -- Next --
- ----------
-
- function Next (E : File_Reference) return File_Reference is
- begin
- return E.Next;
- end Next;
-
- function Next (E : Declaration_Reference) return Declaration_Reference is
- begin
- return E.Next;
- end Next;
-
- ------------------
- -- Next_Obj_Dir --
- ------------------
-
- function Next_Obj_Dir return String is
- First : constant Integer := Directories.Obj_Dir_Index;
- Last : Integer;
-
- begin
- Last := Directories.Obj_Dir_Index;
-
- if Last > Directories.Obj_Dir_Length then
- return String'(1 .. 0 => ' ');
- end if;
-
- while Directories.Obj_Dir (Last) /= Path_Separator loop
- Last := Last + 1;
- end loop;
-
- Directories.Obj_Dir_Index := Last + 1;
- Directories.Last_Obj_Dir_Start := First;
- return Directories.Obj_Dir (First .. Last - 1);
- end Next_Obj_Dir;
-
- -------------------------
- -- Next_Unvisited_File --
- -------------------------
-
- function Next_Unvisited_File return File_Reference is
- procedure Unchecked_Free is new Ada.Unchecked_Deallocation
- (Unvisited_Files_Record, Unvisited_Files_Access);
-
- Ref : File_Reference;
- Tmp : Unvisited_Files_Access;
-
- begin
- if Unvisited_Files = null then
- return Empty_File;
- else
- Tmp := Unvisited_Files;
- Ref := Unvisited_Files.File;
- Unvisited_Files := Unvisited_Files.Next;
- Unchecked_Free (Tmp);
- return Ref;
- end if;
- end Next_Unvisited_File;
-
- ----------------------
- -- Parse_Gnatls_Src --
- ----------------------
-
- function Parse_Gnatls_Src return String is
- Length : Natural;
-
- begin
- Length := 0;
- for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
- if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
- Length := Length + 2;
- else
- Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1;
- end if;
- end loop;
-
- declare
- Result : String (1 .. Length);
- L : Natural;
-
- begin
- L := Result'First;
- for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
- if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
- Result (L .. L + 1) := "." & Path_Separator;
- L := L + 2;
-
- else
- Result (L .. L + Osint.Dir_In_Src_Search_Path (J)'Length - 1) :=
- Osint.Dir_In_Src_Search_Path (J).all;
- L := L + Osint.Dir_In_Src_Search_Path (J)'Length;
- Result (L) := Path_Separator;
- L := L + 1;
- end if;
- end loop;
-
- return Result;
- end;
- end Parse_Gnatls_Src;
-
- ----------------------
- -- Parse_Gnatls_Obj --
- ----------------------
-
- function Parse_Gnatls_Obj return String is
- Length : Natural;
-
- begin
- Length := 0;
- for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
- if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
- Length := Length + 2;
- else
- Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1;
- end if;
- end loop;
-
- declare
- Result : String (1 .. Length);
- L : Natural;
-
- begin
- L := Result'First;
- for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
- if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
- Result (L .. L + 1) := "." & Path_Separator;
- L := L + 2;
- else
- Result (L .. L + Osint.Dir_In_Obj_Search_Path (J)'Length - 1) :=
- Osint.Dir_In_Obj_Search_Path (J).all;
- L := L + Osint.Dir_In_Obj_Search_Path (J)'Length;
- Result (L) := Path_Separator;
- L := L + 1;
- end if;
- end loop;
-
- return Result;
- end;
- end Parse_Gnatls_Obj;
-
- -------------------
- -- Reset_Obj_Dir --
- -------------------
-
- procedure Reset_Obj_Dir is
- begin
- Directories.Obj_Dir_Index := 1;
- end Reset_Obj_Dir;
-
- -----------------------
- -- Set_Default_Match --
- -----------------------
-
- procedure Set_Default_Match (Value : Boolean) is
- begin
- Default_Match := Value;
- end Set_Default_Match;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Str : in out Cst_String_Access) is
- function Convert is new Ada.Unchecked_Conversion
- (Cst_String_Access, GNAT.OS_Lib.String_Access);
-
- S : GNAT.OS_Lib.String_Access := Convert (Str);
-
- begin
- Free (S);
- Str := null;
- end Free;
-
- ---------------------
- -- Reset_Directory --
- ---------------------
-
- procedure Reset_Directory (File : File_Reference) is
- begin
- Free (File.Dir);
- end Reset_Directory;
-
- -------------------
- -- Set_Unvisited --
- -------------------
-
- procedure Set_Unvisited (File_Ref : File_Reference) is
- F : constant String := Get_File (File_Ref, With_Dir => False);
-
- begin
- File_Ref.Visited := False;
-
- -- Do not add a source file to the list. This is true for gnatxref
- -- gnatfind, so good enough.
-
- if F'Length > 4
- and then F (F'Last - 3 .. F'Last) = "." & Osint.ALI_Suffix.all
- then
- Unvisited_Files := new Unvisited_Files_Record'
- (File => File_Ref,
- Next => Unvisited_Files);
- end if;
- end Set_Unvisited;
-
- ----------------------
- -- Get_Declarations --
- ----------------------
-
- function Get_Declarations
- (Sorted : Boolean := True)
- return Declaration_Array_Access
- is
- Arr : constant Declaration_Array_Access :=
- new Declaration_Array (1 .. Entities_Count);
- Decl : Declaration_Reference := Entities_HTable.Get_First;
- Index : Natural := Arr'First;
- Tmp : Declaration_Reference;
-
- procedure Move (From : Natural; To : Natural);
- function Lt (Op1, Op2 : Natural) return Boolean;
- -- See GNAT.Heap_Sort_G
-
- --------
- -- Lt --
- --------
-
- function Lt (Op1, Op2 : Natural) return Boolean is
- begin
- if Op1 = 0 then
- return Is_Less_Than (Tmp, Arr (Op2));
- elsif Op2 = 0 then
- return Is_Less_Than (Arr (Op1), Tmp);
- else
- return Is_Less_Than (Arr (Op1), Arr (Op2));
- end if;
- end Lt;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (From : Natural; To : Natural) is
- begin
- if To = 0 then
- Tmp := Arr (From);
- elsif From = 0 then
- Arr (To) := Tmp;
- else
- Arr (To) := Arr (From);
- end if;
- end Move;
-
- package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt);
-
- -- Start of processing for Get_Declarations
-
- begin
- while Decl /= null loop
- Arr (Index) := Decl;
- Index := Index + 1;
- Decl := Entities_HTable.Get_Next;
- end loop;
-
- if Sorted and then Arr'Length /= 0 then
- Decl_Sort.Sort (Entities_Count);
- end if;
-
- return Arr;
- end Get_Declarations;
-
- ----------------------
- -- References_Count --
- ----------------------
-
- function References_Count
- (Decl : Declaration_Reference;
- Get_Reads : Boolean := False;
- Get_Writes : Boolean := False;
- Get_Bodies : Boolean := False)
- return Natural
- is
- function List_Length (E : Reference) return Natural;
- -- Return the number of references in E
-
- -----------------
- -- List_Length --
- -----------------
-
- function List_Length (E : Reference) return Natural is
- L : Natural := 0;
- E1 : Reference := E;
-
- begin
- while E1 /= null loop
- L := L + 1;
- E1 := E1.Next;
- end loop;
-
- return L;
- end List_Length;
-
- Length : Natural := 0;
-
- -- Start of processing for References_Count
-
- begin
- if Get_Reads then
- Length := List_Length (Decl.Ref_Ref);
- end if;
-
- if Get_Writes then
- Length := Length + List_Length (Decl.Modif_Ref);
- end if;
-
- if Get_Bodies then
- Length := Length + List_Length (Decl.Body_Ref);
- end if;
-
- return Length;
- end References_Count;
-
- ----------------------
- -- Store_References --
- ----------------------
-
- procedure Store_References
- (Decl : Declaration_Reference;
- Get_Writes : Boolean := False;
- Get_Reads : Boolean := False;
- Get_Bodies : Boolean := False;
- Get_Declaration : Boolean := False;
- Arr : in out Reference_Array;
- Index : in out Natural)
- is
- procedure Add (List : Reference);
- -- Add all the references in List to Arr
-
- ---------
- -- Add --
- ---------
-
- procedure Add (List : Reference) is
- E : Reference := List;
- begin
- while E /= null loop
- Arr (Index) := E;
- Index := Index + 1;
- E := E.Next;
- end loop;
- end Add;
-
- -- Start of processing for Store_References
-
- begin
- if Get_Declaration then
- Add (Decl.Decl);
- end if;
-
- if Get_Reads then
- Add (Decl.Ref_Ref);
- end if;
-
- if Get_Writes then
- Add (Decl.Modif_Ref);
- end if;
-
- if Get_Bodies then
- Add (Decl.Body_Ref);
- end if;
- end Store_References;
-
- --------------------
- -- Get_References --
- --------------------
-
- function Get_References
- (Decl : Declaration_Reference;
- Get_Reads : Boolean := False;
- Get_Writes : Boolean := False;
- Get_Bodies : Boolean := False)
- return Reference_Array_Access
- is
- Length : constant Natural :=
- References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies);
-
- Arr : constant Reference_Array_Access :=
- new Reference_Array (1 .. Length);
-
- Index : Natural := Arr'First;
-
- begin
- Store_References
- (Decl => Decl,
- Get_Writes => Get_Writes,
- Get_Reads => Get_Reads,
- Get_Bodies => Get_Bodies,
- Get_Declaration => False,
- Arr => Arr.all,
- Index => Index);
-
- if Arr'Length /= 0 then
- Sort (Arr.all);
- end if;
-
- return Arr;
- end Get_References;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Arr : in out Reference_Array_Access) is
- procedure Internal is new Ada.Unchecked_Deallocation
- (Reference_Array, Reference_Array_Access);
- begin
- Internal (Arr);
- end Free;
-
- ------------------
- -- Is_Parameter --
- ------------------
-
- function Is_Parameter (Decl : Declaration_Reference) return Boolean is
- begin
- return Decl.Is_Parameter;
- end Is_Parameter;
-
-end Xr_Tabls;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- X R _ T A B L S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-2022, 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 3, 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 COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Cross reference utilities used by gnatxref and gnatfind
-
-with GNAT.OS_Lib;
-
-package Xr_Tabls is
-
- -------------------
- -- Project files --
- -------------------
-
- function ALI_File_Name (Ada_File_Name : String) return String;
- -- Returns the ali file name corresponding to Ada_File_Name
-
- procedure Create_Project_File (Name : String);
- -- Open and parse a new project file. If the file Name could not be
- -- opened or is not a valid project file, then a project file associated
- -- with the standard default directories is returned
-
- function Next_Obj_Dir return String;
- -- Returns the next directory to visit to find related ali files
- -- If there are no more such directories, returns a null string.
-
- function Current_Obj_Dir return String;
- -- Returns the obj_dir which was returned by the last Next_Obj_Dir call
-
- procedure Reset_Obj_Dir;
- -- Reset the iterator for Obj_Dir
-
- ------------
- -- Tables --
- ------------
-
- type Declaration_Reference is private;
- Empty_Declaration : constant Declaration_Reference;
-
- type Declaration_Array is array (Natural range <>) of Declaration_Reference;
- type Declaration_Array_Access is access Declaration_Array;
-
- type File_Reference is private;
- Empty_File : constant File_Reference;
-
- type Reference is private;
- Empty_Reference : constant Reference;
-
- type Reference_Array is array (Natural range <>) of Reference;
- type Reference_Array_Access is access Reference_Array;
-
- procedure Free (Arr : in out Reference_Array_Access);
-
- function Add_Declaration
- (File_Ref : File_Reference;
- Symbol : String;
- Line : Natural;
- Column : Natural;
- Decl_Type : Character;
- Is_Parameter : Boolean := False;
- Remove_Only : Boolean := False;
- Symbol_Match : Boolean := True)
- return Declaration_Reference;
- -- Add a new declaration in the table and return the index to it. Decl_Type
- -- is the type of the entity Any previous instance of this entity in the
- -- htable is removed. If Remove_Only is True, then any previous instance is
- -- removed, but the new entity is never inserted. Symbol_Match should be
- -- set to False if the name of the symbol doesn't match the pattern from
- -- the command line. In that case, the entity will not be output by
- -- gnatfind. If Symbol_Match is True, the entity will only be output if
- -- the file name itself matches. Is_Parameter should be set to True if
- -- the entity is known to be a subprogram parameter.
-
- procedure Add_Parent
- (Declaration : in out Declaration_Reference;
- Symbol : String;
- Line : Natural;
- Column : Natural;
- File_Ref : File_Reference);
- -- The parent declaration (Symbol in file File_Ref at position Line and
- -- Column) information is added to Declaration.
-
- function Add_To_Xref_File
- (File_Name : String;
- Visited : Boolean := True;
- Emit_Warning : Boolean := False;
- Gnatchop_File : String := "";
- Gnatchop_Offset : Integer := 0)
- return File_Reference;
- -- Add a new reference to a file in the table. Ref is used to return the
- -- index in the table where this file is stored. Visited is the value which
- -- will be used in the table (if True, the file will not be returned by
- -- Next_Unvisited_File). If Emit_Warning is True and the ali file does
- -- not exist or does not have cross-referencing information, then a
- -- warning will be emitted. Gnatchop_File is the name of the file that
- -- File_Name was extracted from through a call to "gnatchop -r" (using
- -- pragma Source_Reference). Gnatchop_Offset should be the index of the
- -- first line of File_Name within the Gnatchop_File.
-
- procedure Add_Line
- (File : File_Reference;
- Line : Natural;
- Column : Natural);
- -- Add a new reference in a file, which the user has provided on the
- -- command line. This is used for an optimized matching algorithm.
-
- procedure Add_Reference
- (Declaration : Declaration_Reference;
- File_Ref : File_Reference;
- Line : Natural;
- Column : Natural;
- Ref_Type : Character;
- Labels_As_Ref : Boolean);
- -- Add a new reference (Ref_Type = 'r'), body (Ref_Type = 'b') or
- -- modification (Ref_Type = 'm') to an entity. If Labels_As_Ref is True,
- -- then the references to the entity after the end statements ("end Foo")
- -- are counted as actual references. This means that the entity will never
- -- be reported as unreferenced (for instance in the case of gnatxref -u).
-
- function Get_Declarations
- (Sorted : Boolean := True)
- return Declaration_Array_Access;
- -- Return a sorted list of all the declarations in the application.
- -- Freeing this array is the responsibility of the caller, however it
- -- shouldn't free the actual contents of the array, which are pointers
- -- to internal data
-
- function References_Count
- (Decl : Declaration_Reference;
- Get_Reads : Boolean := False;
- Get_Writes : Boolean := False;
- Get_Bodies : Boolean := False)
- return Natural;
- -- Return the number of references in Decl for the categories specified
- -- by the Get_* parameters (read-only accesses, write accesses and bodies)
-
- function Get_References
- (Decl : Declaration_Reference;
- Get_Reads : Boolean := False;
- Get_Writes : Boolean := False;
- Get_Bodies : Boolean := False)
- return Reference_Array_Access;
- -- Return a sorted list of all references to the entity in decl. The
- -- parameters Get_* are used to specify what kind of references should be
- -- merged and returned (read-only accesses, write accesses and bodies).
-
- function Get_Column (Decl : Declaration_Reference) return String;
- function Get_Column (Ref : Reference) return String;
-
- function Get_Declaration
- (File_Ref : File_Reference;
- Line : Natural;
- Column : Natural)
- return Declaration_Reference;
- -- Returns reference to the declaration found in file File_Ref at the
- -- given Line and Column
-
- function Get_Parent
- (Decl : Declaration_Reference)
- return Declaration_Reference;
- -- Returns reference to Decl's parent declaration
-
- function Get_Emit_Warning (File : File_Reference) return Boolean;
- -- Returns the Emit_Warning field of the structure
-
- function Get_Gnatchop_File
- (File : File_Reference;
- With_Dir : Boolean := False)
- return String;
- function Get_Gnatchop_File
- (Ref : Reference;
- With_Dir : Boolean := False)
- return String;
- function Get_Gnatchop_File
- (Decl : Declaration_Reference;
- With_Dir : Boolean := False)
- return String;
- -- Return the name of the file that File was extracted from through a
- -- call to "gnatchop -r". The file name for File is returned if File
- -- was not extracted from such a file. The directory will be given only
- -- if With_Dir is True.
-
- function Get_File
- (Decl : Declaration_Reference;
- With_Dir : Boolean := False) return String;
- pragma Inline (Get_File);
- -- Extract column number or file name from reference
-
- function Get_File
- (Ref : Reference;
- With_Dir : Boolean := False) return String;
- pragma Inline (Get_File);
-
- function Get_File
- (File : File_Reference;
- With_Dir : Boolean := False;
- Strip : Natural := 0) return String;
- -- Returns the file name (and its directory if With_Dir is True or the user
- -- has used the -f switch on the command line. If Strip is not 0, then the
- -- last Strip-th "-..." substrings are removed first. For instance, with
- -- Strip=2, a file name "parent-child1-child2-child3.ali" would be returned
- -- as "parent-child1.ali". This is used when looking for the ALI file to
- -- use for a package, since for separates with have to use the parent's
- -- ALI. The null string is returned if there is no such parent unit.
- --
- -- Note that this version of Get_File is not inlined
-
- function Get_File_Ref (Ref : Reference) return File_Reference;
- function Get_Line (Decl : Declaration_Reference) return String;
- function Get_Line (Ref : Reference) return String;
- function Get_Symbol (Decl : Declaration_Reference) return String;
- function Get_Type (Decl : Declaration_Reference) return Character;
- function Is_Parameter (Decl : Declaration_Reference) return Boolean;
- -- Functions that return the contents of a declaration
-
- function Get_Source_Line (Ref : Reference) return String;
- function Get_Source_Line (Decl : Declaration_Reference) return String;
- -- Return the source line associated with the reference
-
- procedure Grep_Source_Files;
- -- Parse all the source files which have at least one reference, and grep
- -- the appropriate source lines so that we'll be able to display them. This
- -- function should be called once all the .ali files have been parsed, and
- -- only if the appropriate user switch
- -- has been used (gnatfind -s).
- --
- -- Note: To save memory, the strings for the source lines are shared. Thus
- -- it is no longer possible to free the references, or we would free the
- -- same chunk multiple times. It doesn't matter, though, since this is only
- -- called once, prior to exiting gnatfind.
-
- function Longest_File_Name return Natural;
- -- Returns the longest file name found
-
- function Match (Decl : Declaration_Reference) return Boolean;
- -- Return True if the declaration matches
-
- function Match
- (File : File_Reference;
- Line : Natural;
- Column : Natural)
- return Boolean;
- -- Returns True if File:Line:Column was given on the command line
- -- by the user
-
- function Next_Unvisited_File return File_Reference;
- -- Returns the next unvisited library file in the list If there is no more
- -- unvisited file, return Empty_File. Two calls to this subprogram will
- -- return different files.
-
- procedure Set_Default_Match (Value : Boolean);
- -- Set the default value for match in declarations.
- -- This is used so that if no file was provided in the
- -- command line, then every file match
-
- procedure Reset_Directory (File : File_Reference);
- -- Reset the cached directory for file. Next time Get_File is called, the
- -- directory will be recomputed.
-
- procedure Set_Unvisited (File_Ref : File_Reference);
- -- Set File_Ref as unvisited. So Next_Unvisited_File will return it
-
- procedure Read_File
- (File_Name : String;
- Contents : out GNAT.OS_Lib.String_Access);
- -- Reads File_Name into the newly allocated string Contents. Types.EOF
- -- character will be added to the returned Contents to simplify parsing.
- -- Name_Error is raised if the file was not found. End_Error is raised if
- -- the file could not be read correctly. For most systems correct reading
- -- means that the number of bytes read is equal to the file size.
-
-private
- type Project_File (Src_Dir_Length, Obj_Dir_Length : Natural) is record
- Src_Dir_Index : Integer;
- Obj_Dir_Index : Integer;
- Last_Obj_Dir_Start : Natural;
- Src_Dir : String (1 .. Src_Dir_Length);
- Obj_Dir : String (1 .. Obj_Dir_Length);
- end record;
-
- type Project_File_Ptr is access all Project_File;
- -- This is actually a list of all the directories to be searched,
- -- either for source files or for library files
-
- type Ref_In_File;
- type Ref_In_File_Ptr is access all Ref_In_File;
-
- type Ref_In_File is record
- Line : Natural;
- Column : Natural;
- Next : Ref_In_File_Ptr := null;
- end record;
-
- type File_Record;
- type File_Reference is access all File_Record;
-
- Empty_File : constant File_Reference := null;
- type Cst_String_Access is access constant String;
-
- procedure Free (Str : in out Cst_String_Access);
-
- type File_Record is record
- File : Cst_String_Access;
- Dir : GNAT.OS_Lib.String_Access;
- Lines : Ref_In_File_Ptr := null;
- Visited : Boolean := False;
- Emit_Warning : Boolean := False;
- Gnatchop_File : GNAT.OS_Lib.String_Access := null;
- Gnatchop_Offset : Integer := 0;
- Next : File_Reference := null;
- end record;
- -- Holds a reference to a source file, that was referenced in at least one
- -- ALI file. Gnatchop_File will contain the name of the file that File was
- -- extracted From. Gnatchop_Offset contains the index of the first line of
- -- File within Gnatchop_File. These two fields are used to properly support
- -- gnatchop files and pragma Source_Reference.
- --
- -- Lines is used for files that were given on the command line, to
- -- memorize the lines and columns that the user specified.
-
- type Reference_Record;
- type Reference is access all Reference_Record;
-
- Empty_Reference : constant Reference := null;
-
- type Reference_Record is record
- File : File_Reference;
- Line : Natural;
- Column : Natural;
- Source_Line : Cst_String_Access;
- Next : Reference := null;
- end record;
- -- File is a reference to the Ada source file
- -- Source_Line is the Line as it appears in the source file. This
- -- field is only used when the switch is set on the command line of
- -- gnatfind.
-
- type Declaration_Record;
- type Declaration_Reference is access all Declaration_Record;
-
- Empty_Declaration : constant Declaration_Reference := null;
-
- type Declaration_Record (Symbol_Length : Natural) is record
- Key : Cst_String_Access;
- Decl : Reference;
- Is_Parameter : Boolean := False; -- True if entity is subprog param
- Decl_Type : Character;
- Body_Ref : Reference := null;
- Ref_Ref : Reference := null;
- Modif_Ref : Reference := null;
- Match : Boolean := False;
- Par_Symbol : Declaration_Reference := null;
- Next : Declaration_Reference := null;
- Symbol : String (1 .. Symbol_Length);
- end record;
- -- The lists of referenced (Body_Ref, Ref_Ref and Modif_Ref) are
- -- kept unsorted until the results needs to be printed. This saves
- -- lots of time while the internal tables are created.
-
- pragma Inline (Get_Column);
- pragma Inline (Get_Emit_Warning);
- pragma Inline (Get_File_Ref);
- pragma Inline (Get_Line);
- pragma Inline (Get_Symbol);
- pragma Inline (Get_Type);
- pragma Inline (Longest_File_Name);
-end Xr_Tabls;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- X R E F _ L I B --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2022, 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 3, 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 COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-pragma Ada_2012;
-
-with Osint;
-with Output; use Output;
-with Types; use Types;
-
-with Ada.Strings.Fixed; use Ada.Strings.Fixed;
-with Ada.Text_IO;
-with Ada.Unchecked_Deallocation;
-
-with GNAT.Command_Line; use GNAT.Command_Line;
-with GNAT.IO_Aux; use GNAT.IO_Aux;
-
-package body Xref_Lib is
-
- Type_Position : constant := 50;
- -- Column for label identifying type of entity
-
- ---------------------
- -- Local Variables --
- ---------------------
-
- Pipe : constant Character := '|';
- -- First character on xref lines in the .ali file
-
- No_Xref_Information : exception;
- -- Exception raised when there is no cross-referencing information in
- -- the .ali files.
-
- procedure Parse_EOL
- (Source : not null access String;
- Ptr : in out Positive;
- Skip_Continuation_Line : Boolean := False);
- -- On return Source (Ptr) is the first character of the next line
- -- or EOF. Source.all must be terminated by EOF.
- --
- -- If Skip_Continuation_Line is True, this subprogram skips as many
- -- lines as required when the second or more lines starts with '.'
- -- (continuation lines in ALI files).
-
- function Current_Xref_File (File : ALI_File) return File_Reference;
- -- Return the file matching the last 'X' line we found while parsing
- -- the ALI file.
-
- function File_Name (File : ALI_File; Num : Positive) return File_Reference;
- -- Returns the dependency file name number Num
-
- function Get_Full_Type (Decl : Declaration_Reference) return String;
- -- Returns the full type corresponding to a type letter as found in
- -- the .ali files.
-
- procedure Open
- (Name : String;
- File : in out ALI_File;
- Dependencies : Boolean := False);
- -- Open a new ALI file. If Dependencies is True, the insert every library
- -- file 'with'ed in the files database (used for gnatxref)
-
- 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;
- Labels_As_Ref : 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.
- --
- -- If Labels_As_Ref is true, then the references to the entities after
- -- the end statements ("end Foo") will be counted as actual references.
- -- The entity will never be reported as unreferenced by gnatxref -u
-
- procedure Parse_Token
- (Source : not null 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 : not null access String;
- Ptr : in out Positive;
- Number : out Natural);
- -- Skips any separators and parses Source up to 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.
-
- procedure Skip_To_First_X_Line
- (File : in out ALI_File;
- D_Lines : Boolean;
- W_Lines : Boolean);
- -- Skip the lines in the ALI file until the first cross-reference line
- -- (^X...) is found. Search is started from the beginning of the file.
- -- If not such line is found, No_Xref_Information is raised.
- -- If W_Lines is false, then the lines "^W" are not parsed.
- -- If D_Lines is false, then the lines "^D" are not parsed.
-
- ----------------
- -- 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;
- pragma Warnings (Off, File_Ref);
-
- 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 the regular expression is invalid, just consider it as a string
-
- if File_Start = 0 then
- 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;
- end if;
-
- -- Parse the file name
-
- Line_Start := Index (Entity (File_Start .. Entity'Last), ":");
-
- -- Check if it was a disk:\directory item (for Windows)
-
- 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;
-
- declare
- File_Name : String := Entity (File_Start .. Line_Start - 1);
-
- begin
- Osint.Canonical_Case_File_Name (File_Name);
- File_Ref := Add_To_Xref_File (File_Name, Visited => True);
- Pattern.File_Ref := File_Ref;
-
- Add_Line (Pattern.File_Ref, Line_Num, Col_Num);
-
- File_Ref :=
- Add_To_Xref_File
- (ALI_File_Name (File_Name),
- Visited => False,
- Emit_Warning => True);
- end;
- end Add_Entity;
-
- -------------------
- -- Add_Xref_File --
- -------------------
-
- procedure Add_Xref_File (File : String) is
- File_Ref : File_Reference := Empty_File;
- pragma Unreferenced (File_Ref);
-
- Iterator : Expansion_Iterator;
-
- procedure Add_Xref_File_Internal (File : String);
- -- Do the actual addition of the file
-
- ----------------------------
- -- Add_Xref_File_Internal --
- ----------------------------
-
- procedure Add_Xref_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) = "." & Osint.ALI_Suffix.all then
- File_Ref := Add_To_Xref_File
- (File, Visited => False, Emit_Warning => True);
-
- -- Normal non-ali file case
-
- else
- File_Ref := Add_To_Xref_File (File, Visited => True);
-
- File_Ref := Add_To_Xref_File
- (ALI_File_Name (File),
- Visited => False, Emit_Warning => True);
- end if;
- end Add_Xref_File_Internal;
-
- -- Start of processing for Add_Xref_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_Xref_File_Internal (S);
- end;
- end loop;
-
- else
- Add_Xref_File_Internal (File);
- end if;
- end Add_Xref_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;
-
- ---------------
- -- File_Name --
- ---------------
-
- function File_Name
- (File : ALI_File;
- Num : Positive) return File_Reference
- is
- Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
- begin
- return 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_Ref : File_Reference;
- pragma Unreferenced (File_Ref);
-
- 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
- -- Case of no more Obj_Dir lines
-
- 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
- Reset_Obj_Dir;
-
- 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) = "." & Osint.ALI_Suffix.all
- then
- File_Ref :=
- Add_To_Xref_File (Dir_Ent (1 .. Last), Visited => False);
- end if;
- end loop;
- end if;
- end Find_ALI_Files;
-
- -------------------
- -- Get_Full_Type --
- -------------------
-
- function Get_Full_Type (Decl : Declaration_Reference) return String is
-
- function Param_String return String;
- -- Return the string to display depending on whether Decl is a parameter
-
- ------------------
- -- Param_String --
- ------------------
-
- function Param_String return String is
- begin
- if Is_Parameter (Decl) then
- return "parameter ";
- else
- return "";
- end if;
- end Param_String;
-
- -- Start of processing for Get_Full_Type
-
- begin
- case Get_Type (Decl) 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 'H' => return "abstract 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 Param_String & "array object";
- when 'b' => return Param_String & "boolean object";
- when 'c' => return Param_String & "class-wide object";
- when 'd' => return Param_String & "decimal object";
- when 'e' => return Param_String & "enumeration object";
- when 'f' => return Param_String & "float object";
- when 'i' => return Param_String & "integer object";
- when 'j' => return Param_String & "class object";
- when 'm' => return Param_String & "modular object";
- when 'o' => return Param_String & "fixed object";
- when 'p' => return Param_String & "access object";
- when 'r' => return Param_String & "record object";
- when 's' => return Param_String & "string object";
- when 't' => return Param_String & "task object";
- when 'w' => return Param_String & "protected object";
- when 'x' => return Param_String & "abstract procedure";
- when 'y' => return Param_String & "abstract function";
-
- when 'h' => return "interface";
- when 'g' => return "macro";
- when 'G' => return "function macro";
- when 'J' => return "class";
- 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 'Q' => return "include file";
- 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";
-
- when '+' => return "private type";
- when '*' => return "private variable";
-
- -- The above should be the only possibilities, but for this kind
- -- of informational output, we don't want to bomb if we find
- -- something else, so just return three question marks when we
- -- have an unknown Abbrev value
-
- when others =>
- if Is_Parameter (Decl) then
- return "parameter";
- else
- return "??? (" & Get_Type (Decl) & ")";
- end if;
- end case;
- end Get_Full_Type;
-
- --------------------------
- -- Skip_To_First_X_Line --
- --------------------------
-
- procedure Skip_To_First_X_Line
- (File : in out ALI_File;
- D_Lines : Boolean;
- W_Lines : Boolean)
- is
- Ali : String_Access renames File.Buffer;
- Token : Positive;
- Ptr : Positive := Ali'First;
- Num_Dependencies : Natural := 0;
- File_Start : Positive;
- File_End : Positive;
- Gnatchop_Offset : Integer;
- Gnatchop_Name : Positive;
-
- File_Ref : File_Reference;
- pragma Unreferenced (File_Ref);
-
- begin
- -- 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 D_Lines and then Ali (Ptr) = 'D' then
-
- -- Found dependency information. Format looks like:
- -- D src-nam time-stmp checksum [subunit-name] [line:file-name]
-
- -- Skip the D and parse the filenam
-
- 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;
-
- declare
- Table : Table_Type renames
- File.Dep.Table (1 .. Last (File.Dep));
- begin
- Table (Num_Dependencies) := Add_To_Xref_File
- (Ali (File_Start .. File_End),
- Gnatchop_File => Ali (Token .. Ptr - 1),
- Gnatchop_Offset => Gnatchop_Offset);
- end;
-
- elsif W_Lines 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);
-
- File_Ref :=
- Add_To_Xref_File (Ali (Token .. Ptr - 1), 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 Skip_To_First_X_Line;
-
- ----------
- -- Open --
- ----------
-
- procedure Open
- (Name : String;
- File : in out ALI_File;
- Dependencies : Boolean := False)
- is
- Ali : String_Access renames File.Buffer;
- pragma Warnings (Off, Ali);
-
- begin
- if File.Buffer /= null then
- Free (File.Buffer);
- end if;
-
- Init (File.Dep);
-
- begin
- Read_File (Name, Ali);
-
- exception
- when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
- raise No_Xref_Information;
- end;
-
- Skip_To_First_X_Line (File, D_Lines => True, W_Lines => Dependencies);
- end Open;
-
- ---------------
- -- Parse_EOL --
- ---------------
-
- procedure Parse_EOL
- (Source : not null access String;
- Ptr : in out Positive;
- Skip_Continuation_Line : Boolean := False)
- is
- begin
- loop
- pragma Assert (Source (Ptr) /= EOF);
-
- -- 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;
-
- -- Skip CR or LF if not at end of file
-
- if Source (Ptr) /= EOF then
- Ptr := Ptr + 1;
- end if;
-
- -- Skip past CR/LF
-
- if Source (Ptr - 1) = ASCII.CR and then Source (Ptr) = ASCII.LF then
- Ptr := Ptr + 1;
- end if;
-
- exit when not Skip_Continuation_Line or else Source (Ptr) /= '.';
- end loop;
- 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;
- Labels_As_Ref : 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_Name : Positive; -- Pointer to begin of entity name
- E_Global : Boolean; -- True iff entity is global
- E_Type : Character; -- Type of current entity
-
- R_Line : Natural; -- Line number of current reference
- R_Col : Natural; -- Column number of current reference
-
- R_Type : Character := ASCII.NUL; -- 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.
- -- If the symbol is not found, we return (1 .. 3 => '?').
-
- procedure Skip_To_Matching_Closing_Bracket;
- -- When Ptr points to an opening square bracket, moves it to the
- -- character following the matching closing bracket
-
- ---------------------
- -- 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
-
- begin
- -- Look for the X lines corresponding to unit Eun
-
- loop
- if Ali (Ptr) = EOF then
- return "???";
- end if;
-
- if Ali (Ptr) = 'X' then
- Ptr := Ptr + 1;
- Parse_Number (Ali, Ptr, E_Eun);
- exit when E_Eun = Eun;
- end if;
-
- Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
- 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);
- exit when Ali (Ptr) = EOF;
- Ptr := Ptr + 1;
- Parse_Number (Ali, Ptr, E_Col);
- exit when Ali (Ptr) = EOF;
- 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;
-
- Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
- exit when Ali (Ptr) = EOF;
- end loop;
-
- return "???";
- end Get_Symbol_Name;
-
- --------------------------------------
- -- Skip_To_Matching_Closing_Bracket --
- --------------------------------------
-
- procedure Skip_To_Matching_Closing_Bracket is
- Num_Brackets : Natural;
-
- begin
- Num_Brackets := 1;
- while Num_Brackets /= 0 loop
- Ptr := Ptr + 1;
- if Ali (Ptr) = '[' then
- Num_Brackets := Num_Brackets + 1;
- elsif Ali (Ptr) = ']' then
- Num_Brackets := Num_Brackets - 1;
- end if;
- end loop;
-
- Ptr := Ptr + 1;
- end Skip_To_Matching_Closing_Bracket;
-
- Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
-
- -- 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;
-
- -- Ignore some of the entities (labels,...)
-
- if E_Type in 'l' | 'L' | 'q' then
- Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
- return;
- end if;
- else
- -- Unexpected contents, skip line and return
-
- Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
- return;
- 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 or if the file is unknown.
-
- if File.X_File = Empty_File then
- return;
- end if;
-
- if (not Local_Symbols and not E_Global)
- or else (Pattern.Initialized
- and then not Match (Ali (E_Name .. Ptr - 1), Pattern.Entity))
- or else (E_Name >= Ptr)
- then
- Decl_Ref := Add_Declaration
- (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type,
- Remove_Only => True);
- Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
- 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
- Skip_To_Matching_Closing_Bracket;
- end if;
-
- -- Skip any renaming indication
-
- if Ali (Ptr) = '=' then
- declare
- P_Line, P_Column : Natural;
- pragma Warnings (Off, P_Line);
- pragma Warnings (Off, P_Column);
- begin
- Ptr := Ptr + 1;
- Parse_Number (Ali, Ptr, P_Line);
- Ptr := Ptr + 1;
- Parse_Number (Ali, Ptr, P_Column);
- end;
- end if;
-
- while Ptr <= Ali'Last
- and then (Ali (Ptr) = '<'
- or else Ali (Ptr) = '('
- or else Ali (Ptr) = '{')
- loop
- -- 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.
-
- -- We also have the format for generic instantiations, as in
- -- 7a5*Uid(3|5I8[4|2]) 2|4r74
-
- -- We could also have something like
- -- 16I9*I<integer>
- -- that indicates that I derives from the predefined type integer.
-
- Ptr := Ptr + 1;
-
- if Ali (Ptr) in '0' .. '9' then
- Parse_Derived_Info : declare
- P_Line : Natural; -- parent entity line
- P_Column : Natural; -- parent entity column
- P_Eun : Natural := 0; -- 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 Table'Range loop
- P_Eun := K;
- exit when Table (K) = File_Ref;
- end loop;
- end if;
-
- -- Then parse the type and column number
-
- Ptr := Ptr + 1;
- Parse_Number (Ali, Ptr, P_Column);
-
- -- Skip the information for generics instantiations
-
- if Ali (Ptr) = '[' then
- Skip_To_Matching_Closing_Bracket;
- end if;
-
- -- Skip '>', or ')' or '>'
-
- 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
- pragma Assert (P_Eun /= 0);
-
- declare
- Symbol : constant String :=
- Get_Symbol_Name (P_Eun, P_Line, P_Column);
- begin
- if Symbol /= "???" then
- Add_Parent
- (Decl_Ref,
- Symbol,
- P_Line,
- P_Column,
- Table (P_Eun));
- end if;
- end;
- end if;
-
- if Type_Tree
- and then (Pattern.File_Ref = Empty_File
- or else
- Pattern.File_Ref = Current_Xref_File (File))
- 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 (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 hierarchy is defined in the same unit as
- -- the derived type. So we want to revisit the unit.
-
- File_Pos_Backup := File.Current_Line;
-
- Skip_To_First_X_Line
- (File, D_Lines => False, W_Lines => False);
-
- while File.Buffer (File.Current_Line) /= EOF loop
- Parse_X_Filename (File);
- Parse_Identifier_Info
- (Pattern => Pattern,
- File => File,
- Local_Symbols => False,
- Der_Info => Der_Info,
- Type_Tree => True,
- Wide_Search => False,
- Labels_As_Ref => Labels_As_Ref);
- end loop;
-
- File.Current_Line := File_Pos_Backup;
- end Search_Parent_Tree;
- end if;
- end Parse_Derived_Info;
-
- else
- while Ali (Ptr) /= '>'
- and then Ali (Ptr) /= ')'
- and then Ali (Ptr) /= '}'
- loop
- Ptr := Ptr + 1;
- end loop;
- Ptr := Ptr + 1;
- end if;
- end loop;
-
- -- To find the body, we will have to parse the file too
-
- if Wide_Search then
- declare
- File_Name : constant String := Get_Gnatchop_File (File.X_File);
- Ignored : File_Reference;
- begin
- Ignored := Add_To_Xref_File (ALI_File_Name (File_Name), 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 else 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;
-
- -- Imported entities may have an indication specifying information
- -- about the corresponding external name:
- -- 5U14*Foo2 5>20 6b<c,myfoo2>22 # Imported entity
- -- 5U14*Foo2 5>20 6i<c,myfoo2>22 # Exported entity
-
- if Ali (Ptr) = '<'
- and then (R_Type = 'b' or else R_Type = 'i')
- then
- while Ptr <= Ali'Last
- and then Ali (Ptr) /= '>'
- loop
- Ptr := Ptr + 1;
- end loop;
- Ptr := Ptr + 1;
- end if;
-
- Parse_Number (Ali, Ptr, R_Col);
-
- pragma Assert (R_Type /= ASCII.NUL);
-
- -- Insert the reference or body in the table
-
- Add_Reference
- (Decl_Ref, File_Ref, R_Line, R_Col, R_Type, Labels_As_Ref);
-
- -- Skip generic information, if any
-
- if Ali (Ptr) = '[' then
- declare
- Num_Nested : Integer := 1;
-
- begin
- Ptr := Ptr + 1;
- while Num_Nested /= 0 loop
- if Ali (Ptr) = ']' then
- Num_Nested := Num_Nested - 1;
- elsif Ali (Ptr) = '[' then
- Num_Nested := Num_Nested + 1;
- end if;
-
- Ptr := Ptr + 1;
- end loop;
- end;
- end if;
-
- 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 : not null 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 : not null access String;
- Ptr : in out Positive;
- Token_Ptr : out Positive)
- is
- In_Quotes : Character := ASCII.NUL;
-
- 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 /= ASCII.NUL or else
- not (Source (Ptr) = ' '
- or else Source (Ptr) = ASCII.HT
- or else Source (Ptr) = '<'
- or else Source (Ptr) = '{'
- or else Source (Ptr) = '['
- or else Source (Ptr) = '='
- or else Source (Ptr) = '('))
- and then Source (Ptr) >= ' '
- loop
- -- Double-quotes are used for operators
- -- Simple-quotes are used for character constants, for instance when
- -- they are found in an enumeration type "type A is ('+', '-');"
-
- case Source (Ptr) is
- when '"' | ''' =>
- if In_Quotes = Source (Ptr) then
- In_Quotes := ASCII.NUL;
- elsif In_Quotes = ASCII.NUL then
- In_Quotes := Source (Ptr);
- end if;
-
- when others =>
- null;
- end case;
-
- 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;
-
- Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
-
- 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 the referenced file is unknown, we simply ignore it
-
- if File_Nr in Table'Range then
- File.X_File := Table (File_Nr);
- else
- File.X_File := Empty_File;
- end if;
-
- Parse_EOL (Ali, Ptr);
- end loop;
- end Parse_X_Filename;
-
- --------------------
- -- Print_Gnatfind --
- --------------------
-
- procedure Print_Gnatfind
- (References : Boolean;
- Full_Path_Name : Boolean)
- is
- Decls : constant Declaration_Array_Access := Get_Declarations;
- Decl : Declaration_Reference;
- Arr : Reference_Array_Access;
-
- 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
- F : String_Access :=
- Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Ref, Full_Path_Name));
-
- Buffer : constant String :=
- F.all &
- ":" & Get_Line (Ref) &
- ":" & Get_Column (Ref) &
- ": ";
-
- Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
-
- begin
- Free (F);
- 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
- for D in Decls'Range loop
- Decl := Decls (D);
-
- if Match (Decl) then
-
- -- Output the declaration
-
- declare
- Parent : constant Declaration_Reference := Get_Parent (Decl);
-
- F : String_Access :=
- Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Decl, Full_Path_Name));
-
- Buffer : constant String :=
- F.all &
- ":" & Get_Line (Decl) &
- ":" & Get_Column (Decl) &
- ": ";
-
- Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
-
- begin
- Free (F);
- Num_Blanks := Integer'Max (0, Num_Blanks);
- Write_Line
- (Buffer & String'(1 .. Num_Blanks => ' ')
- & "(spec) " & Get_Symbol (Decl));
-
- if Parent /= Empty_Declaration then
- F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent));
- Write_Line
- (Buffer & String'(1 .. Num_Blanks => ' ')
- & " derived from " & Get_Symbol (Parent)
- & " ("
- & F.all
- & ':' & Get_Line (Parent)
- & ':' & Get_Column (Parent) & ')');
- Free (F);
- end if;
- end;
-
- if Get_Source_Line (Decl)'Length /= 0 then
- Write_Line (" " & Get_Source_Line (Decl));
- end if;
-
- -- Output the body (sorted)
-
- Arr := Get_References (Decl, Get_Bodies => True);
-
- for R in Arr'Range loop
- Print_Ref (Arr (R), "(body)");
- end loop;
-
- Free (Arr);
-
- if References then
- Arr := Get_References
- (Decl, Get_Writes => True, Get_Reads => True);
-
- for R in Arr'Range loop
- Print_Ref (Arr (R));
- end loop;
-
- Free (Arr);
- end if;
- end if;
- end loop;
- end Print_Gnatfind;
-
- ------------------
- -- Print_Unused --
- ------------------
-
- procedure Print_Unused (Full_Path_Name : Boolean) is
- Decls : constant Declaration_Array_Access := Get_Declarations;
- Decl : Declaration_Reference;
- Arr : Reference_Array_Access;
- F : String_Access;
-
- begin
- for D in Decls'Range loop
- Decl := Decls (D);
-
- if References_Count
- (Decl, Get_Reads => True, Get_Writes => True) = 0
- then
- F := Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Decl, Full_Path_Name));
- Write_Str (Get_Symbol (Decl)
- & " ("
- & Get_Full_Type (Decl)
- & ") "
- & F.all
- & ':'
- & Get_Line (Decl)
- & ':'
- & Get_Column (Decl));
- Free (F);
-
- -- Print the body if any
-
- Arr := Get_References (Decl, Get_Bodies => True);
-
- for R in Arr'Range loop
- F := Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Arr (R), Full_Path_Name));
- Write_Str (' '
- & F.all
- & ':' & Get_Line (Arr (R))
- & ':' & Get_Column (Arr (R)));
- Free (F);
- end loop;
-
- Write_Eol;
- Free (Arr);
- end if;
- end loop;
- end Print_Unused;
-
- --------------
- -- Print_Vi --
- --------------
-
- procedure Print_Vi (Full_Path_Name : Boolean) is
- Tab : constant Character := ASCII.HT;
- Decls : constant Declaration_Array_Access :=
- Get_Declarations (Sorted => False);
- Decl : Declaration_Reference;
- Arr : Reference_Array_Access;
- F : String_Access;
-
- begin
- for D in Decls'Range loop
- Decl := Decls (D);
-
- F := Osint.To_Host_File_Spec (Get_File (Decl, Full_Path_Name));
- Write_Line (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Decl));
- Free (F);
-
- -- Print the body if any
-
- Arr := Get_References (Decl, Get_Bodies => True);
-
- for R in Arr'Range loop
- F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name));
- Write_Line
- (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Arr (R)));
- Free (F);
- end loop;
-
- Free (Arr);
-
- -- Print the modifications
-
- Arr := Get_References (Decl, Get_Writes => True, Get_Reads => True);
-
- for R in Arr'Range loop
- F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name));
- Write_Line
- (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Arr (R)));
- Free (F);
- end loop;
-
- Free (Arr);
- end loop;
- end Print_Vi;
-
- ----------------
- -- Print_Xref --
- ----------------
-
- procedure Print_Xref (Full_Path_Name : Boolean) is
- Decls : constant Declaration_Array_Access := Get_Declarations;
- Decl : Declaration_Reference;
-
- Margin : constant := 10;
- -- Column where file names start
-
- procedure New_Line80;
- -- Go to start of new line
-
- procedure Print80 (S : 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
-
- procedure Print_List
- (Decl : Declaration_Reference;
- Msg : String;
- Get_Reads : Boolean := False;
- Get_Writes : Boolean := False;
- Get_Bodies : Boolean := False);
- -- Print a list of references. If the list is not empty, Msg will
- -- be printed prior to the list.
-
- ----------------
- -- New_Line80 --
- ----------------
-
- procedure New_Line80 is
- begin
- Write_Eol;
- Write_Str (String'(1 .. Margin - 1 => ' '));
- end New_Line80;
-
- -------------
- -- Print80 --
- -------------
-
- procedure Print80 (S : 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;
-
- ----------------
- -- Print_List --
- ----------------
-
- procedure Print_List
- (Decl : Declaration_Reference;
- Msg : String;
- Get_Reads : Boolean := False;
- Get_Writes : Boolean := False;
- Get_Bodies : Boolean := False)
- is
- Arr : Reference_Array_Access :=
- Get_References
- (Decl,
- Get_Writes => Get_Writes,
- Get_Reads => Get_Reads,
- Get_Bodies => Get_Bodies);
- File : File_Reference := Empty_File;
- F : String_Access;
-
- begin
- if Arr'Length /= 0 then
- Write_Eol;
- Write_Str (Msg);
- end if;
-
- for R in Arr'Range loop
- if Get_File_Ref (Arr (R)) /= File then
- if File /= Empty_File then
- New_Line80;
- end if;
-
- File := Get_File_Ref (Arr (R));
- F := Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Arr (R), Full_Path_Name));
-
- if F = null then
- Write_Str ("<unknown> ");
- else
- Write_Str (F.all & ' ');
- Free (F);
- end if;
- end if;
-
- Print_Ref (Get_Line (Arr (R)), Get_Column (Arr (R)));
- end loop;
-
- Free (Arr);
- end Print_List;
-
- F : String_Access;
-
- -- Start of processing for Print_Xref
-
- begin
- for D in Decls'Range loop
- Decl := Decls (D);
-
- Write_Str (Get_Symbol (Decl));
-
- -- Put the declaration type in column Type_Position, but if the
- -- declaration name is too long, put at least one space between its
- -- name and its type.
-
- while Column < Type_Position - 1 loop
- Write_Char (' ');
- end loop;
-
- Write_Char (' ');
-
- Write_Line (Get_Full_Type (Decl));
-
- Write_Parent_Info : declare
- Parent : constant Declaration_Reference := Get_Parent (Decl);
-
- begin
- if Parent /= Empty_Declaration then
- Write_Str (" Ptype: ");
- F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent));
- Print80 (F.all);
- Free (F);
- Print_Ref (Get_Line (Parent), Get_Column (Parent));
- Print80 (" " & Get_Symbol (Parent));
- Write_Eol;
- end if;
- end Write_Parent_Info;
-
- Write_Str (" Decl: ");
- F := Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Decl, Full_Path_Name));
-
- if F = null then
- Print80 ("<unknown> ");
- else
- Print80 (F.all & ' ');
- Free (F);
- end if;
-
- Print_Ref (Get_Line (Decl), Get_Column (Decl));
-
- Print_List
- (Decl, " Body: ", Get_Bodies => True);
- Print_List
- (Decl, " Modi: ", Get_Writes => True);
- Print_List
- (Decl, " Ref: ", Get_Reads => True);
- Write_Eol;
- end loop;
- end Print_Xref;
-
- ------------
- -- 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 Ada.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));
-
- -- Stripped 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).
-
- -- Reset the cached directory first, in case the separate's
- -- ALI file is not in the same directory.
-
- elsif not File_Exists (Ali_Name.all) then
- Strip_Num := Strip_Num + 1;
- Reset_Directory (File_Ref);
-
- -- Else we finally found it
-
- else
- exit;
- end if;
- end loop;
-
- -- If we had to get the parent's ALI, insert it in the list as usual.
- -- This is to avoid parsing it twice in case it has already been
- -- parsed.
-
- if Ali_Name /= null and then Strip_Num /= 0 then
- File_Ref := Add_To_Xref_File
- (File_Name => Ali_Name.all,
- Visited => False);
-
- -- Now that we have a file name, parse it to find any reference to
- -- the entity.
-
- elsif Ali_Name /= null
- and then (Read_Only or else Is_Writable_File (Ali_Name.all))
- then
- begin
- Open (Ali_Name.all, ALIfile);
-
- -- The cross-reference section in the ALI file may be followed
- -- by other sections, which can be identified by the starting
- -- character of every line, which should neither be 'X' nor a
- -- figure in '1' .. '9'.
-
- -- The loop tests below also take into account the end-of-file
- -- possibility.
-
- while ALIfile.Buffer (ALIfile.Current_Line) = 'X' loop
- Parse_X_Filename (ALIfile);
-
- while ALIfile.Buffer (ALIfile.Current_Line) in '1' .. '9'
- loop
- Parse_Identifier_Info
- (Pattern, ALIfile, Local_Symbols, Der_Info, Type_Tree,
- Wide_Search, Labels_As_Ref => True);
- end loop;
- 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
- Null_Pattern.Initialized := False;
-
- 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
-
- declare
- F : constant String := Get_File (File_Ref, With_Dir => True);
-
- begin
- if Read_Only or else Is_Writable_File (F) then
- Open (F, ALIfile, True);
-
- -- The cross-reference section in the ALI file may be followed
- -- by other sections, which can be identified by the starting
- -- character of every line, which should neither be 'X' nor a
- -- figure in '1' .. '9'.
-
- -- The loop tests below also take into account the end-of-file
- -- possibility.
-
- while ALIfile.Buffer (ALIfile.Current_Line) = 'X' loop
- Parse_X_Filename (ALIfile);
-
- while ALIfile.Buffer (ALIfile.Current_Line) in '1' .. '9'
- loop
- Parse_Identifier_Info
- (Null_Pattern, ALIfile, Local_Symbols, Der_Info,
- Labels_As_Ref => False);
- end loop;
- end loop;
- end if;
-
- exception
- when No_Xref_Information => null;
- end;
- end loop;
- end Search_Xref;
-
-end Xref_Lib;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- X R E F _ L I B --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-2022, 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 3, 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 COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Miscellaneous utilities for the cross-referencing tool
-
-with Hostparm;
-with Xr_Tabls; use Xr_Tabls;
-
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with GNAT.Dynamic_Tables;
-with GNAT.Regexp; use GNAT.Regexp;
-
-package Xref_Lib is
-
- subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length);
- subtype Line_String is String (1 .. Hostparm.Max_Line_Length);
-
- type ALI_File is limited private;
-
- ---------------------
- -- Directory Input --
- ---------------------
-
- type Rec_DIR is limited private;
- -- This one is used for recursive search of .ali files
-
- procedure Find_ALI_Files;
- -- Find all the ali files that we will have to parse, and have them to
- -- the file list
-
- ---------------------
- -- Search patterns --
- ---------------------
-
- type Search_Pattern is private;
- type Search_Pattern_Ptr is access all Search_Pattern;
-
- procedure Add_Entity
- (Pattern : in out Search_Pattern;
- Entity : String;
- Glob : Boolean := False);
- -- Add a new entity to the search pattern (the entity should have the
- -- form pattern[:file[:line[:column]]], and it is parsed entirely in
- -- this procedure. Glob indicates if we should use the 'globbing
- -- patterns' (True) or the full regular expressions (False)
-
- procedure Add_Xref_File (File : String);
- -- Add a new file in the list of files to search for references. File
- -- is interpreted as a globbing regular expression, which is expanded.
-
- Invalid_Argument : exception;
- -- Exception raised when there is a syntax error in the command line
-
- -----------------------
- -- Output Algorithms --
- -----------------------
-
- procedure Print_Gnatfind
- (References : Boolean;
- Full_Path_Name : Boolean);
- procedure Print_Unused (Full_Path_Name : Boolean);
- procedure Print_Vi (Full_Path_Name : Boolean);
- procedure Print_Xref (Full_Path_Name : Boolean);
- -- The actual print procedures. These functions step through the symbol
- -- table and print all the symbols if they match the files given on the
- -- command line (they already match the entities if they are in the
- -- symbol table)
-
- ------------------------
- -- General Algorithms --
- ------------------------
-
- function Default_Project_File (Dir_Name : String) return String;
- -- Returns the default Project file name for the directory Dir_Name
-
- procedure Search
- (Pattern : Search_Pattern;
- Local_Symbols : Boolean;
- Wide_Search : Boolean;
- Read_Only : Boolean;
- Der_Info : Boolean;
- Type_Tree : Boolean);
- -- Search every ALI file for entities matching Pattern, and add
- -- these entities to the internal symbol tables.
- --
- -- If Wide_Search is True, all ALI files found in the object path
- -- are searched.
- --
- -- If Read_Only is True, read-only ALI files will also be parsed,
- -- similar to gnatmake -a.
- --
- -- If Der_Info is true, then the derived type information will be
- -- processed.
- --
- -- If Type_Tree is true, then the type hierarchy will be searched
- -- going from the pattern to the parent type.
-
- procedure Search_Xref
- (Local_Symbols : Boolean;
- Read_Only : Boolean;
- Der_Info : Boolean);
- -- Search every ali file given in the command line and all their
- -- dependencies. If Read_Only is True, we parse the read-only ali
- -- files too. If Der_Mode is true then the derived type information will
- -- be processed
-
-private
- type Rec_DIR is limited record
- Dir : GNAT.Directory_Operations.Dir_Type;
- end record;
-
- package Dependencies_Tables is new GNAT.Dynamic_Tables
- (Table_Component_Type => Xr_Tabls.File_Reference,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 400,
- Table_Increment => 100);
- use Dependencies_Tables;
-
- type Dependencies is new Dependencies_Tables.Instance;
-
- type ALI_File is limited record
- Buffer : String_Access := null;
- -- Buffer used to read the whole file at once
-
- Current_Line : Positive;
- -- Start of the current line in Buffer
-
- Xref_Line : Positive;
- -- Start of the xref lines in Buffer
-
- X_File : Xr_Tabls.File_Reference;
- -- Stores the cross-referencing file-name ("X..." lines), as an
- -- index into the dependencies table
-
- Dep : Dependencies;
- -- Store file name associated with each number ("D..." lines)
- end record;
-
- -- The following record type stores all the patterns that are searched for
-
- type Search_Pattern is record
- Entity : GNAT.Regexp.Regexp;
- -- A regular expression matching the entities we are looking for.
- -- File is a list of the places where the declaration of the entities
- -- has to be. When the user enters a file:line:column on the command
- -- line, it is stored as "Entity_Name Declaration_File:line:column"
-
- File_Ref : Xr_Tabls.File_Reference;
- -- A reference to the source file, if any
-
- Initialized : Boolean := False;
- -- Set to True when Entity has been initialized
- end record;
-
-end Xref_Lib;
projects / platform / upstream / gcc.git / commitdiff