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