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