asis_2019.0.0_3ca32fa2/tools/tool_utils/asis_ul-environment.adb

------------------------------------------------------------------------------
--                                                                          --
--                     ASIS UTILITY LIBRARY COMPONENTS                      --
--                                                                          --
--                  A S I S _ U L . E N V I R O N M E N T                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                    Copyright (C) 2004-2018, AdaCore                      --
--                                                                          --
-- Asis Utility Library (ASIS UL) is free software; you can redistribute it --
-- and/or  modify  it  under  terms  of  the  GNU General Public License as --
-- published by the Free Software Foundation; either version 3, or (at your --
-- option)  any later version.  ASIS UL  is distributed in the hope that it --
-- will  be  useful,  but  WITHOUT  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.                                                          --
--                                                                          --
-- ASIS UL is maintained by AdaCore (http://www.adacore.com).               --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2012;

with Ada.Command_Line;
with Ada.Directories;             use Ada.Directories;
with Ada.Text_IO;                 use Ada.Text_IO;
with System.Multiprocessors;

with GNATCOLL.Projects;           use GNATCOLL.Projects;

with Asis.Ada_Environments;       use Asis.Ada_Environments;

with A4G.A_Debug;
with A4G.GNAT_Int;
with A4G.GNSA_Switch;

with ASIS_UL.Common;              use ASIS_UL.Common;
with ASIS_UL.Compiler_Options;    use ASIS_UL.Compiler_Options;
with ASIS_UL.Debug;               use ASIS_UL.Debug;
with ASIS_UL.Formatted_Output;
with ASIS_UL.Options;             use ASIS_UL.Options;
with ASIS_UL.Output;              use ASIS_UL.Output;
with ASIS_UL.Projects;            use ASIS_UL.Projects;
with ASIS_UL.Source_Table;        use ASIS_UL.Source_Table;

package body ASIS_UL.Environment is

   -----------------------
   -- Local subprograms --
   -----------------------

   pragma Warnings (Off, More_Arguments);
   --  At least gnatstub does not use this procedure, so we have to avoid
   --  warnings about unreferenced procedure

   procedure Check_Parameters;
   --  Checks that the tool settings are compatible with each other. All
   --  possible check are tool-specific, the corresponding subunit
   --  should be provided for each tool

   --  The two procedures Scan_Parameters (see below) and Check_Parameters (see
   --  above) - are a part of the Initialize procedure.  The important thing is
   --  that after finishing Initialize either the source table should contain
   --  at least one name of an existing file (in case the tool is based on
   --  ASIS_UL.Several_Files_Driver driver), or ASIS_UL.Common.Arg_File should
   --  point to an existing file (in case the tool is based on
   --  ASIS_UL.One_Arg_Driver driver procedure). File names in both cases
   --  should be full normalized names.
   --
   --  ASIS_UL.Compiler_Options.Arg_List should collect all the needed options
   --  to call gcc for tree creation

   procedure Tool_Specific_Initialization_1;
   procedure Tool_Specific_Initialization_2;
   --  Do the initialization actions that are specific for a tool. The first
   --  subprogram is called before reading the tool command-line parameters,
   --  the second - when the command-line parameters have just been read in and
   --  analyzed. If the tool needs any specific initialization actions, the
   --  corresponding subunits should be provided for these subprograms.

   function Builder_Command_Line return Argument_List;
   --  Called by the outer invocation of an ASIS tool when in Incremental_Mode.
   --  Returns a sequence of command-line arguments suitable for invoking the
   --  builder. See also the comments on ASIS_UL.Options.Incremental_Mode.

   function Get_Temp_Dir_Parent return String;
   --  If non-empty, points to the name of the directory in which to create the
   --  tool's temporary directory. This comes from the values of environment
   --  variables TMPDIR, TEMP or TMP (in this order of priority). If empty, the
   --  temporary directory is created in the current directory.

   procedure GNSA_GNATLS_Workaround;
   --  A temporary and very simple-minded workaround for GNSA mode. Currently
   --  for project file processing routines from GNATCOLL.Projects need
   --  calls to gnatls. To be sure that we have gnatls on the path we
   --  just appends asis-gnsa/bin to the value of the PATH environment
   --  variable.

   -------------------------
   -- Get_Temp_Dir_Parent --
   -------------------------

   function Get_Temp_Dir_Parent return String is
      Tmpdirs : String_List_Access :=
        new String_List'(1 => new String'("TMPDIR"),
                         2 => new String'("TEMP"),
                         3 => new String'("TMP"));
      Dir      : String_Access;
      Detected : Boolean := False;
   begin
      for J in Tmpdirs'Range loop
         Free (Dir);
         Dir := Getenv (Tmpdirs (J).all);

         if Dir.all /= ""
           and then Is_Absolute_Path (Dir.all)
           and then Is_Directory (Dir.all)
         then
            Detected := True;
            exit;
         end if;

      end loop;

      declare
         Result : constant String :=
           (if Detected then
               Normalize_Pathname (Dir.all)
            else
               "");
      begin
         Free (Dir);
         Free (Tmpdirs);
         return Result;
      end;

   end Get_Temp_Dir_Parent;

   Temp_Dir_Parent : constant String := Get_Temp_Dir_Parent;

   function Temp_Dir_Exists return Boolean is
      (Tool_Temp_Dir /= null);
   --  True if the Tool_Temp_Dir has been created, but not yet deleted by
   --  Clean_Up. Note that we create and delete the Tool_Temp_Dir multiple
   --  times per run.

   Tmpdir_Displayed : Boolean := False;
   --  True if the value of the TMPDIR environment variable has been displayed;
   --  we don't want to display it more than once per run.

   --------------------------
   -- Builder_Command_Line --
   --------------------------

   function Builder_Command_Line return Argument_List is
      pragma Assert (Incremental_Mode);

      Builder_Args, Inner_Args : String_Vector;
      --  Builder_Args are passed to the builder. Inner_Args are passed to the
      --  inner invocations of the ASIS tool by passing them to the builder
      --  after "-cargs".
      Cur : Positive := 1;
      In_Gnatcheck_Rules : Boolean := False;
      --  True if the loop below is in the "-rules" section

      This_Is_Gnatcheck : constant Boolean :=
        Has_Suffix (Tool_Name.all, Suffix => "gnatcheck");
      --  Flag for special-casing gnatcheck. "Suffix" instead of "=" in case
      --  it's a cross compiler.

      use Ada.Command_Line;

   begin
      --  Tell the builder to keep quiet

      if Debug_Flag_C then
         Append (Builder_Args, "-v");
      else
         Append (Builder_Args, "-q");
      end if;

      --  Tell the builder to pretend that the ASIS tool is the compiler, and
      --  which project-file package to use.

      Append (Builder_Args,
              String'("--compiler-subst=ada," &
                        Ada.Command_Line.Command_Name));

      declare
         Pkg_Name : constant String :=
           --  Package name (in project file) corresponding to the
           --  tool. Empty string if none.
           (if Has_Suffix (Tool_Name.all, Suffix => "gnat2xml")
              then "gnat2xml"
            elsif Has_Suffix (Tool_Name.all, Suffix => "gnatpp")
              then "pretty_printer"
            elsif Has_Suffix (Tool_Name.all, Suffix => "gnatcheck")
              then "check"
            elsif Has_Suffix (Tool_Name.all, Suffix => "gnatmetric")
              then "metrics"
            else raise Program_Error); -- other tools don't have --incremental
      begin
         Append (Builder_Args,
                 String'("--compiler-pkg-subst=" & Pkg_Name));
      end;

      --  Tell the builder to create necessary directories if they don't exist

      Append (Builder_Args, "-p");

      --  Tell the builder not to complain about missing object files. We are
      --  pretending that the ASIS tool is the compiler, but of course ASIS
      --  tools don't generate object files.

      Append (Builder_Args, "--no-object-check");

      --  Compile only

      Append (Builder_Args, "-c");

      --  Unique compilation, only compile the given files if any files are
      --  given.

      Append (Builder_Args, "-U");

      --  Tell the builder to place ALI files in a subdirectory of the object
      --  directory -- a different subdirectory for each tool. This is
      --  necessary because otherwise the ALI files would conflict with each
      --  other. For one thing, ASIS tools run the compiler (the real one) with
      --  different switches than normal builds, so we don't want to overwrite
      --  one kind of ALI file with the other. For another thing, just because
      --  the files generated by gnat2xml are up to date doesn't mean that the
      --  files generated by gnatcheck are up to date. So if the object
      --  directory is 'obj', normal builds put ALI files in obj, "gnat2xml
      --  --incremental" puts ALI files in obj/ALI-FILES-gnat2xml, and so on.

      Append (Builder_Args,
              String'("--subdirs=" & "ALI-FILES-" & Tool_Name.all));

      --  Don't bother with code in other languages.

      Append (Builder_Args, "--restricted-to-languages=ada");

      --  Inform the inner invocation where to find input files.

      Append (Inner_Args, String'("--outer-dir=" & Tool_Current_Dir.all));

      --  Modify the --output-dir= switch so it uses a full pathname.
      --  Otherwise, the output files would end up in something like
      --  obj/ALI-FILES-gnat2xml.

      if Out_Dir /= null then
         Append (Inner_Args,
                 String'("--output-dir=" & Out_Dir.all));
      end if;

      --  Set the report file name for the inner invocation using a full path
      --  name, because sometimes the inner invocation has a different current
      --  directory.

      if This_Is_Gnatcheck then
         if Text_Report_ON then
            Append (Inner_Args, "-o");
            Append (Inner_Args, Get_Report_File_Name);
         end if;

         if XML_Report_ON then
            Append (Inner_Args, "-ox");
            Append (Inner_Args, Get_XML_Report_File_Name);
         end if;
      end if;

      --  Now deal with command-line arguments from this invocation of an ASIS
      --  tool (the outer one). Most are copied to Builder_Args or Inner_Args.

      while Cur <= Argument_Count loop
         declare
            Arg : constant String := Argument (Cur);

            function Match
              (Check : String;
               Kind : Character := ' ';
               Builder_Arg, Inner_Arg : Boolean := False;
               Response_File : Boolean := False) return Boolean
              with Pre => Kind in ' ' | ':' | '=' | '!'
                          and then (if Response_File then Kind = '=');
            --  Checks if Arg matches Check. Kind = ' ' means Arg does not have
            --  a parameter. The other possibilities for Kind mean the same
            --  thing as in GNAT.Command_Line.Getopt. If there is a match, then
            --  we move past the arg and its parameter, if any, and append them
            --  onto Builder_Args and/or Inner_Args, as indicated by the
            --  Builder_Arg and Inner_Arg flags. Return True iff there is a
            --  match. To ignore an argument, leave Builder_Arg and Inner_Arg
            --  False. Response_File is True for the "-file=" switch.

            function Match
              (Check : String;
               Kind : Character := ' ';
               Builder_Arg, Inner_Arg : Boolean := False;
               Response_File : Boolean := False) return Boolean is

               procedure App;
               procedure App is
               begin
                  if Builder_Arg then
                     Append (Builder_Args, Argument (Cur));
                  end if;
                  if Inner_Arg then
                     Append (Inner_Args, Argument (Cur));
                  end if;
               end App;

               procedure App_Response_File (Response_File_Name : String);
               --  We turn "-file=files.txt" into "@files.txt"
               procedure App_Response_File (Response_File_Name : String) is
                  Arg : constant String := "@" & Response_File_Name;
               begin
                  Append (Builder_Args, Arg);
               end App_Response_File;

               Old_Cur : constant Positive := Cur;
            begin

               case Kind is
                  when ' ' =>
                     if Arg = Check then
                        App;
                        Cur := Cur + 1;
                     end if;

                  when ':' =>
                     if Arg = Check then
                        App;
                        Cur := Cur + 1;
                        App;
                        Cur := Cur + 1;
                     elsif Has_Prefix (Arg, Prefix => Check) then
                        App;
                        Cur := Cur + 1;
                     end if;

                  when '=' =>
                     if Response_File then
                        if Arg = Check then
                           Cur := Cur + 1;
                           App_Response_File (Argument (Cur));
                           Cur := Cur + 1;
                        elsif Has_Prefix (Arg, Prefix => Check & "=") then
                           App_Response_File
                             (Strip_Prefix (Argument (Cur),
                                            Prefix => Check & "="));
                           Cur := Cur + 1;
                        end if;
                     else
                        if Arg = Check then
                           App;
                           Cur := Cur + 1;
                           App;
                           Cur := Cur + 1;
                        elsif Has_Prefix (Arg, Prefix => Check & "=") then
                           App;
                           Cur := Cur + 1;
                        end if;
                     end if;

                  when '!' =>
                     if Has_Prefix (Arg, Prefix => Check) then
                        App;
                        Cur := Cur + 1;
                     end if;

                  when others => raise Program_Error;
               end case;

               return Cur /= Old_Cur;
            end Match;

         begin
            --  We shouldn't be seeing -c, -gnatc, -gnatec, -gnatem, or -gnateO
            --  here; those are passed by gnatmake or gprbuild to the inner
            --  invocations, whereas we're in the outer one. Might as well
            --  ignore them. "--incremental" needs to be ignored; the inner
            --  invocations shouldn't get here.  "--output-dir" is handled
            --  specially above. Project-related arguments go in
            --  Builder_Args. Non-switches (i.e. file names) go in
            --  Builder_Args. Anything else goes in Inner_Args.

            if Match ("-c", ' ')
              or else Match ("-xml", ' ', Inner_Arg => True)
              or else Match ("-gnatc", '!')
              or else Match ("-gnatec", '!')
              or else Match ("-gnatem", '!')
              or else Match ("-gnateO", '!')
              or else Match ("--incremental", ' ')
              or else Match ("--output-dir", '=')

              or else Match ("-P", ':', Builder_Arg => True)
              or else Match ("-U", ' ', Builder_Arg => True)
              or else Match ("-X", '!', Builder_Arg => True)
              or else Match ("--subdirs", '=', Builder_Arg => True)

              or else Match ("--no_objects_dir", ' ', Inner_Arg => True)
              or else Match ("-o", '=', Inner_Arg => True)
            then
               null; -- One of those Matches already Appended if appropriate
            elsif Match ("-j", '!', Builder_Arg => True) then
               --  The Match already Appended to Builder_Args, but we also want
               --  to pass --outer-parallel to the inner invocation.
               Append (Inner_Args, "--outer-parallel");
            elsif not Has_Prefix (Arg, Prefix => "-") then
               --  If it doesn't look like a switch (e.g. a source file name),
               --  we want to pass it to the builder, except that gnatcheck
               --  rules like "+Blah", should go to the inner tool invocation.
               if In_Gnatcheck_Rules then
                  Append (Inner_Args, Arg);
               else
                  Append (Builder_Args, Arg);
               end if;
               Cur := Cur + 1;
            elsif Match ("-files", '=', Response_File => True) then
               null;
            elsif Arg = "-cargs" then
               --  We can't just pass -cargs, because it would be hi-jacked by
               --  the builder. So we pass -inner-cargs instead. The inner
               --  invocation will then use this different arg when it
               --  processes Process_cargs_Section. So for example if our
               --  (outer) args are:
               --
               --      some_file.adb -cargs -gnat2012
               --
               --  we will pass:
               --
               --      ... -cargs some_file.adb -inner-cargs -gnat2012 ...
               --
               --  to the builder, which will then pass:
               --
               --      ... some_file.adb -inner-cargs -gnat2012 ...
               --
               --  to the inner invocation.

               Append (Inner_Args, "-inner-cargs");
               Cur := Cur + 1;
            else
               pragma Assert (Has_Prefix (Arg, Prefix => "-"));
               --  Here for all other switches, including -d (debug switches).
               --  Pass the switch along to the inner invocation. In addition,
               --  pass -dn (keep temp files) along to the builder.
               Append (Inner_Args, Arg);
               if Arg in "-dn" | "-debugn" then
                  Append (Builder_Args, "-dn");
               end if;
               Cur := Cur + 1;

               if This_Is_Gnatcheck and then Arg = "-rules" then
                  In_Gnatcheck_Rules := True;
               end if;
            end if;
         end;
      end loop;

      --  Include extra args specific to the ASIS tool

      Append (Inner_Args, Extra_Inner_Post_Args);
      Prepend (Inner_Args, Extra_Inner_Pre_Args);

      --  -cargs means to pass the following arguments along to the ASIS tool

      if Last_Index (Inner_Args) > 0 then
         Prepend (Inner_Args, "-cargs:Ada");
      end if;

      --  Finally, construct the result, which is basically
      --  "Builder_Args & Inner_Args".

      return Result : Argument_List
        (1 .. Last_Index (Builder_Args) + Last_Index (Inner_Args))
      do
         declare
            X : Natural := 0;
         begin
            for Arg of Builder_Args loop
               X := X + 1;
               Result (X) := new String'(Arg);
            end loop;

            for Arg of Inner_Args loop
               X := X + 1;
               Result (X) := new String'(Arg);
            end loop;

            pragma Assert (X = Result'Last);
         end;
      end return;
   end Builder_Command_Line;

   ------------------
   -- Call_Builder --
   ------------------

   procedure Call_Builder is
   begin
      if not A4G.GNAT_Int.Execute
        (ASIS_UL.Common.Gprbuild_To_Call,
         Builder_Command_Line,
         Display_Call => ASIS_UL.Debug.Debug_Flag_C)
      then
         raise ASIS_UL.Common.Fatal_Error;
         --  Presumably the builder or one of the inner invocations printed an
         --  error message.
      end if;
   end Call_Builder;

   ----------------------
   -- Check_Parameters --
   ----------------------

   procedure Check_Parameters is separate;

   --------------
   -- Clean_Up --
   --------------

   procedure Clean_Up is
      Success : Boolean := False;
   begin
      Source_Table_Debug_Image;

      Context_Clean_Up;

      --  Clean up temporary dir

      if not Debug_Flag_N and then Temp_Dir_Exists then

         pragma Assert
           (Get_Current_Dir = Tool_Temp_Dir.all & Directory_Separator
            or else Get_Current_Dir = Initial_Dir & Directory_Separator);
         --  It can be Initial_Dir if we fail early
         Change_Dir (Initial_Dir);
         --  to avoid being in the Tool_Temp_Dir when we delete it

         for J in 1 .. 10 loop
            --  On windows, there might be a slight delay between the return of
            --  the close function on a file descriptor and the actual closing
            --  done by the system. Since it's not possible to remove a
            --  directory as long as there are handles on it, this Remove_Dir
            --  may fail. So, if a call to Remove_Dir raises Directory_Error,
            --  we try several times after some delay, and only if all the
            --  attempts fail, we generate an error message and raise an
            --  exception.

            begin
               Remove_Dir (Tool_Temp_Dir.all, Recursive => True);
               Success := True;
               exit;
            exception
               when Directory_Error =>
                  delay 0.05;
            end;
         end loop;

         if not Success then
            --  Because of some unknown reason the temporary directory cannot
            --  be removed:
            Free (Tool_Temp_Dir);  -- to avoid cycling
            Error ("cannot remove temporary directory");
            raise Fatal_Error;
         end if;

         Free (Tool_Temp_Dir);
      end if;
   end Clean_Up;

   ----------------------
   -- Context_Clean_Up --
   ----------------------

   procedure Context_Clean_Up is
   begin
      if Is_Open (The_Context) then
         Close (The_Context);
      end if;

      if Has_Associations (The_Context) then
         Dissociate (The_Context);
      end if;
   end Context_Clean_Up;

   ---------------------
   -- Create_Temp_Dir --
   ---------------------

   procedure Create_Temp_Dir (Success : out Boolean) is
      FD        : File_Descriptor;
      Temp_Name : Temp_File_Name;
   begin
      Success := False;

      pragma Assert (Get_Current_Dir = Initial_Dir & Directory_Separator);
      pragma Assert (not Temp_Dir_Exists);

      if Temp_Dir_Parent /= "" then
         Change_Dir (Temp_Dir_Parent);
         --  So when we create the Tool_Temp_Dir below, it will be a
         --  subdirectory of Temp_Dir_Parent.
      end if;

      --  ??? We create the temp dir by first creating the temp file, then
      --  closing and deleting it, then creating a dir with the same name.
      --  This is not atomic as another program can sneak in between file
      --  deletion and dir creation and snatch this name for itself. This is
      --  quite unlikely and anyway we don't have any other system-independent
      --  way at the moment
      Create_Temp_File (FD, Temp_Name);

      if FD = Invalid_FD then
         --  We do not generate any diagnostic here - this procedure is always
         --  called in tools even if a tool is called with '--version' or
         --  '--help' option.
         return;
      end if;

      Close (FD);
      Delete_File (Temp_Name, Success);

      if not Success then
         Error ("can not delete the temporary file that was "
              & "just created");

         raise Fatal_Error;
      end if;

      Tool_Temp_Dir := new String' -- Remove NUL
        (Normalize_Pathname
           (Temp_Name (Temp_Name'First .. Temp_Name'Last - 1)));

      Parallel_Make_Dir (Tool_Temp_Dir.all);

      Change_Dir (Initial_Dir);

      Success := True;

   exception
      when Directory_Error =>
         Error ("cannot create the temporary directory");
         raise Fatal_Error;
   end Create_Temp_Dir;

   -------------------
   -- Copy_Gnat_Adc --
   -------------------

   procedure Copy_Gnat_Adc is
      Success : Boolean;
   begin
      if Is_Regular_File ("gnat.adc") then
         Copy_File
           (Name     => Tool_Current_Dir.all & Directory_Separator &
                        "gnat.adc",
            Pathname => Tool_Temp_Dir.all & Directory_Separator &
                        "gnat.adc",
            Success  => Success,
            Mode     => Copy);
      end if;

--    pragma Assert (Project_File_Obsolete = null,
--                   "???The following code is not used");
      if Project_File_Obsolete /= null
        and then
         Project_Support_Type = Use_Tmp_Project_File
      then
--         pragma Assert (False);
         Change_Dir (Tool_Temp_Dir.all);

         declare
            Temp_Project_File : File_Type;
         begin
            --  Creating the temporary project file
            Create (Temp_Project_File, Out_File, "tmp.gpr");

            Put (Temp_Project_File, "project Tmp extends """);
            Put (Temp_Project_File, Project_File_Obsolete.all);
            Put (Temp_Project_File, """ is");
            New_Line (Temp_Project_File);

            Put (Temp_Project_File, "   for Object_Dir use ""."";");
            New_Line (Temp_Project_File);

            Put (Temp_Project_File, "end Tmp;");
            New_Line (Temp_Project_File);

            Close (Temp_Project_File);

            --  Storing the temporary project file as an option:

            Store_Option ("-Ptmp.gpr");
            Set_Arg_List;

         exception
            when others =>
               Error ("can not create the temporary project file");
               raise Fatal_Error;
         end;

         Change_Dir (Tool_Current_Dir.all);
      end if;
   exception
      when Directory_Error =>
         Error ("cannot create the temporary directory");
         raise Fatal_Error;
   end Copy_Gnat_Adc;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize
     (Prj : in out ASIS_UL.Projects.Arg_Project_Type'Class)
   is
      Temp_Dir_Created : Boolean;
   begin
      Create_Temp_Dir (Temp_Dir_Created);

      Tool_Specific_Initialization_1;
      --  A tool-specific version should be provided!

      Scan_Parameters (Prj);

      if Incremental_Mode then
         if not Prj.Is_Specified then
            Error ("--incremental mode requires a project file, " &
                     "and cannot be used with the gnat driver");
            raise Fatal_Error;
         end if;
      end if;

      Set_Log_File;

      Set_Tree_Creator (Prj);

      Check_Parameters; --  A tool-specific version should be provided!

      Create_Mapping_File_Copies;

      if not Temp_Dir_Created
       and then
         not ASIS_UL.Options.Nothing_To_Do
      then
         Error ("cannot create temporary directory, check write permission " &
                "for " & Initial_Dir);
         raise Fatal_Error;
      end if;

      Tool_Specific_Initialization_2;
      --  A tool-specific version should be provided!

      if Temp_Dir_Parent /= "" then
         --  In debug mode that keeps temporary files and directories, display
         --  once the value of TMPDIR, so that if temp files cannot be created,
         --  it is easier to understand where temp files are supposed to be
         --  created.

         if ASIS_UL.Debug.Debug_Flag_N and then not Tmpdir_Displayed then
            Info_No_EOL ("TMPDIR = """);
            Info_No_EOL (Temp_Dir_Parent);
            Info        ("""");
            Tmpdir_Displayed := True;
         end if;
      end if;

      if ASIS_UL.Options.Nothing_To_Do then
         return;
      end if;

      Copy_Gnat_Adc;
      pragma Assert (Get_Current_Dir = Tool_Current_Dir.all &
                          Directory_Separator);

      if not Incremental_Mode
        and then
         not In_Aggregate_Project
      then
         Change_Dir (Tool_Temp_Dir.all);
         Store_I_Options;
      end if;

      --  Create output directory if necessary

      if Out_Dir /= null  then
         Parallel_Make_Dir
           (Out_Dir.all, Give_Message => Verbose_Mode);
      end if;
   exception
      when Parameter_Error =>
         --  The diagnosis is already generated
         Try_Help;
         raise Fatal_Error;
      when Fatal_Error =>
         --  The diagnosis is already generated
         raise;
      when others =>
         Error ("initialization failed");
         --  Exception info will be generated in main driver
         raise;
   end Initialize;

   --------------------
   -- More_Arguments --
   --------------------

   function More_Arguments
     (Store_Arguments : Boolean := True;
      In_Switches     : Boolean := False;
      Parser          : Opt_Parser := Command_Line_Parser)
      return            Boolean
   is
      Result : Boolean := False;
   begin
      loop
         declare
            Arg : constant String := Get_Argument
              (Do_Expansion => True,
               Parser       => Parser);
         begin
            exit when Arg = "";
            Result := True;

            if In_Switches then
               Error ("Switches attribute cannot contain argument sources");
               raise Parameter_Error;
            end if;

            if ASIS_UL.Projects.U_Option_Set then
               ASIS_UL.Projects.Store_Main_Unit (Arg, Store_Arguments);
            else
               Store_Sources_To_Process (Arg, Store_Arguments);
            end if;
         end;
      end loop;

      return Result;
   end More_Arguments;

   ------------------------
   -- Print_Command_Line --
   ------------------------

   procedure Print_Command_Line is
      use Ada.Command_Line;
   begin
      if ASIS_UL.Options.Incremental_Mode then
         Formatted_Output.Put ("(outer)\n  ");
      end if;
      if ASIS_UL.Options.Mimic_gcc then
         Formatted_Output.Put ("(inner)\n  ");
      end if;

      Formatted_Output.Put ("current directory = \1\n", Current_Directory);
      if False then -- disable for now
         A4G.A_Debug.Print_Env;
      end if;

      Formatted_Output.Put ("  \1", Command_Name);

      for X in 1 .. Argument_Count loop
         Formatted_Output.Put (" \1", Argument (X));
      end loop;
      Formatted_Output.Put ("\n");
   end Print_Command_Line;

   ---------------------
   -- Scan_Parameters --
   ---------------------

   procedure Scan_Parameters
     (Prj : in out ASIS_UL.Projects.Arg_Project_Type'Class)
   is
      procedure Pre_Scan_Arguments;
      --  Set various flags, such as the Debug_Flag_X's, based on the
      --  command-line options. This is done before the normal 2-pass argument
      --  scan, so we can use these flags during the argument scan.

      -------------------------
      --  Pre_Scan_Arguments --
      -------------------------

      procedure Pre_Scan_Arguments is
         use Ada.Command_Line;
      begin
         for X in 1 .. Argument_Count loop
            declare
               Arg : constant String := Argument (X);
               pragma Assert (Arg'First = 1);
            begin
               --  gnatmetric uses "-debug" instead of "-d"
               if Has_Suffix (Tool_Name.all, Suffix => "gnatmetric") then
                  if Arg'Length = 7 and then Arg (1 .. 6) = "-debug" then
                     Set_Debug_Options (Arg (7 .. 7));
                  end if;
               else
                  if Arg'Length = 3 and then Arg (1 .. 2) = "-d" then
                     Set_Debug_Options (Arg (3 .. 3));
                  end if;
               end if;

               if Arg = "--incremental" then
                  Incremental_Mode := True;
               elsif Has_Prefix (Arg, Prefix => "--outer-dir=") then
                  --  We use --outer-dir to detect that we were called from
                  --  gprbuild.
                  Mimic_gcc := True;
               end if;
            end;
         end loop;

         --  We need to ignore --incremental in the inner invocation, because
         --  --incremental could be specified in package Pretty_Printer of the
         --  project file, which will cause the builder to pass it to the inner
         --  invocation.

         if Mimic_gcc then
            Incremental_Mode := False;
         end if;
      end Pre_Scan_Arguments;

   --  Start of processing for Scan_Parameters

   begin
      GNSA_GNATLS_Workaround; --  ???

      Pre_Scan_Arguments;

      if Debug_Flag_C then
         Print_Command_Line;
      end if;

      Initialize_Option_Scan
        (Stop_At_First_Non_Switch => False,
         Section_Delimiters       => Prj.Get_Section_Delimiters);

      Prj.Scan_Arguments (First_Pass => True);
      pragma Assert (not (Incremental_Mode and Mimic_gcc));

      if Print_Version then
         Print_Tool_Version (2004);
         Clean_Up;
         OS_Exit (0);
      end if;

      if Print_Usage then
         Prj.Print_Tool_Usage;
         Clean_Up;
         OS_Exit (0);
      end if;

      --  Tool_Current_Dir and Tool_Inner_Dir have been set if and only if this
      --  is an inner invocation. If it's NOT an inner invocation, we set
      --  Tool_Current_Dir, and leave Tool_Inner_Dir null.

      pragma Assert ((Tool_Current_Dir /= null) = Mimic_gcc);
      pragma Assert ((Tool_Inner_Dir /= null) = Mimic_gcc);

      if not Mimic_gcc then
         Tool_Current_Dir := new String'(Initial_Dir);
      end if;

      --  If we have the project file specified as a tool parameter, analyze
      --  it. ???This is the obsolete version.

      ASIS_UL.Projects.Process_Project_File (Prj);

      --  And finally - analyze the command-line parameters. We do this even in
      --  Incremental_Mode, so we get any errors on the outer call to the ASIS
      --  tool, rather than on the inner calls.

      Initialize_Option_Scan
        (Stop_At_First_Non_Switch => False,
         Section_Delimiters       => Prj.Get_Section_Delimiters);

      Prj.Scan_Arguments;
      pragma Assert (not (Incremental_Mode and Mimic_gcc));
   end Scan_Parameters;

   ---------------------
   -- Scan_Common_Arg --
   ---------------------

   function Scan_Common_Arg
     (First_Pass      : Boolean;
      Parser          : Opt_Parser;
      In_Switches     : Boolean;
      In_Project_File : Boolean;
      Initial_Char    : Character) return Common_Arg_Status
   is

      Result : Common_Arg_Status := Arg_Not_Processed;
      --  Every switch recognized below MUST set Result!

      --  Note also that if you add processing for a switch here, you must add
      --  it to the string passed to Getopt in each ASIS tool you want to
      --  support that switch.
   begin
      case Initial_Char is
         when 'c' =>
            if Full_Switch (Parser => Parser) = "c" then
               Result := Arg_Processed;
            end if;

         when 'd' =>
            --  gnatmetric uses "-debug" instead of "-d".  Either way,
            --  Set_Debug_Options was already called by Pre_Scan_Arguments.

            if Has_Suffix (Tool_Name.all, Suffix => "gnatmetric") then
               if Full_Switch (Parser => Parser) = "debug" then -- "-debugX"
                  Result := Arg_Processed;
               end if;
            else
               if Full_Switch (Parser => Parser) = "d" then -- "-dX"
                  Result := Arg_Processed;
               end if;
            end if;

         when 'f' =>
            if Full_Switch (Parser => Parser) = "files" then
               Result              := Arg_Processed;
               File_List_Specified := True;

               if First_Pass then
                  Files_Switch_Used := True;
                  Read_Args_From_File (Parameter (Parser => Parser));
               elsif In_Project_File then
                  if In_Switches then
                     Error ("-files option is not allowed " &
                              "for Switches attribute");
                     raise Parameter_Error;
                  else
                     Read_Args_From_File (Parameter (Parser => Parser));
                  end if;
               end if;
            end if;

         when 'g' =>
            --  Various options that are passed to the inner tool invocations
            --  for incremental mode. These should mostly be passed along to
            --  the real compiler.

            --  -gnatec=configuration_pragmas_file
            --  -gnatem=mapping_file
            --  -gnateO=object_path_file_name

            if Full_Switch (Parser => Parser)
              in "gnatec" | "gnatem" | "gnateO"
            then
               Result := Arg_Processed;
               if not First_Pass then
                  Store_GNAT_Option_With_Path
                    (Full_Switch (Parser => Parser),
                     Parameter (Parser => Parser));
               end if;

            elsif Full_Switch (Parser => Parser) = "gnatA" then
               Result := Arg_Processed;
               if not First_Pass then
                  Store_Option
                    ("-" & Full_Switch (Parser => Parser));
               end if;

            elsif Full_Switch (Parser => Parser) = "gnatc" then
               Result := Arg_Processed;
               --  We can ignore -gnatc, because ASIS always calls the compiler
               --  with -gnatc.
            end if;

         when 'I' =>
            if Full_Switch (Parser => Parser) = "I" then
               Result := Arg_Processed;
               if not First_Pass then
                  Store_I_Option (Parameter (Parser => Parser));
               end if;
            end if;

         when 'j' =>
            if Full_Switch (Parser => Parser) = "j" then
               Result := Arg_Processed;

               --  We need to ignore -j in the inner invocation; otherwise we
               --  will complain about mixing -j with -rnb when not in
               --  --incremental mode.

               if not First_Pass and then not Mimic_gcc then
                  begin
                     J_Specified := True;
                     ASIS_UL.Options.Process_Num :=
                       Natural'Value (Parameter (Parser => Parser));

                     if ASIS_UL.Options.Process_Num = 0 then
                        ASIS_UL.Options.Process_Num :=
                          Positive (System.Multiprocessors.Number_Of_CPUs);
                     end if;
                  exception
                     when Constraint_Error =>
                        Error ("Wrong Parameter of '-j' option: " &
                               Parameter (Parser => Parser));
                        raise Parameter_Error;
                  end;
               end if;
            end if;

         when 'v' =>
            if Full_Switch (Parser => Parser) = "v" then
               Result := Arg_Processed;
               if First_Pass then -- Handle verbose switch early
                  Verbose_Mode := True;
               end if;
            end if;

         when 'x' =>
            --  Ignore "-x ada". We only do this in Mimic_gcc, because
            --  gnatmetric uses the -x switch for something else.
            --  ???gnatmetric does not currently support --incremental;
            --  if it ever does, we will need to resolve this conflict.

            if Mimic_gcc and then Full_Switch (Parser => Parser) = "x" then
               Result := Arg_Processed;
            end if;

         when '-' =>
            if Full_Switch (Parser => Parser) = "-help" then
               Result := Quit;
               if In_Project_File then
                  Error ("project file should not contain '--help' option");
                  raise Parameter_Error;
               end if;

               Print_Usage := True;

            elsif Full_Switch (Parser => Parser) = "-version" then
               Result := Quit;
               if In_Project_File then
                  Error
                    ("project file should not contain '--version' option");
                  raise Parameter_Error;
               end if;

               Print_Version := True;

            elsif Full_Switch (Parser => Parser) = "-ignore" then
               Result := Arg_Processed;

               if Is_Regular_File (Parameter (Parser => Parser)) then
                  ASIS_UL.Options.Exempted_Units :=
                    new String'(Normalize_Pathname
                                  (Parameter (Parser => Parser)));
               else
                  Error (Parameter (Parser => Parser) & " not found");
                  raise Parameter_Error;
               end if;

            elsif Full_Switch (Parser => Parser) = "-incremental" then
               Result := Arg_Processed;
               --  Incremental_Mode was already set by Pre_Scan_Arguments

            elsif Full_Switch (Parser => Parser) = "-outer-parallel" then
               Result := Arg_Processed;
               if not First_Pass then
                  Outer_Parallel := True;
                  pragma Assert (Mimic_gcc);
               end if;

            elsif Full_Switch (Parser => Parser) = "-outer-dir" then
               Result := Arg_Processed;
               if First_Pass then -- process --outer-dir early
                  Tool_Current_Dir := new String'
                    (Full_Name (Parameter (Parser => Parser)));
                  Tool_Inner_Dir := new String'(Initial_Dir);
                  pragma Assert
                    (Full_Name (Parameter (Parser => Parser)) =
                       Parameter (Parser => Parser));
                  pragma Assert (Mimic_gcc);
                  pragma Assert (Get_Current_Dir = Initial_Dir &
                                   Directory_Separator);
                  Change_Dir (Tool_Current_Dir.all);
               end if;

            elsif Full_Switch (Parser => Parser) = "-output-dir" then
               Result := Arg_Processed;
               if not First_Pass then
                  Out_Dir := new String'
                    (Full_Name (Parameter (Parser => Parser)));
               end if;

            elsif Full_Switch (Parser => Parser) = "-target" then
               Result := Arg_Processed;

               if First_Pass then  --  we need to know this before parsing
                                    --  the argument project file
                  Target := new String'(Parameter (Parser => Parser));
               end if;
            end if;

         when others => null;
      end case;

      return Result;
   end Scan_Common_Arg;

   ----------------------------------
   -- Tool_Specific_Initialization --
   ----------------------------------

   procedure Tool_Specific_Initialization_1 is separate;
   procedure Tool_Specific_Initialization_2 is separate;

   ----------------------------
   -- GNSA_GNATLS_Workaround --
   ----------------------------

   procedure GNSA_GNATLS_Workaround is
   begin
      if A4G.GNSA_Switch.Use_GNSA then
         declare
            Idx : Natural;
            Old_Path : constant String := Getenv ("PATH").all;
         begin
            Idx := Tool_Dir'Last - 3;
            Setenv ("PATH",
                  Tool_Dir (Tool_Dir'First .. Idx) &
                            A4G.GNSA_Switch.GNSA_Dir &
                            Directory_Separator & "bin" &
                            Path_Separator & Old_Path);
         exception
            when others =>
               if Tool_Dir = null then
                  Info ("no Tool_Dir is known in GNSA_GNATLS_Workaround!");
               else
                  Info ("GNSA_GNATLS_Workaround: Tool_Dir is:");
                  Info (">>" & Tool_Dir.all & "<<");
               end if;

               raise;
         end;
      end if;
   end GNSA_GNATLS_Workaround;

end ASIS_UL.Environment;