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