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