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