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