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-2007, AdaCore                     --
  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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Ada.Characters.Handling; use Ada.Characters.Handling;
  27 with Interfaces.C.Strings;
  28 with System;
  29
  30 with Hostparm;
  31 with Opt;
  32 with Output; use Output;
  33
  34 with MLib.Utl; use MLib.Utl;
  35
  36 with Prj.Com;
  37
  38 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  39
  40 package body MLib is
  41
  42    -------------------
  43    -- Build_Library --
  44    -------------------
  45
  46    procedure Build_Library
  47      (Ofiles      : Argument_List;
  48       Output_File : String;
  49       Output_Dir  : String)
  50    is
  51    begin
  52       if Opt.Verbose_Mode and not Opt.Quiet_Output then
  53          Write_Line ("building a library...");
  54          Write_Str  ("   make ");
  55          Write_Line (Output_File);
  56       end if;
  57
  58       Ar (Output_Dir & Directory_Separator &
  59           "lib" & Output_File & ".a", Objects => Ofiles);
  60    end Build_Library;
  61
  62    ------------------------
  63    -- Check_Library_Name --
  64    ------------------------
  65
  66    procedure Check_Library_Name (Name : String) is
  67    begin
  68       if Name'Length = 0 then
  69          Prj.Com.Fail ("library name cannot be empty");
  70       end if;
  71
  72       if Name'Length > Max_Characters_In_Library_Name then
  73          Prj.Com.Fail ("illegal library name """, Name, """: too long");
  74       end if;
  75
  76       if not Is_Letter (Name (Name'First)) then
  77          Prj.Com.Fail ("illegal library name """,
  78                        Name,
  79                        """: should start with a letter");
  80       end if;
  81
  82       for Index in Name'Range loop
  83          if not Is_Alphanumeric (Name (Index)) then
  84             Prj.Com.Fail ("illegal library name """,
  85                           Name,
  86                           """: should include only letters and digits");
  87          end if;
  88       end loop;
  89    end Check_Library_Name;
  90
  91    --------------------
  92    -- Copy_ALI_Files --
  93    --------------------
  94
  95    procedure Copy_ALI_Files
  96      (Files      : Argument_List;
  97       To         : Path_Name_Type;
  98       Interfaces : String_List)
  99    is
 100       Success      : Boolean := False;
 101       To_Dir       : constant String := Get_Name_String (To);
 102       Is_Interface : Boolean := False;
 103
 104       procedure Verbose_Copy (Index : Positive);
 105       --  In verbose mode, output a message that the indexed file is copied
 106       --  to the destination directory.
 107
 108       ------------------
 109       -- Verbose_Copy --
 110       ------------------
 111
 112       procedure Verbose_Copy (Index : Positive) is
 113       begin
 114          if Opt.Verbose_Mode then
 115             Write_Str ("Copying """);
 116             Write_Str (Files (Index).all);
 117             Write_Str (""" to """);
 118             Write_Str (To_Dir);
 119             Write_Line ("""");
 120          end if;
 121       end Verbose_Copy;
 122
 123    --  Start of processing for Copy_ALI_Files
 124
 125    begin
 126       if Interfaces'Length = 0 then
 127
 128          --  If there are no Interfaces, copy all the ALI files as is
 129
 130          for Index in Files'Range loop
 131             Verbose_Copy (Index);
 132             Set_Writable
 133               (To_Dir &
 134                Directory_Separator &
 135                Base_Name (Files (Index).all));
 136             Copy_File
 137               (Files (Index).all,
 138                To_Dir,
 139                Success,
 140                Mode => Overwrite,
 141                Preserve => Preserve);
 142
 143             exit when not Success;
 144          end loop;
 145
 146       else
 147          --  Copy only the interface ALI file, and put the special indicator
 148          --  "SL" on the P line.
 149
 150          for Index in Files'Range loop
 151
 152             declare
 153                File_Name : String := Base_Name (Files (Index).all);
 154
 155             begin
 156                Canonical_Case_File_Name (File_Name);
 157
 158                --  Check if this is one of the interface ALIs
 159
 160                Is_Interface := False;
 161
 162                for Index in Interfaces'Range loop
 163                   if File_Name = Interfaces (Index).all then
 164                      Is_Interface := True;
 165                      exit;
 166                   end if;
 167                end loop;
 168
 169                --  If it is an interface ALI, copy line by line. Insert
 170                --  the interface indication at the end of the P line.
 171                --  Do not copy ALI files that are not Interfaces.
 172
 173                if Is_Interface then
 174                   Success := False;
 175                   Verbose_Copy (Index);
 176                   Set_Writable
 177                     (To_Dir &
 178                      Directory_Separator &
 179                      Base_Name (Files (Index).all));
 180
 181                   declare
 182                      FD           : File_Descriptor;
 183                      Len          : Integer;
 184                      Actual_Len   : Integer;
 185                      S            : String_Access;
 186                      Curr         : Natural;
 187                      P_Line_Found : Boolean;
 188                      Status       : Boolean;
 189
 190                   begin
 191                      --  Open the file
 192
 193                      Name_Len := Files (Index)'Length;
 194                      Name_Buffer (1 .. Name_Len) := Files (Index).all;
 195                      Name_Len := Name_Len + 1;
 196                      Name_Buffer (Name_Len) := ASCII.NUL;
 197
 198                      FD := Open_Read (Name_Buffer'Address, Binary);
 199
 200                      if FD /= Invalid_FD then
 201                         Len := Integer (File_Length (FD));
 202
 203                         S := new String (1 .. Len + 3);
 204
 205                         --  Read the file. Note that the loop is not necessary
 206                         --  since the whole file is read at once except on VMS.
 207
 208                         Curr := 1;
 209                         Actual_Len := Len;
 210
 211                         while Actual_Len /= 0 loop
 212                            Actual_Len := Read (FD, S (Curr)'Address, Len);
 213                            Curr := Curr + Actual_Len;
 214                         end loop;
 215
 216                         --  We are done with the input file, so we close it
 217                         --  ignoring any bad status.
 218
 219                         Close (FD, Status);
 220
 221                         P_Line_Found := False;
 222
 223                         --  Look for the P line. When found, add marker SL
 224                         --  at the beginning of the P line.
 225
 226                         for Index in 1 .. Len - 3 loop
 227                            if (S (Index) = ASCII.LF or else
 228                                  S (Index) = ASCII.CR)
 229                              and then
 230                                S (Index + 1) = 'P'
 231                            then
 232                               S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
 233                               S (Index + 2 .. Index + 4) := " SL";
 234                               P_Line_Found := True;
 235                               exit;
 236                            end if;
 237                         end loop;
 238
 239                         if P_Line_Found then
 240
 241                            --  Create new modified ALI file
 242
 243                            Name_Len := To_Dir'Length;
 244                            Name_Buffer (1 .. Name_Len) := To_Dir;
 245                            Name_Len := Name_Len + 1;
 246                            Name_Buffer (Name_Len) := Directory_Separator;
 247                            Name_Buffer
 248                              (Name_Len + 1 .. Name_Len + File_Name'Length) :=
 249                                 File_Name;
 250                            Name_Len := Name_Len + File_Name'Length + 1;
 251                            Name_Buffer (Name_Len) := ASCII.NUL;
 252
 253                            FD := Create_File (Name_Buffer'Address, Binary);
 254
 255                            --  Write the modified text and close the newly
 256                            --  created file.
 257
 258                            if FD /= Invalid_FD then
 259                               Actual_Len := Write (FD, S (1)'Address, Len + 3);
 260
 261                               Close (FD, Status);
 262
 263                               --  Set Success to True only if the newly
 264                               --  created file has been correctly written.
 265
 266                               Success := Status and Actual_Len = Len + 3;
 267
 268                               if Success then
 269                                  Set_Read_Only (
 270                                    Name_Buffer (1 .. Name_Len - 1));
 271                               end if;
 272                            end if;
 273                         end if;
 274                      end if;
 275                   end;
 276
 277                --  This is not an interface ALI
 278
 279                else
 280                   Success := True;
 281                end if;
 282             end;
 283
 284             if not Success then
 285                Prj.Com.Fail ("could not copy ALI files to library dir");
 286             end if;
 287          end loop;
 288       end if;
 289    end Copy_ALI_Files;
 290
 291    ----------------------
 292    -- Create_Sym_Links --
 293    ----------------------
 294
 295    procedure Create_Sym_Links
 296      (Lib_Path    : String;
 297       Lib_Version : String;
 298       Lib_Dir     : String;
 299       Maj_Version : String)
 300    is
 301       function Symlink
 302         (Oldpath : System.Address;
 303          Newpath : System.Address) return Integer;
 304       pragma Import (C, Symlink, "__gnat_symlink");
 305
 306       Version_Path : String_Access;
 307
 308       Success : Boolean;
 309       Result  : Integer;
 310       pragma Unreferenced (Success, Result);
 311
 312    begin
 313       if Is_Absolute_Path (Lib_Version) then
 314          Version_Path := new String (1 .. Lib_Version'Length + 1);
 315          Version_Path (1 .. Lib_Version'Length) := Lib_Version;
 316
 317       else
 318          Version_Path :=
 319            new String (1 .. Lib_Dir'Length + 1 + Lib_Version'Length + 1);
 320          Version_Path (1 .. Version_Path'Last - 1) :=
 321            Lib_Dir & Directory_Separator & Lib_Version;
 322       end if;
 323
 324       Version_Path (Version_Path'Last) := ASCII.NUL;
 325
 326       if Maj_Version'Length = 0 then
 327          declare
 328             Newpath : String (1 .. Lib_Path'Length + 1);
 329          begin
 330             Newpath (1 .. Lib_Path'Length) := Lib_Path;
 331             Newpath (Newpath'Last)         := ASCII.NUL;
 332             Delete_File (Lib_Path, Success);
 333             Result := Symlink (Version_Path (1)'Address, Newpath'Address);
 334          end;
 335
 336       else
 337          declare
 338             Newpath1 : String (1 .. Lib_Path'Length + 1);
 339             Maj_Path : constant String :=
 340                          Lib_Dir & Directory_Separator & Maj_Version;
 341             Newpath2 : String (1 .. Maj_Path'Length + 1);
 342
 343          begin
 344             Newpath1 (1 .. Lib_Path'Length) := Lib_Path;
 345             Newpath1 (Newpath1'Last)        := ASCII.NUL;
 346
 347             Newpath2 (1 .. Maj_Path'Length) := Maj_Path;
 348             Newpath2 (Newpath2'Last)        := ASCII.NUL;
 349
 350             Delete_File (Maj_Path, Success);
 351
 352             Result := Symlink (Version_Path (1)'Address, Newpath2'Address);
 353
 354             Delete_File (Lib_Path, Success);
 355
 356             Result := Symlink (Newpath2'Address, Newpath1'Address);
 357          end;
 358       end if;
 359    end Create_Sym_Links;
 360
 361    --------------------------------
 362    -- Linker_Library_Path_Option --
 363    --------------------------------
 364
 365    function Linker_Library_Path_Option return String_Access is
 366
 367       Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
 368       pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
 369       --  Pointer to string representing the native linker option which
 370       --  specifies the path where the dynamic loader should find shared
 371       --  libraries. Equal to null string if this system doesn't support it.
 372
 373       S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr);
 374
 375    begin
 376       if S'Length = 0 then
 377          return null;
 378       else
 379          return new String'(S);
 380       end if;
 381    end Linker_Library_Path_Option;
 382
 383    -------------------
 384    -- Major_Id_Name --
 385    -------------------
 386
 387    function Major_Id_Name
 388      (Lib_Filename : String;
 389       Lib_Version  : String)
 390       return String
 391    is
 392       Maj_Version : constant String := Lib_Version;
 393       Last_Maj    : Positive;
 394       Last        : Positive;
 395       Ok_Maj      : Boolean := False;
 396
 397    begin
 398       Last_Maj := Maj_Version'Last;
 399       while Last_Maj > Maj_Version'First loop
 400          if Maj_Version (Last_Maj) in '0' .. '9' then
 401             Last_Maj := Last_Maj - 1;
 402
 403          else
 404             Ok_Maj := Last_Maj /= Maj_Version'Last and then
 405             Maj_Version (Last_Maj) = '.';
 406
 407             if Ok_Maj then
 408                Last_Maj := Last_Maj - 1;
 409             end if;
 410
 411             exit;
 412          end if;
 413       end loop;
 414
 415       if Ok_Maj then
 416          Last := Last_Maj;
 417          while Last > Maj_Version'First loop
 418             if Maj_Version (Last) in '0' .. '9' then
 419                Last := Last - 1;
 420
 421             else
 422                Ok_Maj := Last /= Last_Maj and then
 423                Maj_Version (Last) = '.';
 424
 425                if Ok_Maj then
 426                   Last := Last - 1;
 427                   Ok_Maj :=
 428                     Maj_Version (Maj_Version'First .. Last) = Lib_Filename;
 429                end if;
 430
 431                exit;
 432             end if;
 433          end loop;
 434       end if;
 435
 436       if Ok_Maj then
 437          return Maj_Version (Maj_Version'First .. Last_Maj);
 438       else
 439          return "";
 440       end if;
 441    end Major_Id_Name;
 442
 443 --  Package elaboration
 444
 445 begin
 446    --  Copy_Attributes always fails on VMS
 447
 448    if Hostparm.OpenVMS then
 449       Preserve := None;
 450    end if;
 451 end MLib;