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