------------------------------------------------------------------------------
--                                                                          --
--                            GNATELIM COMPONENTS                           --
--                                                                          --
--                 G N A T E L I M . P R O C E S S _ B I N D _ F I L E      --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.24 $
--                                                                          --
--            Copyright (c) 1997-2002, Free Software Foundation, Inc.       --
--                                                                          --
-- Gnatelim 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 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 MER-      --
-- CHANTABILITY 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, 59 Temple Place Suite 330,   --
-- Boston, MA 02111-1307, USA.                                              --
--                                                                          --
-- Gnatelim is distributed as a part of the ASIS implementation for GNAT    --
-- (ASIS-for-GNAT).                                                         --
--                                                                          --
-- Gnatelim was originally developed by Alain Le Guennec                    --
--                                                                          --
-- Gnatelim  is  now  maintained  by  Ada  Core  Technologies  Inc          --
-- (http://www.gnat.com).                                                   --
------------------------------------------------------------------------------

with GNATELIM.Errors;
with GNATELIM.Options;        use GNATELIM.Options;

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Text_IO;             use Ada.Text_IO;

with Asis.Compilation_Units;  use Asis.Compilation_Units;

with Hostparm;

package body GNATELIM.Process_Bind_File is

   ------------------------------
   -- Get_Units_From_Bind_File --
   ------------------------------

   function Get_Units_From_Bind_File
     (C : Context; Main, Bindname : String)
      return Compilation_Unit_List
   is
      Bind_File_Descr : File_Type;
      Elab_Proc_Name  : String (1 .. 256);
      Unit_Name       : 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;
      Next_CU : Compilation_Unit;
      Result_List     : Compilation_Unit_List
         := Asis.Compilation_Units.Compilation_Units (C);
      Result_Len      : Natural := 0;

      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

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

      function Ada_Bind_File_Name return String is
         Res_Str_Len : Natural := Main'Length + 6;
         Res_String : String (1 .. Res_Str_Len);
         --  that is b~unit_name.adb
      begin

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

         Res_String (1) := 'b';

         if Hostparm.OpenVMS then
            Res_String (2) := '$';
         else
            Res_String (2) := '~';
         end if;

         for I in Main'Range loop

            if Main (I) = '.' then
               Res_String (I + 2) := '-';
            else
               Res_String (I + 2) := To_Lower (Main (I));
            end if;

         end loop;

         Res_String (Res_Str_Len - 3) := '.';
         Res_String (Res_Str_Len - 2) := 'a';
         Res_String (Res_Str_Len - 1) := 'd';
         Res_String (Res_Str_Len)     := 's';

         return Res_String;

      end Ada_Bind_File_Name;

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

      function C_Bind_File_Name return String is
         Res_Str_Len : Natural := Main'Length + 4;
         Res_String : String (1 .. Res_Str_Len);
         --  that is b_unit_name.c
      begin

         if Bindname /= "" then

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

         end if;

         Res_String (1) := 'b';
         Res_String (2) := '_';

         for I in Main'Range loop

            if Main (I) = '.' then
               Res_String (I + 2) := '-';
            else
               Res_String (I + 2) := To_Lower (Main (I));
            end if;

         end loop;

         Res_String (Res_Str_Len) := 'c';
         Res_String (Res_Str_Len - 1) := '.';

         return Res_String;

      end C_Bind_File_Name;


      procedure Get_Bind_File_Line;
      --  Simple bindfile line processing routine

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

      procedure Get_Bind_File_Line is
      --  Reads next line from bind file and discards leading and trailing
      --  spaces and trailing '('
      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;

      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_Skip_Starting_Part is access procedure;

      Skip_Starting_Part : Access_Skip_Starting_Part;

      function Get_Unit_From_Ada_Elab_Procedure return Compilation_Unit;
      function Get_Unit_From_C_Elab_Procedure   return Compilation_Unit;
      --  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

      type Access_Get_Unit_From_Elab_Procedure is
         access function return Compilation_Unit;

      Get_Unit_From_Elab_Procedure : Access_Get_Unit_From_Elab_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 May_Be_Internal 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 Is_Instance_Body return Boolean;
      --  using the current settings of Unit_Name, Unit_Name_Len, and Spec,
      --  checks if the given Unit Name corresponds to the body, implicitly
      --  created by the compiler for library-level generic instantiation

      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.

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

      function End_Of_Ada_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_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_Unit_From_Ada_Elab_Procedure --
      --------------------------------------

      function Get_Unit_From_Ada_Elab_Procedure return Compilation_Unit is
      begin

         Elab_Proc_NInd := Elab_Proc_NInd + 3;
         --  Skip "-- "

         return Get_Unit_From_C_Elab_Procedure;

      end Get_Unit_From_Ada_Elab_Procedure;

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

      function Get_Unit_From_C_Elab_Procedure return Compilation_Unit is
      begin

         while Elab_Proc_Name (Elab_Proc_NLen) /= ' ' loop
            Elab_Proc_NLen := Elab_Proc_NLen - 1;
         end loop;
         --  Skip "(spec)" or "(body")

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

         Elab_Proc_NLen := Elab_Proc_NLen - 1;
         --  Skip ' ' between the unit name and "(spec|body)"

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

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

         if Spec then

            return Library_Unit_Declaration
              (To_Wide_String (Unit_Name (1 .. Unit_Name_Len)), C);
         else

            return Compilation_Unit_Body
              (To_Wide_String (Unit_Name (1 .. Unit_Name_Len)), C);
         end if;

      end Get_Unit_From_C_Elab_Procedure;

      ----------------------
      -- Is_Instance_Body --
      ----------------------

      function Is_Instance_Body return Boolean is
         Result  : Boolean := False;
         Spec_CU : Compilation_Unit;
      begin

         if not Spec then
            Spec_CU := Library_Unit_Declaration
              (To_Wide_String (Unit_Name (1 .. Unit_Name_Len)), C);

            if Exists (Spec_CU) and then
              Unit_Kind (Spec_CU) in A_Generic_Unit_Instance
            then
               Result := True;
            end if;

         end if;

         return Result;

      end Is_Instance_Body;

      ---------------------
      -- May_Be_Internal --
      ---------------------

      function May_Be_Internal return Boolean is
         Result : Boolean := False;
      begin

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

         --  and their children:
         if Unit_Name_Len >= 5 and then
            Unit_Name (1 .. 4) = "ada."
         then
            Result := True;
         elsif Unit_Name_Len >= 8 and then
            Unit_Name (1 .. 7) = "system."
         then
            Result := True;
         elsif Unit_Name_Len >= 6 and then
            Unit_Name (1 .. 5) = "gnat."
         then
            Result := True;
         elsif Unit_Name_Len >= 12 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 .. Unit_Name_Len) = "unchecked_conversion")
           or else
            (Unit_Name_Len = 22 and then
             Unit_Name (1 .. Unit_Name_Len) = "unchecked_deallocation")
           or else
            (Unit_Name_Len = 13 and then
             Unit_Name (1 .. Unit_Name_Len) = "sequential_io")
           or else
            (Unit_Name_Len =  9 and then
             Unit_Name (1 .. Unit_Name_Len) = "direct_io")
           or else
            (Unit_Name_Len =  7 and then
             Unit_Name (1 .. Unit_Name_Len) = "text_io")
           or else
            (Unit_Name_Len = 13 and then
             Unit_Name (1 .. Unit_Name_Len) = "io_exceptions")
           or else
            (Unit_Name_Len =  8 and then
             Unit_Name (1 .. Unit_Name_Len) = "calendar")
           or else
            (Unit_Name_Len = 12 and then
             Unit_Name (1 .. Unit_Name_Len) = "machine_code")
         then
            Result := True;
         end if;

         return Result;

      end May_Be_Internal;

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

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

         Max_Non_Touchecd_Name_Len : constant Positive := 32;
         subtype Non_Touched_Name is String (1 .. Max_Non_Touchecd_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 : 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_Touchecd_Name_Len loop
               Unit_Name (J) := ' ';
            end loop;

            for J in Non_Touched_Names'Range loop

               if Unit_Name (1 .. Max_Non_Touchecd_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 the call to Set_Globals:
         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  --  Get_Units_From_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;

      --  We assume that there is at least one unit in the elaboration
      --  sequence (that is, at least one call to an elaboration procedure
      --  in the body of adainit). We also assume that
      --  the sequence of the calls to elaboration procedures in the body of
      --  adainit is separated from the line containing "end adainit" by an
      --  empty line in an Ada bind file or by a line containing '}' in its
      --  first postilion in a C bind file:

      Get_Bind_File_Line;

      while not End_Of_Elab_Procedures.all loop

         Next_CU := Get_Unit_From_Elab_Procedure.all;

         if Is_Nil (Next_CU) and then (not Skip_Missed_Units) then
            --  here we have to check if  a given unit may really be nil
            --  (the problem is that a bind file may contain some units for
            --  which tree files are not created when running gnatmake to
            --  prepare the data for gnatelim

            if not (
                  (May_Be_Internal
                 and then
                  (Dont_Eliminate_In_RTS or else Should_Never_Be_Touched))
               or else
                 Is_Instance_Body)
            then
               GNATELIM.Errors.Error
                 ("gnatelim: library item corresponding to "
                  & To_Wide_String (Unit_Name (1 .. Unit_Name_Len))
                  & " not found.");
            end if;

         end if;

         if not Is_Nil (Next_CU) then
            --  In some cases we should not include a unit in a set of units
            --  to be analyzed by gnatelim

            if Unit_Origin (Next_CU) /= An_Application_Unit then

               if Dont_Eliminate_In_RTS or else Should_Never_Be_Touched then
                  Next_CU := Nil_Compilation_Unit;
               end if;

            elsif Unit_Kind (Next_CU) in A_Procedure .. A_Generic_Package
               and then
                  Is_Body_Required (Next_CU)
               and then
                  not Exists (Corresponding_Body (Next_CU))
            then
               --  This condition is a kind of guessing, that Next_CU is
               --  a spec of a component of some precompiled Ada library.
               --  Such component should be turned into Nil_Unit to avoid
               --  registering subprograms declared within it. There is no
               --  reason to raise an exception here - if an exception has
               --  to be raised, it should be raised by the previous check
               --  (for Next_CU being Nil Compilation Unit)
               --
               --  This guessing is not very smart...

               Next_CU := Nil_Compilation_Unit;
            end if;

         end if;

         if not Is_Nil (Next_CU) then
            Result_Len := Result_Len + 1;
            Result_List (Result_Len) := Next_CU;
         end if;

         Get_Bind_File_Line;

      end loop;
      return Result_List (1 .. Result_Len);

   exception
      when Name_Error =>

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

      when Constraint_Error =>

         GNATELIM.Errors.Error
           ("gnatelim: there are probably not enough "
            & "tree files in you environment.");

   end Get_Units_From_Bind_File;

end GNATELIM.Process_Bind_File;
