gcc/ada/bindgen.adb

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