| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- G N A T C M D -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1996-2013, 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 GNAT.Directory_Operations; use GNAT.Directory_Operations; |
| |
| with Csets; |
| with Hostparm; use Hostparm; |
| with Makeutl; use Makeutl; |
| with MLib.Tgt; use MLib.Tgt; |
| with MLib.Utl; |
| with MLib.Fil; |
| 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 Table; |
| with Targparm; |
| with Tempdir; |
| with Types; use Types; |
| with VMS_Conv; use VMS_Conv; |
| with VMS_Cmds; use VMS_Cmds; |
| |
| 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 |
| Project_Node_Tree : Project_Node_Tree_Ref; |
| Root_Environment : Prj.Tree.Environment; |
| Project_File : String_Access; |
| Project : Prj.Project_Id; |
| Current_Verbosity : Prj.Verbosity := Prj.Default; |
| Tool_Package_Name : Name_Id := No_Name; |
| |
| B_Start : String_Ptr := new String'("b~"); |
| -- Prefix of binder generated file, changed to b__ for VMS |
| |
| Project_Tree : constant Project_Tree_Ref := |
| new Project_Tree_Data (Is_Root_Tree => True); |
| -- The project tree |
| |
| Old_Project_File_Used : Boolean := False; |
| -- This flag indicates a switch -p (for gnatxref and gnatfind) for |
| -- an old fashioned project file. -p cannot be used in conjunction |
| -- with -P. |
| |
| 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. |
| |
| ASIS_Main : String_Access := null; |
| -- Main for commands Check, Metric and Pretty, when -U is used |
| |
| 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 Carg_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.Carg_Switches"); |
| -- A table to keep the switches following -cargs for ASIS tools |
| |
| package Rules_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.Rules_Switches"); |
| -- A table to keep the switches following -rules for gnatcheck |
| |
| 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"); |
| |
| -- Packages of project files to pass to Prj.Pars.Parse, depending on the |
| -- tool. We allocate objects because we cannot declare aliased objects |
| -- as we are in a procedure, not a library level package. |
| |
| subtype SA is String_Access; |
| |
| Naming_String : constant SA := new String'("naming"); |
| Binder_String : constant SA := new String'("binder"); |
| Builder_String : constant SA := new String'("builder"); |
| Compiler_String : constant SA := new String'("compiler"); |
| Check_String : constant SA := new String'("check"); |
| Synchronize_String : constant SA := new String'("synchronize"); |
| Eliminate_String : constant SA := new String'("eliminate"); |
| Finder_String : constant SA := new String'("finder"); |
| Linker_String : constant SA := new String'("linker"); |
| Gnatls_String : constant SA := new String'("gnatls"); |
| Pretty_String : constant SA := new String'("pretty_printer"); |
| Stack_String : constant SA := new String'("stack"); |
| Gnatstub_String : constant SA := new String'("gnatstub"); |
| Metric_String : constant SA := new String'("metrics"); |
| Xref_String : constant SA := new String'("cross_reference"); |
| |
| Packages_To_Check_By_Binder : constant String_List_Access := |
| new String_List'((Naming_String, Binder_String)); |
| |
| Packages_To_Check_By_Check : constant String_List_Access := |
| new String_List' |
| ((Naming_String, Builder_String, Check_String, Compiler_String)); |
| |
| Packages_To_Check_By_Sync : constant String_List_Access := |
| new String_List'((Naming_String, Synchronize_String, Compiler_String)); |
| |
| Packages_To_Check_By_Eliminate : constant String_List_Access := |
| new String_List'((Naming_String, Eliminate_String, Compiler_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, Compiler_String)); |
| |
| Packages_To_Check_By_Stack : constant String_List_Access := |
| new String_List'((Naming_String, Stack_String)); |
| |
| Packages_To_Check_By_Gnatstub : constant String_List_Access := |
| new String_List'((Naming_String, Gnatstub_String, Compiler_String)); |
| |
| Packages_To_Check_By_Metric : constant String_List_Access := |
| new String_List'((Naming_String, Metric_String, Compiler_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; |
| |
| ---------------------------------- |
| -- 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. Used to set the correct VMS |
| -- exit status. |
| |
| Current_Work_Dir : constant String := Get_Current_Dir; |
| -- The path of the working directory |
| |
| All_Projects : Boolean := False; |
| -- Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to |
| -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric) |
| -- should be invoked for all sources of all projects. |
| |
| Max_OpenVMS_Logical_Length : constant Integer := 255; |
| -- The maximum length of OpenVMS logicals |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Add_To_Carg_Switches (Switch : String_Access); |
| -- Add a switch to the Carg_Switches table. If it is the first one, put the |
| -- switch "-cargs" at the beginning of the table. |
| |
| procedure Add_To_Rules_Switches (Switch : String_Access); |
| -- Add a switch to the Rules_Switches table. If it is the first one, put |
| -- the switch "-crules" at the beginning of the table. |
| |
| procedure Check_Files; |
| -- For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, 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. |
| |
| function Check_Project |
| (Project : Project_Id; |
| Root_Project : Project_Id) return Boolean; |
| -- Returns True if Project = Root_Project or if we want to consider all |
| -- sources of all projects. For GNAT METRIC, also returns True if Project |
| -- is extended by Root_Project. |
| |
| procedure Check_Relative_Executable (Name : in out String_Access); |
| -- Check if an executable is specified as a relative path. If it is, and |
| -- the path contains directory information, fail. Otherwise, prepend the |
| -- exec directory. This procedure is only used for GNAT LINK when a project |
| -- file is specified. |
| |
| function Configuration_Pragmas_File return Path_Name_Type; |
| -- Return an argument, if there is a configuration pragmas file to be |
| -- specified for Project, otherwise return No_Name. Used for gnatstub |
| -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric |
| -- (GNAT METRIC). |
| |
| procedure Delete_Temp_Config_Files; |
| -- Delete all temporary config files. The caller is responsible for |
| -- ensuring that Keep_Temporary_Files is False. |
| |
| procedure Ensure_Absolute_Path |
| (Switch : in out String_Access; |
| Parent : String); |
| -- Test if Switch is a relative search path switch. If it is and it |
| -- includes directory information, prepend the path with Parent. This |
| -- subprogram is only called when using project files. |
| |
| procedure Get_Closure; |
| -- Get the sources in the closure of the ASIS_Main and add them to the |
| -- list of arguments. |
| |
| function Mapping_File return Path_Name_Type; |
| -- Create and return the path name of a mapping file. Used for gnatstub |
| -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric |
| -- (GNAT METRIC). |
| |
| procedure Non_VMS_Usage; |
| -- Display usage for platforms other than VMS |
| |
| procedure Process_Link; |
| -- Process GNAT LINK, when there is a project file specified |
| |
| procedure Set_Library_For |
| (Project : Project_Id; |
| Tree : Project_Tree_Ref; |
| Libraries_Present : in out Boolean); |
| -- If Project is a library project, add the correct -L and -l switches to |
| -- the linker invocation. |
| |
| procedure Set_Libraries is new |
| For_Every_Project_Imported (Boolean, Set_Library_For); |
| -- Add the -L and -l switches to the linker for all the library projects |
| |
| -------------------------- |
| -- Add_To_Carg_Switches -- |
| -------------------------- |
| |
| procedure Add_To_Carg_Switches (Switch : String_Access) is |
| begin |
| -- If the Carg_Switches table is empty, put "-cargs" at the beginning |
| |
| if Carg_Switches.Last = 0 then |
| Carg_Switches.Increment_Last; |
| Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs"); |
| end if; |
| |
| Carg_Switches.Increment_Last; |
| Carg_Switches.Table (Carg_Switches.Last) := Switch; |
| end Add_To_Carg_Switches; |
| |
| --------------------------- |
| -- Add_To_Rules_Switches -- |
| --------------------------- |
| |
| procedure Add_To_Rules_Switches (Switch : String_Access) is |
| begin |
| -- If the Rules_Switches table is empty, put "-rules" at the beginning |
| |
| if Rules_Switches.Last = 0 then |
| Rules_Switches.Increment_Last; |
| Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules"); |
| end if; |
| |
| Rules_Switches.Increment_Last; |
| Rules_Switches.Table (Rules_Switches.Last) := Switch; |
| end Add_To_Rules_Switches; |
| |
| ----------------- |
| -- 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 or if |
| -- there is a -files= switch. |
| |
| for Index in 1 .. Last_Switches.Last loop |
| if Last_Switches.Table (Index).all'Length > 7 |
| and then Last_Switches.Table (Index) (1 .. 7) = "-files=" |
| then |
| Add_Sources := False; |
| exit; |
| |
| elsif Last_Switches.Table (Index) (1) /= '-' then |
| if Index = 1 |
| or else |
| (The_Command = Check |
| and then Last_Switches.Table (Index - 1).all /= "-o") |
| or else |
| (The_Command = Pretty |
| and then Last_Switches.Table (Index - 1).all /= "-o" |
| and then Last_Switches.Table (Index - 1).all /= "-of") |
| or else |
| (The_Command = Metric |
| and then |
| Last_Switches.Table (Index - 1).all /= "-o" and then |
| Last_Switches.Table (Index - 1).all /= "-og" and then |
| Last_Switches.Table (Index - 1).all /= "-ox" and then |
| Last_Switches.Table (Index - 1).all /= "-d") |
| or else |
| (The_Command /= Check and then |
| The_Command /= Pretty and then |
| The_Command /= Metric) |
| then |
| Add_Sources := False; |
| exit; |
| end if; |
| 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 |
| |
| -- For gnatcheck, gnatpp, and gnatmetric, create a temporary file |
| -- and put the list of sources in it. For gnatstack create a |
| -- temporary file with the list of .ci files. |
| |
| if The_Command = Check or else |
| The_Command = Pretty or else |
| The_Command = Metric or else |
| The_Command = Stack |
| then |
| Tempdir.Create_Temp_File (FD, Temp_File_Name); |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| new String'("-files=" & Get_Name_String (Temp_File_Name)); |
| end if; |
| |
| declare |
| Proj : Project_List; |
| |
| begin |
| -- Gnatstack needs to add the .ci file for the binder generated |
| -- files corresponding to all of the library projects and main |
| -- units belonging to the application. |
| |
| if The_Command = Stack then |
| Proj := Project_Tree.Projects; |
| while Proj /= null loop |
| if Check_Project (Proj.Project, Project) then |
| declare |
| Main : String_List_Id; |
| |
| begin |
| -- Include binder generated files for main programs |
| |
| Main := Proj.Project.Mains; |
| while Main /= Nil_String loop |
| Add_To_Response_File |
| (Get_Name_String |
| (Proj.Project.Object_Directory.Name) & |
| B_Start.all & |
| MLib.Fil.Ext_To |
| (Get_Name_String |
| (Project_Tree.Shared.String_Elements.Table |
| (Main).Value), |
| "ci")); |
| |
| -- When looking for the .ci file for a binder |
| -- generated file, look for both b~xxx and b__xxx |
| -- as gprbuild always uses b__ as the prefix of |
| -- such files. |
| |
| if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) |
| and then B_Start.all /= "b__" |
| then |
| Add_To_Response_File |
| (Get_Name_String |
| (Proj.Project.Object_Directory.Name) & |
| "b__" & |
| MLib.Fil.Ext_To |
| (Get_Name_String |
| (Project_Tree.Shared |
| .String_Elements.Table (Main).Value), |
| "ci")); |
| end if; |
| |
| Main := Project_Tree.Shared.String_Elements.Table |
| (Main).Next; |
| end loop; |
| |
| if Proj.Project.Library then |
| |
| -- Include the .ci file for the binder generated |
| -- files that contains the initialization and |
| -- finalization of the library. |
| |
| Add_To_Response_File |
| (Get_Name_String |
| (Proj.Project.Object_Directory.Name) & |
| B_Start.all & |
| Get_Name_String (Proj.Project.Library_Name) & |
| ".ci"); |
| |
| -- When looking for the .ci file for a binder |
| -- generated file, look for both b~xxx and b__xxx |
| -- as gprbuild always uses b__ as the prefix of |
| -- such files. |
| |
| if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) |
| and then B_Start.all /= "b__" |
| then |
| Add_To_Response_File |
| (Get_Name_String |
| (Proj.Project.Object_Directory.Name) & |
| "b__" & |
| Get_Name_String (Proj.Project.Library_Name) & |
| ".ci"); |
| end if; |
| end if; |
| end; |
| end if; |
| |
| Proj := Proj.Next; |
| end loop; |
| end if; |
| |
| Unit := Units_Htable.Get_First (Project_Tree.Units_HT); |
| while Unit /= No_Unit_Index loop |
| |
| -- For gnatls, we only need to put the library units, body or |
| -- spec, but not the subunits. |
| |
| if The_Command = List then |
| 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 |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| new String' |
| (Get_Name_String |
| (Unit.File_Names |
| (Impl).Display_File)); |
| 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 |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| new String'(Get_Name_String |
| (Unit.File_Names (Spec).Display_File)); |
| end if; |
| end if; |
| |
| -- For gnatstack, we put the .ci files corresponding to the |
| -- different units, including the binder generated files. We |
| -- only need to do that for the library units, body or spec, |
| -- but not the subunits. |
| |
| elsif The_Command = Stack then |
| if Unit.File_Names (Impl) /= null |
| and then not Unit.File_Names (Impl).Locally_Removed |
| then |
| -- There is a body. Check if .ci files for this project |
| -- must be added. |
| |
| if Check_Project |
| (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 .ci files are not |
| -- generated for 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).Project. Object_Directory.Name) & |
| MLib.Fil.Ext_To |
| (Get_Name_String |
| (Unit.File_Names (Impl).Display_File), |
| "ci")); |
| end if; |
| end if; |
| |
| elsif Unit.File_Names (Spec) /= null |
| and then not Unit.File_Names (Spec).Locally_Removed |
| then |
| -- Spec with no body, check if it is for this project |
| |
| if Check_Project |
| (Unit.File_Names (Spec).Project, Project) |
| then |
| Add_To_Response_File |
| (Get_Name_String |
| (Unit.File_Names |
| (Spec).Project. Object_Directory.Name) & |
| Dir_Separator & |
| MLib.Fil.Ext_To |
| (Get_Name_String (Unit.File_Names (Spec).File), |
| "ci")); |
| end if; |
| end if; |
| |
| else |
| -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all |
| -- sources of the project, or of all projects if -U was |
| -- specified. |
| |
| for Kind in Spec_Or_Body loop |
| if Unit.File_Names (Kind) /= null |
| and then Check_Project |
| (Unit.File_Names (Kind).Project, Project) |
| and then not Unit.File_Names (Kind).Locally_Removed |
| then |
| Add_To_Response_File |
| ("""" & |
| Get_Name_String |
| (Unit.File_Names (Kind).Path.Display_Name) & |
| """", |
| Check_File => False); |
| end if; |
| end loop; |
| end if; |
| |
| Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); |
| end loop; |
| end; |
| |
| 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; |
| |
| ------------------- |
| -- Check_Project -- |
| ------------------- |
| |
| function Check_Project |
| (Project : Project_Id; |
| Root_Project : Project_Id) return Boolean |
| is |
| Proj : Project_Id; |
| |
| begin |
| if Project = No_Project then |
| return False; |
| |
| elsif All_Projects or else Project = Root_Project then |
| return True; |
| |
| elsif The_Command = Metric then |
| Proj := Root_Project; |
| while Proj.Extends /= No_Project loop |
| if Project = Proj.Extends then |
| return True; |
| end if; |
| |
| Proj := Proj.Extends; |
| end loop; |
| end if; |
| |
| return False; |
| end Check_Project; |
| |
| ------------------------------- |
| -- Check_Relative_Executable -- |
| ------------------------------- |
| |
| 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 (Project.Exec_Directory.Name); |
| |
| 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; |
| |
| -------------------------------- |
| -- Configuration_Pragmas_File -- |
| -------------------------------- |
| |
| function Configuration_Pragmas_File return Path_Name_Type is |
| begin |
| Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree); |
| return Project.Config_File_Name; |
| end Configuration_Pragmas_File; |
| |
| ------------------------------ |
| -- Delete_Temp_Config_Files -- |
| ------------------------------ |
| |
| procedure Delete_Temp_Config_Files is |
| Success : Boolean; |
| Proj : Project_List; |
| pragma Warnings (Off, Success); |
| |
| begin |
| -- This should only be called if Keep_Temporary_Files is False |
| |
| pragma Assert (not Keep_Temporary_Files); |
| |
| if Project /= No_Project then |
| Proj := Project_Tree.Projects; |
| while Proj /= null loop |
| if Proj.Project.Config_File_Temp then |
| Delete_Temporary_File |
| (Project_Tree.Shared, Proj.Project.Config_File_Name); |
| end if; |
| |
| Proj := Proj.Next; |
| end loop; |
| end if; |
| |
| -- If a temporary text file that contains a list of files for a tool |
| -- has been created, delete this temporary file. |
| |
| if Temp_File_Name /= No_Path then |
| Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name); |
| end if; |
| end Delete_Temp_Config_Files; |
| |
| --------------------------- |
| -- Ensure_Absolute_Path -- |
| --------------------------- |
| |
| procedure Ensure_Absolute_Path |
| (Switch : in out String_Access; |
| Parent : String) |
| is |
| begin |
| Makeutl.Ensure_Absolute_Path |
| (Switch, Parent, |
| Do_Fail => Osint.Fail'Access, |
| Including_Non_Switch => False, |
| Including_RTS => True); |
| end Ensure_Absolute_Path; |
| |
| ----------------- |
| -- Get_Closure -- |
| ----------------- |
| |
| procedure Get_Closure is |
| Args : constant Argument_List := |
| (1 => new String'("-q"), |
| 2 => new String'("-b"), |
| 3 => new String'("-P"), |
| 4 => Project_File, |
| 5 => ASIS_Main, |
| 6 => new String'("-bargs"), |
| 7 => new String'("-R"), |
| 8 => new String'("-Z")); |
| -- Arguments for the invocation of gnatmake which are added to the |
| -- Last_Arguments list by this procedure. |
| |
| FD : File_Descriptor; |
| -- File descriptor for the temp file that will get the output of the |
| -- invocation of gnatmake. |
| |
| Name : Path_Name_Type; |
| -- Path of the file FD |
| |
| GN_Name : constant String := Program_Name ("gnatmake", "gnat").all; |
| -- Name for gnatmake |
| |
| GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name); |
| -- Path of gnatmake |
| |
| Return_Code : Integer; |
| |
| Unused : Boolean; |
| pragma Warnings (Off, Unused); |
| |
| File : Ada.Text_IO.File_Type; |
| Line : String (1 .. 250); |
| Last : Natural; |
| -- Used to read file if there is an error, it is good enough to display |
| -- just 250 characters if the first line of the file is very long. |
| |
| Unit : Unit_Index; |
| Path : Path_Name_Type; |
| |
| Files_File : Ada.Text_IO.File_Type; |
| Temp_File_Name : Path_Name_Type; |
| |
| begin |
| if GN_Path = null then |
| Put_Line (Standard_Error, "could not locate " & GN_Name); |
| raise Error_Exit; |
| end if; |
| |
| -- Create the temp file |
| |
| Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files"); |
| |
| -- And close it, because on VMS Spawn with a file descriptor created |
| -- with Create_Temp_File does not redirect output. |
| |
| Close (FD); |
| |
| -- Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z" |
| |
| Spawn |
| (Program_Name => GN_Path.all, |
| Args => Args, |
| Output_File => Get_Name_String (Name), |
| Success => Unused, |
| Return_Code => Return_Code, |
| Err_To_Out => True); |
| |
| -- Read the output of the invocation of gnatmake |
| |
| Open (File, In_File, Get_Name_String (Name)); |
| |
| -- If it was unsuccessful, display the first line in the file and exit |
| -- with error. |
| |
| if Return_Code /= 0 then |
| Get_Line (File, Line, Last); |
| |
| begin |
| if not Keep_Temporary_Files then |
| Delete (File); |
| else |
| Close (File); |
| end if; |
| |
| -- Don't crash if it is not possible to delete or close the file, |
| -- just ignore the situation. |
| |
| exception |
| when others => |
| null; |
| end; |
| |
| Put_Line (Standard_Error, Line (1 .. Last)); |
| Put_Line |
| (Standard_Error, "could not get closure of " & ASIS_Main.all); |
| raise Error_Exit; |
| |
| else |
| -- Create a temporary file to put the list of files in the closure |
| |
| Tempdir.Create_Temp_File (FD, Temp_File_Name); |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| new String'("-files=" & Get_Name_String (Temp_File_Name)); |
| |
| Close (FD); |
| |
| Open (Files_File, Out_File, Get_Name_String (Temp_File_Name)); |
| |
| -- Get each file name in the file, find its path and add it the list |
| -- of arguments. |
| |
| while not End_Of_File (File) loop |
| Get_Line (File, Line, Last); |
| Path := No_Path; |
| |
| Unit := Units_Htable.Get_First (Project_Tree.Units_HT); |
| while Unit /= No_Unit_Index loop |
| if Unit.File_Names (Spec) /= null |
| and then |
| Get_Name_String (Unit.File_Names (Spec).File) = |
| Line (1 .. Last) |
| then |
| Path := Unit.File_Names (Spec).Path.Name; |
| exit; |
| |
| elsif Unit.File_Names (Impl) /= null |
| and then |
| Get_Name_String (Unit.File_Names (Impl).File) = |
| Line (1 .. Last) |
| then |
| Path := Unit.File_Names (Impl).Path.Name; |
| exit; |
| end if; |
| |
| Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); |
| end loop; |
| |
| if Path /= No_Path then |
| Put_Line (Files_File, Get_Name_String (Path)); |
| |
| else |
| Put_Line (Files_File, Line (1 .. Last)); |
| end if; |
| end loop; |
| |
| Close (Files_File); |
| |
| begin |
| if not Keep_Temporary_Files then |
| Delete (File); |
| else |
| Close (File); |
| end if; |
| |
| -- Don't crash if it is not possible to delete or close the file, |
| -- just ignore the situation. |
| |
| exception |
| when others => |
| null; |
| end; |
| end if; |
| end Get_Closure; |
| |
| ------------------ |
| -- Mapping_File -- |
| ------------------ |
| |
| function Mapping_File return Path_Name_Type is |
| Result : Path_Name_Type; |
| begin |
| Prj.Env.Create_Mapping_File |
| (Project => Project, |
| Language => Name_Ada, |
| In_Tree => Project_Tree, |
| Name => Result); |
| return Result; |
| end Mapping_File; |
| |
| ------------------- |
| -- Non_VMS_Usage -- |
| ------------------- |
| |
| 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 |
| |
| -- No usage for VMS only command or for Sync |
| |
| if not Command_List (C).VMS_Only and then C /= Sync then |
| if Targparm.AAMP_On_Target then |
| Put ("gnaampcmd "); |
| else |
| Put ("gnat "); |
| end if; |
| |
| Put (To_Lower (Command_List (C).Cname.all)); |
| Set_Col (25); |
| |
| -- Never call gnatstack with a prefix |
| |
| if C = Stack then |
| Put (Command_List (C).Unixcmd.all); |
| else |
| Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all); |
| end if; |
| |
| 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 ("All commands except chop, krunch and preprocess " & |
| "accept project file switches -vPx, -Pprj and -Xnam=val"); |
| New_Line; |
| end Non_VMS_Usage; |
| ------------------ |
| -- Process_Link -- |
| ------------------ |
| |
| procedure Process_Link is |
| Look_For_Executable : Boolean := True; |
| Libraries_Present : 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 the default search directories, to be able to find |
| -- libgnat in call to MLib.Utl.Lib_Directory. |
| |
| Add_Default_Search_Dirs; |
| |
| Library_Paths.Set_Last (0); |
| |
| -- Check if there are library project files |
| |
| if MLib.Tgt.Support_For_Libraries /= None then |
| Set_Libraries (Project, Project_Tree, Libraries_Present); |
| end if; |
| |
| -- If there are, add the necessary additional switches |
| |
| if Libraries_Present then |
| |
| -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir> |
| |
| 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 is not null, create the switch ("-Wl,-rpath," or |
| -- equivalent) with all the library dirs plus the standard GNAT |
| -- library dir. |
| |
| if Path_Option /= null then |
| declare |
| Option : String_Access; |
| Length : Natural := Path_Option'Length; |
| Current : Natural; |
| |
| begin |
| if MLib.Separate_Run_Path_Options then |
| |
| -- We are going to create one switch of the form |
| -- "-Wl,-rpath,dir_N" for each directory to consider. |
| |
| -- One switch for each library directory |
| |
| for Index in |
| Library_Paths.First .. Library_Paths.Last |
| loop |
| Last_Switches.Increment_Last; |
| Last_Switches.Table |
| (Last_Switches.Last) := new String' |
| (Path_Option.all & |
| Last_Switches.Table (Index).all); |
| end loop; |
| |
| -- One switch for the standard GNAT library dir |
| |
| Last_Switches.Increment_Last; |
| Last_Switches.Table |
| (Last_Switches.Last) := new String' |
| (Path_Option.all & MLib.Utl.Lib_Directory); |
| |
| else |
| -- First, compute the exact length for the switch |
| |
| for Index in |
| Library_Paths.First .. Library_Paths.Last |
| loop |
| -- Add the length of the library dir plus one for the |
| -- directory separator. |
| |
| Length := |
| Length + |
| Library_Paths.Table (Index)'Length + 1; |
| end loop; |
| |
| -- Finally, add the length of the standard GNAT library dir |
| |
| Length := Length + MLib.Utl.Lib_Directory'Length; |
| Option := new String (1 .. Length); |
| Option (1 .. Path_Option'Length) := Path_Option.all; |
| Current := Path_Option'Length; |
| |
| -- Put each library dir followed by a dir separator |
| |
| 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; |
| |
| -- Finally put the standard GNAT library dir |
| |
| Option |
| (Current + 1 .. |
| Current + MLib.Utl.Lib_Directory'Length) := |
| MLib.Utl.Lib_Directory; |
| |
| -- And add the switch to the last switches |
| |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| Option; |
| end if; |
| end; |
| end if; |
| end if; |
| |
| -- Check if the first ALI file specified can be found, either in the |
| -- object directory of the main project or in an object directory of a |
| -- project file extended by the main project. If the ALI file can be |
| -- found, replace its name with its absolute path. |
| |
| Skip_Executable := False; |
| |
| Switch_Loop : for J in 1 .. Last_Switches.Last loop |
| |
| -- If we have an executable just reset the flag |
| |
| if Skip_Executable then |
| Skip_Executable := False; |
| |
| -- If -o, set flag so that next switch is not processed |
| |
| elsif Last_Switches.Table (J).all = "-o" then |
| Skip_Executable := True; |
| |
| -- Normal case |
| |
| 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; |
| |
| -- Skip real switches |
| |
| if Switch'Length /= 0 |
| and then Switch (Switch'First) /= '-' |
| then |
| -- Append ".ali" if file name does not end with it |
| |
| if Switch'Length <= 4 |
| or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali" |
| then |
| Last := ALI_File'Last; |
| end if; |
| |
| -- If file name includes directory information, stop if ALI |
| -- file exists. |
| |
| 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; |
| |
| -- Look in object directories if ALI file exists |
| |
| else |
| Project_Loop : loop |
| declare |
| Dir : constant String := |
| Get_Name_String (Prj.Object_Directory.Name); |
| begin |
| if Is_Regular_File |
| (Dir & |
| ALI_File (1 .. Last)) |
| then |
| -- We have found the correct project, so we |
| -- replace the file with the absolute path. |
| |
| Last_Switches.Table (J) := |
| new String'(Dir & ALI_File (1 .. Last)); |
| |
| -- And we are done |
| |
| exit Switch_Loop; |
| end if; |
| end; |
| |
| -- Go to the project being extended, if any |
| |
| Prj := Prj.Extends; |
| exit Project_Loop when Prj = No_Project; |
| end loop Project_Loop; |
| end if; |
| end if; |
| end; |
| end if; |
| end loop Switch_Loop; |
| |
| -- If a relative path output file has been specified, we add the exec |
| -- directory. |
| |
| 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 no executable is specified, then find the name of the first ALI |
| -- file on the command line and issue a -o switch with the absolute path |
| -- of the executable in the exec directory. |
| |
| 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 (Project.Exec_Directory.Name); |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| new String'(Name_Buffer (1 .. Name_Len) & |
| Executable_Name |
| (Base_Name (Arg (Arg'First .. Last)))); |
| exit; |
| end if; |
| end if; |
| end loop; |
| end if; |
| end Process_Link; |
| |
| --------------------- |
| -- Set_Library_For -- |
| --------------------- |
| |
| procedure Set_Library_For |
| (Project : Project_Id; |
| Tree : Project_Tree_Ref; |
| Libraries_Present : in out Boolean) |
| is |
| pragma Unreferenced (Tree); |
| |
| Path_Option : constant String_Access := |
| MLib.Linker_Library_Path_Option; |
| |
| begin |
| -- Case of library project |
| |
| if Project.Library then |
| Libraries_Present := True; |
| |
| -- Add the -L switch |
| |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| new String'("-L" & Get_Name_String (Project.Library_Dir.Name)); |
| |
| -- Add the -l switch |
| |
| Last_Switches.Increment_Last; |
| Last_Switches.Table (Last_Switches.Last) := |
| new String'("-l" & Get_Name_String (Project.Library_Name)); |
| |
| -- Add the directory to table Library_Paths, to be processed later |
| -- if library is not static and if Path_Option is not null. |
| |
| if 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 (Project.Library_Dir.Name)); |
| end if; |
| end if; |
| end Set_Library_For; |
| |
| -- 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; |
| |
| Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags); |
| Prj.Env.Initialize_Default_Project_Path |
| (Root_Environment.Project_Path, |
| Target_Name => Sdefault.Target_Name.all); |
| |
| 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); |
| Carg_Switches.Init; |
| Carg_Switches.Set_Last (0); |
| Rules_Switches.Init; |
| Rules_Switches.Set_Last (0); |
| |
| VMS_Conv.Initialize; |
| |
| -- Add the default search directories, to be able to find system.ads in the |
| -- subsequent call to Targparm.Get_Target_Parameters. |
| |
| Add_Default_Search_Dirs; |
| |
| -- Get target parameters so that AAMP_On_Target will be set, for testing in |
| -- Osint.Program_Name to handle the mapping of GNAAMP tool names. |
| |
| Targparm.Get_Target_Parameters; |
| |
| -- 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; |
| |
| -- On OpenVMS, setenv creates a logical whose length is limited to |
| -- 255 bytes. |
| |
| if OpenVMS and then Name_Len > Max_OpenVMS_Logical_Length then |
| Name_Buffer (Max_OpenVMS_Logical_Length - 2 |
| .. Max_OpenVMS_Logical_Length) := "..."; |
| Name_Len := Max_OpenVMS_Logical_Length; |
| end if; |
| |
| 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. Do not do this |
| -- for VMS, where the notion of path does not really exist. |
| |
| 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 on VMS, or if VMS emulation is on, convert VMS style /qualifiers, |
| -- filenames and pathnames to Unix style. |
| |
| if Hostparm.OpenVMS |
| or else To_Lower (Getenv ("EMULATE_VMS").all) = "true" |
| then |
| VMS_Conversion (The_Command); |
| |
| B_Start := new String'("b__"); |
| |
| -- If not on VMS, scan the command line directly |
| |
| 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 => |
| |
| -- 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 => |
| Non_VMS_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; |
| end if; |
| end if; |
| |
| declare |
| Program : String_Access; |
| Exec_Path : String_Access; |
| |
| 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"); |
| end if; |
| |
| -- For the tools where the GNAT driver processes the project files, |
| -- allow shared library projects to import projects that are not shared |
| -- library projects, to avoid adding a switch for these tools. For the |
| -- builder (gnatmake), if a shared library project imports a project |
| -- that is not a shared library project and the appropriate switch is |
| -- not specified, the invocation of gnatmake will fail. |
| |
| Opt.Unchecked_Shared_Lib_Imports := True; |
| |
| -- 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 BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB, |
| -- SYNC and XREF, look for project file related switches. |
| |
| case The_Command is |
| when Bind => |
| Tool_Package_Name := Name_Binder; |
| Packages_To_Check := Packages_To_Check_By_Binder; |
| when Check => |
| Tool_Package_Name := Name_Check; |
| Packages_To_Check := Packages_To_Check_By_Check; |
| 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 Stack => |
| Tool_Package_Name := Name_Stack; |
| Packages_To_Check := Packages_To_Check_By_Stack; |
| when Stub => |
| Tool_Package_Name := Name_Gnatstub; |
| Packages_To_Check := Packages_To_Check_By_Gnatstub; |
| when Sync => |
| Tool_Package_Name := Name_Synchronize; |
| Packages_To_Check := Packages_To_Check_By_Sync; |
| when Xref => |
| Tool_Package_Name := Name_Cross_Reference; |
| Packages_To_Check := Packages_To_Check_By_Xref; |
| when others => |
| Tool_Package_Name := No_Name; |
| end case; |
| |
| if Tool_Package_Name /= No_Name then |
| |
| -- 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; |
| |
| -- The two style project files (-p and -P) cannot be used |
| -- together |
| |
| 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; |
| |
| -- --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)); |
| |
| Remove_Switch (Arg_Num); |
| |
| -- -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 |
| & """)"); |
| |
| -- The two style project files (-p and -P) cannot be |
| -- used together. |
| |
| elsif Old_Project_File_Used then |
| Fail ("-p and -P cannot be used together"); |
| |
| 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); |
| |
| elsif |
| (The_Command = Check or else |
| The_Command = Sync or else |
| The_Command = Pretty or else |
| The_Command = Metric or else |
| The_Command = Stack or else |
| 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; |
| |
| elsif ((The_Command = Check and then Argv (Argv'First) /= '+') |
| or else The_Command = Sync |
| or else The_Command = Metric |
| or else The_Command = Pretty) |
| and then Project_File /= null |
| and then All_Projects |
| then |
| if ASIS_Main /= null then |
| Fail ("cannot specify more than one main after -U"); |
| else |
| ASIS_Main := Argv; |
| Remove_Switch (Arg_Num); |
| end if; |
| |
| else |
| Arg_Num := Arg_Num + 1; |
| end if; |
| end loop; |
| end Inspect_Switches; |
| end if; |
| |
| -- 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"); |
| 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); |
| |
| -- Packages Gnatls and Gnatstack have a single attribute |
| -- Switches, that is not an associative array. |
| |
| if The_Command = List or else The_Command = Stack 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), |
| -- Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check |
| -- (for gnatcheck), and Metric (for gnatmetric) 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 |
| or else The_Command = Elim |
| 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 => False); |
| |
| -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create |
| -- a configuration pragmas file, if necessary. |
| |
| if The_Command = Pretty |
| or else The_Command = Metric |
| or else The_Command = Stub |
| or else The_Command = Elim |
| or else The_Command = Check |
| or else The_Command = Sync |
| then |
| -- If there are switches in package Compiler, put them in the |
| -- Carg_Switches table. |
| |
| declare |
| Pkg : constant Prj.Package_Id := |
| Prj.Util.Value_Of |
| (Name => Name_Compiler, |
| 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; |
| Main_Id : Name_Id; |
| |
| begin |
| if Pkg /= No_Package then |
| |
| -- First, check if there is a single main specified |
| |
| 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; |
| |
| Element := Project_Tree.Shared.Packages.Table (Pkg); |
| |
| -- If there is a single main and there is compilation |
| -- switches specified in the project file, use them. |
| |
| if Main /= null and then not All_Projects then |
| Name_Len := Main'Length; |
| Name_Buffer (1 .. Name_Len) := Main.all; |
| Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); |
| Main_Id := Name_Find; |
| |
| Switches_Array := |
| Prj.Util.Value_Of |
| (Name => Name_Switches, |
| In_Arrays => Element.Decl.Arrays, |
| Shared => Project_Tree.Shared); |
| The_Switches := Prj.Util.Value_Of |
| (Index => Main_Id, |
| Src_Index => 0, |
| In_Array => Switches_Array, |
| Shared => Project_Tree.Shared); |
| end if; |
| |
| -- Otherwise, get the Default_Switches ("Ada") |
| |
| if The_Switches.Kind = 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; |
| |
| -- If there are switches specified, put them in the |
| -- Carg_Switches table. |
| |
| 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 |
| Add_To_Carg_Switches (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 |
| Add_To_Carg_Switches (new String'(Switch)); |
| end if; |
| end; |
| |
| Current := The_String.Next; |
| end loop; |
| end case; |
| end if; |
| end; |
| |
| -- If -cargs is one of the switches, move the following switches |
| -- to the Carg_Switches table. |
| |
| for J in 1 .. First_Switches.Last loop |
| if First_Switches.Table (J).all = "-cargs" then |
| declare |
| K : Positive; |
| Last : Natural; |
| |
| begin |
| -- Move the switches that are before -rules when the |
| -- command is CHECK. |
| |
| K := J + 1; |
| while K <= First_Switches.Last |
| and then |
| (The_Command /= Check |
| or else First_Switches.Table (K).all /= "-rules") |
| loop |
| Add_To_Carg_Switches (First_Switches.Table (K)); |
| K := K + 1; |
| end loop; |
| |
| if K > First_Switches.Last then |
| First_Switches.Set_Last (J - 1); |
| |
| else |
| Last := J - 1; |
| while K <= First_Switches.Last loop |
| Last := Last + 1; |
| First_Switches.Table (Last) := |
| First_Switches.Table (K); |
| K := K + 1; |
| end loop; |
| |
| First_Switches.Set_Last (Last); |
| end if; |
| end; |
| |
| exit; |
| end if; |
| end loop; |
| |
| for J in 1 .. Last_Switches.Last loop |
| if Last_Switches.Table (J).all = "-cargs" then |
| declare |
| K : Positive; |
| Last : Natural; |
| |
| begin |
| -- Move the switches that are before -rules when the |
| -- command is CHECK. |
| |
| K := J + 1; |
| while K <= Last_Switches.Last |
| and then |
| (The_Command /= Check |
| or else Last_Switches.Table (K).all /= "-rules") |
| loop |
| Add_To_Carg_Switches (Last_Switches.Table (K)); |
| K := K + 1; |
| end loop; |
| |
| if K > Last_Switches.Last then |
| Last_Switches.Set_Last (J - 1); |
| |
| else |
| Last := J - 1; |
| while K <= Last_Switches.Last loop |
| Last := Last + 1; |
| Last_Switches.Table (Last) := |
| Last_Switches.Table (K); |
| K := K + 1; |
| end loop; |
| |
| Last_Switches.Set_Last (Last); |
| end if; |
| end; |
| |
| exit; |
| end if; |
| end loop; |
| |
| declare |
| CP_File : constant Path_Name_Type := Configuration_Pragmas_File; |
| M_File : constant Path_Name_Type := Mapping_File; |
| |
| begin |
| if CP_File /= No_Path then |
| if The_Command = Elim then |
| First_Switches.Increment_Last; |
| First_Switches.Table (First_Switches.Last) := |
| new String'("-C" & Get_Name_String (CP_File)); |
| |
| else |
| Add_To_Carg_Switches |
| (new String'("-gnatec=" & Get_Name_String (CP_File))); |
| end if; |
| end if; |
| |
| if M_File /= No_Path then |
| Add_To_Carg_Switches |
| (new String'("-gnatem=" & Get_Name_String (M_File))); |
| end if; |
| |
| -- For gnatcheck, gnatpp, gnatstub and gnatmetric, also |
| -- indicate a global configuration pragmas file and, if -U |
| -- is not used, a local one. |
| |
| if The_Command = Check or else |
| The_Command = Pretty or else |
| The_Command = Stub or else |
| The_Command = Metric |
| then |
| declare |
| Pkg : constant Prj.Package_Id := |
| Prj.Util.Value_Of |
| (Name => Name_Builder, |
| In_Packages => Project.Decl.Packages, |
| Shared => Project_Tree.Shared); |
| |
| Variable : Variable_Value := |
| Prj.Util.Value_Of |
| (Name => No_Name, |
| Attribute_Or_Array_Name => |
| Name_Global_Configuration_Pragmas, |
| In_Package => Pkg, |
| Shared => Project_Tree.Shared); |
| |
| begin |
| if (Variable = Nil_Variable_Value |
| or else Length_Of_Name (Variable.Value) = 0) |
| and then Pkg /= No_Package |
| then |
| Variable := |
| Prj.Util.Value_Of |
| (Name => Name_Ada, |
| Attribute_Or_Array_Name => |
| Name_Global_Config_File, |
| In_Package => Pkg, |
| Shared => Project_Tree.Shared); |
| end if; |
| |
| if Variable /= Nil_Variable_Value |
| and then Length_Of_Name (Variable.Value) /= 0 |
| then |
| declare |
| Path : constant String := |
| Absolute_Path |
| (Path_Name_Type (Variable.Value), |
| Variable.Project); |
| begin |
| Add_To_Carg_Switches |
| (new String'("-gnatec=" & Path)); |
| end; |
| end if; |
| end; |
| |
| if not All_Projects then |
| declare |
| Pkg : constant Prj.Package_Id := |
| Prj.Util.Value_Of |
| (Name => Name_Compiler, |
| In_Packages => Project.Decl.Packages, |
| Shared => Project_Tree.Shared); |
| |
| Variable : Variable_Value := |
| Prj.Util.Value_Of |
| (Name => No_Name, |
| Attribute_Or_Array_Name => |
| Name_Local_Configuration_Pragmas, |
| In_Package => Pkg, |
| Shared => Project_Tree.Shared); |
| |
| begin |
| if (Variable = Nil_Variable_Value |
| or else Length_Of_Name (Variable.Value) = 0) |
| and then Pkg /= No_Package |
| then |
| Variable := |
| Prj.Util.Value_Of |
| (Name => Name_Ada, |
| Attribute_Or_Array_Name => |
| Name_Local_Config_File, |
| In_Package => Pkg, |
| Shared => |
| Project_Tree.Shared); |
| end if; |
| |
| if Variable /= Nil_Variable_Value |
| and then Length_Of_Name (Variable.Value) /= 0 |
| then |
| declare |
| Path : constant String := |
| Absolute_Path |
| (Path_Name_Type (Variable.Value), |
| Variable.Project); |
| begin |
| Add_To_Carg_Switches |
| (new String'("-gnatec=" & Path)); |
| end; |
| end if; |
| end; |
| end if; |
| end if; |
| end; |
| end if; |
| |
| if The_Command = Link then |
| Process_Link; |
| end if; |
| |
| if The_Command = Link or else The_Command = Bind then |
| |
| -- For files that are specified as relative paths with directory |
| -- information, we convert them to absolute paths, with parent |
| -- being the current working directory if specified on the command |
| -- line and the project directory if specified in the project |
| -- file. This is what gnatmake is doing for linker and binder |
| -- arguments. |
| |
| for J in 1 .. Last_Switches.Last loop |
| GNATCmd.Ensure_Absolute_Path |
| (Last_Switches.Table (J), Current_Work_Dir); |
| end loop; |
| |
| Get_Name_String (Project.Directory.Name); |
| |
| declare |
| Project_Dir : constant String := Name_Buffer (1 .. Name_Len); |
| begin |
| for J in 1 .. First_Switches.Last loop |
| GNATCmd.Ensure_Absolute_Path |
| (First_Switches.Table (J), Project_Dir); |
| end loop; |
| end; |
| |
| elsif The_Command = Stub then |
| declare |
| File_Index : Integer := 0; |
| Dir_Index : Integer := 0; |
| Last : constant Integer := Last_Switches.Last; |
| Lang : constant Language_Ptr := |
| Get_Language_From_Name (Project, "ada"); |
| |
| 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 the project file naming scheme is not standard, and if |
| -- the file name ends with the spec suffix, then indicate to |
| -- gnatstub the name of the body file with a -o switch. |
| |
| if Lang /= No_Language_Index |
| and then not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) |
| 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 (Lang.Config.Naming_Data.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 |
| (Lang.Config.Naming_Data.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; |
| |
| -- Add the directory of the spec as the destination directory |
| -- of the body, if there is no destination directory already |
| -- specified. |
| |
| 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; |
| |
| -- For gnatmetric, the generated files should be put in the object |
| -- directory. This must be the first switch, because it may be |
| -- overridden by a switch in package Metrics in the project file or |
| -- by a command line option. Note that we don't add the -d= switch |
| -- if there is no object directory available. |
| |
| if The_Command = Metric |
| and then Project.Object_Directory /= No_Path_Information |
| 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 (Project.Object_Directory.Name)); |
| end if; |
| |
| -- For gnat check, -rules and the following switches need to be the |
| -- last options, so move all these switches to table Rules_Switches. |
| |
| if The_Command = Check then |
| declare |
| New_Last : Natural; |
| -- Set to rank of options preceding "-rules" |
| |
| In_Rules_Switches : Boolean; |
| -- Set to True when options "-rules" is found |
| |
| begin |
| New_Last := First_Switches.Last; |
| In_Rules_Switches := False; |
| |
| for J in 1 .. First_Switches.Last loop |
| if In_Rules_Switches then |
| Add_To_Rules_Switches (First_Switches.Table (J)); |
| |
| elsif First_Switches.Table (J).all = "-rules" then |
| New_Last := J - 1; |
| In_Rules_Switches := True; |
| end if; |
| end loop; |
| |
| if In_Rules_Switches then |
| First_Switches.Set_Last (New_Last); |
| end if; |
| |
| New_Last := Last_Switches.Last; |
| In_Rules_Switches := False; |
| |
| for J in 1 .. Last_Switches.Last loop |
| if In_Rules_Switches then |
| Add_To_Rules_Switches (Last_Switches.Table (J)); |
| |
| elsif Last_Switches.Table (J).all = "-rules" then |
| New_Last := J - 1; |
| In_Rules_Switches := True; |
| end if; |
| end loop; |
| |
| if In_Rules_Switches then |
| Last_Switches.Set_Last (New_Last); |
| end if; |
| end; |
| end if; |
| |
| -- For gnat check, sync, metric or pretty with -U + a main, get the |
| -- list of sources from the closure and add them to the arguments. |
| |
| if ASIS_Main /= null then |
| Get_Closure; |
| |
| -- On VMS, set up the env var again for source dirs file. This is |
| -- because the call to gnatmake has set this env var to another |
| -- file that has now been deleted. |
| |
| if Hostparm.OpenVMS then |
| |
| -- First make sure that the recorded file names are empty |
| |
| Prj.Env.Initialize (Project_Tree); |
| |
| Prj.Env.Set_Ada_Paths |
| (Project, Project_Tree, Including_Libraries => False); |
| end if; |
| |
| -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list, |
| -- and gnat stack, if no file has been put on the command line, call |
| -- tool with all the sources of the main project. |
| |
| elsif The_Command = Check or else |
| The_Command = Sync or else |
| The_Command = Pretty or else |
| The_Command = Metric or else |
| The_Command = List or else |
| The_Command = Stack |
| 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 + |
| Carg_Switches.Last + |
| Rules_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; |
| |
| for J in 1 .. Carg_Switches.Last loop |
| Arg_Num := Arg_Num + 1; |
| The_Args (Arg_Num) := Carg_Switches.Table (J); |
| end loop; |
| |
| for J in 1 .. Rules_Switches.Last loop |
| Arg_Num := Arg_Num + 1; |
| The_Args (Arg_Num) := Rules_Switches.Table (J); |
| end loop; |
| |
| -- If Display_Command is on, only display the generated command |
| |
| 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 => |
| if not Keep_Temporary_Files then |
| Prj.Delete_All_Temp_Files (Project_Tree.Shared); |
| Delete_Temp_Config_Files; |
| end if; |
| |
| Set_Exit_Status (Failure); |
| |
| when Normal_Exit => |
| if not Keep_Temporary_Files then |
| Prj.Delete_All_Temp_Files (Project_Tree.Shared); |
| Delete_Temp_Config_Files; |
| end if; |
| |
| -- Since GNATCmd is normally called from DCL (the VMS shell), it must |
| -- return an understandable VMS exit status. However the exit status |
| -- returned *to* GNATCmd is a Posix style code, so we test it and return |
| -- just a simple success or failure on VMS. |
| |
| 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; |
