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-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 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
 286             for J in Ranlib_Options'Range loop
 287                Write_Str  (Ranlib_Options (J).all);
 288                Write_Char (' ');
 289             end loop;
 290
 291             Write_Line (Arguments (Ar_Options'Length + 1).all);
 292          end if;
 293
 294          Spawn
 295            (Ranlib_Exec.all,
 296             Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)),
 297             Success);
 298
 299          if not Success then
 300             Fail (Ranlib_Name.all & " execution error.");
 301          end if;
 302       end if;
 303    end Ar;
 304
 305    -----------------
 306    -- Delete_File --
 307    -----------------
 308
 309    procedure Delete_File (Filename : String) is
 310       File    : constant String := Filename & ASCII.NUL;
 311       Success : Boolean;
 312
 313    begin
 314       Delete_File (File'Address, Success);
 315
 316       if Opt.Verbose_Mode then
 317          if Success then
 318             Write_Str ("deleted ");
 319
 320          else
 321             Write_Str ("could not delete ");
 322          end if;
 323
 324          Write_Line (Filename);
 325       end if;
 326    end Delete_File;
 327
 328    ---------
 329    -- Gcc --
 330    ---------
 331
 332    procedure Gcc
 333      (Output_File : String;
 334       Objects     : Argument_List;
 335       Options     : Argument_List;
 336       Options_2   : Argument_List;
 337       Driver_Name : Name_Id := No_Name)
 338    is
 339       Link_Bytes : Integer := 0;
 340       --  Projected number of bytes for the linker command line
 341
 342       Link_Max : Integer;
 343       pragma Import (C, Link_Max, "__gnat_link_max");
 344       --  Maximum number of bytes on the command line supported by the OS
 345       --  linker. Passed this limit the response file mechanism must be used
 346       --  if supported.
 347
 348       Object_List_File_Supported : Boolean;
 349       for Object_List_File_Supported'Size use Character'Size;
 350       pragma Import
 351         (C, Object_List_File_Supported, "__gnat_objlist_file_supported");
 352       --  Predicate indicating whether the linker has an option whereby the
 353       --  names of object files can be passed to the linker in a file.
 354
 355       Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
 356       pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option");
 357       --  Pointer to a string representing the linker option which specifies
 358       --  the response file.
 359
 360       Object_File_Option : constant String := Value (Object_File_Option_Ptr);
 361       --  The linker option which specifies the response file as a string
 362
 363       Using_GNU_response_file : constant Boolean :=
 364                                   Object_File_Option'Length > 0
 365                                     and then
 366                                       Object_File_Option
 367                                         (Object_File_Option'Last) = '@';
 368       --  Whether a GNU response file is used
 369
 370       Tname    : String_Access;
 371       Tname_FD : File_Descriptor := Invalid_FD;
 372       --  Temporary file used by linker to pass list of object files on
 373       --  certain systems with limitations on size of arguments.
 374
 375       Closing_Status : Boolean;
 376       --  For call to Close
 377
 378       Arguments :
 379         Argument_List
 380           (1 .. 7 + Objects'Length + Options'Length + Options_2'Length);
 381
 382       A       : Natural := 0;
 383       Success : Boolean;
 384
 385       Out_Opt : constant String_Access := new String'("-o");
 386       Out_V   : constant String_Access := new String'(Output_File);
 387       Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory);
 388       Lib_Opt : constant String_Access := new String'(Dynamic_Option);
 389
 390       Driver : String_Access;
 391
 392       type Object_Position is (First, Second, Last);
 393
 394       Position : Object_Position;
 395
 396       procedure Write_RF (S : String);
 397       --  Write a string to the response file and check if it was successful.
 398       --  Fail the program if it was not successful (disk full).
 399
 400       --------------
 401       -- Write_RF --
 402       --------------
 403
 404       procedure Write_RF (S : String) is
 405          Success    : Boolean            := True;
 406          Back_Slash : constant Character := '\';
 407
 408       begin
 409          --  If a GNU response file is used, space and backslash need to be
 410          --  escaped because they are interpreted as a string separator and
 411          --  an escape character respectively by the underlying mechanism.
 412          --  On the other hand, quote and double-quote are not escaped since
 413          --  they are interpreted as string delimiters on both sides.
 414
 415          if Using_GNU_response_file then
 416             for J in S'Range loop
 417                if S (J) = ' ' or else S (J) = '\' then
 418                   if Write (Tname_FD, Back_Slash'Address, 1) /= 1 then
 419                      Success := False;
 420                   end if;
 421                end if;
 422
 423                if Write (Tname_FD, S (J)'Address, 1) /= 1 then
 424                   Success := False;
 425                end if;
 426             end loop;
 427
 428          else
 429             if Write (Tname_FD, S'Address, S'Length) /= S'Length then
 430                Success := False;
 431             end if;
 432          end if;
 433
 434          if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then
 435             Success := False;
 436          end if;
 437
 438          if not Success then
 439             Fail ("cannot generate response file to link library: disk full");
 440          end if;
 441       end Write_RF;
 442
 443    --  Start of processing for Gcc
 444
 445    begin
 446       if Driver_Name = No_Name then
 447          if Gcc_Exec = null then
 448             if Gcc_Name = null then
 449                Gcc_Name := Osint.Program_Name ("gcc", "gnatmake");
 450             end if;
 451
 452             Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all);
 453
 454             if Gcc_Exec = null then
 455                Fail (Gcc_Name.all & " not found in path");
 456             end if;
 457          end if;
 458
 459          Driver := Gcc_Exec;
 460
 461       else
 462          Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name));
 463
 464          if Driver = null then
 465             Fail (Get_Name_String (Driver_Name) & " not found in path");
 466          end if;
 467       end if;
 468
 469       Link_Bytes := 0;
 470
 471       if Lib_Opt'Length /= 0 then
 472          A := A + 1;
 473          Arguments (A) := Lib_Opt;
 474          Link_Bytes := Link_Bytes + Lib_Opt'Length + 1;
 475       end if;
 476
 477       A := A + 1;
 478       Arguments (A) := Out_Opt;
 479       Link_Bytes := Link_Bytes + Out_Opt'Length + 1;
 480
 481       A := A + 1;
 482       Arguments (A) := Out_V;
 483       Link_Bytes := Link_Bytes + Out_V'Length + 1;
 484
 485       A := A + 1;
 486       Arguments (A) := Lib_Dir;
 487       Link_Bytes := Link_Bytes + Lib_Dir'Length + 1;
 488
 489       A := A + Options'Length;
 490       Arguments (A - Options'Length + 1 .. A) := Options;
 491
 492       for J in Options'Range loop
 493          Link_Bytes := Link_Bytes + Options (J)'Length + 1;
 494       end loop;
 495
 496       if not Opt.Quiet_Output then
 497          if Opt.Verbose_Mode then
 498             Write_Str (Driver.all);
 499
 500          elsif Driver_Name /= No_Name then
 501             Write_Str (Get_Name_String (Driver_Name));
 502
 503          else
 504             Write_Str (Gcc_Name.all);
 505          end if;
 506
 507          for J in 1 .. A loop
 508             if Opt.Verbose_Mode or else J < 4 then
 509                Write_Char (' ');
 510                Write_Str  (Arguments (J).all);
 511
 512             else
 513                Write_Str (" ...");
 514                exit;
 515             end if;
 516          end loop;
 517
 518          --  Do not display all the object files if not in verbose mode, only
 519          --  the first one.
 520
 521          Position := First;
 522          for J in Objects'Range loop
 523             if Opt.Verbose_Mode or else Position = First then
 524                Write_Char (' ');
 525                Write_Str (Objects (J).all);
 526                Position := Second;
 527
 528             elsif Position = Second then
 529                Write_Str (" ...");
 530                Position := Last;
 531                exit;
 532             end if;
 533          end loop;
 534
 535          for J in Options_2'Range loop
 536             if not Opt.Verbose_Mode then
 537                if Position = Second then
 538                   Write_Str (" ...");
 539                end if;
 540
 541                exit;
 542             end if;
 543
 544             Write_Char (' ');
 545             Write_Str (Options_2 (J).all);
 546          end loop;
 547
 548          Write_Eol;
 549       end if;
 550
 551       for J in Objects'Range loop
 552          Link_Bytes := Link_Bytes + Objects (J)'Length + 1;
 553       end loop;
 554
 555       for J in Options_2'Range loop
 556          Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1;
 557       end loop;
 558
 559       if Object_List_File_Supported and then Link_Bytes > Link_Max then
 560
 561          --  Create a temporary file containing the object files, one object
 562          --  file per line for maximal compatibility with linkers supporting
 563          --  this option.
 564
 565          Create_Temp_File (Tname_FD, Tname);
 566
 567          for J in Objects'Range loop
 568             Write_RF (Objects (J).all);
 569          end loop;
 570
 571          Close (Tname_FD, Closing_Status);
 572
 573          if not Closing_Status then
 574             Fail ("cannot generate response file to link library: disk full");
 575          end if;
 576
 577          A := A + 1;
 578          Arguments (A) := new String'(Object_File_Option & Tname.all);
 579
 580       else
 581          A := A + Objects'Length;
 582          Arguments (A - Objects'Length + 1 .. A) := Objects;
 583       end if;
 584
 585       A := A + Options_2'Length;
 586       Arguments (A - Options_2'Length + 1 .. A) := Options_2;
 587
 588       Spawn (Driver.all, Arguments (1 .. A), Success);
 589
 590       if Success then
 591          --  Delete the temporary file used in conjunction with linking
 592          --  if one was created.
 593
 594          if Tname_FD /= Invalid_FD then
 595             Delete_File (Tname.all);
 596          end if;
 597
 598       else
 599          if Driver_Name = No_Name then
 600             Fail (Gcc_Name.all & " execution error");
 601          else
 602             Fail (Get_Name_String (Driver_Name) & " execution error");
 603          end if;
 604       end if;
 605    end Gcc;
 606
 607    -------------------
 608    -- Lib_Directory --
 609    -------------------
 610
 611    function Lib_Directory return String is
 612       Libgnat : constant String := Tgt.Libgnat;
 613
 614    begin
 615       --  If procedure Specify_Adalib_Dir has been called, used the specified
 616       --  value.
 617
 618       if Adalib_Path /= null then
 619          return Adalib_Path.all;
 620       end if;
 621
 622       Name_Len := Libgnat'Length;
 623       Name_Buffer (1 .. Name_Len) := Libgnat;
 624       Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library));
 625
 626       --  Remove libgnat.a
 627
 628       return Name_Buffer (1 .. Name_Len - Libgnat'Length);
 629    end Lib_Directory;
 630
 631    ------------------------
 632    -- Specify_Adalib_Dir --
 633    ------------------------
 634
 635    procedure Specify_Adalib_Dir (Path : String) is
 636    begin
 637       if Path'Length = 0 then
 638          Adalib_Path := null;
 639       else
 640          Adalib_Path := new String'(Path);
 641       end if;
 642    end Specify_Adalib_Dir;
 643
 644 end MLib.Utl;