gcc/ada/bindgen.adb

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