gcc/ada/gnatlink.adb

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