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