gcc/ada/gnatlink.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             G N A T L I N K                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1996-2004 Free Software Foundation, Inc.          --
  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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 --  Gnatlink usage: please consult the gnat documentation
  28
  29 with ALI;      use ALI;
  30 with Gnatvsn;  use Gnatvsn;
  31 with Hostparm;
  32 with Namet;    use Namet;
  33 with Opt;
  34 with Osint;    use Osint;
  35 with Output;   use Output;
  36 with Switch;   use Switch;
  37 with System;   use System;
  38 with Table;
  39 with Types;
  40
  41 with Ada.Command_Line;     use Ada.Command_Line;
  42 with Ada.Exceptions;       use Ada.Exceptions;
  43 with GNAT.OS_Lib;          use GNAT.OS_Lib;
  44 with Interfaces.C_Streams; use Interfaces.C_Streams;
  45 with System.CRTL;
  46
  47 procedure Gnatlink is
  48    pragma Ident (Gnatvsn.Gnat_Static_Version_String);
  49
  50    package Gcc_Linker_Options is new Table.Table (
  51      Table_Component_Type => String_Access,
  52      Table_Index_Type     => Integer,
  53      Table_Low_Bound      => 1,
  54      Table_Initial        => 20,
  55      Table_Increment      => 100,
  56      Table_Name           => "Gnatlink.Gcc_Linker_Options");
  57    --  Comments needed ???
  58
  59    package Libpath is new Table.Table (
  60      Table_Component_Type => Character,
  61      Table_Index_Type     => Integer,
  62      Table_Low_Bound      => 1,
  63      Table_Initial        => 4096,
  64      Table_Increment      => 2,
  65      Table_Name           => "Gnatlink.Libpath");
  66    --  Comments needed ???
  67
  68    package Linker_Options is new Table.Table (
  69      Table_Component_Type => String_Access,
  70      Table_Index_Type     => Integer,
  71      Table_Low_Bound      => 1,
  72      Table_Initial        => 20,
  73      Table_Increment      => 100,
  74      Table_Name           => "Gnatlink.Linker_Options");
  75    --  Comments needed ???
  76
  77    package Linker_Objects is new Table.Table (
  78      Table_Component_Type => String_Access,
  79      Table_Index_Type     => Integer,
  80      Table_Low_Bound      => 1,
  81      Table_Initial        => 20,
  82      Table_Increment      => 100,
  83      Table_Name           => "Gnatlink.Linker_Objects");
  84    --  This table collects the objects file to be passed to the linker. In the
  85    --  case where the linker command line is too long then programs objects
  86    --  are put on the Response_File_Objects table. Note that the binder object
  87    --  file and the user's objects remain in this table. This is very
  88    --  important because on the GNU linker command line the -L switch is not
  89    --  used to look for objects files but -L switch is used to look for
  90    --  objects listed in the response file. This is not a problem with the
  91    --  applications objects as they are specified with a fullname.
  92
  93    package Response_File_Objects is new Table.Table (
  94      Table_Component_Type => String_Access,
  95      Table_Index_Type     => Integer,
  96      Table_Low_Bound      => 1,
  97      Table_Initial        => 20,
  98      Table_Increment      => 100,
  99      Table_Name           => "Gnatlink.Response_File_Objects");
 100    --  This table collects the objects file that are to be put in the response
 101    --  file. Only application objects are collected there (see details in
 102    --  Linker_Objects table comments)
 103
 104    package Binder_Options_From_ALI is new Table.Table (
 105      Table_Component_Type => String_Access,
 106      Table_Index_Type     => Integer,
 107      Table_Low_Bound      => 1, -- equals low bound of Argument_List for Spawn
 108      Table_Initial        => 20,
 109      Table_Increment      => 100,
 110      Table_Name           => "Gnatlink.Binder_Options_From_ALI");
 111    --  This table collects the switches from the ALI file of the main
 112    --  subprogram.
 113
 114    package Binder_Options is new Table.Table (
 115      Table_Component_Type => String_Access,
 116      Table_Index_Type     => Integer,
 117      Table_Low_Bound      => 1, -- equals low bound of Argument_List for Spawn
 118      Table_Initial        => 20,
 119      Table_Increment      => 100,
 120      Table_Name           => "Gnatlink.Binder_Options");
 121    --  This table collects the arguments to be passed to compile the binder
 122    --  generated file.
 123
 124    subtype chars_ptr is System.Address;
 125
 126    Gcc : String_Access := Program_Name ("gcc");
 127
 128    Read_Mode  : constant String := "r" & ASCII.Nul;
 129
 130    Begin_Info : String := "--  BEGIN Object file/option list";
 131    End_Info   : String := "--  END Object file/option list   ";
 132    --  Note: above lines are modified in C mode, see option processing
 133
 134    Gcc_Path             : String_Access;
 135    Linker_Path          : String_Access;
 136
 137    Output_File_Name     : String_Access;
 138    Ali_File_Name        : String_Access;
 139    Binder_Spec_Src_File : String_Access;
 140    Binder_Body_Src_File : String_Access;
 141    Binder_Ali_File      : String_Access;
 142    Binder_Obj_File      : String_Access;
 143
 144    Tname    : Temp_File_Name;
 145    Tname_FD : File_Descriptor := Invalid_FD;
 146    --  Temporary file used by linker to pass list of object files on
 147    --  certain systems with limitations on size of arguments.
 148
 149    Debug_Flag_Present : Boolean := False;
 150    Verbose_Mode       : Boolean := False;
 151    Very_Verbose_Mode  : Boolean := False;
 152
 153    Ada_Bind_File : Boolean := True;
 154    --  Set to True if bind file is generated in Ada
 155
 156    Standard_Gcc  : Boolean := True;
 157
 158    Compile_Bind_File : Boolean := True;
 159    --  Set to False if bind file is not to be compiled
 160
 161    Object_List_File_Supported : Boolean;
 162    pragma Import (C, Object_List_File_Supported, "objlist_file_supported");
 163    --  Predicate indicating whether the linker has an option whereby the
 164    --  names of object files can be passed to the linker in a file.
 165
 166    Object_List_File_Required : Boolean := False;
 167    --  Set to True to force generation of a response file
 168
 169    function Base_Name (File_Name : in String) return String;
 170    --  Return just the file name part without the extension (if present).
 171
 172    procedure Delete (Name : in String);
 173    --  Wrapper to unlink as status is ignored by this application.
 174
 175    procedure Error_Msg (Message : in String);
 176    --  Output the error or warning Message
 177
 178    procedure Exit_With_Error (Error : in String);
 179    --  Output Error and exit program with a fatal condition.
 180
 181    procedure Process_Args;
 182    --  Go through all the arguments and build option tables.
 183
 184    procedure Process_Binder_File (Name : in String);
 185    --  Reads the binder file and extracts linker arguments.
 186
 187    function Value (chars : chars_ptr) return String;
 188    --  Return NUL-terminated string chars as an Ada string.
 189
 190    procedure Write_Header;
 191    --  Show user the program name, version and copyright.
 192
 193    procedure Write_Usage;
 194    --  Show user the program options.
 195
 196    ---------------
 197    -- Base_Name --
 198    ---------------
 199
 200    function Base_Name (File_Name : in String) return String is
 201       Findex1 : Natural;
 202       Findex2 : Natural;
 203
 204    begin
 205       Findex1 := File_Name'First;
 206
 207       --  The file might be specified by a full path name. However,
 208       --  we want the path to be stripped away.
 209
 210       for J in reverse File_Name'Range loop
 211          if Is_Directory_Separator (File_Name (J)) then
 212             Findex1 := J + 1;
 213             exit;
 214          end if;
 215       end loop;
 216
 217       Findex2 := File_Name'Last;
 218       while Findex2 > Findex1
 219         and then File_Name (Findex2) /=  '.'
 220       loop
 221          Findex2 := Findex2 - 1;
 222       end loop;
 223
 224       if Findex2 = Findex1 then
 225          Findex2 := File_Name'Last + 1;
 226       end if;
 227
 228       return File_Name (Findex1 .. Findex2 - 1);
 229    end Base_Name;
 230
 231    ------------
 232    -- Delete --
 233    ------------
 234
 235    procedure Delete (Name : in String) is
 236       Status : int;
 237       pragma Unreferenced (Status);
 238    begin
 239       Status := unlink (Name'Address);
 240       --  Is it really right to ignore an error here ???
 241    end Delete;
 242
 243    ---------------
 244    -- Error_Msg --
 245    ---------------
 246
 247    procedure Error_Msg (Message : in String) is
 248    begin
 249       Write_Str (Base_Name (Command_Name));
 250       Write_Str (": ");
 251       Write_Str (Message);
 252       Write_Eol;
 253    end Error_Msg;
 254
 255    ---------------------
 256    -- Exit_With_Error --
 257    ---------------------
 258
 259    procedure Exit_With_Error (Error : in String) is
 260    begin
 261       Error_Msg (Error);
 262       Exit_Program (E_Fatal);
 263    end Exit_With_Error;
 264
 265    ------------------
 266    -- Process_Args --
 267    ------------------
 268
 269    procedure Process_Args is
 270       Next_Arg  : Integer;
 271       Skip_Next : Boolean := False;
 272       --  Set to true if the next argument is to be added into the list of
 273       --  linker's argument without parsing it.
 274
 275    begin
 276       --  Loop through arguments of gnatlink command
 277
 278       Next_Arg := 1;
 279       loop
 280          exit when Next_Arg > Argument_Count;
 281
 282          Process_One_Arg : declare
 283             Arg : constant String := Argument (Next_Arg);
 284
 285          begin
 286             --  Case of argument which is a switch
 287
 288             --  We definitely need section by section comments here ???
 289
 290             if Skip_Next then
 291
 292                --  This argument must not be parsed, just add it to the
 293                --  list of linker's options.
 294
 295                Skip_Next := False;
 296
 297                Linker_Options.Increment_Last;
 298                Linker_Options.Table (Linker_Options.Last) :=
 299                  new String'(Arg);
 300
 301             elsif Arg'Length /= 0 and then Arg (1) = '-' then
 302                if Arg'Length > 4
 303                  and then Arg (2 .. 5) =  "gnat"
 304                then
 305                   Exit_With_Error
 306                     ("invalid switch: """ & Arg & """ (gnat not needed here)");
 307                end if;
 308
 309                if Arg = "-Xlinker" then
 310
 311                   --  Next argument should be sent directly to the linker.
 312                   --  We do not want to parse it here.
 313
 314                   Skip_Next := True;
 315
 316                   Linker_Options.Increment_Last;
 317                   Linker_Options.Table (Linker_Options.Last) :=
 318                     new String'(Arg);
 319
 320                elsif Arg (2) = 'g'
 321                  and then (Arg'Length < 5 or else Arg (2 .. 5) /= "gnat")
 322                then
 323                   Debug_Flag_Present := True;
 324
 325                   Linker_Options.Increment_Last;
 326                   Linker_Options.Table (Linker_Options.Last) :=
 327                    new String'(Arg);
 328
 329                   Binder_Options.Increment_Last;
 330                   Binder_Options.Table (Binder_Options.Last) :=
 331                     Linker_Options.Table (Linker_Options.Last);
 332
 333                elsif Arg'Length = 2 then
 334                   case Arg (2) is
 335                      when 'A' =>
 336                         Ada_Bind_File := True;
 337                         Begin_Info := "--  BEGIN Object file/option list";
 338                         End_Info   := "--  END Object file/option list   ";
 339
 340                      when 'b' =>
 341                         Linker_Options.Increment_Last;
 342                         Linker_Options.Table (Linker_Options.Last) :=
 343                           new String'(Arg);
 344
 345                         Binder_Options.Increment_Last;
 346                         Binder_Options.Table (Binder_Options.Last) :=
 347                           Linker_Options.Table (Linker_Options.Last);
 348
 349                         Next_Arg := Next_Arg + 1;
 350
 351                         if Next_Arg > Argument_Count then
 352                            Exit_With_Error ("Missing argument for -b");
 353                         end if;
 354
 355                         Get_Machine_Name : declare
 356                            Name_Arg : constant String_Access :=
 357                                         new String'(Argument (Next_Arg));
 358
 359                         begin
 360                            Linker_Options.Increment_Last;
 361                            Linker_Options.Table (Linker_Options.Last) :=
 362                              Name_Arg;
 363
 364                            Binder_Options.Increment_Last;
 365                            Binder_Options.Table (Binder_Options.Last) :=
 366                              Name_Arg;
 367
 368                         end Get_Machine_Name;
 369
 370                      when 'C' =>
 371                         Ada_Bind_File := False;
 372                         Begin_Info := "/*  BEGIN Object file/option list";
 373                         End_Info   := "    END Object file/option list */";
 374
 375                      when 'f' =>
 376                         if Object_List_File_Supported then
 377                            Object_List_File_Required := True;
 378                         else
 379                            Exit_With_Error
 380                              ("Object list file not supported on this target");
 381                         end if;
 382
 383                      when 'n' =>
 384                         Compile_Bind_File := False;
 385
 386                      when 'o' =>
 387                         Linker_Options.Increment_Last;
 388                         Linker_Options.Table (Linker_Options.Last) :=
 389                          new String'(Arg);
 390
 391                         Next_Arg := Next_Arg + 1;
 392
 393                         if Next_Arg > Argument_Count then
 394                            Exit_With_Error ("Missing argument for -o");
 395                         end if;
 396
 397                         Output_File_Name := new String'(Argument (Next_Arg));
 398
 399                         Linker_Options.Increment_Last;
 400                         Linker_Options.Table (Linker_Options.Last) :=
 401                           Output_File_Name;
 402
 403                      when 'R' =>
 404                         Opt.Run_Path_Option := False;
 405
 406                      when 'v' =>
 407
 408                         --  Support "double" verbose mode.  Second -v
 409                         --  gets sent to the linker and binder phases.
 410
 411                         if Verbose_Mode then
 412                            Very_Verbose_Mode := True;
 413
 414                            Linker_Options.Increment_Last;
 415                            Linker_Options.Table (Linker_Options.Last) :=
 416                             new String'(Arg);
 417
 418                            Binder_Options.Increment_Last;
 419                            Binder_Options.Table (Binder_Options.Last) :=
 420                              Linker_Options.Table (Linker_Options.Last);
 421
 422                         else
 423                            Verbose_Mode := True;
 424
 425                         end if;
 426
 427                      when others =>
 428                         Linker_Options.Increment_Last;
 429                         Linker_Options.Table (Linker_Options.Last) :=
 430                          new String'(Arg);
 431
 432                   end case;
 433
 434                elsif Arg (2) = 'B' then
 435                   Linker_Options.Increment_Last;
 436                   Linker_Options.Table (Linker_Options.Last) :=
 437                     new String'(Arg);
 438
 439                   Binder_Options.Increment_Last;
 440                   Binder_Options.Table (Binder_Options.Last) :=
 441                     Linker_Options.Table (Linker_Options.Last);
 442
 443                elsif Arg'Length >= 7 and then Arg (1 .. 7) = "--LINK=" then
 444
 445                   if Arg'Length = 7 then
 446                      Exit_With_Error ("Missing argument for --LINK=");
 447                   end if;
 448
 449                   Linker_Path :=
 450                     GNAT.OS_Lib.Locate_Exec_On_Path (Arg (8 .. Arg'Last));
 451
 452                   if Linker_Path = null then
 453                      Exit_With_Error
 454                        ("Could not locate linker: " & Arg (8 .. Arg'Last));
 455                   end if;
 456
 457                elsif Arg'Length > 6 and then Arg (1 .. 6) = "--GCC=" then
 458                   declare
 459                      Program_Args : constant Argument_List_Access :=
 460                                       Argument_String_To_List
 461                                                  (Arg (7 .. Arg'Last));
 462
 463                   begin
 464                      Gcc := new String'(Program_Args.all (1).all);
 465                      Standard_Gcc := False;
 466
 467                      --  Set appropriate flags for switches passed
 468
 469                      for J in 2 .. Program_Args.all'Last loop
 470                         declare
 471                            Arg : constant String := Program_Args.all (J).all;
 472                            AF  : constant Integer := Arg'First;
 473
 474                         begin
 475                            if Arg'Length /= 0 and then Arg (AF) = '-' then
 476                               if Arg (AF + 1) = 'g'
 477                                 and then (Arg'Length = 2
 478                                   or else Arg (AF + 2) in '0' .. '3'
 479                                   or else Arg (AF + 2 .. Arg'Last) = "coff")
 480                               then
 481                                  Debug_Flag_Present := True;
 482                               end if;
 483                            end if;
 484
 485                            --  Pass to gcc for compiling binder generated file
 486                            --  No use passing libraries, it will just generate
 487                            --  a warning
 488
 489                            if not (Arg (AF .. AF + 1) = "-l"
 490                              or else Arg (AF .. AF + 1) = "-L")
 491                            then
 492                               Binder_Options.Increment_Last;
 493                               Binder_Options.Table (Binder_Options.Last) :=
 494                                 new String'(Arg);
 495                            end if;
 496
 497                            --  Pass to gcc for linking program.
 498
 499                            Gcc_Linker_Options.Increment_Last;
 500                            Gcc_Linker_Options.Table
 501                              (Gcc_Linker_Options.Last) := new String'(Arg);
 502                         end;
 503                      end loop;
 504                   end;
 505
 506                --  Send all multi-character switches not recognized as
 507                --  a special case by gnatlink to the linker/loader stage.
 508
 509                else
 510                   Linker_Options.Increment_Last;
 511                   Linker_Options.Table (Linker_Options.Last) :=
 512                     new String'(Arg);
 513                end if;
 514
 515             --  Here if argument is a file name rather than a switch
 516
 517             else
 518                --  If explicit ali file, capture it
 519
 520                if Arg'Length > 4
 521                  and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
 522                then
 523                   if Ali_File_Name = null then
 524                      Ali_File_Name := new String'(Arg);
 525                   else
 526                      Exit_With_Error ("cannot handle more than one ALI file");
 527                   end if;
 528
 529                --  If object file, record object file
 530
 531                elsif Arg'Length > Get_Object_Suffix.all'Length
 532                  and then Arg
 533                    (Arg'Last - Get_Object_Suffix.all'Length + 1 .. Arg'Last)
 534                                                 = Get_Object_Suffix.all
 535                then
 536                   Linker_Objects.Increment_Last;
 537                   Linker_Objects.Table (Linker_Objects.Last) :=
 538                     new String'(Arg);
 539
 540                --  If corresponding ali file exists, capture it
 541
 542                elsif Ali_File_Name = null
 543                  and then Is_Regular_File (Arg & ".ali")
 544                then
 545                   Ali_File_Name := new String'(Arg & ".ali");
 546
 547                --  Otherwise assume this is a linker options entry, but
 548                --  see below for interesting adjustment to this assumption.
 549
 550                else
 551                   Linker_Options.Increment_Last;
 552                   Linker_Options.Table (Linker_Options.Last) :=
 553                     new String'(Arg);
 554                end if;
 555             end if;
 556          end Process_One_Arg;
 557
 558          Next_Arg := Next_Arg + 1;
 559       end loop;
 560
 561       --  If Ada bind file, then compile it with warnings suppressed, because
 562       --  otherwise the with of the main program may cause junk warnings.
 563
 564       if Ada_Bind_File then
 565          Binder_Options.Increment_Last;
 566          Binder_Options.Table (Binder_Options.Last) := new String'("-gnatws");
 567       end if;
 568
 569       --  If we did not get an ali file at all, and we had at least one
 570       --  linker option, then assume that was the intended ali file after
 571       --  all, so that we get a nicer message later on.
 572
 573       if Ali_File_Name = null
 574         and then Linker_Options.Last >= Linker_Options.First
 575       then
 576          Ali_File_Name :=
 577            new String'(Linker_Options.Table (Linker_Options.First).all &
 578                                                                    ".ali");
 579       end if;
 580    end Process_Args;
 581
 582    -------------------------
 583    -- Process_Binder_File --
 584    -------------------------
 585
 586    procedure Process_Binder_File (Name : in String) is
 587       Fd : FILEs;
 588       --  Binder file's descriptor
 589
 590       Link_Bytes : Integer := 0;
 591       --  Projected number of bytes for the linker command line
 592
 593       Link_Max : Integer;
 594       pragma Import (C, Link_Max, "link_max");
 595       --  Maximum number of bytes on the command line supported by the OS
 596       --  linker. Passed this limit the response file mechanism must be used
 597       --  if supported.
 598
 599       Next_Line : String (1 .. 1000);
 600       --  Current line value
 601
 602       Nlast  : Integer;
 603       Nfirst : Integer;
 604       --  Current line slice (the slice does not contain line terminator)
 605
 606       Last : Integer;
 607       --  Current line last character for shared libraries (without version)
 608
 609       Objs_Begin : Integer := 0;
 610       --  First object file index in Linker_Objects table
 611
 612       Objs_End : Integer := 0;
 613       --  Last object file index in Linker_Objects table
 614
 615       Status : int;
 616       --  Used for various Interfaces.C_Streams calls
 617
 618       Closing_Status : Boolean;
 619       --  For call to Close
 620
 621       GNAT_Static : Boolean := False;
 622       --  Save state of -static option.
 623
 624       GNAT_Shared : Boolean := False;
 625       --  Save state of -shared option.
 626
 627       Xlinker_Was_Previous : Boolean := False;
 628       --  Indicate that "-Xlinker" was the option preceding the current
 629       --  option. If True, then the current option is never suppressed.
 630
 631       --  Rollback data
 632
 633       --  These data items are used to store current binder file context.
 634       --  The context is composed of the file descriptor position and the
 635       --  current line together with the slice indexes (first and last
 636       --  position) for this line. The rollback data are used by the
 637       --  Store_File_Context and Rollback_File_Context routines below.
 638       --  The file context mechanism interact only with the Get_Next_Line
 639       --  call. For example:
 640
 641       --     Store_File_Context;
 642       --     Get_Next_Line;
 643       --     Rollback_File_Context;
 644       --     Get_Next_Line;
 645
 646       --  Both Get_Next_Line calls above will read the exact same data from
 647       --  the file. In other words, Next_Line, Nfirst and Nlast variables
 648       --  will be set with the exact same values.
 649
 650       RB_File_Pos  : long;                -- File position
 651       RB_Next_Line : String (1 .. 1000);  -- Current line content
 652       RB_Nlast     : Integer;             -- Slice last index
 653       RB_Nfirst    : Integer;             -- Slice first index
 654
 655       Run_Path_Option_Ptr : Address;
 656       pragma Import (C, Run_Path_Option_Ptr, "run_path_option");
 657       --  Pointer to string representing the native linker option which
 658       --  specifies the path where the dynamic loader should find shared
 659       --  libraries. Equal to null string if this system doesn't support it.
 660
 661       Object_Library_Ext_Ptr : Address;
 662       pragma Import (C, Object_Library_Ext_Ptr, "object_library_extension");
 663       --  Pointer to string specifying the default extension for
 664       --  object libraries, e.g. Unix uses ".a", VMS uses ".olb".
 665
 666       Object_File_Option_Ptr : Address;
 667       pragma Import (C, Object_File_Option_Ptr, "object_file_option");
 668       --  Pointer to a string representing the linker option which specifies
 669       --  the response file.
 670
 671       Using_GNU_Linker : Boolean;
 672       pragma Import (C, Using_GNU_Linker, "using_gnu_linker");
 673       --  Predicate indicating whether this target uses the GNU linker. In
 674       --  this case we must output a GNU linker compatible response file.
 675
 676       procedure Get_Next_Line;
 677       --  Read the next line from the binder file without the line
 678       --  terminator.
 679
 680       function Index (S, Pattern : String) return Natural;
 681       --  Return the first occurrence of Pattern in S, or 0 if none.
 682
 683       function Is_Option_Present (Opt : in String) return Boolean;
 684       --  Return true if the option Opt is already present in
 685       --  Linker_Options table.
 686
 687       procedure Store_File_Context;
 688       --  Store current file context, Fd position and current line data.
 689       --  The file context is stored into the rollback data above (RB_*).
 690       --  Store_File_Context can be called at any time, only the last call
 691       --  will be used (i.e. this routine overwrites the file context).
 692
 693       procedure Rollback_File_Context;
 694       --  Restore file context from rollback data. This routine must be called
 695       --  after Store_File_Context. The binder file context will be restored
 696       --  with the data stored by the last Store_File_Context call.
 697
 698       -------------------
 699       -- Get_Next_Line --
 700       -------------------
 701
 702       procedure Get_Next_Line is
 703          Fchars : chars;
 704
 705       begin
 706          Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd);
 707
 708          if Fchars = System.Null_Address then
 709             Exit_With_Error ("Error reading binder output");
 710          end if;
 711
 712          Nfirst := Next_Line'First;
 713          Nlast := Nfirst;
 714          while Nlast <= Next_Line'Last
 715            and then Next_Line (Nlast) /= ASCII.LF
 716            and then Next_Line (Nlast) /= ASCII.CR
 717          loop
 718             Nlast := Nlast + 1;
 719          end loop;
 720
 721          Nlast := Nlast - 1;
 722       end Get_Next_Line;
 723
 724       -----------
 725       -- Index --
 726       -----------
 727
 728       function Index (S, Pattern : String) return Natural is
 729          Len : constant Natural := Pattern'Length;
 730       begin
 731          for J in S'First .. S'Last - Len + 1 loop
 732             if Pattern = S (J .. J + Len - 1) then
 733                return J;
 734             end if;
 735          end loop;
 736
 737          return 0;
 738       end Index;
 739
 740       -----------------------
 741       -- Is_Option_Present --
 742       -----------------------
 743
 744       function Is_Option_Present (Opt : in String) return Boolean is
 745       begin
 746          for I in 1 .. Linker_Options.Last loop
 747
 748             if Linker_Options.Table (I).all = Opt then
 749                return True;
 750             end if;
 751
 752          end loop;
 753
 754          return False;
 755       end Is_Option_Present;
 756
 757       ---------------------------
 758       -- Rollback_File_Context --
 759       ---------------------------
 760
 761       procedure Rollback_File_Context is
 762       begin
 763          Next_Line := RB_Next_Line;
 764          Nfirst    := RB_Nfirst;
 765          Nlast     := RB_Nlast;
 766          Status    := fseek (Fd, RB_File_Pos, Interfaces.C_Streams.SEEK_SET);
 767
 768          if Status = -1 then
 769             Exit_With_Error ("Error setting file position");
 770          end if;
 771       end Rollback_File_Context;
 772
 773       ------------------------
 774       -- Store_File_Context --
 775       ------------------------
 776
 777       procedure Store_File_Context is
 778          use type System.CRTL.long;
 779       begin
 780          RB_Next_Line := Next_Line;
 781          RB_Nfirst    := Nfirst;
 782          RB_Nlast     := Nlast;
 783          RB_File_Pos  := ftell (Fd);
 784
 785          if RB_File_Pos = -1 then
 786             Exit_With_Error ("Error getting file position");
 787          end if;
 788       end Store_File_Context;
 789
 790    --  Start of processing for Process_Binder_File
 791
 792    begin
 793       Fd := fopen (Name'Address, Read_Mode'Address);
 794
 795       if Fd = NULL_Stream then
 796          Exit_With_Error ("Failed to open binder output");
 797       end if;
 798
 799       --  Skip up to the Begin Info line
 800
 801       loop
 802          Get_Next_Line;
 803          exit when Next_Line (Nfirst .. Nlast) = Begin_Info;
 804       end loop;
 805
 806       loop
 807          Get_Next_Line;
 808
 809          --  Go to end when end line is reached (this will happen in
 810          --  High_Integrity_Mode where no -L switches are generated)
 811
 812          exit when Next_Line (Nfirst .. Nlast) = End_Info;
 813
 814          if Ada_Bind_File then
 815             Next_Line (Nfirst .. Nlast - 8) :=
 816               Next_Line (Nfirst + 8 .. Nlast);
 817             Nlast := Nlast - 8;
 818          end if;
 819
 820          --  Go to next section when switches are reached
 821
 822          exit when Next_Line (1) = '-';
 823
 824          --  Otherwise we have another object file to collect
 825
 826          Linker_Objects.Increment_Last;
 827
 828          --  Mark the positions of first and last object files in case
 829          --  they need to be placed with a named file on systems having
 830          --  linker line limitations.
 831
 832          if Objs_Begin = 0 then
 833             Objs_Begin := Linker_Objects.Last;
 834          end if;
 835
 836          Linker_Objects.Table (Linker_Objects.Last) :=
 837            new String'(Next_Line (Nfirst .. Nlast));
 838
 839          Link_Bytes := Link_Bytes + Nlast - Nfirst + 2;
 840          --  Nlast - Nfirst + 1, for the size, plus one for the space between
 841          --  each arguments.
 842       end loop;
 843
 844       Objs_End := Linker_Objects.Last;
 845
 846       --  Let's continue to compute the Link_Bytes, the linker options are
 847       --  part of command line length.
 848
 849       Store_File_Context;
 850
 851       while Next_Line (Nfirst .. Nlast) /= End_Info loop
 852          Link_Bytes := Link_Bytes + Nlast - Nfirst + 2;
 853          --  See comment above
 854          Get_Next_Line;
 855       end loop;
 856
 857       Rollback_File_Context;
 858
 859       --  On systems that have limitations on handling very long linker lines
 860       --  we make use of the system linker option which takes a list of object
 861       --  file names from a file instead of the command line itself. What we do
 862       --  is to replace the list of object files by the special linker option
 863       --  which then reads the object file list from a file instead. The option
 864       --  to read from a file instead of the command line is only triggered if
 865       --  a conservative threshold is passed.
 866
 867       if Object_List_File_Required
 868         or else (Object_List_File_Supported
 869                    and then Link_Bytes > Link_Max)
 870       then
 871          --  Create a temporary file containing the Ada user object files
 872          --  needed by the link. This list is taken from the bind file
 873          --  and is output one object per line for maximal compatibility with
 874          --  linkers supporting this option.
 875
 876          Create_Temp_File (Tname_FD, Tname);
 877
 878          --  ??? File descriptor should be checked to not be Invalid_FD.
 879          --  ??? Status of Write and Close operations should be checked, and
 880          --  failure should occur if a status is wrong.
 881
 882          --  If target is using the GNU linker we must add a special header
 883          --  and footer in the response file.
 884          --  The syntax is : INPUT (object1.o object2.o ... )
 885
 886          if Using_GNU_Linker then
 887             declare
 888                GNU_Header : aliased constant String := "INPUT (";
 889
 890             begin
 891                Status := Write (Tname_FD, GNU_Header'Address,
 892                  GNU_Header'Length);
 893             end;
 894          end if;
 895
 896          for J in Objs_Begin .. Objs_End loop
 897             Status := Write (Tname_FD, Linker_Objects.Table (J).all'Address,
 898               Linker_Objects.Table (J).all'Length);
 899             Status := Write (Tname_FD, ASCII.LF'Address, 1);
 900
 901             Response_File_Objects.Increment_Last;
 902             Response_File_Objects.Table (Response_File_Objects.Last) :=
 903               Linker_Objects.Table (J);
 904          end loop;
 905
 906          --  handle GNU linker response file footer.
 907
 908          if Using_GNU_Linker then
 909             declare
 910                GNU_Footer : aliased constant String := ")";
 911
 912             begin
 913                Status := Write (Tname_FD, GNU_Footer'Address,
 914                  GNU_Footer'Length);
 915             end;
 916          end if;
 917
 918          Close (Tname_FD, Closing_Status);
 919
 920          --  Add the special objects list file option together with the name
 921          --  of the temporary file (removing the null character) to the objects
 922          --  file table.
 923
 924          Linker_Objects.Table (Objs_Begin) :=
 925            new String'(Value (Object_File_Option_Ptr) &
 926                        Tname (Tname'First .. Tname'Last - 1));
 927
 928          --  The slots containing these object file names are then removed
 929          --  from the objects table so they do not appear in the link. They
 930          --  are removed by moving up the linker options and non-Ada object
 931          --  files appearing after the Ada object list in the table.
 932
 933          declare
 934             N : Integer;
 935          begin
 936             N := Objs_End - Objs_Begin + 1;
 937
 938             for J in Objs_End + 1 .. Linker_Objects.Last loop
 939                Linker_Objects.Table (J - N + 1) := Linker_Objects.Table (J);
 940             end loop;
 941
 942             Linker_Objects.Set_Last (Linker_Objects.Last - N + 1);
 943          end;
 944       end if;
 945
 946       --  Process switches and options
 947
 948       if Next_Line (Nfirst .. Nlast) /= End_Info then
 949          Xlinker_Was_Previous := False;
 950
 951          loop
 952             if Xlinker_Was_Previous
 953               or else Next_Line (Nfirst .. Nlast) = "-Xlinker"
 954             then
 955                Linker_Options.Increment_Last;
 956                Linker_Options.Table (Linker_Options.Last) :=
 957                  new String'(Next_Line (Nfirst .. Nlast));
 958
 959             elsif Next_Line (Nfirst .. Nlast) = "-static" then
 960                GNAT_Static := True;
 961
 962             elsif Next_Line (Nfirst .. Nlast) = "-shared" then
 963                GNAT_Shared := True;
 964
 965             --  Add binder options only if not already set on the command
 966             --  line. This rule is a way to control the linker options order.
 967
 968             elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then
 969                if Nlast > Nfirst + 2 and then
 970                  Next_Line (Nfirst .. Nfirst + 1) = "-L"
 971                then
 972                   --  Construct a library search path for use later
 973                   --  to locate static gnatlib libraries.
 974
 975                   if Libpath.Last > 1 then
 976                      Libpath.Increment_Last;
 977                      Libpath.Table (Libpath.Last) := Path_Separator;
 978                   end if;
 979
 980                   for I in Nfirst + 2 .. Nlast loop
 981                      Libpath.Increment_Last;
 982                      Libpath.Table (Libpath.Last) := Next_Line (I);
 983                   end loop;
 984
 985                   Linker_Options.Increment_Last;
 986
 987                   Linker_Options.Table (Linker_Options.Last) :=
 988                     new String'(Next_Line (Nfirst .. Nlast));
 989
 990                elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat"
 991                  or else Next_Line (Nfirst .. Nlast) = "-lgnarl"
 992                  or else Next_Line (Nfirst .. Nlast) = "-lgnat"
 993                  or else Next_Line
 994                      (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) =
 995                        Shared_Lib ("gnarl")
 996                  or else Next_Line
 997                      (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) =
 998                        Shared_Lib ("gnat")
 999                then
1000                   --  If it is a shared library, remove the library version.
1001                   --  We will be looking for the static version of the library
1002                   --  as it is in the same directory as the shared version.
1003
1004                   if Next_Line (Nlast - Library_Version'Length + 1 .. Nlast)
1005                        = Library_Version
1006                   then
1007                      --  Set Last to point to last character before the
1008                      --  library version.
1009
1010                      Last := Nlast - Library_Version'Length - 1;
1011                   else
1012                      Last := Nlast;
1013                   end if;
1014
1015                   --  Given a Gnat standard library, search the
1016                   --  library path to find the library location
1017
1018                   declare
1019                      File_Path : String_Access;
1020
1021                      Object_Lib_Extension : constant String :=
1022                                               Value (Object_Library_Ext_Ptr);
1023
1024                      File_Name : constant String := "lib" &
1025                                    Next_Line (Nfirst + 2 .. Last) &
1026                                    Object_Lib_Extension;
1027
1028                      Run_Path_Opt : constant String :=
1029                        Value (Run_Path_Option_Ptr);
1030
1031                      GCC_Index          : Natural;
1032                      Run_Path_Opt_Index : Natural := 0;
1033
1034                   begin
1035                      File_Path :=
1036                        Locate_Regular_File (File_Name,
1037                          String (Libpath.Table (1 .. Libpath.Last)));
1038
1039                      if File_Path /= null then
1040                         if GNAT_Static then
1041
1042                            --  If static gnatlib found, explicitly
1043                            --  specify to overcome possible linker
1044                            --  default usage of shared version.
1045
1046                            Linker_Options.Increment_Last;
1047
1048                            Linker_Options.Table (Linker_Options.Last) :=
1049                              new String'(File_Path.all);
1050
1051                         elsif GNAT_Shared then
1052                            if Opt.Run_Path_Option then
1053                               --  If shared gnatlib desired, add the
1054                               --  appropriate system specific switch
1055                               --  so that it can be located at runtime.
1056
1057                               if Run_Path_Opt'Length /= 0 then
1058                                  --  Output the system specific linker command
1059                                  --  that allows the image activator to find
1060                                  --  the shared library at runtime.
1061                                  --  Also add path to find libgcc_s.so, if
1062                                  --  relevant.
1063
1064                                  GCC_Index := Index (File_Path.all, "gcc-lib");
1065
1066                                  --  Look for an eventual run_path_option in
1067                                  --  the linker switches.
1068
1069                                  for J in reverse 1 .. Linker_Options.Last loop
1070                                     if Linker_Options.Table (J) /= null
1071                                       and then
1072                                         Linker_Options.Table (J)'Length
1073                                                   > Run_Path_Opt'Length
1074                                       and then
1075                                         Linker_Options.Table (J)
1076                                           (1 .. Run_Path_Opt'Length) =
1077                                                                 Run_Path_Opt
1078                                     then
1079                                        --  We have found a already specified
1080                                        --  run_path_option: we will add to this
1081                                        --  switch, because only one
1082                                        --  run_path_option should be specified.
1083
1084                                        Run_Path_Opt_Index := J;
1085                                        exit;
1086                                     end if;
1087                                  end loop;
1088
1089                                  --  If there is no run_path_option, we need
1090                                  --  to add one.
1091
1092                                  if Run_Path_Opt_Index = 0 then
1093                                     Linker_Options.Increment_Last;
1094                                  end if;
1095
1096                                  if GCC_Index = 0 then
1097                                     if Run_Path_Opt_Index = 0 then
1098                                        Linker_Options.Table
1099                                          (Linker_Options.Last) :=
1100                                            new String'
1101                                               (Run_Path_Opt
1102                                                 & File_Path
1103                                                   (1 .. File_Path'Length
1104                                                          - File_Name'Length));
1105
1106                                     else
1107                                        Linker_Options.Table
1108                                          (Run_Path_Opt_Index) :=
1109                                            new String'
1110                                              (Linker_Options.Table
1111                                                  (Run_Path_Opt_Index).all
1112                                               & Path_Separator
1113                                               & File_Path
1114                                                  (1 .. File_Path'Length
1115                                                        - File_Name'Length));
1116                                     end if;
1117
1118                                  else
1119                                     if Run_Path_Opt_Index = 0 then
1120                                        Linker_Options.Table
1121                                          (Linker_Options.Last) :=
1122                                            new String'(Run_Path_Opt
1123                                              & File_Path
1124                                                  (1 .. File_Path'Length
1125                                                        - File_Name'Length)
1126                                              & Path_Separator
1127                                              & File_Path (1 .. GCC_Index - 1));
1128
1129                                     else
1130                                        Linker_Options.Table
1131                                          (Run_Path_Opt_Index) :=
1132                                            new String'
1133                                             (Linker_Options.Table
1134                                                 (Run_Path_Opt_Index).all
1135                                              & Path_Separator
1136                                              & File_Path
1137                                                  (1 .. File_Path'Length
1138                                                        - File_Name'Length)
1139                                              & Path_Separator
1140                                              & File_Path (1 .. GCC_Index - 1));
1141                                     end if;
1142                                  end if;
1143                               end if;
1144                            end if;
1145
1146                            --  Then we add the appropriate -l switch
1147
1148                            Linker_Options.Increment_Last;
1149                            Linker_Options.Table (Linker_Options.Last) :=
1150                              new String'(Next_Line (Nfirst .. Nlast));
1151                         end if;
1152
1153                      else
1154                         --  If gnatlib library not found, then
1155                         --  add it anyway in case some other
1156                         --  mechanimsm may find it.
1157
1158                         Linker_Options.Increment_Last;
1159                         Linker_Options.Table (Linker_Options.Last) :=
1160                           new String'(Next_Line (Nfirst .. Nlast));
1161                      end if;
1162                   end;
1163                else
1164                   Linker_Options.Increment_Last;
1165                   Linker_Options.Table (Linker_Options.Last) :=
1166                     new String'(Next_Line (Nfirst .. Nlast));
1167                end if;
1168             end if;
1169
1170             Xlinker_Was_Previous := Next_Line (Nfirst .. Nlast) = "-Xlinker";
1171
1172             Get_Next_Line;
1173             exit when Next_Line (Nfirst .. Nlast) = End_Info;
1174
1175             if Ada_Bind_File then
1176                Next_Line (Nfirst .. Nlast - 8) :=
1177                  Next_Line (Nfirst + 8 .. Nlast);
1178                Nlast := Nlast - 8;
1179             end if;
1180          end loop;
1181       end if;
1182
1183       Status := fclose (Fd);
1184    end Process_Binder_File;
1185
1186    -----------
1187    -- Value --
1188    -----------
1189
1190    function Value (chars : chars_ptr) return String is
1191       function Strlen (chars : chars_ptr) return Natural;
1192       pragma Import (C, Strlen);
1193
1194    begin
1195       if chars = Null_Address then
1196          return "";
1197
1198       else
1199          declare
1200             subtype Result_Type is String (1 .. Strlen (chars));
1201
1202             Result : Result_Type;
1203             for Result'Address use chars;
1204
1205          begin
1206             return Result;
1207          end;
1208       end if;
1209    end Value;
1210
1211    ------------------
1212    -- Write_Header --
1213    ------------------
1214
1215    procedure Write_Header is
1216    begin
1217       if Verbose_Mode then
1218          Write_Eol;
1219          Write_Str ("GNATLINK ");
1220          Write_Str (Gnat_Version_String);
1221          Write_Str (" Copyright 1995-2004 Free Software Foundation, Inc");
1222          Write_Eol;
1223       end if;
1224    end Write_Header;
1225
1226    -----------------
1227    -- Write_Usage --
1228    -----------------
1229
1230    procedure Write_Usage is
1231    begin
1232       Write_Header;
1233
1234       Write_Str ("Usage: ");
1235       Write_Str (Base_Name (Command_Name));
1236       Write_Str (" switches mainprog.ali [non-Ada-objects] [linker-options]");
1237       Write_Eol;
1238       Write_Eol;
1239       Write_Line ("  mainprog.ali   the ALI file of the main program");
1240       Write_Eol;
1241       Write_Line ("  -A    Binder generated source file is in Ada (default)");
1242       Write_Line ("  -C    Binder generated source file is in C");
1243       Write_Line ("  -f    force object file list to be generated");
1244       Write_Line ("  -g    Compile binder source file with debug information");
1245       Write_Line ("  -n    Do not compile the binder source file");
1246       Write_Line ("  -R    Do not use a run_path_option");
1247       Write_Line ("  -v    verbose mode");
1248       Write_Line ("  -v -v very verbose mode");
1249       Write_Eol;
1250       Write_Line ("  -o nam     Use 'nam' as the name of the executable");
1251       Write_Line ("  -b target  Compile the binder source to run on target");
1252       Write_Line ("  -Bdir      Load compiler executables from dir");
1253       Write_Line ("  --GCC=comp Use comp as the compiler");
1254       Write_Line ("  --LINK=nam Use 'nam' for the linking rather than 'gcc'");
1255       Write_Eol;
1256       Write_Line ("  [non-Ada-objects]  list of non Ada object files");
1257       Write_Line ("  [linker-options]   other options for the linker");
1258    end Write_Usage;
1259
1260 --  Start of processing for Gnatlink
1261
1262 begin
1263    Process_Args;
1264
1265    if Argument_Count = 0
1266      or else
1267      (Verbose_Mode and then Argument_Count = 1)
1268    then
1269       Write_Usage;
1270       Exit_Program (E_Fatal);
1271    end if;
1272
1273    if Hostparm.Java_VM then
1274       Gcc := new String'("jgnat");
1275       Ada_Bind_File := True;
1276       Begin_Info := "--  BEGIN Object file/option list";
1277       End_Info   := "--  END Object file/option list   ";
1278    end if;
1279
1280    --  We always compile with -c
1281
1282    Binder_Options_From_ALI.Increment_Last;
1283    Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) :=
1284      new String'("-c");
1285
1286    --  If the main program is in Ada it is compiled with the following
1287    --  switches:
1288
1289    --    -gnatA   stops reading gnat.adc, since we don't know what
1290    --             pagmas would work, and we do not need it anyway.
1291
1292    --    -gnatWb  allows brackets coding for wide characters
1293
1294    --    -gnatiw  allows wide characters in identifiers. This is needed
1295    --             because bindgen uses brackets encoding for all upper
1296    --             half and wide characters in identifier names.
1297
1298    if Ada_Bind_File then
1299       Binder_Options_From_ALI.Increment_Last;
1300       Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) :=
1301         new String'("-gnatA");
1302       Binder_Options_From_ALI.Increment_Last;
1303       Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) :=
1304         new String'("-gnatWb");
1305       Binder_Options_From_ALI.Increment_Last;
1306       Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) :=
1307         new String'("-gnatiw");
1308    end if;
1309
1310    --  Locate all the necessary programs and verify required files are present
1311
1312    Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all);
1313
1314    if Gcc_Path = null then
1315       Exit_With_Error ("Couldn't locate " & Gcc.all);
1316    end if;
1317
1318    if Linker_Path = null then
1319       Linker_Path := Gcc_Path;
1320    end if;
1321
1322    if Ali_File_Name = null then
1323       Exit_With_Error ("no ali file given for link");
1324    end if;
1325
1326    if not Is_Regular_File (Ali_File_Name.all) then
1327       Exit_With_Error (Ali_File_Name.all & " not found");
1328
1329    --  Read the ALI file of the main subprogram if the binder generated
1330    --  file needs to be compiled and no --GCC= switch has been specified.
1331    --  Fetch the back end switches from this ALI file and use these switches
1332    --  to compile the binder generated file
1333
1334    elsif Compile_Bind_File and then Standard_Gcc then
1335       --  Do some initializations
1336
1337       Initialize_ALI;
1338       Namet.Initialize;
1339       Name_Len := Ali_File_Name'Length;
1340       Name_Buffer (1 .. Name_Len) := Ali_File_Name.all;
1341
1342       declare
1343          use Types;
1344          F : constant File_Name_Type := Name_Find;
1345          T : Text_Buffer_Ptr;
1346          A : ALI_Id;
1347
1348       begin
1349          --  Osint.Add_Default_Search_Dirs;
1350          --  Load the ALI file
1351
1352          T := Read_Library_Info (F, True);
1353
1354          --  Read it
1355
1356          A := Scan_ALI (F, T, Ignore_ED => False, Err => False);
1357
1358          if A /= No_ALI_Id then
1359             for
1360               Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg ..
1361                        Units.Table (ALIs.Table (A).First_Unit).Last_Arg
1362             loop
1363                --  Do not compile with the front end switches except for --RTS
1364
1365                declare
1366                   Arg : String_Ptr renames Args.Table (Index);
1367                begin
1368                   if not Is_Front_End_Switch (Arg.all)
1369                     or else Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
1370                   then
1371                      Binder_Options_From_ALI.Increment_Last;
1372                      Binder_Options_From_ALI.Table
1373                        (Binder_Options_From_ALI.Last) := String_Access (Arg);
1374                   end if;
1375                end;
1376             end loop;
1377          end if;
1378       end;
1379    end if;
1380
1381    Write_Header;
1382
1383    --  If no output name specified, then use the base name of .ali file name
1384
1385    if Output_File_Name = null then
1386
1387       Output_File_Name :=
1388         new String'(Base_Name (Ali_File_Name.all)
1389                        & Get_Debuggable_Suffix.all);
1390
1391       Linker_Options.Increment_Last;
1392       Linker_Options.Table (Linker_Options.Last) :=
1393         new String'("-o");
1394
1395       Linker_Options.Increment_Last;
1396       Linker_Options.Table (Linker_Options.Last) :=
1397         new String'(Output_File_Name.all);
1398
1399    end if;
1400
1401    --  Warn if main program is called "test", as that may be a built-in command
1402    --  on Unix. On non-Unix systems executables have a suffix, so the warning
1403    --  will not appear. However, do not warn in the case of a cross compiler.
1404
1405    --  Assume that if the executable name is not gnatlink, this is a cross
1406    --  tool.
1407
1408    if Base_Name (Command_Name) = "gnatlink"
1409      and then Output_File_Name.all = "test"
1410    then
1411       Error_Msg ("warning: executable name """ & Output_File_Name.all
1412                    & """ may conflict with shell command");
1413    end if;
1414
1415    --  Perform consistency checks
1416
1417    --  Transform the .ali file name into the binder output file name.
1418
1419    Make_Binder_File_Names : declare
1420       Fname     : constant String  := Base_Name (Ali_File_Name.all);
1421       Fname_Len : Integer := Fname'Length;
1422
1423       function Get_Maximum_File_Name_Length return Integer;
1424       pragma Import (C, Get_Maximum_File_Name_Length,
1425                         "__gnat_get_maximum_file_name_length");
1426
1427       Maximum_File_Name_Length : constant Integer :=
1428         Get_Maximum_File_Name_Length;
1429
1430       Second_Char : Character;
1431       --  Second character of name of files
1432
1433    begin
1434       --  Set proper second character of file name
1435
1436       if not Ada_Bind_File then
1437          Second_Char := '_';
1438
1439       elsif Hostparm.OpenVMS then
1440          Second_Char := '$';
1441
1442       else
1443          Second_Char := '~';
1444       end if;
1445
1446       --  If the length of the binder file becomes too long due to
1447       --  the addition of the "b?" prefix, then truncate it.
1448
1449       if Maximum_File_Name_Length > 0 then
1450          while Fname_Len > Maximum_File_Name_Length - 2 loop
1451             Fname_Len := Fname_Len - 1;
1452          end loop;
1453       end if;
1454
1455       if Ada_Bind_File then
1456          Binder_Spec_Src_File :=
1457            new String'('b'
1458                        & Second_Char
1459                        & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1460                        & ".ads");
1461          Binder_Body_Src_File :=
1462            new String'('b'
1463                        & Second_Char
1464                        & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1465                        & ".adb");
1466          Binder_Ali_File :=
1467            new String'('b'
1468                        & Second_Char
1469                        & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1470                        & ".ali");
1471
1472       else
1473          Binder_Body_Src_File :=
1474            new String'('b'
1475                        & Second_Char
1476                        & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1477                        & ".c");
1478       end if;
1479
1480       Binder_Obj_File :=
1481         new String'('b'
1482                     & Second_Char
1483                     & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1484                     & Get_Object_Suffix.all);
1485
1486       if Fname_Len /= Fname'Length then
1487          Binder_Options.Increment_Last;
1488          Binder_Options.Table (Binder_Options.Last) := new String'("-o");
1489          Binder_Options.Increment_Last;
1490          Binder_Options.Table (Binder_Options.Last) := Binder_Obj_File;
1491       end if;
1492
1493    end Make_Binder_File_Names;
1494
1495    Process_Binder_File (Binder_Body_Src_File.all & ASCII.NUL);
1496
1497    --  Compile the binder file. This is fast, so we always do it, unless
1498    --  specifically told not to by the -n switch
1499
1500    if Compile_Bind_File then
1501       Bind_Step : declare
1502          Success : Boolean;
1503          Args    : Argument_List
1504            (1 .. Binder_Options_From_ALI.Last + Binder_Options.Last + 1);
1505
1506       begin
1507          for J in 1 .. Binder_Options_From_ALI.Last loop
1508             Args (J) := Binder_Options_From_ALI.Table (J);
1509          end loop;
1510
1511          for J in 1 .. Binder_Options.Last loop
1512             Args (Binder_Options_From_ALI.Last + J) :=
1513               Binder_Options.Table (J);
1514          end loop;
1515
1516          Args (Args'Last) := Binder_Body_Src_File;
1517
1518          if Verbose_Mode then
1519             Write_Str (Base_Name (Gcc_Path.all));
1520
1521             for J in Args'Range loop
1522                Write_Str (" ");
1523                Write_Str (Args (J).all);
1524             end loop;
1525
1526             Write_Eol;
1527          end if;
1528
1529          GNAT.OS_Lib.Spawn (Gcc_Path.all, Args, Success);
1530
1531          if not Success then
1532             Exit_Program (E_Fatal);
1533          end if;
1534       end Bind_Step;
1535    end if;
1536
1537    --  Now, actually link the program.
1538
1539    --  Skip this step for now on the JVM since the Java interpreter will do
1540    --  the actual link at run time. We might consider packing all class files
1541    --  in a .zip file during this step.
1542
1543    if not Hostparm.Java_VM then
1544       Link_Step : declare
1545          Num_Args : Natural :=
1546                      (Linker_Options.Last - Linker_Options.First + 1) +
1547                      (Gcc_Linker_Options.Last - Gcc_Linker_Options.First + 1) +
1548                      (Linker_Objects.Last - Linker_Objects.First + 1);
1549          Stack_Op : Boolean := False;
1550          IDENT_Op : Boolean := False;
1551
1552       begin
1553          --  Remove duplicate stack size setting from the Linker_Options
1554          --  table. The stack setting option "-Xlinker --stack=R,C" can be
1555          --  found in one line when set by a pragma Linker_Options or in two
1556          --  lines ("-Xlinker" then "--stack=R,C") when set on the command
1557          --  line. We also check for the "-Wl,--stack=R" style option.
1558
1559          --  We must remove the second stack setting option instance
1560          --  because the one on the command line will always be the first
1561          --  one. And any subsequent stack setting option will overwrite the
1562          --  previous one. This is done especially for GNAT/NT where we set
1563          --  the stack size for tasking programs by a pragma in the NT
1564          --  specific tasking package System.Task_Primitives.Oparations.
1565
1566          --  Note: This is not a FOR loop that runs from Linker_Options.First
1567          --  to Linker_Options.Last, since operations within the loop can
1568          --  modify the length of the table.
1569
1570          Clean_Link_Option_Set : declare
1571             J : Natural := Linker_Options.First;
1572
1573          begin
1574             while J <= Linker_Options.Last loop
1575
1576                if Linker_Options.Table (J).all = "-Xlinker"
1577                  and then J < Linker_Options.Last
1578                  and then Linker_Options.Table (J + 1)'Length > 8
1579                  and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack="
1580                then
1581                   if Stack_Op then
1582                      Linker_Options.Table (J .. Linker_Options.Last - 2) :=
1583                        Linker_Options.Table (J + 2 .. Linker_Options.Last);
1584                      Linker_Options.Decrement_Last;
1585                      Linker_Options.Decrement_Last;
1586                      Num_Args := Num_Args - 2;
1587
1588                   else
1589                      Stack_Op := True;
1590                   end if;
1591                end if;
1592
1593                --  Here we just check for a canonical form that matches the
1594                --  pragma Linker_Options set in the NT runtime.
1595
1596                if (Linker_Options.Table (J)'Length > 17
1597                    and then Linker_Options.Table (J) (1 .. 17)
1598                            = "-Xlinker --stack=")
1599                  or else
1600                   (Linker_Options.Table (J)'Length > 12
1601                    and then Linker_Options.Table (J) (1 .. 12)
1602                             = "-Wl,--stack=")
1603                then
1604                   if Stack_Op then
1605                      Linker_Options.Table (J .. Linker_Options.Last - 1) :=
1606                        Linker_Options.Table (J + 1 .. Linker_Options.Last);
1607                      Linker_Options.Decrement_Last;
1608                      Num_Args := Num_Args - 1;
1609
1610                   else
1611                      Stack_Op := True;
1612                   end if;
1613                end if;
1614
1615                --  Remove duplicate IDENTIFICATION directives (VMS)
1616
1617                if Linker_Options.Table (J)'Length > 27
1618                  and then Linker_Options.Table (J) (1 .. 28)
1619                           = "--for-linker=IDENTIFICATION="
1620                then
1621                   if IDENT_Op then
1622                      Linker_Options.Table (J .. Linker_Options.Last - 1) :=
1623                        Linker_Options.Table (J + 1 .. Linker_Options.Last);
1624                      Linker_Options.Decrement_Last;
1625                      Num_Args := Num_Args - 1;
1626                   else
1627                      IDENT_Op := True;
1628                   end if;
1629                end if;
1630
1631                J := J + 1;
1632             end loop;
1633          end Clean_Link_Option_Set;
1634
1635          --  Prepare arguments for call to linker
1636
1637          Call_Linker : declare
1638             Success  : Boolean;
1639             Args     : Argument_List (1 .. Num_Args + 1);
1640             Index    : Integer := Args'First;
1641
1642          begin
1643             Args (Index) := Binder_Obj_File;
1644
1645             --  Add the object files and any -largs libraries
1646
1647             for J in Linker_Objects.First .. Linker_Objects.Last loop
1648                Index := Index + 1;
1649                Args (Index) := Linker_Objects.Table (J);
1650             end loop;
1651
1652             --  Add the linker options from the binder file
1653
1654             for J in Linker_Options.First .. Linker_Options.Last loop
1655                Index := Index + 1;
1656                Args (Index) := Linker_Options.Table (J);
1657             end loop;
1658
1659             --  Finally add the libraries from the --GCC= switch
1660
1661             for J in Gcc_Linker_Options.First .. Gcc_Linker_Options.Last loop
1662                Index := Index + 1;
1663                Args (Index) := Gcc_Linker_Options.Table (J);
1664             end loop;
1665
1666             if Verbose_Mode then
1667                Write_Str (Linker_Path.all);
1668
1669                for J in Args'Range loop
1670                   Write_Str (" ");
1671                   Write_Str (Args (J).all);
1672                end loop;
1673
1674                Write_Eol;
1675
1676                --  If we are on very verbose mode (-v -v) and a response file
1677                --  is used we display its content.
1678
1679                if Very_Verbose_Mode and then Tname_FD /= Invalid_FD then
1680                   Write_Eol;
1681                   Write_Str ("Response file (" &
1682                              Tname (Tname'First .. Tname'Last - 1) &
1683                              ") content : ");
1684                   Write_Eol;
1685
1686                   for J in
1687                     Response_File_Objects.First ..
1688                     Response_File_Objects.Last
1689                   loop
1690                      Write_Str (Response_File_Objects.Table (J).all);
1691                      Write_Eol;
1692                   end loop;
1693
1694                   Write_Eol;
1695                end if;
1696             end if;
1697
1698             GNAT.OS_Lib.Spawn (Linker_Path.all, Args, Success);
1699
1700             --  Delete the temporary file used in conjuction with linking if
1701             --  one was created. See Process_Bind_File for details.
1702
1703             if Tname_FD /= Invalid_FD then
1704                Delete (Tname);
1705             end if;
1706
1707             if not Success then
1708                Error_Msg ("cannot call " & Linker_Path.all);
1709                Exit_Program (E_Fatal);
1710             end if;
1711          end Call_Linker;
1712       end Link_Step;
1713    end if;
1714
1715    --  Only keep the binder output file and it's associated object
1716    --  file if compiling with the -g option.  These files are only
1717    --  useful if debugging.
1718
1719    if not Debug_Flag_Present then
1720       if Binder_Ali_File /= null then
1721          Delete (Binder_Ali_File.all & ASCII.NUL);
1722       end if;
1723
1724       if Binder_Spec_Src_File /= null then
1725          Delete (Binder_Spec_Src_File.all & ASCII.NUL);
1726       end if;
1727
1728       Delete (Binder_Body_Src_File.all & ASCII.NUL);
1729
1730       if not Hostparm.Java_VM then
1731          Delete (Binder_Obj_File.all & ASCII.NUL);
1732       end if;
1733    end if;
1734
1735    Exit_Program (E_Success);
1736
1737 exception
1738    when X : others =>
1739       Write_Line (Exception_Information (X));
1740       Exit_With_Error ("INTERNAL ERROR. Please report");
1741 end Gnatlink;