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