gcc/ada/bindgen.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              B I N D G E N                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with ALI;         use ALI;
  28 with Binde;       use Binde;
  29 with Casing;      use Casing;
  30 with Fname;       use Fname;
  31 with GNAT.OS_Lib; use GNAT.OS_Lib;
  32 with Gnatvsn;     use Gnatvsn;
  33 with Hostparm;
  34 with Namet;       use Namet;
  35 with Opt;         use Opt;
  36 with Osint;       use Osint;
  37 with Osint.B;     use Osint.B;
  38 with Output;      use Output;
  39 with Rident;      use Rident;
  40 with Table;       use Table;
  41 with Targparm;    use Targparm;
  42 with Types;       use Types;
  43
  44 with GNAT.Heap_Sort_A;     use GNAT.Heap_Sort_A;
  45
  46 package body Bindgen is
  47
  48    Statement_Buffer : String (1 .. 1000);
  49    --  Buffer used for constructing output statements
  50
  51    Last : Natural := 0;
  52    --  Last location in Statement_Buffer currently set
  53
  54    With_DECGNAT : Boolean := False;
  55    --  Flag which indicates whether the program uses the DECGNAT library
  56    --  (presence of the unit DEC).
  57
  58    With_GNARL : Boolean := False;
  59    --  Flag which indicates whether the program uses the GNARL library
  60    --  (presence of the unit System.OS_Interface)
  61
  62    Num_Elab_Calls : Nat := 0;
  63    --  Number of generated calls to elaboration routines
  64
  65    ----------------------------------
  66    -- Interface_State Pragma Table --
  67    ----------------------------------
  68
  69    --  This table assembles the interface state pragma information from
  70    --  all the units in the partition. Note that Bcheck has already checked
  71    --  that the information is consistent across partitions. The entries
  72    --  in this table are n/u/r/s for not set/user/runtime/system.
  73
  74    package IS_Pragma_Settings is new Table.Table (
  75      Table_Component_Type => Character,
  76      Table_Index_Type     => Int,
  77      Table_Low_Bound      => 0,
  78      Table_Initial        => 100,
  79      Table_Increment      => 200,
  80      Table_Name           => "IS_Pragma_Settings");
  81
  82    ----------------------
  83    -- Run-Time Globals --
  84    ----------------------
  85
  86    --  This section documents the global variables that are passed to the
  87    --  run time from the generated binder file. The call that is made is
  88    --  to the routine Set_Globals, which has the following spec:
  89
  90    --   procedure Set_Globals
  91    --     (Main_Priority            : Integer;
  92    --      Time_Slice_Value         : Integer;
  93    --      WC_Encoding              : Character;
  94    --      Locking_Policy           : Character;
  95    --      Queuing_Policy           : Character;
  96    --      Task_Dispatching_Policy  : Character;
  97    --      Restrictions             : System.Address;
  98    --      Interrupt_States         : System.Address;
  99    --      Num_Interrupt_States     : Integer;
 100    --      Unreserve_All_Interrupts : Integer;
 101    --      Exception_Tracebacks     : Integer;
 102    --      Zero_Cost_Exceptions     : Integer;
 103    --      Detect_Blocking          : Integer);
 104
 105    --  Main_Priority is the priority value set by pragma Priority in the
 106    --  main program. If no such pragma is present, the value is -1.
 107
 108    --  Time_Slice_Value is the time slice value set by pragma Time_Slice
 109    --  in the main program, or by the use of a -Tnnn parameter for the
 110    --  binder (if both are present, the binder value overrides). The
 111    --  value is in milliseconds. A value of zero indicates that time
 112    --  slicing should be suppressed. If no pragma is present, and no
 113    --  -T switch was used, the value is -1.
 114
 115    --  WC_Encoding shows the wide character encoding method used for
 116    --  the main program. This is one of the encoding letters defined
 117    --  in System.WCh_Con.WC_Encoding_Letters.
 118
 119    --  Locking_Policy is a space if no locking policy was specified
 120    --  for the partition. If a locking policy was specified, the value
 121    --  is the upper case first character of the locking policy name,
 122    --  for example, 'C' for Ceiling_Locking.
 123
 124    --  Queuing_Policy is a space if no queuing policy was specified
 125    --  for the partition. If a queuing policy was specified, the value
 126    --  is the upper case first character of the queuing policy name
 127    --  for example, 'F' for FIFO_Queuing.
 128
 129    --  Task_Dispatching_Policy is a space if no task dispatching policy
 130    --  was specified for the partition. If a task dispatching policy
 131    --  was specified, the value is the upper case first character of
 132    --  the policy name, e.g. 'F' for FIFO_Within_Priorities.
 133
 134    --  Restrictions is the address of a null-terminated string specifying the
 135    --  restrictions information for the partition. The format is identical to
 136    --  that of the parameter string found on R lines in ali files (see Lib.Writ
 137    --  spec in lib-writ.ads for full details). The difference is that in this
 138    --  context the values are the cumulative ones for the entire partition.
 139
 140    --  Interrupt_States is the address of a string used to specify the
 141    --  cumulative results of Interrupt_State pragmas used in the partition.
 142    --  The length of this string is determined by the last interrupt for which
 143    --  such a pragma is given (the string will be a null string if no pragmas
 144    --  were used). If pragma were present the entries apply to the interrupts
 145    --  in sequence from the first interrupt, and are set to one of four
 146    --  possible settings: 'n' for not specified, 'u' for user, 'r' for
 147    --  run time, 's' for system, see description of Interrupt_State pragma
 148    --  for further details.
 149
 150    --  Num_Interrupt_States is the length of the Interrupt_States string.
 151    --  It will be set to zero if no Interrupt_State pragmas are present.
 152
 153    --  Unreserve_All_Interrupts is set to one if at least one unit in the
 154    --  partition had a pragma Unreserve_All_Interrupts, and zero otherwise.
 155
 156    --  Exception_Tracebacks is set to one if the -E parameter was present
 157    --  in the bind and to zero otherwise. Note that on some targets exception
 158    --  tracebacks are provided by default, so a value of zero for this
 159    --  parameter does not necessarily mean no trace backs are available.
 160
 161    --  Zero_Cost_Exceptions is set to one if zero cost exceptions are used for
 162    --  this partition, and to zero if longjmp/setjmp exceptions are used.
 163    --  the use of zero
 164
 165    --  Detect_Blocking indicates whether pragma Detect_Blocking is
 166    --  active or not. A value of zero indicates that the pragma is not
 167    --  present, while a value of 1 signals its presence in the
 168    --  partition.
 169
 170    -----------------------
 171    -- Local Subprograms --
 172    -----------------------
 173
 174    procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
 175    --  Convenient shorthand used throughout
 176
 177    procedure Gen_Adainit_Ada;
 178    --  Generates the Adainit procedure (Ada code case)
 179
 180    procedure Gen_Adainit_C;
 181    --  Generates the Adainit procedure (C code case)
 182
 183    procedure Gen_Adafinal_Ada;
 184    --  Generate the Adafinal procedure (Ada code case)
 185
 186    procedure Gen_Adafinal_C;
 187    --  Generate the Adafinal procedure (C code case)
 188
 189    procedure Gen_Elab_Calls_Ada;
 190    --  Generate sequence of elaboration calls (Ada code case)
 191
 192    procedure Gen_Elab_Calls_C;
 193    --  Generate sequence of elaboration calls (C code case)
 194
 195    procedure Gen_Elab_Order_Ada;
 196    --  Generate comments showing elaboration order chosen (Ada case)
 197
 198    procedure Gen_Elab_Order_C;
 199    --  Generate comments showing elaboration order chosen (C case)
 200
 201    procedure Gen_Elab_Defs_C;
 202    --  Generate sequence of definitions for elaboration routines (C code case)
 203
 204    procedure Gen_Exception_Table_Ada;
 205    --  Generate binder exception table (Ada code case). This consists of
 206    --  declarations followed by a begin followed by a call. If zero cost
 207    --  exceptions are not active, then only the begin is generated.
 208
 209    procedure Gen_Exception_Table_C;
 210    --  Generate binder exception table (C code case). This has no effect
 211    --  if zero cost exceptions are not active, otherwise it generates a
 212    --  set of declarations followed by a call.
 213
 214    procedure Gen_Main_Ada;
 215    --  Generate procedure main (Ada code case)
 216
 217    procedure Gen_Main_C;
 218    --  Generate main() procedure (C code case)
 219
 220    procedure Gen_Object_Files_Options;
 221    --  Output comments containing a list of the full names of the object
 222    --  files to be linked and the list of linker options supplied by
 223    --  Linker_Options pragmas in the source. (C and Ada code case)
 224
 225    procedure Gen_Output_File_Ada (Filename : String);
 226    --  Generate output file (Ada code case)
 227
 228    procedure Gen_Output_File_C (Filename : String);
 229    --  Generate output file (C code case)
 230
 231    procedure Gen_Restrictions_String_1;
 232    --  Generate first restrictions string, which consists of the parameters
 233    --  the first R line, as described in lib-writ.ads, with the restrictions
 234    --  being those for the entire partition (from Cumulative_Restrictions).
 235
 236    procedure Gen_Restrictions_String_2;
 237    --  Generate first restrictions string, which consists of the parameters
 238    --  the second R line, as described in lib-writ.ads, with the restrictions
 239    --  being those for the entire partition (from Cumulative_Restrictions).
 240
 241    procedure Gen_Versions_Ada;
 242    --  Output series of definitions for unit versions (Ada code case)
 243
 244    procedure Gen_Versions_C;
 245    --  Output series of definitions for unit versions (C code case)
 246
 247    function Get_Ada_Main_Name return String;
 248    --  This function is used in the Ada main output case to compute a usable
 249    --  name for the generated main program. The normal main program name is
 250    --  Ada_Main, but this won't work if the user has a unit with this name.
 251    --  This function tries Ada_Main first, and if there is such a clash, then
 252    --  it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.
 253
 254    function Get_Main_Name return String;
 255    --  This function is used in the Ada main output case to compute the
 256    --  correct external main program. It is "main" by default, unless the
 257    --  flag Use_Ada_Main_Program_Name_On_Target is set, in which case it
 258    --  is the name of the Ada main name without the "_ada". This default
 259    --  can be overridden explicitly using the -Mname binder switch.
 260
 261    function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
 262    --  Compare linker options, when sorting, first according to
 263    --  Is_Internal_File (internal files come later) and then by
 264    --  elaboration order position (latest to earliest).
 265
 266    procedure Move_Linker_Option (From : Natural; To : Natural);
 267    --  Move routine for sorting linker options
 268
 269    procedure Public_Version_Warning;
 270    --  Emit a warning concerning the use of the Public version under
 271    --  certain circumstances. See details in body.
 272
 273    procedure Resolve_Binder_Options;
 274    --  Set the value of With_GNARL and With_DECGNAT. The latter only on VMS
 275    --  since it tests for a package named "dec" which might cause a conflict
 276    --  on non-VMS systems.
 277
 278    procedure Set_Char (C : Character);
 279    --  Set given character in Statement_Buffer at the Last + 1 position
 280    --  and increment Last by one to reflect the stored character.
 281
 282    procedure Set_EA_Last;
 283    --  Output the number of elements in array EA
 284
 285    procedure Set_Int (N : Int);
 286    --  Set given value in decimal in Statement_Buffer with no spaces
 287    --  starting at the Last + 1 position, and updating Last past the value.
 288    --  A minus sign is output for a negative value.
 289
 290    procedure Set_IS_Pragma_Table;
 291    --  Initializes contents of IS_Pragma_Settings table from ALI table
 292
 293    procedure Set_Main_Program_Name;
 294    --  Given the main program name in Name_Buffer (length in Name_Len)
 295    --  generate the name of the routine to be used in the call. The name
 296    --  is generated starting at Last + 1, and Last is updated past it.
 297
 298    procedure Set_Name_Buffer;
 299    --  Set the value stored in positions 1 .. Name_Len of the Name_Buffer.
 300
 301    procedure Set_String (S : String);
 302    --  Sets characters of given string in Statement_Buffer, starting at the
 303    --  Last + 1 position, and updating last past the string value.
 304
 305    procedure Set_Unit_Name;
 306    --  Given a unit name in the Name_Buffer, copies it to Statement_Buffer,
 307    --  starting at the Last + 1 position, and updating last past the value.
 308    --  changing periods to double underscores, and updating Last appropriately.
 309
 310    procedure Set_Unit_Number (U : Unit_Id);
 311    --  Sets unit number (first unit is 1, leading zeroes output to line
 312    --  up all output unit numbers nicely as required by the value, and
 313    --  by the total number of units.
 314
 315    procedure Tab_To (N : Natural);
 316    --  If Last is greater than or equal to N, no effect, otherwise store
 317    --  blanks in Statement_Buffer bumping Last, until Last = N.
 318
 319    procedure Write_Info_Ada_C (Ada : String; C : String; Common : String);
 320    --  For C code case, write C & Common, for Ada case write Ada & Common
 321    --  to current binder output file using Write_Binder_Info.
 322
 323    procedure Write_Statement_Buffer;
 324    --  Write out contents of statement buffer up to Last, and reset Last to 0
 325
 326    procedure Write_Statement_Buffer (S : String);
 327    --  First writes its argument (using Set_String (S)), then writes out the
 328    --  contents of statement buffer up to Last, and reset Last to 0
 329
 330    ----------------------
 331    -- Gen_Adafinal_Ada --
 332    ----------------------
 333
 334    procedure Gen_Adafinal_Ada is
 335    begin
 336       WBI ("");
 337       WBI ("   procedure " & Ada_Final_Name.all & " is");
 338       WBI ("   begin");
 339
 340       --  If compiling for the JVM, we directly call Adafinal because
 341       --  we don't import it via Do_Finalize (see Gen_Output_File_Ada).
 342
 343       if Hostparm.Java_VM then
 344          WBI ("      System.Standard_Library.Adafinal;");
 345
 346       --  If there is no finalization, there is nothing to do
 347
 348       elsif Cumulative_Restrictions.Set (No_Finalization) then
 349          WBI ("      null;");
 350       else
 351          WBI ("      Do_Finalize;");
 352       end if;
 353
 354       WBI ("   end " & Ada_Final_Name.all & ";");
 355    end Gen_Adafinal_Ada;
 356
 357    --------------------
 358    -- Gen_Adafinal_C --
 359    --------------------
 360
 361    procedure Gen_Adafinal_C is
 362    begin
 363       WBI ("void " & Ada_Final_Name.all & " () {");
 364       WBI ("   system__standard_library__adafinal ();");
 365       WBI ("}");
 366       WBI ("");
 367    end Gen_Adafinal_C;
 368
 369    ---------------------
 370    -- Gen_Adainit_Ada --
 371    ---------------------
 372
 373    procedure Gen_Adainit_Ada is
 374       Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
 375
 376    begin
 377       WBI ("   procedure " & Ada_Init_Name.all & " is");
 378
 379       --  Generate externals for elaboration entities
 380
 381       for E in Elab_Order.First .. Elab_Order.Last loop
 382          declare
 383             Unum : constant Unit_Id := Elab_Order.Table (E);
 384             U    : Unit_Record renames Units.Table (Unum);
 385
 386          begin
 387             --  Check for Elab_Entity to be set for this unit
 388
 389             if U.Set_Elab_Entity
 390
 391             --  Don't generate reference for stand alone library
 392
 393               and then not U.SAL_Interface
 394
 395             --  Don't generate reference for predefined file in No_Run_Time
 396             --  mode, since we don't include the object files in this case
 397
 398               and then not
 399                 (No_Run_Time_Mode
 400                    and then Is_Predefined_File_Name (U.Sfile))
 401             then
 402                Set_String ("      ");
 403                Set_String ("E");
 404                Set_Unit_Number (Unum);
 405                Set_String (" : Boolean; pragma Import (Ada, ");
 406                Set_String ("E");
 407                Set_Unit_Number (Unum);
 408                Set_String (", """);
 409                Get_Name_String (U.Uname);
 410
 411                --  In the case of JGNAT we need to emit an Import name
 412                --  that includes the class name (using '$' separators
 413                --  in the case of a child unit name).
 414
 415                if Hostparm.Java_VM then
 416                   for J in 1 .. Name_Len - 2 loop
 417                      if Name_Buffer (J) /= '.' then
 418                         Set_Char (Name_Buffer (J));
 419                      else
 420                         Set_String ("$");
 421                      end if;
 422                   end loop;
 423
 424                   Set_String (".");
 425
 426                   --  If the unit name is very long, then split the
 427                   --  Import link name across lines using "&" (occurs
 428                   --  in some C2 tests).
 429
 430                   if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then
 431                      Set_String (""" &");
 432                      Write_Statement_Buffer;
 433                      Set_String ("         """);
 434                   end if;
 435                end if;
 436
 437                Set_Unit_Name;
 438                Set_String ("_E"");");
 439                Write_Statement_Buffer;
 440             end if;
 441          end;
 442       end loop;
 443
 444       Write_Statement_Buffer;
 445
 446       --  If the standard library is suppressed, then the only global variable
 447       --  that might be needed (by the Ravenscar profile) is the priority of
 448       --  the environment. Also no exception tables are needed.
 449
 450       if Suppress_Standard_Library_On_Target then
 451          if Main_Priority /= No_Main_Priority then
 452             WBI ("      Main_Priority : Integer;");
 453             WBI ("      pragma Import (C, Main_Priority," &
 454                  " ""__gl_main_priority"");");
 455             WBI ("");
 456          end if;
 457
 458          WBI ("   begin");
 459
 460          if Main_Priority /= No_Main_Priority then
 461             Set_String ("      Main_Priority := ");
 462             Set_Int    (Main_Priority);
 463             Set_Char   (';');
 464             Write_Statement_Buffer;
 465
 466          else
 467             WBI ("      null;");
 468          end if;
 469
 470       --  Normal case (standard library not suppressed). Global values are
 471       --  assigned using the runtime routine Set_Globals (we have to use
 472       --  the routine call, rather than define the globals in the binder
 473       --  file to deal with cross-library calls in some systems.
 474
 475       else
 476          --  Generate restrictions string
 477
 478          Set_String ("      Restrictions : constant String :=");
 479          Write_Statement_Buffer;
 480
 481          Set_String ("        """);
 482          Gen_Restrictions_String_1;
 483          Set_String (""" &");
 484          Write_Statement_Buffer;
 485
 486          Set_String ("        """);
 487          Gen_Restrictions_String_2;
 488          Set_String (""" & ASCII.Nul;");
 489          Write_Statement_Buffer;
 490          WBI ("");
 491
 492          --  Generate Interrupt_State pragma string
 493
 494          Set_String ("      Interrupt_States : constant String :=");
 495          Write_Statement_Buffer;
 496
 497          declare
 498             Col : Natural;
 499
 500          begin
 501             Set_String ("        """);
 502             Col := 9;
 503
 504             for J in 0 .. IS_Pragma_Settings.Last loop
 505                if Col > 72 then
 506                   Set_String (""" &");
 507                   Write_Statement_Buffer;
 508                   Set_String ("        """);
 509                   Col := 9;
 510
 511                else
 512                   Col := Col + 1;
 513                end if;
 514
 515                Set_Char (IS_Pragma_Settings.Table (J));
 516             end loop;
 517          end;
 518
 519          Set_String (""";");
 520          Write_Statement_Buffer;
 521          WBI ("");
 522
 523          --  Generate spec for Set_Globals procedure
 524
 525          WBI ("      procedure Set_Globals");
 526          WBI ("        (Main_Priority            : Integer;");
 527          WBI ("         Time_Slice_Value         : Integer;");
 528          WBI ("         WC_Encoding              : Character;");
 529          WBI ("         Locking_Policy           : Character;");
 530          WBI ("         Queuing_Policy           : Character;");
 531          WBI ("         Task_Dispatching_Policy  : Character;");
 532
 533          WBI ("         Restrictions             : System.Address;");
 534          WBI ("         Interrupt_States         : System.Address;");
 535          WBI ("         Num_Interrupt_States     : Integer;");
 536          WBI ("         Unreserve_All_Interrupts : Integer;");
 537          WBI ("         Exception_Tracebacks     : Integer;");
 538          WBI ("         Zero_Cost_Exceptions     : Integer;");
 539          WBI ("         Detect_Blocking          : Integer);");
 540          WBI ("      pragma Import (C, Set_Globals, ""__gnat_set_globals"");");
 541
 542          --  Import entry point for elaboration time signal handler
 543          --  installation, and indication of if it's been called previously.
 544
 545          WBI ("");
 546          WBI ("      procedure Install_Handler;");
 547          WBI ("      pragma Import (C, Install_Handler, " &
 548               """__gnat_install_handler"");");
 549          WBI ("");
 550          WBI ("      Handler_Installed : Integer;");
 551          WBI ("      pragma Import (C, Handler_Installed, " &
 552               """__gnat_handler_installed"");");
 553
 554          --  Generate exception table
 555
 556          Gen_Exception_Table_Ada;
 557
 558          --  Generate the call to Set_Globals
 559
 560          WBI ("      Set_Globals");
 561
 562          Set_String ("        (Main_Priority            => ");
 563          Set_Int    (Main_Priority);
 564          Set_Char   (',');
 565          Write_Statement_Buffer;
 566
 567          Set_String ("         Time_Slice_Value         => ");
 568
 569          if Task_Dispatching_Policy_Specified = 'F'
 570            and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
 571          then
 572             Set_Int (0);
 573          else
 574             Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
 575          end if;
 576
 577          Set_Char   (',');
 578          Write_Statement_Buffer;
 579
 580          Set_String ("         WC_Encoding              => '");
 581          Set_Char   (ALIs.Table (ALIs.First).WC_Encoding);
 582          Set_String ("',");
 583          Write_Statement_Buffer;
 584
 585          Set_String ("         Locking_Policy           => '");
 586          Set_Char   (Locking_Policy_Specified);
 587          Set_String ("',");
 588          Write_Statement_Buffer;
 589
 590          Set_String ("         Queuing_Policy           => '");
 591          Set_Char   (Queuing_Policy_Specified);
 592          Set_String ("',");
 593          Write_Statement_Buffer;
 594
 595          Set_String ("         Task_Dispatching_Policy  => '");
 596          Set_Char   (Task_Dispatching_Policy_Specified);
 597          Set_String ("',");
 598          Write_Statement_Buffer;
 599
 600          WBI ("         Restrictions             => Restrictions'Address,");
 601
 602          WBI ("         Interrupt_States         => " &
 603                                                  "Interrupt_States'Address,");
 604
 605          Set_String ("         Num_Interrupt_States     => ");
 606          Set_Int (IS_Pragma_Settings.Last + 1);
 607          Set_Char (',');
 608          Write_Statement_Buffer;
 609
 610          Set_String ("         Unreserve_All_Interrupts => ");
 611
 612          if Unreserve_All_Interrupts_Specified then
 613             Set_String ("1");
 614          else
 615             Set_String ("0");
 616          end if;
 617
 618          Set_Char (',');
 619          Write_Statement_Buffer;
 620
 621          Set_String ("         Exception_Tracebacks     => ");
 622
 623          if Exception_Tracebacks then
 624             Set_String ("1");
 625          else
 626             Set_String ("0");
 627          end if;
 628
 629          Set_String (",");
 630          Write_Statement_Buffer;
 631
 632          Set_String ("         Zero_Cost_Exceptions     => ");
 633
 634          if Zero_Cost_Exceptions_Specified then
 635             Set_String ("1");
 636          else
 637             Set_String ("0");
 638          end if;
 639
 640          Set_String (",");
 641          Write_Statement_Buffer;
 642
 643          Set_String ("         Detect_Blocking          => ");
 644
 645          if Detect_Blocking then
 646             Set_Int (1);
 647          else
 648             Set_Int (0);
 649          end if;
 650
 651          Set_String (");");
 652          Write_Statement_Buffer;
 653
 654          --  Generate call to Install_Handler
 655
 656          WBI ("");
 657          WBI ("      if Handler_Installed = 0 then");
 658          WBI ("         Install_Handler;");
 659          WBI ("      end if;");
 660       end if;
 661
 662       --  Generate call to set Initialize_Scalar values if active
 663
 664       if Initialize_Scalars_Used then
 665          WBI ("");
 666          Set_String ("      System.Scalar_Values.Initialize ('");
 667          Set_Char (Initialize_Scalars_Mode1);
 668          Set_String ("', '");
 669          Set_Char (Initialize_Scalars_Mode2);
 670          Set_String ("');");
 671          Write_Statement_Buffer;
 672       end if;
 673
 674       --  Generate assignment of default secondary stack size if set
 675
 676       if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
 677          WBI ("");
 678          Set_String ("      System.Secondary_Stack.");
 679          Set_String ("Default_Secondary_Stack_Size := ");
 680          Set_Int (Opt.Default_Sec_Stack_Size);
 681          Set_Char (';');
 682          Write_Statement_Buffer;
 683       end if;
 684
 685       --  Generate elaboration calls
 686
 687       WBI ("");
 688       Gen_Elab_Calls_Ada;
 689
 690       WBI ("   end " & Ada_Init_Name.all & ";");
 691    end Gen_Adainit_Ada;
 692
 693    -------------------
 694    -- Gen_Adainit_C --
 695    --------------------
 696
 697    procedure Gen_Adainit_C is
 698       Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
 699
 700    begin
 701       WBI ("void " & Ada_Init_Name.all & " (void)");
 702       WBI ("{");
 703
 704       --  Generate externals for elaboration entities
 705
 706       for E in Elab_Order.First .. Elab_Order.Last loop
 707          declare
 708             Unum : constant Unit_Id := Elab_Order.Table (E);
 709             U    : Unit_Record renames Units.Table (Unum);
 710
 711          begin
 712             --  Check for Elab entity to be set for this unit
 713
 714             if U.Set_Elab_Entity
 715
 716             --  Don't generate reference for stand alone library
 717
 718               and then not U.SAL_Interface
 719
 720             --  Don't generate reference for predefined file in No_Run_Time
 721             --  mode, since we don't include the object files in this case
 722
 723               and then not
 724                 (No_Run_Time_Mode
 725                    and then Is_Predefined_File_Name (U.Sfile))
 726             then
 727                Set_String ("   extern char ");
 728                Get_Name_String (U.Uname);
 729                Set_Unit_Name;
 730                Set_String ("_E;");
 731                Write_Statement_Buffer;
 732             end if;
 733          end;
 734       end loop;
 735
 736       Write_Statement_Buffer;
 737
 738       --  Standard library suppressed
 739
 740       if Suppress_Standard_Library_On_Target then
 741
 742          --  Case of High_Integrity_Mode mode. Set __gl_main_priority if needed
 743          --  for the Ravenscar profile.
 744
 745          if Main_Priority /= No_Main_Priority then
 746             Set_String ("   extern int __gl_main_priority = ");
 747             Set_Int    (Main_Priority);
 748             Set_Char   (';');
 749             Write_Statement_Buffer;
 750          end if;
 751
 752       --  Normal case (standard library not suppressed)
 753
 754       else
 755          --  Generate definition for restrictions string
 756
 757          Set_String ("   const char *restrictions = """);
 758          Gen_Restrictions_String_1;
 759          Gen_Restrictions_String_2;
 760          Set_String (""";");
 761          Write_Statement_Buffer;
 762
 763          --  Generate definition for interrupt states string
 764
 765          Set_String ("   const char *interrupt_states = """);
 766
 767          for J in 0 .. IS_Pragma_Settings.Last loop
 768             Set_Char (IS_Pragma_Settings.Table (J));
 769          end loop;
 770
 771          Set_String (""";");
 772          Write_Statement_Buffer;
 773
 774          --  Generate declaration for secondary stack default if needed
 775
 776          if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
 777             WBI ("   extern int system__secondary_stack__" &
 778                  "default_secondary_stack_size;");
 779          end if;
 780
 781          WBI ("");
 782
 783          --  Code for normal case (standard library not suppressed)
 784
 785          Gen_Exception_Table_C;
 786
 787          --  Generate call to set the runtime global variables defined in
 788          --  a-init.c. We define the varables in a-init.c, rather than in
 789          --  the binder generated file itself to avoid undefined externals
 790          --  when the runtime is linked as a shareable image library.
 791
 792          --  We call the routine from inside adainit() because this works for
 793          --  both programs with and without binder generated "main" functions.
 794
 795          WBI ("   __gnat_set_globals (");
 796
 797          Set_String ("      ");
 798          Set_Int (Main_Priority);
 799          Set_Char (',');
 800          Tab_To (24);
 801          Set_String ("/* Main_Priority              */");
 802          Write_Statement_Buffer;
 803
 804          Set_String ("      ");
 805
 806          if Task_Dispatching_Policy = 'F'
 807            and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
 808          then
 809             Set_Int (0);
 810          else
 811             Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
 812          end if;
 813
 814          Set_Char   (',');
 815          Tab_To (24);
 816          Set_String ("/* Time_Slice_Value           */");
 817          Write_Statement_Buffer;
 818
 819          Set_String ("      '");
 820          Set_Char   (ALIs.Table (ALIs.First).WC_Encoding);
 821          Set_String ("',");
 822          Tab_To (24);
 823          Set_String ("/* WC_Encoding                */");
 824          Write_Statement_Buffer;
 825
 826          Set_String ("      '");
 827          Set_Char (Locking_Policy_Specified);
 828          Set_String ("',");
 829          Tab_To (24);
 830          Set_String ("/* Locking_Policy             */");
 831          Write_Statement_Buffer;
 832
 833          Set_String ("      '");
 834          Set_Char (Queuing_Policy_Specified);
 835          Set_String ("',");
 836          Tab_To (24);
 837          Set_String ("/* Queuing_Policy             */");
 838          Write_Statement_Buffer;
 839
 840          Set_String ("      '");
 841          Set_Char (Task_Dispatching_Policy_Specified);
 842          Set_String ("',");
 843          Tab_To (24);
 844          Set_String ("/* Tasking_Dispatching_Policy */");
 845          Write_Statement_Buffer;
 846
 847          Set_String ("      ");
 848          Set_String ("restrictions");
 849          Set_String (",");
 850          Tab_To (24);
 851          Set_String ("/* Restrictions               */");
 852          Write_Statement_Buffer;
 853
 854          Set_String ("      ");
 855          Set_String ("interrupt_states");
 856          Set_String (",");
 857          Tab_To (24);
 858          Set_String ("/* Interrupt_States           */");
 859          Write_Statement_Buffer;
 860
 861          Set_String ("      ");
 862          Set_Int (IS_Pragma_Settings.Last + 1);
 863          Set_String (",");
 864          Tab_To (24);
 865          Set_String ("/* Num_Interrupt_States       */");
 866          Write_Statement_Buffer;
 867
 868          Set_String ("      ");
 869          Set_Int    (Boolean'Pos (Unreserve_All_Interrupts_Specified));
 870          Set_String (",");
 871          Tab_To (24);
 872          Set_String ("/* Unreserve_All_Interrupts   */");
 873          Write_Statement_Buffer;
 874
 875          Set_String ("      ");
 876          Set_Int    (Boolean'Pos (Exception_Tracebacks));
 877          Set_String (",");
 878          Tab_To (24);
 879          Set_String ("/* Exception_Tracebacks       */");
 880          Write_Statement_Buffer;
 881
 882          Set_String ("      ");
 883          Set_Int    (Boolean'Pos (Zero_Cost_Exceptions_Specified));
 884          Set_String (",");
 885          Tab_To (24);
 886          Set_String ("/* Zero_Cost_Exceptions       */");
 887          Write_Statement_Buffer;
 888
 889          Set_String ("      ");
 890
 891          if Detect_Blocking then
 892             Set_Int (1);
 893          else
 894             Set_Int (0);
 895          end if;
 896
 897          Set_String (");");
 898          Tab_To (24);
 899          Set_String ("/* Detect_Blocking            */");
 900          Write_Statement_Buffer;
 901          WBI ("");
 902
 903          --  Install elaboration time signal handler
 904
 905          WBI ("   if (__gnat_handler_installed == 0)");
 906          WBI ("     {");
 907          WBI ("        __gnat_install_handler ();");
 908          WBI ("     }");
 909       end if;
 910
 911       --  Generate call to set Initialize_Scalar values if needed
 912
 913       if Initialize_Scalars_Used then
 914          WBI ("");
 915          Set_String ("      system__scalar_values__initialize('");
 916          Set_Char (Initialize_Scalars_Mode1);
 917          Set_String ("', '");
 918          Set_Char (Initialize_Scalars_Mode2);
 919          Set_String ("');");
 920          Write_Statement_Buffer;
 921       end if;
 922
 923       --  Generate assignment of default secondary stack size if set
 924
 925       if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
 926          WBI ("");
 927          Set_String ("   system__secondary_stack__");
 928          Set_String ("default_secondary_stack_size = ");
 929          Set_Int (Opt.Default_Sec_Stack_Size);
 930          Set_Char (';');
 931          Write_Statement_Buffer;
 932       end if;
 933
 934       --  Generate elaboration calls
 935
 936       WBI ("");
 937       Gen_Elab_Calls_C;
 938       WBI ("}");
 939    end Gen_Adainit_C;
 940
 941    ------------------------
 942    -- Gen_Elab_Calls_Ada --
 943    ------------------------
 944
 945    procedure Gen_Elab_Calls_Ada is
 946    begin
 947       for E in Elab_Order.First .. Elab_Order.Last loop
 948          declare
 949             Unum : constant Unit_Id := Elab_Order.Table (E);
 950             U    : Unit_Record renames Units.Table (Unum);
 951
 952             Unum_Spec : Unit_Id;
 953             --  This is the unit number of the spec that corresponds to
 954             --  this entry. It is the same as Unum except when the body
 955             --  and spec are different and we are currently processing
 956             --  the body, in which case it is the spec (Unum + 1).
 957
 958          begin
 959             if U.Utype = Is_Body then
 960                Unum_Spec := Unum + 1;
 961             else
 962                Unum_Spec := Unum;
 963             end if;
 964
 965             --  Nothing to do if predefined unit in no run time mode
 966
 967             if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
 968                null;
 969
 970             --  Case of no elaboration code
 971
 972             elsif U.No_Elab then
 973
 974                --  The only case in which we have to do something is if
 975                --  this is a body, with a separate spec, where the separate
 976                --  spec has an elaboration entity defined.
 977
 978                --  In that case, this is where we set the elaboration entity
 979                --  to True, we do not need to test if this has already been
 980                --  done, since it is quicker to set the flag than to test it.
 981
 982                if not U.SAL_Interface and then U.Utype = Is_Body
 983                  and then Units.Table (Unum_Spec).Set_Elab_Entity
 984                then
 985                   Set_String ("      E");
 986                   Set_Unit_Number (Unum_Spec);
 987                   Set_String (" := True;");
 988                   Write_Statement_Buffer;
 989                end if;
 990
 991             --  Here if elaboration code is present. If binding a library
 992             --  or if there is a non-Ada main subprogram then we generate:
 993
 994             --    if not uname_E then
 995             --       uname'elab_[spec|body];
 996             --       uname_E := True;
 997             --    end if;
 998
 999             --  Otherwise, elaboration routines are called unconditionally:
1000
1001             --    uname'elab_[spec|body];
1002             --    uname_E := True;
1003
1004             --  The uname_E assignment is skipped if this is a separate spec,
1005             --  since the assignment will be done when we process the body.
1006
1007             elsif not U.SAL_Interface then
1008                if Force_Checking_Of_Elaboration_Flags or
1009                   Interface_Library_Unit or
1010                   (not Bind_Main_Program)
1011                then
1012                   Set_String ("      if not E");
1013                   Set_Unit_Number (Unum_Spec);
1014                   Set_String (" then");
1015                   Write_Statement_Buffer;
1016                   Set_String ("   ");
1017                end if;
1018
1019                Set_String ("      ");
1020                Get_Decoded_Name_String_With_Brackets (U.Uname);
1021
1022                if Name_Buffer (Name_Len) = 's' then
1023                   Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_spec";
1024                else
1025                   Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_body";
1026                end if;
1027
1028                Name_Len := Name_Len + 8;
1029                Set_Casing (U.Icasing);
1030                Set_Name_Buffer;
1031                Set_Char (';');
1032                Write_Statement_Buffer;
1033
1034                if U.Utype /= Is_Spec then
1035                   if Force_Checking_Of_Elaboration_Flags or
1036                      Interface_Library_Unit or
1037                      (not Bind_Main_Program)
1038                   then
1039                      Set_String ("   ");
1040                   end if;
1041
1042                   Set_String ("      E");
1043                   Set_Unit_Number (Unum_Spec);
1044                   Set_String (" := True;");
1045                   Write_Statement_Buffer;
1046                end if;
1047
1048                if Force_Checking_Of_Elaboration_Flags or
1049                   Interface_Library_Unit or
1050                   (not Bind_Main_Program)
1051                then
1052                   WBI ("      end if;");
1053                end if;
1054             end if;
1055          end;
1056       end loop;
1057    end Gen_Elab_Calls_Ada;
1058
1059    ----------------------
1060    -- Gen_Elab_Calls_C --
1061    ----------------------
1062
1063    procedure Gen_Elab_Calls_C is
1064    begin
1065       for E in Elab_Order.First .. Elab_Order.Last loop
1066          declare
1067             Unum : constant Unit_Id := Elab_Order.Table (E);
1068             U    : Unit_Record renames Units.Table (Unum);
1069
1070             Unum_Spec : Unit_Id;
1071             --  This is the unit number of the spec that corresponds to
1072             --  this entry. It is the same as Unum except when the body
1073             --  and spec are different and we are currently processing
1074             --  the body, in which case it is the spec (Unum + 1).
1075
1076          begin
1077             if U.Utype = Is_Body then
1078                Unum_Spec := Unum + 1;
1079             else
1080                Unum_Spec := Unum;
1081             end if;
1082
1083             --  Nothing to do if predefined unit in no run time mode
1084
1085             if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
1086                null;
1087
1088             --  Case of no elaboration code
1089
1090             elsif U.No_Elab then
1091
1092                --  The only case in which we have to do something is if
1093                --  this is a body, with a separate spec, where the separate
1094                --  spec has an elaboration entity defined.
1095
1096                --  In that case, this is where we set the elaboration entity
1097                --  to True, we do not need to test if this has already been
1098                --  done, since it is quicker to set the flag than to test it.
1099
1100                if not U.SAL_Interface and then U.Utype = Is_Body
1101                  and then Units.Table (Unum_Spec).Set_Elab_Entity
1102                then
1103                   Set_String ("   ");
1104                   Get_Name_String (U.Uname);
1105                   Set_Unit_Name;
1106                   Set_String ("_E = 1;");
1107                   Write_Statement_Buffer;
1108                end if;
1109
1110             --  Here if elaboration code is present. If binding a library
1111             --  or if there is a non-Ada main subprogram then we generate:
1112
1113             --    if (uname_E == 0) {
1114             --       uname__elab[s|b] ();
1115             --       uname_E++;
1116             --    }
1117
1118             --  The uname_E assignment is skipped if this is a separate spec,
1119             --  since the assignment will be done when we process the body.
1120
1121             elsif not U.SAL_Interface then
1122                Get_Name_String (U.Uname);
1123
1124                if Force_Checking_Of_Elaboration_Flags or
1125                   Interface_Library_Unit or
1126                   (not Bind_Main_Program)
1127                then
1128                   Set_String ("   if (");
1129                   Set_Unit_Name;
1130                   Set_String ("_E == 0) {");
1131                   Write_Statement_Buffer;
1132                   Set_String ("   ");
1133                end if;
1134
1135                Set_String ("   ");
1136                Set_Unit_Name;
1137                Set_String ("___elab");
1138                Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1139                Set_String (" ();");
1140                Write_Statement_Buffer;
1141
1142                if U.Utype /= Is_Spec then
1143                   if Force_Checking_Of_Elaboration_Flags or
1144                      Interface_Library_Unit or
1145                      (not Bind_Main_Program)
1146                   then
1147                      Set_String ("   ");
1148                   end if;
1149
1150                   Set_String ("   ");
1151                   Set_Unit_Name;
1152                   Set_String ("_E++;");
1153                   Write_Statement_Buffer;
1154                end if;
1155
1156                if Force_Checking_Of_Elaboration_Flags or
1157                   Interface_Library_Unit or
1158                   (not Bind_Main_Program)
1159                then
1160                   WBI ("   }");
1161                end if;
1162             end if;
1163          end;
1164       end loop;
1165
1166    end Gen_Elab_Calls_C;
1167
1168    ----------------------
1169    -- Gen_Elab_Defs_C --
1170    ----------------------
1171
1172    procedure Gen_Elab_Defs_C is
1173    begin
1174       for E in Elab_Order.First .. Elab_Order.Last loop
1175
1176          --  Generate declaration of elaboration procedure if elaboration
1177          --  needed. Note that passive units are always excluded.
1178
1179          if not Units.Table (Elab_Order.Table (E)).No_Elab then
1180             Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1181             Set_String ("extern void ");
1182             Set_Unit_Name;
1183             Set_String ("___elab");
1184             Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1185             Set_String (" (void);");
1186             Write_Statement_Buffer;
1187          end if;
1188
1189       end loop;
1190
1191       WBI ("");
1192    end Gen_Elab_Defs_C;
1193
1194    ------------------------
1195    -- Gen_Elab_Order_Ada --
1196    ------------------------
1197
1198    procedure Gen_Elab_Order_Ada is
1199    begin
1200       WBI ("");
1201       WBI ("   --  BEGIN ELABORATION ORDER");
1202
1203       for J in Elab_Order.First .. Elab_Order.Last loop
1204          Set_String ("   --  ");
1205          Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1206          Set_Name_Buffer;
1207          Write_Statement_Buffer;
1208       end loop;
1209
1210       WBI ("   --  END ELABORATION ORDER");
1211    end Gen_Elab_Order_Ada;
1212
1213    ----------------------
1214    -- Gen_Elab_Order_C --
1215    ----------------------
1216
1217    procedure Gen_Elab_Order_C is
1218    begin
1219       WBI ("");
1220       WBI ("/* BEGIN ELABORATION ORDER");
1221
1222       for J in Elab_Order.First .. Elab_Order.Last loop
1223          Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
1224          Set_Name_Buffer;
1225          Write_Statement_Buffer;
1226       end loop;
1227
1228       WBI ("   END ELABORATION ORDER */");
1229    end Gen_Elab_Order_C;
1230
1231    -----------------------------
1232    -- Gen_Exception_Table_Ada --
1233    -----------------------------
1234
1235    procedure Gen_Exception_Table_Ada is
1236       Num  : Nat;
1237       Last : ALI_Id := No_ALI_Id;
1238
1239    begin
1240       if not Zero_Cost_Exceptions_Specified then
1241          WBI ("   begin");
1242          return;
1243       end if;
1244
1245       --  The code we generate looks like
1246
1247       --        procedure SDP_Table_Build
1248       --          (SDP_Addresses   : System.Address;
1249       --           SDP_Count       : Natural;
1250       --           Elab_Addresses  : System.Address;
1251       --           Elab_Addr_Count : Natural);
1252       --        pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build");
1253       --
1254       --        ST : aliased constant array (1 .. nnn) of System.Address := (
1255       --               unit_name_1'UET_Address,
1256       --               unit_name_2'UET_Address,
1257       --               ...
1258       --               unit_name_3'UET_Address,
1259       --
1260       --        EA : aliased constant array (1 .. eee) of System.Address := (
1261       --               adainit'Code_Address,
1262       --               adafinal'Code_Address,
1263       --               unit_name'elab[spec|body]'Code_Address,
1264       --               unit_name'elab[spec|body]'Code_Address,
1265       --               unit_name'elab[spec|body]'Code_Address,
1266       --               unit_name'elab[spec|body]'Code_Address);
1267       --
1268       --     begin
1269       --        SDP_Table_Build (ST'Address, nnn, EA'Address, eee);
1270
1271       Num := 0;
1272       for A in ALIs.First .. ALIs.Last loop
1273          if not ALIs.Table (A).SAL_Interface
1274            and then ALIs.Table (A).Unit_Exception_Table
1275          then
1276             Num := Num + 1;
1277             Last := A;
1278          end if;
1279       end loop;
1280
1281       if Num = 0 then
1282
1283          --  Happens with "gnatmake -a -f -gnatL ..."
1284
1285          WBI (" ");
1286          WBI ("   begin");
1287          return;
1288       end if;
1289
1290       WBI ("      procedure SDP_Table_Build");
1291       WBI ("        (SDP_Addresses   : System.Address;");
1292       WBI ("         SDP_Count       : Natural;");
1293       WBI ("         Elab_Addresses  : System.Address;");
1294       WBI ("         Elab_Addr_Count : Natural);");
1295       WBI ("      " &
1296            "pragma Import (C, SDP_Table_Build, ""__gnat_SDP_Table_Build"");");
1297
1298       WBI (" ");
1299       Set_String ("      ST : aliased constant array (1 .. ");
1300       Set_Int (Num);
1301       Set_String (") of System.Address := (");
1302
1303       if Num = 1 then
1304          Set_String ("1 => ");
1305
1306       else
1307          Write_Statement_Buffer;
1308       end if;
1309
1310       for A in ALIs.First .. ALIs.Last loop
1311          if not ALIs.Table (A).SAL_Interface
1312            and then ALIs.Table (A).Unit_Exception_Table
1313          then
1314             Get_Decoded_Name_String_With_Brackets
1315               (Units.Table (ALIs.Table (A).First_Unit).Uname);
1316             Set_Casing (Mixed_Case);
1317
1318             if Num /= 1 then
1319                Set_String ("        ");
1320             end if;
1321
1322             Set_String (Name_Buffer (1 .. Name_Len - 2));
1323             Set_String ("'UET_Address");
1324
1325             if A = Last then
1326                Set_String (");");
1327             else
1328                Set_Char (',');
1329             end if;
1330
1331             Write_Statement_Buffer;
1332          end if;
1333       end loop;
1334
1335       WBI (" ");
1336       Set_String ("      EA : aliased constant array (1 .. ");
1337       Set_EA_Last;
1338       Set_String (") of System.Address := (");
1339       Write_Statement_Buffer;
1340       Set_String ("        " & Ada_Init_Name.all & "'Code_Address");
1341
1342       --  If compiling for the JVM, we directly reference Adafinal because
1343       --  we don't import it via Do_Finalize (see Gen_Output_File_Ada).
1344
1345       if not Cumulative_Restrictions.Set (No_Finalization) then
1346          Set_Char (',');
1347          Write_Statement_Buffer;
1348
1349          if Hostparm.Java_VM then
1350             Set_String
1351               ("        System.Standard_Library.Adafinal'Code_Address");
1352          else
1353             Set_String
1354               ("        Do_Finalize'Code_Address");
1355          end if;
1356       end if;
1357
1358       for E in Elab_Order.First .. Elab_Order.Last loop
1359          Get_Decoded_Name_String_With_Brackets
1360            (Units.Table (Elab_Order.Table (E)).Uname);
1361
1362          if Units.Table (Elab_Order.Table (E)).No_Elab then
1363             null;
1364
1365          else
1366             Set_Char (',');
1367             Write_Statement_Buffer;
1368             Set_String ("        ");
1369
1370             if Name_Buffer (Name_Len) = 's' then
1371                Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
1372                                         "'elab_spec'code_address";
1373             else
1374                Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
1375                                         "'elab_body'code_address";
1376             end if;
1377
1378             Name_Len := Name_Len + 21;
1379             Set_Casing (Units.Table (Elab_Order.Table (E)).Icasing);
1380             Set_Name_Buffer;
1381          end if;
1382       end loop;
1383
1384       Set_String (");");
1385       Write_Statement_Buffer;
1386
1387       WBI (" ");
1388       WBI ("   begin");
1389
1390       Set_String ("      SDP_Table_Build (ST'Address, ");
1391       Set_Int (Num);
1392       Set_String (", EA'Address, ");
1393       Set_EA_Last;
1394       Set_String (");");
1395       Write_Statement_Buffer;
1396    end Gen_Exception_Table_Ada;
1397
1398    ---------------------------
1399    -- Gen_Exception_Table_C --
1400    ---------------------------
1401
1402    procedure Gen_Exception_Table_C is
1403       Num  : Nat;
1404       Num2 : Nat;
1405
1406    begin
1407       if not Zero_Cost_Exceptions_Specified then
1408          return;
1409       end if;
1410
1411       --  The code we generate looks like
1412
1413       --     extern void *__gnat_unitname1__SDP;
1414       --     extern void *__gnat_unitname2__SDP;
1415       --     ...
1416       --
1417       --     void **st[nnn] = {
1418       --       &__gnat_unitname1__SDP,
1419       --       &__gnat_unitname2__SDP,
1420       --       ...
1421       --       &__gnat_unitnamen__SDP};
1422       --
1423       --     extern void unitname1__elabb ();
1424       --     extern void unitname2__elabb ();
1425       --     ...
1426       --
1427       --     void (*ea[eee]) () = {
1428       --       adainit,
1429       --       adafinal,
1430       --       unitname1___elab[b,s],
1431       --       unitname2___elab[b,s],
1432       --       ...
1433       --       unitnamen___elab[b,s]};
1434       --
1435       --     __gnat_SDP_Table_Build (&st, nnn, &ea, eee);
1436
1437       Num := 0;
1438       for A in ALIs.First .. ALIs.Last loop
1439          if not ALIs.Table (A).SAL_Interface
1440            and then ALIs.Table (A).Unit_Exception_Table
1441          then
1442             Num := Num + 1;
1443
1444             Set_String ("   extern void *__gnat_");
1445             Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
1446             Set_Unit_Name;
1447             Set_String ("__SDP");
1448             Set_Char (';');
1449             Write_Statement_Buffer;
1450          end if;
1451       end loop;
1452
1453       if Num = 0 then
1454
1455          --  Happens with "gnatmake -a -f -gnatL ..."
1456
1457          return;
1458       end if;
1459
1460       WBI (" ");
1461
1462       Set_String ("   void **st[");
1463       Set_Int (Num);
1464       Set_String ("] = {");
1465       Write_Statement_Buffer;
1466
1467       Num2 := 0;
1468       for A in ALIs.First .. ALIs.Last loop
1469          if not ALIs.Table (A).SAL_Interface
1470            and then ALIs.Table (A).Unit_Exception_Table
1471          then
1472             Num2 := Num2 + 1;
1473
1474             Set_String ("     &__gnat_");
1475             Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
1476             Set_Unit_Name;
1477             Set_String ("__SDP");
1478
1479             if Num = Num2 then
1480                Set_String ("};");
1481             else
1482                Set_Char (',');
1483             end if;
1484
1485             Write_Statement_Buffer;
1486          end if;
1487       end loop;
1488
1489       WBI ("");
1490       for E in Elab_Order.First .. Elab_Order.Last loop
1491          Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1492
1493          if Units.Table (Elab_Order.Table (E)).No_Elab then
1494             null;
1495
1496          else
1497             Set_String ("   extern void ");
1498             Set_Unit_Name;
1499             Set_String ("___elab");
1500             Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1501             Set_String (" ();");
1502             Write_Statement_Buffer;
1503          end if;
1504       end loop;
1505
1506       WBI ("");
1507       Set_String ("   void (*ea[");
1508       Set_EA_Last;
1509       Set_String ("]) () = {");
1510       Write_Statement_Buffer;
1511
1512       Set_String ("     " & Ada_Init_Name.all);
1513
1514       if not Cumulative_Restrictions.Set (No_Finalization) then
1515          Set_Char (',');
1516          Write_Statement_Buffer;
1517          Set_String ("     system__standard_library__adafinal");
1518       end if;
1519
1520       for E in Elab_Order.First .. Elab_Order.Last loop
1521          Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
1522
1523          if Units.Table (Elab_Order.Table (E)).No_Elab then
1524             null;
1525
1526          else
1527             Set_Char (',');
1528             Write_Statement_Buffer;
1529             Set_String ("     ");
1530             Set_Unit_Name;
1531             Set_String ("___elab");
1532             Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
1533          end if;
1534       end loop;
1535
1536       Set_String ("};");
1537       Write_Statement_Buffer;
1538
1539       WBI (" ");
1540
1541       Set_String ("   __gnat_SDP_Table_Build (&st, ");
1542       Set_Int (Num);
1543       Set_String (", ea, ");
1544       Set_EA_Last;
1545       Set_String (");");
1546       Write_Statement_Buffer;
1547    end Gen_Exception_Table_C;
1548
1549    ------------------
1550    -- Gen_Main_Ada --
1551    ------------------
1552
1553    procedure Gen_Main_Ada is
1554    begin
1555       WBI ("");
1556
1557       if Exit_Status_Supported_On_Target then
1558          Set_String ("   function ");
1559       else
1560          Set_String ("   procedure ");
1561       end if;
1562
1563       Set_String (Get_Main_Name);
1564
1565       if Command_Line_Args_On_Target then
1566          Write_Statement_Buffer;
1567          WBI ("     (argc : Integer;");
1568          WBI ("      argv : System.Address;");
1569          WBI ("      envp : System.Address)");
1570
1571          if Exit_Status_Supported_On_Target then
1572             WBI ("      return Integer");
1573          end if;
1574
1575          WBI ("   is");
1576
1577       else
1578          if Exit_Status_Supported_On_Target then
1579             Set_String (" return Integer is");
1580          else
1581             Set_String (" is");
1582          end if;
1583
1584          Write_Statement_Buffer;
1585       end if;
1586
1587       if Opt.Default_Exit_Status /= 0
1588         and then Bind_Main_Program
1589         and then not Configurable_Run_Time_Mode
1590       then
1591          WBI ("      procedure Set_Exit_Status (Status : Integer);");
1592          WBI ("      pragma Import (C, Set_Exit_Status, " &
1593                      """__gnat_set_exit_status"");");
1594          WBI ("");
1595       end if;
1596
1597       --  Initialize and Finalize
1598
1599       if not Cumulative_Restrictions.Set (No_Finalization) then
1600          WBI ("      procedure initialize (Addr : System.Address);");
1601          WBI ("      pragma Import (C, initialize, ""__gnat_initialize"");");
1602          WBI ("");
1603          WBI ("      procedure finalize;");
1604          WBI ("      pragma Import (C, finalize, ""__gnat_finalize"");");
1605       end if;
1606
1607       --  Deal with declarations for main program case
1608
1609       if not No_Main_Subprogram then
1610
1611          --  To call the main program, we declare it using a pragma Import
1612          --  Ada with the right link name.
1613
1614          --  It might seem more obvious to "with" the main program, and call
1615          --  it in the normal Ada manner. We do not do this for three reasons:
1616
1617          --    1. It is more efficient not to recompile the main program
1618          --    2. We are not entitled to assume the source is accessible
1619          --    3. We don't know what options to use to compile it
1620
1621          --  It is really reason 3 that is most critical (indeed we used
1622          --  to generate the "with", but several regression tests failed).
1623
1624          WBI ("");
1625
1626          if ALIs.Table (ALIs.First).Main_Program = Func then
1627             WBI ("      Result : Integer;");
1628             WBI ("");
1629             WBI ("      function Ada_Main_Program return Integer;");
1630
1631          else
1632             WBI ("      procedure Ada_Main_Program;");
1633          end if;
1634
1635          Set_String ("      pragma Import (Ada, Ada_Main_Program, """);
1636          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1637          Set_Main_Program_Name;
1638          Set_String (""");");
1639
1640          Write_Statement_Buffer;
1641          WBI ("");
1642
1643          if Bind_Main_Program
1644            and then not Suppress_Standard_Library_On_Target
1645          then
1646             WBI ("      SEH : aliased array (1 .. 2) of Integer;");
1647             WBI ("");
1648          end if;
1649       end if;
1650
1651       --  Generate a reference to Ada_Main_Program_Name. This symbol is
1652       --  not referenced elsewhere in the generated program, but is needed
1653       --  by the debugger (that's why it is generated in the first place).
1654       --  The reference stops Ada_Main_Program_Name from being optimized
1655       --  away by smart linkers, such as the AiX linker.
1656
1657       if Bind_Main_Program then
1658          WBI
1659            ("      Ensure_Reference : System.Address := " &
1660             "Ada_Main_Program_Name'Address;");
1661          WBI ("");
1662       end if;
1663
1664       WBI ("   begin");
1665
1666       --  Acquire command line arguments if present on target
1667
1668       if Command_Line_Args_On_Target then
1669          WBI ("      gnat_argc := argc;");
1670          WBI ("      gnat_argv := argv;");
1671          WBI ("      gnat_envp := envp;");
1672          WBI ("");
1673
1674       --  If configurable run time and no command line args, then nothing
1675       --  needs to be done since the gnat_argc/argv/envp variables are
1676       --  suppressed in this case.
1677
1678       elsif Configurable_Run_Time_On_Target then
1679          null;
1680
1681       --  Otherwise set dummy values (to be filled in by some other unit?)
1682
1683       else
1684          WBI ("      gnat_argc := 0;");
1685          WBI ("      gnat_argv := System.Null_Address;");
1686          WBI ("      gnat_envp := System.Null_Address;");
1687       end if;
1688
1689       if Opt.Default_Exit_Status /= 0
1690         and then Bind_Main_Program
1691         and then not Configurable_Run_Time_Mode
1692       then
1693          Set_String ("      Set_Exit_Status (");
1694          Set_Int (Opt.Default_Exit_Status);
1695          Set_String (");");
1696          Write_Statement_Buffer;
1697       end if;
1698
1699       if not Cumulative_Restrictions.Set (No_Finalization) then
1700
1701          if not No_Main_Subprogram
1702            and then Bind_Main_Program
1703            and then not Suppress_Standard_Library_On_Target
1704          then
1705             WBI ("      Initialize (SEH'Address);");
1706          else
1707             WBI ("      Initialize (System.Null_Address);");
1708          end if;
1709       end if;
1710
1711       WBI ("      " & Ada_Init_Name.all & ";");
1712
1713       if not No_Main_Subprogram then
1714          WBI ("      Break_Start;");
1715
1716          if ALIs.Table (ALIs.First).Main_Program = Proc then
1717             WBI ("      Ada_Main_Program;");
1718          else
1719             WBI ("      Result := Ada_Main_Program;");
1720          end if;
1721       end if;
1722
1723       --  Adafinal call is skipped if no finalization
1724
1725       if not Cumulative_Restrictions.Set (No_Finalization) then
1726
1727          --  If compiling for the JVM, we directly call Adafinal because
1728          --  we don't import it via Do_Finalize (see Gen_Output_File_Ada).
1729
1730          if Hostparm.Java_VM then
1731             WBI ("      System.Standard_Library.Adafinal;");
1732          else
1733             WBI ("      Do_Finalize;");
1734          end if;
1735       end if;
1736
1737       --  Finalize is only called if we have a run time
1738
1739       if not Cumulative_Restrictions.Set (No_Finalization) then
1740          WBI ("      Finalize;");
1741       end if;
1742
1743       --  Return result
1744
1745       if Exit_Status_Supported_On_Target then
1746          if No_Main_Subprogram
1747            or else ALIs.Table (ALIs.First).Main_Program = Proc
1748          then
1749             WBI ("      return (gnat_exit_status);");
1750          else
1751             WBI ("      return (Result);");
1752          end if;
1753       end if;
1754
1755       WBI ("   end;");
1756    end Gen_Main_Ada;
1757
1758    ----------------
1759    -- Gen_Main_C --
1760    ----------------
1761
1762    procedure Gen_Main_C is
1763    begin
1764       if Exit_Status_Supported_On_Target then
1765          Set_String ("int ");
1766       else
1767          Set_String ("void ");
1768       end if;
1769
1770       Set_String (Get_Main_Name);
1771
1772       --  Generate command line args in prototype if present on target
1773
1774       if Command_Line_Args_On_Target then
1775          Write_Statement_Buffer (" (int argc, char **argv, char **envp)");
1776
1777       --  Case of no command line arguments on target
1778
1779       else
1780          Write_Statement_Buffer (" ()");
1781       end if;
1782
1783       WBI ("{");
1784
1785       --  Generate a reference to __gnat_ada_main_program_name. This symbol
1786       --  is  not referenced elsewhere in the generated program, but is
1787       --  needed by the debugger (that's why it is generated in the first
1788       --  place). The reference stops Ada_Main_Program_Name from being
1789       --  optimized away by smart linkers, such as the AiX linker.
1790
1791       if Bind_Main_Program then
1792          WBI ("   char *ensure_reference __attribute__ ((__unused__)) = " &
1793               "__gnat_ada_main_program_name;");
1794          WBI ("");
1795
1796          if not Suppress_Standard_Library_On_Target
1797            and then not No_Main_Subprogram
1798          then
1799             WBI ("   int SEH [2];");
1800             WBI ("");
1801          end if;
1802       end if;
1803
1804       --  If main program is a function, generate result variable
1805
1806       if ALIs.Table (ALIs.First).Main_Program = Func then
1807          WBI ("   int result;");
1808       end if;
1809
1810       --  Set command line argument values from parameters if command line
1811       --  arguments are present on target
1812
1813       if Command_Line_Args_On_Target then
1814          WBI ("   gnat_argc = argc;");
1815          WBI ("   gnat_argv = argv;");
1816          WBI ("   gnat_envp = envp;");
1817          WBI (" ");
1818
1819       --  If configurable run-time, then nothing to do, since in this case
1820       --  the gnat_argc/argv/envp variables are entirely suppressed.
1821
1822       elsif Configurable_Run_Time_On_Target then
1823          null;
1824
1825       --  if no command line arguments on target, set dummy values
1826
1827       else
1828          WBI ("   int result;");
1829          WBI ("   gnat_argc = 0;");
1830          WBI ("   gnat_argv = 0;");
1831          WBI ("   gnat_envp = 0;");
1832       end if;
1833
1834       if Opt.Default_Exit_Status /= 0
1835         and then Bind_Main_Program
1836         and then not Configurable_Run_Time_Mode
1837       then
1838          Set_String ("   __gnat_set_exit_status (");
1839          Set_Int (Opt.Default_Exit_Status);
1840          Set_String (");");
1841          Write_Statement_Buffer;
1842       end if;
1843
1844       --  The __gnat_initialize routine is used only if we have a run-time
1845
1846       if not Suppress_Standard_Library_On_Target then
1847          if not No_Main_Subprogram and then Bind_Main_Program then
1848             WBI ("   __gnat_initialize ((void *)SEH);");
1849          else
1850             WBI ("   __gnat_initialize ((void *)0);");
1851          end if;
1852       end if;
1853
1854       WBI ("   " & Ada_Init_Name.all & " ();");
1855
1856       if not No_Main_Subprogram then
1857          WBI ("   __gnat_break_start ();");
1858          WBI (" ");
1859
1860          --  Output main program name
1861
1862          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
1863
1864          --  Main program is procedure case
1865
1866          if ALIs.Table (ALIs.First).Main_Program = Proc then
1867             Set_String ("   ");
1868             Set_Main_Program_Name;
1869             Set_String (" ();");
1870             Write_Statement_Buffer;
1871
1872          --  Main program is function case
1873
1874          else -- ALIs.Table (ALIs_First).Main_Program = Func
1875             Set_String ("   result = ");
1876             Set_Main_Program_Name;
1877             Set_String (" ();");
1878             Write_Statement_Buffer;
1879          end if;
1880
1881       end if;
1882
1883       --  Call adafinal if finalization active
1884
1885       if not Cumulative_Restrictions.Set (No_Finalization) then
1886          WBI (" ");
1887          WBI ("   system__standard_library__adafinal ();");
1888       end if;
1889
1890       --  The finalize routine is used only if we have a run-time
1891
1892       if not Suppress_Standard_Library_On_Target then
1893          WBI ("   __gnat_finalize ();");
1894       end if;
1895
1896       --  Case of main program is a function, so the value it returns
1897       --  is the exit status in this case.
1898
1899       if ALIs.Table (ALIs.First).Main_Program = Func then
1900          if Exit_Status_Supported_On_Target then
1901
1902             --  VMS must use Posix exit routine in order to get the effect
1903             --  of a Unix compatible setting of the program exit status.
1904             --  For all other systems, we use the standard exit routine.
1905
1906             if OpenVMS_On_Target then
1907                WBI ("   __posix_exit (result);");
1908             else
1909                WBI ("   exit (result);");
1910             end if;
1911          end if;
1912
1913       --  Case of main program is a procedure, in which case the exit
1914       --  status is whatever was set by a Set_Exit call most recently
1915
1916       else
1917          if Exit_Status_Supported_On_Target then
1918
1919             --  VMS must use Posix exit routine in order to get the effect
1920             --  of a Unix compatible setting of the program exit status.
1921             --  For all other systems, we use the standard exit routine.
1922
1923             if OpenVMS_On_Target then
1924                WBI ("   __posix_exit (gnat_exit_status);");
1925             else
1926                WBI ("   exit (gnat_exit_status);");
1927             end if;
1928          end if;
1929       end if;
1930
1931       WBI ("}");
1932    end Gen_Main_C;
1933
1934    ------------------------------
1935    -- Gen_Object_Files_Options --
1936    ------------------------------
1937
1938    procedure Gen_Object_Files_Options is
1939       Lgnat : Natural;
1940       --  This keeps track of the position in the sorted set of entries
1941       --  in the Linker_Options table of where the first entry from an
1942       --  internal file appears.
1943
1944       procedure Write_Linker_Option;
1945       --  Write binder info linker option.
1946
1947       -------------------------
1948       -- Write_Linker_Option --
1949       -------------------------
1950
1951       procedure Write_Linker_Option is
1952          Start : Natural;
1953          Stop  : Natural;
1954
1955       begin
1956          --  Loop through string, breaking at null's
1957
1958          Start := 1;
1959          while Start < Name_Len loop
1960
1961             --  Find null ending this section
1962
1963             Stop := Start + 1;
1964             while Name_Buffer (Stop) /= ASCII.NUL
1965               and then Stop <= Name_Len loop
1966                Stop := Stop + 1;
1967             end loop;
1968
1969             --  Process section if non-null
1970
1971             if Stop > Start then
1972                   if Output_Linker_Option_List then
1973                      Write_Str (Name_Buffer (Start .. Stop - 1));
1974                      Write_Eol;
1975                   end if;
1976                   Write_Info_Ada_C
1977                     ("   --   ", "", Name_Buffer (Start .. Stop - 1));
1978             end if;
1979
1980             Start := Stop + 1;
1981          end loop;
1982       end Write_Linker_Option;
1983
1984    --  Start of processing for Gen_Object_Files_Options
1985
1986    begin
1987       WBI ("");
1988       Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list");
1989
1990       for E in Elab_Order.First .. Elab_Order.Last loop
1991
1992          --  If not spec that has an associated body, then generate a
1993          --  comment giving the name of the corresponding object file.
1994
1995          if (not Units.Table (Elab_Order.Table (E)).SAL_Interface)
1996            and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
1997          then
1998             Get_Name_String
1999               (ALIs.Table
2000                 (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
2001
2002             --  If the presence of an object file is necessary or if it
2003             --  exists, then use it.
2004
2005             if not Hostparm.Exclude_Missing_Objects
2006               or else GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
2007             then
2008                Write_Info_Ada_C ("   --   ", "", Name_Buffer (1 .. Name_Len));
2009
2010                if Output_Object_List then
2011                   Write_Str (Name_Buffer (1 .. Name_Len));
2012                   Write_Eol;
2013                end if;
2014
2015                --  Don't link with the shared library on VMS if an internal
2016                --  filename object is seen. Multiply defined symbols will
2017                --  result.
2018
2019                if Hostparm.OpenVMS
2020                  and then Is_Internal_File_Name
2021                   (ALIs.Table
2022                    (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
2023                then
2024                   --  Special case for g-trasym.obj, which is not included
2025                   --  in libgnat.
2026
2027                   Get_Name_String (ALIs.Table
2028                             (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile);
2029
2030                   if Name_Buffer (1 .. 8) /= "g-trasym" then
2031                      Opt.Shared_Libgnat := False;
2032                   end if;
2033                end if;
2034             end if;
2035          end if;
2036       end loop;
2037
2038       --  Add a "-Ldir" for each directory in the object path
2039
2040       for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
2041          declare
2042             Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
2043          begin
2044             Name_Len := 0;
2045             Add_Str_To_Name_Buffer ("-L");
2046             Add_Str_To_Name_Buffer (Dir.all);
2047             Write_Linker_Option;
2048          end;
2049       end loop;
2050
2051       --  Sort linker options
2052
2053       --  This sort accomplishes two important purposes:
2054
2055       --    a) All application files are sorted to the front, and all
2056       --       GNAT internal files are sorted to the end. This results
2057       --       in a well defined dividing line between the two sets of
2058       --       files, for the purpose of inserting certain standard
2059       --       library references into the linker arguments list.
2060
2061       --    b) Given two different units, we sort the linker options so
2062       --       that those from a unit earlier in the elaboration order
2063       --       comes later in the list. This is a heuristic designed
2064       --       to create a more friendly order of linker options when
2065       --       the operations appear in separate units. The idea is that
2066       --       if unit A must be elaborated before unit B, then it is
2067       --       more likely that B references libraries included by A,
2068       --       than vice versa, so we want the libraries included by
2069       --       A to come after the libraries included by B.
2070
2071       --  These two criteria are implemented by function Lt_Linker_Option.
2072       --  Note that a special case of b) is that specs are elaborated before
2073       --  bodies, so linker options from specs come after linker options
2074       --  for bodies, and again, the assumption is that libraries used by
2075       --  the body are more likely to reference libraries used by the spec,
2076       --  than vice versa.
2077
2078       Sort
2079         (Linker_Options.Last,
2080          Move_Linker_Option'Access,
2081          Lt_Linker_Option'Access);
2082
2083       --  Write user linker options, i.e. the set of linker options that
2084       --  come from all files other than GNAT internal files, Lgnat is
2085       --  left set to point to the first entry from a GNAT internal file,
2086       --  or past the end of the entriers if there are no internal files.
2087
2088       Lgnat := Linker_Options.Last + 1;
2089
2090       for J in 1 .. Linker_Options.Last loop
2091          if not Linker_Options.Table (J).Internal_File then
2092             Get_Name_String (Linker_Options.Table (J).Name);
2093             Write_Linker_Option;
2094          else
2095             Lgnat := J;
2096             exit;
2097          end if;
2098       end loop;
2099
2100       --  Now we insert standard linker options that must appear after the
2101       --  entries from user files, and before the entries from GNAT run-time
2102       --  files. The reason for this decision is that libraries referenced
2103       --  by internal routines may reference these standard library entries.
2104
2105       if not Opt.No_Stdlib then
2106          Name_Len := 0;
2107
2108          if Opt.Shared_Libgnat then
2109             Add_Str_To_Name_Buffer ("-shared");
2110          else
2111             Add_Str_To_Name_Buffer ("-static");
2112          end if;
2113
2114          --  Write directly to avoid -K output (why???)
2115
2116          Write_Info_Ada_C ("   --   ", "", Name_Buffer (1 .. Name_Len));
2117
2118          if With_DECGNAT then
2119             Name_Len := 0;
2120             Add_Str_To_Name_Buffer ("-ldecgnat");
2121             Write_Linker_Option;
2122          end if;
2123
2124          if With_GNARL then
2125             Name_Len := 0;
2126
2127             if Opt.Shared_Libgnat then
2128                Add_Str_To_Name_Buffer (Shared_Lib ("gnarl"));
2129             else
2130                Add_Str_To_Name_Buffer ("-lgnarl");
2131             end if;
2132
2133             Write_Linker_Option;
2134          end if;
2135
2136          Name_Len := 0;
2137
2138          if Opt.Shared_Libgnat then
2139             Add_Str_To_Name_Buffer (Shared_Lib ("gnat"));
2140          else
2141             Add_Str_To_Name_Buffer ("-lgnat");
2142          end if;
2143
2144          Write_Linker_Option;
2145       end if;
2146
2147       --  Write linker options from all internal files
2148
2149       for J in Lgnat .. Linker_Options.Last loop
2150          Get_Name_String (Linker_Options.Table (J).Name);
2151          Write_Linker_Option;
2152       end loop;
2153
2154       if Ada_Bind_File then
2155          WBI ("--  END Object file/option list   ");
2156       else
2157          WBI ("    END Object file/option list */");
2158       end if;
2159    end Gen_Object_Files_Options;
2160
2161    ---------------------
2162    -- Gen_Output_File --
2163    ---------------------
2164
2165    procedure Gen_Output_File (Filename : String) is
2166       Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
2167       Is_GAP_Version    : constant Boolean := Get_Gnat_Build_Type = GAP;
2168
2169    begin
2170       --  Acquire settings for Interrupt_State pragmas
2171
2172       Set_IS_Pragma_Table;
2173
2174       --  Override Ada_Bind_File and Bind_Main_Program for Java since
2175       --  JGNAT only supports Ada code, and the main program is already
2176       --  generated by the compiler.
2177
2178       if Hostparm.Java_VM then
2179          Ada_Bind_File := True;
2180          Bind_Main_Program := False;
2181       end if;
2182
2183       --  Override time slice value if -T switch is set
2184
2185       if Time_Slice_Set then
2186          ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value;
2187       end if;
2188
2189       --  Count number of elaboration calls
2190
2191       for E in Elab_Order.First .. Elab_Order.Last loop
2192          if Units.Table (Elab_Order.Table (E)).No_Elab then
2193             null;
2194          else
2195             Num_Elab_Calls := Num_Elab_Calls + 1;
2196          end if;
2197       end loop;
2198
2199       --  Get the time stamp of the former bind for public version warning
2200
2201       if Is_Public_Version or Is_GAP_Version then
2202          Record_Time_From_Last_Bind;
2203       end if;
2204
2205       --  Generate output file in appropriate language
2206
2207       if Ada_Bind_File then
2208          Gen_Output_File_Ada (Filename);
2209       else
2210          Gen_Output_File_C (Filename);
2211       end if;
2212
2213       --  Periodically issue a warning when the public version is used on
2214       --  big projects
2215
2216       if Is_Public_Version then
2217          Public_Version_Warning;
2218       end if;
2219    end Gen_Output_File;
2220
2221    -------------------------
2222    -- Gen_Output_File_Ada --
2223    -------------------------
2224
2225    procedure Gen_Output_File_Ada (Filename : String) is
2226
2227       Bfiles : Name_Id;
2228       --  Name of generated bind file (spec)
2229
2230       Bfileb : Name_Id;
2231       --  Name of generated bind file (body)
2232
2233       Ada_Main : constant String := Get_Ada_Main_Name;
2234       --  Name to be used for generated Ada main program. See the body of
2235       --  function Get_Ada_Main_Name for details on the form of the name.
2236
2237    begin
2238       --  Create spec first
2239
2240       Create_Binder_Output (Filename, 's', Bfiles);
2241
2242       --  If we are operating in Restrictions (No_Exception_Handlers) mode,
2243       --  then we need to make sure that the binder program is compiled with
2244       --  the same restriction, so that no exception tables are generated.
2245
2246       if Cumulative_Restrictions.Set (No_Exception_Handlers) then
2247          WBI ("pragma Restrictions (No_Exception_Handlers);");
2248       end if;
2249
2250       --  Generate with of System so we can reference System.Address
2251
2252       WBI ("with System;");
2253
2254       --  Generate with of System.Initialize_Scalars if active
2255
2256       if Initialize_Scalars_Used then
2257          WBI ("with System.Scalar_Values;");
2258       end if;
2259
2260       --  Generate with of System.Secondary_Stack if active
2261
2262       if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
2263          WBI ("with System.Secondary_Stack;");
2264       end if;
2265
2266       Resolve_Binder_Options;
2267
2268       if not Suppress_Standard_Library_On_Target then
2269
2270          --  Usually, adafinal is called using a pragma Import C. Since
2271          --  Import C doesn't have the same semantics for JGNAT, we use
2272          --  standard Ada.
2273
2274          if Hostparm.Java_VM then
2275             WBI ("with System.Standard_Library;");
2276          end if;
2277       end if;
2278
2279       WBI ("package " & Ada_Main & " is");
2280       WBI ("   pragma Warnings (Off);");
2281
2282       --  Main program case
2283
2284       if Bind_Main_Program then
2285
2286          --  Generate argc/argv stuff unless suppressed
2287
2288          if Command_Line_Args_On_Target
2289            or not Configurable_Run_Time_On_Target
2290          then
2291             WBI ("");
2292             WBI ("   gnat_argc : Integer;");
2293             WBI ("   gnat_argv : System.Address;");
2294             WBI ("   gnat_envp : System.Address;");
2295
2296             --  If the standard library is not suppressed, these variables are
2297             --  in the runtime data area for easy access from the runtime
2298
2299             if not Suppress_Standard_Library_On_Target then
2300                WBI ("");
2301                WBI ("   pragma Import (C, gnat_argc);");
2302                WBI ("   pragma Import (C, gnat_argv);");
2303                WBI ("   pragma Import (C, gnat_envp);");
2304             end if;
2305          end if;
2306
2307          --  Define exit status. Again in normal mode, this is in the
2308          --  run-time library, and is initialized there, but in the
2309          --  configurable runtime case, the variable is declared and
2310          --  initialized in this file.
2311
2312          WBI ("");
2313
2314          if Configurable_Run_Time_Mode then
2315             if Exit_Status_Supported_On_Target then
2316                WBI ("   gnat_exit_status : Integer := 0;");
2317             end if;
2318          else
2319             WBI ("   gnat_exit_status : Integer;");
2320             WBI ("   pragma Import (C, gnat_exit_status);");
2321          end if;
2322       end if;
2323
2324       --  Generate the GNAT_Version and Ada_Main_Program_Name info only for
2325       --  the main program. Otherwise, it can lead under some circumstances
2326       --  to a symbol duplication during the link (for instance when a
2327       --  C program uses 2 Ada libraries)
2328
2329       if Bind_Main_Program then
2330          WBI ("");
2331          WBI ("   GNAT_Version : constant String :=");
2332          WBI ("                    ""GNAT Version: " &
2333                                    Gnat_Version_String & """;");
2334          WBI ("   pragma Export (C, GNAT_Version, ""__gnat_version"");");
2335
2336          WBI ("");
2337          Set_String ("   Ada_Main_Program_Name : constant String := """);
2338          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2339          Set_Main_Program_Name;
2340          Set_String (""" & Ascii.NUL;");
2341          Write_Statement_Buffer;
2342
2343          WBI
2344            ("   pragma Export (C, Ada_Main_Program_Name, " &
2345             """__gnat_ada_main_program_name"");");
2346       end if;
2347
2348       WBI ("");
2349       WBI ("   procedure " & Ada_Final_Name.all & ";");
2350       WBI ("   pragma Export (C, " & Ada_Final_Name.all & ", """ &
2351            Ada_Final_Name.all & """);");
2352
2353       WBI ("");
2354       WBI ("   procedure " & Ada_Init_Name.all & ";");
2355       WBI ("   pragma Export (C, " & Ada_Init_Name.all & ", """ &
2356            Ada_Init_Name.all & """);");
2357
2358       if Bind_Main_Program then
2359
2360          --  If we have the standard library, then Break_Start is defined
2361          --  there, but when the standard library is suppressed, Break_Start
2362          --  is defined here.
2363
2364          WBI ("");
2365          WBI ("   procedure Break_Start;");
2366
2367          if Suppress_Standard_Library_On_Target then
2368             WBI ("   pragma Export (C, Break_Start, ""__gnat_break_start"");");
2369          else
2370             WBI ("   pragma Import (C, Break_Start, ""__gnat_break_start"");");
2371          end if;
2372
2373          WBI ("");
2374
2375          if Exit_Status_Supported_On_Target then
2376             Set_String ("   function ");
2377          else
2378             Set_String ("   procedure ");
2379          end if;
2380
2381          Set_String (Get_Main_Name);
2382
2383          --  Generate argument list if present
2384
2385          if Command_Line_Args_On_Target then
2386             Write_Statement_Buffer;
2387             WBI ("     (argc : Integer;");
2388             WBI ("      argv : System.Address;");
2389             Set_String
2390                 ("      envp : System.Address)");
2391
2392             if Exit_Status_Supported_On_Target then
2393                Write_Statement_Buffer;
2394                WBI ("      return Integer;");
2395             else
2396                Write_Statement_Buffer (";");
2397             end if;
2398
2399          else
2400             if Exit_Status_Supported_On_Target then
2401                Write_Statement_Buffer (" return Integer;");
2402             else
2403                Write_Statement_Buffer (";");
2404             end if;
2405          end if;
2406
2407          WBI ("   pragma Export (C, " & Get_Main_Name & ", """ &
2408            Get_Main_Name & """);");
2409       end if;
2410
2411       Gen_Versions_Ada;
2412       Gen_Elab_Order_Ada;
2413
2414       --  Spec is complete
2415
2416       WBI ("");
2417       WBI ("end " & Ada_Main & ";");
2418       Close_Binder_Output;
2419
2420       --  Prepare to write body
2421
2422       Create_Binder_Output (Filename, 'b', Bfileb);
2423
2424       --  Output Source_File_Name pragmas which look like
2425
2426       --    pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
2427       --    pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb");
2428
2429       --  where sss/bbb are the spec/body file names respectively
2430
2431       Get_Name_String (Bfiles);
2432       Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2433
2434       WBI ("pragma Source_File_Name (" &
2435            Ada_Main &
2436            ", Spec_File_Name => """ &
2437            Name_Buffer (1 .. Name_Len + 3));
2438
2439       Get_Name_String (Bfileb);
2440       Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2441
2442       WBI ("pragma Source_File_Name (" &
2443            Ada_Main &
2444            ", Body_File_Name => """ &
2445            Name_Buffer (1 .. Name_Len + 3));
2446
2447       WBI ("");
2448       WBI ("package body " & Ada_Main & " is");
2449       WBI ("   pragma Warnings (Off);");
2450
2451       --  Import the finalization procedure only if finalization active
2452
2453       if not Cumulative_Restrictions.Set (No_Finalization) then
2454
2455          --  In the Java case, pragma Import C cannot be used, so the
2456          --  standard Ada constructs will be used instead.
2457
2458          if not Hostparm.Java_VM then
2459             WBI ("");
2460             WBI ("   procedure Do_Finalize;");
2461             WBI
2462               ("   pragma Import (C, Do_Finalize, " &
2463                """system__standard_library__adafinal"");");
2464             WBI ("");
2465          end if;
2466       end if;
2467
2468       Gen_Adainit_Ada;
2469
2470       Gen_Adafinal_Ada;
2471
2472       if Bind_Main_Program then
2473
2474          --  When suppressing the standard library then generate dummy body
2475          --  for Break_Start
2476
2477          if Suppress_Standard_Library_On_Target then
2478             WBI ("");
2479             WBI ("   procedure Break_Start is");
2480             WBI ("   begin");
2481             WBI ("      null;");
2482             WBI ("   end;");
2483          end if;
2484
2485          Gen_Main_Ada;
2486       end if;
2487
2488       --  Output object file list and the Ada body is complete
2489
2490       Gen_Object_Files_Options;
2491
2492       WBI ("");
2493       WBI ("end " & Ada_Main & ";");
2494
2495       Close_Binder_Output;
2496    end Gen_Output_File_Ada;
2497
2498    -----------------------
2499    -- Gen_Output_File_C --
2500    -----------------------
2501
2502    procedure Gen_Output_File_C (Filename : String) is
2503
2504       Bfile : Name_Id;
2505       --  Name of generated bind file
2506
2507    begin
2508       Create_Binder_Output (Filename, 'c', Bfile);
2509
2510       Resolve_Binder_Options;
2511
2512       WBI ("extern void __gnat_set_globals");
2513       WBI ("  (int, int, char, char, char, char,");
2514       WBI ("   const char *, const char *,");
2515       WBI ("   int, int, int, int, int);");
2516       WBI ("extern void " & Ada_Final_Name.all & " (void);");
2517       WBI ("extern void " & Ada_Init_Name.all & " (void);");
2518       WBI ("extern void system__standard_library__adafinal (void);");
2519
2520       if not No_Main_Subprogram then
2521          Set_String ("extern ");
2522
2523          if Exit_Status_Supported_On_Target then
2524             Set_String ("int");
2525          else
2526             Set_String ("void");
2527          end if;
2528
2529          Set_String (" main ");
2530
2531          if Command_Line_Args_On_Target then
2532             Write_Statement_Buffer ("(int, char **, char **);");
2533          else
2534             Write_Statement_Buffer ("(void);");
2535          end if;
2536
2537          if OpenVMS_On_Target then
2538             WBI ("extern void __posix_exit (int);");
2539          else
2540             WBI ("extern void exit (int);");
2541          end if;
2542
2543          WBI ("extern void __gnat_break_start (void);");
2544          Set_String ("extern ");
2545
2546          if ALIs.Table (ALIs.First).Main_Program = Proc then
2547             Set_String ("void ");
2548          else
2549             Set_String ("int ");
2550          end if;
2551
2552          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2553          Set_Main_Program_Name;
2554          Set_String (" (void);");
2555          Write_Statement_Buffer;
2556       end if;
2557
2558       if not Suppress_Standard_Library_On_Target then
2559          WBI ("extern void __gnat_initialize (void *);");
2560          WBI ("extern void __gnat_finalize (void);");
2561          WBI ("extern void __gnat_install_handler (void);");
2562       end if;
2563
2564       WBI ("");
2565
2566       Gen_Elab_Defs_C;
2567
2568       --  Imported variable used to track elaboration/finalization phase.
2569       --  Used only when we have a runtime.
2570
2571       if not Suppress_Standard_Library_On_Target then
2572          WBI ("extern int  __gnat_handler_installed;");
2573          WBI ("");
2574       end if;
2575
2576       --  Write argv/argc exit status stuff if main program case
2577
2578       if Bind_Main_Program then
2579
2580          --  First deal with argc/argv/envp. In the normal case they
2581          --  are in the run-time library.
2582
2583          if not Configurable_Run_Time_On_Target then
2584             WBI ("extern int gnat_argc;");
2585             WBI ("extern char **gnat_argv;");
2586             WBI ("extern char **gnat_envp;");
2587
2588          --  If configurable run time and no command line args, then the
2589          --  generation of these variables is entirely suppressed.
2590
2591          elsif not Command_Line_Args_On_Target then
2592             null;
2593
2594          --  Otherwise, in the configurable run-time case they are right in
2595          --  the binder file.
2596
2597          else
2598             WBI ("int gnat_argc;");
2599             WBI ("char **gnat_argv;");
2600             WBI ("char **gnat_envp;");
2601          end if;
2602
2603          --  Similarly deal with exit status
2604          --  are in the run-time library.
2605
2606          if not Configurable_Run_Time_On_Target then
2607             WBI ("extern int gnat_exit_status;");
2608
2609          --  If configurable run time and no exit status on target, then
2610          --  the generation of this variables is entirely suppressed.
2611
2612          elsif not Exit_Status_Supported_On_Target then
2613             null;
2614
2615          --  Otherwise, in the configurable run-time case this variable is
2616          --  right in the binder file, and initialized to zero there.
2617
2618          else
2619             WBI ("int gnat_exit_status = 0;");
2620          end if;
2621
2622          WBI ("");
2623       end if;
2624
2625       --  When suppressing the standard library, the __gnat_break_start
2626       --  routine (for the debugger to get initial control) is defined in
2627       --  this file.
2628
2629       if Suppress_Standard_Library_On_Target then
2630          WBI ("");
2631          WBI ("void __gnat_break_start () {}");
2632       end if;
2633
2634       --  Generate the __gnat_version and __gnat_ada_main_program_name info
2635       --  only for the main program. Otherwise, it can lead under some
2636       --  circumstances to a symbol duplication during the link (for instance
2637       --  when a C program uses 2 Ada libraries)
2638
2639       if Bind_Main_Program then
2640          WBI ("");
2641          WBI ("char __gnat_version[] = ""GNAT Version: " &
2642                                    Gnat_Version_String & """;");
2643
2644          Set_String ("char __gnat_ada_main_program_name[] = """);
2645          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2646          Set_Main_Program_Name;
2647          Set_String (""";");
2648          Write_Statement_Buffer;
2649       end if;
2650
2651       --  Generate the adafinal routine. In no runtime mode, this is
2652       --  not needed, since there is no finalization to do.
2653
2654       if not Cumulative_Restrictions.Set (No_Finalization) then
2655          Gen_Adafinal_C;
2656       end if;
2657
2658       Gen_Adainit_C;
2659
2660       --  Main is only present for Ada main case
2661
2662       if Bind_Main_Program then
2663          Gen_Main_C;
2664       end if;
2665
2666       --  Generate versions, elaboration order, list of object files
2667
2668       Gen_Versions_C;
2669       Gen_Elab_Order_C;
2670       Gen_Object_Files_Options;
2671
2672       --  C binder output is complete
2673
2674       Close_Binder_Output;
2675    end Gen_Output_File_C;
2676
2677    -------------------------------
2678    -- Gen_Restrictions_String_1 --
2679    -------------------------------
2680
2681    procedure Gen_Restrictions_String_1 is
2682    begin
2683       for R in All_Boolean_Restrictions loop
2684          if Cumulative_Restrictions.Set (R) then
2685             Set_Char ('r');
2686          elsif Cumulative_Restrictions.Violated (R) then
2687             Set_Char ('v');
2688          else
2689             Set_Char ('n');
2690          end if;
2691       end loop;
2692    end Gen_Restrictions_String_1;
2693
2694    -------------------------------
2695    -- Gen_Restrictions_String_2 --
2696    -------------------------------
2697
2698    procedure Gen_Restrictions_String_2 is
2699    begin
2700       for RP in All_Parameter_Restrictions loop
2701          if Cumulative_Restrictions.Set (RP) then
2702             Set_Char ('r');
2703             Set_Int (Int (Cumulative_Restrictions.Value (RP)));
2704          else
2705             Set_Char ('n');
2706          end if;
2707
2708          if not Cumulative_Restrictions.Violated (RP)
2709            or else RP not in Checked_Parameter_Restrictions
2710          then
2711             Set_Char ('n');
2712          else
2713             Set_Char ('v');
2714             Set_Int (Int (Cumulative_Restrictions.Count (RP)));
2715
2716             if Cumulative_Restrictions.Unknown (RP) then
2717                Set_Char ('+');
2718             end if;
2719          end if;
2720       end loop;
2721    end Gen_Restrictions_String_2;
2722
2723    ----------------------
2724    -- Gen_Versions_Ada --
2725    ----------------------
2726
2727    --  This routine generates two sets of lines. The first set has the form:
2728
2729    --    unnnnn : constant Integer := 16#hhhhhhhh#;
2730
2731    --  The second set has the form
2732
2733    --    pragma Export (C, unnnnn, unam);
2734
2735    --  for each unit, where unam is the unit name suffixed by either B or
2736    --  S for body or spec, with dots replaced by double underscores, and
2737    --  hhhhhhhh is the version number, and nnnnn is a 5-digits serial number.
2738
2739    procedure Gen_Versions_Ada is
2740       Ubuf : String (1 .. 6) := "u00000";
2741
2742       procedure Increment_Ubuf;
2743       --  Little procedure to increment the serial number
2744
2745       procedure Increment_Ubuf is
2746       begin
2747          for J in reverse Ubuf'Range loop
2748             Ubuf (J) := Character'Succ (Ubuf (J));
2749             exit when Ubuf (J) <= '9';
2750             Ubuf (J) := '0';
2751          end loop;
2752       end Increment_Ubuf;
2753
2754    --  Start of processing for Gen_Versions_Ada
2755
2756    begin
2757       if Bind_For_Library then
2758
2759          --  When building libraries, the version number of each unit can
2760          --  not be computed, since the binder does not know the full list
2761          --  of units. Therefore, the 'Version and 'Body_Version
2762          --  attributes can not supported in this case.
2763
2764          return;
2765       end if;
2766
2767       WBI ("");
2768
2769       WBI ("   type Version_32 is mod 2 ** 32;");
2770       for U in Units.First .. Units.Last loop
2771          Increment_Ubuf;
2772          WBI ("   " & Ubuf & " : constant Version_32 := 16#" &
2773               Units.Table (U).Version & "#;");
2774       end loop;
2775
2776       WBI ("");
2777       Ubuf := "u00000";
2778
2779       for U in Units.First .. Units.Last loop
2780          Increment_Ubuf;
2781          Set_String ("   pragma Export (C, ");
2782          Set_String (Ubuf);
2783          Set_String (", """);
2784
2785          Get_Name_String (Units.Table (U).Uname);
2786
2787          for K in 1 .. Name_Len loop
2788             if Name_Buffer (K) = '.' then
2789                Set_Char ('_');
2790                Set_Char ('_');
2791
2792             elsif Name_Buffer (K) = '%' then
2793                exit;
2794
2795             else
2796                Set_Char (Name_Buffer (K));
2797             end if;
2798          end loop;
2799
2800          if Name_Buffer (Name_Len) = 's' then
2801             Set_Char ('S');
2802          else
2803             Set_Char ('B');
2804          end if;
2805
2806          Set_String (""");");
2807          Write_Statement_Buffer;
2808       end loop;
2809
2810    end Gen_Versions_Ada;
2811
2812    --------------------
2813    -- Gen_Versions_C --
2814    --------------------
2815
2816    --  This routine generates a line of the form:
2817
2818    --    unsigned unam = 0xhhhhhhhh;
2819
2820    --  for each unit, where unam is the unit name suffixed by either B or
2821    --  S for body or spec, with dots replaced by double underscores.
2822
2823    procedure Gen_Versions_C is
2824    begin
2825       if Bind_For_Library then
2826
2827          --  When building libraries, the version number of each unit can
2828          --  not be computed, since the binder does not know the full list
2829          --  of units. Therefore, the 'Version and 'Body_Version
2830          --  attributes can not supported.
2831
2832          return;
2833       end if;
2834
2835       for U in Units.First .. Units.Last loop
2836          Set_String ("unsigned ");
2837
2838          Get_Name_String (Units.Table (U).Uname);
2839
2840          for K in 1 .. Name_Len loop
2841             if Name_Buffer (K) = '.' then
2842                Set_String ("__");
2843
2844             elsif Name_Buffer (K) = '%' then
2845                exit;
2846
2847             else
2848                Set_Char (Name_Buffer (K));
2849             end if;
2850          end loop;
2851
2852          if Name_Buffer (Name_Len) = 's' then
2853             Set_Char ('S');
2854          else
2855             Set_Char ('B');
2856          end if;
2857
2858          Set_String (" = 0x");
2859          Set_String (Units.Table (U).Version);
2860          Set_Char   (';');
2861          Write_Statement_Buffer;
2862       end loop;
2863
2864    end Gen_Versions_C;
2865
2866    -----------------------
2867    -- Get_Ada_Main_Name --
2868    -----------------------
2869
2870    function Get_Ada_Main_Name return String is
2871       Suffix : constant String := "_00";
2872       Name   : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
2873                  Opt.Ada_Main_Name.all & Suffix;
2874       Nlen   : Natural;
2875
2876    begin
2877       --  The main program generated by JGNAT expects a package called
2878       --  ada_<main procedure>.
2879
2880       if Hostparm.Java_VM then
2881          --  Get main program name
2882
2883          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2884
2885          --  Remove the %b
2886
2887          return "ada_" & Name_Buffer (1 .. Name_Len - 2);
2888       end if;
2889
2890       --  This loop tries the following possibilities in order
2891       --    <Ada_Main>
2892       --    <Ada_Main>_01
2893       --    <Ada_Main>_02
2894       --    ..
2895       --    <Ada_Main>_99
2896       --  where <Ada_Main> is equal to Opt.Ada_Main_Name. By default,
2897       --  it is set to 'ada_main'.
2898
2899       for J in 0 .. 99 loop
2900          if J = 0 then
2901             Nlen := Name'Length - Suffix'Length;
2902          else
2903             Nlen := Name'Length;
2904             Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0'));
2905             Name (Name'Last - 1) :=
2906               Character'Val (J /   10 + Character'Pos ('0'));
2907          end if;
2908
2909          for K in ALIs.First .. ALIs.Last loop
2910             for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop
2911
2912                --  Get unit name, removing %b or %e at end
2913
2914                Get_Name_String (Units.Table (L).Uname);
2915                Name_Len := Name_Len - 2;
2916
2917                if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then
2918                   goto Continue;
2919                end if;
2920             end loop;
2921          end loop;
2922
2923          return Name (1 .. Nlen);
2924
2925       <<Continue>>
2926          null;
2927       end loop;
2928
2929       --  If we fall through, just use a peculiar unlikely name
2930
2931       return ("Qwertyuiop");
2932    end Get_Ada_Main_Name;
2933
2934    -------------------
2935    -- Get_Main_Name --
2936    -------------------
2937
2938    function Get_Main_Name return String is
2939    begin
2940       --  Explicit name given with -M switch
2941
2942       if Bind_Alternate_Main_Name then
2943          return Alternate_Main_Name.all;
2944
2945       --  Case of main program name to be used directly
2946
2947       elsif Use_Ada_Main_Program_Name_On_Target then
2948
2949          --  Get main program name
2950
2951          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2952
2953          --  If this is a child name, return only the name of the child,
2954          --  since we can't have dots in a nested program name. Note that
2955          --  we do not include the %b at the end of the unit name.
2956
2957          for J in reverse 1 .. Name_Len - 2 loop
2958             if J = 1 or else Name_Buffer (J - 1) = '.' then
2959                return Name_Buffer (J .. Name_Len - 2);
2960             end if;
2961          end loop;
2962
2963          raise Program_Error; -- impossible exit
2964
2965       --  Case where "main" is to be used as default
2966
2967       else
2968          return "main";
2969       end if;
2970    end Get_Main_Name;
2971
2972    ----------------------
2973    -- Lt_Linker_Option --
2974    ----------------------
2975
2976    function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
2977    begin
2978       --  Sort internal files last
2979
2980       if Linker_Options.Table (Op1).Internal_File
2981            /=
2982          Linker_Options.Table (Op2).Internal_File
2983       then
2984          --  Note: following test uses False < True
2985
2986          return Linker_Options.Table (Op1).Internal_File
2987                   <
2988                 Linker_Options.Table (Op2).Internal_File;
2989
2990       --  If both internal or both non-internal, sort according to the
2991       --  elaboration position. A unit that is elaborated later should
2992       --  come earlier in the linker options list.
2993
2994       else
2995          return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
2996                   >
2997                 Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
2998
2999       end if;
3000    end Lt_Linker_Option;
3001
3002    ------------------------
3003    -- Move_Linker_Option --
3004    ------------------------
3005
3006    procedure Move_Linker_Option (From : Natural; To : Natural) is
3007    begin
3008       Linker_Options.Table (To) := Linker_Options.Table (From);
3009    end Move_Linker_Option;
3010
3011    ----------------------------
3012    -- Public_Version_Warning --
3013    ----------------------------
3014
3015    procedure Public_Version_Warning is
3016       Time : constant Int := Time_From_Last_Bind;
3017
3018       --  Constants to help defining periods
3019
3020       Hour : constant := 60;
3021       Day  : constant := 24 * Hour;
3022
3023       Never : constant := Integer'Last;
3024       --  Special value indicating no warnings should be given
3025
3026       --  Constants defining when the warning is issued. Programs with more
3027       --  than Large Units will issue a warning every Period_Large amount of
3028       --  time. Smaller programs will generate a warning every Period_Small
3029       --  amount of time.
3030
3031       Large : constant := 20;
3032       --  Threshold for considering a program small or large
3033
3034       Period_Large : constant := Day;
3035       --  Periodic warning time for large programs
3036
3037       Period_Small : constant := Never;
3038       --  Periodic warning time for small programs
3039
3040       Nb_Unit : Int;
3041
3042    begin
3043       --  Compute the number of units that are not GNAT internal files
3044
3045       Nb_Unit := 0;
3046       for A in ALIs.First .. ALIs.Last loop
3047          if not Is_Internal_File_Name (ALIs.Table (A).Sfile) then
3048             Nb_Unit := Nb_Unit + 1;
3049          end if;
3050       end loop;
3051
3052       --  Do not emit the message if the last message was emitted in the
3053       --  specified period taking into account the number of units.
3054
3055       pragma Warnings (Off);
3056       --  Turn off warning of constant condition, which may happen here
3057       --  depending on the choice of constants in the above declarations.
3058
3059       if Nb_Unit < Large and then Time <= Period_Small then
3060          return;
3061       elsif Time <= Period_Large then
3062          return;
3063       end if;
3064
3065       pragma Warnings (On);
3066
3067       Write_Eol;
3068       Write_Str ("IMPORTANT NOTICE:");
3069       Write_Eol;
3070       Write_Str ("    This version of GNAT is unsupported"
3071         &                        " and comes with absolutely no warranty.");
3072       Write_Eol;
3073       Write_Str ("    If you intend to evaluate or use GNAT for building "
3074         &                                       "commercial applications,");
3075       Write_Eol;
3076       Write_Str ("    please consult http://www.gnat.com/ for information");
3077       Write_Eol;
3078       Write_Str ("    on the GNAT Professional product line.");
3079       Write_Eol;
3080       Write_Eol;
3081    end Public_Version_Warning;
3082
3083    ----------------------------
3084    -- Resolve_Binder_Options --
3085    ----------------------------
3086
3087    procedure Resolve_Binder_Options is
3088    begin
3089       for E in Elab_Order.First .. Elab_Order.Last loop
3090          Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
3091
3092          --  The procedure of looking for specific packages and setting
3093          --  flags is somewhat dubious, but there isn't a good alternative
3094          --  at the current time ???
3095
3096          if Name_Buffer (1 .. 19) = "system.os_interface" then
3097             With_GNARL := True;
3098          end if;
3099
3100          if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then
3101             With_DECGNAT := True;
3102          end if;
3103       end loop;
3104    end Resolve_Binder_Options;
3105
3106    --------------
3107    -- Set_Char --
3108    --------------
3109
3110    procedure Set_Char (C : Character) is
3111    begin
3112       Last := Last + 1;
3113       Statement_Buffer (Last) := C;
3114    end Set_Char;
3115
3116    -----------------
3117    -- Set_EA_Last --
3118    -----------------
3119
3120    procedure Set_EA_Last is
3121    begin
3122       --  When there is no finalization, only adainit is added
3123
3124       if Cumulative_Restrictions.Set (No_Finalization) then
3125          Set_Int (Num_Elab_Calls + 1);
3126
3127       --  When there is finalization, both adainit and adafinal are added
3128
3129       else
3130          Set_Int (Num_Elab_Calls + 2);
3131       end if;
3132    end Set_EA_Last;
3133
3134    -------------
3135    -- Set_Int --
3136    -------------
3137
3138    procedure Set_Int (N : Int) is
3139    begin
3140       if N < 0 then
3141          Set_String ("-");
3142          Set_Int (-N);
3143
3144       else
3145          if N > 9 then
3146             Set_Int (N / 10);
3147          end if;
3148
3149          Last := Last + 1;
3150          Statement_Buffer (Last) :=
3151            Character'Val (N mod 10 + Character'Pos ('0'));
3152       end if;
3153    end Set_Int;
3154
3155    -------------------------
3156    -- Set_IS_Pragma_Table --
3157    -------------------------
3158
3159    procedure Set_IS_Pragma_Table is
3160    begin
3161       for F in ALIs.First .. ALIs.Last loop
3162          for K in ALIs.Table (F).First_Interrupt_State ..
3163                   ALIs.Table (F).Last_Interrupt_State
3164          loop
3165             declare
3166                Inum : constant Int :=
3167                         Interrupt_States.Table (K).Interrupt_Id;
3168                Stat : constant Character :=
3169                         Interrupt_States.Table (K).Interrupt_State;
3170
3171             begin
3172                while IS_Pragma_Settings.Last < Inum loop
3173                   IS_Pragma_Settings.Append ('n');
3174                end loop;
3175
3176                IS_Pragma_Settings.Table (Inum) := Stat;
3177             end;
3178          end loop;
3179       end loop;
3180    end Set_IS_Pragma_Table;
3181
3182    ---------------------------
3183    -- Set_Main_Program_Name --
3184    ---------------------------
3185
3186    procedure Set_Main_Program_Name is
3187    begin
3188       --  Note that name has %b on the end which we ignore
3189
3190       --  First we output the initial _ada_ since we know that the main
3191       --  program is a library level subprogram.
3192
3193       Set_String ("_ada_");
3194
3195       --  Copy name, changing dots to double underscores
3196
3197       for J in 1 .. Name_Len - 2 loop
3198          if Name_Buffer (J) = '.' then
3199             Set_String ("__");
3200          else
3201             Set_Char (Name_Buffer (J));
3202          end if;
3203       end loop;
3204    end Set_Main_Program_Name;
3205
3206    ---------------------
3207    -- Set_Name_Buffer --
3208    ---------------------
3209
3210    procedure Set_Name_Buffer is
3211    begin
3212       for J in 1 .. Name_Len loop
3213          Set_Char (Name_Buffer (J));
3214       end loop;
3215    end Set_Name_Buffer;
3216
3217    ----------------
3218    -- Set_String --
3219    ----------------
3220
3221    procedure Set_String (S : String) is
3222    begin
3223       Statement_Buffer (Last + 1 .. Last + S'Length) := S;
3224       Last := Last + S'Length;
3225    end Set_String;
3226
3227    -------------------
3228    -- Set_Unit_Name --
3229    -------------------
3230
3231    procedure Set_Unit_Name is
3232    begin
3233       for J in 1 .. Name_Len - 2 loop
3234          if Name_Buffer (J) /= '.' then
3235             Set_Char (Name_Buffer (J));
3236          else
3237             Set_String ("__");
3238          end if;
3239       end loop;
3240    end Set_Unit_Name;
3241
3242    ---------------------
3243    -- Set_Unit_Number --
3244    ---------------------
3245
3246    procedure Set_Unit_Number (U : Unit_Id) is
3247       Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First);
3248       Unum      : constant Nat := Nat (U) - Nat (Unit_Id'First);
3249
3250    begin
3251       if Num_Units >= 10 and then Unum < 10 then
3252          Set_Char ('0');
3253       end if;
3254
3255       if Num_Units >= 100 and then Unum < 100 then
3256          Set_Char ('0');
3257       end if;
3258
3259       Set_Int (Unum);
3260    end Set_Unit_Number;
3261
3262    ------------
3263    -- Tab_To --
3264    ------------
3265
3266    procedure Tab_To (N : Natural) is
3267    begin
3268       while Last < N loop
3269          Set_Char (' ');
3270       end loop;
3271    end Tab_To;
3272
3273    ----------------------
3274    -- Write_Info_Ada_C --
3275    ----------------------
3276
3277    procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is
3278    begin
3279       if Ada_Bind_File then
3280          declare
3281             S : String (1 .. Ada'Length + Common'Length);
3282          begin
3283             S (1 .. Ada'Length) := Ada;
3284             S (Ada'Length + 1 .. S'Length) := Common;
3285             WBI (S);
3286          end;
3287
3288       else
3289          declare
3290             S : String (1 .. C'Length + Common'Length);
3291          begin
3292             S (1 .. C'Length) := C;
3293             S (C'Length + 1 .. S'Length) := Common;
3294             WBI (S);
3295          end;
3296       end if;
3297    end Write_Info_Ada_C;
3298
3299    ----------------------------
3300    -- Write_Statement_Buffer --
3301    ----------------------------
3302
3303    procedure Write_Statement_Buffer is
3304    begin
3305       WBI (Statement_Buffer (1 .. Last));
3306       Last := 0;
3307    end Write_Statement_Buffer;
3308
3309    procedure Write_Statement_Buffer (S : String) is
3310    begin
3311       Set_String (S);
3312       Write_Statement_Buffer;
3313    end Write_Statement_Buffer;
3314
3315 end Bindgen;