mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-13 08:29:53 +00:00
1411 lines
46 KiB
Ada
1411 lines
46 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- G N A T N A M E --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2001-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 Ada.Characters.Handling; use Ada.Characters.Handling;
|
|
with Ada.Command_Line; use Ada.Command_Line;
|
|
with Ada.Text_IO; use Ada.Text_IO;
|
|
|
|
with GNAT.Command_Line; use GNAT.Command_Line;
|
|
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
|
|
with GNAT.Dynamic_Tables;
|
|
with GNAT.OS_Lib; use GNAT.OS_Lib;
|
|
|
|
with Make_Util; use Make_Util;
|
|
with Namet; use Namet;
|
|
with Opt;
|
|
with Osint; use Osint;
|
|
with Output;
|
|
with Switch; use Switch;
|
|
with Table;
|
|
with Tempdir;
|
|
with Types; use Types;
|
|
|
|
with System.CRTL;
|
|
with System.Regexp; use System.Regexp;
|
|
|
|
procedure Gnatname is
|
|
|
|
pragma Warnings (Off);
|
|
type Matched_Type is (True, False, Excluded);
|
|
pragma Warnings (On);
|
|
|
|
Create_Project : Boolean := False;
|
|
|
|
Subdirs_Switch : constant String := "--subdirs=";
|
|
|
|
Usage_Output : Boolean := False;
|
|
-- Set to True when usage is output, to avoid multiple output
|
|
|
|
Usage_Needed : Boolean := False;
|
|
-- Set to True by -h switch
|
|
|
|
Version_Output : Boolean := False;
|
|
-- Set to True when version is output, to avoid multiple output
|
|
|
|
Very_Verbose : Boolean := False;
|
|
-- Set to True with -v -v
|
|
|
|
File_Path : String_Access := new String'("gnat.adc");
|
|
-- Path name of the file specified by -c or -P switch
|
|
|
|
File_Set : Boolean := False;
|
|
-- Set to True by -c or -P switch.
|
|
-- Used to detect multiple -c/-P switches.
|
|
|
|
Args : Argument_List_Access;
|
|
-- The list of arguments for calls to the compiler to get the unit names
|
|
-- and kinds (spec or body) in the Ada sources.
|
|
|
|
Path_Name : String_Access;
|
|
|
|
Path_Last : Natural;
|
|
|
|
Directory_Last : Natural := 0;
|
|
|
|
function Dup (Fd : File_Descriptor) return File_Descriptor;
|
|
|
|
procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
|
|
|
|
Gcc : constant String := "gcc";
|
|
Gcc_Path : String_Access := null;
|
|
|
|
package Patterns is new GNAT.Dynamic_Tables
|
|
(Table_Component_Type => String_Access,
|
|
Table_Index_Type => Natural,
|
|
Table_Low_Bound => 0,
|
|
Table_Initial => 10,
|
|
Table_Increment => 100);
|
|
-- Table to accumulate the patterns
|
|
|
|
type Argument_Data is record
|
|
Directories : Patterns.Instance;
|
|
Name_Patterns : Patterns.Instance;
|
|
Excluded_Patterns : Patterns.Instance;
|
|
Foreign_Patterns : Patterns.Instance;
|
|
end record;
|
|
|
|
package Arguments is new Table.Table
|
|
(Table_Component_Type => Argument_Data,
|
|
Table_Index_Type => Natural,
|
|
Table_Low_Bound => 0,
|
|
Table_Initial => 10,
|
|
Table_Increment => 100,
|
|
Table_Name => "Gnatname.Arguments");
|
|
-- Table to accumulate directories and patterns
|
|
|
|
package Preprocessor_Switches is new Table.Table
|
|
(Table_Component_Type => String_Access,
|
|
Table_Index_Type => Natural,
|
|
Table_Low_Bound => 0,
|
|
Table_Initial => 10,
|
|
Table_Increment => 100,
|
|
Table_Name => "Gnatname.Preprocessor_Switches");
|
|
-- Table to store the preprocessor switches to be used in the call
|
|
-- to the compiler.
|
|
|
|
type Source is record
|
|
File_Name : Name_Id;
|
|
Unit_Name : Name_Id;
|
|
Index : Int := 0;
|
|
Spec : Boolean;
|
|
end record;
|
|
|
|
package Processed_Directories is new Table.Table
|
|
(Table_Component_Type => String_Access,
|
|
Table_Index_Type => Natural,
|
|
Table_Low_Bound => 0,
|
|
Table_Initial => 10,
|
|
Table_Increment => 100,
|
|
Table_Name => "Prj.Makr.Processed_Directories");
|
|
-- The list of already processed directories for each section, to avoid
|
|
-- processing several times the same directory in the same section.
|
|
|
|
package Sources is new Table.Table
|
|
(Table_Component_Type => Source,
|
|
Table_Index_Type => Natural,
|
|
Table_Low_Bound => 0,
|
|
Table_Initial => 10,
|
|
Table_Increment => 100,
|
|
Table_Name => "Gnatname.Sources");
|
|
-- The list of Ada sources found, with their unit name and kind, to be put
|
|
-- in the pragmas Source_File_Name in the configuration pragmas file.
|
|
|
|
procedure Output_Version;
|
|
-- Print name and version
|
|
|
|
procedure Usage;
|
|
-- Print usage
|
|
|
|
procedure Scan_Args;
|
|
-- Scan the command line arguments
|
|
|
|
procedure Add_Source_Directory (S : String);
|
|
-- Add S in the Source_Directories table
|
|
|
|
procedure Get_Directories (From_File : String);
|
|
-- Read a source directory text file
|
|
|
|
procedure Write_Eol;
|
|
-- Output an empty line
|
|
|
|
procedure Write_A_String (S : String);
|
|
-- Write a String to Output_FD
|
|
|
|
procedure Initialize
|
|
(File_Path : String;
|
|
Preproc_Switches : Argument_List);
|
|
-- Start the creation of a configuration pragmas file
|
|
--
|
|
-- File_Path is the name of the configuration pragmas file to create
|
|
--
|
|
-- Preproc_Switches is a list of switches to be used when invoking the
|
|
-- compiler to get the name and kind of unit of a source file.
|
|
|
|
type Regexp_List is array (Positive range <>) of Regexp;
|
|
|
|
procedure Process
|
|
(Directories : Argument_List;
|
|
Name_Patterns : Regexp_List;
|
|
Excluded_Patterns : Regexp_List;
|
|
Foreign_Patterns : Regexp_List);
|
|
-- Look for source files in the specified directories, with the specified
|
|
-- patterns.
|
|
--
|
|
-- Directories is the list of source directories where to look for sources.
|
|
--
|
|
-- Name_Patterns is a potentially empty list of file name patterns to check
|
|
-- for Ada Sources.
|
|
--
|
|
-- Excluded_Patterns is a potentially empty list of file name patterns that
|
|
-- should not be checked for Ada or non Ada sources.
|
|
--
|
|
-- Foreign_Patterns is a potentially empty list of file name patterns to
|
|
-- check for non Ada sources.
|
|
--
|
|
-- At least one of Name_Patterns and Foreign_Patterns is not empty
|
|
|
|
procedure Finalize;
|
|
-- Write the configuration pragmas file indicated in a call to procedure
|
|
-- Initialize, after one or several calls to procedure Process.
|
|
|
|
--------------------------
|
|
-- Add_Source_Directory --
|
|
--------------------------
|
|
|
|
procedure Add_Source_Directory (S : String) is
|
|
begin
|
|
Patterns.Append
|
|
(Arguments.Table (Arguments.Last).Directories, new String'(S));
|
|
end Add_Source_Directory;
|
|
|
|
---------
|
|
-- Dup --
|
|
---------
|
|
|
|
function Dup (Fd : File_Descriptor) return File_Descriptor is
|
|
begin
|
|
return File_Descriptor (System.CRTL.dup (Integer (Fd)));
|
|
end Dup;
|
|
|
|
----------
|
|
-- Dup2 --
|
|
----------
|
|
|
|
procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is
|
|
Fd : Integer;
|
|
pragma Warnings (Off, Fd);
|
|
begin
|
|
Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd));
|
|
end Dup2;
|
|
|
|
---------------------
|
|
-- Get_Directories --
|
|
---------------------
|
|
|
|
procedure Get_Directories (From_File : String) is
|
|
File : Ada.Text_IO.File_Type;
|
|
Line : String (1 .. 2_000);
|
|
Last : Natural;
|
|
|
|
begin
|
|
Open (File, In_File, From_File);
|
|
|
|
while not End_Of_File (File) loop
|
|
Get_Line (File, Line, Last);
|
|
|
|
if Last /= 0 then
|
|
Add_Source_Directory (Line (1 .. Last));
|
|
end if;
|
|
end loop;
|
|
|
|
Close (File);
|
|
|
|
exception
|
|
when Name_Error =>
|
|
Fail ("cannot open source directory file """ & From_File & '"');
|
|
end Get_Directories;
|
|
|
|
--------------
|
|
-- Finalize --
|
|
--------------
|
|
|
|
procedure Finalize is
|
|
Discard : Boolean;
|
|
pragma Warnings (Off, Discard);
|
|
|
|
begin
|
|
-- Delete the file if it already exists
|
|
|
|
Delete_File
|
|
(Path_Name (Directory_Last + 1 .. Path_Last),
|
|
Success => Discard);
|
|
|
|
-- Create a new one
|
|
|
|
if Opt.Verbose_Mode then
|
|
Output.Write_Str ("Creating new file """);
|
|
Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
|
|
Output.Write_Line ("""");
|
|
end if;
|
|
|
|
Output_FD := Create_New_File
|
|
(Path_Name (Directory_Last + 1 .. Path_Last),
|
|
Fmode => Text);
|
|
|
|
-- Fails if file cannot be created
|
|
|
|
if Output_FD = Invalid_FD then
|
|
Fail_Program
|
|
("cannot create new """ & Path_Name (1 .. Path_Last) & """");
|
|
end if;
|
|
|
|
-- For each Ada source, write a pragma Source_File_Name to the
|
|
-- configuration pragmas file.
|
|
|
|
for Index in 1 .. Sources.Last loop
|
|
if Sources.Table (Index).Unit_Name /= No_Name then
|
|
Write_A_String ("pragma Source_File_Name");
|
|
Write_Eol;
|
|
Write_A_String (" (");
|
|
Write_A_String
|
|
(Get_Name_String (Sources.Table (Index).Unit_Name));
|
|
Write_A_String (",");
|
|
Write_Eol;
|
|
|
|
if Sources.Table (Index).Spec then
|
|
Write_A_String (" Spec_File_Name => """);
|
|
|
|
else
|
|
Write_A_String (" Body_File_Name => """);
|
|
end if;
|
|
|
|
Write_A_String
|
|
(Get_Name_String (Sources.Table (Index).File_Name));
|
|
|
|
Write_A_String ("""");
|
|
|
|
if Sources.Table (Index).Index /= 0 then
|
|
Write_A_String (", Index =>");
|
|
Write_A_String (Sources.Table (Index).Index'Img);
|
|
end if;
|
|
|
|
Write_A_String (");");
|
|
Write_Eol;
|
|
end if;
|
|
end loop;
|
|
|
|
Close (Output_FD);
|
|
end Finalize;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
procedure Initialize
|
|
(File_Path : String;
|
|
Preproc_Switches : Argument_List)
|
|
is
|
|
begin
|
|
Sources.Set_Last (0);
|
|
|
|
-- Initialize the compiler switches
|
|
|
|
Args := new Argument_List (1 .. Preproc_Switches'Length + 6);
|
|
Args (1) := new String'("-c");
|
|
Args (2) := new String'("-gnats");
|
|
Args (3) := new String'("-gnatu");
|
|
Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
|
|
Args (4 + Preproc_Switches'Length) := new String'("-x");
|
|
Args (5 + Preproc_Switches'Length) := new String'("ada");
|
|
|
|
-- Get the path and file names
|
|
|
|
Path_Name := new
|
|
String (1 .. File_Path'Length);
|
|
Path_Last := File_Path'Length;
|
|
|
|
if File_Names_Case_Sensitive then
|
|
Path_Name (1 .. Path_Last) := File_Path;
|
|
else
|
|
Path_Name (1 .. Path_Last) := To_Lower (File_Path);
|
|
end if;
|
|
|
|
-- Get the end of directory information, if any
|
|
|
|
for Index in reverse 1 .. Path_Last loop
|
|
if Path_Name (Index) = Directory_Separator then
|
|
Directory_Last := Index;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
-- Change the current directory to the directory of the project file,
|
|
-- if any directory information is specified.
|
|
|
|
if Directory_Last /= 0 then
|
|
begin
|
|
Change_Dir (Path_Name (1 .. Directory_Last));
|
|
exception
|
|
when Directory_Error =>
|
|
Fail_Program
|
|
("unknown directory """
|
|
& Path_Name (1 .. Directory_Last)
|
|
& """");
|
|
end;
|
|
end if;
|
|
end Initialize;
|
|
|
|
-------------
|
|
-- Process --
|
|
-------------
|
|
|
|
procedure Process
|
|
(Directories : Argument_List;
|
|
Name_Patterns : Regexp_List;
|
|
Excluded_Patterns : Regexp_List;
|
|
Foreign_Patterns : Regexp_List)
|
|
is
|
|
procedure Process_Directory (Dir_Name : String);
|
|
-- Look for Ada and foreign sources in a directory, according to the
|
|
-- patterns.
|
|
|
|
-----------------------
|
|
-- Process_Directory --
|
|
-----------------------
|
|
|
|
procedure Process_Directory (Dir_Name : String) is
|
|
Matched : Matched_Type := False;
|
|
Str : String (1 .. 2_000);
|
|
Canon : String (1 .. 2_000);
|
|
Last : Natural;
|
|
Dir : Dir_Type;
|
|
Do_Process : Boolean := True;
|
|
|
|
Temp_File_Name : String_Access := null;
|
|
Save_Last_Source_Index : Natural := 0;
|
|
File_Name_Id : Name_Id := No_Name;
|
|
|
|
Current_Source : Source;
|
|
|
|
begin
|
|
-- Avoid processing the same directory more than once
|
|
|
|
for Index in 1 .. Processed_Directories.Last loop
|
|
if Processed_Directories.Table (Index).all = Dir_Name then
|
|
Do_Process := False;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
if Do_Process then
|
|
if Opt.Verbose_Mode then
|
|
Output.Write_Str ("Processing directory """);
|
|
Output.Write_Str (Dir_Name);
|
|
Output.Write_Line ("""");
|
|
end if;
|
|
|
|
Processed_Directories. Increment_Last;
|
|
Processed_Directories.Table (Processed_Directories.Last) :=
|
|
new String'(Dir_Name);
|
|
|
|
-- Get the source file names from the directory. Fails if the
|
|
-- directory does not exist.
|
|
|
|
begin
|
|
Open (Dir, Dir_Name);
|
|
exception
|
|
when Directory_Error =>
|
|
Fail_Program ("cannot open directory """ & Dir_Name & """");
|
|
end;
|
|
|
|
-- Process each regular file in the directory
|
|
|
|
File_Loop : loop
|
|
Read (Dir, Str, Last);
|
|
exit File_Loop when Last = 0;
|
|
|
|
-- Copy the file name and put it in canonical case to match
|
|
-- against the patterns that have themselves already been put
|
|
-- in canonical case.
|
|
|
|
Canon (1 .. Last) := Str (1 .. Last);
|
|
Canonical_Case_File_Name (Canon (1 .. Last));
|
|
|
|
if Is_Regular_File
|
|
(Dir_Name & Directory_Separator & Str (1 .. Last))
|
|
then
|
|
Matched := True;
|
|
|
|
Name_Len := Last;
|
|
Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
|
|
File_Name_Id := Name_Find;
|
|
|
|
-- First, check if the file name matches at least one of
|
|
-- the excluded expressions;
|
|
|
|
for Index in Excluded_Patterns'Range loop
|
|
if
|
|
Match (Canon (1 .. Last), Excluded_Patterns (Index))
|
|
then
|
|
Matched := Excluded;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
-- If it does not match any of the excluded expressions,
|
|
-- check if the file name matches at least one of the
|
|
-- regular expressions.
|
|
|
|
if Matched = True then
|
|
Matched := False;
|
|
|
|
for Index in Name_Patterns'Range loop
|
|
if
|
|
Match
|
|
(Canon (1 .. Last), Name_Patterns (Index))
|
|
then
|
|
Matched := True;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
|
|
if Very_Verbose
|
|
or else (Matched = True and then Opt.Verbose_Mode)
|
|
then
|
|
Output.Write_Str (" Checking """);
|
|
Output.Write_Str (Str (1 .. Last));
|
|
Output.Write_Line (""": ");
|
|
end if;
|
|
|
|
-- If the file name matches one of the regular expressions,
|
|
-- parse it to get its unit name.
|
|
|
|
if Matched = True then
|
|
declare
|
|
FD : File_Descriptor;
|
|
Success : Boolean;
|
|
Saved_Output : File_Descriptor;
|
|
Saved_Error : File_Descriptor;
|
|
Tmp_File : Path_Name_Type;
|
|
|
|
begin
|
|
-- If we don't have the path of the compiler yet,
|
|
-- get it now. The compiler name may have a prefix,
|
|
-- so we get the potentially prefixed name.
|
|
|
|
if Gcc_Path = null then
|
|
declare
|
|
Prefix_Gcc : String_Access :=
|
|
Program_Name (Gcc, "gnatname");
|
|
begin
|
|
Gcc_Path :=
|
|
Locate_Exec_On_Path (Prefix_Gcc.all);
|
|
Free (Prefix_Gcc);
|
|
end;
|
|
|
|
if Gcc_Path = null then
|
|
Fail_Program ("could not locate " & Gcc);
|
|
end if;
|
|
end if;
|
|
|
|
-- Create the temporary file
|
|
|
|
Tempdir.Create_Temp_File (FD, Tmp_File);
|
|
|
|
if FD = Invalid_FD then
|
|
Fail_Program
|
|
("could not create temporary file");
|
|
|
|
else
|
|
Temp_File_Name :=
|
|
new String'(Get_Name_String (Tmp_File));
|
|
end if;
|
|
|
|
Args (Args'Last) :=
|
|
new String'
|
|
(Dir_Name & Directory_Separator & Str (1 .. Last));
|
|
|
|
-- Save the standard output and error
|
|
|
|
Saved_Output := Dup (Standout);
|
|
Saved_Error := Dup (Standerr);
|
|
|
|
-- Set standard output and error to the temporary file
|
|
|
|
Dup2 (FD, Standout);
|
|
Dup2 (FD, Standerr);
|
|
|
|
-- And spawn the compiler
|
|
|
|
Spawn (Gcc_Path.all, Args.all, Success);
|
|
|
|
-- Restore the standard output and error
|
|
|
|
Dup2 (Saved_Output, Standout);
|
|
Dup2 (Saved_Error, Standerr);
|
|
|
|
-- Close the temporary file
|
|
|
|
Close (FD);
|
|
|
|
-- And close the saved standard output and error to
|
|
-- avoid too many file descriptors.
|
|
|
|
Close (Saved_Output);
|
|
Close (Saved_Error);
|
|
|
|
-- Now that standard output is restored, check if
|
|
-- the compiler ran correctly.
|
|
|
|
-- Read the lines of the temporary file:
|
|
-- they should contain the kind and name of the unit.
|
|
|
|
declare
|
|
File : Ada.Text_IO.File_Type;
|
|
Text_Line : String (1 .. 1_000);
|
|
Text_Last : Natural;
|
|
|
|
begin
|
|
begin
|
|
Open (File, In_File, Temp_File_Name.all);
|
|
|
|
exception
|
|
when others =>
|
|
Fail_Program
|
|
("could not read temporary file " &
|
|
Temp_File_Name.all);
|
|
end;
|
|
|
|
Save_Last_Source_Index := Sources.Last;
|
|
|
|
if End_Of_File (File) then
|
|
if Opt.Verbose_Mode then
|
|
if not Success then
|
|
Output.Write_Str (" (process died) ");
|
|
end if;
|
|
end if;
|
|
|
|
else
|
|
Line_Loop : while not End_Of_File (File) loop
|
|
Get_Line (File, Text_Line, Text_Last);
|
|
|
|
-- Find the first closing parenthesis
|
|
|
|
Char_Loop : for J in 1 .. Text_Last loop
|
|
if Text_Line (J) = ')' then
|
|
if J >= 13 and then
|
|
Text_Line (1 .. 4) = "Unit"
|
|
then
|
|
-- Add entry to Sources table
|
|
|
|
Name_Len := J - 12;
|
|
Name_Buffer (1 .. Name_Len) :=
|
|
Text_Line (6 .. J - 7);
|
|
Current_Source :=
|
|
(Unit_Name => Name_Find,
|
|
File_Name => File_Name_Id,
|
|
Index => 0,
|
|
Spec => Text_Line (J - 5 .. J) =
|
|
"(spec)");
|
|
|
|
Sources.Append (Current_Source);
|
|
end if;
|
|
|
|
exit Char_Loop;
|
|
end if;
|
|
end loop Char_Loop;
|
|
end loop Line_Loop;
|
|
end if;
|
|
|
|
if Save_Last_Source_Index = Sources.Last then
|
|
if Opt.Verbose_Mode then
|
|
Output.Write_Line (" not a unit");
|
|
end if;
|
|
|
|
else
|
|
if Sources.Last >
|
|
Save_Last_Source_Index + 1
|
|
then
|
|
for Index in Save_Last_Source_Index + 1 ..
|
|
Sources.Last
|
|
loop
|
|
Sources.Table (Index).Index :=
|
|
Int (Index - Save_Last_Source_Index);
|
|
end loop;
|
|
end if;
|
|
|
|
for Index in Save_Last_Source_Index + 1 ..
|
|
Sources.Last
|
|
loop
|
|
Current_Source := Sources.Table (Index);
|
|
pragma Annotate
|
|
(CodePeer, Modified, Current_Source);
|
|
|
|
if Opt.Verbose_Mode then
|
|
if Current_Source.Spec then
|
|
Output.Write_Str (" spec of ");
|
|
|
|
else
|
|
Output.Write_Str (" body of ");
|
|
end if;
|
|
|
|
Output.Write_Line
|
|
(Get_Name_String
|
|
(Current_Source.Unit_Name));
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
|
|
Close (File);
|
|
|
|
Delete_File (Temp_File_Name.all, Success);
|
|
end;
|
|
end;
|
|
|
|
-- File name matches none of the regular expressions
|
|
|
|
else
|
|
-- If file is not excluded, see if this is foreign source
|
|
|
|
if Matched /= Excluded then
|
|
for Index in Foreign_Patterns'Range loop
|
|
if Match (Canon (1 .. Last),
|
|
Foreign_Patterns (Index))
|
|
then
|
|
Matched := True;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
end if;
|
|
|
|
if Very_Verbose then
|
|
case Matched is
|
|
when False =>
|
|
Output.Write_Line ("no match");
|
|
|
|
when Excluded =>
|
|
Output.Write_Line ("excluded");
|
|
|
|
when True =>
|
|
Output.Write_Line ("foreign source");
|
|
end case;
|
|
end if;
|
|
|
|
if Matched = True then
|
|
|
|
-- Add source file name without unit name
|
|
|
|
Name_Len := 0;
|
|
Add_Str_To_Name_Buffer (Canon (1 .. Last));
|
|
Sources.Append
|
|
((File_Name => Name_Find,
|
|
Unit_Name => No_Name,
|
|
Index => 0,
|
|
Spec => False));
|
|
end if;
|
|
end if;
|
|
end if;
|
|
end loop File_Loop;
|
|
|
|
Close (Dir);
|
|
end if;
|
|
|
|
end Process_Directory;
|
|
|
|
-- Start of processing for Process
|
|
|
|
begin
|
|
Processed_Directories.Set_Last (0);
|
|
|
|
-- Process each directory
|
|
|
|
for Index in Directories'Range loop
|
|
Process_Directory (Directories (Index).all);
|
|
end loop;
|
|
end Process;
|
|
|
|
--------------------
|
|
-- Output_Version --
|
|
--------------------
|
|
|
|
procedure Output_Version is
|
|
begin
|
|
if not Version_Output then
|
|
Version_Output := True;
|
|
Output.Write_Eol;
|
|
Display_Version ("GNATNAME", "2001");
|
|
end if;
|
|
end Output_Version;
|
|
|
|
---------------
|
|
-- Scan_Args --
|
|
---------------
|
|
|
|
procedure Scan_Args is
|
|
|
|
procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
|
|
|
|
Project_File_Name_Expected : Boolean;
|
|
|
|
Pragmas_File_Expected : Boolean;
|
|
|
|
Directory_Expected : Boolean;
|
|
|
|
Dir_File_Name_Expected : Boolean;
|
|
|
|
Foreign_Pattern_Expected : Boolean;
|
|
|
|
Excluded_Pattern_Expected : Boolean;
|
|
|
|
procedure Check_Regular_Expression (S : String);
|
|
-- Compile string S into a Regexp, fail if any error
|
|
|
|
-----------------------------
|
|
-- Check_Regular_Expression--
|
|
-----------------------------
|
|
|
|
procedure Check_Regular_Expression (S : String) is
|
|
Dummy : Regexp;
|
|
pragma Warnings (Off, Dummy);
|
|
begin
|
|
Dummy := Compile (S, Glob => True);
|
|
exception
|
|
when Error_In_Regexp =>
|
|
Fail ("invalid regular expression """ & S & """");
|
|
end Check_Regular_Expression;
|
|
|
|
-- Start of processing for Scan_Args
|
|
|
|
begin
|
|
-- First check for --version or --help
|
|
|
|
Check_Version_And_Help ("GNATNAME", "2001");
|
|
|
|
-- Now scan the other switches
|
|
|
|
Project_File_Name_Expected := False;
|
|
Pragmas_File_Expected := False;
|
|
Directory_Expected := False;
|
|
Dir_File_Name_Expected := False;
|
|
Foreign_Pattern_Expected := False;
|
|
Excluded_Pattern_Expected := False;
|
|
|
|
for Next_Arg in 1 .. Argument_Count loop
|
|
declare
|
|
Next_Argv : constant String := Argument (Next_Arg);
|
|
Arg : String (1 .. Next_Argv'Length) := Next_Argv;
|
|
|
|
begin
|
|
if Arg'Length > 0 then
|
|
|
|
-- -P xxx
|
|
|
|
if Project_File_Name_Expected then
|
|
if Arg (1) = '-' then
|
|
Fail ("project file name missing");
|
|
|
|
else
|
|
File_Set := True;
|
|
File_Path := new String'(Arg);
|
|
Project_File_Name_Expected := False;
|
|
end if;
|
|
|
|
-- -c file
|
|
|
|
elsif Pragmas_File_Expected then
|
|
File_Set := True;
|
|
File_Path := new String'(Arg);
|
|
Pragmas_File_Expected := False;
|
|
|
|
-- -d xxx
|
|
|
|
elsif Directory_Expected then
|
|
Add_Source_Directory (Arg);
|
|
Directory_Expected := False;
|
|
|
|
-- -D xxx
|
|
|
|
elsif Dir_File_Name_Expected then
|
|
Get_Directories (Arg);
|
|
Dir_File_Name_Expected := False;
|
|
|
|
-- -f xxx
|
|
|
|
elsif Foreign_Pattern_Expected then
|
|
Patterns.Append
|
|
(Arguments.Table (Arguments.Last).Foreign_Patterns,
|
|
new String'(Arg));
|
|
Check_Regular_Expression (Arg);
|
|
Foreign_Pattern_Expected := False;
|
|
|
|
-- -x xxx
|
|
|
|
elsif Excluded_Pattern_Expected then
|
|
Patterns.Append
|
|
(Arguments.Table (Arguments.Last).Excluded_Patterns,
|
|
new String'(Arg));
|
|
Check_Regular_Expression (Arg);
|
|
Excluded_Pattern_Expected := False;
|
|
|
|
-- There must be at least one Ada pattern or one foreign
|
|
-- pattern for the previous section.
|
|
|
|
-- --and
|
|
|
|
elsif Arg = "--and" then
|
|
|
|
if Patterns.Last
|
|
(Arguments.Table (Arguments.Last).Name_Patterns) = 0
|
|
and then
|
|
Patterns.Last
|
|
(Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
|
|
then
|
|
Try_Help;
|
|
return;
|
|
end if;
|
|
|
|
-- If no directory were specified for the previous section,
|
|
-- then the directory is the project directory.
|
|
|
|
if Patterns.Last
|
|
(Arguments.Table (Arguments.Last).Directories) = 0
|
|
then
|
|
Patterns.Append
|
|
(Arguments.Table (Arguments.Last).Directories,
|
|
new String'("."));
|
|
end if;
|
|
|
|
-- Add and initialize another component to Arguments table
|
|
|
|
declare
|
|
New_Arguments : Argument_Data;
|
|
pragma Warnings (Off, New_Arguments);
|
|
-- Declaring this defaulted initialized object ensures
|
|
-- that the new allocated component of table Arguments
|
|
-- is correctly initialized.
|
|
|
|
-- This is VERY ugly, Table should never be used with
|
|
-- data requiring default initialization. We should
|
|
-- find a way to avoid violating this rule ???
|
|
|
|
begin
|
|
Arguments.Append (New_Arguments);
|
|
end;
|
|
|
|
Patterns.Init
|
|
(Arguments.Table (Arguments.Last).Directories);
|
|
Patterns.Set_Last
|
|
(Arguments.Table (Arguments.Last).Directories, 0);
|
|
Patterns.Init
|
|
(Arguments.Table (Arguments.Last).Name_Patterns);
|
|
Patterns.Set_Last
|
|
(Arguments.Table (Arguments.Last).Name_Patterns, 0);
|
|
Patterns.Init
|
|
(Arguments.Table (Arguments.Last).Excluded_Patterns);
|
|
Patterns.Set_Last
|
|
(Arguments.Table (Arguments.Last).Excluded_Patterns, 0);
|
|
Patterns.Init
|
|
(Arguments.Table (Arguments.Last).Foreign_Patterns);
|
|
Patterns.Set_Last
|
|
(Arguments.Table (Arguments.Last).Foreign_Patterns, 0);
|
|
|
|
-- Subdirectory switch
|
|
|
|
elsif Arg'Length > Subdirs_Switch'Length
|
|
and then Arg (1 .. Subdirs_Switch'Length) = Subdirs_Switch
|
|
then
|
|
null;
|
|
-- Subdirs are only used in gprname
|
|
|
|
-- --no-backup
|
|
|
|
elsif Arg = "--no-backup" then
|
|
Opt.No_Backup := True;
|
|
|
|
-- -c
|
|
|
|
elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-c" then
|
|
if File_Set then
|
|
Fail ("only one -P or -c switch may be specified");
|
|
end if;
|
|
|
|
if Arg'Length = 2 then
|
|
Pragmas_File_Expected := True;
|
|
|
|
if Next_Arg = Argument_Count then
|
|
Fail ("configuration pragmas file name missing");
|
|
end if;
|
|
|
|
else
|
|
File_Set := True;
|
|
File_Path := new String'(Arg (3 .. Arg'Last));
|
|
end if;
|
|
|
|
-- -d
|
|
|
|
elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then
|
|
if Arg'Length = 2 then
|
|
Directory_Expected := True;
|
|
|
|
if Next_Arg = Argument_Count then
|
|
Fail ("directory name missing");
|
|
end if;
|
|
|
|
else
|
|
Add_Source_Directory (Arg (3 .. Arg'Last));
|
|
end if;
|
|
|
|
-- -D
|
|
|
|
elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then
|
|
if Arg'Length = 2 then
|
|
Dir_File_Name_Expected := True;
|
|
|
|
if Next_Arg = Argument_Count then
|
|
Fail ("directory list file name missing");
|
|
end if;
|
|
|
|
else
|
|
Get_Directories (Arg (3 .. Arg'Last));
|
|
end if;
|
|
|
|
-- -eL
|
|
|
|
elsif Arg = "-eL" then
|
|
Opt.Follow_Links_For_Files := True;
|
|
Opt.Follow_Links_For_Dirs := True;
|
|
|
|
-- -f
|
|
|
|
elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then
|
|
if Arg'Length = 2 then
|
|
Foreign_Pattern_Expected := True;
|
|
|
|
if Next_Arg = Argument_Count then
|
|
Fail ("foreign pattern missing");
|
|
end if;
|
|
|
|
else
|
|
Patterns.Append
|
|
(Arguments.Table (Arguments.Last).Foreign_Patterns,
|
|
new String'(Arg (3 .. Arg'Last)));
|
|
Check_Regular_Expression (Arg (3 .. Arg'Last));
|
|
end if;
|
|
|
|
-- -gnatep or -gnateD
|
|
|
|
elsif Arg'Length > 7 and then
|
|
(Arg (1 .. 7) = "-gnatep" or else Arg (1 .. 7) = "-gnateD")
|
|
then
|
|
Preprocessor_Switches.Append (new String'(Arg));
|
|
|
|
-- -h
|
|
|
|
elsif Arg = "-h" then
|
|
Usage_Needed := True;
|
|
|
|
-- -P
|
|
|
|
elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then
|
|
if File_Set then
|
|
Fail ("only one -c or -P switch may be specified");
|
|
end if;
|
|
|
|
if Arg'Length = 2 then
|
|
if Next_Arg = Argument_Count then
|
|
Fail ("project file name missing");
|
|
|
|
else
|
|
Project_File_Name_Expected := True;
|
|
end if;
|
|
|
|
else
|
|
File_Set := True;
|
|
File_Path := new String'(Arg (3 .. Arg'Last));
|
|
end if;
|
|
|
|
Create_Project := True;
|
|
|
|
-- -v
|
|
|
|
elsif Arg = "-v" then
|
|
if Opt.Verbose_Mode then
|
|
Very_Verbose := True;
|
|
else
|
|
Opt.Verbose_Mode := True;
|
|
end if;
|
|
|
|
-- -x
|
|
|
|
elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then
|
|
if Arg'Length = 2 then
|
|
Excluded_Pattern_Expected := True;
|
|
|
|
if Next_Arg = Argument_Count then
|
|
Fail ("excluded pattern missing");
|
|
end if;
|
|
|
|
else
|
|
Patterns.Append
|
|
(Arguments.Table (Arguments.Last).Excluded_Patterns,
|
|
new String'(Arg (3 .. Arg'Last)));
|
|
Check_Regular_Expression (Arg (3 .. Arg'Last));
|
|
end if;
|
|
|
|
-- Junk switch starting with minus
|
|
|
|
elsif Arg (1) = '-' then
|
|
Fail ("wrong switch: " & Arg);
|
|
|
|
-- Not a recognized switch, assume file name
|
|
|
|
else
|
|
Canonical_Case_File_Name (Arg);
|
|
Patterns.Append
|
|
(Arguments.Table (Arguments.Last).Name_Patterns,
|
|
new String'(Arg));
|
|
Check_Regular_Expression (Arg);
|
|
end if;
|
|
end if;
|
|
end;
|
|
end loop;
|
|
end Scan_Args;
|
|
|
|
-----------
|
|
-- Usage --
|
|
-----------
|
|
|
|
procedure Usage is
|
|
begin
|
|
if not Usage_Output then
|
|
Usage_Needed := False;
|
|
Usage_Output := True;
|
|
Output.Write_Str ("Usage: ");
|
|
Osint.Write_Program_Name;
|
|
Output.Write_Line (" [switches] naming-pattern [naming-patterns]");
|
|
Output.Write_Line
|
|
(" {--and [switches] naming-pattern [naming-patterns]}");
|
|
Output.Write_Eol;
|
|
Output.Write_Line ("switches:");
|
|
|
|
Display_Usage_Version_And_Help;
|
|
|
|
Output.Write_Line
|
|
(" --subdirs=dir real obj/lib/exec dirs are subdirs");
|
|
Output.Write_Line
|
|
(" --no-backup do not create backup of project file");
|
|
Output.Write_Eol;
|
|
|
|
Output.Write_Line (" --and use different patterns");
|
|
Output.Write_Eol;
|
|
|
|
Output.Write_Line
|
|
(" -cfile create configuration pragmas file");
|
|
Output.Write_Line (" -ddir use dir as one of the source " &
|
|
"directories");
|
|
Output.Write_Line (" -Dfile get source directories from file");
|
|
Output.Write_Line
|
|
(" -eL follow symbolic links when processing " &
|
|
"project files");
|
|
Output.Write_Line (" -fpat foreign pattern");
|
|
Output.Write_Line
|
|
(" -gnateDsym=v preprocess with symbol definition");
|
|
Output.Write_Line (" -gnatep=data preprocess files with data file");
|
|
Output.Write_Line (" -h output this help message");
|
|
Output.Write_Line
|
|
(" -Pproj update or create project file proj");
|
|
Output.Write_Line (" -v verbose output");
|
|
Output.Write_Line (" -v -v very verbose output");
|
|
Output.Write_Line (" -xpat exclude pattern pat");
|
|
end if;
|
|
end Usage;
|
|
|
|
---------------
|
|
-- Write_Eol --
|
|
---------------
|
|
|
|
procedure Write_Eol is
|
|
begin
|
|
Write_A_String ((1 => ASCII.LF));
|
|
end Write_Eol;
|
|
|
|
--------------------
|
|
-- Write_A_String --
|
|
--------------------
|
|
|
|
procedure Write_A_String (S : String) is
|
|
Str : String (1 .. S'Length);
|
|
|
|
begin
|
|
if S'Length > 0 then
|
|
Str := S;
|
|
|
|
if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
|
|
Fail_Program ("disk full");
|
|
end if;
|
|
end if;
|
|
end Write_A_String;
|
|
|
|
-- Start of processing for Gnatname
|
|
|
|
begin
|
|
-- Add the directory where gnatname is invoked in front of the
|
|
-- path, if gnatname is invoked with directory information.
|
|
|
|
declare
|
|
Command : constant String := Command_Name;
|
|
|
|
begin
|
|
for Index in reverse Command'Range loop
|
|
if Command (Index) = Directory_Separator then
|
|
declare
|
|
Absolute_Dir : constant String :=
|
|
Normalize_Pathname
|
|
(Command (Command'First .. Index));
|
|
|
|
PATH : constant String :=
|
|
Absolute_Dir &
|
|
Path_Separator &
|
|
Getenv ("PATH").all;
|
|
|
|
begin
|
|
Setenv ("PATH", PATH);
|
|
end;
|
|
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
end;
|
|
|
|
-- Initialize tables
|
|
|
|
Arguments.Set_Last (0);
|
|
declare
|
|
New_Arguments : Argument_Data;
|
|
pragma Warnings (Off, New_Arguments);
|
|
-- Declaring this defaulted initialized object ensures that the new
|
|
-- allocated component of table Arguments is correctly initialized.
|
|
begin
|
|
Arguments.Append (New_Arguments);
|
|
end;
|
|
|
|
Patterns.Init (Arguments.Table (1).Directories);
|
|
Patterns.Set_Last (Arguments.Table (1).Directories, 0);
|
|
Patterns.Init (Arguments.Table (1).Name_Patterns);
|
|
Patterns.Set_Last (Arguments.Table (1).Name_Patterns, 0);
|
|
Patterns.Init (Arguments.Table (1).Excluded_Patterns);
|
|
Patterns.Set_Last (Arguments.Table (1).Excluded_Patterns, 0);
|
|
Patterns.Init (Arguments.Table (1).Foreign_Patterns);
|
|
Patterns.Set_Last (Arguments.Table (1).Foreign_Patterns, 0);
|
|
|
|
Preprocessor_Switches.Set_Last (0);
|
|
|
|
-- Get the arguments
|
|
|
|
Scan_Args;
|
|
|
|
if Create_Project then
|
|
declare
|
|
Gprname_Path : constant String_Access :=
|
|
Locate_Exec_On_Path ("gprname");
|
|
Arg_Len : Natural := Argument_Count;
|
|
Pos : Natural := 0;
|
|
Target : String_Access := null;
|
|
Success : Boolean := False;
|
|
begin
|
|
if Gprname_Path = null then
|
|
Fail_Program
|
|
("project files are no longer supported by gnatname;" &
|
|
" use gprname instead");
|
|
end if;
|
|
|
|
Find_Program_Name;
|
|
|
|
if Name_Len > 9
|
|
and then Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatname"
|
|
then
|
|
Target := new String'(Name_Buffer (1 .. Name_Len - 9));
|
|
Arg_Len := Arg_Len + 1;
|
|
end if;
|
|
|
|
declare
|
|
Args : Argument_List (1 .. Arg_Len);
|
|
begin
|
|
if Target /= null then
|
|
Args (1) := new String'("--target=" & Target.all);
|
|
Pos := 1;
|
|
end if;
|
|
|
|
for J in 1 .. Argument_Count loop
|
|
Pos := Pos + 1;
|
|
Args (Pos) := new String'(Argument (J));
|
|
end loop;
|
|
|
|
Spawn (Gprname_Path.all, Args, Success);
|
|
|
|
if Success then
|
|
Exit_Program (E_Success);
|
|
else
|
|
Exit_Program (E_Errors);
|
|
end if;
|
|
end;
|
|
end;
|
|
end if;
|
|
|
|
if Opt.Verbose_Mode then
|
|
Output_Version;
|
|
end if;
|
|
|
|
if Usage_Needed then
|
|
Usage;
|
|
end if;
|
|
|
|
-- If no Ada or foreign pattern was specified, print the usage and return
|
|
|
|
if Patterns.Last (Arguments.Table (Arguments.Last).Name_Patterns) = 0
|
|
and then
|
|
Patterns.Last (Arguments.Table (Arguments.Last).Foreign_Patterns) = 0
|
|
then
|
|
if Argument_Count = 0 then
|
|
Usage;
|
|
elsif not Usage_Output then
|
|
Try_Help;
|
|
end if;
|
|
|
|
return;
|
|
end if;
|
|
|
|
-- If no source directory was specified, use the current directory as the
|
|
-- unique directory. Note that if a file was specified with directory
|
|
-- information, the current directory is the directory of the specified
|
|
-- file.
|
|
|
|
if Patterns.Last (Arguments.Table (Arguments.Last).Directories) = 0 then
|
|
Patterns.Append
|
|
(Arguments.Table (Arguments.Last).Directories, new String'("."));
|
|
end if;
|
|
|
|
-- Initialize
|
|
|
|
declare
|
|
Prep_Switches : Argument_List
|
|
(1 .. Integer (Preprocessor_Switches.Last));
|
|
|
|
begin
|
|
for Index in Prep_Switches'Range loop
|
|
Prep_Switches (Index) := Preprocessor_Switches.Table (Index);
|
|
end loop;
|
|
|
|
Initialize
|
|
(File_Path => File_Path.all,
|
|
Preproc_Switches => Prep_Switches);
|
|
end;
|
|
|
|
-- Process each section successively
|
|
|
|
for J in 1 .. Arguments.Last loop
|
|
declare
|
|
Directories : Argument_List
|
|
(1 .. Integer
|
|
(Patterns.Last (Arguments.Table (J).Directories)));
|
|
Name_Patterns : Regexp_List
|
|
(1 .. Integer
|
|
(Patterns.Last (Arguments.Table (J).Name_Patterns)));
|
|
Excl_Patterns : Regexp_List
|
|
(1 .. Integer
|
|
(Patterns.Last (Arguments.Table (J).Excluded_Patterns)));
|
|
Frgn_Patterns : Regexp_List
|
|
(1 .. Integer
|
|
(Patterns.Last (Arguments.Table (J).Foreign_Patterns)));
|
|
|
|
begin
|
|
-- Build the Directories and Patterns arguments
|
|
|
|
for Index in Directories'Range loop
|
|
Directories (Index) :=
|
|
Arguments.Table (J).Directories.Table (Index);
|
|
end loop;
|
|
|
|
for Index in Name_Patterns'Range loop
|
|
Name_Patterns (Index) :=
|
|
Compile
|
|
(Arguments.Table (J).Name_Patterns.Table (Index).all,
|
|
Glob => True);
|
|
end loop;
|
|
|
|
for Index in Excl_Patterns'Range loop
|
|
Excl_Patterns (Index) :=
|
|
Compile
|
|
(Arguments.Table (J).Excluded_Patterns.Table (Index).all,
|
|
Glob => True);
|
|
end loop;
|
|
|
|
for Index in Frgn_Patterns'Range loop
|
|
Frgn_Patterns (Index) :=
|
|
Compile
|
|
(Arguments.Table (J).Foreign_Patterns.Table (Index).all,
|
|
Glob => True);
|
|
end loop;
|
|
|
|
-- Call Prj.Makr.Process where the real work is done
|
|
|
|
Process
|
|
(Directories => Directories,
|
|
Name_Patterns => Name_Patterns,
|
|
Excluded_Patterns => Excl_Patterns,
|
|
Foreign_Patterns => Frgn_Patterns);
|
|
end;
|
|
end loop;
|
|
|
|
-- Finalize
|
|
|
|
Finalize;
|
|
|
|
if Opt.Verbose_Mode then
|
|
Output.Write_Eol;
|
|
end if;
|
|
end Gnatname;
|