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