with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Csets;
with MLib.Tgt; use MLib.Tgt;
with MLib.Utl;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
with Output;
with Prj; use Prj;
with Prj.Com;
with Prj.Env;
with Prj.Ext; use Prj.Ext;
with Prj.Pars;
with Prj.Util; use Prj.Util;
with Sinput.P;
with Snames; use Snames;
with Table;
with Types; use Types;
with Hostparm; use Hostparm;
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.OS_Lib; use GNAT.OS_Lib;
with Table;
with VMS_Conv; use VMS_Conv;
procedure GNATCmd is
Project_File : String_Access;
Project : Prj.Project_Id;
Current_Verbosity : Prj.Verbosity := Prj.Default;
Tool_Package_Name : Name_Id := No_Name;
Old_Project_File_Used : Boolean := False;
Max_Files_On_The_Command_Line : constant := 30;
Temp_File_Name : String_Access := null;
package First_Switches is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 100,
Table_Name => "Gnatcmd.First_Switches");
package Library_Paths is new Table.Table (
Table_Component_Type => String_Access,
Table_Index_Type => Integer,
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 100,
Table_Name => "Make.Library_Path");
Naming_String : constant String_Access := new String'("naming");
Binder_String : constant String_Access := new String'("binder");
Eliminate_String : constant String_Access := new String'("eliminate");
Finder_String : constant String_Access := new String'("finder");
Linker_String : constant String_Access := new String'("linker");
Gnatls_String : constant String_Access := new String'("gnatls");
Pretty_String : constant String_Access := new String'("pretty_printer");
Gnatstub_String : constant String_Access := new String'("gnatstub");
Metric_String : constant String_Access := new String'("metrics");
Xref_String : constant String_Access := new String'("cross_reference");
Packages_To_Check_By_Binder : constant String_List_Access :=
new String_List'((Naming_String, Binder_String));
Packages_To_Check_By_Eliminate : constant String_List_Access :=
new String_List'((Naming_String, Eliminate_String));
Packages_To_Check_By_Finder : constant String_List_Access :=
new String_List'((Naming_String, Finder_String));
Packages_To_Check_By_Linker : constant String_List_Access :=
new String_List'((Naming_String, Linker_String));
Packages_To_Check_By_Gnatls : constant String_List_Access :=
new String_List'((Naming_String, Gnatls_String));
Packages_To_Check_By_Pretty : constant String_List_Access :=
new String_List'((Naming_String, Pretty_String));
Packages_To_Check_By_Gnatstub : constant String_List_Access :=
new String_List'((Naming_String, Gnatstub_String));
Packages_To_Check_By_Metric : constant String_List_Access :=
new String_List'((Naming_String, Metric_String));
Packages_To_Check_By_Xref : constant String_List_Access :=
new String_List'((Naming_String, Xref_String));
Packages_To_Check : String_List_Access := Prj.All_Packages;
The_Command : Command_Type;
Command_Arg : Positive := 1;
My_Exit_Status : Exit_Status := Success;
Current_Work_Dir : constant String := Get_Current_Dir;
procedure Check_Files;
function Check_Project
(Project : Project_Id;
Root_Project : Project_Id) return Boolean;
procedure Check_Relative_Executable (Name : in out String_Access);
function Configuration_Pragmas_File return Name_Id;
procedure Delete_Temp_Config_Files;
function Index (Char : Character; Str : String) return Natural;
procedure Non_VMS_Usage;
procedure Process_Link;
procedure Set_Library_For
(Project : Project_Id;
There_Are_Libraries : in out Boolean);
procedure Set_Libraries is
new For_Every_Project_Imported (Boolean, Set_Library_For);
procedure Test_If_Relative_Path
(Switch : in out String_Access;
Parent : String);
procedure Check_Files is
Add_Sources : Boolean := True;
Unit_Data : Prj.Com.Unit_Data;
Subunit : Boolean := False;
begin
for Index in 1 .. Last_Switches.Last loop
if Last_Switches.Table (Index) (1) /= '-' then
Add_Sources := False;
exit;
end if;
end loop;
if Add_Sources then
declare
Current_Last : constant Integer := Last_Switches.Last;
use Prj.Com;
begin
for Unit in 1 .. Prj.Com.Units.Last loop
Unit_Data := Prj.Com.Units.Table (Unit);
if The_Command = List then
if
Unit_Data.File_Names (Body_Part).Name /= No_Name
then
if Unit_Data.File_Names (Body_Part).Project =
Project
then
Subunit := False;
if Unit_Data.File_Names (Specification).Name =
No_Name
then
declare
Src_Ind : Source_File_Index;
begin
Src_Ind := Sinput.P.Load_Project_File
(Get_Name_String
(Unit_Data.File_Names
(Body_Part).Path));
Subunit :=
Sinput.P.Source_File_Is_Subunit
(Src_Ind);
end;
end if;
if not Subunit then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'
(Get_Name_String
(Unit_Data.File_Names
(Body_Part).Display_Name));
end if;
end if;
elsif Unit_Data.File_Names (Specification).Name /=
No_Name
then
if Unit_Data.File_Names (Specification).Project =
Project
then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'
(Get_Name_String
(Unit_Data.File_Names
(Specification).Display_Name));
end if;
end if;
else
for Kind in Prj.Com.Spec_Or_Body loop
if Check_Project
(Unit_Data.File_Names (Kind).Project, Project)
then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'
(Get_Name_String
(Unit_Data.File_Names
(Kind).Display_Path));
end if;
end loop;
end if;
end loop;
if Last_Switches.Last - Current_Last >
Max_Files_On_The_Command_Line
then
declare
Temp_File_FD : File_Descriptor;
Buffer : String (1 .. 1_000);
Len : Natural;
OK : Boolean := True;
begin
Create_Temp_File (Temp_File_FD, Temp_File_Name);
if Temp_File_Name /= null then
for Index in Current_Last + 1 ..
Last_Switches.Last
loop
Len := Last_Switches.Table (Index)'Length;
Buffer (1 .. Len) :=
Last_Switches.Table (Index).all;
Len := Len + 1;
Buffer (Len) := ASCII.LF;
Buffer (Len + 1) := ASCII.NUL;
OK :=
Write (Temp_File_FD,
Buffer (1)'Address,
Len) = Len;
exit when not OK;
end loop;
if OK then
Close (Temp_File_FD, OK);
else
Close (Temp_File_FD, OK);
OK := False;
end if;
if OK then
Last_Switches.Set_Last (Current_Last + 1);
Last_Switches.Table (Last_Switches.Last) :=
new String'("-files=" & Temp_File_Name.all);
end if;
end if;
end;
end if;
end;
end if;
end Check_Files;
function Check_Project
(Project : Project_Id;
Root_Project : Project_Id) return Boolean
is
begin
if Project = Root_Project then
return True;
elsif The_Command = Metric then
declare
Data : Project_Data := Projects.Table (Root_Project);
begin
while Data.Extends /= No_Project loop
if Project = Data.Extends then
return True;
end if;
Data := Projects.Table (Data.Extends);
end loop;
end;
end if;
return False;
end Check_Project;
procedure Check_Relative_Executable (Name : in out String_Access) is
Exec_File_Name : constant String := Name.all;
begin
if not Is_Absolute_Path (Exec_File_Name) then
for Index in Exec_File_Name'Range loop
if Exec_File_Name (Index) = Directory_Separator then
Fail ("relative executable (""" &
Exec_File_Name &
""") with directory part not allowed " &
"when using project files");
end if;
end loop;
Get_Name_String (Projects.Table
(Project).Exec_Directory);
if Name_Buffer (Name_Len) /= Directory_Separator then
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Directory_Separator;
end if;
Name_Buffer (Name_Len + 1 ..
Name_Len + Exec_File_Name'Length) :=
Exec_File_Name;
Name_Len := Name_Len + Exec_File_Name'Length;
Name := new String'(Name_Buffer (1 .. Name_Len));
end if;
end Check_Relative_Executable;
function Configuration_Pragmas_File return Name_Id is
begin
Prj.Env.Create_Config_Pragmas_File
(Project, Project, Include_Config_Files => False);
return Projects.Table (Project).Config_File_Name;
end Configuration_Pragmas_File;
procedure Delete_Temp_Config_Files is
Success : Boolean;
begin
if not Keep_Temporary_Files then
if Project /= No_Project then
for Prj in 1 .. Projects.Last loop
if Projects.Table (Prj).Config_File_Temp then
if Verbose_Mode then
Output.Write_Str ("Deleting temp configuration file """);
Output.Write_Str
(Get_Name_String
(Projects.Table (Prj).Config_File_Name));
Output.Write_Line ("""");
end if;
Delete_File
(Name => Get_Name_String
(Projects.Table (Prj).Config_File_Name),
Success => Success);
end if;
end loop;
end if;
if Temp_File_Name /= null then
Delete_File (Temp_File_Name.all, Success);
end if;
end if;
end Delete_Temp_Config_Files;
function Index (Char : Character; Str : String) return Natural is
begin
for Index in Str'Range loop
if Str (Index) = Char then
return Index;
end if;
end loop;
return 0;
end Index;
procedure Process_Link is
Look_For_Executable : Boolean := True;
There_Are_Libraries : Boolean := False;
Path_Option : constant String_Access :=
MLib.Linker_Library_Path_Option;
Prj : Project_Id := Project;
Arg : String_Access;
Last : Natural := 0;
Skip_Executable : Boolean := False;
begin
Add_Default_Search_Dirs;
Library_Paths.Set_Last (0);
if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
Set_Libraries (Project, There_Are_Libraries);
end if;
if There_Are_Libraries then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-L" & MLib.Utl.Lib_Directory);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-lgnarl");
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-lgnat");
if Path_Option /= null then
declare
Option : String_Access;
Length : Natural := Path_Option'Length;
Current : Natural;
begin
for Index in
Library_Paths.First .. Library_Paths.Last
loop
Length :=
Length +
Library_Paths.Table (Index)'Length + 1;
end loop;
Length := Length + MLib.Utl.Lib_Directory'Length;
Option := new String (1 .. Length);
Option (1 .. Path_Option'Length) := Path_Option.all;
Current := Path_Option'Length;
for Index in
Library_Paths.First .. Library_Paths.Last
loop
Option
(Current + 1 ..
Current +
Library_Paths.Table (Index)'Length) :=
Library_Paths.Table (Index).all;
Current :=
Current +
Library_Paths.Table (Index)'Length + 1;
Option (Current) := Path_Separator;
end loop;
Option
(Current + 1 ..
Current + MLib.Utl.Lib_Directory'Length) :=
MLib.Utl.Lib_Directory;
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
Option;
end;
end if;
end if;
Skip_Executable := False;
Switch_Loop : for J in 1 .. Last_Switches.Last loop
if Skip_Executable then
Skip_Executable := False;
elsif Last_Switches.Table (J).all = "-o" then
Skip_Executable := True;
else
declare
Switch : constant String :=
Last_Switches.Table (J).all;
ALI_File : constant String (1 .. Switch'Length + 4) :=
Switch & ".ali";
Test_Existence : Boolean := False;
begin
Last := Switch'Length;
if Switch'Length /= 0
and then Switch (Switch'First) /= '-'
then
if Switch'Length <= 4
or else Switch (Switch'Last - 3 .. Switch'Last)
/= ".ali"
then
Last := ALI_File'Last;
end if;
if Is_Absolute_Path (ALI_File (1 .. Last)) then
Test_Existence := True;
else
for K in Switch'Range loop
if Switch (K) = '/' or else
Switch (K) = Directory_Separator
then
Test_Existence := True;
exit;
end if;
end loop;
end if;
if Test_Existence then
if Is_Regular_File (ALI_File (1 .. Last)) then
exit Switch_Loop;
end if;
else
Project_Loop : loop
declare
Dir : constant String :=
Get_Name_String
(Projects.Table (Prj).
Object_Directory);
begin
if Is_Regular_File
(Dir &
Directory_Separator &
ALI_File (1 .. Last))
then
Last_Switches.Table (J) :=
new String'
(Dir & Directory_Separator &
ALI_File (1 .. Last));
exit Switch_Loop;
end if;
end;
Prj := Projects.Table (Prj).Extends;
exit Project_Loop when Prj = No_Project;
end loop Project_Loop;
end if;
end if;
end;
end if;
end loop Switch_Loop;
for J in reverse 1 .. Last_Switches.Last - 1 loop
if Last_Switches.Table (J).all = "-o" then
Check_Relative_Executable
(Name => Last_Switches.Table (J + 1));
Look_For_Executable := False;
exit;
end if;
end loop;
if Look_For_Executable then
for J in reverse 1 .. First_Switches.Last - 1 loop
if First_Switches.Table (J).all = "-o" then
Look_For_Executable := False;
Check_Relative_Executable
(Name => First_Switches.Table (J + 1));
exit;
end if;
end loop;
end if;
if Look_For_Executable then
for J in 1 .. Last_Switches.Last loop
Arg := Last_Switches.Table (J);
Last := 0;
if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
if Arg'Length > 4
and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
then
Last := Arg'Last - 4;
elsif Is_Regular_File (Arg.all & ".ali") then
Last := Arg'Last;
end if;
if Last /= 0 then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-o");
Get_Name_String
(Projects.Table (Project).Exec_Directory);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(Name_Buffer (1 .. Name_Len) &
Directory_Separator &
Base_Name (Arg (Arg'First .. Last)) &
Get_Executable_Suffix.all);
exit;
end if;
end if;
end loop;
end if;
end Process_Link;
procedure Set_Library_For
(Project : Project_Id;
There_Are_Libraries : in out Boolean)
is
Path_Option : constant String_Access :=
MLib.Linker_Library_Path_Option;
begin
if Projects.Table (Project).Library then
There_Are_Libraries := True;
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-L" &
Get_Name_String
(Projects.Table (Project).Library_Dir));
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-l" &
Get_Name_String
(Projects.Table (Project).Library_Name));
if Projects.Table (Project).Library_Kind /= Static
and then Path_Option /= null
then
Library_Paths.Increment_Last;
Library_Paths.Table (Library_Paths.Last) :=
new String'(Get_Name_String
(Projects.Table (Project).Library_Dir));
end if;
end if;
end Set_Library_For;
procedure Test_If_Relative_Path
(Switch : in out String_Access;
Parent : String)
is
begin
if Switch /= null then
declare
Sw : String (1 .. Switch'Length);
Start : Positive := 1;
begin
Sw := Switch.all;
if Sw (1) = '-' then
if Sw'Length >= 3
and then (Sw (2) = 'A' or else
Sw (2) = 'I' or else
Sw (2) = 'L')
then
Start := 3;
if Sw = "-I-" then
return;
end if;
elsif Sw'Length >= 4
and then (Sw (2 .. 3) = "aL" or else
Sw (2 .. 3) = "aO" or else
Sw (2 .. 3) = "aI")
then
Start := 4;
elsif Sw'Length >= 7
and then Sw (2 .. 6) = "-RTS="
then
Start := 7;
else
return;
end if;
end if;
if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
for J in Start .. Sw'Last loop
if Sw (J) = Directory_Separator then
Switch :=
new String'
(Sw (1 .. Start - 1) &
Parent &
Directory_Separator &
Sw (Start .. Sw'Last));
return;
end if;
end loop;
end if;
end;
end if;
end Test_If_Relative_Path;
procedure Non_VMS_Usage is
begin
Output_Version;
New_Line;
Put_Line ("List of available commands");
New_Line;
for C in Command_List'Range loop
if not Command_List (C).VMS_Only then
Put ("gnat " & To_Lower (Command_List (C).Cname.all));
Set_Col (25);
Put (Command_List (C).Unixcmd.all);
declare
Sws : Argument_List_Access renames Command_List (C).Unixsws;
begin
if Sws /= null then
for J in Sws'Range loop
Put (' ');
Put (Sws (J).all);
end loop;
end if;
end;
New_Line;
end if;
end loop;
New_Line;
Put_Line ("Commands find, list, metric, pretty, stub and xref accept " &
"project file switches -vPx, -Pprj and -Xnam=val");
New_Line;
end Non_VMS_Usage;
begin
Namet.Initialize;
Csets.Initialize;
Snames.Initialize;
Prj.Initialize;
Last_Switches.Init;
Last_Switches.Set_Last (0);
First_Switches.Init;
First_Switches.Set_Last (0);
VMS_Conv.Initialize;
if not OpenVMS then
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;
end if;
if Hostparm.OpenVMS
or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
then
VMS_Conversion (The_Command);
else
if Argument_Count = 0 then
Non_VMS_Usage;
return;
else
begin
loop
if Argument_Count > Command_Arg
and then Argument (Command_Arg) = "-v"
then
Verbose_Mode := True;
Command_Arg := Command_Arg + 1;
elsif Argument_Count > Command_Arg
and then Argument (Command_Arg) = "-dn"
then
Keep_Temporary_Files := True;
Command_Arg := Command_Arg + 1;
else
exit;
end if;
end loop;
The_Command := Real_Command_Type'Value (Argument (Command_Arg));
if Command_List (The_Command).VMS_Only then
Non_VMS_Usage;
Fail
("Command """,
Command_List (The_Command).Cname.all,
""" can only be used on VMS");
end if;
exception
when Constraint_Error =>
declare
Alternate : Alternate_Command;
begin
Alternate := Alternate_Command'Value
(Argument (Command_Arg));
The_Command := Corresponding_To (Alternate);
exception
when Constraint_Error =>
Non_VMS_Usage;
Fail ("Unknown command: ", Argument (Command_Arg));
end;
end;
for Arg in Command_Arg + 1 .. Argument_Count loop
declare
The_Arg : constant String := Argument (Arg);
begin
if The_Arg (The_Arg'First) = '@' then
declare
Arg_File : Ada.Text_IO.File_Type;
Line : String (1 .. 256);
Last : Natural;
begin
begin
Open
(Arg_File, In_File,
The_Arg (The_Arg'First + 1 .. The_Arg'Last));
exception
when others =>
Put
(Standard_Error, "Cannot open argument file """);
Put
(Standard_Error,
The_Arg (The_Arg'First + 1 .. The_Arg'Last));
Put_Line (Standard_Error, """");
raise Error_Exit;
end;
while not End_Of_File (Arg_File) loop
Get_Line (Arg_File, Line, Last);
if Last /= 0 then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(Line (1 .. Last));
end if;
end loop;
Close (Arg_File);
end;
else
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(The_Arg);
end if;
end;
end loop;
end if;
end if;
declare
Program : constant String :=
Program_Name (Command_List (The_Command).Unixcmd.all).all;
Exec_Path : String_Access;
begin
if The_Command = Setup then
Process_Setup :
declare
Arg_Num : Positive := 1;
Argv : String_Access;
begin
while Arg_Num <= Last_Switches.Last loop
Argv := Last_Switches.Table (Arg_Num);
if Argv (Argv'First) /= '-' then
Fail ("invalid parameter """, Argv.all, """");
else
if Argv'Length = 1 then
Fail
("switch character cannot be followed by a blank");
end if;
if Argv'Length = 4
and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
then
case Argv (Argv'Last) is
when '0' =>
Current_Verbosity := Prj.Default;
when '1' =>
Current_Verbosity := Prj.Medium;
when '2' =>
Current_Verbosity := Prj.High;
when others =>
Fail ("Invalid switch: ", Argv.all);
end case;
elsif Argv (Argv'First + 1) = 'P' then
if Project_File /= null then
Fail
(Argv.all,
": second project file forbidden (first is """,
Project_File.all & """)");
elsif Argv'Length = 2 then
if Arg_Num = Last_Switches.Last then
Fail ("project file name missing after -P");
else
Arg_Num := Arg_Num + 1;
Argv := Last_Switches.Table (Arg_Num);
if Argv (Argv'First) = '-' then
Fail ("project file name missing after -P");
else
Project_File := new String'(Argv.all);
end if;
end if;
else
Project_File :=
new String'(Argv (Argv'First + 2 .. Argv'Last));
end if;
elsif Argv'Length >= 5
and then Argv (Argv'First + 1) = 'X'
then
declare
Equal_Pos : constant Natural :=
Index ('=', Argv (Argv'First + 2 .. Argv'Last));
begin
if Equal_Pos >= Argv'First + 3 and then
Equal_Pos /= Argv'Last then
Add
(External_Name =>
Argv (Argv'First + 2 .. Equal_Pos - 1),
Value => Argv (Equal_Pos + 1 .. Argv'Last));
else
Fail
(Argv.all,
" is not a valid external assignment.");
end if;
end;
elsif Argv.all = "-v" then
Verbose_Mode := True;
elsif Argv.all = "-q" then
Quiet_Output := True;
else
Fail ("invalid parameter """, Argv.all, """");
end if;
end if;
Arg_Num := Arg_Num + 1;
end loop;
if Project_File = null then
Fail ("no project file specified");
end if;
Setup_Projects := True;
Prj.Pars.Set_Verbosity (To => Current_Verbosity);
Prj.Pars.Parse
(Project => Project,
Project_File_Name => Project_File.all,
Packages_To_Check => All_Packages);
if Project = Prj.No_Project then
Fail ("""", Project_File.all, """ processing failed");
end if;
return;
end Process_Setup;
end if;
Exec_Path := Locate_Exec_On_Path (Program);
if Exec_Path = null then
Put_Line (Standard_Error, "Couldn't locate " & Program);
raise Error_Exit;
end if;
if Command_List (The_Command).Unixsws /= null then
for J in Command_List (The_Command).Unixsws'Range loop
First_Switches.Increment_Last;
First_Switches.Table (First_Switches.Last) :=
Command_List (The_Command).Unixsws (J);
end loop;
end if;
if The_Command = Bind
or else The_Command = Elim
or else The_Command = Find
or else The_Command = Link
or else The_Command = List
or else The_Command = Xref
or else The_Command = Pretty
or else The_Command = Stub
or else The_Command = Metric
then
case The_Command is
when Bind =>
Tool_Package_Name := Name_Binder;
Packages_To_Check := Packages_To_Check_By_Binder;
when Elim =>
Tool_Package_Name := Name_Eliminate;
Packages_To_Check := Packages_To_Check_By_Eliminate;
when Find =>
Tool_Package_Name := Name_Finder;
Packages_To_Check := Packages_To_Check_By_Finder;
when Link =>
Tool_Package_Name := Name_Linker;
Packages_To_Check := Packages_To_Check_By_Linker;
when List =>
Tool_Package_Name := Name_Gnatls;
Packages_To_Check := Packages_To_Check_By_Gnatls;
when Metric =>
Tool_Package_Name := Name_Metrics;
Packages_To_Check := Packages_To_Check_By_Metric;
when Pretty =>
Tool_Package_Name := Name_Pretty_Printer;
Packages_To_Check := Packages_To_Check_By_Pretty;
when Stub =>
Tool_Package_Name := Name_Gnatstub;
Packages_To_Check := Packages_To_Check_By_Gnatstub;
when Xref =>
Tool_Package_Name := Name_Cross_Reference;
Packages_To_Check := Packages_To_Check_By_Xref;
when others =>
null;
end case;
Inspect_Switches :
declare
Arg_Num : Positive := 1;
Argv : String_Access;
procedure Remove_Switch (Num : Positive);
procedure Remove_Switch (Num : Positive) is
begin
Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
Last_Switches.Table (Num + 1 .. Last_Switches.Last);
Last_Switches.Decrement_Last;
end Remove_Switch;
begin
while Arg_Num <= Last_Switches.Last loop
Argv := Last_Switches.Table (Arg_Num);
if Argv (Argv'First) = '-' then
if Argv'Length = 1 then
Fail
("switch character cannot be followed by a blank");
end if;
if (The_Command = Find or else The_Command = Xref)
and then Argv (2) = 'p'
then
Old_Project_File_Used := True;
if Project_File /= null then
Fail ("-P and -p cannot be used together");
end if;
end if;
if Argv'Length = 4
and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
then
case Argv (Argv'Last) is
when '0' =>
Current_Verbosity := Prj.Default;
when '1' =>
Current_Verbosity := Prj.Medium;
when '2' =>
Current_Verbosity := Prj.High;
when others =>
Fail ("Invalid switch: ", Argv.all);
end case;
Remove_Switch (Arg_Num);
elsif Argv (Argv'First + 1) = 'P' then
if Project_File /= null then
Fail
(Argv.all,
": second project file forbidden (first is """,
Project_File.all & """)");
elsif Old_Project_File_Used then
Fail ("-p and -P cannot be used together");
elsif Argv'Length = 2 then
if Arg_Num = Last_Switches.Last then
Fail ("project file name missing after -P");
else
Remove_Switch (Arg_Num);
Argv := Last_Switches.Table (Arg_Num);
if Argv (Argv'First) = '-' then
Fail ("project file name missing after -P");
else
Project_File := new String'(Argv.all);
end if;
end if;
else
Project_File :=
new String'(Argv (Argv'First + 2 .. Argv'Last));
end if;
Remove_Switch (Arg_Num);
elsif Argv'Length >= 5
and then Argv (Argv'First + 1) = 'X'
then
declare
Equal_Pos : constant Natural :=
Index ('=', Argv (Argv'First + 2 .. Argv'Last));
begin
if Equal_Pos >= Argv'First + 3 and then
Equal_Pos /= Argv'Last then
Add (External_Name =>
Argv (Argv'First + 2 .. Equal_Pos - 1),
Value => Argv (Equal_Pos + 1 .. Argv'Last));
else
Fail
(Argv.all,
" is not a valid external assignment.");
end if;
end;
Remove_Switch (Arg_Num);
else
Arg_Num := Arg_Num + 1;
end if;
else
Arg_Num := Arg_Num + 1;
end if;
end loop;
end Inspect_Switches;
end if;
if Project_File /= null then
Prj.Pars.Set_Verbosity (To => Current_Verbosity);
Prj.Pars.Parse
(Project => Project,
Project_File_Name => Project_File.all,
Packages_To_Check => Packages_To_Check);
if Project = Prj.No_Project then
Fail ("""", Project_File.all, """ processing failed");
end if;
declare
Data : constant Prj.Project_Data :=
Prj.Projects.Table (Project);
Pkg : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Tool_Package_Name,
In_Packages => Data.Decl.Packages);
Element : Package_Element;
Default_Switches_Array : Array_Element_Id;
The_Switches : Prj.Variable_Value;
Current : Prj.String_List_Id;
The_String : String_Element;
begin
if Pkg /= No_Package then
Element := Packages.Table (Pkg);
if The_Command = List then
The_Switches :=
Prj.Util.Value_Of
(Variable_Name => Snames.Name_Switches,
In_Variables => Element.Decl.Attributes);
else
if The_Switches.Kind = Prj.Undefined then
Default_Switches_Array :=
Prj.Util.Value_Of
(Name => Name_Default_Switches,
In_Arrays => Element.Decl.Arrays);
The_Switches := Prj.Util.Value_Of
(Index => Name_Ada,
Src_Index => 0,
In_Array => Default_Switches_Array);
end if;
end if;
case The_Switches.Kind is
when Prj.Undefined =>
null;
when Prj.Single =>
declare
Switch : constant String :=
Get_Name_String (The_Switches.Value);
begin
if Switch'Length > 0 then
First_Switches.Increment_Last;
First_Switches.Table (First_Switches.Last) :=
new String'(Switch);
end if;
end;
when Prj.List =>
Current := The_Switches.Values;
while Current /= Prj.Nil_String loop
The_String := String_Elements.Table (Current);
declare
Switch : constant String :=
Get_Name_String (The_String.Value);
begin
if Switch'Length > 0 then
First_Switches.Increment_Last;
First_Switches.Table (First_Switches.Last) :=
new String'(Switch);
end if;
end;
Current := The_String.Next;
end loop;
end case;
end if;
end;
if The_Command = Bind
or else The_Command = Link
or else The_Command = Elim
then
Change_Dir
(Get_Name_String
(Projects.Table (Project).Object_Directory));
end if;
Prj.Env.Set_Ada_Paths (Project, Including_Libraries => False);
if The_Command = Pretty
or else The_Command = Metric
or else The_Command = Stub
or else The_Command = Elim
then
declare
CP_File : constant Name_Id := Configuration_Pragmas_File;
begin
if CP_File /= No_Name then
First_Switches.Increment_Last;
if The_Command = Elim then
First_Switches.Table (First_Switches.Last) :=
new String'("-C" & Get_Name_String (CP_File));
else
First_Switches.Table (First_Switches.Last) :=
new String'("-gnatec=" & Get_Name_String (CP_File));
end if;
end if;
end;
end if;
if The_Command = Link then
Process_Link;
end if;
if The_Command = Link or The_Command = Bind then
for J in 1 .. Last_Switches.Last loop
Test_If_Relative_Path
(Last_Switches.Table (J), Current_Work_Dir);
end loop;
Get_Name_String (Projects.Table (Project).Directory);
declare
Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
begin
for J in 1 .. First_Switches.Last loop
Test_If_Relative_Path
(First_Switches.Table (J), Project_Dir);
end loop;
end;
elsif The_Command = Stub then
declare
Data : constant Prj.Project_Data :=
Prj.Projects.Table (Project);
File_Index : Integer := 0;
Dir_Index : Integer := 0;
Last : constant Integer := Last_Switches.Last;
begin
for Index in 1 .. Last loop
if Last_Switches.Table (Index)
(Last_Switches.Table (Index)'First) /= '-'
then
File_Index := Index;
exit;
end if;
end loop;
if Data.Naming.Current_Spec_Suffix /=
Prj.Default_Ada_Spec_Suffix
then
if File_Index /= 0 then
declare
Spec : constant String :=
Base_Name (Last_Switches.Table (File_Index).all);
Last : Natural := Spec'Last;
begin
Get_Name_String (Data.Naming.Current_Spec_Suffix);
if Spec'Length > Name_Len
and then Spec (Last - Name_Len + 1 .. Last) =
Name_Buffer (1 .. Name_Len)
then
Last := Last - Name_Len;
Get_Name_String (Data.Naming.Current_Body_Suffix);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-o");
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'(Spec (Spec'First .. Last) &
Name_Buffer (1 .. Name_Len));
end if;
end;
end if;
end if;
if File_Index /= 0 then
for Index in File_Index + 1 .. Last loop
if Last_Switches.Table (Index)
(Last_Switches.Table (Index)'First) /= '-'
then
Dir_Index := Index;
exit;
end if;
end loop;
if Dir_Index = 0 then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'
(Dir_Name (Last_Switches.Table (File_Index).all));
end if;
end if;
end;
end if;
if The_Command = Metric then
First_Switches.Increment_Last;
First_Switches.Table (2 .. First_Switches.Last) :=
First_Switches.Table (1 .. First_Switches.Last - 1);
First_Switches.Table (1) :=
new String'("-d=" &
Get_Name_String
(Projects.Table (Project).Object_Directory));
end if;
if The_Command = Pretty or else
The_Command = Metric or else
The_Command = List
then
Check_Files;
end if;
end if;
declare
The_Args : Argument_List
(1 .. First_Switches.Last + Last_Switches.Last);
Arg_Num : Natural := 0;
begin
for J in 1 .. First_Switches.Last loop
Arg_Num := Arg_Num + 1;
The_Args (Arg_Num) := First_Switches.Table (J);
end loop;
for J in 1 .. Last_Switches.Last loop
Arg_Num := Arg_Num + 1;
The_Args (Arg_Num) := Last_Switches.Table (J);
end loop;
if Display_Command then
Put (Standard_Error, "generated command -->");
Put (Standard_Error, Exec_Path.all);
for Arg in The_Args'Range loop
Put (Standard_Error, " ");
Put (Standard_Error, The_Args (Arg).all);
end loop;
Put (Standard_Error, "<--");
New_Line (Standard_Error);
raise Normal_Exit;
end if;
if Verbose_Mode then
Output.Write_Str (Exec_Path.all);
for Arg in The_Args'Range loop
Output.Write_Char (' ');
Output.Write_Str (The_Args (Arg).all);
end loop;
Output.Write_Eol;
end if;
My_Exit_Status :=
Exit_Status (Spawn (Exec_Path.all, The_Args));
raise Normal_Exit;
end;
end;
exception
when Error_Exit =>
Prj.Env.Delete_All_Path_Files;
Delete_Temp_Config_Files;
Set_Exit_Status (Failure);
when Normal_Exit =>
Prj.Env.Delete_All_Path_Files;
Delete_Temp_Config_Files;
if Hostparm.OpenVMS and then My_Exit_Status /= Success then
Set_Exit_Status (Failure);
else
Set_Exit_Status (My_Exit_Status);
end if;
end GNATCmd;