path: root/gcc/ada/mlib.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                 M L I B                                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 1999-2009, AdaCore                     --
--                                                                          --
-- 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 3,  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 COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Interfaces.C.Strings;
with System;

with Hostparm;
with Opt;
with Output; use Output;

with MLib.Utl; use MLib.Utl;

with Prj.Com;

with GNAT.Directory_Operations; use GNAT.Directory_Operations;

package body MLib is

   -------------------
   -- Build_Library --
   -------------------

   procedure Build_Library
     (Ofiles      : Argument_List;
      Output_File : String;
      Output_Dir  : String)
   is
   begin
      if Opt.Verbose_Mode and not Opt.Quiet_Output then
         Write_Line ("building a library...");
         Write_Str  ("   make ");
         Write_Line (Output_File);
      end if;

      Ar (Output_Dir &
          "lib" & Output_File & ".a", Objects => Ofiles);
   end Build_Library;

   ------------------------
   -- Check_Library_Name --
   ------------------------

   procedure Check_Library_Name (Name : String) is
   begin
      if Name'Length = 0 then
         Prj.Com.Fail ("library name cannot be empty");
      end if;

      if Name'Length > Max_Characters_In_Library_Name then
         Prj.Com.Fail ("illegal library name """
                       & Name
                       & """: too long");
      end if;

      if not Is_Letter (Name (Name'First)) then
         Prj.Com.Fail ("illegal library name """
                       & Name
                       & """: should start with a letter");
      end if;

      for Index in Name'Range loop
         if not Is_Alphanumeric (Name (Index)) then
            Prj.Com.Fail ("illegal library name """
                          & Name
                          & """: should include only letters and digits");
         end if;
      end loop;
   end Check_Library_Name;

   --------------------
   -- Copy_ALI_Files --
   --------------------

   procedure Copy_ALI_Files
     (Files      : Argument_List;
      To         : Path_Name_Type;
      Interfaces : String_List)
   is
      Success      : Boolean := False;
      To_Dir       : constant String := Get_Name_String (To);
      Is_Interface : Boolean := False;

      procedure Verbose_Copy (Index : Positive);
      --  In verbose mode, output a message that the indexed file is copied
      --  to the destination directory.

      ------------------
      -- Verbose_Copy --
      ------------------

      procedure Verbose_Copy (Index : Positive) is
      begin
         if Opt.Verbose_Mode then
            Write_Str ("Copying """);
            Write_Str (Files (Index).all);
            Write_Str (""" to """);
            Write_Str (To_Dir);
            Write_Line ("""");
         end if;
      end Verbose_Copy;

   --  Start of processing for Copy_ALI_Files

   begin
      if Interfaces'Length = 0 then

         --  If there are no Interfaces, copy all the ALI files as is

         for Index in Files'Range loop
            Verbose_Copy (Index);
            Set_Writable
              (To_Dir &
               Directory_Separator &
               Base_Name (Files (Index).all));
            Copy_File
              (Files (Index).all,
               To_Dir,
               Success,
               Mode => Overwrite,
               Preserve => Preserve);

            exit when not Success;
         end loop;

      else
         --  Copy only the interface ALI file, and put the special indicator
         --  "SL" on the P line.

         for Index in Files'Range loop

            declare
               File_Name : String := Base_Name (Files (Index).all);

            begin
               Canonical_Case_File_Name (File_Name);

               --  Check if this is one of the interface ALIs

               Is_Interface := False;

               for Index in Interfaces'Range loop
                  if File_Name = Interfaces (Index).all then
                     Is_Interface := True;
                     exit;
                  end if;
               end loop;

               --  If it is an interface ALI, copy line by line. Insert
               --  the interface indication at the end of the P line.
               --  Do not copy ALI files that are not Interfaces.

               if Is_Interface then
                  Success := False;
                  Verbose_Copy (Index);
                  Set_Writable
                    (To_Dir &
                     Directory_Separator &
                     Base_Name (Files (Index).all));

                  declare
                     FD           : File_Descriptor;
                     Len          : Integer;
                     Actual_Len   : Integer;
                     S            : String_Access;
                     Curr         : Natural;
                     P_Line_Found : Boolean;
                     Status       : Boolean;

                  begin
                     --  Open the file

                     Name_Len := Files (Index)'Length;
                     Name_Buffer (1 .. Name_Len) := Files (Index).all;
                     Name_Len := Name_Len + 1;
                     Name_Buffer (Name_Len) := ASCII.NUL;

                     FD := Open_Read (Name_Buffer'Address, Binary);

                     if FD /= Invalid_FD then
                        Len := Integer (File_Length (FD));

                        --  ??? Why "+3" here

                        S := new String (1 .. Len + 3);

                        --  Read the file. Note that the loop is not necessary
                        --  since the whole file is read at once except on VMS.

                        Curr := S'First;
                        while Curr <= Len loop
                           Actual_Len := Read (FD, S (Curr)'Address, Len);

                           --  Exit if we could not read for some reason

                           exit when Actual_Len = 0;

                           Curr := Curr + Actual_Len;
                        end loop;

                        --  We are done with the input file, so we close it
                        --  ignoring any bad status.

                        Close (FD, Status);

                        P_Line_Found := False;

                        --  Look for the P line. When found, add marker SL
                        --  at the beginning of the P line.

                        for Index in 1 .. Len - 3 loop
                           if (S (Index) = ASCII.LF
                                 or else
                               S (Index) = ASCII.CR)
                             and then S (Index + 1) = 'P'
                           then
                              S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
                              S (Index + 2 .. Index + 4) := " SL";
                              P_Line_Found := True;
                              exit;
                           end if;
                        end loop;

                        if P_Line_Found then

                           --  Create new modified ALI file

                           Name_Len := To_Dir'Length;
                           Name_Buffer (1 .. Name_Len) := To_Dir;
                           Name_Len := Name_Len + 1;
                           Name_Buffer (Name_Len) := Directory_Separator;
                           Name_Buffer
                             (Name_Len + 1 .. Name_Len + File_Name'Length) :=
                                File_Name;
                           Name_Len := Name_Len + File_Name'Length + 1;
                           Name_Buffer (Name_Len) := ASCII.NUL;

                           FD := Create_File (Name_Buffer'Address, Binary);

                           --  Write the modified text and close the newly
                           --  created file.

                           if FD /= Invalid_FD then
                              Actual_Len := Write (FD, S (1)'Address, Len + 3);

                              Close (FD, Status);

                              --  Set Success to True only if the newly
                              --  created file has been correctly written.

                              Success := Status and then Actual_Len = Len + 3;

                              if Success then

                                 --  Set_Read_Only is used here, rather than
                                 --  Set_Non_Writable, so that gprbuild can
                                 --  he compiled with older compilers.

                                 Set_Read_Only
                                   (Name_Buffer (1 .. Name_Len - 1));
                              end if;
                           end if;
                        end if;
                     end if;
                  end;

               --  This is not an interface ALI

               else
                  Success := True;
               end if;
            end;

            if not Success then
               Prj.Com.Fail ("could not copy ALI files to library dir");
            end if;
         end loop;
      end if;
   end Copy_ALI_Files;

   ----------------------
   -- Create_Sym_Links --
   ----------------------

   procedure Create_Sym_Links
     (Lib_Path    : String;
      Lib_Version : String;
      Lib_Dir     : String;
      Maj_Version : String)
   is
      function Symlink
        (Oldpath : System.Address;
         Newpath : System.Address) return Integer;
      pragma Import (C, Symlink, "__gnat_symlink");

      Version_Path : String_Access;

      Success : Boolean;
      Result  : Integer;
      pragma Unreferenced (Success, Result);

   begin
      Version_Path := new String (1 .. Lib_Version'Length + 1);
      Version_Path (1 .. Lib_Version'Length) := Lib_Version;
      Version_Path (Version_Path'Last)       := ASCII.NUL;

      if Maj_Version'Length = 0 then
         declare
            Newpath : String (1 .. Lib_Path'Length + 1);
         begin
            Newpath (1 .. Lib_Path'Length) := Lib_Path;
            Newpath (Newpath'Last)         := ASCII.NUL;
            Delete_File (Lib_Path, Success);
            Result := Symlink (Version_Path (1)'Address, Newpath'Address);
         end;

      else
         declare
            Newpath1 : String (1 .. Lib_Path'Length + 1);
            Maj_Path : constant String :=
                         Lib_Dir & Directory_Separator & Maj_Version;
            Newpath2 : String (1 .. Maj_Path'Length + 1);
            Maj_Ver  : String (1 .. Maj_Version'Length + 1);

         begin
            Newpath1 (1 .. Lib_Path'Length) := Lib_Path;
            Newpath1 (Newpath1'Last)        := ASCII.NUL;

            Newpath2 (1 .. Maj_Path'Length) := Maj_Path;
            Newpath2 (Newpath2'Last)        := ASCII.NUL;

            Maj_Ver (1 .. Maj_Version'Length) := Maj_Version;
            Maj_Ver (Maj_Ver'Last)            := ASCII.NUL;

            Delete_File (Maj_Path, Success);

            Result := Symlink (Version_Path (1)'Address, Newpath2'Address);

            Delete_File (Lib_Path, Success);

            Result := Symlink (Maj_Ver'Address, Newpath1'Address);
         end;
      end if;
   end Create_Sym_Links;

   --------------------------------
   -- Linker_Library_Path_Option --
   --------------------------------

   function Linker_Library_Path_Option return String_Access is

      Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
      pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
      --  Pointer to string representing the native linker option which
      --  specifies the path where the dynamic loader should find shared
      --  libraries. Equal to null string if this system doesn't support it.

      S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr);

   begin
      if S'Length = 0 then
         return null;
      else
         return new String'(S);
      end if;
   end Linker_Library_Path_Option;

   -------------------
   -- Major_Id_Name --
   -------------------

   function Major_Id_Name
     (Lib_Filename : String;
      Lib_Version  : String)
      return String
   is
      Maj_Version : constant String := Lib_Version;
      Last_Maj    : Positive;
      Last        : Positive;
      Ok_Maj      : Boolean := False;

   begin
      Last_Maj := Maj_Version'Last;
      while Last_Maj > Maj_Version'First loop
         if Maj_Version (Last_Maj) in '0' .. '9' then
            Last_Maj := Last_Maj - 1;

         else
            Ok_Maj := Last_Maj /= Maj_Version'Last and then
            Maj_Version (Last_Maj) = '.';

            if Ok_Maj then
               Last_Maj := Last_Maj - 1;
            end if;

            exit;
         end if;
      end loop;

      if Ok_Maj then
         Last := Last_Maj;
         while Last > Maj_Version'First loop
            if Maj_Version (Last) in '0' .. '9' then
               Last := Last - 1;

            else
               Ok_Maj := Last /= Last_Maj and then
               Maj_Version (Last) = '.';

               if Ok_Maj then
                  Last := Last - 1;
                  Ok_Maj :=
                    Maj_Version (Maj_Version'First .. Last) = Lib_Filename;
               end if;

               exit;
            end if;
         end loop;
      end if;

      if Ok_Maj then
         return Maj_Version (Maj_Version'First .. Last_Maj);
      else
         return "";
      end if;
   end Major_Id_Name;

   -------------------------------
   -- Separate_Run_Path_Options --
   -------------------------------

   function Separate_Run_Path_Options return Boolean is
      Separate_Paths : Boolean;
      for Separate_Paths'Size use Character'Size;
      pragma Import (C, Separate_Paths, "__gnat_separate_run_path_options");
   begin
      return Separate_Paths;
   end Separate_Run_Path_Options;

--  Package elaboration

begin
   --  Copy_Attributes always fails on VMS

   if Hostparm.OpenVMS then
      Preserve := None;
   end if;
end MLib;