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-2005 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_Eol;
1282          Write_Str ("Copyright 1995-2005 Free Software Foundation, Inc");
1283          Write_Eol;
1284       end if;
1285    end Write_Header;
1286
1287    -----------------
1288    -- Write_Usage --
1289    -----------------
1290
1291    procedure Write_Usage is
1292    begin
1293       Write_Header;
1294
1295       Write_Str ("Usage: ");
1296       Write_Str (Base_Name (Command_Name));
1297       Write_Str (" switches mainprog.ali [non-Ada-objects] [linker-options]");
1298       Write_Eol;
1299       Write_Eol;
1300       Write_Line ("  mainprog.ali   the ALI file of the main program");
1301       Write_Eol;
1302       Write_Line ("  -A    Binder generated source file is in Ada (default)");
1303       Write_Line ("  -C    Binder generated source file is in C");
1304       Write_Line ("  -f    force object file list to be generated");
1305       Write_Line ("  -g    Compile binder source file with debug information");
1306       Write_Line ("  -n    Do not compile the binder source file");
1307       Write_Line ("  -R    Do not use a run_path_option");
1308       Write_Line ("  -v    verbose mode");
1309       Write_Line ("  -v -v very verbose mode");
1310       Write_Eol;
1311       Write_Line ("  -o nam     Use 'nam' as the name of the executable");
1312       Write_Line ("  -b target  Compile the binder source to run on target");
1313       Write_Line ("  -Bdir      Load compiler executables from dir");
1314
1315       if Is_Supported (Map_File) then
1316          Write_Line ("  -Mmap      Create map file map");
1317          Write_Line ("  -M         Create map file mainprog.map");
1318       end if;
1319
1320       Write_Line ("  --GCC=comp Use comp as the compiler");
1321       Write_Line ("  --LINK=nam Use 'nam' for the linking rather than 'gcc'");
1322       Write_Eol;
1323       Write_Line ("  [non-Ada-objects]  list of non Ada object files");
1324       Write_Line ("  [linker-options]   other options for the linker");
1325    end Write_Usage;
1326
1327 --  Start of processing for Gnatlink
1328
1329 begin
1330    --  Add the directory where gnatlink is invoked in front of the
1331    --  path, if gnatlink is invoked with directory information.
1332    --  Only do this if the platform is not VMS, where the notion of path
1333    --  does not really exist.
1334
1335    if not Hostparm.OpenVMS then
1336       declare
1337          Command : constant String := Command_Name;
1338
1339       begin
1340          for Index in reverse Command'Range loop
1341             if Command (Index) = Directory_Separator then
1342                declare
1343                   Absolute_Dir : constant String :=
1344                                    Normalize_Pathname
1345                                      (Command (Command'First .. Index));
1346
1347                   PATH         : constant String :=
1348                                    Absolute_Dir &
1349                   Path_Separator &
1350                   Getenv ("PATH").all;
1351
1352                begin
1353                   Setenv ("PATH", PATH);
1354                end;
1355
1356                exit;
1357             end if;
1358          end loop;
1359       end;
1360    end if;
1361
1362    Process_Args;
1363
1364    if Argument_Count = 0
1365      or else
1366      (Verbose_Mode and then Argument_Count = 1)
1367    then
1368       Write_Usage;
1369       Exit_Program (E_Fatal);
1370    end if;
1371
1372    if Hostparm.Java_VM then
1373       Gcc := new String'("jgnat");
1374       Ada_Bind_File := True;
1375       Begin_Info := "--  BEGIN Object file/option list";
1376       End_Info   := "--  END Object file/option list   ";
1377    end if;
1378
1379    --  We always compile with -c
1380
1381    Binder_Options_From_ALI.Increment_Last;
1382    Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) :=
1383      new String'("-c");
1384
1385    --  If the main program is in Ada it is compiled with the following
1386    --  switches:
1387
1388    --    -gnatA   stops reading gnat.adc, since we don't know what
1389    --             pagmas would work, and we do not need it anyway.
1390
1391    --    -gnatWb  allows brackets coding for wide characters
1392
1393    --    -gnatiw  allows wide characters in identifiers. This is needed
1394    --             because bindgen uses brackets encoding for all upper
1395    --             half and wide characters in identifier names.
1396
1397    if Ada_Bind_File then
1398       Binder_Options_From_ALI.Increment_Last;
1399       Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) :=
1400         new String'("-gnatA");
1401       Binder_Options_From_ALI.Increment_Last;
1402       Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) :=
1403         new String'("-gnatWb");
1404       Binder_Options_From_ALI.Increment_Last;
1405       Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) :=
1406         new String'("-gnatiw");
1407    end if;
1408
1409    --  Locate all the necessary programs and verify required files are present
1410
1411    Gcc_Path := GNAT.OS_Lib.Locate_Exec_On_Path (Gcc.all);
1412
1413    if Gcc_Path = null then
1414       Exit_With_Error ("Couldn't locate " & Gcc.all);
1415    end if;
1416
1417    if Linker_Path = null then
1418       Linker_Path := Gcc_Path;
1419    end if;
1420
1421    if Ali_File_Name = null then
1422       Exit_With_Error ("no ali file given for link");
1423    end if;
1424
1425    if not Is_Regular_File (Ali_File_Name.all) then
1426       Exit_With_Error (Ali_File_Name.all & " not found");
1427
1428    --  Read the ALI file of the main subprogram if the binder generated
1429    --  file needs to be compiled and no --GCC= switch has been specified.
1430    --  Fetch the back end switches from this ALI file and use these switches
1431    --  to compile the binder generated file
1432
1433    elsif Compile_Bind_File and then Standard_Gcc then
1434       --  Do some initializations
1435
1436       Initialize_ALI;
1437       Namet.Initialize;
1438       Name_Len := Ali_File_Name'Length;
1439       Name_Buffer (1 .. Name_Len) := Ali_File_Name.all;
1440
1441       declare
1442          use Types;
1443          F : constant File_Name_Type := Name_Find;
1444          T : Text_Buffer_Ptr;
1445          A : ALI_Id;
1446
1447       begin
1448          --  Osint.Add_Default_Search_Dirs;
1449          --  Load the ALI file
1450
1451          T := Read_Library_Info (F, True);
1452
1453          --  Read it. Note that we ignore errors, since we only want very
1454          --  limited information from the ali file, and likely a slightly
1455          --  wrong version will be just fine, though in normal operation
1456          --  we don't expect this to happen!
1457
1458          A := Scan_ALI
1459                (F,
1460                 T,
1461                 Ignore_ED     => False,
1462                 Err           => False,
1463                 Ignore_Errors => True);
1464
1465          if A /= No_ALI_Id then
1466             for
1467               Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg ..
1468                        Units.Table (ALIs.Table (A).First_Unit).Last_Arg
1469             loop
1470                --  Do not compile with the front end switches except for --RTS
1471                --  if the binder generated file is in Ada.
1472
1473                declare
1474                   Arg : String_Ptr renames Args.Table (Index);
1475                begin
1476                   if not Is_Front_End_Switch (Arg.all)
1477                     or else
1478                       (Ada_Bind_File
1479                         and then Arg'Length > 5
1480                         and then Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=")
1481                   then
1482                      Binder_Options_From_ALI.Increment_Last;
1483                      Binder_Options_From_ALI.Table
1484                        (Binder_Options_From_ALI.Last) := String_Access (Arg);
1485                   end if;
1486                end;
1487             end loop;
1488          end if;
1489       end;
1490    end if;
1491
1492    Write_Header;
1493
1494    --  If no output name specified, then use the base name of .ali file name
1495
1496    if Output_File_Name = null then
1497
1498       Output_File_Name :=
1499         new String'(Base_Name (Ali_File_Name.all)
1500                        & Get_Debuggable_Suffix.all);
1501
1502       Linker_Options.Increment_Last;
1503       Linker_Options.Table (Linker_Options.Last) :=
1504         new String'("-o");
1505
1506       Linker_Options.Increment_Last;
1507       Linker_Options.Table (Linker_Options.Last) :=
1508         new String'(Output_File_Name.all);
1509
1510    end if;
1511
1512    --  Warn if main program is called "test", as that may be a built-in command
1513    --  on Unix. On non-Unix systems executables have a suffix, so the warning
1514    --  will not appear. However, do not warn in the case of a cross compiler.
1515
1516    --  Assume this is a cross tool if the executable name is not gnatlink
1517
1518    if Base_Name (Command_Name) = "gnatlink"
1519      and then Output_File_Name.all = "test"
1520    then
1521       Error_Msg ("warning: executable name """ & Output_File_Name.all
1522                    & """ may conflict with shell command");
1523    end if;
1524
1525    --  If -M switch was specified, add the switches to create the map file
1526
1527    if Create_Map_File then
1528       declare
1529          Map_Name : constant String := Base_Name (Ali_File_Name.all) & ".map";
1530          Switches : String_List_Access;
1531
1532       begin
1533          Convert (Map_File, Map_Name, Switches);
1534
1535          if Switches /= null then
1536             for J in Switches'Range loop
1537                Linker_Options.Increment_Last;
1538                Linker_Options.Table (Linker_Options.Last) := Switches (J);
1539             end loop;
1540          end if;
1541       end;
1542    end if;
1543
1544    --  Perform consistency checks
1545
1546    --  Transform the .ali file name into the binder output file name
1547
1548    Make_Binder_File_Names : declare
1549       Fname     : constant String  := Base_Name (Ali_File_Name.all);
1550       Fname_Len : Integer := Fname'Length;
1551
1552       function Get_Maximum_File_Name_Length return Integer;
1553       pragma Import (C, Get_Maximum_File_Name_Length,
1554                         "__gnat_get_maximum_file_name_length");
1555
1556       Maximum_File_Name_Length : constant Integer :=
1557         Get_Maximum_File_Name_Length;
1558
1559       Second_Char : Character;
1560       --  Second character of name of files
1561
1562    begin
1563       --  Set proper second character of file name
1564
1565       if not Ada_Bind_File then
1566          Second_Char := '_';
1567
1568       elsif Hostparm.OpenVMS then
1569          Second_Char := '$';
1570
1571       else
1572          Second_Char := '~';
1573       end if;
1574
1575       --  If the length of the binder file becomes too long due to
1576       --  the addition of the "b?" prefix, then truncate it.
1577
1578       if Maximum_File_Name_Length > 0 then
1579          while Fname_Len > Maximum_File_Name_Length - 2 loop
1580             Fname_Len := Fname_Len - 1;
1581          end loop;
1582       end if;
1583
1584       if Ada_Bind_File then
1585          Binder_Spec_Src_File :=
1586            new String'('b'
1587                        & Second_Char
1588                        & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1589                        & ".ads");
1590          Binder_Body_Src_File :=
1591            new String'('b'
1592                        & Second_Char
1593                        & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1594                        & ".adb");
1595          Binder_Ali_File :=
1596            new String'('b'
1597                        & Second_Char
1598                        & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1599                        & ".ali");
1600
1601       else
1602          Binder_Body_Src_File :=
1603            new String'('b'
1604                        & Second_Char
1605                        & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1606                        & ".c");
1607       end if;
1608
1609       Binder_Obj_File :=
1610         new String'('b'
1611                     & Second_Char
1612                     & Fname (Fname'First .. Fname'First + Fname_Len - 1)
1613                     & Get_Object_Suffix.all);
1614
1615       if Fname_Len /= Fname'Length then
1616          Binder_Options.Increment_Last;
1617          Binder_Options.Table (Binder_Options.Last) := new String'("-o");
1618          Binder_Options.Increment_Last;
1619          Binder_Options.Table (Binder_Options.Last) := Binder_Obj_File;
1620       end if;
1621
1622    end Make_Binder_File_Names;
1623
1624    Process_Binder_File (Binder_Body_Src_File.all & ASCII.NUL);
1625
1626    --  Compile the binder file. This is fast, so we always do it, unless
1627    --  specifically told not to by the -n switch
1628
1629    if Compile_Bind_File then
1630       Bind_Step : declare
1631          Success : Boolean;
1632          Args    : Argument_List
1633            (1 .. Binder_Options_From_ALI.Last + Binder_Options.Last + 1);
1634
1635       begin
1636          for J in 1 .. Binder_Options_From_ALI.Last loop
1637             Args (J) := Binder_Options_From_ALI.Table (J);
1638          end loop;
1639
1640          for J in 1 .. Binder_Options.Last loop
1641             Args (Binder_Options_From_ALI.Last + J) :=
1642               Binder_Options.Table (J);
1643          end loop;
1644
1645          Args (Args'Last) := Binder_Body_Src_File;
1646
1647          if Verbose_Mode then
1648             Write_Str (Base_Name (Gcc_Path.all));
1649
1650             for J in Args'Range loop
1651                Write_Str (" ");
1652                Write_Str (Args (J).all);
1653             end loop;
1654
1655             Write_Eol;
1656          end if;
1657
1658          GNAT.OS_Lib.Spawn (Gcc_Path.all, Args, Success);
1659
1660          if not Success then
1661             Exit_Program (E_Fatal);
1662          end if;
1663       end Bind_Step;
1664    end if;
1665
1666    --  Now, actually link the program
1667
1668    --  Skip this step for now on the JVM since the Java interpreter will do
1669    --  the actual link at run time. We might consider packing all class files
1670    --  in a .zip file during this step.
1671
1672    if not Hostparm.Java_VM then
1673       Link_Step : declare
1674          Num_Args : Natural :=
1675                      (Linker_Options.Last - Linker_Options.First + 1) +
1676                      (Gcc_Linker_Options.Last - Gcc_Linker_Options.First + 1) +
1677                      (Linker_Objects.Last - Linker_Objects.First + 1);
1678          Stack_Op : Boolean := False;
1679          IDENT_Op : Boolean := False;
1680
1681       begin
1682          --  Remove duplicate stack size setting from the Linker_Options
1683          --  table. The stack setting option "-Xlinker --stack=R,C" can be
1684          --  found in one line when set by a pragma Linker_Options or in two
1685          --  lines ("-Xlinker" then "--stack=R,C") when set on the command
1686          --  line. We also check for the "-Wl,--stack=R" style option.
1687
1688          --  We must remove the second stack setting option instance
1689          --  because the one on the command line will always be the first
1690          --  one. And any subsequent stack setting option will overwrite the
1691          --  previous one. This is done especially for GNAT/NT where we set
1692          --  the stack size for tasking programs by a pragma in the NT
1693          --  specific tasking package System.Task_Primitives.Oparations.
1694
1695          --  Note: This is not a FOR loop that runs from Linker_Options.First
1696          --  to Linker_Options.Last, since operations within the loop can
1697          --  modify the length of the table.
1698
1699          Clean_Link_Option_Set : declare
1700             J : Natural := Linker_Options.First;
1701
1702          begin
1703             while J <= Linker_Options.Last loop
1704
1705                if Linker_Options.Table (J).all = "-Xlinker"
1706                  and then J < Linker_Options.Last
1707                  and then Linker_Options.Table (J + 1)'Length > 8
1708                  and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack="
1709                then
1710                   if Stack_Op then
1711                      Linker_Options.Table (J .. Linker_Options.Last - 2) :=
1712                        Linker_Options.Table (J + 2 .. Linker_Options.Last);
1713                      Linker_Options.Decrement_Last;
1714                      Linker_Options.Decrement_Last;
1715                      Num_Args := Num_Args - 2;
1716
1717                   else
1718                      Stack_Op := True;
1719                   end if;
1720                end if;
1721
1722                --  Here we just check for a canonical form that matches the
1723                --  pragma Linker_Options set in the NT runtime.
1724
1725                if (Linker_Options.Table (J)'Length > 17
1726                    and then Linker_Options.Table (J) (1 .. 17)
1727                            = "-Xlinker --stack=")
1728                  or else
1729                   (Linker_Options.Table (J)'Length > 12
1730                    and then Linker_Options.Table (J) (1 .. 12)
1731                             = "-Wl,--stack=")
1732                then
1733                   if Stack_Op then
1734                      Linker_Options.Table (J .. Linker_Options.Last - 1) :=
1735                        Linker_Options.Table (J + 1 .. Linker_Options.Last);
1736                      Linker_Options.Decrement_Last;
1737                      Num_Args := Num_Args - 1;
1738
1739                   else
1740                      Stack_Op := True;
1741                   end if;
1742                end if;
1743
1744                --  Remove duplicate IDENTIFICATION directives (VMS)
1745
1746                if Linker_Options.Table (J)'Length > 27
1747                  and then Linker_Options.Table (J) (1 .. 28)
1748                           = "--for-linker=IDENTIFICATION="
1749                then
1750                   if IDENT_Op then
1751                      Linker_Options.Table (J .. Linker_Options.Last - 1) :=
1752                        Linker_Options.Table (J + 1 .. Linker_Options.Last);
1753                      Linker_Options.Decrement_Last;
1754                      Num_Args := Num_Args - 1;
1755                   else
1756                      IDENT_Op := True;
1757                   end if;
1758                end if;
1759
1760                J := J + 1;
1761             end loop;
1762          end Clean_Link_Option_Set;
1763
1764          --  Prepare arguments for call to linker
1765
1766          Call_Linker : declare
1767             Success  : Boolean;
1768             Args     : Argument_List (1 .. Num_Args + 1);
1769             Index    : Integer := Args'First;
1770
1771          begin
1772             Args (Index) := Binder_Obj_File;
1773
1774             --  Add the object files and any -largs libraries
1775
1776             for J in Linker_Objects.First .. Linker_Objects.Last loop
1777                Index := Index + 1;
1778                Args (Index) := Linker_Objects.Table (J);
1779             end loop;
1780
1781             --  Add the linker options from the binder file
1782
1783             for J in Linker_Options.First .. Linker_Options.Last loop
1784                Index := Index + 1;
1785                Args (Index) := Linker_Options.Table (J);
1786             end loop;
1787
1788             --  Finally add the libraries from the --GCC= switch
1789
1790             for J in Gcc_Linker_Options.First .. Gcc_Linker_Options.Last loop
1791                Index := Index + 1;
1792                Args (Index) := Gcc_Linker_Options.Table (J);
1793             end loop;
1794
1795             if Verbose_Mode then
1796                Write_Str (Linker_Path.all);
1797
1798                for J in Args'Range loop
1799                   Write_Str (" ");
1800                   Write_Str (Args (J).all);
1801                end loop;
1802
1803                Write_Eol;
1804
1805                --  If we are on very verbose mode (-v -v) and a response file
1806                --  is used we display its content.
1807
1808                if Very_Verbose_Mode and then Tname_FD /= Invalid_FD then
1809                   Write_Eol;
1810                   Write_Str ("Response file (" &
1811                              Tname (Tname'First .. Tname'Last - 1) &
1812                              ") content : ");
1813                   Write_Eol;
1814
1815                   for J in
1816                     Response_File_Objects.First ..
1817                     Response_File_Objects.Last
1818                   loop
1819                      Write_Str (Response_File_Objects.Table (J).all);
1820                      Write_Eol;
1821                   end loop;
1822
1823                   Write_Eol;
1824                end if;
1825             end if;
1826
1827             GNAT.OS_Lib.Spawn (Linker_Path.all, Args, Success);
1828
1829             --  Delete the temporary file used in conjuction with linking if
1830             --  one was created. See Process_Bind_File for details.
1831
1832             if Tname_FD /= Invalid_FD then
1833                Delete (Tname);
1834             end if;
1835
1836             if not Success then
1837                Error_Msg ("cannot call " & Linker_Path.all);
1838                Exit_Program (E_Fatal);
1839             end if;
1840          end Call_Linker;
1841       end Link_Step;
1842    end if;
1843
1844    --  Only keep the binder output file and it's associated object
1845    --  file if compiling with the -g option.  These files are only
1846    --  useful if debugging.
1847
1848    if not Debug_Flag_Present then
1849       if Binder_Ali_File /= null then
1850          Delete (Binder_Ali_File.all & ASCII.NUL);
1851       end if;
1852
1853       if Binder_Spec_Src_File /= null then
1854          Delete (Binder_Spec_Src_File.all & ASCII.NUL);
1855       end if;
1856
1857       Delete (Binder_Body_Src_File.all & ASCII.NUL);
1858
1859       if not Hostparm.Java_VM then
1860          Delete (Binder_Obj_File.all & ASCII.NUL);
1861       end if;
1862    end if;
1863
1864    Exit_Program (E_Success);
1865
1866 exception
1867    when X : others =>
1868       Write_Line (Exception_Information (X));
1869       Exit_With_Error ("INTERNAL ERROR. Please report");
1870 end Gnatlink;