------------------------------------------------------------------------------
--                                                                          --
--                           GNATELIM COMPONENTS                            --
--                                                                          --
--                     G N A T E L I M . A N A L Y Z E                      --
--                                                                          --
--                       P r o c e d u r e   B o d y                        --
--                                                                          --
--                     Copyright (C) 1998-2006 AdaCore                      --
--                                                                          --
-- GNATELIM  is  free software;  you can  redistribute it and/or  modify it --
-- under the terms of the  GNU  General Public License  as published by the --
-- Free Software Foundation; either version 2 or (at your option) any later --
-- version. GNATELIM is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of  MERCHANTABI- --
-- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public Li- --
-- cense 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.                                              --
--                                                                          --
-- The original version  of  GNATELIM  was developed by  Alain  Le  Guennec --
--                                                                          --
-- GNATELIM is now maintained by AdaCore (http://www.adacore.com)           --
------------------------------------------------------------------------------

with Ada.Characters.Handling;   use Ada.Characters.Handling;
with Ada.Strings.Wide_Fixed;    use Ada.Strings.Wide_Fixed;
with Ada.Exceptions;            use Ada.Exceptions;
with Ada.Wide_Text_IO;          use Ada.Wide_Text_IO;

with Asis.Ada_Environments;     use Asis.Ada_Environments;
with Asis.Compilation_Units;    use Asis.Compilation_Units;
with Asis.Elements;             use Asis.Elements;
with Asis.Errors;
with Asis.Exceptions;           use Asis.Exceptions;
with Asis.Extensions;           use Asis.Extensions;
with Asis.Implementation;       use Asis.Implementation;
use Asis;

with ASIS_UL.Compiler_Options;  use ASIS_UL.Compiler_Options;

with Gnatelim.Analyze_Unit;
with Gnatelim.Bind_File;        use Gnatelim.Bind_File;
with Gnatelim.Errors;           use Gnatelim.Errors;
with Gnatelim.Nodes;            use Gnatelim.Nodes;
with Gnatelim.Output;           use Gnatelim.Output;
with Gnatelim.Strings;          use Gnatelim.Strings;

with GNAT.OS_Lib;               use GNAT.OS_Lib;
with GNAT.Expect;               use GNAT.Expect;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;

function Gnatelim.Analyze (Main : String_Access) return Node is

   Main_Node   : Node;
   Success     : Boolean;
   The_Context : Asis.Context;
   Units_Left  : Natural := Gnatelim.Bind_File.Unit_Names.Last;

   Temp_Dir : String_Access := null;
   --  Temporary directory used by Gnatelim's ASIS subsystem

   Gnatmake_Pars : Argument_List_Access;
   --  For gnatmake we need a different set of parameters then for gcc calls.
   --  All the -Idir options should be transformed into -aIdir, some additional
   --  options are needed

   Add_Pars      : Natural;
   --  The number of additional parameters for gnatemake calls

   Pars_First    : Natural;
   Tmp_Idx       : Natural;
   --  Temporary variables used to trahsform Arg_List into gnatmake parameters

   procedure Create_Temp_Dir;
   --  Creates the temporary directory and stores its name in Temp_Dir

   procedure Clean_Temp_Dir;
   --  Cleans the temporary directory and then removes it
   --  ??? To be rewritten with new functionality of GNAT.Directory_Operations

   function Execute_Cmd
     (Cmd : String_Access;
      Args : Argument_List;
      Show_Output : Boolean := False) return String;
   --  Executes a command Cmd with a list of arguments Args, returning the
   --  resulting output as a result. The output is duplicated to screen if
   --  Show_Output is on.

   procedure Output_Unit_Name (Name : Wide_String);
   --  Outputs the name of the unit whose processing is about to begin,
   --  followed by a progress indicator

   function Process_Next_Tree
     (Contains_Main : Boolean := False) return Boolean;
   --  Processes all the units obtained from the next tree that comprises
   --  the partition. Returns False if call to gnatmake didn't yield a useable
   --  file name (i.e. processing is complete)
   --  If Contains_Main is set then the node that corresponds to the main
   --  subprogram is stored in variable Main_Node

   procedure Prepare_Context
     (Gnatmake_Output : String_Access;
      Tree_File       : String);
   --  This procedure does the final preparations needed to open an ASIS
   --  Context processed by gnatelim and opens this Context. Its body is
   --  defined as separate because we need two different versions of the body
   --  for non-GNSA and for GNSA modes. In not-gnsa mode this procedure calls
   --  GNAT to compile the source computed as the result of preceding call to
   --  gnatmake. In GNSA mode the name of this source is added to the
   --  definition of GNSA Context.

   --------------------
   -- Clean_Temp_Dir --
   --------------------

   procedure Clean_Temp_Dir is
      Dir : Dir_Type;
      S : String (1 .. 1024);
      N : Natural;
      Success : Boolean;
   begin

      if not Is_Directory (Temp_Dir.all) then
         --  Perhaps we are inside it?
         Change_Dir ("..");
      end if;

      Change_Dir (Temp_Dir.all);
      --  Exception will be raised if it doesn't exist or is inaccessible

      Open (Dir, ".");

      loop
         Read (Dir, S, N);
         exit when N = 0;
         if S (1 .. N) /= "." and then S (1 .. N) /= ".." then
            Delete_File (S (1 .. N), Success);
         end if;
      end loop;

      Change_Dir ("..");

      Remove_Dir (Temp_Dir.all);
   exception
      when Directory_Error =>
         null;
   end Clean_Temp_Dir;

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

   procedure Create_Temp_Dir is
      FD        : File_Descriptor;
      Temp_Name : Temp_File_Name;
      Success   : Boolean;
   begin
      --  ??? 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 atomary 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);
      Close (FD);
      Delete_File (Temp_Name, Success);
      if not Success then
         Error ("Could not delete the temporary file that was just created");
      end if;
      Make_Dir (Temp_Name);

      --  We need to remove trailing zero during concatenation
      Temp_Dir := new String'(Get_Current_Dir
                              & Temp_Name
                                (Temp_Name'First .. Temp_Name'Last - 1)
                                & Directory_Separator);
   exception
      when Directory_Error =>
         Error ("Could not create the temporary directory");
   end Create_Temp_Dir;

   -----------------
   -- Execute_Cmd --
   -----------------

   function Execute_Cmd
     (Cmd : String_Access;
      Args : Argument_List;
      Show_Output : Boolean := False) return String is

      Pd      : Process_Descriptor;
      PID     : GNAT.OS_Lib.Process_Id;
      Success : Boolean;
      Errout  : File_Descriptor;
      Buffer  : String (1 .. 1024);
      Length  : Integer;

   begin
      Non_Blocking_Spawn (Pd, Cmd.all, Args,
                          Buffer_Size => 1, Err_To_Out => False);

      Errout := Get_Error_Fd (Pd);

      Length := Read (Errout, Buffer'Address, 1024);

      Wait_Process (PID, Success);

      delay 0.05;
      --  ??? A really ugly hack to avoid the race condition

      Close (Pd);

      if Show_Output then
         Put (To_Wide_String (Buffer (1 .. Length)));
         if Length = 1024 then
            Put_Line ("(more output)");
         end if;
      end if;

      for J in 1 .. Length loop
         if Buffer (J) = ASCII.LF or Buffer (J) = ASCII.CR then
            declare
               S : constant String := Buffer (1 .. J - 1);
            begin
               return S;
            end;
         end if;
      end loop;

      return Buffer (1 .. Length);

   exception
      when Invalid_Process =>
         Error ("Could not spawn a process " & To_Wide_String (Cmd.all));
   end Execute_Cmd;

   ----------------------
   -- Output_Unit_Name --
   ----------------------

   procedure Output_Unit_Name (Name : Wide_String) is
      N : constant Wide_String := Natural'Wide_Image (Units_Left);
   begin

      if Progress_Indicator_Mode then
         declare
            Total : constant Integer := Gnatelim.Bind_File.Unit_Names.Last;
            Current : constant Integer := Total - Units_Left;
            Percent : Wide_String :=
              Integer'Wide_Image ((Current * 100) / Total);
         begin
            Percent (1) := '(';
            Put_Line ("completed" & Integer'Wide_Image (Current) & " out of"
                      & Integer'Wide_Image (Total) & " " & Percent & "%)...");
         end;
      end if;

      if Verbose_Mode then
         Warning ("[" & N (2 .. N'Last) & "]  "
                  & To_Wide_String (Base_Name (To_String (Name))),
                  True);

      elsif not (Quiet_Mode or Progress_Indicator_Mode) then
         Set_Output (Standard_Error);
         Put ("Units remaining:");
         Put (N);
         Put ("     ");
         Put (To_Wide_Character (ASCII.CR));
         Set_Output (Standard_Output);
      end if;

   end Output_Unit_Name;

   ---------------------
   -- Prepare_Context --
   ---------------------

   procedure Prepare_Context
     (Gnatmake_Output : String_Access;
      Tree_File       : String) is separate;

   -----------------------
   -- Process_Next_Tree --
   -----------------------

   function Process_Next_Tree
     (Contains_Main : Boolean := False) return Boolean is
      use Gnatelim.Bind_File.Unit_Names;
      use Standard;

      procedure Clean;
      --  Performs ASIS Context finalization

      function Get_Tree_File_Name (Name : String) return String;
      --  Returns the name of the tree file corresponding to a given file name

      -----------
      -- Clean --
      -----------

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

         Dissociate (The_Context);
      end Clean;

      ------------------------
      -- Get_Tree_File_Name --
      ------------------------

      function Get_Tree_File_Name (Name : String) return String is
         Base : constant String := Base_Name (Name);
         Ext  : constant String := File_Extension (Base);
      begin
         return Base (Base'First .. Base'Last - Ext'Length) & ".adt";
      end Get_Tree_File_Name;

      CU, CU1, CU_Main : Asis.Compilation_Unit;

      Gnatmake_Output : String_Access :=
        new String'(Execute_Cmd (Gnatmake, Gnatmake_Pars.all));

      Tree_File : constant String :=
        Get_Tree_File_Name (Gnatmake_Output.all);

      Needs_Further_Analysis : Boolean;
      Mode                   : Analysis_Mode;

      Mode1 : Analysis_Mode;
      --  This variable is used as a trick  to keep reasonable tracking of
      --  gnatelim actions generated in -v and -dv modes. We've got read of
      --  No_Instance_Bodies as of a special mode of processing the
      --  compilation units, now we try to go as deep and as far as it is
      --  possible. Because the way of processing of generics needs a
      --  systematic revision anyway, we are trying to keep changes in the
      --  existing approach as minimal as possible.

   begin

      if Gnatmake_Output.all = "" or else
        Index (To_Wide_String (Gnatmake_Output.all),
               "objects up to date.") /= 0 then
         return False;
      end if;

      if not Is_Regular_File (Gnatmake_Output.all) then
         --  There was an error in gnatmake run
         Error (To_Wide_String
                ("Unexpected output from gnatmake:"
                 & ASCII.LF & Gnatmake_Output.all));
      else
         Warning (To_Wide_String ("Compiling "
                                  & Base_Name (Gnatmake_Output.all)));
      end if;

      Prepare_Context (Gnatmake_Output, Tree_File);

      CU_Main := Asis.Extensions.Main_Unit_In_Current_Tree (The_Context);

      for J in 1 .. Last loop
         Needs_Further_Analysis := False;

         if not Table (J).Analyzed then

            if Table (J).Spec then
               CU := Library_Unit_Declaration (Get_String (Table (J).Name),
                                               The_Context);
               if not Is_Nil (CU) then
                  CU1 := Corresponding_Body (CU);
               end if;

               if Is_Nil (CU1) then
                  CU1 := CU;
               end if;

               --  If the specification is not processed in the scope of the
               --  tree of its main unit, we will not be able to obtain bodies
               --  of generic instantiations within. However, we can't
               --  completely postpone the processing of this spec until the
               --  proper tree passes by, because entries in the spec may
               --  already start being used and must therefore be already
               --  registered. To avoid this problem, we process everything BUT
               --  instance bodies here, and later we will revisit this spec
               --  to analyze the instance bodies and complete the analysis.
               Needs_Further_Analysis :=
                 not (Is_Nil (CU1) or else Is_Equal (CU1, CU_Main));

               if Needs_Further_Analysis and then Table (J).Postponed then
                  CU := Nil_Compilation_Unit;
               end if;

            else
               CU := Compilation_Unit_Body (Get_String (Table (J).Name),
                                            The_Context);

               --  We only accept a body if it is the main unit of a tree,
               --  that is to say the tree was obtained by compiling body's
               --  source. Otherwise body-level generic instantiations might
               --  not be analyzable
               if not Is_Equal (CU, CU_Main) then
                  CU := Nil_Compilation_Unit;
               end if;

            end if;

            if not Is_Nil (CU) then

               if Needs_Further_Analysis then
                  Table (J).Postponed := True;
                  Mode1 := No_Instance_Bodies;
                  Mode := Normal;
               else
                  Table (J).Analyzed := True;
                  Units_Left := Units_Left - 1;

                  if Table (J).Postponed then
                     Mode := Instance_Bodies_Only;
                  else
                     Mode := Normal;
                  end if;

                  Mode1 := Mode;
               end if;

               if Unit_Origin (CU) = An_Application_Unit
                 or else Eliminate_In_RTL
               then

                  if Output_Debug_Information
                    or else Mode1 /= No_Instance_Bodies
                  then
                     Output_Unit_Name (Asis.Compilation_Units.Text_Name (CU));

                     if Mode1 = No_Instance_Bodies then
                        Warning (" ... postponed", True);
                     end if;

                  end if;

                  Gnatelim.Analyze_Unit (CU, Mode);
               end if;

            end if;

         end if;

      end loop;

      if Contains_Main then
         Main_Node := Corresponding_Node (Unit_Declaration (CU_Main));

         if Main_Node = Empty_Node then
            Error ("Library item corresponding to "
                   & To_Wide_String (Main.all) & " not found.");
         end if;

         if not Asis.Compilation_Units.Can_Be_Main_Program (CU_Main) then
            Error ("The unit corresponding to "
                   & To_Wide_String (Main.all) & " cannot be a main program.");
         end if;

      end if;

      Clean;

      Delete_File (Tree_File, Success);
      Free (Gnatmake_Output);

      return True;

   exception
      when others =>
         Clean;
         raise;

   end Process_Next_Tree;

   use type Asis.Errors.Error_Kinds;

begin  --  Gnatelim.Analyze
   Create_Temp_Dir;

   --  Set up gnatmake parameters. The problem here is that
   --  ASIS_UL.Compiler_Options.Arg_List contains -I options, whereas for the
   --  gnatmake calls we need -aI not to mess up with ALI files that can exist
   --  outside our temporary directory.

   Add_Pars := 6 + 1;
   --  "6" is for "-n -c -gnatct -nostdlib -gnatws -I.",
   --  and "1" - for the name of the main file

   if Eliminate_In_RTL then
      Add_Pars := Add_Pars + 1;
   end if;

   Gnatmake_Pars :=
     new Argument_List (Arg_List'First .. Arg_List'Last + Add_Pars);

   Pars_First := Gnatmake_Pars'First;

   Gnatmake_Pars (Pars_First)     := new String'("-n");
   Gnatmake_Pars (Pars_First + 1) := new String'("-c");
   Gnatmake_Pars (Pars_First + 2) := new String'("-gnatct");
   Gnatmake_Pars (Pars_First + 3) := new String'("-gnatws");
   Gnatmake_Pars (Pars_First + 4) := new String'("-nostdlib");
   Gnatmake_Pars (Pars_First + 5) := new String'("-I.");

   if Eliminate_In_RTL then
      Gnatmake_Pars (Pars_First + 6) := new String'("-a");
   end if;

   for J in Arg_List'Range loop
      Tmp_Idx := Arg_List (J)'First;

      if Arg_List (J) (Tmp_Idx .. Tmp_Idx + 1) = "-I"
        and then
         Arg_List (J) (Tmp_Idx + 2) /= '-'
      then
         Gnatmake_Pars (J + Add_Pars - 1) :=
           new String'("-aI" &
             Arg_List (J) (Tmp_Idx + 2 .. Arg_List (J)'Last));
      else
         Gnatmake_Pars (J + Add_Pars - 1) :=
           new String'(Arg_List (J).all);
      end if;

   end loop;

   Gnatmake_Pars (Gnatmake_Pars'Last) := Main;

   if Gnatelim.ASIS_2005_Mode then
      Initialize ("-asis05 -ws");
   else
      Initialize ("-ws");
   end if;

   Change_Dir (Temp_Dir.all);
   if not Process_Next_Tree (Contains_Main => True) then
      --  Something is wrong - we couldn't compile even the top source
      Error ("Could not compile " & To_Wide_String (Main.all));
   end if;

   loop
      exit when not Process_Next_Tree;
   end loop;

   Clean_Temp_Dir;
   return Main_Node;

exception
   when Ex : Asis.Exceptions.ASIS_Inappropriate_Context
          |  Asis.Exceptions.ASIS_Inappropriate_Container
          |  Asis.Exceptions.ASIS_Inappropriate_Compilation_Unit
          |  Asis.Exceptions.ASIS_Inappropriate_Element
          |  Asis.Exceptions.ASIS_Inappropriate_Line
          |  Asis.Exceptions.ASIS_Inappropriate_Line_Number
          |  Asis.Exceptions.ASIS_Failed
     =>
      Clean_Temp_Dir;
      Set_Output (Standard_Error);
      New_Line;

      if Exception_Identity (Ex) = Asis.Exceptions.ASIS_Failed'Identity
        and then
         Asis.Implementation.Status = Asis.Errors.Use_Error
        and then
         Asis.Implementation.Diagnosis =
         "Cannot process Ada sources compiled with -gnat05"
      then
         --  EC12-013: This path should be removed when ASIS 2005 is
         --  implemented
         Put_Line ("gnatelim: Ada 2005 not supported yet, exiting");
      else
         Put ("Unexpected ASIS exception in ");
         Put_Gnatelim_Version;
         New_Line;
         Put (To_Wide_String (Exception_Name (Ex)));
         Put_Line (" raised");
         Put ("gnatelim: ASIS Diagnosis is " &  Asis.Implementation.Diagnosis);
         New_Line;
         Put ("gnatelim: Status Value   is ");
         Put_Line
           (Asis.Errors.Error_Kinds 'Wide_Image (Asis.Implementation.Status));
         New_Line;
         Put_Line ("Please report to report@gnat.com.");
      end if;

      --  Exit cleanly.
      Set_Output (Standard_Output);
      raise Fatal_Error;

   when Ex : others =>
      Clean_Temp_Dir;
      Set_Output (Standard_Error);
      New_Line;

      if Exception_Identity (Ex) = Program_Error'Identity and then
         Exception_Message (Ex) = "Inconsistent versions of GNAT and ASIS"
      then
         Put_Gnatelim_Version;
         New_Line;
         Put ("is inconsistent with the GNAT version");
         New_Line;
         Put ("Check your installation of GNAT, ASIS and the GNAT toolset");
         New_Line;
         raise Fatal_Error;
      else
         raise;
      end if;

end Gnatelim.Analyze;
