gcc/ada/bindgen.adb

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