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       Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
1898
1899    begin
1900       --  Acquire settings for Interrupt_State pragmas
1901
1902       Set_IS_Pragma_Table;
1903
1904       --  Override Ada_Bind_File and Bind_Main_Program for Java since
1905       --  JGNAT only supports Ada code, and the main program is already
1906       --  generated by the compiler.
1907
1908       if Hostparm.Java_VM then
1909          Ada_Bind_File := True;
1910          Bind_Main_Program := False;
1911       end if;
1912
1913       --  Override time slice value if -T switch is set
1914
1915       if Time_Slice_Set then
1916          ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value;
1917       end if;
1918
1919       --  Count number of elaboration calls
1920
1921       for E in Elab_Order.First .. Elab_Order.Last loop
1922          if Units.Table (Elab_Order.Table (E)).No_Elab then
1923             null;
1924          else
1925             Num_Elab_Calls := Num_Elab_Calls + 1;
1926          end if;
1927       end loop;
1928
1929       --  Get the time stamp of the former bind for public version warning
1930
1931       if Is_Public_Version then
1932          Record_Time_From_Last_Bind;
1933       end if;
1934
1935       --  Generate output file in appropriate language
1936
1937       if Ada_Bind_File then
1938          Gen_Output_File_Ada (Filename);
1939       else
1940          Gen_Output_File_C (Filename);
1941       end if;
1942
1943       --  Periodically issue a warning when the public version is used on
1944       --  big projects
1945
1946       if Is_Public_Version then
1947          Public_Version_Warning;
1948       end if;
1949    end Gen_Output_File;
1950
1951    -------------------------
1952    -- Gen_Output_File_Ada --
1953    -------------------------
1954
1955    procedure Gen_Output_File_Ada (Filename : String) is
1956
1957       Bfiles : Name_Id;
1958       --  Name of generated bind file (spec)
1959
1960       Bfileb : Name_Id;
1961       --  Name of generated bind file (body)
1962
1963       Ada_Main : constant String := Get_Ada_Main_Name;
1964       --  Name to be used for generated Ada main program. See the body of
1965       --  function Get_Ada_Main_Name for details on the form of the name.
1966
1967    begin
1968       --  Create spec first
1969
1970       Create_Binder_Output (Filename, 's', Bfiles);
1971
1972       --  If we are operating in Restrictions (No_Exception_Handlers) mode,
1973       --  then we need to make sure that the binder program is compiled with
1974       --  the same restriction, so that no exception tables are generated.
1975
1976       if Restrictions_On_Target (No_Exception_Handlers) then
1977          WBI ("pragma Restrictions (No_Exception_Handlers);");
1978       end if;
1979
1980       --  Generate with of System so we can reference System.Address
1981
1982       WBI ("with System;");
1983
1984       --  Generate with of System.Initialize_Scalars if active
1985
1986       if Initialize_Scalars_Used then
1987          WBI ("with System.Scalar_Values;");
1988       end if;
1989
1990       Resolve_Binder_Options;
1991
1992       if not Suppress_Standard_Library_On_Target then
1993
1994          --  Usually, adafinal is called using a pragma Import C. Since
1995          --  Import C doesn't have the same semantics for JGNAT, we use
1996          --  standard Ada.
1997
1998          if Hostparm.Java_VM then
1999             WBI ("with System.Standard_Library;");
2000          end if;
2001       end if;
2002
2003       WBI ("package " & Ada_Main & " is");
2004       WBI ("   pragma Warnings (Off);");
2005
2006       --  Main program case
2007
2008       if Bind_Main_Program then
2009
2010          --  Generate argc/argv stuff unless suppressed
2011
2012          if Command_Line_Args_On_Target
2013            or not Configurable_Run_Time_On_Target
2014          then
2015             WBI ("");
2016             WBI ("   gnat_argc : Integer;");
2017             WBI ("   gnat_argv : System.Address;");
2018             WBI ("   gnat_envp : System.Address;");
2019
2020             --  If the standard library is not suppressed, these variables are
2021             --  in the runtime data area for easy access from the runtime
2022
2023             if not Suppress_Standard_Library_On_Target then
2024                WBI ("");
2025                WBI ("   pragma Import (C, gnat_argc);");
2026                WBI ("   pragma Import (C, gnat_argv);");
2027                WBI ("   pragma Import (C, gnat_envp);");
2028             end if;
2029          end if;
2030
2031          --  Define exit status. Again in normal mode, this is in the
2032          --  run-time library, and is initialized there, but in the
2033          --  configurable runtime case, the variable is declared and
2034          --  initialized in this file.
2035
2036          WBI ("");
2037
2038          if Configurable_Run_Time_Mode then
2039             if Exit_Status_Supported_On_Target then
2040                WBI ("   gnat_exit_status : Integer := 0;");
2041             end if;
2042          else
2043             WBI ("   gnat_exit_status : Integer;");
2044             WBI ("   pragma Import (C, gnat_exit_status);");
2045          end if;
2046       end if;
2047
2048       --  Generate the GNAT_Version and Ada_Main_Program_Name info only for
2049       --  the main program. Otherwise, it can lead under some circumstances
2050       --  to a symbol duplication during the link (for instance when a
2051       --  C program uses 2 Ada libraries)
2052
2053       if Bind_Main_Program then
2054          WBI ("");
2055          WBI ("   GNAT_Version : constant String :=");
2056          WBI ("                    ""GNAT Version: " &
2057                                    Gnat_Version_String & """;");
2058          WBI ("   pragma Export (C, GNAT_Version, ""__gnat_version"");");
2059
2060          WBI ("");
2061          Set_String ("   Ada_Main_Program_Name : constant String := """);
2062          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2063          Set_Main_Program_Name;
2064          Set_String (""" & Ascii.NUL;");
2065          Write_Statement_Buffer;
2066
2067          WBI
2068            ("   pragma Export (C, Ada_Main_Program_Name, " &
2069             """__gnat_ada_main_program_name"");");
2070       end if;
2071
2072       --  No need to generate a finalization routine if finalization
2073       --  is restricted, since there is nothing to do in this case.
2074
2075       if not Restrictions_On_Target (No_Finalization) then
2076          WBI ("");
2077          WBI ("   procedure " & Ada_Final_Name.all & ";");
2078          WBI ("   pragma Export (C, " & Ada_Final_Name.all & ", """ &
2079               Ada_Final_Name.all & """);");
2080       end if;
2081
2082       WBI ("");
2083       WBI ("   procedure " & Ada_Init_Name.all & ";");
2084       WBI ("   pragma Export (C, " & Ada_Init_Name.all & ", """ &
2085            Ada_Init_Name.all & """);");
2086
2087       if Bind_Main_Program then
2088
2089          --  If we have the standard library, then Break_Start is defined
2090          --  there, but when the standard library is suppressed, Break_Start
2091          --  is defined here.
2092
2093          WBI ("");
2094          WBI ("   procedure Break_Start;");
2095
2096          if Suppress_Standard_Library_On_Target then
2097             WBI ("   pragma Export (C, Break_Start, ""__gnat_break_start"");");
2098          else
2099             WBI ("   pragma Import (C, Break_Start, ""__gnat_break_start"");");
2100          end if;
2101
2102          WBI ("");
2103
2104          if Exit_Status_Supported_On_Target then
2105             Set_String ("   function ");
2106          else
2107             Set_String ("   procedure ");
2108          end if;
2109
2110          Set_String (Get_Main_Name);
2111
2112          --  Generate argument list if present
2113
2114          if Command_Line_Args_On_Target then
2115             Write_Statement_Buffer;
2116             WBI ("     (argc : Integer;");
2117             WBI ("      argv : System.Address;");
2118             Set_String
2119                 ("      envp : System.Address)");
2120
2121             if Exit_Status_Supported_On_Target then
2122                Write_Statement_Buffer;
2123                WBI ("      return Integer;");
2124             else
2125                Write_Statement_Buffer (";");
2126             end if;
2127
2128          else
2129             if Exit_Status_Supported_On_Target then
2130                Write_Statement_Buffer (" return Integer;");
2131             else
2132                Write_Statement_Buffer (";");
2133             end if;
2134          end if;
2135
2136          WBI ("   pragma Export (C, " & Get_Main_Name & ", """ &
2137            Get_Main_Name & """);");
2138       end if;
2139
2140       Gen_Versions_Ada;
2141       Gen_Elab_Order_Ada;
2142
2143       --  Spec is complete
2144
2145       WBI ("");
2146       WBI ("end " & Ada_Main & ";");
2147       Close_Binder_Output;
2148
2149       --  Prepare to write body
2150
2151       Create_Binder_Output (Filename, 'b', Bfileb);
2152
2153       --  Output Source_File_Name pragmas which look like
2154
2155       --    pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
2156       --    pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb");
2157
2158       --  where sss/bbb are the spec/body file names respectively
2159
2160       Get_Name_String (Bfiles);
2161       Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2162
2163       WBI ("pragma Source_File_Name (" &
2164            Ada_Main &
2165            ", Spec_File_Name => """ &
2166            Name_Buffer (1 .. Name_Len + 3));
2167
2168       Get_Name_String (Bfileb);
2169       Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
2170
2171       WBI ("pragma Source_File_Name (" &
2172            Ada_Main &
2173            ", Body_File_Name => """ &
2174            Name_Buffer (1 .. Name_Len + 3));
2175
2176       WBI ("");
2177       WBI ("package body " & Ada_Main & " is");
2178       WBI ("   pragma Warnings (Off);");
2179
2180       --  Import the finalization procedure only if finalization active
2181
2182       if not Restrictions_On_Target (No_Finalization) then
2183
2184          --  In the Java case, pragma Import C cannot be used, so the
2185          --  standard Ada constructs will be used instead.
2186
2187          if not Hostparm.Java_VM then
2188             WBI ("");
2189             WBI ("   procedure Do_Finalize;");
2190             WBI
2191               ("   pragma Import (C, Do_Finalize, " &
2192                """system__standard_library__adafinal"");");
2193             WBI ("");
2194          end if;
2195       end if;
2196
2197       Gen_Adainit_Ada;
2198
2199       --  No need to generate a finalization routine if no finalization
2200
2201       if not Restrictions_On_Target (No_Finalization) then
2202          Gen_Adafinal_Ada;
2203       end if;
2204
2205       if Bind_Main_Program then
2206
2207          --  When suppressing the standard library then generate dummy body
2208          --  for Break_Start
2209
2210          if Suppress_Standard_Library_On_Target then
2211             WBI ("");
2212             WBI ("   procedure Break_Start is");
2213             WBI ("   begin");
2214             WBI ("      null;");
2215             WBI ("   end;");
2216          end if;
2217
2218          Gen_Main_Ada;
2219       end if;
2220
2221       --  Output object file list and the Ada body is complete
2222
2223       Gen_Object_Files_Options;
2224
2225       WBI ("");
2226       WBI ("end " & Ada_Main & ";");
2227
2228       Close_Binder_Output;
2229    end Gen_Output_File_Ada;
2230
2231    -----------------------
2232    -- Gen_Output_File_C --
2233    -----------------------
2234
2235    procedure Gen_Output_File_C (Filename : String) is
2236
2237       Bfile : Name_Id;
2238       --  Name of generated bind file
2239
2240    begin
2241       Create_Binder_Output (Filename, 'c', Bfile);
2242
2243       Resolve_Binder_Options;
2244
2245       WBI ("extern void __gnat_set_globals");
2246       WBI ("  (int, int, char, char, char, char,");
2247       WBI ("   const char *, const char *,");
2248       WBI ("   int, int, int, int);");
2249       WBI ("extern void " & Ada_Final_Name.all & " (void);");
2250       WBI ("extern void " & Ada_Init_Name.all & " (void);");
2251       WBI ("extern void system__standard_library__adafinal (void);");
2252
2253       if not No_Main_Subprogram then
2254          Set_String ("extern ");
2255
2256          if Exit_Status_Supported_On_Target then
2257             Set_String ("int");
2258          else
2259             Set_String ("void");
2260          end if;
2261
2262          Set_String (" main ");
2263
2264          if Command_Line_Args_On_Target then
2265             Write_Statement_Buffer ("(int, char **, char **);");
2266          else
2267             Write_Statement_Buffer ("(void);");
2268          end if;
2269
2270          if OpenVMS_On_Target then
2271             WBI ("extern void __posix_exit (int);");
2272          else
2273             WBI ("extern void exit (int);");
2274          end if;
2275
2276          WBI ("extern void __gnat_break_start (void);");
2277          Set_String ("extern ");
2278
2279          if ALIs.Table (ALIs.First).Main_Program = Proc then
2280             Set_String ("void ");
2281          else
2282             Set_String ("int ");
2283          end if;
2284
2285          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2286          Set_Main_Program_Name;
2287          Set_String (" (void);");
2288          Write_Statement_Buffer;
2289       end if;
2290
2291       if not Suppress_Standard_Library_On_Target then
2292          WBI ("extern void __gnat_initialize (void);");
2293          WBI ("extern void __gnat_finalize (void);");
2294          WBI ("extern void __gnat_install_handler (void);");
2295       end if;
2296
2297       WBI ("");
2298
2299       Gen_Elab_Defs_C;
2300
2301       --  Imported variable used to track elaboration/finalization phase.
2302       --  Used only when we have a runtime.
2303
2304       if not Suppress_Standard_Library_On_Target then
2305          WBI ("extern int  __gnat_handler_installed;");
2306          WBI ("");
2307       end if;
2308
2309       --  Write argv/argc exit status stuff if main program case
2310
2311       if Bind_Main_Program then
2312
2313          --  First deal with argc/argv/envp. In the normal case they
2314          --  are in the run-time library.
2315
2316          if not Configurable_Run_Time_On_Target then
2317             WBI ("extern int gnat_argc;");
2318             WBI ("extern char **gnat_argv;");
2319             WBI ("extern char **gnat_envp;");
2320             WBI ("extern int gnat_exit_status;");
2321
2322          --  If configurable run time and no command line args, then the
2323          --  generation of these variables is entirely suppressed.
2324
2325          elsif not Command_Line_Args_On_Target then
2326             null;
2327
2328          --  Otherwise, in the configurable run-time case they are right in
2329          --  the binder file.
2330
2331          else
2332             WBI ("int gnat_argc;");
2333             WBI ("char **gnat_argv;");
2334             WBI ("char **gnat_envp;");
2335             WBI ("int gnat_exit_status = 0;");
2336          end if;
2337
2338          --  Similarly deal with exit status
2339          --  are in the run-time library.
2340
2341          if not Configurable_Run_Time_On_Target then
2342             WBI ("extern int gnat_exit_status;");
2343
2344          --  If configurable run time and no exit status on target, then
2345          --  the generation of this variables is entirely suppressed.
2346
2347          elsif not Exit_Status_Supported_On_Target then
2348             null;
2349
2350          --  Otherwise, in the configurable run-time case this variable is
2351          --  right in the binder file, and initialized to zero there.
2352
2353          else
2354             WBI ("int gnat_exit_status = 0;");
2355          end if;
2356
2357          WBI ("");
2358       end if;
2359
2360       --  When suppressing the standard library, the __gnat_break_start
2361       --  routine (for the debugger to get initial control) is defined in
2362       --  this file.
2363
2364       if Suppress_Standard_Library_On_Target then
2365          WBI ("");
2366          WBI ("void __gnat_break_start () {}");
2367       end if;
2368
2369       --  Generate the __gnat_version and __gnat_ada_main_program_name info
2370       --  only for the main program. Otherwise, it can lead under some
2371       --  circumstances to a symbol duplication during the link (for instance
2372       --  when a C program uses 2 Ada libraries)
2373
2374       if Bind_Main_Program then
2375          WBI ("");
2376          WBI ("char __gnat_version[] = ""GNAT Version: " &
2377                                    Gnat_Version_String & """;");
2378
2379          Set_String ("char __gnat_ada_main_program_name[] = """);
2380          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2381          Set_Main_Program_Name;
2382          Set_String (""";");
2383          Write_Statement_Buffer;
2384       end if;
2385
2386       --  Generate the adafinal routine. In no runtime mode, this is
2387       --  not needed, since there is no finalization to do.
2388
2389       if not Restrictions_On_Target (No_Finalization) then
2390          Gen_Adafinal_C;
2391       end if;
2392
2393       Gen_Adainit_C;
2394
2395       --  Main is only present for Ada main case
2396
2397       if Bind_Main_Program then
2398          Gen_Main_C;
2399       end if;
2400
2401       --  Generate versions, elaboration order, list of object files
2402
2403       Gen_Versions_C;
2404       Gen_Elab_Order_C;
2405       Gen_Object_Files_Options;
2406
2407       --  C binder output is complete
2408
2409       Close_Binder_Output;
2410    end Gen_Output_File_C;
2411
2412    ----------------------
2413    -- Gen_Versions_Ada --
2414    ----------------------
2415
2416    --  This routine generates two sets of lines. The first set has the form:
2417
2418    --    unnnnn : constant Integer := 16#hhhhhhhh#;
2419
2420    --  The second set has the form
2421
2422    --    pragma Export (C, unnnnn, unam);
2423
2424    --  for each unit, where unam is the unit name suffixed by either B or
2425    --  S for body or spec, with dots replaced by double underscores, and
2426    --  hhhhhhhh is the version number, and nnnnn is a 5-digits serial number.
2427
2428    procedure Gen_Versions_Ada is
2429       Ubuf : String (1 .. 6) := "u00000";
2430
2431       procedure Increment_Ubuf;
2432       --  Little procedure to increment the serial number
2433
2434       procedure Increment_Ubuf is
2435       begin
2436          for J in reverse Ubuf'Range loop
2437             Ubuf (J) := Character'Succ (Ubuf (J));
2438             exit when Ubuf (J) <= '9';
2439             Ubuf (J) := '0';
2440          end loop;
2441       end Increment_Ubuf;
2442
2443    --  Start of processing for Gen_Versions_Ada
2444
2445    begin
2446       if Bind_For_Library then
2447
2448          --  When building libraries, the version number of each unit can
2449          --  not be computed, since the binder does not know the full list
2450          --  of units. Therefore, the 'Version and 'Body_Version
2451          --  attributes can not supported in this case.
2452
2453          return;
2454       end if;
2455
2456       WBI ("");
2457
2458       WBI ("   type Version_32 is mod 2 ** 32;");
2459       for U in Units.First .. Units.Last loop
2460          Increment_Ubuf;
2461          WBI ("   " & Ubuf & " : constant Version_32 := 16#" &
2462               Units.Table (U).Version & "#;");
2463       end loop;
2464
2465       WBI ("");
2466       Ubuf := "u00000";
2467
2468       for U in Units.First .. Units.Last loop
2469          Increment_Ubuf;
2470          Set_String ("   pragma Export (C, ");
2471          Set_String (Ubuf);
2472          Set_String (", """);
2473
2474          Get_Name_String (Units.Table (U).Uname);
2475
2476          for K in 1 .. Name_Len loop
2477             if Name_Buffer (K) = '.' then
2478                Set_Char ('_');
2479                Set_Char ('_');
2480
2481             elsif Name_Buffer (K) = '%' then
2482                exit;
2483
2484             else
2485                Set_Char (Name_Buffer (K));
2486             end if;
2487          end loop;
2488
2489          if Name_Buffer (Name_Len) = 's' then
2490             Set_Char ('S');
2491          else
2492             Set_Char ('B');
2493          end if;
2494
2495          Set_String (""");");
2496          Write_Statement_Buffer;
2497       end loop;
2498
2499    end Gen_Versions_Ada;
2500
2501    --------------------
2502    -- Gen_Versions_C --
2503    --------------------
2504
2505    --  This routine generates a line of the form:
2506
2507    --    unsigned unam = 0xhhhhhhhh;
2508
2509    --  for each unit, where unam is the unit name suffixed by either B or
2510    --  S for body or spec, with dots replaced by double underscores.
2511
2512    procedure Gen_Versions_C is
2513    begin
2514       if Bind_For_Library then
2515
2516          --  When building libraries, the version number of each unit can
2517          --  not be computed, since the binder does not know the full list
2518          --  of units. Therefore, the 'Version and 'Body_Version
2519          --  attributes can not supported.
2520
2521          return;
2522       end if;
2523
2524       for U in Units.First .. Units.Last loop
2525          Set_String ("unsigned ");
2526
2527          Get_Name_String (Units.Table (U).Uname);
2528
2529          for K in 1 .. Name_Len loop
2530             if Name_Buffer (K) = '.' then
2531                Set_String ("__");
2532
2533             elsif Name_Buffer (K) = '%' then
2534                exit;
2535
2536             else
2537                Set_Char (Name_Buffer (K));
2538             end if;
2539          end loop;
2540
2541          if Name_Buffer (Name_Len) = 's' then
2542             Set_Char ('S');
2543          else
2544             Set_Char ('B');
2545          end if;
2546
2547          Set_String (" = 0x");
2548          Set_String (Units.Table (U).Version);
2549          Set_Char   (';');
2550          Write_Statement_Buffer;
2551       end loop;
2552
2553    end Gen_Versions_C;
2554
2555    -----------------------
2556    -- Get_Ada_Main_Name --
2557    -----------------------
2558
2559    function Get_Ada_Main_Name return String is
2560       Suffix : constant String := "_00";
2561       Name   : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
2562                  Opt.Ada_Main_Name.all & Suffix;
2563       Nlen   : Natural;
2564
2565    begin
2566       --  The main program generated by JGNAT expects a package called
2567       --  ada_<main procedure>.
2568
2569       if Hostparm.Java_VM then
2570          --  Get main program name
2571
2572          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2573
2574          --  Remove the %b
2575
2576          return "ada_" & Name_Buffer (1 .. Name_Len - 2);
2577       end if;
2578
2579       --  This loop tries the following possibilities in order
2580       --    <Ada_Main>
2581       --    <Ada_Main>_01
2582       --    <Ada_Main>_02
2583       --    ..
2584       --    <Ada_Main>_99
2585       --  where <Ada_Main> is equal to Opt.Ada_Main_Name. By default,
2586       --  it is set to 'ada_main'.
2587
2588       for J in 0 .. 99 loop
2589          if J = 0 then
2590             Nlen := Name'Length - Suffix'Length;
2591          else
2592             Nlen := Name'Length;
2593             Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0'));
2594             Name (Name'Last - 1) :=
2595               Character'Val (J /   10 + Character'Pos ('0'));
2596          end if;
2597
2598          for K in ALIs.First .. ALIs.Last loop
2599             for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop
2600
2601                --  Get unit name, removing %b or %e at end
2602
2603                Get_Name_String (Units.Table (L).Uname);
2604                Name_Len := Name_Len - 2;
2605
2606                if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then
2607                   goto Continue;
2608                end if;
2609             end loop;
2610          end loop;
2611
2612          return Name (1 .. Nlen);
2613
2614       <<Continue>>
2615          null;
2616       end loop;
2617
2618       --  If we fall through, just use a peculiar unlikely name
2619
2620       return ("Qwertyuiop");
2621    end Get_Ada_Main_Name;
2622
2623    -------------------
2624    -- Get_Main_Name --
2625    -------------------
2626
2627    function Get_Main_Name return String is
2628    begin
2629       --  Explicit name given with -M switch
2630
2631       if Bind_Alternate_Main_Name then
2632          return Alternate_Main_Name.all;
2633
2634       --  Case of main program name to be used directly
2635
2636       elsif Use_Ada_Main_Program_Name_On_Target then
2637
2638          --  Get main program name
2639
2640          Get_Name_String (Units.Table (First_Unit_Entry).Uname);
2641
2642          --  If this is a child name, return only the name of the child,
2643          --  since we can't have dots in a nested program name. Note that
2644          --  we do not include the %b at the end of the unit name.
2645
2646          for J in reverse 1 .. Name_Len - 2 loop
2647             if J = 1 or else Name_Buffer (J - 1) = '.' then
2648                return Name_Buffer (J .. Name_Len - 2);
2649             end if;
2650          end loop;
2651
2652          raise Program_Error; -- impossible exit
2653
2654       --  Case where "main" is to be used as default
2655
2656       else
2657          return "main";
2658       end if;
2659    end Get_Main_Name;
2660
2661    ----------------------
2662    -- Lt_Linker_Option --
2663    ----------------------
2664
2665    function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
2666    begin
2667       --  Sort internal files last
2668
2669       if Linker_Options.Table (Op1).Internal_File
2670            /=
2671          Linker_Options.Table (Op2).Internal_File
2672       then
2673          --  Note: following test uses False < True
2674
2675          return Linker_Options.Table (Op1).Internal_File
2676                   <
2677                 Linker_Options.Table (Op2).Internal_File;
2678
2679       --  If both internal or both non-internal, sort according to the
2680       --  elaboration position. A unit that is elaborated later should
2681       --  come earlier in the linker options list.
2682
2683       else
2684          return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
2685                   >
2686                 Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
2687
2688       end if;
2689    end Lt_Linker_Option;
2690
2691    ------------------------
2692    -- Move_Linker_Option --
2693    ------------------------
2694
2695    procedure Move_Linker_Option (From : Natural; To : Natural) is
2696    begin
2697       Linker_Options.Table (To) := Linker_Options.Table (From);
2698    end Move_Linker_Option;
2699
2700    ----------------------------
2701    -- Public_Version_Warning --
2702    ----------------------------
2703
2704    procedure Public_Version_Warning is
2705
2706       Time : constant Int := Time_From_Last_Bind;
2707
2708       --  Constants to help defining periods
2709
2710       Hour : constant := 60;
2711       Day  : constant := 24 * Hour;
2712
2713       Never : constant := Integer'Last;
2714       --  Special value indicating no warnings should be given
2715
2716       --  Constants defining when the warning is issued. Programs with more
2717       --  than Large Units will issue a warning every Period_Large amount of
2718       --  time. Smaller programs will generate a warning every Period_Small
2719       --  amount of time.
2720
2721       Large : constant := 20;
2722       --  Threshold for considering a program small or large
2723
2724       Period_Large : constant := Day;
2725       --  Periodic warning time for large programs
2726
2727       Period_Small : constant := Never;
2728       --  Periodic warning time for small programs
2729
2730       Nb_Unit : Int;
2731
2732    begin
2733       --  Compute the number of units that are not GNAT internal files
2734
2735       Nb_Unit := 0;
2736       for A in ALIs.First .. ALIs.Last loop
2737          if not Is_Internal_File_Name (ALIs.Table (A).Sfile) then
2738             Nb_Unit := Nb_Unit + 1;
2739          end if;
2740       end loop;
2741
2742       --  Do not emit the message if the last message was emitted in the
2743       --  specified period taking into account the number of units.
2744
2745       if Nb_Unit < Large and then Time <= Period_Small then
2746          return;
2747
2748       elsif Time <= Period_Large then
2749          return;
2750       end if;
2751
2752       Write_Eol;
2753       Write_Str ("IMPORTANT NOTICE:");
2754       Write_Eol;
2755       Write_Str ("    This version of GNAT is unsupported"
2756         &                        " and comes with absolutely no warranty.");
2757       Write_Eol;
2758       Write_Str ("    If you intend to evaluate or use GNAT for building "
2759         &                                       "commercial applications,");
2760       Write_Eol;
2761       Write_Str ("    please consult http://www.gnat.com/ for information");
2762       Write_Eol;
2763       Write_Str ("    on the GNAT Professional product line.");
2764       Write_Eol;
2765       Write_Eol;
2766    end Public_Version_Warning;
2767
2768    ----------------------------
2769    -- Resolve_Binder_Options --
2770    ----------------------------
2771
2772    procedure Resolve_Binder_Options is
2773    begin
2774       for E in Elab_Order.First .. Elab_Order.Last loop
2775          Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
2776
2777          --  The procedure of looking for specific packages and setting
2778          --  flags is somewhat dubious, but there isn't a good alternative
2779          --  at the current time ???
2780
2781          if Name_Buffer (1 .. 19) = "system.os_interface" then
2782             With_GNARL := True;
2783          end if;
2784
2785          if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then
2786             With_DECGNAT := True;
2787          end if;
2788       end loop;
2789    end Resolve_Binder_Options;
2790
2791    --------------
2792    -- Set_Char --
2793    --------------
2794
2795    procedure Set_Char (C : Character) is
2796    begin
2797       Last := Last + 1;
2798       Statement_Buffer (Last) := C;
2799    end Set_Char;
2800
2801    -------------
2802    -- Set_Int --
2803    -------------
2804
2805    procedure Set_Int (N : Int) is
2806    begin
2807       if N < 0 then
2808          Set_String ("-");
2809          Set_Int (-N);
2810
2811       else
2812          if N > 9 then
2813             Set_Int (N / 10);
2814          end if;
2815
2816          Last := Last + 1;
2817          Statement_Buffer (Last) :=
2818            Character'Val (N mod 10 + Character'Pos ('0'));
2819       end if;
2820    end Set_Int;
2821
2822    -------------------------
2823    -- Set_IS_Pragma_Table --
2824    -------------------------
2825
2826    procedure Set_IS_Pragma_Table is
2827    begin
2828       for F in ALIs.First .. ALIs.Last loop
2829          for K in ALIs.Table (F).First_Interrupt_State ..
2830                   ALIs.Table (F).Last_Interrupt_State
2831          loop
2832             declare
2833                Inum : constant Int :=
2834                         Interrupt_States.Table (K).Interrupt_Id;
2835                Stat : constant Character :=
2836                         Interrupt_States.Table (K).Interrupt_State;
2837
2838             begin
2839                while IS_Pragma_Settings.Last < Inum loop
2840                   IS_Pragma_Settings.Append ('n');
2841                end loop;
2842
2843                IS_Pragma_Settings.Table (Inum) := Stat;
2844             end;
2845          end loop;
2846       end loop;
2847    end Set_IS_Pragma_Table;
2848
2849    ---------------------------
2850    -- Set_Main_Program_Name --
2851    ---------------------------
2852
2853    procedure Set_Main_Program_Name is
2854    begin
2855       --  Note that name has %b on the end which we ignore
2856
2857       --  First we output the initial _ada_ since we know that the main
2858       --  program is a library level subprogram.
2859
2860       Set_String ("_ada_");
2861
2862       --  Copy name, changing dots to double underscores
2863
2864       for J in 1 .. Name_Len - 2 loop
2865          if Name_Buffer (J) = '.' then
2866             Set_String ("__");
2867          else
2868             Set_Char (Name_Buffer (J));
2869          end if;
2870       end loop;
2871    end Set_Main_Program_Name;
2872
2873    ---------------------
2874    -- Set_Name_Buffer --
2875    ---------------------
2876
2877    procedure Set_Name_Buffer is
2878    begin
2879       for J in 1 .. Name_Len loop
2880          Set_Char (Name_Buffer (J));
2881       end loop;
2882    end Set_Name_Buffer;
2883
2884    ----------------
2885    -- Set_String --
2886    ----------------
2887
2888    procedure Set_String (S : String) is
2889    begin
2890       Statement_Buffer (Last + 1 .. Last + S'Length) := S;
2891       Last := Last + S'Length;
2892    end Set_String;
2893
2894    -------------------
2895    -- Set_Unit_Name --
2896    -------------------
2897
2898    procedure Set_Unit_Name is
2899    begin
2900       for J in 1 .. Name_Len - 2 loop
2901          if Name_Buffer (J) /= '.' then
2902             Set_Char (Name_Buffer (J));
2903          else
2904             Set_String ("__");
2905          end if;
2906       end loop;
2907    end Set_Unit_Name;
2908
2909    ---------------------
2910    -- Set_Unit_Number --
2911    ---------------------
2912
2913    procedure Set_Unit_Number (U : Unit_Id) is
2914       Num_Units : constant Nat := Nat (Units.Table'Last) - Nat (Unit_Id'First);
2915       Unum      : constant Nat := Nat (U) - Nat (Unit_Id'First);
2916
2917    begin
2918       if Num_Units >= 10 and then Unum < 10 then
2919          Set_Char ('0');
2920       end if;
2921
2922       if Num_Units >= 100 and then Unum < 100 then
2923          Set_Char ('0');
2924       end if;
2925
2926       Set_Int (Unum);
2927    end Set_Unit_Number;
2928
2929    ------------
2930    -- Tab_To --
2931    ------------
2932
2933    procedure Tab_To (N : Natural) is
2934    begin
2935       while Last < N loop
2936          Set_Char (' ');
2937       end loop;
2938    end Tab_To;
2939
2940    ----------------------
2941    -- Write_Info_Ada_C --
2942    ----------------------
2943
2944    procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is
2945    begin
2946       if Ada_Bind_File then
2947          declare
2948             S : String (1 .. Ada'Length + Common'Length);
2949          begin
2950             S (1 .. Ada'Length) := Ada;
2951             S (Ada'Length + 1 .. S'Length) := Common;
2952             WBI (S);
2953          end;
2954
2955       else
2956          declare
2957             S : String (1 .. C'Length + Common'Length);
2958          begin
2959             S (1 .. C'Length) := C;
2960             S (C'Length + 1 .. S'Length) := Common;
2961             WBI (S);
2962          end;
2963       end if;
2964    end Write_Info_Ada_C;
2965
2966    ----------------------------
2967    -- Write_Statement_Buffer --
2968    ----------------------------
2969
2970    procedure Write_Statement_Buffer is
2971    begin
2972       WBI (Statement_Buffer (1 .. Last));
2973       Last := 0;
2974    end Write_Statement_Buffer;
2975
2976    procedure Write_Statement_Buffer (S : String) is
2977    begin
2978       Set_String (S);
2979       Write_Statement_Buffer;
2980    end Write_Statement_Buffer;
2981
2982 end Bindgen;