gcc/ada/gnatlink.adb

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