------------------------------------------------------------------------------
--                                                                          --
--                           GNATELIM COMPONENTS                            --
--                                                                          --
--                   G N A T E L I M . B I N D _ F I L E                    --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 1998-2007, 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 --
-- It is now maintained by AdaCore (http://www.adacore.com)                 --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Wide_Text_IO;        use Ada.Wide_Text_IO;

with Gnatelim.Errors;         use Gnatelim.Errors;
with Gnatelim.Strings;        use Gnatelim.Strings;

with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Hostparm;

package body Gnatelim.Bind_File is

   procedure Process_Bind_File (Main : String; Bindname : String := "") is

      Bind_File_Descr    : File_Type;
      Elab_Proc_Name     : Wide_String (1 .. 256);
      Unit_Name          : Wide_String (1 .. 256);
      --  256 should be enough
      --  ??? names used for local variables are not really good
      Elab_Proc_NLen     : Natural  range 0 .. 256;
      Elab_Proc_NInd     : Positive range 1 .. 256;
      Unit_Name_Len      : Natural  range 0 .. 256;
      Spec               : Boolean;

      function Ada_Bind_File_Name return String;
      function C_Bind_File_Name   return String;
      --  Returns the name of the Ada or C bind file. If Bindname is not empty,
      --  it is simply checked what language is it written in, otherwise the
      --  name is computed based on Main. In the later case it is assumed that
      --  unit name is not redefined by Source_File_Name pragma, it is not
      --  any predefined/gnat-specific unit, and neither it is an empty string

      procedure Get_Bind_File_Line;
      --  Reads next line from bind file and discards leading and trailing
      --  spaces and trailing '('

      procedure Skip_Ada_Starting_Part;
      procedure Skip_C_Starting_Part;
      --  Skips the first lines of an Ada or C bind file; stops when the next
      --  line to read is the line containing the first call to an elaboration
      --  procedure;

      type Access_Procedure is access procedure;

      Skip_Starting_Part : Access_Procedure;

      procedure Get_Unit_From_Ada_Elab_Procedure;
      procedure Get_Unit_From_C_Elab_Procedure;
      --  takes the call to an elaboration procedure (in Ada or C bind file
      --  respectively) as the value of Elab_Proc_Name (1 .. Elab_Proc_NLen)
      --  and returns the corresponding ASIS Compilation_Unit.
      --  Also sets Spec for it. Stores the full expanded Ada name of the unit
      --  to get in Unit_Name and sets Unit_Name_Len accordingly

      Get_Unit_From_Elab_Procedure : Access_Procedure;

      function End_Of_Ada_Elab_Procedures return Boolean;
      function End_Of_C_Elab_Procedures   return Boolean;
      --  Checks if the latest line read from a bind file does not already
      --  contain a call to an elaboration procedure

      type Access_End_Of_Elab_Procedures is access function return Boolean;

      End_Of_Elab_Procedures : Access_End_Of_Elab_Procedures;

      function Is_From_RTL return Boolean;
      --  using the current settings of Unit_Name and Unit_Name_Len,
      --  tries to guess, if the corresponding unit can be from RTL

      function Should_Never_Be_Touched return Boolean;
      --  using the current settings of Unit_Name and Unit_Name_Len, defines
      --  if a given unit is an RTL component for which no Eliminate pragmas
      --  could be generated because the frontend may generate implicit calls
      --  to subprograms defined in the corresponding unit.

      ------------------------
      -- Ada_Bind_File_Name --
      ------------------------

      function Ada_Bind_File_Name return String is
         Short_Main : constant String := Base_Name (Main);
         Main_Ext   : constant String := File_Extension (Short_Main);
         Res_String : constant String :=
           Short_Main (Short_Main'First .. Short_Main'Last - Main_Ext'Length) &
            ".ads";
         --  that is <short source file name - extension>.ads
      begin

         if Bindname /= "" then
            if To_Lower (Bindname (Bindname'Last)) /= 's' then
               raise Name_Error;
            else
               return Bindname;
            end if;
         end if;

         if Hostparm.OpenVMS then
            return "b__" & Res_String;
         else
            return "b~" & Res_String;
         end if;

      end Ada_Bind_File_Name;

      ----------------------
      -- C_Bind_File_Name --
      ----------------------

      function C_Bind_File_Name return String is
         Short_Main : constant String := Base_Name (Main);
         Main_Ext   : constant String := File_Extension (Short_Main);
         Res_String : constant String :=
           "b_" &
           Short_Main (Short_Main'First .. Short_Main'Last - Main_Ext'Length) &
            ".c";
         --  that is b_<short source file name - extension>.c
      begin

         if Bindname /= "" then

            if To_Lower (Bindname (Bindname'Last)) /= 'c' then
               raise Name_Error;
            else
               return Bindname;
            end if;

         end if;

         return Res_String;

      end C_Bind_File_Name;

      --------------------------------
      -- End_Of_Ada_Elab_Procedures --
      --------------------------------

      function End_Of_Ada_Elab_Procedures return Boolean is
         Result : Boolean  := True;
         Idx    : Positive := Elab_Proc_NInd;
      begin

         while Elab_Proc_Name (Idx) = '-' or else
               Elab_Proc_Name (Idx) = ' '
         loop
            Idx := Idx + 1;
         end loop;

         Result := Elab_Proc_Name (Idx .. Elab_Proc_NLen) =
           "END ELABORATION ORDER";

         return Result;

      end End_Of_Ada_Elab_Procedures;

      ------------------------------
      -- End_Of_C_Elab_Procedures --
      ------------------------------

      function End_Of_C_Elab_Procedures return Boolean is
         Result : Boolean := True;
      begin
         Result := Elab_Proc_Name (Elab_Proc_NInd .. Elab_Proc_NLen) =
           "END ELABORATION ORDER */";

         return Result;

      end End_Of_C_Elab_Procedures;

      ------------------------
      -- Get_Bind_File_Line --
      ------------------------

      procedure Get_Bind_File_Line is
      begin
         Elab_Proc_NInd := 1;
         Get_Line (Bind_File_Descr, Elab_Proc_Name, Elab_Proc_NLen);

         while Elab_Proc_NInd < Elab_Proc_NLen and then
           Elab_Proc_Name (Elab_Proc_NInd) = ' '
         loop
            Elab_Proc_NInd := Elab_Proc_NInd + 1;
         end loop;

         while Elab_Proc_NLen > 1 and then
           (Elab_Proc_Name (Elab_Proc_NLen) = ' ' or else
            Elab_Proc_Name (Elab_Proc_NLen) = '(')
         loop
            Elab_Proc_NLen := Elab_Proc_NLen - 1;
         end loop;

      end Get_Bind_File_Line;

      --------------------------------------
      -- Get_Unit_From_Ada_Elab_Procedure --
      --------------------------------------

      procedure Get_Unit_From_Ada_Elab_Procedure is
      begin

         --  Skip "-- "
         while Elab_Proc_Name (Elab_Proc_NInd) = '-' or else
               Elab_Proc_Name (Elab_Proc_NInd) = ' '
         loop
            Elab_Proc_NInd := Elab_Proc_NInd + 1;
         end loop;

         Get_Unit_From_C_Elab_Procedure;

      end Get_Unit_From_Ada_Elab_Procedure;

      ------------------------------------
      -- Get_Unit_From_C_Elab_Procedure --
      ------------------------------------

      procedure Get_Unit_From_C_Elab_Procedure is
         use Unit_Names;
      begin

         while not (Elab_Proc_Name (Elab_Proc_NLen) = 's'
                 or else
                    Elab_Proc_Name (Elab_Proc_NLen) = 'b')
         loop
            Elab_Proc_NLen := Elab_Proc_NLen - 1;
         end loop;
         --  Skip "(spec)" or "(body"), for the old format of the comments
         --  in the bind file. In any case we will stop either on 's' or 'b'
         --  either from '(spec)|(body)' or from '%s|%b'

         if Elab_Proc_Name (Elab_Proc_NLen) = 's' then
            Spec := True;
         else
            Spec := False;
         end if;

         Elab_Proc_NLen := Elab_Proc_NLen - 2;

         if Elab_Proc_Name (Elab_Proc_NLen) =  ' ' then
            --  Skip ' ' between the unit name and "(spec|body)", for the old
            --  format of the comments
            Elab_Proc_NLen := Elab_Proc_NLen - 1;
         end if;

         Unit_Name_Len := Elab_Proc_NLen - Elab_Proc_NInd + 1;
         Unit_Name (1 .. Unit_Name_Len) :=
           Elab_Proc_Name (Elab_Proc_NInd .. Elab_Proc_NLen);

         --  here we have a unit name as Unit_Name (1 .. Unit_Name_Len);

         if Should_Never_Be_Touched
           or else (not Eliminate_In_RTL and then Is_From_RTL)
         then
            return;
         end if;

         Increment_Last;

         Table (Last) := Unit_Name_Record'
           (Name         => Enter_String (Unit_Name (1 .. Unit_Name_Len)),
            Spec         => Spec,
            Present_Here => False,
            Analyzed     => False,
            Postponed    => False);

      end Get_Unit_From_C_Elab_Procedure;

      -----------------
      -- Is_From_RTL --
      -----------------

      function Is_From_RTL return Boolean is

         Result : Boolean := False;
      begin

         --  Roots of predefined and GNAT-specific hierarchies:
         if        (Unit_Name_Len = 6 and then
                    Unit_Name (1 .. 6) = "system")
           or else (Unit_Name_Len = 3 and then
                    Unit_Name (1 .. 3) = "ada")
           or else (Unit_Name_Len = 4 and then
                    Unit_Name (1 .. 4) = "gnat")
           or else (Unit_Name_Len = 10 and then
                    Unit_Name (1 .. 10) = "interfaces")
         then
            Result := True;
         end if;

         --  Roots of predefined and GNAT-specific hierarchies:
         if        (Unit_Name_Len > 6 and then
                    Unit_Name (1 .. 7) = "system.")
           or else (Unit_Name_Len > 3 and then
                    Unit_Name (1 .. 4) = "ada.")
           or else (Unit_Name_Len > 4 and then
                    Unit_Name (1 .. 5) = "gnat.")
           or else (Unit_Name_Len > 10 and then
                    Unit_Name (1 .. 11) = "interfaces.")
         then
            Result := True;
         end if;

         --  And, finally, checking  obsolescent library unit renamings

         if (Unit_Name_Len = 20 and then
             Unit_Name (1 .. 20) = "unchecked_conversion")
           or else
           (Unit_Name_Len = 22 and then
            Unit_Name (1 .. 22) = "unchecked_deallocation")
           or else
           (Unit_Name_Len = 13 and then
            Unit_Name (1 .. 13) = "sequential_io")
           or else
           (Unit_Name_Len =  9 and then
            Unit_Name (1 .. 9) = "direct_io")
           or else
           (Unit_Name_Len =  7 and then
            Unit_Name (1 .. 7) = "text_io")
           or else
           (Unit_Name_Len = 13 and then
            Unit_Name (1 .. 13) = "io_exceptions")
           or else
           (Unit_Name_Len =  8 and then
            Unit_Name (1 .. 8) = "calendar")
           or else
           (Unit_Name_Len = 12 and then
            Unit_Name (1 .. 12) = "machine_code")
         then
            Result := True;
         end if;

         return Result;

      end Is_From_RTL;

      -----------------------------
      -- Should_Never_Be_Touched --
      -----------------------------

      function Should_Never_Be_Touched return Boolean is
         Result : Boolean := False;

         Max_Non_Touched_Name_Len : constant Positive := 32;
         subtype Non_Touched_Name is
           Wide_String (1 .. Max_Non_Touched_Name_Len);

         type Non_Touched_Name_List is array (Positive range <>)
           of Non_Touched_Name;

         --  This is the list of units which should never been touched.
         --  The original list was suggested by Robert Dewar in the
         --  gnatelim-related discussion on asis-report (23.02.98).
         --  Some more elements were added to this list later, as the
         --  results of gnatelim testing, they are marked by '--  ???'
         --  comments on the right.

         Non_Touched_Names : constant Non_Touched_Name_List :=
           ("ada.calendar                    ",
            "ada.exceptions                  ",
            "ada.finalization                ",
            "ada.interrupts                  ",
            "ada.real_time                   ",
            "ada.streams                     ",
            "ada.tags                        ",
            "ada.task_identification         ",
            "ada.calendar.delays             ",
            "ada.calendar.delay_objects      ",
            "ada.finalization.list_controller",
            "ada.real_time.delays            ",

            "interfaces                      ",
            "interfaces.cpp                  ",
            "interfaces.packed_decimal       ",
            "interfaces.c_streams            ",  --  ???

            "gnat.heap_sort_a                "); --  ???
      begin

         --  nothing in the System hierarchy should be touched
         if (Unit_Name_Len = 6 and then
             Unit_Name (1 .. Unit_Name_Len) = "system")
           or else
           (Unit_Name_Len >= 8 and then
            Unit_Name (1 .. 7) = "system.")
         then
            Result := True;
         end if;

         --  The predefined Interfaces package should not be touched
         if Result = False and then
           (Unit_Name_Len = 10 and then
            Unit_Name (1 .. 10) = "interfaces")
         then
            Result := True;
         end if;

         --  Checking Ada, Gnat and Interfaces hierarchies:
         if Result = False and then
           ((Unit_Name_Len > 4 and then
             Unit_Name (1 .. 4) = "ada.")
            or else
            (Unit_Name_Len > 11 and then
             Unit_Name (1 .. 11) = "interfaces.")
            or else                                  --  ???
            (Unit_Name_Len > 5 and then
             Unit_Name (1 .. 5) = "gnat."))
         then

            for J in Unit_Name_Len + 1 .. Max_Non_Touched_Name_Len loop
               Unit_Name (J) := ' ';
            end loop;

            for J in Non_Touched_Names'Range loop

               if Unit_Name (1 .. Max_Non_Touched_Name_Len) =
                 Non_Touched_Names (J)
               then
                  Result := True;
                  exit;
               end if;

            end loop;

         end if;

         return Result;

      end Should_Never_Be_Touched;

      ----------------------------
      -- Skip_Ada_Starting_Part --
      ----------------------------

      procedure Skip_Ada_Starting_Part is
      begin
         --  looking for BEGIN ELABORATION ORDER:
         loop
            Get_Bind_File_Line;

            exit when
              Elab_Proc_Name (Elab_Proc_NInd .. Elab_Proc_NLen)
              = "--  BEGIN ELABORATION ORDER";

         end loop;

      end Skip_Ada_Starting_Part;

      --------------------------
      -- Skip_C_Starting_Part --
      --------------------------

      procedure Skip_C_Starting_Part is
      begin
         --  looking for /* BEGIN ELABORATION ORDER
         loop
            Get_Bind_File_Line;

            exit when
              Elab_Proc_Name (Elab_Proc_NInd .. Elab_Proc_NLen) =
              "/* BEGIN ELABORATION ORDER";

         end loop;

      end Skip_C_Starting_Part;

   begin  --  Process_Bind_File

      --  we assume that a bind file is in the current directory. If there
      --  is neither Ada nor C bind file, we'll be in the exception handler
      --  just after this block statement (the default preference is an Ada
      --  bind file):
      Opening_A_Bind_File : begin
         Open (Bind_File_Descr, In_File, Ada_Bind_File_Name);
         --  if we are here, we will process an Ada bind file:
         Skip_Starting_Part :=  Skip_Ada_Starting_Part'Access;
         Get_Unit_From_Elab_Procedure :=
           Get_Unit_From_Ada_Elab_Procedure'Access;
         End_Of_Elab_Procedures := End_Of_Ada_Elab_Procedures'Access;
      exception
         when Name_Error =>
            Open (Bind_File_Descr, In_File, C_Bind_File_Name);
            --  if we are here, we will process a C bind file:
            Skip_Starting_Part :=  Skip_C_Starting_Part'Access;
            Get_Unit_From_Elab_Procedure :=
              Get_Unit_From_C_Elab_Procedure'Access;
            End_Of_Elab_Procedures := End_Of_C_Elab_Procedures'Access;
      end Opening_A_Bind_File;

      --  and if we are here, we have some bind file to process

      Skip_Starting_Part.all;

      Get_Bind_File_Line;

      while not End_Of_Elab_Procedures.all loop
         Get_Unit_From_Elab_Procedure.all;
         Get_Bind_File_Line;
      end loop;

   exception

      when Name_Error =>

         Gnatelim.Errors.Error
           ("gnatelim: cannot find a bind file for " & To_Wide_String (Main));
         raise Fatal_Error;

   end Process_Bind_File;

end Gnatelim.Bind_File;
