gcc/ada/bindgen.adb

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