Subversion Repositories scarts

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              O S I N T - C                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--         Copyright (C) 2001-2005 Free Software Foundation, Inc.           --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Hostparm;
with Namet;    use Namet;
with Opt;      use Opt;
with Tree_IO;  use Tree_IO;
 
package body Osint.C is
 
   Output_Object_File_Name : String_Ptr;
   --  Argument of -o compiler option, if given. This is needed to verify
   --  consistency with the ALI file name.
 
   procedure Adjust_OS_Resource_Limits;
   pragma Import (C, Adjust_OS_Resource_Limits,
                  "__gnat_adjust_os_resource_limits");
   --  Procedure to make system specific adjustments to make GNAT run better
 
   function Create_Auxiliary_File
     (Src    : File_Name_Type;
      Suffix : String) return File_Name_Type;
   --  Common processing for Creat_Repinfo_File and Create_Debug_File.
   --  Src is the file name used to create the required output file and
   --  Suffix is the desired suffic (dg/rep for debug/repinfo file).
 
   procedure Set_Library_Info_Name;
   --  Sets a default ali file name from the main compiler source name.
   --  This is used by Create_Output_Library_Info, and by the version of
   --  Read_Library_Info that takes a default file name. The name is in
   --  Name_Buffer (with length in Name_Len) on return from the call
 
   ----------------------
   -- Close_Debug_File --
   ----------------------
 
   procedure Close_Debug_File is
      Status : Boolean;
 
   begin
      Close (Output_FD, Status);
 
      if not Status then
         Fail
           ("error while closing expanded source file ",
            Get_Name_String (Output_File_Name));
      end if;
   end Close_Debug_File;
 
   -------------------------------
   -- Close_Output_Library_Info --
   -------------------------------
 
   procedure Close_Output_Library_Info is
      Status : Boolean;
 
   begin
      Close (Output_FD, Status);
 
      if not Status then
         Fail
           ("error while closing ALI file ",
            Get_Name_String (Output_File_Name));
      end if;
   end Close_Output_Library_Info;
 
   ------------------------
   -- Close_Repinfo_File --
   ------------------------
 
   procedure Close_Repinfo_File is
      Status : Boolean;
 
   begin
      Close (Output_FD, Status);
 
      if not Status then
         Fail
           ("error while closing representation info file ",
            Get_Name_String (Output_File_Name));
      end if;
   end Close_Repinfo_File;
 
   ---------------------------
   -- Create_Auxiliary_File --
   ---------------------------
 
   function Create_Auxiliary_File
     (Src    : File_Name_Type;
      Suffix : String) return   File_Name_Type
   is
      Result : File_Name_Type;
 
   begin
      Get_Name_String (Src);
 
      if Hostparm.OpenVMS then
         Name_Buffer (Name_Len + 1) := '_';
      else
         Name_Buffer (Name_Len + 1) := '.';
      end if;
 
      Name_Len := Name_Len + 1;
      Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
      Name_Len := Name_Len + Suffix'Length;
 
      if Output_Object_File_Name /= null then
 
         for Index in reverse Output_Object_File_Name'Range loop
 
            if Output_Object_File_Name (Index) = Directory_Separator then
               declare
                  File_Name : constant String := Name_Buffer (1 .. Name_Len);
 
               begin
                  Name_Len := Index - Output_Object_File_Name'First + 1;
                  Name_Buffer (1 .. Name_Len) :=
                    Output_Object_File_Name
                      (Output_Object_File_Name'First .. Index);
                  Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) :=
                    File_Name;
                  Name_Len := Name_Len + File_Name'Length;
               end;
 
               exit;
            end if;
         end loop;
      end if;
 
      Result := Name_Find;
      Name_Buffer (Name_Len + 1) := ASCII.NUL;
      Create_File_And_Check (Output_FD, Text);
      return Result;
   end Create_Auxiliary_File;
 
   -----------------------
   -- Create_Debug_File --
   -----------------------
 
   function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
   begin
      return Create_Auxiliary_File (Src, "dg");
   end Create_Debug_File;
 
   --------------------------------
   -- Create_Output_Library_Info --
   --------------------------------
 
   procedure Create_Output_Library_Info is
   begin
      Set_Library_Info_Name;
      Create_File_And_Check (Output_FD, Text);
   end Create_Output_Library_Info;
 
   --------------------------
   -- Creat_Repinfo_File --
   --------------------------
 
   procedure Creat_Repinfo_File (Src : File_Name_Type) is
      S : constant File_Name_Type := Create_Auxiliary_File (Src, "rep");
      pragma Warnings (Off, S);
 
   begin
      return;
   end Creat_Repinfo_File;
 
   ---------------------------
   -- Debug_File_Eol_Length --
   ---------------------------
 
   function Debug_File_Eol_Length return Nat is
   begin
      --  There has to be a cleaner way to do this! ???
 
      if Directory_Separator = '/' then
         return 1;
      else
         return 2;
      end if;
   end Debug_File_Eol_Length;
 
   -----------------------
   -- More_Source_Files --
   -----------------------
 
   function More_Source_Files return Boolean renames More_Files;
 
   ----------------------
   -- Next_Main_Source --
   ----------------------
 
   function Next_Main_Source return File_Name_Type renames Next_Main_File;
 
   -----------------------
   -- Read_Library_Info --
   -----------------------
 
   --  Version with default file name
 
   procedure Read_Library_Info
     (Name : out File_Name_Type;
      Text : out Text_Buffer_Ptr)
   is
   begin
      Set_Library_Info_Name;
      Name := Name_Find;
      Text := Read_Library_Info (Name, Fatal_Err => False);
   end Read_Library_Info;
 
   ---------------------------
   -- Set_Library_Info_Name --
   ---------------------------
 
   procedure Set_Library_Info_Name is
      Dot_Index : Natural;
 
   begin
      Get_Name_String (Current_Main);
 
      --  Find last dot since we replace the existing extension by .ali. The
      --  initialization to Name_Len + 1 provides for simply adding the .ali
      --  extension if the source file name has no extension.
 
      Dot_Index := Name_Len + 1;
 
      for J in reverse 1 .. Name_Len loop
         if Name_Buffer (J) = '.' then
            Dot_Index := J;
            exit;
         end if;
      end loop;
 
      --  Make sure that the output file name matches the source file name.
      --  To compare them, remove file name directories and extensions.
 
      if Output_Object_File_Name /= null then
 
         --  Make sure there is a dot at Dot_Index. This may not be the case
         --  if the source file name has no extension.
 
         Name_Buffer (Dot_Index) := '.';
 
         --  If we are in multiple unit per file mode, then add ~nnn
         --  extension to the name before doing the comparison.
 
         if Multiple_Unit_Index /= 0 then
            declare
               Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
            begin
               Name_Len := Dot_Index - 1;
               Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
               Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
               Dot_Index := Name_Len + 1;
               Add_Str_To_Name_Buffer (Exten);
            end;
         end if;
 
         --  Remove extension preparing to replace it
 
         declare
            Name : constant String  := Name_Buffer (1 .. Dot_Index);
            Len  : constant Natural := Dot_Index;
 
         begin
            Name_Buffer (1 .. Output_Object_File_Name'Length) :=
              Output_Object_File_Name.all;
            Dot_Index := 0;
 
            for J in reverse Output_Object_File_Name'Range loop
               if Name_Buffer (J) = '.' then
                  Dot_Index := J;
                  exit;
               end if;
            end loop;
 
            --  Dot_Index should be zero now (we check for extension elsewhere)
 
            pragma Assert (Dot_Index /= 0);
 
            --  Check name of object file is what we expect
 
            if Name /= Name_Buffer (Dot_Index - Len + 1 .. Dot_Index) then
               Fail ("incorrect object file name");
            end if;
         end;
      end if;
 
      Name_Buffer (Dot_Index) := '.';
      Name_Buffer (Dot_Index + 1 .. Dot_Index + 3) := ALI_Suffix.all;
      Name_Buffer (Dot_Index + 4) := ASCII.NUL;
      Name_Len := Dot_Index + 3;
   end Set_Library_Info_Name;
 
   ---------------------------------
   -- Set_Output_Object_File_Name --
   ---------------------------------
 
   procedure Set_Output_Object_File_Name (Name : String) is
      Ext : constant String := Object_Suffix;
      NL  : constant Natural := Name'Length;
      EL  : constant Natural := Ext'Length;
 
   begin
      --  Make sure that the object file has the expected extension
 
      if NL <= EL
         or else
          (Name (NL - EL + Name'First .. Name'Last) /= Ext
             and then Name (NL - 2 + Name'First .. Name'Last) /= ".o")
      then
         Fail ("incorrect object file extension");
      end if;
 
      Output_Object_File_Name := new String'(Name);
   end Set_Output_Object_File_Name;
 
   ----------------
   -- Tree_Close --
   ----------------
 
   procedure Tree_Close is
      Status : Boolean;
   begin
      Tree_Write_Terminate;
      Close (Output_FD, Status);
 
      if not Status then
         Fail
           ("error while closing tree file ",
            Get_Name_String (Output_File_Name));
      end if;
   end Tree_Close;
 
   -----------------
   -- Tree_Create --
   -----------------
 
   procedure Tree_Create is
      Dot_Index : Natural;
 
   begin
      Get_Name_String (Current_Main);
 
      --  If an object file has been specified, then the ALI file
      --  will be in the same directory as the object file;
      --  so, we put the tree file in this same directory,
      --  even though no object file needs to be generated.
 
      if Output_Object_File_Name /= null then
         Name_Len := Output_Object_File_Name'Length;
         Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
      end if;
 
      Dot_Index := Name_Len + 1;
 
      for J in reverse 1 .. Name_Len loop
         if Name_Buffer (J) = '.' then
            Dot_Index := J;
            exit;
         end if;
      end loop;
 
      --  Should be impossible to not have an extension
 
      pragma Assert (Dot_Index /= 0);
 
      --  Change exctension to adt
 
      Name_Buffer (Dot_Index) := '.';
      Name_Buffer (Dot_Index + 1) := 'a';
      Name_Buffer (Dot_Index + 2) := 'd';
      Name_Buffer (Dot_Index + 3) := 't';
      Name_Buffer (Dot_Index + 4) := ASCII.NUL;
      Name_Len := Dot_Index + 3;
      Create_File_And_Check (Output_FD, Binary);
 
      Tree_Write_Initialize (Output_FD);
   end Tree_Create;
 
   -----------------------
   -- Write_Debug_Info --
   -----------------------
 
   procedure Write_Debug_Info (Info : String) renames Write_Info;
 
   ------------------------
   -- Write_Library_Info --
   ------------------------
 
   procedure Write_Library_Info (Info : String) renames Write_Info;
 
   ------------------------
   -- Write_Repinfo_Line --
   ------------------------
 
   procedure Write_Repinfo_Line (Info : String) renames Write_Info;
 
begin
 
   Adjust_OS_Resource_Limits;
   Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access;
   Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
   Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
 
   Set_Program (Compiler);
 
end Osint.C;