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