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