gcc/ada/mlib.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                 M L I B                                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --           Copyright (C) 1999-2005, Ada Core Technologies, Inc.           --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Ada.Characters.Handling; use Ada.Characters.Handling;
  28 with Interfaces.C.Strings;
  29
  30 with Hostparm;
  31 with Opt;
  32 with Output; use Output;
  33 with Namet;  use Namet;
  34
  35 with MLib.Utl; use MLib.Utl;
  36
  37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  38 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  39
  40 package body MLib is
  41
  42    -------------------
  43    -- Build_Library --
  44    -------------------
  45
  46    procedure Build_Library
  47      (Ofiles      : Argument_List;
  48       Afiles      : Argument_List;
  49       Output_File : String;
  50       Output_Dir  : String)
  51    is
  52       pragma Warnings (Off, Afiles);
  53
  54       use GNAT.OS_Lib;
  55
  56    begin
  57       if not Opt.Quiet_Output then
  58          Write_Line ("building a library...");
  59          Write_Str  ("   make ");
  60          Write_Line (Output_File);
  61       end if;
  62
  63       Ar (Output_Dir & "/lib" & Output_File & ".a", Objects => Ofiles);
  64    end Build_Library;
  65
  66    ------------------------
  67    -- Check_Library_Name --
  68    ------------------------
  69
  70    procedure Check_Library_Name (Name : String) is
  71    begin
  72       if Name'Length = 0 then
  73          Fail ("library name cannot be empty");
  74       end if;
  75
  76       if Name'Length > Max_Characters_In_Library_Name then
  77          Fail ("illegal library name """, Name, """: too long");
  78       end if;
  79
  80       if not Is_Letter (Name (Name'First)) then
  81          Fail ("illegal library name """,
  82                Name,
  83                """: should start with a letter");
  84       end if;
  85
  86       for Index in Name'Range loop
  87          if not Is_Alphanumeric (Name (Index)) then
  88             Fail ("illegal library name """,
  89                   Name,
  90                   """: should include only letters and digits");
  91          end if;
  92       end loop;
  93    end Check_Library_Name;
  94
  95    --------------------
  96    -- Copy_ALI_Files --
  97    --------------------
  98
  99    procedure Copy_ALI_Files
 100      (Files      : Argument_List;
 101       To         : Name_Id;
 102       Interfaces : String_List)
 103    is
 104       Success      : Boolean := False;
 105       To_Dir       : constant String := Get_Name_String (To);
 106       Is_Interface : Boolean := False;
 107
 108       procedure Verbose_Copy (Index : Positive);
 109       --  In verbose mode, output a message that the indexed file is copied
 110       --  to the destination directory.
 111
 112       ------------------
 113       -- Verbose_Copy --
 114       ------------------
 115
 116       procedure Verbose_Copy (Index : Positive) is
 117       begin
 118          if Opt.Verbose_Mode then
 119             Write_Str ("Copying """);
 120             Write_Str (Files (Index).all);
 121             Write_Str (""" to """);
 122             Write_Str (To_Dir);
 123             Write_Line ("""");
 124          end if;
 125       end Verbose_Copy;
 126
 127    begin
 128       if Interfaces'Length = 0 then
 129
 130          --  If there are no Interfaces, copy all the ALI files as is
 131
 132          for Index in Files'Range loop
 133             Verbose_Copy (Index);
 134             Copy_File
 135               (Files (Index).all,
 136                To_Dir,
 137                Success,
 138                Mode => Overwrite,
 139                Preserve => Preserve);
 140
 141             exit when not Success;
 142          end loop;
 143
 144       else
 145          --  Copy only the interface ALI file, and put the special indicator
 146          --  "SL" on the P line.
 147
 148          for Index in Files'Range loop
 149
 150             declare
 151                File_Name : String := Base_Name (Files (Index).all);
 152             begin
 153                Canonical_Case_File_Name (File_Name);
 154
 155                --  Check if this is one of the interface ALIs
 156
 157                Is_Interface := False;
 158
 159                for Index in Interfaces'Range loop
 160                   if File_Name = Interfaces (Index).all then
 161                      Is_Interface := True;
 162                      exit;
 163                   end if;
 164                end loop;
 165
 166                --  If it is an interface ALI, copy line by line. Insert
 167                --  the interface indication at the end of the P line.
 168                --  Do not copy ALI files that are not Interfaces.
 169
 170                if Is_Interface then
 171                   Success := False;
 172                   Verbose_Copy (Index);
 173
 174                   declare
 175                      FD         : File_Descriptor;
 176                      Len        : Integer;
 177                      Actual_Len : Integer;
 178                      S          : String_Access;
 179                      Curr       : Natural;
 180                      P_Line_Found : Boolean;
 181                      Status     : Boolean;
 182
 183                   begin
 184                      --  Open the file
 185
 186                      Name_Len := Files (Index)'Length;
 187                      Name_Buffer (1 .. Name_Len) := Files (Index).all;
 188                      Name_Len := Name_Len + 1;
 189                      Name_Buffer (Name_Len) := ASCII.NUL;
 190
 191                      FD := Open_Read (Name_Buffer'Address, Binary);
 192
 193                      if FD /= Invalid_FD then
 194                         Len := Integer (File_Length (FD));
 195
 196                         S := new String (1 .. Len + 3);
 197
 198                         --  Read the file. Note that the loop is not necessary
 199                         --  since the whole file is read at once except on VMS.
 200
 201                         Curr := 1;
 202                         Actual_Len := Len;
 203
 204                         while Actual_Len /= 0 loop
 205                            Actual_Len := Read (FD, S (Curr)'Address, Len);
 206                            Curr := Curr + Actual_Len;
 207                         end loop;
 208
 209                         --  We are done with the input file, so we close it
 210
 211                         Close (FD, Status);
 212                         --  We simply ignore any bad status
 213
 214                         P_Line_Found := False;
 215
 216                         --  Look for the P line. When found, add marker SL
 217                         --  at the beginning of the P line.
 218
 219                         for Index in 1 .. Len - 3 loop
 220                            if (S (Index) = ASCII.LF or else
 221                                  S (Index) = ASCII.CR)
 222                              and then
 223                                S (Index + 1) = 'P'
 224                            then
 225                               S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
 226                               S (Index + 2 .. Index + 4) := " SL";
 227                               P_Line_Found := True;
 228                               exit;
 229                            end if;
 230                         end loop;
 231
 232                         if P_Line_Found then
 233
 234                            --  Create new modified ALI file
 235
 236                            Name_Len := To_Dir'Length;
 237                            Name_Buffer (1 .. Name_Len) := To_Dir;
 238                            Name_Len := Name_Len + 1;
 239                            Name_Buffer (Name_Len) := Directory_Separator;
 240                            Name_Buffer
 241                              (Name_Len + 1 .. Name_Len + File_Name'Length) :=
 242                                 File_Name;
 243                            Name_Len := Name_Len + File_Name'Length + 1;
 244                            Name_Buffer (Name_Len) := ASCII.NUL;
 245
 246                            FD := Create_File (Name_Buffer'Address, Binary);
 247
 248                            --  Write the modified text and close the newly
 249                            --  created file.
 250
 251                            if FD /= Invalid_FD then
 252                               Actual_Len := Write (FD, S (1)'Address, Len + 3);
 253
 254                               Close (FD, Status);
 255
 256                               --  Set Success to True only if the newly
 257                               --  created file has been correctly written.
 258
 259                               Success := Status and Actual_Len = Len + 3;
 260
 261                               if Success then
 262                                  Set_Read_Only (
 263                                    Name_Buffer (1 .. Name_Len - 1));
 264                               end if;
 265                            end if;
 266                         end if;
 267                      end if;
 268                   end;
 269
 270                else
 271                   --  This is not an interface ALI
 272
 273                   Success := True;
 274
 275                end if;
 276             end;
 277
 278             if not Success then
 279                Fail ("could not copy ALI files to library dir");
 280             end if;
 281          end loop;
 282       end if;
 283    end Copy_ALI_Files;
 284
 285    --------------------------------
 286    -- Linker_Library_Path_Option --
 287    --------------------------------
 288
 289    function Linker_Library_Path_Option return String_Access is
 290
 291       Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
 292       pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
 293       --  Pointer to string representing the native linker option which
 294       --  specifies the path where the dynamic loader should find shared
 295       --  libraries. Equal to null string if this system doesn't support it.
 296
 297       S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr);
 298
 299    begin
 300       if S'Length = 0 then
 301          return null;
 302       else
 303          return new String'(S);
 304       end if;
 305    end Linker_Library_Path_Option;
 306
 307 --  Package elaboration
 308
 309 begin
 310    --  Copy_Attributes always fails on VMS
 311
 312    if Hostparm.OpenVMS then
 313       Preserve := None;
 314    end if;
 315 end MLib;