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