mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-13 08:29:53 +00:00
655 lines
20 KiB
Ada
655 lines
20 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- G N A T C M D --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1996-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 Gnatvsn;
|
|
with Namet; use Namet;
|
|
with Opt; use Opt;
|
|
with Osint; use Osint;
|
|
with Output; use Output;
|
|
with Switch; use Switch;
|
|
with Table;
|
|
with Usage;
|
|
|
|
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;
|
|
|
|
procedure GNATCmd is
|
|
Gprbuild : constant String := "gprbuild";
|
|
Gprclean : constant String := "gprclean";
|
|
Gprname : constant String := "gprname";
|
|
Gprls : constant String := "gprls";
|
|
|
|
Ada_Help_Switch : constant String := "--help-ada";
|
|
-- Flag to display available build switches
|
|
|
|
Error_Exit : exception;
|
|
-- Raise this exception if error detected
|
|
|
|
type Command_Type is
|
|
(Bind,
|
|
Chop,
|
|
Clean,
|
|
Compile,
|
|
Check,
|
|
Elim,
|
|
Find,
|
|
Krunch,
|
|
Link,
|
|
List,
|
|
Make,
|
|
Metric,
|
|
Name,
|
|
Preprocess,
|
|
Pretty,
|
|
Stack,
|
|
Stub,
|
|
Test,
|
|
Xref,
|
|
Undefined);
|
|
|
|
subtype Real_Command_Type is Command_Type range Bind .. Xref;
|
|
-- All real command types (excludes only Undefined).
|
|
|
|
type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
|
|
-- Alternate command label
|
|
|
|
Corresponding_To : constant array (Alternate_Command) of Command_Type :=
|
|
(Comp => Compile,
|
|
Ls => List,
|
|
Kr => Krunch,
|
|
Prep => Preprocess,
|
|
Pp => Pretty);
|
|
-- Mapping of alternate commands to commands
|
|
|
|
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");
|
|
-- A table to keep the switches from the project file
|
|
|
|
package Last_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.Last_Switches");
|
|
|
|
----------------------------------
|
|
-- Declarations for GNATCMD use --
|
|
----------------------------------
|
|
|
|
The_Command : Command_Type;
|
|
-- The command specified in the invocation of the GNAT driver
|
|
|
|
Command_Arg : Positive := 1;
|
|
-- The index of the command in the arguments of the GNAT driver
|
|
|
|
My_Exit_Status : Exit_Status := Success;
|
|
-- The exit status of the spawned tool
|
|
|
|
type Command_Entry is record
|
|
Cname : String_Access;
|
|
-- Command name for GNAT xxx command
|
|
|
|
Unixcmd : String_Access;
|
|
-- Corresponding Unix command
|
|
|
|
Unixsws : Argument_List_Access;
|
|
-- List of switches to be used with the Unix command
|
|
end record;
|
|
|
|
Command_List : constant array (Real_Command_Type) of Command_Entry :=
|
|
(Bind =>
|
|
(Cname => new String'("BIND"),
|
|
Unixcmd => new String'("gnatbind"),
|
|
Unixsws => null),
|
|
|
|
Chop =>
|
|
(Cname => new String'("CHOP"),
|
|
Unixcmd => new String'("gnatchop"),
|
|
Unixsws => null),
|
|
|
|
Clean =>
|
|
(Cname => new String'("CLEAN"),
|
|
Unixcmd => new String'("gnatclean"),
|
|
Unixsws => null),
|
|
|
|
Compile =>
|
|
(Cname => new String'("COMPILE"),
|
|
Unixcmd => new String'("gnatmake"),
|
|
Unixsws => new Argument_List'(1 => new String'("-f"),
|
|
2 => new String'("-u"),
|
|
3 => new String'("-c"))),
|
|
|
|
Check =>
|
|
(Cname => new String'("CHECK"),
|
|
Unixcmd => new String'("gnatcheck"),
|
|
Unixsws => null),
|
|
|
|
Elim =>
|
|
(Cname => new String'("ELIM"),
|
|
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"),
|
|
Unixsws => null),
|
|
|
|
Link =>
|
|
(Cname => new String'("LINK"),
|
|
Unixcmd => new String'("gnatlink"),
|
|
Unixsws => null),
|
|
|
|
List =>
|
|
(Cname => new String'("LIST"),
|
|
Unixcmd => new String'("gnatls"),
|
|
Unixsws => null),
|
|
|
|
Make =>
|
|
(Cname => new String'("MAKE"),
|
|
Unixcmd => new String'("gnatmake"),
|
|
Unixsws => null),
|
|
|
|
Metric =>
|
|
(Cname => new String'("METRIC"),
|
|
Unixcmd => new String'("gnatmetric"),
|
|
Unixsws => null),
|
|
|
|
Name =>
|
|
(Cname => new String'("NAME"),
|
|
Unixcmd => new String'("gnatname"),
|
|
Unixsws => null),
|
|
|
|
Preprocess =>
|
|
(Cname => new String'("PREPROCESS"),
|
|
Unixcmd => new String'("gnatprep"),
|
|
Unixsws => null),
|
|
|
|
Pretty =>
|
|
(Cname => new String'("PRETTY"),
|
|
Unixcmd => new String'("gnatpp"),
|
|
Unixsws => null),
|
|
|
|
Stack =>
|
|
(Cname => new String'("STACK"),
|
|
Unixcmd => new String'("gnatstack"),
|
|
Unixsws => null),
|
|
|
|
Stub =>
|
|
(Cname => new String'("STUB"),
|
|
Unixcmd => new String'("gnatstub"),
|
|
Unixsws => null),
|
|
|
|
Test =>
|
|
(Cname => new String'("TEST"),
|
|
Unixcmd => new String'("gnattest"),
|
|
Unixsws => null),
|
|
|
|
Xref =>
|
|
(Cname => new String'("XREF"),
|
|
Unixcmd => new String'("gnatxref"),
|
|
Unixsws => null)
|
|
);
|
|
|
|
-----------------------
|
|
-- Local Subprograms --
|
|
-----------------------
|
|
|
|
procedure Output_Version;
|
|
-- Output the version of this program
|
|
|
|
procedure GNATCmd_Usage;
|
|
-- Display usage
|
|
|
|
--------------------
|
|
-- Output_Version --
|
|
--------------------
|
|
|
|
procedure Output_Version is
|
|
begin
|
|
Put ("GNAT ");
|
|
Put_Line (Gnatvsn.Gnat_Version_String);
|
|
Put_Line ("Copyright 1996-" & Gnatvsn.Current_Year
|
|
& ", Free Software Foundation, Inc.");
|
|
end Output_Version;
|
|
|
|
-------------------
|
|
-- GNATCmd_Usage --
|
|
-------------------
|
|
|
|
procedure GNATCmd_Usage is
|
|
begin
|
|
Output_Version;
|
|
New_Line;
|
|
Put_Line ("To list Ada build switches use " & Ada_Help_Switch);
|
|
New_Line;
|
|
Put_Line ("List of available commands");
|
|
New_Line;
|
|
|
|
for C in Command_List'Range loop
|
|
Put ("gnat ");
|
|
Put (To_Lower (Command_List (C).Cname.all));
|
|
Set_Col (25);
|
|
Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").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 loop;
|
|
|
|
New_Line;
|
|
end GNATCmd_Usage;
|
|
|
|
procedure Check_Version_And_Help
|
|
is new Check_Version_And_Help_G (GNATCmd_Usage);
|
|
|
|
-- Start of processing for GNATCmd
|
|
|
|
begin
|
|
-- All output from GNATCmd is debugging or error output: send to stderr
|
|
|
|
Set_Standard_Error;
|
|
|
|
-- Initializations
|
|
|
|
Last_Switches.Init;
|
|
Last_Switches.Set_Last (0);
|
|
|
|
First_Switches.Init;
|
|
First_Switches.Set_Last (0);
|
|
|
|
-- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
|
|
-- so that the spawned tool may know the way the GNAT driver was invoked.
|
|
|
|
Name_Len := 0;
|
|
Add_Str_To_Name_Buffer (Command_Name);
|
|
|
|
for J in 1 .. Argument_Count loop
|
|
Add_Char_To_Name_Buffer (' ');
|
|
Add_Str_To_Name_Buffer (Argument (J));
|
|
end loop;
|
|
|
|
Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
|
|
|
|
-- Add the directory where the GNAT driver is invoked in front of the path,
|
|
-- if the GNAT driver 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;
|
|
|
|
-- Scan the command line
|
|
|
|
-- First, scan to detect --version and/or --help
|
|
|
|
Check_Version_And_Help ("GNAT", "1996");
|
|
|
|
begin
|
|
loop
|
|
if Command_Arg <= Argument_Count
|
|
and then Argument (Command_Arg) = "-v"
|
|
then
|
|
Verbose_Mode := True;
|
|
Command_Arg := Command_Arg + 1;
|
|
|
|
elsif Command_Arg <= Argument_Count
|
|
and then Argument (Command_Arg) = "-dn"
|
|
then
|
|
Keep_Temporary_Files := True;
|
|
Command_Arg := Command_Arg + 1;
|
|
|
|
elsif Command_Arg <= Argument_Count
|
|
and then Argument (Command_Arg) = Ada_Help_Switch
|
|
then
|
|
Usage;
|
|
Exit_Program (E_Success);
|
|
|
|
else
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
-- If there is no command, just output the usage
|
|
|
|
if Command_Arg > Argument_Count then
|
|
GNATCmd_Usage;
|
|
|
|
-- Add the following so that output is consistent with or without the
|
|
-- --help flag.
|
|
Write_Eol;
|
|
Write_Line ("Report bugs to report@adacore.com");
|
|
return;
|
|
end if;
|
|
|
|
The_Command := Real_Command_Type'Value (Argument (Command_Arg));
|
|
|
|
exception
|
|
when Constraint_Error =>
|
|
|
|
-- Check if it is an alternate command
|
|
|
|
declare
|
|
Alternate : Alternate_Command;
|
|
|
|
begin
|
|
Alternate := Alternate_Command'Value (Argument (Command_Arg));
|
|
The_Command := Corresponding_To (Alternate);
|
|
|
|
exception
|
|
when Constraint_Error =>
|
|
GNATCmd_Usage;
|
|
Fail ("unknown command: " & Argument (Command_Arg));
|
|
end;
|
|
end;
|
|
|
|
-- Get the arguments from the command line and from the eventual
|
|
-- argument file(s) specified on the command line.
|
|
|
|
for Arg in Command_Arg + 1 .. Argument_Count loop
|
|
declare
|
|
The_Arg : constant String := Argument (Arg);
|
|
|
|
begin
|
|
-- Check if an argument file is specified
|
|
|
|
if The_Arg'Length > 0 and then The_Arg (The_Arg'First) = '@' then
|
|
declare
|
|
Arg_File : Ada.Text_IO.File_Type;
|
|
Line : String (1 .. 256);
|
|
Last : Natural;
|
|
|
|
begin
|
|
-- Open the file and fail if the file cannot be found
|
|
|
|
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;
|
|
|
|
-- Read line by line and put the content of each non-
|
|
-- empty line in the Last_Switches table.
|
|
|
|
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;
|
|
|
|
elsif The_Arg'Length > 0 then
|
|
-- It is not an argument file; just put the argument in
|
|
-- the Last_Switches table.
|
|
|
|
Last_Switches.Increment_Last;
|
|
Last_Switches.Table (Last_Switches.Last) := new String'(The_Arg);
|
|
end if;
|
|
end;
|
|
end loop;
|
|
|
|
declare
|
|
Program : String_Access;
|
|
Exec_Path : String_Access;
|
|
Get_Target : Boolean := False;
|
|
|
|
begin
|
|
if The_Command = Stack then
|
|
|
|
-- Never call gnatstack with a prefix
|
|
|
|
Program := new String'(Command_List (The_Command).Unixcmd.all);
|
|
|
|
elsif The_Command in Check | Test then
|
|
Program := new String'(Command_List (The_Command).Unixcmd.all);
|
|
Find_Program_Name;
|
|
|
|
if Name_Len > 5 then
|
|
First_Switches.Append
|
|
(new String'
|
|
("--target=" & Name_Buffer (1 .. Name_Len - 5)));
|
|
end if;
|
|
else
|
|
Program :=
|
|
Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
|
|
|
|
-- If we want to invoke gnatmake/gnatclean with -P, then check if
|
|
-- gprbuild/gprclean is available; if it is, use gprbuild/gprclean
|
|
-- instead of gnatmake/gnatclean.
|
|
-- Ditto for gnatname -> gprname and gnatls -> gprls.
|
|
|
|
if The_Command in Make | Compile | Bind | Link | Clean | Name | List
|
|
then
|
|
declare
|
|
Switch : String_Access;
|
|
Call_GPR_Tool : Boolean := False;
|
|
begin
|
|
for J in 1 .. Last_Switches.Last loop
|
|
Switch := Last_Switches.Table (J);
|
|
|
|
if Switch'Length >= 2
|
|
and then Switch (Switch'First .. Switch'First + 1) = "-P"
|
|
then
|
|
Call_GPR_Tool := True;
|
|
exit;
|
|
end if;
|
|
end loop;
|
|
|
|
if Call_GPR_Tool then
|
|
case The_Command is
|
|
when Bind
|
|
| Compile
|
|
| Link
|
|
| Make
|
|
=>
|
|
if Locate_Exec_On_Path (Gprbuild) /= null then
|
|
Program := new String'(Gprbuild);
|
|
Get_Target := True;
|
|
|
|
if The_Command = Bind then
|
|
First_Switches.Append (new String'("-b"));
|
|
elsif The_Command = Link then
|
|
First_Switches.Append (new String'("-l"));
|
|
end if;
|
|
|
|
elsif The_Command = Bind then
|
|
Fail
|
|
("'gnat bind -P' is no longer supported;" &
|
|
" use 'gprbuild -b' instead.");
|
|
|
|
elsif The_Command = Link then
|
|
Fail
|
|
("'gnat Link -P' is no longer supported;" &
|
|
" use 'gprbuild -l' instead.");
|
|
end if;
|
|
|
|
when Clean =>
|
|
if Locate_Exec_On_Path (Gprclean) /= null then
|
|
Program := new String'(Gprclean);
|
|
Get_Target := True;
|
|
end if;
|
|
|
|
when Name =>
|
|
if Locate_Exec_On_Path (Gprname) /= null then
|
|
Program := new String'(Gprname);
|
|
Get_Target := True;
|
|
end if;
|
|
|
|
when List =>
|
|
if Locate_Exec_On_Path (Gprls) /= null then
|
|
Program := new String'(Gprls);
|
|
Get_Target := True;
|
|
end if;
|
|
|
|
when others =>
|
|
null;
|
|
end case;
|
|
|
|
if Get_Target then
|
|
Find_Program_Name;
|
|
|
|
if Name_Len > 5 then
|
|
First_Switches.Append
|
|
(new String'
|
|
("--target=" & Name_Buffer (1 .. Name_Len - 5)));
|
|
end if;
|
|
end if;
|
|
end if;
|
|
end;
|
|
end if;
|
|
end if;
|
|
|
|
-- Locate the executable for the command
|
|
|
|
Exec_Path := Locate_Exec_On_Path (Program.all);
|
|
|
|
if Exec_Path = null then
|
|
Put_Line (Standard_Error, "could not locate " & Program.all);
|
|
raise Error_Exit;
|
|
end if;
|
|
|
|
-- If there are switches for the executable, put them as first switches
|
|
|
|
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;
|
|
|
|
-- 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
|
|
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 Verbose_Mode then
|
|
Put (Exec_Path.all);
|
|
|
|
for Arg in The_Args'Range loop
|
|
Put (" " & The_Args (Arg).all);
|
|
end loop;
|
|
|
|
New_Line;
|
|
end if;
|
|
|
|
My_Exit_Status := Exit_Status (Spawn (Exec_Path.all, The_Args));
|
|
|
|
Set_Exit_Status (My_Exit_Status);
|
|
end;
|
|
end;
|
|
|
|
exception
|
|
when Error_Exit =>
|
|
Set_Exit_Status (Failure);
|
|
end GNATCmd;
|