gcc/ada/bindgen.adb

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