gcc/ada/mlib-utl.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             M L I B . U T L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2002-2013, 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 MLib.Fil; use MLib.Fil;
  27 with MLib.Tgt; use MLib.Tgt;
  28 with Opt;
  29 with Osint;
  30 with Output;   use Output;
  31
  32 with Interfaces.C.Strings; use Interfaces.C.Strings;
  33
  34 package body MLib.Utl is
  35
  36    Adalib_Path : String_Access := null;
  37    --  Path of the GNAT adalib directory, specified in procedure
  38    --  Specify_Adalib_Dir. Used in function Lib_Directory.
  39
  40    Gcc_Name : String_Access;
  41    --  Default value of the "gcc" executable used in procedure Gcc
  42
  43    Gcc_Exec : String_Access;
  44    --  The full path name of the "gcc" executable
  45
  46    Ar_Name : String_Access;
  47    --  The name of the archive builder for the platform, set when procedure Ar
  48    --  is called for the first time.
  49
  50    Ar_Exec : String_Access;
  51    --  The full path name of the archive builder
  52
  53    Ar_Options : String_List_Access;
  54    --  The minimum options used when invoking the archive builder
  55
  56    Ar_Append_Options : String_List_Access;
  57    --  The options to be used when invoking the archive builder to add chunks
  58    --  of object files, when building the archive in chunks.
  59
  60    Opt_Length : Natural := 0;
  61    --  The max number of options for the Archive_Builder
  62
  63    Initial_Size : Natural := 0;
  64    --  The minimum number of bytes for the invocation of the Archive Builder
  65    --  (without name of the archive or object files).
  66
  67    Ranlib_Name : String_Access;
  68    --  The name of the archive indexer for the platform, if there is one
  69
  70    Ranlib_Exec : String_Access := null;
  71    --  The full path name of the archive indexer
  72
  73    Ranlib_Options : String_List_Access := null;
  74    --  The options to be used when invoking the archive indexer, if any
  75
  76    --------
  77    -- Ar --
  78    --------
  79
  80    procedure Ar (Output_File : String; Objects : Argument_List) is
  81       Full_Output_File : constant String :=
  82                              Ext_To (Output_File, Archive_Ext);
  83
  84       Arguments   : Argument_List_Access;
  85       Last_Arg    : Natural := 0;
  86       Success     : Boolean;
  87       Line_Length : Natural := 0;
  88
  89       Maximum_Size : Integer;
  90       pragma Import (C, Maximum_Size, "__gnat_link_max");
  91       --  Maximum number of bytes to put in an invocation of the
  92       --  Archive_Builder.
  93
  94       Size : Integer;
  95       --  The number of bytes for the invocation of the archive builder
  96
  97       Current_Object : Natural;
  98
  99       procedure Display;
 100       --  Display an invocation of the Archive Builder
 101
 102       -------------
 103       -- Display --
 104       -------------
 105
 106       procedure Display is
 107       begin
 108          if not Opt.Quiet_Output then
 109             Write_Str (Ar_Name.all);
 110             Line_Length := Ar_Name'Length;
 111
 112             for J in 1 .. Last_Arg loop
 113
 114                --  Make sure the Output buffer does not overflow
 115
 116                if Line_Length + 1 + Arguments (J)'Length > Buffer_Max then
 117                   Write_Eol;
 118                   Line_Length := 0;
 119                end if;
 120
 121                Write_Char (' ');
 122
 123                --  Only output the first object files when not in verbose mode
 124
 125                if (not Opt.Verbose_Mode) and then J = Opt_Length + 3 then
 126                   Write_Str ("...");
 127                   exit;
 128                end if;
 129
 130                Write_Str (Arguments (J).all);
 131                Line_Length := Line_Length + 1 + Arguments (J)'Length;
 132             end loop;
 133
 134             Write_Eol;
 135          end if;
 136
 137       end Display;
 138
 139    begin
 140       if Ar_Exec = null then
 141          Ar_Name := Osint.Program_Name (Archive_Builder, "gnatmake");
 142          Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
 143
 144          if Ar_Exec = null then
 145             Free (Ar_Name);
 146             Ar_Name := new String'(Archive_Builder);
 147             Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
 148          end if;
 149
 150          if Ar_Exec = null then
 151             Fail (Ar_Name.all & " not found in path");
 152
 153          elsif Opt.Verbose_Mode then
 154             Write_Str  ("found ");
 155             Write_Line (Ar_Exec.all);
 156          end if;
 157
 158          Ar_Options := Archive_Builder_Options;
 159
 160          Initial_Size := 0;
 161          for J in Ar_Options'Range loop
 162             Initial_Size := Initial_Size + Ar_Options (J)'Length + 1;
 163          end loop;
 164
 165          Ar_Append_Options := Archive_Builder_Append_Options;
 166
 167          Opt_Length := Ar_Options'Length;
 168
 169          if Ar_Append_Options /= null then
 170             Opt_Length := Natural'Max (Ar_Append_Options'Length, Opt_Length);
 171
 172             Size := 0;
 173             for J in Ar_Append_Options'Range loop
 174                Size := Size + Ar_Append_Options (J)'Length + 1;
 175             end loop;
 176
 177             Initial_Size := Integer'Max (Initial_Size, Size);
 178          end if;
 179
 180          --  ranlib
 181
 182          Ranlib_Name := Osint.Program_Name (Archive_Indexer, "gnatmake");
 183
 184          if Ranlib_Name'Length > 0 then
 185             Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
 186
 187             if Ranlib_Exec = null then
 188                Free (Ranlib_Name);
 189                Ranlib_Name := new String'(Archive_Indexer);
 190                Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
 191             end if;
 192
 193             if Ranlib_Exec /= null and then Opt.Verbose_Mode then
 194                Write_Str ("found ");
 195                Write_Line (Ranlib_Exec.all);
 196             end if;
 197          end if;
 198
 199          Ranlib_Options := Archive_Indexer_Options;
 200       end if;
 201
 202       Arguments :=
 203         new String_List (1 .. 1 + Opt_Length + Objects'Length);
 204       Arguments (1 .. Ar_Options'Length) := Ar_Options.all; --  "ar cr ..."
 205       Arguments (Ar_Options'Length + 1) := new String'(Full_Output_File);
 206
 207       Delete_File (Full_Output_File);
 208
 209       Size := Initial_Size + Full_Output_File'Length + 1;
 210
 211       --  Check the full size of a call of the archive builder with all the
 212       --  object files.
 213
 214       for J in Objects'Range loop
 215          Size := Size + Objects (J)'Length + 1;
 216       end loop;
 217
 218       --  If the size is not too large or if it is not possible to build the
 219       --  archive in chunks, build the archive in a single invocation.
 220
 221       if Size <= Maximum_Size or else Ar_Append_Options = null then
 222          Last_Arg := Ar_Options'Length + 1 + Objects'Length;
 223          Arguments (Ar_Options'Length + 2 .. Last_Arg) := Objects;
 224
 225          Display;
 226
 227          Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
 228
 229       else
 230          --  Build the archive in several invocation, making sure to not
 231          --  go over the maximum size for each invocation.
 232
 233          Last_Arg := Ar_Options'Length + 1;
 234          Current_Object := Objects'First;
 235          Size := Initial_Size + Full_Output_File'Length + 1;
 236
 237          --  First invocation
 238
 239          while Current_Object <= Objects'Last loop
 240             Size := Size + Objects (Current_Object)'Length + 1;
 241             exit when Size > Maximum_Size;
 242             Last_Arg := Last_Arg + 1;
 243             Arguments (Last_Arg) := Objects (Current_Object);
 244             Current_Object := Current_Object + 1;
 245          end loop;
 246
 247          Display;
 248
 249          Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
 250
 251          Arguments (1 .. Ar_Append_Options'Length) := Ar_Append_Options.all;
 252          Arguments
 253            (Ar_Append_Options'Length + 1) := new String'(Full_Output_File);
 254
 255          --  Appending invocation(s)
 256
 257          Big_Loop : while Success and then Current_Object <= Objects'Last loop
 258             Last_Arg := Ar_Append_Options'Length + 1;
 259             Size := Initial_Size + Full_Output_File'Length + 1;
 260
 261             Inner_Loop : while Current_Object <= Objects'Last loop
 262                Size := Size + Objects (Current_Object)'Length + 1;
 263                exit Inner_Loop when Size > Maximum_Size;
 264                Last_Arg := Last_Arg + 1;
 265                Arguments (Last_Arg) := Objects (Current_Object);
 266                Current_Object := Current_Object + 1;
 267             end loop Inner_Loop;
 268
 269             Display;
 270
 271             Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
 272          end loop Big_Loop;
 273       end if;
 274
 275       if not Success then
 276          Fail (Ar_Name.all & " execution error.");
 277       end if;
 278
 279       --  If we have found ranlib, run it over the library
 280
 281       if Ranlib_Exec /= null then
 282          if not Opt.Quiet_Output then
 283             Write_Str  (Ranlib_Name.all);
 284             Write_Char (' ');
 285             for J in Ranlib_Options'Range loop
 286                Write_Str  (Ranlib_Options (J).all);
 287                Write_Char (' ');
 288             end loop;
 289             Write_Line (Arguments (Ar_Options'Length + 1).all);
 290          end if;
 291
 292          Spawn
 293            (Ranlib_Exec.all,
 294             Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)),
 295             Success);
 296
 297          if not Success then
 298             Fail (Ranlib_Name.all & " execution error.");
 299          end if;
 300       end if;
 301    end Ar;
 302
 303    -----------------
 304    -- Delete_File --
 305    -----------------
 306
 307    procedure Delete_File (Filename : String) is
 308       File    : constant String := Filename & ASCII.NUL;
 309       Success : Boolean;
 310
 311    begin
 312       Delete_File (File'Address, Success);
 313
 314       if Opt.Verbose_Mode then
 315          if Success then
 316             Write_Str ("deleted ");
 317
 318          else
 319             Write_Str ("could not delete ");
 320          end if;
 321
 322          Write_Line (Filename);
 323       end if;
 324    end Delete_File;
 325
 326    ---------
 327    -- Gcc --
 328    ---------
 329
 330    procedure Gcc
 331      (Output_File : String;
 332       Objects     : Argument_List;
 333       Options     : Argument_List;
 334       Options_2   : Argument_List;
 335       Driver_Name : Name_Id := No_Name)
 336    is
 337       Link_Bytes : Integer := 0;
 338       --  Projected number of bytes for the linker command line
 339
 340       Link_Max : Integer;
 341       pragma Import (C, Link_Max, "__gnat_link_max");
 342       --  Maximum number of bytes on the command line supported by the OS
 343       --  linker. Passed this limit the response file mechanism must be used
 344       --  if supported.
 345
 346       Object_List_File_Supported : Boolean;
 347       for Object_List_File_Supported'Size use Character'Size;
 348       pragma Import
 349         (C, Object_List_File_Supported, "__gnat_objlist_file_supported");
 350       --  Predicate indicating whether the linker has an option whereby the
 351       --  names of object files can be passed to the linker in a file.
 352
 353       Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
 354       pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option");
 355       --  Pointer to a string representing the linker option which specifies
 356       --  the response file.
 357
 358       Object_File_Option : constant String := Value (Object_File_Option_Ptr);
 359       --  The linker option which specifies the response file as a string
 360
 361       Using_GNU_response_file : constant Boolean :=
 362                                   Object_File_Option'Length > 0
 363                                     and then
 364                                       Object_File_Option
 365                                         (Object_File_Option'Last) = '@';
 366       --  Whether a GNU response file is used
 367
 368       Tname    : String_Access;
 369       Tname_FD : File_Descriptor := Invalid_FD;
 370       --  Temporary file used by linker to pass list of object files on
 371       --  certain systems with limitations on size of arguments.
 372
 373       Closing_Status : Boolean;
 374       --  For call to Close
 375
 376       Arguments :
 377         Argument_List
 378           (1 .. 7 + Objects'Length + Options'Length + Options_2'Length);
 379
 380       A       : Natural := 0;
 381       Success : Boolean;
 382
 383       Out_Opt : constant String_Access := new String'("-o");
 384       Out_V   : constant String_Access := new String'(Output_File);
 385       Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory);
 386       Lib_Opt : constant String_Access := new String'(Dynamic_Option);
 387
 388       Driver : String_Access;
 389
 390       type Object_Position is (First, Second, Last);
 391
 392       Position : Object_Position;
 393
 394       procedure Write_RF (S : String);
 395       --  Write a string to the response file and check if it was successful.
 396       --  Fail the program if it was not successful (disk full).
 397
 398       --------------
 399       -- Write_RF --
 400       --------------
 401
 402       procedure Write_RF (S : String) is
 403          Success    : Boolean            := True;
 404          Back_Slash : constant Character := '\';
 405
 406       begin
 407          --  If a GNU response file is used, space and backslash need to be
 408          --  escaped because they are interpreted as a string separator and
 409          --  an escape character respectively by the underlying mechanism.
 410          --  On the other hand, quote and double-quote are not escaped since
 411          --  they are interpreted as string delimiters on both sides.
 412
 413          if Using_GNU_response_file then
 414             for J in S'Range loop
 415                if S (J) = ' ' or else S (J) = '\' then
 416                   if Write (Tname_FD, Back_Slash'Address, 1) /= 1 then
 417                      Success := False;
 418                   end if;
 419                end if;
 420
 421                if Write (Tname_FD, S (J)'Address, 1) /= 1 then
 422                   Success := False;
 423                end if;
 424             end loop;
 425
 426          else
 427             if Write (Tname_FD, S'Address, S'Length) /= S'Length then
 428                Success := False;
 429             end if;
 430          end if;
 431
 432          if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then
 433             Success := False;
 434          end if;
 435
 436          if not Success then
 437             Fail ("cannot generate response file to link library: disk full");
 438          end if;
 439       end Write_RF;
 440
 441    --  Start of processing for Gcc
 442
 443    begin
 444       if Driver_Name = No_Name then
 445          if Gcc_Exec = null then
 446             if Gcc_Name = null then
 447                Gcc_Name := Osint.Program_Name ("gcc", "gnatmake");
 448             end if;
 449
 450             Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all);
 451
 452             if Gcc_Exec = null then
 453                Fail (Gcc_Name.all & " not found in path");
 454             end if;
 455          end if;
 456
 457          Driver := Gcc_Exec;
 458
 459       else
 460          Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name));
 461
 462          if Driver = null then
 463             Fail (Get_Name_String (Driver_Name) & " not found in path");
 464          end if;
 465       end if;
 466
 467       Link_Bytes := 0;
 468
 469       if Lib_Opt'Length /= 0 then
 470          A := A + 1;
 471          Arguments (A) := Lib_Opt;
 472          Link_Bytes := Link_Bytes + Lib_Opt'Length + 1;
 473       end if;
 474
 475       A := A + 1;
 476       Arguments (A) := Out_Opt;
 477       Link_Bytes := Link_Bytes + Out_Opt'Length + 1;
 478
 479       A := A + 1;
 480       Arguments (A) := Out_V;
 481       Link_Bytes := Link_Bytes + Out_V'Length + 1;
 482
 483       A := A + 1;
 484       Arguments (A) := Lib_Dir;
 485       Link_Bytes := Link_Bytes + Lib_Dir'Length + 1;
 486
 487       A := A + Options'Length;
 488       Arguments (A - Options'Length + 1 .. A) := Options;
 489
 490       for J in Options'Range loop
 491          Link_Bytes := Link_Bytes + Options (J)'Length + 1;
 492       end loop;
 493
 494       if not Opt.Quiet_Output then
 495          if Opt.Verbose_Mode then
 496             Write_Str (Driver.all);
 497
 498          elsif Driver_Name /= No_Name then
 499             Write_Str (Get_Name_String (Driver_Name));
 500
 501          else
 502             Write_Str (Gcc_Name.all);
 503          end if;
 504
 505          for J in 1 .. A loop
 506             if Opt.Verbose_Mode or else J < 4 then
 507                Write_Char (' ');
 508                Write_Str  (Arguments (J).all);
 509
 510             else
 511                Write_Str (" ...");
 512                exit;
 513             end if;
 514          end loop;
 515
 516          --  Do not display all the object files if not in verbose mode, only
 517          --  the first one.
 518
 519          Position := First;
 520          for J in Objects'Range loop
 521             if Opt.Verbose_Mode or else Position = First then
 522                Write_Char (' ');
 523                Write_Str (Objects (J).all);
 524                Position := Second;
 525
 526             elsif Position = Second then
 527                Write_Str (" ...");
 528                Position := Last;
 529                exit;
 530             end if;
 531          end loop;
 532
 533          for J in Options_2'Range loop
 534             if not Opt.Verbose_Mode then
 535                if Position = Second then
 536                   Write_Str (" ...");
 537                end if;
 538
 539                exit;
 540             end if;
 541
 542             Write_Char (' ');
 543             Write_Str (Options_2 (J).all);
 544          end loop;
 545
 546          Write_Eol;
 547       end if;
 548
 549       for J in Objects'Range loop
 550          Link_Bytes := Link_Bytes + Objects (J)'Length + 1;
 551       end loop;
 552
 553       for J in Options_2'Range loop
 554          Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1;
 555       end loop;
 556
 557       if Object_List_File_Supported and then Link_Bytes > Link_Max then
 558
 559          --  Create a temporary file containing the object files, one object
 560          --  file per line for maximal compatibility with linkers supporting
 561          --  this option.
 562
 563          Create_Temp_File (Tname_FD, Tname);
 564
 565          for J in Objects'Range loop
 566             Write_RF (Objects (J).all);
 567          end loop;
 568
 569          Close (Tname_FD, Closing_Status);
 570
 571          if not Closing_Status then
 572             Fail ("cannot generate response file to link library: disk full");
 573          end if;
 574
 575          A := A + 1;
 576          Arguments (A) := new String'(Object_File_Option & Tname.all);
 577
 578       else
 579          A := A + Objects'Length;
 580          Arguments (A - Objects'Length + 1 .. A) := Objects;
 581       end if;
 582
 583       A := A + Options_2'Length;
 584       Arguments (A - Options_2'Length + 1 .. A) := Options_2;
 585
 586       Spawn (Driver.all, Arguments (1 .. A), Success);
 587
 588       if Success then
 589          --  Delete the temporary file used in conjunction with linking
 590          --  if one was created.
 591
 592          if Tname_FD /= Invalid_FD then
 593             Delete_File (Tname.all);
 594          end if;
 595
 596       else
 597          if Driver_Name = No_Name then
 598             Fail (Gcc_Name.all & " execution error");
 599          else
 600             Fail (Get_Name_String (Driver_Name) & " execution error");
 601          end if;
 602       end if;
 603    end Gcc;
 604
 605    -------------------
 606    -- Lib_Directory --
 607    -------------------
 608
 609    function Lib_Directory return String is
 610       Libgnat : constant String := Tgt.Libgnat;
 611
 612    begin
 613       --  If procedure Specify_Adalib_Dir has been called, used the specified
 614       --  value.
 615
 616       if Adalib_Path /= null then
 617          return Adalib_Path.all;
 618       end if;
 619
 620       Name_Len := Libgnat'Length;
 621       Name_Buffer (1 .. Name_Len) := Libgnat;
 622       Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library));
 623
 624       --  Remove libgnat.a
 625
 626       return Name_Buffer (1 .. Name_Len - Libgnat'Length);
 627    end Lib_Directory;
 628
 629    ------------------------
 630    -- Specify_Adalib_Dir --
 631    ------------------------
 632
 633    procedure Specify_Adalib_Dir (Path : String) is
 634    begin
 635       if Path'Length = 0 then
 636          Adalib_Path := null;
 637       else
 638          Adalib_Path := new String'(Path);
 639       end if;
 640    end Specify_Adalib_Dir;
 641
 642 end MLib.Utl;