gcc/ada/gnatbind.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             G N A T B I N D                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2013, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with ALI;      use ALI;
  27 with ALI.Util; use ALI.Util;
  28 with Bcheck;   use Bcheck;
  29 with Binde;    use Binde;
  30 with Binderr;  use Binderr;
  31 with Bindgen;  use Bindgen;
  32 with Bindusg;
  33 with Butil;    use Butil;
  34 with Casing;   use Casing;
  35 with Csets;
  36 with Debug;    use Debug;
  37 with Fmap;
  38 with Fname;    use Fname;
  39 with Namet;    use Namet;
  40 with Opt;      use Opt;
  41 with Osint;    use Osint;
  42 with Osint.B;  use Osint.B;
  43 with Output;   use Output;
  44 with Rident;   use Rident;
  45 with Snames;
  46 with Switch;   use Switch;
  47 with Switch.B; use Switch.B;
  48 with Table;
  49 with Targparm; use Targparm;
  50 with Types;    use Types;
  51
  52 with System.Case_Util; use System.Case_Util;
  53 with System.OS_Lib;    use System.OS_Lib;
  54
  55 with Ada.Command_Line.Response_File; use Ada.Command_Line;
  56
  57 procedure Gnatbind is
  58
  59    Total_Errors : Nat := 0;
  60    --  Counts total errors in all files
  61
  62    Total_Warnings : Nat := 0;
  63    --  Total warnings in all files
  64
  65    Main_Lib_File : File_Name_Type;
  66    --  Current main library file
  67
  68    First_Main_Lib_File : File_Name_Type := No_File;
  69    --  The first library file, that should be a main subprogram if neither -n
  70    --  nor -z are used.
  71
  72    Std_Lib_File : File_Name_Type;
  73    --  Standard library
  74
  75    Text     : Text_Buffer_Ptr;
  76    Next_Arg : Positive;
  77
  78    Output_File_Name_Seen : Boolean := False;
  79    Output_File_Name      : String_Ptr := new String'("");
  80
  81    L_Switch_Seen : Boolean := False;
  82
  83    Mapping_File : String_Ptr := null;
  84
  85    package Closure_Sources is new Table.Table
  86      (Table_Component_Type => File_Name_Type,
  87       Table_Index_Type     => Natural,
  88       Table_Low_Bound      => 1,
  89       Table_Initial        => 10,
  90       Table_Increment      => 100,
  91       Table_Name           => "Gnatbind.Closure_Sources");
  92    --  Table to record the sources in the closure, to avoid duplications. Used
  93    --  only with switch -R.
  94
  95    function Gnatbind_Supports_Auto_Init return Boolean;
  96    --  Indicates if automatic initialization of elaboration procedure
  97    --  through the constructor mechanism is possible on the platform.
  98
  99    procedure List_Applicable_Restrictions;
 100    --  List restrictions that apply to this partition if option taken
 101
 102    procedure Scan_Bind_Arg (Argv : String);
 103    --  Scan and process binder specific arguments. Argv is a single argument.
 104    --  All the one character arguments are still handled by Switch. This
 105    --  routine handles -aO -aI and -I-. The lower bound of Argv must be 1.
 106
 107    function Is_Cross_Compiler return Boolean;
 108    --  Returns True iff this is a cross-compiler
 109
 110    ---------------------------------
 111    -- Gnatbind_Supports_Auto_Init --
 112    ---------------------------------
 113
 114    function Gnatbind_Supports_Auto_Init return Boolean is
 115       function gnat_binder_supports_auto_init return Integer;
 116       pragma Import (C, gnat_binder_supports_auto_init,
 117                      "__gnat_binder_supports_auto_init");
 118    begin
 119       return gnat_binder_supports_auto_init /= 0;
 120    end Gnatbind_Supports_Auto_Init;
 121
 122    -----------------------
 123    -- Is_Cross_Compiler --
 124    -----------------------
 125
 126    function Is_Cross_Compiler return Boolean is
 127       Cross_Compiler : Integer;
 128       pragma Import (C, Cross_Compiler, "__gnat_is_cross_compiler");
 129    begin
 130       return Cross_Compiler = 1;
 131    end Is_Cross_Compiler;
 132
 133    ----------------------------------
 134    -- List_Applicable_Restrictions --
 135    ----------------------------------
 136
 137    procedure List_Applicable_Restrictions is
 138
 139       --  Define those restrictions that should be output if the gnatbind
 140       --  -r switch is used. Not all restrictions are output for the reasons
 141       --  given below in the list, and this array is used to test whether
 142       --  the corresponding pragma should be listed. True means that it
 143       --  should not be listed.
 144
 145       No_Restriction_List : constant array (All_Restrictions) of Boolean :=
 146         (No_Standard_Allocators_After_Elaboration => True,
 147          --  This involves run-time conditions not checkable at compile time
 148
 149          No_Anonymous_Allocators         => True,
 150          --  Premature, since we have not implemented this yet
 151
 152          No_Exception_Propagation        => True,
 153          --  Modifies code resulting in different exception semantics
 154
 155          No_Exceptions                   => True,
 156          --  Has unexpected Suppress (All_Checks) effect
 157
 158          No_Implicit_Conditionals        => True,
 159          --  This could modify and pessimize generated code
 160
 161          No_Implicit_Dynamic_Code        => True,
 162          --  This could modify and pessimize generated code
 163
 164          No_Implicit_Loops               => True,
 165          --  This could modify and pessimize generated code
 166
 167          No_Recursion                    => True,
 168          --  Not checkable at compile time
 169
 170          No_Reentrancy                   => True,
 171          --  Not checkable at compile time
 172
 173          Max_Entry_Queue_Length           => True,
 174          --  Not checkable at compile time
 175
 176          Max_Storage_At_Blocking         => True,
 177          --  Not checkable at compile time
 178
 179          others                          => False);
 180
 181       Additional_Restrictions_Listed : Boolean := False;
 182       --  Set True if we have listed header for restrictions
 183
 184       function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean;
 185       --  Returns True if the given restriction can be listed as an additional
 186       --  restriction that could be set.
 187
 188       ------------------------------
 189       -- Restriction_Could_Be_Set --
 190       ------------------------------
 191
 192       function Restriction_Could_Be_Set (R : Restriction_Id) return Boolean is
 193          CR : Restrictions_Info renames Cumulative_Restrictions;
 194
 195       begin
 196          case R is
 197
 198             --  Boolean restriction
 199
 200             when All_Boolean_Restrictions =>
 201
 202                --  The condition for listing a boolean restriction as an
 203                --  additional restriction that could be set is that it is
 204                --  not violated by any unit, and not already set.
 205
 206                return CR.Violated (R) = False and then CR.Set (R) = False;
 207
 208             --  Parameter restriction
 209
 210             when All_Parameter_Restrictions =>
 211
 212                --  If the restriction is violated and the level of violation is
 213                --  unknown, the restriction can definitely not be listed.
 214
 215                if CR.Violated (R) and then CR.Unknown (R) then
 216                   return False;
 217
 218                --  We can list the restriction if it is not set
 219
 220                elsif not CR.Set (R) then
 221                   return True;
 222
 223                --  We can list the restriction if is set to a greater value
 224                --  than the maximum value known for the violation.
 225
 226                else
 227                   return CR.Value (R) > CR.Count (R);
 228                end if;
 229
 230             --  No other values for R possible
 231
 232             when others =>
 233                raise Program_Error;
 234
 235          end case;
 236       end Restriction_Could_Be_Set;
 237
 238    --  Start of processing for List_Applicable_Restrictions
 239
 240    begin
 241       --  Loop through restrictions
 242
 243       for R in All_Restrictions loop
 244          if not No_Restriction_List (R)
 245             and then Restriction_Could_Be_Set (R)
 246          then
 247             if not Additional_Restrictions_Listed then
 248                Write_Eol;
 249                Write_Line
 250                  ("The following additional restrictions may be" &
 251                   " applied to this partition:");
 252                Additional_Restrictions_Listed := True;
 253             end if;
 254
 255             Write_Str ("pragma Restrictions (");
 256
 257             declare
 258                S : constant String := Restriction_Id'Image (R);
 259             begin
 260                Name_Len := S'Length;
 261                Name_Buffer (1 .. Name_Len) := S;
 262             end;
 263
 264             Set_Casing (Mixed_Case);
 265             Write_Str (Name_Buffer (1 .. Name_Len));
 266
 267             if R in All_Parameter_Restrictions then
 268                Write_Str (" => ");
 269                Write_Int (Int (Cumulative_Restrictions.Count (R)));
 270             end if;
 271
 272             Write_Str (");");
 273             Write_Eol;
 274          end if;
 275       end loop;
 276    end List_Applicable_Restrictions;
 277
 278    -------------------
 279    -- Scan_Bind_Arg --
 280    -------------------
 281
 282    procedure Scan_Bind_Arg (Argv : String) is
 283       pragma Assert (Argv'First = 1);
 284
 285    begin
 286       --  Now scan arguments that are specific to the binder and are not
 287       --  handled by the common circuitry in Switch.
 288
 289       if Opt.Output_File_Name_Present
 290         and then not Output_File_Name_Seen
 291       then
 292          Output_File_Name_Seen := True;
 293
 294          if Argv'Length = 0
 295            or else (Argv'Length >= 1 and then Argv (1) = '-')
 296          then
 297             Fail ("output File_Name missing after -o");
 298
 299          else
 300             Output_File_Name := new String'(Argv);
 301          end if;
 302
 303       elsif Argv'Length >= 2 and then Argv (1) = '-' then
 304
 305          --  -I-
 306
 307          if Argv (2 .. Argv'Last) = "I-" then
 308             Opt.Look_In_Primary_Dir := False;
 309
 310          --  -Idir
 311
 312          elsif Argv (2) = 'I' then
 313             Add_Src_Search_Dir (Argv (3 .. Argv'Last));
 314             Add_Lib_Search_Dir (Argv (3 .. Argv'Last));
 315
 316          --  -Ldir
 317
 318          elsif Argv (2) = 'L' then
 319             if Argv'Length >= 3 then
 320
 321                --  Remember that the -L switch was specified, so that if this
 322                --  is on OpenVMS, the export names are put in uppercase.
 323                --  This is not known before the target parameters are read.
 324
 325                L_Switch_Seen := True;
 326
 327                Opt.Bind_For_Library := True;
 328                Opt.Ada_Init_Name :=
 329                  new String'(Argv (3 .. Argv'Last) & Opt.Ada_Init_Suffix);
 330                Opt.Ada_Final_Name :=
 331                  new String'(Argv (3 .. Argv'Last) & Opt.Ada_Final_Suffix);
 332                Opt.Ada_Main_Name :=
 333                  new String'(Argv (3 .. Argv'Last) & Opt.Ada_Main_Name_Suffix);
 334
 335                --  This option (-Lxxx) implies -n
 336
 337                Opt.Bind_Main_Program := False;
 338
 339             else
 340                Fail
 341                  ("Prefix of initialization and finalization " &
 342                   "procedure names missing in -L");
 343             end if;
 344
 345          --  -Sin -Slo -Shi -Sxx -Sev
 346
 347          elsif Argv'Length = 4
 348            and then Argv (2) = 'S'
 349          then
 350             declare
 351                C1 : Character := Argv (3);
 352                C2 : Character := Argv (4);
 353
 354             begin
 355                --  Fold to upper case
 356
 357                if C1 in 'a' .. 'z' then
 358                   C1 := Character'Val (Character'Pos (C1) - 32);
 359                end if;
 360
 361                if C2 in 'a' .. 'z' then
 362                   C2 := Character'Val (Character'Pos (C2) - 32);
 363                end if;
 364
 365                --  Test valid option and set mode accordingly
 366
 367                if C1 = 'E' and then C2 = 'V' then
 368                   null;
 369
 370                elsif C1 = 'I' and then C2 = 'N' then
 371                   null;
 372
 373                elsif C1 = 'L' and then C2 = 'O' then
 374                   null;
 375
 376                elsif C1 = 'H' and then C2 = 'I' then
 377                   null;
 378
 379                elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'F')
 380                        and then
 381                      (C2 in '0' .. '9' or else C2 in 'A' .. 'F')
 382                then
 383                   null;
 384
 385                --  Invalid -S switch, let Switch give error, set default of IN
 386
 387                else
 388                   Scan_Binder_Switches (Argv);
 389                   C1 := 'I';
 390                   C2 := 'N';
 391                end if;
 392
 393                Initialize_Scalars_Mode1 := C1;
 394                Initialize_Scalars_Mode2 := C2;
 395             end;
 396
 397          --  -aIdir
 398
 399          elsif Argv'Length >= 3
 400            and then Argv (2 .. 3) = "aI"
 401          then
 402             Add_Src_Search_Dir (Argv (4 .. Argv'Last));
 403
 404          --  -aOdir
 405
 406          elsif Argv'Length >= 3
 407            and then Argv (2 .. 3) = "aO"
 408          then
 409             Add_Lib_Search_Dir (Argv (4 .. Argv'Last));
 410
 411          --  -nostdlib
 412
 413          elsif Argv (2 .. Argv'Last) = "nostdlib" then
 414             Opt.No_Stdlib := True;
 415
 416          --  -nostdinc
 417
 418          elsif Argv (2 .. Argv'Last) = "nostdinc" then
 419             Opt.No_Stdinc := True;
 420
 421          --  -static
 422
 423          elsif Argv (2 .. Argv'Last) = "static" then
 424             Opt.Shared_Libgnat := False;
 425
 426          --  -shared
 427
 428          elsif Argv (2 .. Argv'Last) = "shared" then
 429             Opt.Shared_Libgnat := True;
 430
 431          --  -F=mapping_file
 432
 433          elsif Argv'Length >= 4 and then Argv (2 .. 3) = "F=" then
 434             if Mapping_File /= null then
 435                Fail ("cannot specify several mapping files");
 436             end if;
 437
 438             Mapping_File := new String'(Argv (4 .. Argv'Last));
 439
 440          --  -Mname
 441
 442          elsif Argv'Length >= 3 and then Argv (2) = 'M' then
 443             if not Is_Cross_Compiler then
 444                Write_Line
 445                  ("gnatbind: -M not expected to be used on native platforms");
 446             end if;
 447
 448             Opt.Bind_Alternate_Main_Name := True;
 449             Opt.Alternate_Main_Name := new String'(Argv (3 .. Argv'Last));
 450
 451          --  All other options are single character and are handled by
 452          --  Scan_Binder_Switches.
 453
 454          else
 455             Scan_Binder_Switches (Argv);
 456          end if;
 457
 458       --  Not a switch, so must be a file name (if non-empty)
 459
 460       elsif Argv'Length /= 0 then
 461          if Argv'Length > 4
 462            and then Argv (Argv'Last - 3 .. Argv'Last) = ".ali"
 463          then
 464             Add_File (Argv);
 465          else
 466             Add_File (Argv & ".ali");
 467          end if;
 468       end if;
 469    end Scan_Bind_Arg;
 470
 471    procedure Check_Version_And_Help is
 472      new Check_Version_And_Help_G (Bindusg.Display);
 473
 474 --  Start of processing for Gnatbind
 475
 476 begin
 477    --  Set default for Shared_Libgnat option
 478
 479    declare
 480       Shared_Libgnat_Default : Character;
 481       pragma Import
 482         (C, Shared_Libgnat_Default, "__gnat_shared_libgnat_default");
 483
 484       SHARED : constant Character := 'H';
 485       STATIC : constant Character := 'T';
 486
 487    begin
 488       pragma Assert
 489         (Shared_Libgnat_Default = SHARED
 490          or else
 491         Shared_Libgnat_Default = STATIC);
 492       Shared_Libgnat := (Shared_Libgnat_Default = SHARED);
 493    end;
 494
 495    --  Scan the switches and arguments
 496
 497    --  First, scan to detect --version and/or --help
 498
 499    Check_Version_And_Help ("GNATBIND", "1995");
 500
 501    --  Use low level argument routines to avoid dragging in the secondary stack
 502
 503    Next_Arg := 1;
 504    Scan_Args : while Next_Arg < Arg_Count loop
 505       declare
 506          Next_Argv : String (1 .. Len_Arg (Next_Arg));
 507       begin
 508          Fill_Arg (Next_Argv'Address, Next_Arg);
 509
 510          if Next_Argv'Length > 0 then
 511             if Next_Argv (1) = '@' then
 512                if Next_Argv'Length > 1 then
 513                   declare
 514                      Arguments : constant Argument_List :=
 515                                    Response_File.Arguments_From
 516                                      (Response_File_Name        =>
 517                                         Next_Argv (2 .. Next_Argv'Last),
 518                                       Recursive                 => True,
 519                                       Ignore_Non_Existing_Files => True);
 520                   begin
 521                      for J in Arguments'Range loop
 522                         Scan_Bind_Arg (Arguments (J).all);
 523                      end loop;
 524                   end;
 525                end if;
 526
 527             else
 528                Scan_Bind_Arg (Next_Argv);
 529             end if;
 530          end if;
 531       end;
 532
 533       Next_Arg := Next_Arg + 1;
 534    end loop Scan_Args;
 535
 536    if Use_Pragma_Linker_Constructor then
 537       if Bind_Main_Program then
 538          Fail ("switch -a must be used in conjunction with -n or -Lxxx");
 539
 540       elsif not Gnatbind_Supports_Auto_Init then
 541          Fail ("automatic initialisation of elaboration " &
 542                "not supported on this platform");
 543       end if;
 544    end if;
 545
 546    --  Test for trailing -o switch
 547
 548    if Opt.Output_File_Name_Present and then not Output_File_Name_Seen then
 549       Fail ("output file name missing after -o");
 550    end if;
 551
 552    --  Output usage if requested
 553
 554    if Usage_Requested then
 555       Bindusg.Display;
 556    end if;
 557
 558    --  Check that the binder file specified has extension .adb
 559
 560    if Opt.Output_File_Name_Present and then Output_File_Name_Seen then
 561       Check_Extensions : declare
 562          Length : constant Natural := Output_File_Name'Length;
 563          Last   : constant Natural := Output_File_Name'Last;
 564       begin
 565          if Length <= 4
 566            or else Output_File_Name (Last - 3 .. Last) /= ".adb"
 567          then
 568             Fail ("output file name should have .adb extension");
 569          end if;
 570       end Check_Extensions;
 571    end if;
 572
 573    Osint.Add_Default_Search_Dirs;
 574
 575    --  Carry out package initializations. These are initializations which
 576    --  might logically be performed at elaboration time, and we decide to be
 577    --  consistent. Like elaboration, the order in which these calls are made
 578    --  is in some cases important.
 579
 580    Csets.Initialize;
 581    Snames.Initialize;
 582
 583    --  Acquire target parameters
 584
 585    Targparm.Get_Target_Parameters;
 586
 587    --  Initialize Cumulative_Restrictions with the restrictions on the target
 588    --  scanned from the system.ads file. Then as we read ALI files, we will
 589    --  accumulate additional restrictions specified in other files.
 590
 591    Cumulative_Restrictions := Targparm.Restrictions_On_Target;
 592
 593    --  On OpenVMS, when -L is used, all external names used in pragmas Export
 594    --  are in upper case. The reason is that on OpenVMS, the macro-assembler
 595    --  MACASM-32, used to build Stand-Alone Libraries, only understands
 596    --  uppercase.
 597
 598    if L_Switch_Seen and then OpenVMS_On_Target then
 599       To_Upper (Opt.Ada_Init_Name.all);
 600       To_Upper (Opt.Ada_Final_Name.all);
 601       To_Upper (Opt.Ada_Main_Name.all);
 602    end if;
 603
 604    --  Acquire configurable run-time mode
 605
 606    if Configurable_Run_Time_On_Target then
 607       Configurable_Run_Time_Mode := True;
 608    end if;
 609
 610    --  Output copyright notice if in verbose mode
 611
 612    if Verbose_Mode then
 613       Write_Eol;
 614       Display_Version ("GNATBIND", "1995");
 615    end if;
 616
 617    --  Output usage information if no files
 618
 619    if not More_Lib_Files then
 620       Bindusg.Display;
 621       Exit_Program (E_Fatal);
 622    end if;
 623
 624    --  If a mapping file was specified, initialize the file mapping
 625
 626    if Mapping_File /= null then
 627       Fmap.Initialize (Mapping_File.all);
 628    end if;
 629
 630    --  The block here is to catch the Unrecoverable_Error exception in the
 631    --  case where we exceed the maximum number of permissible errors or some
 632    --  other unrecoverable error occurs.
 633
 634    begin
 635       --  Initialize binder packages
 636
 637       Initialize_Binderr;
 638       Initialize_ALI;
 639       Initialize_ALI_Source;
 640
 641       if Verbose_Mode then
 642          Write_Eol;
 643       end if;
 644
 645       --  Input ALI files
 646
 647       while More_Lib_Files loop
 648          Main_Lib_File := Next_Main_Lib_File;
 649
 650          if First_Main_Lib_File = No_File then
 651             First_Main_Lib_File := Main_Lib_File;
 652          end if;
 653
 654          if Verbose_Mode then
 655             if Check_Only then
 656                Write_Str ("Checking: ");
 657             else
 658                Write_Str ("Binding: ");
 659             end if;
 660
 661             Write_Name (Main_Lib_File);
 662             Write_Eol;
 663          end if;
 664
 665          Text := Read_Library_Info (Main_Lib_File, True);
 666
 667          declare
 668             Id : ALI_Id;
 669             pragma Warnings (Off, Id);
 670
 671          begin
 672             Id := Scan_ALI
 673                     (F                => Main_Lib_File,
 674                      T                => Text,
 675                      Ignore_ED        => False,
 676                      Err              => False,
 677                      Ignore_Errors    => Debug_Flag_I,
 678                      Directly_Scanned => True);
 679          end;
 680
 681          Free (Text);
 682       end loop;
 683
 684       --  No_Run_Time mode
 685
 686       if No_Run_Time_Mode then
 687
 688          --  Set standard configuration parameters
 689
 690          Suppress_Standard_Library_On_Target := True;
 691          Configurable_Run_Time_Mode          := True;
 692       end if;
 693
 694       --  For main ALI files, even if they are interfaces, we get their
 695       --  dependencies. To be sure, we reset the Interface flag for all main
 696       --  ALI files.
 697
 698       for Index in ALIs.First .. ALIs.Last loop
 699          ALIs.Table (Index).SAL_Interface := False;
 700       end loop;
 701
 702       --  Add System.Standard_Library to list to ensure that these files are
 703       --  included in the bind, even if not directly referenced from Ada code
 704       --  This is suppressed if the appropriate targparm switch is set.
 705
 706       if not Suppress_Standard_Library_On_Target then
 707          Name_Buffer (1 .. 12) := "s-stalib.ali";
 708          Name_Len := 12;
 709          Std_Lib_File := Name_Find;
 710          Text := Read_Library_Info (Std_Lib_File, True);
 711
 712          declare
 713             Id : ALI_Id;
 714             pragma Warnings (Off, Id);
 715
 716          begin
 717             Id :=
 718               Scan_ALI
 719                 (F             => Std_Lib_File,
 720                  T             => Text,
 721                  Ignore_ED     => False,
 722                  Err           => False,
 723                  Ignore_Errors => Debug_Flag_I);
 724          end;
 725
 726          Free (Text);
 727       end if;
 728
 729       --  Load ALIs for all dependent units
 730
 731       for Index in ALIs.First .. ALIs.Last loop
 732          Read_Withed_ALIs (Index);
 733       end loop;
 734
 735       --  Quit if some file needs compiling
 736
 737       if No_Object_Specified then
 738          raise Unrecoverable_Error;
 739       end if;
 740
 741       --  Output list of ALI files in closure
 742
 743       if Output_ALI_List then
 744          if ALI_List_Filename /= null then
 745             Set_List_File (ALI_List_Filename.all);
 746          end if;
 747
 748          for Index in ALIs.First .. ALIs.Last loop
 749             declare
 750                Full_Afile : constant File_Name_Type :=
 751                               Find_File (ALIs.Table (Index).Afile, Library);
 752             begin
 753                Write_Name (Full_Afile);
 754                Write_Eol;
 755             end;
 756          end loop;
 757
 758          if ALI_List_Filename /= null then
 759             Close_List_File;
 760          end if;
 761       end if;
 762
 763       --  Build source file table from the ALI files we have read in
 764
 765       Set_Source_Table;
 766
 767       --  If there is main program to bind, set Main_Lib_File to the first
 768       --  library file, and the name from which to derive the binder generate
 769       --  file to the first ALI file.
 770
 771       if Bind_Main_Program then
 772          Main_Lib_File := First_Main_Lib_File;
 773          Set_Current_File_Name_Index (To => 1);
 774       end if;
 775
 776       --  Check that main library file is a suitable main program
 777
 778       if Bind_Main_Program
 779         and then ALIs.Table (ALIs.First).Main_Program = None
 780         and then not No_Main_Subprogram
 781       then
 782          Get_Name_String
 783            (Units.Table (ALIs.Table (ALIs.First).First_Unit).Uname);
 784
 785          declare
 786             Unit_Name : String := Name_Buffer (1 .. Name_Len - 2);
 787          begin
 788             To_Mixed (Unit_Name);
 789             Get_Name_String (ALIs.Table (ALIs.First).Sfile);
 790             Add_Str_To_Name_Buffer (":1: ");
 791             Add_Str_To_Name_Buffer (Unit_Name);
 792             Add_Str_To_Name_Buffer (" cannot be used as a main program");
 793             Write_Line (Name_Buffer (1 .. Name_Len));
 794             Errors_Detected := Errors_Detected + 1;
 795          end;
 796       end if;
 797
 798       --  Perform consistency and correctness checks
 799
 800       Check_Duplicated_Subunits;
 801       Check_Versions;
 802       Check_Consistency;
 803       Check_Configuration_Consistency;
 804
 805       --  List restrictions that could be applied to this partition
 806
 807       if List_Restrictions then
 808          List_Applicable_Restrictions;
 809       end if;
 810
 811       --  Complete bind if no errors
 812
 813       if Errors_Detected = 0 then
 814          Find_Elab_Order;
 815
 816          if Errors_Detected = 0 then
 817             --  Display elaboration order if -l was specified
 818
 819             if Elab_Order_Output then
 820                if not Zero_Formatting then
 821                   Write_Eol;
 822                   Write_Str ("ELABORATION ORDER");
 823                   Write_Eol;
 824                end if;
 825
 826                for J in Elab_Order.First .. Elab_Order.Last loop
 827                   if not Units.Table (Elab_Order.Table (J)).SAL_Interface then
 828                      if not Zero_Formatting then
 829                         Write_Str ("   ");
 830                      end if;
 831
 832                      Write_Unit_Name
 833                        (Units.Table (Elab_Order.Table (J)).Uname);
 834                      Write_Eol;
 835                   end if;
 836                end loop;
 837
 838                if not Zero_Formatting then
 839                   Write_Eol;
 840                end if;
 841             end if;
 842
 843             if not Check_Only then
 844                Gen_Output_File (Output_File_Name.all);
 845             end if;
 846
 847             --  Display list of sources in the closure (except predefined
 848             --  sources) if -R was used.
 849
 850             if List_Closure then
 851                List_Closure_Display : declare
 852                   Source : File_Name_Type;
 853
 854                   function Put_In_Sources (S : File_Name_Type) return Boolean;
 855                   --  Check if S is already in table Sources and put in Sources
 856                   --  if it is not. Return False if the source is already in
 857                   --  Sources, and True if it is added.
 858
 859                   --------------------
 860                   -- Put_In_Sources --
 861                   --------------------
 862
 863                   function Put_In_Sources
 864                     (S : File_Name_Type) return Boolean is
 865                   begin
 866                      for J in 1 .. Closure_Sources.Last loop
 867                         if Closure_Sources.Table (J) = S then
 868                            return False;
 869                         end if;
 870                      end loop;
 871
 872                      Closure_Sources.Append (S);
 873                      return True;
 874                   end Put_In_Sources;
 875
 876                --  Start of processing for List_Closure_Display
 877
 878                begin
 879                   Closure_Sources.Init;
 880
 881                   if not Zero_Formatting then
 882                      Write_Eol;
 883                      Write_Str ("REFERENCED SOURCES");
 884                      Write_Eol;
 885                   end if;
 886
 887                   for J in reverse Elab_Order.First .. Elab_Order.Last loop
 888                      Source := Units.Table (Elab_Order.Table (J)).Sfile;
 889
 890                      --  Do not include the sources of the runtime and do not
 891                      --  include the same source several times.
 892
 893                      if Put_In_Sources (Source)
 894                        and then not Is_Internal_File_Name (Source)
 895                      then
 896                         if not Zero_Formatting then
 897                            Write_Str ("   ");
 898                         end if;
 899
 900                         Write_Str (Get_Name_String (Source));
 901                         Write_Eol;
 902                      end if;
 903                   end loop;
 904
 905                   --  Subunits do not appear in the elaboration table because
 906                   --  they are subsumed by their parent units, but we need to
 907                   --  list them for other tools. For now they are listed after
 908                   --  other files, rather than right after their parent, since
 909                   --  there is no easy link between the elaboration table and
 910                   --  the ALIs table ??? As subunits may appear repeatedly in
 911                   --  the list, if the parent unit appears in the context of
 912                   --  several units in the closure, duplicates are suppressed.
 913
 914                   for J in Sdep.First .. Sdep.Last loop
 915                      Source := Sdep.Table (J).Sfile;
 916
 917                      if Sdep.Table (J).Subunit_Name /= No_Name
 918                        and then Put_In_Sources (Source)
 919                        and then not Is_Internal_File_Name (Source)
 920                      then
 921                         if not Zero_Formatting then
 922                            Write_Str ("   ");
 923                         end if;
 924
 925                         Write_Str (Get_Name_String (Source));
 926                         Write_Eol;
 927                      end if;
 928                   end loop;
 929
 930                   if not Zero_Formatting then
 931                      Write_Eol;
 932                   end if;
 933                end List_Closure_Display;
 934             end if;
 935          end if;
 936       end if;
 937
 938       Total_Errors := Total_Errors + Errors_Detected;
 939       Total_Warnings := Total_Warnings + Warnings_Detected;
 940
 941    exception
 942       when Unrecoverable_Error =>
 943          Total_Errors := Total_Errors + Errors_Detected;
 944          Total_Warnings := Total_Warnings + Warnings_Detected;
 945    end;
 946
 947    --  All done. Set proper exit status
 948
 949    Finalize_Binderr;
 950    Namet.Finalize;
 951
 952    if Total_Errors > 0 then
 953       Exit_Program (E_Errors);
 954
 955    elsif Total_Warnings > 0 then
 956       Exit_Program (E_Warnings);
 957
 958    else
 959       --  Do not call Exit_Program (E_Success), so that finalization occurs
 960       --  normally.
 961
 962       null;
 963    end if;
 964 end Gnatbind;