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