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