| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G N A T C M D -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1996-2016, 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 Csets; |
| with Gnatvsn; |
| with Makeutl; use Makeutl; |
| with Namet; use Namet; |
| with Opt; use Opt; |
| with Osint; use Osint; |
| with Output; use Output; |
| with Prj; use Prj; |
| with Prj.Env; |
| with Prj.Ext; use Prj.Ext; |
| with Prj.Pars; |
| with Prj.Tree; use Prj.Tree; |
| with Prj.Util; use Prj.Util; |
| with Sdefault; |
| with Sinput.P; |
| with Snames; use Snames; |
| with Stringt; |
| with Switch; use Switch; |
| with Table; |
| with Tempdir; |
| with Types; use Types; |
| |
| 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.Directory_Operations; use GNAT.Directory_Operations; |
| 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"; |
| |
| 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 |
| |
| Call_GPR_Tool : Boolean := False; |
| -- True when a GPR tool should be called, if available |
| |
| Project_Node_Tree : Project_Node_Tree_Ref; |
| Project_File : String_Access; |
| Project : Prj.Project_Id; |
| Current_Verbosity : Prj.Verbosity := Prj.Default; |
| Tool_Package_Name : Name_Id := No_Name; |
| |
| Project_Tree : constant Project_Tree_Ref := |
| new Project_Tree_Data (Is_Root_Tree => True); |
| -- The project tree |
| |
| All_Projects : Boolean := False; |
| |
| Temp_File_Name : Path_Name_Type := No_Path; |
| -- The name of the temporary text file to put a list of source/object |
| -- files to pass to a tool. |
| |
| 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) |
| ); |
| |
| subtype SA is String_Access; |
| |
| Naming_String : constant SA := new String'("naming"); |
| Gnatls_String : constant SA := new String'("gnatls"); |
| |
| Packages_To_Check_By_Gnatls : constant String_List_Access := |
| new String_List'((Naming_String, Gnatls_String)); |
| |
| Packages_To_Check : String_List_Access := Prj.All_Packages; |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Check_Files; |
| -- For GNAT LIST -V, check if a project file is specified, without any file |
| -- arguments and without a switch -files=. If it is the case, invoke the |
| -- GNAT tool with the proper list of files, derived from the sources of |
| -- the project. |
| |
| procedure Output_Version; |
| -- Output the version of this program |
| |
| procedure Usage; |
| -- Display usage |
| |
| ----------------- |
| -- Check_Files -- |
| ----------------- |
| |
| procedure Check_Files is |
| Add_Sources : Boolean := True; |
| Unit : Prj.Unit_Index; |
| Subunit : Boolean := False; |
| FD : File_Descriptor := Invalid_FD; |
| Status : Integer; |
| Success : Boolean; |
| |
| procedure Add_To_Response_File |
| (File_Name : String; |
| Check_File : Boolean := True); |
| -- Include the file name passed as parameter in the response file for |
| -- the tool being called. If the response file can not be written then |
| -- the file name is passed in the parameter list of the tool. If the |
| -- Check_File parameter is True then the procedure verifies the |
| -- existence of the file before adding it to the response file. |
| |
| -------------------------- |
| -- Add_To_Response_File -- |
| -------------------------- |
| |
| procedure Add_To_Response_File |
| (File_Name : String; |
| Check_File : Boolean := True) |
| is |
| begin |
| Name_Len := 0; |
| |
| Add_Str_To_Name_Buffer (File_Name); |
| |
| if not Check_File or else |
| Is_Regular_File (Name_Buffer (1 .. Name_Len)) |
| then |
| if FD /= Invalid_FD then |
| Name_Len := Name_Len + 1; |
| Name_Buffer (Name_Len) := ASCII.LF; |
| |
| Status := Write (FD, Name_Buffer (1)'Address, Name_Len); |
| |
| if Status /= Name_Len then |
| Osint.Fail ("disk full"); |
| end if; |
| else |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| new String'(File_Name); |
| end if; |
| end if; |
| end Add_To_Response_File; |
| |
| -- Start of processing for Check_Files |
| |
| begin |
| -- Check if there is at least one argument that is not a switch |
| |
| for Index in 1 .. Last_Switches.Last loop |
| if Last_Switches.Table (Index) (1) /= '-' |
| or else (Last_Switches.Table (Index).all'Length > 7 |
| and then Last_Switches.Table (Index) (1 .. 7) = "-files=") |
| then |
| Add_Sources := False; |
| exit; |
| end if; |
| end loop; |
| |
| -- If all arguments are switches and there is no switch -files=, add the |
| -- path names of all the sources of the main project. |
| |
| if Add_Sources then |
| Tempdir.Create_Temp_File (FD, Temp_File_Name); |
| Record_Temp_File (Project_Tree.Shared, Temp_File_Name); |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| new String'("-files=" & Get_Name_String (Temp_File_Name)); |
| |
| Unit := Units_Htable.Get_First (Project_Tree.Units_HT); |
| while Unit /= No_Unit_Index loop |
| |
| -- We only need to put the library units, body or spec, but not |
| -- the subunits. |
| |
| if Unit.File_Names (Impl) /= null |
| and then not Unit.File_Names (Impl).Locally_Removed |
| then |
| -- There is a body, check if it is for this project |
| |
| if All_Projects |
| or else Unit.File_Names (Impl).Project = Project |
| then |
| Subunit := False; |
| |
| if Unit.File_Names (Spec) = null |
| or else Unit.File_Names (Spec).Locally_Removed |
| then |
| -- We have a body with no spec: we need to check if |
| -- this is a subunit, because gnatls will complain |
| -- about subunits. |
| |
| declare |
| Src_Ind : constant Source_File_Index := |
| Sinput.P.Load_Project_File |
| (Get_Name_String |
| (Unit.File_Names (Impl).Path.Name)); |
| begin |
| Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind); |
| end; |
| end if; |
| |
| if not Subunit then |
| Add_To_Response_File |
| (Get_Name_String (Unit.File_Names (Impl).Display_File), |
| Check_File => False); |
| end if; |
| end if; |
| |
| elsif Unit.File_Names (Spec) /= null |
| and then not Unit.File_Names (Spec).Locally_Removed |
| then |
| -- We have a spec with no body. Check if it is for this project |
| |
| if All_Projects |
| or else Unit.File_Names (Spec).Project = Project |
| then |
| Add_To_Response_File |
| (Get_Name_String (Unit.File_Names (Spec).Display_File), |
| Check_File => False); |
| end if; |
| end if; |
| |
| Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); |
| end loop; |
| |
| if FD /= Invalid_FD then |
| Close (FD, Success); |
| |
| if not Success then |
| Osint.Fail ("disk full"); |
| end if; |
| end if; |
| end if; |
| end Check_Files; |
| |
| -------------------- |
| -- 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; |
| |
| ----------- |
| -- Usage -- |
| ----------- |
| |
| procedure Usage is |
| begin |
| Output_Version; |
| 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 Usage; |
| |
| procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); |
| |
| -- Start of processing for GNATCmd |
| |
| begin |
| -- All output from GNATCmd is debugging or error output: send to stderr |
| |
| Set_Standard_Error; |
| |
| -- Initializations |
| |
| Csets.Initialize; |
| Snames.Initialize; |
| Stringt.Initialize; |
| |
| Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags); |
| |
| Project_Node_Tree := new Project_Node_Tree_Data; |
| Prj.Tree.Initialize (Project_Node_Tree); |
| |
| Prj.Initialize (Project_Tree); |
| |
| 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; |
| |
| else |
| exit; |
| end if; |
| end loop; |
| |
| -- If there is no command, just output the usage |
| |
| if Command_Arg > Argument_Count then |
| Usage; |
| 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 => |
| 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 (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; |
| |
| else |
| -- 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); |
| |
| 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 = Make |
| or else The_Command = Compile |
| or else The_Command = Bind |
| or else The_Command = Link |
| or else The_Command = Clean |
| or else The_Command = Name |
| or else The_Command = List |
| then |
| declare |
| Switch : String_Access; |
| Dash_V_Switch : constant String := "-V"; |
| |
| begin |
| for J in 1 .. Last_Switches.Last loop |
| Switch := Last_Switches.Table (J); |
| |
| if The_Command = List and then Switch.all = Dash_V_Switch |
| then |
| Call_GPR_Tool := False; |
| exit; |
| end if; |
| |
| if Switch'Length >= 2 |
| and then Switch (Switch'First .. Switch'First + 1) = "-P" |
| then |
| Call_GPR_Tool := True; |
| 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 is no longer supporting |
| -- project files. |
| |
| if The_Command = Find or else The_Command = 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 no longer supported;"); |
| else |
| Fail ("'gnat xref -P' is no longer supported;"); |
| end if; |
| end if; |
| end loop; |
| end; |
| end if; |
| |
| if The_Command = List and then not Call_GPR_Tool then |
| Tool_Package_Name := Name_Gnatls; |
| Packages_To_Check := Packages_To_Check_By_Gnatls; |
| |
| -- Check that the switches are consistent. Detect project file |
| -- related switches. |
| |
| Inspect_Switches : declare |
| Arg_Num : Positive := 1; |
| Argv : String_Access; |
| |
| procedure Remove_Switch (Num : Positive); |
| -- Remove a project related switch from table Last_Switches |
| |
| ------------------- |
| -- Remove_Switch -- |
| ------------------- |
| |
| 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; |
| |
| -- Start of processing for Inspect_Switches |
| |
| 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; |
| |
| -- --subdirs=... Specify Subdirs |
| |
| if Argv'Length > Makeutl.Subdirs_Option'Length |
| and then |
| Argv |
| (Argv'First .. |
| Argv'First + Makeutl.Subdirs_Option'Length - 1) = |
| Makeutl.Subdirs_Option |
| then |
| Subdirs := |
| new String' |
| (Argv (Argv'First + Makeutl.Subdirs_Option'Length .. |
| Argv'Last)); |
| |
| Remove_Switch (Arg_Num); |
| |
| -- -aPdir Add dir to the project search path |
| |
| elsif Argv'Length > 3 |
| and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP" |
| then |
| Prj.Env.Add_Directories |
| (Root_Environment.Project_Path, |
| Argv (Argv'First + 3 .. Argv'Last)); |
| |
| -- Pass -aPdir to gnatls, but not to other tools |
| |
| if The_Command = List then |
| Arg_Num := Arg_Num + 1; |
| else |
| Remove_Switch (Arg_Num); |
| end if; |
| |
| -- -eL Follow links for files |
| |
| elsif Argv.all = "-eL" then |
| Follow_Links_For_Files := True; |
| Follow_Links_For_Dirs := True; |
| |
| Remove_Switch (Arg_Num); |
| |
| -- -vPx Specify verbosity while parsing project files |
| |
| elsif Argv'Length >= 3 |
| and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" |
| then |
| if Argv'Length = 4 |
| and then Argv (Argv'Last) in '0' .. '2' |
| 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 => |
| |
| -- Cannot happen |
| |
| raise Program_Error; |
| end case; |
| else |
| Fail ("invalid verbosity level: " |
| & Argv (Argv'First + 3 .. Argv'Last)); |
| end if; |
| |
| Remove_Switch (Arg_Num); |
| |
| -- -Pproject_file Specify project file to be used |
| |
| elsif Argv (Argv'First + 1) = 'P' then |
| |
| -- Only one -P switch can be used |
| |
| if Project_File /= null then |
| Fail |
| (Argv.all |
| & ": second project file forbidden (first is """ |
| & Project_File.all & """)"); |
| |
| elsif Argv'Length = 2 then |
| |
| -- There is space between -P and the project file |
| -- name. -P cannot be the last option. |
| |
| 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); |
| |
| -- After -P, there must be a project file name, |
| -- not another switch. |
| |
| if Argv (Argv'First) = '-' then |
| Fail ("project file name missing after -P"); |
| |
| else |
| Project_File := new String'(Argv.all); |
| end if; |
| end if; |
| |
| else |
| -- No space between -P and project file name |
| |
| Project_File := |
| new String'(Argv (Argv'First + 2 .. Argv'Last)); |
| end if; |
| |
| Remove_Switch (Arg_Num); |
| |
| -- -Xexternal=value Specify an external reference to be |
| -- used in project files |
| |
| elsif Argv'Length >= 5 |
| and then Argv (Argv'First + 1) = 'X' |
| then |
| if not Check (Root_Environment.External, |
| Argv (Argv'First + 2 .. Argv'Last)) |
| then |
| Fail |
| (Argv.all & " is not a valid external assignment."); |
| end if; |
| |
| Remove_Switch (Arg_Num); |
| |
| -- --unchecked-shared-lib-imports |
| |
| elsif Argv.all = "--unchecked-shared-lib-imports" then |
| Opt.Unchecked_Shared_Lib_Imports := True; |
| Remove_Switch (Arg_Num); |
| |
| -- gnat list -U |
| |
| elsif |
| The_Command = List |
| and then Argv'Length = 2 |
| and then Argv (2) = 'U' |
| then |
| All_Projects := True; |
| 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; |
| |
| -- Add the default project search directories now, after the directories |
| -- that have been specified by switches -aP<dir>. |
| |
| Prj.Env.Initialize_Default_Project_Path |
| (Root_Environment.Project_Path, |
| Target_Name => Sdefault.Target_Name.all); |
| |
| -- If there is a project file specified, parse it, get the switches |
| -- for the tool and setup PATH environment variables. |
| |
| if Project_File /= null then |
| Prj.Pars.Set_Verbosity (To => Current_Verbosity); |
| |
| Prj.Pars.Parse |
| (Project => Project, |
| In_Tree => Project_Tree, |
| In_Node_Tree => Project_Node_Tree, |
| Project_File_Name => Project_File.all, |
| Env => Root_Environment, |
| Packages_To_Check => Packages_To_Check); |
| |
| -- Prj.Pars.Parse calls Set_Standard_Output, reset to stderr |
| |
| Set_Standard_Error; |
| |
| if Project = Prj.No_Project then |
| Fail ("""" & Project_File.all & """ processing failed"); |
| |
| elsif Project.Qualifier = Aggregate then |
| Fail ("aggregate projects are not supported"); |
| |
| elsif Aggregate_Libraries_In (Project_Tree) then |
| Fail ("aggregate library projects are not supported"); |
| end if; |
| |
| -- Check if a package with the name of the tool is in the project |
| -- file and if there is one, get the switches, if any, and scan them. |
| |
| declare |
| Pkg : constant Prj.Package_Id := |
| Prj.Util.Value_Of |
| (Name => Tool_Package_Name, |
| In_Packages => Project.Decl.Packages, |
| Shared => Project_Tree.Shared); |
| |
| Element : Package_Element; |
| |
| Switches_Array : Array_Element_Id; |
| |
| The_Switches : Prj.Variable_Value; |
| Current : Prj.String_List_Id; |
| The_String : String_Element; |
| |
| Main : String_Access := null; |
| |
| begin |
| if Pkg /= No_Package then |
| Element := Project_Tree.Shared.Packages.Table (Pkg); |
| |
| -- Package Gnatls has a single attribute Switches, that is not |
| -- an associative array. |
| |
| if The_Command = List then |
| The_Switches := |
| Prj.Util.Value_Of |
| (Variable_Name => Snames.Name_Switches, |
| In_Variables => Element.Decl.Attributes, |
| Shared => Project_Tree.Shared); |
| |
| -- Packages Binder (for gnatbind), Cross_Reference (for |
| -- gnatxref), Linker (for gnatlink), Finder (for gnatfind), |
| -- have an attributed Switches, an associative array, indexed |
| -- by the name of the file. |
| |
| -- They also have an attribute Default_Switches, indexed by the |
| -- name of the programming language. |
| |
| else |
| -- First check if there is a single main |
| |
| for J in 1 .. Last_Switches.Last loop |
| if Last_Switches.Table (J) (1) /= '-' then |
| if Main = null then |
| Main := Last_Switches.Table (J); |
| else |
| Main := null; |
| exit; |
| end if; |
| end if; |
| end loop; |
| |
| if Main /= null then |
| Switches_Array := |
| Prj.Util.Value_Of |
| (Name => Name_Switches, |
| In_Arrays => Element.Decl.Arrays, |
| Shared => Project_Tree.Shared); |
| Name_Len := 0; |
| |
| -- If the single main has been specified as an absolute |
| -- path, use only the simple file name. If the absolute |
| -- path is incorrect, an error will be reported by the |
| -- underlying tool and it does not make a difference |
| -- what switches are used. |
| |
| if Is_Absolute_Path (Main.all) then |
| Add_Str_To_Name_Buffer (File_Name (Main.all)); |
| else |
| Add_Str_To_Name_Buffer (Main.all); |
| end if; |
| |
| The_Switches := Prj.Util.Value_Of |
| (Index => Name_Find, |
| Src_Index => 0, |
| In_Array => Switches_Array, |
| Shared => Project_Tree.Shared); |
| end if; |
| |
| if The_Switches.Kind = Prj.Undefined then |
| Switches_Array := |
| Prj.Util.Value_Of |
| (Name => Name_Default_Switches, |
| In_Arrays => Element.Decl.Arrays, |
| Shared => Project_Tree.Shared); |
| The_Switches := Prj.Util.Value_Of |
| (Index => Name_Ada, |
| Src_Index => 0, |
| In_Array => Switches_Array, |
| Shared => Project_Tree.Shared); |
| end if; |
| end if; |
| |
| -- If there are switches specified in the package of the |
| -- project file corresponding to the tool, scan them. |
| |
| 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 := Project_Tree.Shared.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 then |
| if Project.Object_Directory.Name = No_Path then |
| Fail ("project " & Get_Name_String (Project.Display_Name) |
| & " has no object directory"); |
| end if; |
| |
| Change_Dir (Get_Name_String (Project.Object_Directory.Name)); |
| end if; |
| |
| -- Set up the env vars for project path files |
| |
| Prj.Env.Set_Ada_Paths |
| (Project, Project_Tree, Including_Libraries => True); |
| |
| if The_Command = List then |
| Check_Files; |
| end if; |
| 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)); |
| |
| if not Keep_Temporary_Files then |
| Delete_All_Temp_Files (Project_Tree.Shared); |
| end if; |
| |
| Set_Exit_Status (My_Exit_Status); |
| end; |
| end; |
| |
| exception |
| when Error_Exit => |
| Set_Exit_Status (Failure); |
| end GNATCmd; |
