X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fgnatcmd.adb;h=87983997a7a5471566eaf39055883d7a227f190e;hb=8ea9ace27b85d52f2d24f567fd7433e4da712bbc;hp=c4137a95abdc01a44e12770d5944eb7754847fc1;hpb=f27cea3abf8ded22456f5f46a812cc3915969815;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index c4137a95abd..87983997a7a 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2012, 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 2, or (at your option) any later ver- -- +-- 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 COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- 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. -- @@ -27,52 +26,63 @@ 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; +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 Hostparm; use Hostparm; --- Used to determine if we are in VMS or not for error message purposes +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; - -with Table; - -with VMS_Conv; use VMS_Conv; +with GNAT.OS_Lib; use GNAT.OS_Lib; procedure GNATCmd is - Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data; + 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 conjonction + -- an old fashioned project file. -p cannot be used in conjunction -- with -P. - Max_Files_On_The_Command_Line : constant := 30; -- Arbitrary - - Temp_File_Name : String_Access := null; + 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, when there are more than - -- Max_Files_On_The_Command_Line files. + -- 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, @@ -92,6 +102,15 @@ procedure GNATCmd is 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, @@ -104,22 +123,36 @@ procedure GNATCmd is -- tool. We allocate objects because we cannot declare aliased objects -- as we are in a procedure, not a library level package. - Naming_String : constant String_Access := new String'("naming"); - Binder_String : constant String_Access := new String'("binder"); - Eliminate_String : constant String_Access := new String'("eliminate"); - Finder_String : constant String_Access := new String'("finder"); - Linker_String : constant String_Access := new String'("linker"); - Gnatls_String : constant String_Access := new String'("gnatls"); - Pretty_String : constant String_Access := new String'("pretty_printer"); - Gnatstub_String : constant String_Access := new String'("gnatstub"); - Metric_String : constant String_Access := new String'("metrics"); - Xref_String : constant String_Access := new String'("cross_reference"); + 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)); + 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)); @@ -131,13 +164,16 @@ procedure GNATCmd is new String_List'((Naming_String, Gnatls_String)); Packages_To_Check_By_Pretty : constant String_List_Access := - new String_List'((Naming_String, Pretty_String)); + 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)); + 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)); + 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)); @@ -162,74 +198,87 @@ procedure GNATCmd is -- The path of the working directory All_Projects : Boolean := False; - -- Flag used for GNAT PRETTY and GNAT METRIC to indicate that - -- the underlying tool (gnatpp or gnatmetric) should be invoked for all - -- sources of all projects. + -- 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. + -- 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 and GNAT METRIC, check if a project - -- file is specified, without any file arguments. If it is the case, - -- invoke the GNAT tool with the proper list of files, derived from - -- the sources of the project. + -- 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. - -- For GNAT METRIC, also returns True if Project is extended by - -- Root_Project. + -- 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. + -- 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 Name_Id; + 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). + -- specified for Project, otherwise return No_Name. Used for gnatstub (GNAT + -- STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric (GNAT + -- METRIC). + + 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 Delete_Temp_Config_Files; - -- Delete all temporary config files + -- Delete all temporary config files. The caller is responsible for + -- ensuring that Keep_Temporary_Files is False. - function Index (Char : Character; Str : String) return Natural; - -- Returns the first occurrence of Char in Str. - -- Returns 0 if Char is not in Str. + procedure Get_Closure; + -- Get the sources in the closure of the ASIS_Main and add them to the + -- list of arguments. procedure Non_VMS_Usage; -- Display usage for platforms other than VMS procedure Process_Link; - -- Process GNAT LINK, when there is a project file specified. + -- Process GNAT LINK, when there is a project file specified procedure Set_Library_For - (Project : Project_Id; - There_Are_Libraries : in out Boolean); - -- If Project is a library project, add the correct - -- -L and -l switches to the linker invocation. + (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 - -- of the library projects. + -- Add the -L and -l switches to the linker for all of the library + -- projects. procedure Test_If_Relative_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. + -- 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. -------------------------- -- Add_To_Carg_Switches -- @@ -248,71 +297,259 @@ procedure GNATCmd is 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_Data : Prj.Unit_Data; + 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 + -- 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) (1) /= '-' then + 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 were switches, add the path names of - -- all the sources of the main project. + -- 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 - Current_Last : constant Integer := Last_Switches.Last; + Proj : Project_List; + begin - for Unit in Unit_Table.First .. - Unit_Table.Last (Project_Tree.Units) - loop - Unit_Data := Project_Tree.Units.Table (Unit); + -- 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; - -- For gnatls, we only need to put the library units, - -- body or spec, but not the subunits. + 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_Data.File_Names (Body_Part).Name /= No_Name + 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. + -- There is a body, check if it is for this project - if Unit_Data.File_Names (Body_Part).Project = - Project + if All_Projects + or else Unit.File_Names (Impl).Project = Project then Subunit := False; - if Unit_Data.File_Names (Specification).Name = - No_Name + 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. + -- 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 : Source_File_Index; - + Src_Ind : constant Source_File_Index := + Sinput.P.Load_Project_File + (Get_Name_String + (Unit.File_Names + (Impl).Path.Name)); begin - Src_Ind := Sinput.P.Load_Project_File - (Get_Name_String - (Unit_Data.File_Names - (Body_Part).Path)); - Subunit := - Sinput.P.Source_File_Is_Subunit - (Src_Ind); + Sinput.P.Source_File_Is_Subunit (Src_Ind); end; end if; @@ -321,108 +558,126 @@ procedure GNATCmd is Last_Switches.Table (Last_Switches.Last) := new String' (Get_Name_String - (Unit_Data.File_Names - (Body_Part).Display_Name)); + (Unit.File_Names + (Impl).Display_File)); end if; end if; - elsif Unit_Data.File_Names (Specification).Name /= - No_Name + 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. + -- We have a spec with no body. Check if it is for this + -- project. - if Unit_Data.File_Names (Specification).Project = - 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_Data.File_Names - (Specification).Display_Name)); + new String'(Get_Name_String + (Unit.File_Names (Spec).Display_File)); end if; end if; - else - -- For gnatpp and gnatmetric, put all sources - -- of the project, or of all projects if -U was specified. - - for Kind in Spec_Or_Body loop + -- 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. - -- Put only sources that belong to the main - -- project. + 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_Data.File_Names (Kind).Project, Project) + (Unit.File_Names (Impl).Project, Project) then - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - new String' - (Get_Name_String - (Unit_Data.File_Names - (Kind).Display_Path)); - end if; - end loop; - end if; - end loop; + Subunit := False; - -- If the list of files is too long, create a temporary - -- text file that lists these files, and pass this temp - -- file to gnatpp or gnatmetric using switch -files=. + 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. - if Last_Switches.Last - Current_Last > - Max_Files_On_The_Command_Line - then - declare - Temp_File_FD : File_Descriptor; - Buffer : String (1 .. 1_000); - Len : Natural; - OK : Boolean := True; + 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; - begin - Create_Temp_File (Temp_File_FD, Temp_File_Name); + 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; - if Temp_File_Name /= null then - for Index in Current_Last + 1 .. - Last_Switches.Last - loop - Len := Last_Switches.Table (Index)'Length; - Buffer (1 .. Len) := - Last_Switches.Table (Index).all; - Len := Len + 1; - Buffer (Len) := ASCII.LF; - Buffer (Len + 1) := ASCII.NUL; - OK := - Write (Temp_File_FD, - Buffer (1)'Address, - Len) = Len; - exit when not OK; - end loop; + 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 OK then - Close (Temp_File_FD, OK); - else - Close (Temp_File_FD, OK); - OK := False; + 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; - -- If there were any problem creating the temp - -- file, then pass the list of files. + else + -- For gnatcheck, gnatsync, gnatpp and gnatmetric, put all + -- sources of the project, or of all projects if -U was + -- specified. - if OK then + 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; - -- Replace the list of files with - -- "-files=". + Unit := Units_Htable.Get_Next (Project_Tree.Units_HT); + end loop; + end; - Last_Switches.Set_Last (Current_Last + 1); - Last_Switches.Table (Last_Switches.Last) := - new String'("-files=" & Temp_File_Name.all); - end if; - end if; - end; + if FD /= Invalid_FD then + Close (FD, Success); + + if not Success then + Osint.Fail ("disk full"); end if; - end; + end if; end if; end Check_Files; @@ -434,27 +689,24 @@ procedure GNATCmd is (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 Project = Root_Project then + elsif All_Projects or else Project = Root_Project then return True; elsif The_Command = Metric then - declare - Data : Project_Data := - Project_Tree.Projects.Table (Root_Project); - - begin - while Data.Extends /= No_Project loop - if Project = Data.Extends then - return True; - end if; + Proj := Root_Project; + while Proj.Extends /= No_Project loop + if Project = Proj.Extends then + return True; + end if; - Data := Project_Tree.Projects.Table (Data.Extends); - end loop; - end; + Proj := Proj.Extends; + end loop; end if; return False; @@ -478,8 +730,7 @@ procedure GNATCmd is end if; end loop; - Get_Name_String (Project_Tree.Projects.Table - (Project).Exec_Directory); + Get_Name_String (Project.Exec_Directory.Name); if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; @@ -498,11 +749,10 @@ procedure GNATCmd is -- Configuration_Pragmas_File -- -------------------------------- - function Configuration_Pragmas_File return Name_Id is + function Configuration_Pragmas_File return Path_Name_Type is begin - Prj.Env.Create_Config_Pragmas_File - (Project, Project, Project_Tree, Include_Config_Files => False); - return Project_Tree.Projects.Table (Project).Config_File_Name; + Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree); + return Project.Config_File_Name; end Configuration_Pragmas_File; ------------------------------ @@ -511,71 +761,220 @@ procedure GNATCmd is procedure Delete_Temp_Config_Files is Success : Boolean; + Proj : Project_List; + pragma Warnings (Off, Success); begin - if not Keep_Temporary_Files then - if Project /= No_Project then - for Prj in Project_Table.First .. - Project_Table.Last (Project_Tree.Projects) - loop - if - Project_Tree.Projects.Table (Prj).Config_File_Temp + -- 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; + + ----------------- + -- 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; + + begin + if GN_Path = null then + Put_Line (Standard_Error, "could not locate " & GN_Name); + raise Error_Exit; + end if; + + -- Create the temp file + + Tempdir.Create_Temp_File (FD, Name); + + -- 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
-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 + -- 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 - if Verbose_Mode then - Output.Write_Str ("Deleting temp configuration file """); - Output.Write_Str - (Get_Name_String - (Project_Tree.Projects.Table - (Prj).Config_File_Name)); - Output.Write_Line (""""); - end if; + Path := Unit.File_Names (Spec).Path.Name; + exit; - Delete_File - (Name => Get_Name_String - (Project_Tree.Projects.Table - (Prj).Config_File_Name), - Success => Success); + 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; - end if; - -- If a temporary text file that contains a list of files for a tool - -- has been created, delete this temporary file. + Last_Switches.Increment_Last; - if Temp_File_Name /= null then - Delete_File (Temp_File_Name.all, Success); - end if; + if Path /= No_Path then + Last_Switches.Table (Last_Switches.Last) := + new String'(Get_Name_String (Path)); + + else + Last_Switches.Table (Last_Switches.Last) := + new String'(Line (1 .. Last)); + end if; + end loop; + + 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 Delete_Temp_Config_Files; + end Get_Closure; - ----------- - -- Index -- - ----------- + ------------------ + -- Mapping_File -- + ------------------ - function Index (Char : Character; Str : String) return Natural is + function Mapping_File return Path_Name_Type is + Result : Path_Name_Type; begin - for Index in Str'Range loop - if Str (Index) = Char then - return Index; - end if; - end loop; - - return 0; - end Index; + Prj.Env.Create_Mapping_File + (Project => Project, + Language => Name_Ada, + In_Tree => Project_Tree, + Name => Result); + return Result; + end Mapping_File; ------------------ -- Process_Link -- ------------------ procedure Process_Link is - Look_For_Executable : Boolean := True; - There_Are_Libraries : Boolean := False; - Path_Option : constant String_Access := - MLib.Linker_Library_Path_Option; - Prj : Project_Id := Project; - Arg : String_Access; - Last : Natural := 0; - Skip_Executable : Boolean := False; + 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 @@ -587,13 +986,13 @@ procedure GNATCmd is -- Check if there are library project files - if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then - Set_Libraries (Project, Project_Tree, There_Are_Libraries); + 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 There_Are_Libraries then + if Libraries_Present then -- Add -L -lgnarl -lgnat -Wl,-rpath, @@ -607,9 +1006,9 @@ procedure GNATCmd is 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 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 @@ -618,64 +1017,88 @@ procedure GNATCmd is Current : Natural; begin - -- First, compute the exact length for the switch + if MLib.Separate_Run_Path_Options then - for Index in - Library_Paths.First .. Library_Paths.Last - loop - -- Add the length of the library dir plus one - -- for the directory separator. + -- We are going to create one switch of the form + -- "-Wl,-rpath,dir_N" for each directory to consider. - Length := - Length + - Library_Paths.Table (Index)'Length + 1; - end loop; + -- 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; - -- Finally, add the length of the standard GNAT - -- library dir. + -- One switch for 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; + Last_Switches.Increment_Last; + Last_Switches.Table + (Last_Switches.Last) := new String' + (Path_Option.all & MLib.Utl.Lib_Directory); - -- Put each library dir followed by a dir separator + else + -- First, compute the exact length for the switch - for Index in - Library_Paths.First .. Library_Paths.Last - loop - Option - (Current + 1 .. + 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) := - Library_Paths.Table (Index).all; - Current := - Current + - Library_Paths.Table (Index)'Length + 1; - Option (Current) := Path_Separator; - end loop; + Library_Paths.Table (Index)'Length + 1; + Option (Current) := Path_Separator; + end loop; - -- Finally put the standard GNAT library dir + -- Finally put the standard GNAT library dir - Option - (Current + 1 .. - Current + MLib.Utl.Lib_Directory'Length) := - MLib.Utl.Lib_Directory; + Option + (Current + 1 .. + Current + MLib.Utl.Lib_Directory'Length) := + MLib.Utl.Lib_Directory; - -- And add the switch to the last switches + -- And add the switch to the last switches - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - Option; + 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. + -- 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; @@ -695,11 +1118,10 @@ procedure GNATCmd is else declare - Switch : constant String := - Last_Switches.Table (J).all; - - ALI_File : constant String (1 .. Switch'Length + 4) := - Switch & ".ali"; + Switch : constant String := + Last_Switches.Table (J).all; + ALI_File : constant String (1 .. Switch'Length + 4) := + Switch & ".ali"; Test_Existence : Boolean := False; @@ -714,22 +1136,21 @@ procedure GNATCmd is -- Append ".ali" if file name does not end with it if Switch'Length <= 4 - or else Switch (Switch'Last - 3 .. Switch'Last) - /= ".ali" + 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 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 + if Switch (K) = '/' + or else Switch (K) = Directory_Separator then Test_Existence := True; exit; @@ -748,22 +1169,17 @@ procedure GNATCmd is Project_Loop : loop declare Dir : constant String := - Get_Name_String - (Project_Tree.Projects.Table - (Prj).Object_Directory); + Get_Name_String (Prj.Object_Directory.Name); begin if Is_Regular_File (Dir & - Directory_Separator & 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 & Directory_Separator & - ALI_File (1 .. Last)); + new String'(Dir & ALI_File (1 .. Last)); -- And we are done @@ -771,11 +1187,9 @@ procedure GNATCmd is end if; end; - -- Go to the project being extended, - -- if any. + -- Go to the project being extended, if any - Prj := - Project_Tree.Projects.Table (Prj).Extends; + Prj := Prj.Extends; exit Project_Loop when Prj = No_Project; end loop Project_Loop; end if; @@ -784,8 +1198,8 @@ procedure GNATCmd is end if; end loop Switch_Loop; - -- If a relative path output file has been specified, we add - -- the exec directory. + -- 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 @@ -807,10 +1221,9 @@ procedure GNATCmd is 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 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 @@ -831,15 +1244,12 @@ procedure GNATCmd is Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'("-o"); - Get_Name_String - (Project_Tree.Projects.Table - (Project).Exec_Directory); + Get_Name_String (Project.Exec_Directory.Name); Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'(Name_Buffer (1 .. Name_Len) & - Directory_Separator & - Base_Name (Arg (Arg'First .. Last)) & - Get_Executable_Suffix.all); + Executable_Name + (Base_Name (Arg (Arg'First .. Last)))); exit; end if; end if; @@ -852,48 +1262,42 @@ procedure GNATCmd is --------------------- procedure Set_Library_For - (Project : Project_Id; - There_Are_Libraries : in out Boolean) + (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_Tree.Projects.Table (Project).Library then - There_Are_Libraries := True; + 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_Tree.Projects.Table - (Project).Library_Dir)); + 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_Tree.Projects.Table - (Project).Library_Name)); + 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_Tree.Projects.Table (Project).Library_Kind /= - Static + 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_Tree.Projects.Table - (Project).Library_Dir)); + new String'(Get_Name_String (Project.Library_Dir.Name)); end if; end if; end Set_Library_For; @@ -907,66 +1311,16 @@ procedure GNATCmd is Parent : String) is begin - if Switch /= null then - - declare - Sw : String (1 .. Switch'Length); - Start : Positive := 1; - - begin - Sw := Switch.all; - - if Sw (1) = '-' then - if Sw'Length >= 3 - and then (Sw (2) = 'A' or else - Sw (2) = 'I' or else - Sw (2) = 'L') - then - Start := 3; + Makeutl.Test_If_Relative_Path + (Switch, Parent, + Do_Fail => Osint.Fail'Access, + Including_Non_Switch => False, + Including_RTS => True); + end Test_If_Relative_Path; - if Sw = "-I-" then - return; - end if; - - elsif Sw'Length >= 4 - and then (Sw (2 .. 3) = "aL" or else - Sw (2 .. 3) = "aO" or else - Sw (2 .. 3) = "aI") - then - Start := 4; - - elsif Sw'Length >= 7 - and then Sw (2 .. 6) = "-RTS=" - then - Start := 7; - else - return; - end if; - end if; - - -- If the path is relative, test if it includes directory - -- information. If it does, prepend Parent to the path. - - if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then - for J in Start .. Sw'Last loop - if Sw (J) = Directory_Separator then - Switch := - new String' - (Sw (1 .. Start - 1) & - Parent & - Directory_Separator & - Sw (Start .. Sw'Last)); - return; - end if; - end loop; - end if; - end; - end if; - end Test_If_Relative_Path; - - ------------------- - -- Non_VMS_Usage -- - ------------------- + ------------------- + -- Non_VMS_Usage -- + ------------------- procedure Non_VMS_Usage is begin @@ -976,10 +1330,26 @@ procedure GNATCmd is New_Line; for C in Command_List'Range loop - if not Command_List (C).VMS_Only then - Put ("gnat " & To_Lower (Command_List (C).Cname.all)); + + -- 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); - Put (Command_List (C).Unixcmd.all); + + -- 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; @@ -997,23 +1367,31 @@ procedure GNATCmd is end loop; New_Line; - Put_Line ("Commands find, list, metric, pretty, stub and xref accept " & - "project file switches -vPx, -Pprj and -Xnam=val"); + Put_Line ("All commands except chop, krunch and preprocess " & + "accept project file switches -vPx, -Pprj and -Xnam=val"); New_Line; end Non_VMS_Usage; - ------------------------------------- - -- Start of processing for GNATCmd -- - ------------------------------------- +-- Start of processing for GNATCmd begin + -- All output from GNATCmd is debugging or error output: send to stderr + + Set_Standard_Error; + -- Initializations - Namet.Initialize; 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; @@ -1023,13 +1401,46 @@ begin 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 directory where the GNAT driver is invoked in front of the - -- path, if the GNAT driver is invoked with directory information. - -- Only do this if the platform is not VMS, where the notion of path - -- does not really exist. + -- 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 @@ -1043,10 +1454,8 @@ begin Normalize_Pathname (Command (Command'First .. Index)); - PATH : constant String := - Absolute_Dir & - Path_Separator & - Getenv ("PATH").all; + PATH : constant String := + Absolute_Dir & Path_Separator & Getenv ("PATH").all; begin Setenv ("PATH", PATH); @@ -1066,6 +1475,8 @@ begin then VMS_Conversion (The_Command); + B_Start := new String'("b__"); + -- If not on VMS, scan the command line directly else @@ -1097,9 +1508,9 @@ begin 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"); + ("Command """ + & Command_List (The_Command).Cname.all + & """ can only be used on VMS"); end if; exception @@ -1118,7 +1529,7 @@ begin exception when Constraint_Error => Non_VMS_Usage; - Fail ("Unknown command: ", Argument (Command_Arg)); + Fail ("Unknown command: " & Argument (Command_Arg)); end; end; @@ -1158,8 +1569,8 @@ begin raise Error_Exit; end; - -- Read line by line and put the content of each - -- non empty line in the Last_Switches table. + -- 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); @@ -1188,161 +1599,36 @@ begin end if; declare - Program : constant String := - Program_Name (Command_List (The_Command).Unixcmd.all).all; - + Program : String_Access; Exec_Path : String_Access; begin - -- First deal with built-in command(s) - - if The_Command = Setup then - Process_Setup : - declare - Arg_Num : Positive := 1; - Argv : String_Access; - - begin - while Arg_Num <= Last_Switches.Last loop - Argv := Last_Switches.Table (Arg_Num); - - if Argv (Argv'First) /= '-' then - Fail ("invalid parameter """, Argv.all, """"); - - else - if Argv'Length = 1 then - Fail - ("switch character cannot be followed by a blank"); - end if; - - -- -vPx Specify verbosity while parsing project files - - if Argv'Length = 4 - and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" - then - case Argv (Argv'Last) is - when '0' => - Current_Verbosity := Prj.Default; - when '1' => - Current_Verbosity := Prj.Medium; - when '2' => - Current_Verbosity := Prj.High; - when others => - Fail ("Invalid switch: ", Argv.all); - end case; + if The_Command = Stack then - -- -Pproject_file Specify project file to be used + -- Never call gnatstack with a prefix - 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. + Program := new String'(Command_List (The_Command).Unixcmd.all); - if Arg_Num = Last_Switches.Last then - Fail ("project file name missing after -P"); - - else - Arg_Num := Arg_Num + 1; - Argv := Last_Switches.Table (Arg_Num); - - -- 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; - - -- -Xexternal=value Specify an external reference to be - -- used in project files - - elsif Argv'Length >= 5 - and then Argv (Argv'First + 1) = 'X' - then - declare - Equal_Pos : constant Natural := - Index ('=', Argv (Argv'First + 2 .. Argv'Last)); - begin - if Equal_Pos >= Argv'First + 3 and then - Equal_Pos /= Argv'Last then - Add - (External_Name => - Argv (Argv'First + 2 .. Equal_Pos - 1), - Value => Argv (Equal_Pos + 1 .. Argv'Last)); - else - Fail - (Argv.all, - " is not a valid external assignment."); - end if; - end; - - elsif Argv.all = "-v" then - Verbose_Mode := True; - - elsif Argv.all = "-q" then - Quiet_Output := True; - - else - Fail ("invalid parameter """, Argv.all, """"); - end if; - end if; - - Arg_Num := Arg_Num + 1; - end loop; - - if Project_File = null then - Fail ("no project file specified"); - end if; - - Setup_Projects := True; - - Prj.Pars.Set_Verbosity (To => Current_Verbosity); - - -- Missing directories are created during processing of the - -- project tree. + else + Program := + Program_Name (Command_List (The_Command).Unixcmd.all, "gnat"); + end if; - Prj.Pars.Parse - (Project => Project, - In_Tree => Project_Tree, - Project_File_Name => Project_File.all, - Packages_To_Check => All_Packages); + -- 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. - if Project = Prj.No_Project then - Fail ("""", Project_File.all, """ processing failed"); - end if; - - -- Processing is done - - return; - end Process_Setup; - end if; + Opt.Unchecked_Shared_Lib_Imports := True; -- Locate the executable for the command - Exec_Path := Locate_Exec_On_Path (Program); + Exec_Path := Locate_Exec_On_Path (Program.all); if Exec_Path = null then - Put_Line (Standard_Error, "Couldn't locate " & Program); + Put_Line (Standard_Error, "could not locate " & Program.all); raise Error_Exit; end if; @@ -1356,56 +1642,56 @@ begin end loop; end if; - -- For BIND, FIND, LINK, LIST, PRETTY ad XREF, look for project file - -- related switches. - - if The_Command = Bind - or else The_Command = Elim - or else The_Command = Find - or else The_Command = Link - or else The_Command = List - or else The_Command = Xref - or else The_Command = Pretty - or else The_Command = Stub - or else The_Command = Metric - then - case The_Command is - when Bind => - Tool_Package_Name := Name_Binder; - Packages_To_Check := Packages_To_Check_By_Binder; - when Elim => - Tool_Package_Name := Name_Eliminate; - Packages_To_Check := Packages_To_Check_By_Eliminate; - when Find => - Tool_Package_Name := Name_Finder; - Packages_To_Check := Packages_To_Check_By_Finder; - when Link => - Tool_Package_Name := Name_Linker; - Packages_To_Check := Packages_To_Check_By_Linker; - when List => - Tool_Package_Name := Name_Gnatls; - Packages_To_Check := Packages_To_Check_By_Gnatls; - when Metric => - Tool_Package_Name := Name_Metrics; - Packages_To_Check := Packages_To_Check_By_Metric; - when Pretty => - Tool_Package_Name := Name_Pretty_Printer; - Packages_To_Check := Packages_To_Check_By_Pretty; - when Stub => - Tool_Package_Name := Name_Gnatstub; - Packages_To_Check := Packages_To_Check_By_Gnatstub; - when Xref => - Tool_Package_Name := Name_Cross_Reference; - Packages_To_Check := Packages_To_Check_By_Xref; - when others => - null; - end case; - - -- Check that the switches are consistent. - -- Detect project file related switches. - - Inspect_Switches : - declare + -- 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; @@ -1447,9 +1733,45 @@ begin 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 - if Argv'Length = 4 + elsif Argv'Length = 4 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" then case Argv (Argv'Last) is @@ -1460,7 +1782,7 @@ begin when '2' => Current_Verbosity := Prj.High; when others => - Fail ("Invalid switch: ", Argv.all); + Fail ("Invalid switch: " & Argv.all); end case; Remove_Switch (Arg_Num); @@ -1473,9 +1795,10 @@ begin if Project_File /= null then Fail - (Argv.all, - ": second project file forbidden (first is """, - Project_File.all & """)"); + (Argv.all + & ": second project file forbidden (first is """ + & Project_File.all + & """)"); -- The two style project files (-p and -P) cannot be -- used together. @@ -1521,25 +1844,22 @@ begin elsif Argv'Length >= 5 and then Argv (Argv'First + 1) = 'X' then - declare - Equal_Pos : constant Natural := - Index ('=', Argv (Argv'First + 2 .. Argv'Last)); - begin - if Equal_Pos >= Argv'First + 3 and then - Equal_Pos /= Argv'Last then - Add (External_Name => - Argv (Argv'First + 2 .. Equal_Pos - 1), - Value => Argv (Equal_Pos + 1 .. Argv'Last)); - else - Fail - (Argv.all, - " is not a valid external assignment."); - end if; - end; + 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 = Pretty or else The_Command = Metric) + 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 @@ -1550,6 +1870,20 @@ begin 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; @@ -1566,69 +1900,104 @@ begin 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"); + 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 - Data : constant Prj.Project_Data := - Project_Tree.Projects.Table (Project); - Pkg : constant Prj.Package_Id := Prj.Util.Value_Of (Name => Tool_Package_Name, - In_Packages => Data.Decl.Packages, - In_Tree => Project_Tree); + In_Packages => Project.Decl.Packages, + Shared => Project_Tree.Shared); Element : Package_Element; - Default_Switches_Array : Array_Element_Id; + 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.Packages.Table (Pkg); + Element := Project_Tree.Shared.Packages.Table (Pkg); - -- Packages Gnatls has a single attribute Switches, that is - -- not an associative array. + -- Packages Gnatls and Gnatstack have a single attribute + -- Switches, that is not an associative array. - if The_Command = List then + 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, - In_Tree => Project_Tree); + 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) and - -- Metric (for gnatmetric) have an attributed Switches, - -- an associative array, indexed by the name of the file. + -- 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. + -- 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; + Add_Str_To_Name_Buffer (Main.all); + 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 - Default_Switches_Array := + Switches_Array := Prj.Util.Value_Of (Name => Name_Default_Switches, In_Arrays => Element.Decl.Arrays, - In_Tree => Project_Tree); + Shared => Project_Tree.Shared); The_Switches := Prj.Util.Value_Of (Index => Name_Ada, Src_Index => 0, - In_Array => Default_Switches_Array, - In_Tree => Project_Tree); + In_Array => Switches_Array, + Shared => Project_Tree.Shared); end if; end if; @@ -1655,7 +2024,7 @@ begin when Prj.List => Current := The_Switches.Values; while Current /= Prj.Nil_String loop - The_String := Project_Tree.String_Elements. + The_String := Project_Tree.Shared.String_Elements. Table (Current); declare @@ -1676,14 +2045,11 @@ begin end if; end; - if The_Command = Bind + if The_Command = Bind or else The_Command = Link or else The_Command = Elim then - Change_Dir - (Get_Name_String - (Project_Tree.Projects.Table - (Project).Object_Directory)); + Change_Dir (Get_Name_String (Project.Object_Directory.Name)); end if; -- Set up the env vars for project path files @@ -1691,41 +2057,219 @@ begin Prj.Env.Set_Ada_Paths (Project, Project_Tree, Including_Libraries => False); - -- For gnatstub, gnatmetric, gnatpp and gnatelim, create + -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create -- a configuration pragmas file, if necessary. - if The_Command = Pretty + 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 -cargs is one of the switches, move the following - -- switches to the Carg_Switches table. + -- 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 - for K in J + 1 .. First_Switches.Last loop - Add_To_Carg_Switches (First_Switches.Table (K)); - end loop; - First_Switches.Set_Last (J - 1); + 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 - for K in J + 1 .. Last_Switches.Last loop - Add_To_Carg_Switches (Last_Switches.Table (K)); - end loop; - Last_Switches.Set_Last (J - 1); + 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 Name_Id := Configuration_Pragmas_File; + CP_File : constant Path_Name_Type := Configuration_Pragmas_File; + M_File : constant Path_Name_Type := Mapping_File; + begin - if CP_File /= No_Name then + if CP_File /= No_Path then if The_Command = Elim then First_Switches.Increment_Last; First_Switches.Table (First_Switches.Last) := @@ -1736,6 +2280,96 @@ begin (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, also indicate a global configuration pragmas + -- file and, if -U is not used, a local one. + + if The_Command = Check 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 + Add_To_Carg_Switches + (new String' + ("-gnatec=" & Get_Name_String (Variable.Value))); + 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 + Add_To_Carg_Switches + (new String' + ("-gnatec=" & + Get_Name_String (Variable.Value))); + end if; + end; + end if; + end if; end; end if; @@ -1743,7 +2377,7 @@ begin Process_Link; end if; - if The_Command = Link or The_Command = Bind then + 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 @@ -1753,30 +2387,28 @@ begin -- arguments. for J in 1 .. Last_Switches.Last loop - Test_If_Relative_Path + GNATCmd.Test_If_Relative_Path (Last_Switches.Table (J), Current_Work_Dir); end loop; - Get_Name_String - (Project_Tree.Projects.Table (Project).Directory); + 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 - Test_If_Relative_Path + GNATCmd.Test_If_Relative_Path (First_Switches.Table (J), Project_Dir); end loop; end; elsif The_Command = Stub then declare - Data : constant Prj.Project_Data := - Project_Tree.Projects.Table (Project); 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 @@ -1788,29 +2420,28 @@ begin end if; end loop; - -- If the naming scheme of the project file 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 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 Data.Naming.Ada_Spec_Suffix /= - Prj.Default_Ada_Spec_Suffix - then + if 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); + Base_Name + (Last_Switches.Table (File_Index).all); Last : Natural := Spec'Last; begin - Get_Name_String (Data.Naming.Ada_Spec_Suffix); + 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) + Name_Buffer (1 .. Name_Len) then Last := Last - Name_Len; - Get_Name_String (Data.Naming.Ada_Body_Suffix); + Get_Name_String + (Lang.Config.Naming_Data.Body_Suffix); Last_Switches.Increment_Last; Last_Switches.Table (Last_Switches.Last) := new String'("-o"); @@ -1830,7 +2461,7 @@ begin if File_Index /= 0 then for Index in File_Index + 1 .. Last loop if Last_Switches.Table (Index) - (Last_Switches.Table (Index)'First) /= '-' + (Last_Switches.Table (Index)'First) /= '-' then Dir_Index := Index; exit; @@ -1847,29 +2478,101 @@ begin 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 overriden by a switch in package Metrics in the project file - -- or by a command line option. + -- 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 then + 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_Tree.Projects.Table - (Project).Object_Directory)); + Get_Name_String (Project.Object_Directory.Name)); end if; - -- For gnat pretty and gnat metric, if no file has been put on the - -- command line, call the tool with all the sources of the main - -- project. + -- 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 = Pretty or else - The_Command = Metric or else - The_Command = List + 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; @@ -1881,7 +2584,8 @@ begin The_Args : Argument_List (1 .. First_Switches.Last + Last_Switches.Last + - Carg_Switches.Last); + Carg_Switches.Last + + Rules_Switches.Last); Arg_Num : Natural := 0; begin @@ -1900,6 +2604,11 @@ begin 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 @@ -1935,18 +2644,23 @@ begin exception when Error_Exit => - Prj.Env.Delete_All_Path_Files (Project_Tree); - Delete_Temp_Config_Files; + 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 => - Prj.Env.Delete_All_Path_Files (Project_Tree); - Delete_Temp_Config_Files; + 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. + -- 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);