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