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