gcc/ada/gnatlink.adb

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