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