+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- B I N D G E N --
--- --
--- B o d y --
--- --
--- $Revision: 1.5.10.2 $
--- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with ALI; use ALI;
-with Binde; use Binde;
-with Butil; use Butil;
-with Casing; use Casing;
-with Fname; use Fname;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Gnatvsn; use Gnatvsn;
-with Hostparm;
-with Namet; use Namet;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Types; use Types;
-with Sdefault; use Sdefault;
-with System; use System;
-
-with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
-
-package body Bindgen is
-
- Statement_Buffer : String (1 .. 1000);
- -- Buffer used for constructing output statements
-
- Last : Natural := 0;
- -- Last location in Statement_Buffer currently set
-
- With_DECGNAT : Boolean := False;
- -- Flag which indicates whether the program uses the DECGNAT library
- -- (presence of the unit System.Aux_DEC.DECLIB)
-
- With_GNARL : Boolean := False;
- -- Flag which indicates whether the program uses the GNARL library
- -- (presence of the unit System.OS_Interface)
-
- Num_Elab_Calls : Nat := 0;
- -- Number of generated calls to elaboration routines
-
- subtype chars_ptr is Address;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure WBI (Info : String) renames Osint.Write_Binder_Info;
- -- Convenient shorthand used throughout
-
- function ABE_Boolean_Required (U : Unit_Id) return Boolean;
- -- Given a unit id value U, determines if the corresponding unit requires
- -- an access-before-elaboration check variable, i.e. it is a non-predefined
- -- body for which no pragma Elaborate, Elaborate_All or Elaborate_Body is
- -- present, and thus could require ABE checks.
-
- procedure Resolve_Binder_Options;
- -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS
- -- since it tests for a package named "dec" which might cause a conflict
- -- on non-VMS systems.
-
- procedure Gen_Adainit_Ada;
- -- Generates the Adainit procedure (Ada code case)
-
- procedure Gen_Adainit_C;
- -- Generates the Adainit procedure (C code case)
-
- procedure Gen_Adafinal_Ada;
- -- Generate the Adafinal procedure (Ada code case)
-
- procedure Gen_Adafinal_C;
- -- Generate the Adafinal procedure (C code case)
-
- procedure Gen_Elab_Calls_Ada;
- -- Generate sequence of elaboration calls (Ada code case)
-
- procedure Gen_Elab_Calls_C;
- -- Generate sequence of elaboration calls (C code case)
-
- procedure Gen_Elab_Order_Ada;
- -- Generate comments showing elaboration order chosen (Ada case)
-
- procedure Gen_Elab_Order_C;
- -- Generate comments showing elaboration order chosen (C case)
-
- procedure Gen_Elab_Defs_C;
- -- Generate sequence of definitions for elaboration routines (C code case)
-
- procedure Gen_Exception_Table_Ada;
- -- Generate binder exception table (Ada code case). This consists of
- -- declarations followed by a begin followed by a call. If zero cost
- -- exceptions are not active, then only the begin is generated.
-
- procedure Gen_Exception_Table_C;
- -- Generate binder exception table (C code case). This has no effect
- -- if zero cost exceptions are not active, otherwise it generates a
- -- set of declarations followed by a call.
-
- procedure Gen_Main_Ada;
- -- Generate procedure main (Ada code case)
-
- procedure Gen_Main_C;
- -- Generate main() procedure (C code case)
-
- procedure Gen_Object_Files_Options;
- -- Output comments containing a list of the full names of the object
- -- files to be linked and the list of linker options supplied by
- -- Linker_Options pragmas in the source. (C and Ada code case)
-
- procedure Gen_Output_File_Ada (Filename : String);
- -- Generate output file (Ada code case)
-
- procedure Gen_Output_File_C (Filename : String);
- -- Generate output file (C code case)
-
- procedure Gen_Scalar_Values;
- -- Generates scalar initialization values for -Snn. A single procedure
- -- handles both the Ada and C cases, since there is much common code.
-
- procedure Gen_Versions_Ada;
- -- Output series of definitions for unit versions (Ada code case)
-
- procedure Gen_Versions_C;
- -- Output series of definitions for unit versions (C code case)
-
- function Get_Ada_Main_Name return String;
- -- This function is used in the Ada main output case to compute a usable
- -- name for the generated main program. The normal main program name is
- -- Ada_Main, but this won't work if the user has a unit with this name.
- -- This function tries Ada_Main first, and if there is such a clash, then
- -- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.
-
- function Get_Main_Name return String;
- -- This function is used in the Ada main output case to compute the
- -- correct external main program. It is "main" by default, except on
- -- VxWorks where it is the name of the Ada main name without the "_ada".
- -- the -Mname binder option overrides the default with name.
-
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
- -- Compare linker options, when sorting, first according to
- -- Is_Internal_File (internal files come later) and then by elaboration
- -- order position (latest to earliest) except its not possible to
- -- distinguish between a linker option in the spec and one in the body.
-
- procedure Move_Linker_Option (From : Natural; To : Natural);
- -- Move routine for sorting linker options
-
- procedure Set_Char (C : Character);
- -- Set given character in Statement_Buffer at the Last + 1 position
- -- and increment Last by one to reflect the stored character.
-
- procedure Set_Int (N : Int);
- -- Set given value in decimal in Statement_Buffer with no spaces
- -- starting at the Last + 1 position, and updating Last past the value.
- -- A minus sign is output for a negative value.
-
- procedure Set_Main_Program_Name;
- -- Given the main program name in Name_Buffer (length in Name_Len)
- -- generate the name of the routine to be used in the call. The name
- -- is generated starting at Last + 1, and Last is updated past it.
-
- procedure Set_Name_Buffer;
- -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer.
-
- procedure Set_String (S : String);
- -- Sets characters of given string in Statement_Buffer, starting at the
- -- Last + 1 position, and updating last past the string value.
-
- procedure Set_Unit_Name;
- -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer,
- -- starting at the Last + 1 position, and updating last past the value.
- -- changing periods to double underscores, and updating Last appropriately.
-
- procedure Set_Unit_Number (U : Unit_Id);
- -- Sets unit number (first unit is 1, leading zeroes output to line
- -- up all output unit numbers nicely as required by the value, and
- -- by the total number of units.
-
- procedure Tab_To (N : Natural);
- -- If Last is greater than or equal to N, no effect, otherwise store
- -- blanks in Statement_Buffer bumping Last, until Last = N.
-
- function Value (chars : chars_ptr) return String;
- -- Return C NUL-terminated string at chars as an Ada string
-
- procedure Write_Info_Ada_C (Ada : String; C : String; Common : String);
- -- For C code case, write C & Common, for Ada case write Ada & Common
- -- to current binder output file using Write_Binder_Info.
-
- procedure Write_Statement_Buffer;
- -- Write out contents of statement buffer up to Last, and reset Last to 0
-
- procedure Write_Statement_Buffer (S : String);
- -- First writes its argument (using Set_String (S)), then writes out the
- -- contents of statement buffer up to Last, and reset Last to 0
-
- --------------------------
- -- ABE_Boolean_Required --
- --------------------------
-
- function ABE_Boolean_Required (U : Unit_Id) return Boolean is
- Typ : constant Unit_Type := Units.Table (U).Utype;
- Unit : Unit_Id;
-
- begin
- if Typ /= Is_Body then
- return False;
-
- else
- Unit := U + 1;
-
- return (not Units.Table (Unit).Pure)
- and then
- (not Units.Table (Unit).Preelab)
- and then
- (not Units.Table (Unit).Elaborate_Body)
- and then
- (not Units.Table (Unit).Predefined);
- end if;
- end ABE_Boolean_Required;
-
- ----------------------
- -- Gen_Adafinal_Ada --
- ----------------------
-
- procedure Gen_Adafinal_Ada is
- begin
- WBI ("");
- WBI (" procedure " & Ada_Final_Name.all & " is");
- WBI (" begin");
-
- -- If compiling for the JVM, we directly call Adafinal because
- -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
-
- if Hostparm.Java_VM then
- WBI (" System.Standard_Library.Adafinal;");
- else
- WBI (" Do_Finalize;");
- end if;
-
- WBI (" end " & Ada_Final_Name.all & ";");
- end Gen_Adafinal_Ada;
-
- --------------------
- -- Gen_Adafinal_C --
- --------------------
-
- procedure Gen_Adafinal_C is
- begin
- WBI ("void " & Ada_Final_Name.all & " () {");
- WBI (" system__standard_library__adafinal ();");
- WBI ("}");
- WBI ("");
- end Gen_Adafinal_C;
-
- ---------------------
- -- Gen_Adainit_Ada --
- ---------------------
-
- procedure Gen_Adainit_Ada is
- Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
- begin
- WBI (" procedure " & Ada_Init_Name.all & " is");
-
- -- Generate externals for elaboration entities
-
- for E in Elab_Order.First .. Elab_Order.Last loop
- declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
- U : Unit_Record renames Units.Table (Unum);
-
- begin
- if U.Set_Elab_Entity then
- Set_String (" ");
- Set_String ("E");
- Set_Unit_Number (Unum);
- Set_String (" : Boolean; pragma Import (Ada, ");
- Set_String ("E");
- Set_Unit_Number (Unum);
- Set_String (", """);
- Get_Name_String (U.Uname);
-
- -- In the case of JGNAT we need to emit an Import name
- -- that includes the class name (using '$' separators
- -- in the case of a child unit name).
-
- if Hostparm.Java_VM then
- for J in 1 .. Name_Len - 2 loop
- if Name_Buffer (J) /= '.' then
- Set_Char (Name_Buffer (J));
- else
- Set_String ("$");
- end if;
- end loop;
-
- Set_String (".");
-
- -- If the unit name is very long, then split the
- -- Import link name across lines using "&" (occurs
- -- in some C2 tests).
-
- if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then
- Set_String (""" &");
- Write_Statement_Buffer;
- Set_String (" """);
- end if;
- end if;
-
- Set_Unit_Name;
- Set_String ("_E"");");
- Write_Statement_Buffer;
- end if;
- end;
- end loop;
-
- Write_Statement_Buffer;
-
- -- Normal case (not No_Run_Time mode). The global values are
- -- assigned using the runtime routine Set_Globals (we have to use
- -- the routine call, rather than define the globals in the binder
- -- file to deal with cross-library calls in some systems.
-
- if No_Run_Time_Specified then
-
- -- Case of No_Run_Time mode. The only global variable that might
- -- be needed (by the Ravenscar profile) is the priority of the
- -- environment. Also no exception tables are needed.
-
- if Main_Priority /= No_Main_Priority then
- WBI (" Main_Priority : Integer;");
- WBI (" pragma Import (C, Main_Priority," &
- " ""__gl_main_priority"");");
- WBI ("");
- end if;
-
- WBI (" begin");
-
- if Main_Priority /= No_Main_Priority then
- Set_String (" Main_Priority := ");
- Set_Int (Main_Priority);
- Set_Char (';');
- Write_Statement_Buffer;
-
- else
- WBI (" null;");
- end if;
-
- else
- WBI ("");
- WBI (" procedure Set_Globals");
- WBI (" (Main_Priority : Integer;");
- WBI (" Time_Slice_Value : Integer;");
- WBI (" WC_Encoding : Character;");
- WBI (" Locking_Policy : Character;");
- WBI (" Queuing_Policy : Character;");
- WBI (" Task_Dispatching_Policy : Character;");
- WBI (" Adafinal : System.Address;");
- WBI (" Unreserve_All_Interrupts : Integer;");
- WBI (" Exception_Tracebacks : Integer);");
- WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");");
- WBI ("");
-
- -- Import entry point for elaboration time signal handler
- -- installation, and indication of whether it's been called
- -- previously
- WBI ("");
- WBI (" procedure Install_Handler;");
- WBI (" pragma Import (C, Install_Handler, " &
- """__gnat_install_handler"");");
- WBI ("");
- WBI (" Handler_Installed : Integer;");
- WBI (" pragma Import (C, Handler_Installed, " &
- """__gnat_handler_installed"");");
-
- -- Generate exception table
-
- Gen_Exception_Table_Ada;
-
- -- Generate the call to Set_Globals
-
- WBI (" Set_Globals");
-
- Set_String (" (Main_Priority => ");
- Set_Int (Main_Priority);
- Set_Char (',');
- Write_Statement_Buffer;
-
- Set_String (" Time_Slice_Value => ");
-
- if Task_Dispatching_Policy_Specified = 'F'
- and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
- then
- Set_Int (0);
- else
- Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
- end if;
-
- Set_Char (',');
- Write_Statement_Buffer;
-
- Set_String (" WC_Encoding => '");
- Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
- Set_String ("',");
- Write_Statement_Buffer;
-
- Set_String (" Locking_Policy => '");
- Set_Char (Locking_Policy_Specified);
- Set_String ("',");
- Write_Statement_Buffer;
-
- Set_String (" Queuing_Policy => '");
- Set_Char (Queuing_Policy_Specified);
- Set_String ("',");
- Write_Statement_Buffer;
-
- Set_String (" Task_Dispatching_Policy => '");
- Set_Char (Task_Dispatching_Policy_Specified);
- Set_String ("',");
- Write_Statement_Buffer;
-
- WBI (" Adafinal => System.Null_Address,");
-
- Set_String (" Unreserve_All_Interrupts => ");
-
- if Unreserve_All_Interrupts_Specified then
- Set_String ("1");
- else
- Set_String ("0");
- end if;
-
- Set_String (",");
- Write_Statement_Buffer;
-
- Set_String (" Exception_Tracebacks => ");
-
- if Exception_Tracebacks then
- Set_String ("1");
- else
- Set_String ("0");
- end if;
-
- Set_String (");");
- Write_Statement_Buffer;
-
- -- Generate call to Install_Handler
- WBI ("");
- WBI (" if Handler_Installed = 0 then");
- WBI (" Install_Handler;");
- WBI (" end if;");
- end if;
-
- Gen_Elab_Calls_Ada;
-
- WBI (" end " & Ada_Init_Name.all & ";");
- end Gen_Adainit_Ada;
-
- -------------------
- -- Gen_Adainit_C --
- --------------------
-
- procedure Gen_Adainit_C is
- Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
- begin
- WBI ("void " & Ada_Init_Name.all & " ()");
- WBI ("{");
-
- -- Generate externals for elaboration entities
-
- for E in Elab_Order.First .. Elab_Order.Last loop
- declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
- U : Unit_Record renames Units.Table (Unum);
-
- begin
- if U.Set_Elab_Entity then
- Set_String (" extern char ");
- Get_Name_String (U.Uname);
- Set_Unit_Name;
- Set_String ("_E;");
- Write_Statement_Buffer;
- end if;
- end;
- end loop;
-
- Write_Statement_Buffer;
-
- if No_Run_Time_Specified then
-
- -- Case of No_Run_Time mode. Set __gl_main_priority if needed
- -- for the Ravenscar profile.
-
- if Main_Priority /= No_Main_Priority then
- Set_String (" extern int __gl_main_priority = ");
- Set_Int (Main_Priority);
- Set_Char (';');
- Write_Statement_Buffer;
- end if;
-
- else
- -- Code for normal case (not in No_Run_Time mode)
-
- Gen_Exception_Table_C;
-
- -- Generate call to set the runtime global variables defined in
- -- a-init.c. We define the varables in a-init.c, rather than in
- -- the binder generated file itself to avoid undefined externals
- -- when the runtime is linked as a shareable image library.
-
- -- We call the routine from inside adainit() because this works for
- -- both programs with and without binder generated "main" functions.
-
- WBI (" __gnat_set_globals (");
-
- Set_String (" ");
- Set_Int (Main_Priority);
- Set_Char (',');
- Tab_To (15);
- Set_String ("/* Main_Priority */");
- Write_Statement_Buffer;
-
- Set_String (" ");
-
- if Task_Dispatching_Policy = 'F'
- and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
- then
- Set_Int (0);
- else
- Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
- end if;
-
- Set_Char (',');
- Tab_To (15);
- Set_String ("/* Time_Slice_Value */");
- Write_Statement_Buffer;
-
- Set_String (" '");
- Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
- Set_String ("',");
- Tab_To (15);
- Set_String ("/* WC_Encoding */");
- Write_Statement_Buffer;
-
- Set_String (" '");
- Set_Char (Locking_Policy_Specified);
- Set_String ("',");
- Tab_To (15);
- Set_String ("/* Locking_Policy */");
- Write_Statement_Buffer;
-
- Set_String (" '");
- Set_Char (Queuing_Policy_Specified);
- Set_String ("',");
- Tab_To (15);
- Set_String ("/* Queuing_Policy */");
- Write_Statement_Buffer;
-
- Set_String (" '");
- Set_Char (Task_Dispatching_Policy_Specified);
- Set_String ("',");
- Tab_To (15);
- Set_String ("/* Tasking_Dispatching_Policy */");
- Write_Statement_Buffer;
-
- Set_String (" ");
- Set_String ("0,");
- Tab_To (15);
- Set_String ("/* Finalization routine address, not used anymore */");
- Write_Statement_Buffer;
-
- Set_String (" ");
- Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
- Set_String (",");
- Tab_To (15);
- Set_String ("/* Unreserve_All_Interrupts */");
- Write_Statement_Buffer;
-
- Set_String (" ");
- Set_Int (Boolean'Pos (Exception_Tracebacks));
- Set_String (");");
- Tab_To (15);
- Set_String ("/* Exception_Tracebacks */");
- Write_Statement_Buffer;
-
- -- Install elaboration time signal handler
- WBI (" if (__gnat_handler_installed == 0)");
- WBI (" {");
- WBI (" __gnat_install_handler ();");
- WBI (" }");
- end if;
-
- WBI ("");
- Gen_Elab_Calls_C;
- WBI ("}");
- end Gen_Adainit_C;
-
- ------------------------
- -- Gen_Elab_Calls_Ada --
- ------------------------
-
- procedure Gen_Elab_Calls_Ada is
- begin
-
- for E in Elab_Order.First .. Elab_Order.Last loop
- declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
- U : Unit_Record renames Units.Table (Unum);
-
- Unum_Spec : Unit_Id;
- -- This is the unit number of the spec that corresponds to
- -- this entry. It is the same as Unum except when the body
- -- and spec are different and we are currently processing
- -- the body, in which case it is the spec (Unum + 1).
-
- procedure Set_Elab_Entity;
- -- Set name of elaboration entity flag
-
- procedure Set_Elab_Entity is
- begin
- Get_Decoded_Name_String_With_Brackets (U.Uname);
- Name_Len := Name_Len - 2;
- Set_Casing (U.Icasing);
- Set_Name_Buffer;
- end Set_Elab_Entity;
-
- begin
- if U.Utype = Is_Body then
- Unum_Spec := Unum + 1;
- else
- Unum_Spec := Unum;
- end if;
-
- -- Case of no elaboration code
-
- if U.No_Elab then
-
- -- The only case in which we have to do something is if
- -- this is a body, with a separate spec, where the separate
- -- spec has an elaboration entity defined.
-
- -- In that case, this is where we set the elaboration entity
- -- to True, we do not need to test if this has already been
- -- done, since it is quicker to set the flag than to test it.
-
- if U.Utype = Is_Body
- and then Units.Table (Unum_Spec).Set_Elab_Entity
- then
- Set_String (" E");
- Set_Unit_Number (Unum_Spec);
- Set_String (" := True;");
- Write_Statement_Buffer;
- end if;
-
- -- Here if elaboration code is present. We generate:
-
- -- if not uname_E then
- -- uname'elab_[spec|body];
- -- uname_E := True;
- -- end if;
-
- -- The uname_E assignment is skipped if this is a separate spec,
- -- since the assignment will be done when we process the body.
-
- else
- Set_String (" if not E");
- Set_Unit_Number (Unum_Spec);
- Set_String (" then");
- Write_Statement_Buffer;
-
- Set_String (" ");
- Get_Decoded_Name_String_With_Brackets (U.Uname);
-
- if Name_Buffer (Name_Len) = 's' then
- Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_spec";
- else
- Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_body";
- end if;
-
- Name_Len := Name_Len + 8;
- Set_Casing (U.Icasing);
- Set_Name_Buffer;
- Set_Char (';');
- Write_Statement_Buffer;
-
- if U.Utype /= Is_Spec then
- Set_String (" E");
- Set_Unit_Number (Unum_Spec);
- Set_String (" := True;");
- Write_Statement_Buffer;
- end if;
-
- WBI (" end if;");
- end if;
- end;
- end loop;
-
- end Gen_Elab_Calls_Ada;
-
- ----------------------
- -- Gen_Elab_Calls_C --
- ----------------------
-
- procedure Gen_Elab_Calls_C is
- begin
-
- for E in Elab_Order.First .. Elab_Order.Last loop
- declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
- U : Unit_Record renames Units.Table (Unum);
-
- Unum_Spec : Unit_Id;
- -- This is the unit number of the spec that corresponds to
- -- this entry. It is the same as Unum except when the body
- -- and spec are different and we are currently processing
- -- the body, in which case it is the spec (Unum + 1).
-
- begin
- if U.Utype = Is_Body then
- Unum_Spec := Unum + 1;
- else
- Unum_Spec := Unum;
- end if;
-
- -- Case of no elaboration code
-
- if U.No_Elab then
-
- -- The only case in which we have to do something is if
- -- this is a body, with a separate spec, where the separate
- -- spec has an elaboration entity defined.
-
- -- In that case, this is where we set the elaboration entity
- -- to True, we do not need to test if this has already been
- -- done, since it is quicker to set the flag than to test it.
-
- if U.Utype = Is_Body
- and then Units.Table (Unum_Spec).Set_Elab_Entity
- then
- Set_String (" ");
- Get_Name_String (U.Uname);
- Set_Unit_Name;
- Set_String ("_E = 1;");
- Write_Statement_Buffer;
- end if;
-
- -- Here if elaboration code is present. We generate:
-
- -- if (uname_E == 0) {
- -- uname__elab[s|b] ();
- -- uname_E++;
- -- }
-
- -- The uname_E assignment is skipped if this is a separate spec,
- -- since the assignment will be done when we process the body.
-
- else
- Set_String (" if (");
- Get_Name_String (U.Uname);
- Set_Unit_Name;
- Set_String ("_E == 0) {");
- Write_Statement_Buffer;
-
- Set_String (" ");
- Set_Unit_Name;
- Set_String ("___elab");
- Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
- Set_String (" ();");
- Write_Statement_Buffer;
-
- if U.Utype /= Is_Spec then
- Set_String (" ");
- Set_Unit_Name;
- Set_String ("_E++;");
- Write_Statement_Buffer;
- end if;
-
- WBI (" }");
- end if;
- end;
- end loop;
-
- end Gen_Elab_Calls_C;
-
- ----------------------
- -- Gen_Elab_Defs_C --
- ----------------------
-
- procedure Gen_Elab_Defs_C is
- begin
- for E in Elab_Order.First .. Elab_Order.Last loop
-
- -- Generate declaration of elaboration procedure if elaboration
- -- needed. Note that passive units are always excluded.
-
- if not Units.Table (Elab_Order.Table (E)).No_Elab then
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
- Set_String ("extern void ");
- Set_Unit_Name;
- Set_String ("___elab");
- Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
- Set_String (" PARAMS ((void));");
- Write_Statement_Buffer;
- end if;
-
- end loop;
-
- WBI ("");
- end Gen_Elab_Defs_C;
-
- ------------------------
- -- Gen_Elab_Order_Ada --
- ------------------------
-
- procedure Gen_Elab_Order_Ada is
- begin
- WBI ("");
- WBI (" -- BEGIN ELABORATION ORDER");
-
- for J in Elab_Order.First .. Elab_Order.Last loop
- Set_String (" -- ");
- Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
- Set_Name_Buffer;
- Write_Statement_Buffer;
- end loop;
-
- WBI (" -- END ELABORATION ORDER");
- end Gen_Elab_Order_Ada;
-
- ----------------------
- -- Gen_Elab_Order_C --
- ----------------------
-
- procedure Gen_Elab_Order_C is
- begin
- WBI ("");
- WBI ("/* BEGIN ELABORATION ORDER");
-
- for J in Elab_Order.First .. Elab_Order.Last loop
- Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
- Set_Name_Buffer;
- Write_Statement_Buffer;
- end loop;
-
- WBI (" END ELABORATION ORDER */");
- end Gen_Elab_Order_C;
-
- -----------------------------
- -- Gen_Exception_Table_Ada --
- -----------------------------
-
- procedure Gen_Exception_Table_Ada is
- Num : Nat;
- Last : ALI_Id := No_ALI_Id;
-
- begin
- if not Zero_Cost_Exceptions_Specified then
- WBI (" begin");
- return;
- end if;
-
- -- The code we generate looks like
-
- -- procedure SDP_Table_Build
- -- (SDP_Addresses : System.Address;
- -- SDP_Count : Natural;
- -- Elab_Addresses : System.Address;
- -- Elab_Addr_Count : Natural);
- -- pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build");
- --
- -- ST : aliased constant array (1 .. nnn) of System.Address := (
- -- unit_name_1'UET_Address,
- -- unit_name_2'UET_Address,
- -- ...
- -- unit_name_3'UET_Address,
- --
- -- EA : aliased constant array (1 .. eee) of System.Address := (
- -- adainit'Code_Address,
- -- adafinal'Code_Address,
- -- unit_name'elab[spec|body]'Code_Address,
- -- unit_name'elab[spec|body]'Code_Address,
- -- unit_name'elab[spec|body]'Code_Address,
- -- unit_name'elab[spec|body]'Code_Address);
- --
- -- begin
- -- SDP_Table_Build (ST'Address, nnn, EA'Address, eee);
-
- Num := 0;
- for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
- Num := Num + 1;
- Last := A;
- end if;
- end loop;
-
- if Num = 0 then
-
- -- Happens with "gnatmake -a -f -gnatL ..."
-
- WBI (" ");
- WBI (" begin");
- return;
- end if;
-
- WBI (" procedure SDP_Table_Build");
- WBI (" (SDP_Addresses : System.Address;");
- WBI (" SDP_Count : Natural;");
- WBI (" Elab_Addresses : System.Address;");
- WBI (" Elab_Addr_Count : Natural);");
- WBI (" " &
- "pragma Import (C, SDP_Table_Build, ""__gnat_SDP_Table_Build"");");
-
- WBI (" ");
- Set_String (" ST : aliased constant array (1 .. ");
- Set_Int (Num);
- Set_String (") of System.Address := (");
-
- if Num = 1 then
- Set_String ("1 => A1);");
- Write_Statement_Buffer;
-
- else
- Write_Statement_Buffer;
-
- for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
- Get_Decoded_Name_String_With_Brackets
- (Units.Table (ALIs.Table (A).First_Unit).Uname);
- Set_Casing (Mixed_Case);
- Set_String (" ");
- Set_String (Name_Buffer (1 .. Name_Len - 2));
- Set_String ("'UET_Address");
-
- if A = Last then
- Set_String (");");
- else
- Set_Char (',');
- end if;
-
- Write_Statement_Buffer;
- end if;
- end loop;
- end if;
-
- WBI (" ");
- Set_String (" EA : aliased constant array (1 .. ");
- Set_Int (Num_Elab_Calls + 2);
- Set_String (") of System.Address := (");
- Write_Statement_Buffer;
- WBI (" " & Ada_Init_Name.all & "'Code_Address,");
-
- -- If compiling for the JVM, we directly reference Adafinal because
- -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
-
- if Hostparm.Java_VM then
- Set_String (" System.Standard_Library.Adafinal'Code_Address");
- else
- Set_String (" Do_Finalize'Code_Address");
- end if;
-
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Decoded_Name_String_With_Brackets
- (Units.Table (Elab_Order.Table (E)).Uname);
-
- if Units.Table (Elab_Order.Table (E)).No_Elab then
- null;
-
- else
- Set_Char (',');
- Write_Statement_Buffer;
- Set_String (" ");
-
- if Name_Buffer (Name_Len) = 's' then
- Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
- "'elab_spec'code_address";
- else
- Name_Buffer (Name_Len - 1 .. Name_Len + 21) :=
- "'elab_body'code_address";
- end if;
-
- Name_Len := Name_Len + 21;
- Set_Casing (Units.Table (Elab_Order.Table (E)).Icasing);
- Set_Name_Buffer;
- end if;
- end loop;
-
- Set_String (");");
- Write_Statement_Buffer;
-
- WBI (" ");
- WBI (" begin");
-
- Set_String (" SDP_Table_Build (ST'Address, ");
- Set_Int (Num);
- Set_String (", EA'Address, ");
- Set_Int (Num_Elab_Calls + 2);
- Set_String (");");
- Write_Statement_Buffer;
- end Gen_Exception_Table_Ada;
-
- ---------------------------
- -- Gen_Exception_Table_C --
- ---------------------------
-
- procedure Gen_Exception_Table_C is
- Num : Nat;
- Num2 : Nat;
-
- begin
- if not Zero_Cost_Exceptions_Specified then
- return;
- end if;
-
- -- The code we generate looks like
-
- -- extern void *__gnat_unitname1__SDP;
- -- extern void *__gnat_unitname2__SDP;
- -- ...
- --
- -- void **st[nnn] = {
- -- &__gnat_unitname1__SDP,
- -- &__gnat_unitname2__SDP,
- -- ...
- -- &__gnat_unitnamen__SDP};
- --
- -- extern void unitname1__elabb ();
- -- extern void unitname2__elabb ();
- -- ...
- --
- -- void (*ea[eee]) () = {
- -- adainit,
- -- adafinal,
- -- unitname1___elab[b,s],
- -- unitname2___elab[b,s],
- -- ...
- -- unitnamen___elab[b,s]};
- --
- -- __gnat_SDP_Table_Build (&st, nnn, &ea, eee);
-
- Num := 0;
- for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
- Num := Num + 1;
-
- Set_String (" extern void *__gnat_");
- Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
- Set_Unit_Name;
- Set_String ("__SDP");
- Set_Char (';');
- Write_Statement_Buffer;
- end if;
- end loop;
-
- if Num = 0 then
-
- -- Happens with "gnatmake -a -f -gnatL ..."
-
- return;
- end if;
-
- WBI (" ");
-
- Set_String (" void **st[");
- Set_Int (Num);
- Set_String ("] = {");
- Write_Statement_Buffer;
-
- Num2 := 0;
- for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
- Num2 := Num2 + 1;
-
- Set_String (" &__gnat_");
- Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
- Set_Unit_Name;
- Set_String ("__SDP");
-
- if Num = Num2 then
- Set_String ("};");
- else
- Set_Char (',');
- end if;
-
- Write_Statement_Buffer;
- end if;
- end loop;
-
- WBI ("");
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
-
- if Units.Table (Elab_Order.Table (E)).No_Elab then
- null;
-
- else
- Set_String (" extern void ");
- Set_Unit_Name;
- Set_String ("___elab");
- Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
- Set_String (" ();");
- Write_Statement_Buffer;
- end if;
- end loop;
-
- WBI ("");
- Set_String (" void (*ea[");
- Set_Int (Num_Elab_Calls + 2);
- Set_String ("]) () = {");
- Write_Statement_Buffer;
-
- WBI (" " & Ada_Init_Name.all & ",");
- Set_String (" system__standard_library__adafinal");
-
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
-
- if Units.Table (Elab_Order.Table (E)).No_Elab then
- null;
-
- else
- Set_Char (',');
- Write_Statement_Buffer;
- Set_String (" ");
- Set_Unit_Name;
- Set_String ("___elab");
- Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
- end if;
- end loop;
-
- Set_String ("};");
- Write_Statement_Buffer;
-
- WBI (" ");
-
- Set_String (" __gnat_SDP_Table_Build (&st, ");
- Set_Int (Num);
- Set_String (", ea, ");
- Set_Int (Num_Elab_Calls + 2);
- Set_String (");");
- Write_Statement_Buffer;
- end Gen_Exception_Table_C;
-
- ------------------
- -- Gen_Main_Ada --
- ------------------
-
- procedure Gen_Main_Ada is
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/";
-
- begin
- WBI ("");
- Set_String (" function ");
- Set_String (Get_Main_Name);
-
- if VxWorks_Target then
- Set_String (" return Integer is");
- Write_Statement_Buffer;
-
- else
- Write_Statement_Buffer;
- WBI (" (argc : Integer;");
- WBI (" argv : System.Address;");
- WBI (" envp : System.Address)");
- WBI (" return Integer");
- WBI (" is");
- end if;
-
- -- Initialize and Finalize are not used in No_Run_Time mode
-
- if not No_Run_Time_Specified then
- WBI (" procedure initialize;");
- WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
- WBI ("");
- WBI (" procedure finalize;");
- WBI (" pragma Import (C, finalize, ""__gnat_finalize"");");
- WBI ("");
- end if;
-
- -- Deal with declarations for main program case
-
- if not No_Main_Subprogram then
-
- -- To call the main program, we declare it using a pragma Import
- -- Ada with the right link name.
-
- -- It might seem more obvious to "with" the main program, and call
- -- it in the normal Ada manner. We do not do this for three reasons:
-
- -- 1. It is more efficient not to recompile the main program
- -- 2. We are not entitled to assume the source is accessible
- -- 3. We don't know what options to use to compile it
-
- -- It is really reason 3 that is most critical (indeed we used
- -- to generate the "with", but several regression tests failed).
-
- WBI ("");
-
- if ALIs.Table (ALIs.First).Main_Program = Func then
- WBI (" Result : Integer;");
- WBI ("");
- WBI (" function Ada_Main_Program return Integer;");
-
- else
- WBI (" procedure Ada_Main_Program;");
- end if;
-
- Set_String (" pragma Import (Ada, Ada_Main_Program, """);
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- Set_Main_Program_Name;
- Set_String (""");");
-
- Write_Statement_Buffer;
- WBI ("");
- end if;
-
- WBI (" begin");
-
- -- On VxWorks, there are no command line arguments
-
- if VxWorks_Target then
- WBI (" gnat_argc := 0;");
- WBI (" gnat_argv := System.Null_Address;");
- WBI (" gnat_envp := System.Null_Address;");
-
- -- Normal case of command line arguments present
-
- else
- WBI (" gnat_argc := argc;");
- WBI (" gnat_argv := argv;");
- WBI (" gnat_envp := envp;");
- WBI ("");
- end if;
-
- if not No_Run_Time_Specified then
- WBI (" Initialize;");
- end if;
-
- WBI (" " & Ada_Init_Name.all & ";");
-
- if not No_Main_Subprogram then
- WBI (" Break_Start;");
-
- if ALIs.Table (ALIs.First).Main_Program = Proc then
- WBI (" Ada_Main_Program;");
- else
- WBI (" Result := Ada_Main_Program;");
- end if;
- end if;
-
- -- Adafinal is only called if we have a run time
-
- if not No_Run_Time_Specified then
-
- -- If compiling for the JVM, we directly call Adafinal because
- -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
-
- if Hostparm.Java_VM then
- WBI (" System.Standard_Library.Adafinal;");
- else
- WBI (" Do_Finalize;");
- end if;
- end if;
-
- -- Finalize is only called if we have a run time
-
- if not No_Run_Time_Specified then
- WBI (" Finalize;");
- end if;
-
- -- Return result
-
- if No_Main_Subprogram
- or else ALIs.Table (ALIs.First).Main_Program = Proc
- then
- WBI (" return (gnat_exit_status);");
- else
- WBI (" return (Result);");
- end if;
-
- WBI (" end;");
- end Gen_Main_Ada;
-
- ----------------
- -- Gen_Main_C --
- ----------------
-
- procedure Gen_Main_C is
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/";
-
- begin
- Set_String ("int ");
- Set_String (Get_Main_Name);
-
- -- On VxWorks, there are no command line arguments
-
- if VxWorks_Target then
- Set_String (" ()");
-
- -- Normal case with command line arguments present
-
- else
- Set_String (" (argc, argv, envp)");
- end if;
-
- Write_Statement_Buffer;
-
- -- VxWorks doesn't have the notion of argc/argv
-
- if VxWorks_Target then
- WBI ("{");
- WBI (" int result;");
- WBI (" gnat_argc = 0;");
- WBI (" gnat_argv = 0;");
- WBI (" gnat_envp = 0;");
-
- -- Normal case of arguments present
-
- else
- WBI (" int argc;");
- WBI (" char **argv;");
- WBI (" char **envp;");
- WBI ("{");
-
- if ALIs.Table (ALIs.First).Main_Program = Func then
- WBI (" int result;");
- end if;
-
- WBI (" gnat_argc = argc;");
- WBI (" gnat_argv = argv;");
- WBI (" gnat_envp = envp;");
- WBI (" ");
- end if;
-
- -- The __gnat_initialize routine is used only if we have a run-time
-
- if not No_Run_Time_Specified then
- WBI
- (" __gnat_initialize ();");
- end if;
-
- WBI (" " & Ada_Init_Name.all & " ();");
-
- if not No_Main_Subprogram then
-
- WBI (" __gnat_break_start ();");
- WBI (" ");
-
- -- Output main program name
-
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
-
- -- Main program is procedure case
-
- if ALIs.Table (ALIs.First).Main_Program = Proc then
- Set_String (" ");
- Set_Main_Program_Name;
- Set_String (" ();");
- Write_Statement_Buffer;
-
- -- Main program is function case
-
- else -- ALIs.Table (ALIs_First).Main_Program = Func
- Set_String (" result = ");
- Set_Main_Program_Name;
- Set_String (" ();");
- Write_Statement_Buffer;
- end if;
-
- end if;
-
- -- Adafinal is called only when we have a run-time
-
- if not No_Run_Time_Specified then
- WBI (" ");
- WBI (" system__standard_library__adafinal ();");
- end if;
-
- -- The finalize routine is used only if we have a run-time
-
- if not No_Run_Time_Specified then
- WBI (" __gnat_finalize ();");
- end if;
-
- if ALIs.Table (ALIs.First).Main_Program = Func then
-
- if Hostparm.OpenVMS then
-
- -- VMS must use the Posix exit routine in order to get an
- -- Unix compatible exit status.
-
- WBI (" __posix_exit (result);");
-
- else
- WBI (" exit (result);");
- end if;
-
- else
-
- if Hostparm.OpenVMS then
- -- VMS must use the Posix exit routine in order to get an
- -- Unix compatible exit status.
- WBI (" __posix_exit (gnat_exit_status);");
- else
- WBI (" exit (gnat_exit_status);");
- end if;
- end if;
-
- WBI ("}");
- end Gen_Main_C;
-
- ------------------------------
- -- Gen_Object_Files_Options --
- ------------------------------
-
- procedure Gen_Object_Files_Options is
- Lgnat : Integer;
-
- procedure Write_Linker_Option;
- -- Write binder info linker option.
-
- -------------------------
- -- Write_Linker_Option --
- -------------------------
-
- procedure Write_Linker_Option is
- Start : Natural;
- Stop : Natural;
-
- begin
- -- Loop through string, breaking at null's
-
- Start := 1;
- while Start < Name_Len loop
-
- -- Find null ending this section
-
- Stop := Start + 1;
- while Name_Buffer (Stop) /= ASCII.NUL
- and then Stop <= Name_Len loop
- Stop := Stop + 1;
- end loop;
-
- -- Process section if non-null
-
- if Stop > Start then
- if Output_Linker_Option_List then
- Write_Str (Name_Buffer (Start .. Stop - 1));
- Write_Eol;
- end if;
- Write_Info_Ada_C
- (" -- ", "", Name_Buffer (Start .. Stop - 1));
- end if;
-
- Start := Stop + 1;
- end loop;
- end Write_Linker_Option;
-
- -- Start of processing for Gen_Object_Files_Options
-
- begin
- WBI ("");
- Write_Info_Ada_C ("--", "/*", " BEGIN Object file/option list");
-
- for E in Elab_Order.First .. Elab_Order.Last loop
-
- -- If not spec that has an associated body, then generate a
- -- comment giving the name of the corresponding object file.
-
- if Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec then
- Get_Name_String
- (ALIs.Table
- (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
-
- -- If the presence of an object file is necessary or if it
- -- exists, then use it.
-
- if not Hostparm.Exclude_Missing_Objects
- or else
- GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
- then
- Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
- if Output_Object_List then
- Write_Str (Name_Buffer (1 .. Name_Len));
- Write_Eol;
- end if;
-
- -- Don't link with the shared library on VMS if an internal
- -- filename object is seen. Multiply defined symbols will
- -- result.
-
- if Hostparm.OpenVMS
- and then Is_Internal_File_Name
- (ALIs.Table
- (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
- then
- Opt.Shared_Libgnat := False;
- end if;
-
- end if;
- end if;
- end loop;
-
- -- Add a "-Ldir" for each directory in the object path. We skip this
- -- in No_Run_Time mode, where we want more precise control of exactly
- -- what goes into the resulting object file
-
- if not No_Run_Time_Specified then
- for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
- declare
- Dir : String_Ptr := Dir_In_Obj_Search_Path (J);
-
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer ("-L");
- Add_Str_To_Name_Buffer (Dir.all);
- Write_Linker_Option;
- end;
- end loop;
- end if;
-
- -- Sort linker options
-
- Sort (Linker_Options.Last, Move_Linker_Option'Access,
- Lt_Linker_Option'Access);
-
- -- Write user linker options
-
- Lgnat := Linker_Options.Last + 1;
-
- for J in 1 .. Linker_Options.Last loop
- if not Linker_Options.Table (J).Internal_File then
- Get_Name_String (Linker_Options.Table (J).Name);
- Write_Linker_Option;
- else
- Lgnat := J;
- exit;
- end if;
- end loop;
-
- if not (No_Run_Time_Specified or else Opt.No_Stdlib) then
-
- Name_Len := 0;
-
- if Opt.Shared_Libgnat then
- Add_Str_To_Name_Buffer ("-shared");
- else
- Add_Str_To_Name_Buffer ("-static");
- end if;
-
- -- Write directly to avoid -K output.
-
- Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
-
- if With_DECGNAT then
- Name_Len := 0;
- Add_Str_To_Name_Buffer ("-ldecgnat");
- Write_Linker_Option;
- end if;
-
- if With_GNARL then
- Name_Len := 0;
- Add_Str_To_Name_Buffer ("-lgnarl");
- Write_Linker_Option;
- end if;
-
- Name_Len := 0;
- Add_Str_To_Name_Buffer ("-lgnat");
- Write_Linker_Option;
-
- end if;
-
- -- Write internal linker options
-
- for J in Lgnat .. Linker_Options.Last loop
- Get_Name_String (Linker_Options.Table (J).Name);
- Write_Linker_Option;
- end loop;
-
- if Ada_Bind_File then
- WBI ("-- END Object file/option list ");
- else
- WBI (" END Object file/option list */");
- end if;
-
- end Gen_Object_Files_Options;
-
- ---------------------
- -- Gen_Output_File --
- ---------------------
-
- procedure Gen_Output_File (Filename : String) is
-
- -- Start of processing for Gen_Output_File
-
- begin
- -- Override Ada_Bind_File and Bind_Main_Program for Java since
- -- JGNAT only supports Ada code, and the main program is already
- -- generated by the compiler.
-
- if Hostparm.Java_VM then
- Ada_Bind_File := True;
- Bind_Main_Program := False;
- end if;
-
- -- Override time slice value if -T switch is set
-
- if Time_Slice_Set then
- ALIs.Table (ALIs.First).Time_Slice_Value := Opt.Time_Slice_Value;
- end if;
-
- -- Count number of elaboration calls
-
- for E in Elab_Order.First .. Elab_Order.Last loop
- if Units.Table (Elab_Order.Table (E)).No_Elab then
- null;
- else
- Num_Elab_Calls := Num_Elab_Calls + 1;
- end if;
- end loop;
-
- -- Generate output file in appropriate language
-
- if Ada_Bind_File then
- Gen_Output_File_Ada (Filename);
- else
- Gen_Output_File_C (Filename);
- end if;
-
- end Gen_Output_File;
-
- -------------------------
- -- Gen_Output_File_Ada --
- -------------------------
-
- procedure Gen_Output_File_Ada (Filename : String) is
-
- Bfiles : Name_Id;
- -- Name of generated bind file (spec)
-
- Bfileb : Name_Id;
- -- Name of generated bind file (body)
-
- Ada_Main : constant String := Get_Ada_Main_Name;
- -- Name to be used for generated Ada main program. See the body of
- -- function Get_Ada_Main_Name for details on the form of the name.
-
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/";
-
- begin
- -- Create spec first
-
- Create_Binder_Output (Filename, 's', Bfiles);
-
- if No_Run_Time_Specified then
- WBI ("pragma No_Run_Time;");
- end if;
-
- -- Generate with of System so we can reference System.Address, note
- -- that such a reference is safe even in No_Run_Time mode, since we
- -- do not need any run-time code for such a reference, and we output
- -- a pragma No_Run_Time for this compilation above.
-
- WBI ("with System;");
-
- -- Generate with of System.Initialize_Scalars if active
-
- if Initialize_Scalars_Used then
- WBI ("with System.Scalar_Values;");
- end if;
-
- Resolve_Binder_Options;
-
- if not No_Run_Time_Specified then
-
- -- Usually, adafinal is called using a pragma Import C. Since
- -- Import C doesn't have the same semantics for JGNAT, we use
- -- standard Ada.
-
- if Hostparm.Java_VM then
- WBI ("with System.Standard_Library;");
- end if;
- end if;
-
- WBI ("package " & Ada_Main & " is");
-
- -- Main program case
-
- if Bind_Main_Program then
-
- -- Generate argc/argv stuff
-
- WBI ("");
- WBI (" gnat_argc : Integer;");
- WBI (" gnat_argv : System.Address;");
- WBI (" gnat_envp : System.Address;");
-
- -- If we have a run time present, these variables are in the
- -- runtime data area for easy access from the runtime
-
- if not No_Run_Time_Specified then
- WBI ("");
- WBI (" pragma Import (C, gnat_argc);");
- WBI (" pragma Import (C, gnat_argv);");
- WBI (" pragma Import (C, gnat_envp);");
- end if;
-
- -- Define exit status. Again in normal mode, this is in the
- -- run-time library, and is initialized there, but in the no
- -- run time case, the variable is here and initialized here.
-
- WBI ("");
-
- if No_Run_Time_Specified then
- WBI (" gnat_exit_status : Integer := 0;");
- else
- WBI (" gnat_exit_status : Integer;");
- WBI (" pragma Import (C, gnat_exit_status);");
- end if;
- end if;
-
- -- Generate the GNAT_Version and Ada_Main_Program_name info only for
- -- the main program. Otherwise, it can lead under some circumstances
- -- to a symbol duplication during the link (for instance when a
- -- C program uses 2 Ada libraries)
-
- if Bind_Main_Program then
- WBI ("");
- WBI (" GNAT_Version : constant String :=");
- WBI (" ""GNAT Version: " &
- Gnat_Version_String & """;");
- WBI (" pragma Export (C, GNAT_Version, ""__gnat_version"");");
-
- WBI ("");
- Set_String (" Ada_Main_Program_Name : constant String := """);
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- Set_Main_Program_Name;
- Set_String (""" & Ascii.NUL;");
- Write_Statement_Buffer;
-
- WBI
- (" pragma Export (C, Ada_Main_Program_Name, " &
- """__gnat_ada_main_program_name"");");
- end if;
-
- -- No need to generate a finalization routine if there is no
- -- runtime, since there is nothing to do in this case.
-
- if not No_Run_Time_Specified then
- WBI ("");
- WBI (" procedure " & Ada_Final_Name.all & ";");
- WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
- Ada_Final_Name.all & """);");
- end if;
-
- WBI ("");
- WBI (" procedure " & Ada_Init_Name.all & ";");
- WBI (" pragma Export (C, " & Ada_Init_Name.all & ", """ &
- Ada_Init_Name.all & """);");
-
- if Bind_Main_Program then
-
- -- If we have a run time, then Break_Start is defined there, but
- -- if there is no run-time, Break_Start is defined in this file.
-
- WBI ("");
- WBI (" procedure Break_Start;");
-
- if No_Run_Time_Specified then
- WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");");
- else
- WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");");
- end if;
-
- WBI ("");
- WBI (" function " & Get_Main_Name);
-
- -- Generate argument list (except on VxWorks, where none is present)
-
- if not VxWorks_Target then
- WBI (" (argc : Integer;");
- WBI (" argv : System.Address;");
- WBI (" envp : System.Address)");
- end if;
-
- WBI (" return Integer;");
- WBI (" pragma Export (C, " & Get_Main_Name & ", """ &
- Get_Main_Name & """);");
- end if;
-
- if Initialize_Scalars_Used then
- Gen_Scalar_Values;
- end if;
-
- Gen_Versions_Ada;
- Gen_Elab_Order_Ada;
-
- -- Spec is complete
-
- WBI ("");
- WBI ("end " & Ada_Main & ";");
- Close_Binder_Output;
-
- -- Prepare to write body
-
- Create_Binder_Output (Filename, 'b', Bfileb);
-
- -- Output Source_File_Name pragmas which look like
-
- -- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
- -- pragma Source_File_Name (Ada_Main, Body_File_Name => "bbb");
-
- -- where sss/bbb are the spec/body file names respectively
-
- Get_Name_String (Bfiles);
- Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
-
- WBI ("pragma Source_File_Name (" &
- Ada_Main &
- ", Spec_File_Name => """ &
- Name_Buffer (1 .. Name_Len + 3));
-
- Get_Name_String (Bfileb);
- Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
-
- WBI ("pragma Source_File_Name (" &
- Ada_Main &
- ", Body_File_Name => """ &
- Name_Buffer (1 .. Name_Len + 3));
-
- WBI ("");
- WBI ("package body " & Ada_Main & " is");
-
- -- Import the finalization procedure only if there is a runtime.
-
- if not No_Run_Time_Specified then
-
- -- In the Java case, pragma Import C cannot be used, so the
- -- standard Ada constructs will be used instead.
-
- if not Hostparm.Java_VM then
- WBI ("");
- WBI (" procedure Do_Finalize;");
- WBI
- (" pragma Import (C, Do_Finalize, " &
- """system__standard_library__adafinal"");");
- WBI ("");
- end if;
- end if;
-
- Gen_Adainit_Ada;
-
- -- No need to generate a finalization routine if there is no
- -- runtime, since there is nothing to do in this case.
-
- if not No_Run_Time_Specified then
- Gen_Adafinal_Ada;
- end if;
-
- if Bind_Main_Program then
-
- -- In No_Run_Time mode, generate dummy body for Break_Start
-
- if No_Run_Time_Specified then
- WBI ("");
- WBI (" procedure Break_Start is");
- WBI (" begin");
- WBI (" null;");
- WBI (" end;");
- end if;
-
- Gen_Main_Ada;
- end if;
-
- -- Output object file list and the Ada body is complete
-
- Gen_Object_Files_Options;
-
- WBI ("");
- WBI ("end " & Ada_Main & ";");
-
- Close_Binder_Output;
- end Gen_Output_File_Ada;
-
- -----------------------
- -- Gen_Output_File_C --
- -----------------------
-
- procedure Gen_Output_File_C (Filename : String) is
-
- Bfile : Name_Id;
- -- Name of generated bind file
-
- begin
- Create_Binder_Output (Filename, 'c', Bfile);
-
- Resolve_Binder_Options;
-
- WBI ("#ifdef __STDC__");
- WBI ("#define PARAMS(paramlist) paramlist");
- WBI ("#else");
- WBI ("#define PARAMS(paramlist) ()");
- WBI ("#endif");
- WBI ("");
-
- WBI ("extern void __gnat_set_globals ");
- WBI (" PARAMS ((int, int, int, int, int, int, ");
- WBI (" void (*) PARAMS ((void)), int, int));");
- WBI ("extern void " & Ada_Final_Name.all & " PARAMS ((void));");
- WBI ("extern void " & Ada_Init_Name.all & " PARAMS ((void));");
-
- WBI ("extern void system__standard_library__adafinal PARAMS ((void));");
-
- if not No_Main_Subprogram then
- WBI ("extern int main PARAMS ((int, char **, char **));");
- if Hostparm.OpenVMS then
- WBI ("extern void __posix_exit PARAMS ((int));");
- else
- WBI ("extern void exit PARAMS ((int));");
- end if;
-
- WBI ("extern void __gnat_break_start PARAMS ((void));");
- Set_String ("extern ");
-
- if ALIs.Table (ALIs.First).Main_Program = Proc then
- Set_String ("void ");
- else
- Set_String ("int ");
- end if;
-
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- Set_Main_Program_Name;
- Set_String (" PARAMS ((void));");
- Write_Statement_Buffer;
- end if;
-
- if not No_Run_Time_Specified then
- WBI ("extern void __gnat_initialize PARAMS ((void));");
- WBI ("extern void __gnat_finalize PARAMS ((void));");
- WBI ("extern void __gnat_install_handler PARAMS ((void));");
- end if;
-
- WBI ("");
-
- Gen_Elab_Defs_C;
-
- -- Imported variable used to track elaboration/finalization phase.
- -- Used only when we have a runtime.
-
- if not No_Run_Time_Specified then
- WBI ("extern int __gnat_handler_installed;");
- WBI ("");
- end if;
-
- -- Write argv/argc stuff if main program case
-
- if Bind_Main_Program then
-
- -- In the normal case, these are in the runtime library
-
- if not No_Run_Time_Specified then
- WBI ("extern int gnat_argc;");
- WBI ("extern char **gnat_argv;");
- WBI ("extern char **gnat_envp;");
- WBI ("extern int gnat_exit_status;");
-
- -- In the No_Run_Time case, they are right in the binder file
- -- and we initialize gnat_exit_status in the declaration.
-
- else
- WBI ("int gnat_argc;");
- WBI ("char **gnat_argv;");
- WBI ("char **gnat_envp;");
- WBI ("int gnat_exit_status = 0;");
- end if;
-
- WBI ("");
- end if;
-
- -- In no run-time mode, the __gnat_break_start routine (for the
- -- debugger to get initial control) is defined in this file.
-
- if No_Run_Time_Specified then
- WBI ("");
- WBI ("void __gnat_break_start () {}");
- end if;
-
- -- Generate the __gnat_version and __gnat_ada_main_program_name info
- -- only for the main program. Otherwise, it can lead under some
- -- circumstances to a symbol duplication during the link (for instance
- -- when a C program uses 2 Ada libraries)
-
- if Bind_Main_Program then
- WBI ("");
- WBI ("char __gnat_version[] = ""GNAT Version: " &
- Gnat_Version_String & """;");
-
- Set_String ("char __gnat_ada_main_program_name[] = """);
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- Set_Main_Program_Name;
- Set_String (""";");
- Write_Statement_Buffer;
- end if;
-
- -- Generate the adafinal routine. In no runtime mode, this is
- -- not needed, since there is no finalization to do.
-
- if not No_Run_Time_Specified then
- Gen_Adafinal_C;
- end if;
-
- Gen_Adainit_C;
-
- -- Main is only present for Ada main case
-
- if Bind_Main_Program then
- Gen_Main_C;
- end if;
-
- -- Scalar values, versions and object files needed in both cases
-
- if Initialize_Scalars_Used then
- Gen_Scalar_Values;
- end if;
-
- Gen_Versions_C;
- Gen_Elab_Order_C;
- Gen_Object_Files_Options;
-
- -- C binder output is complete
-
- Close_Binder_Output;
- end Gen_Output_File_C;
-
- -----------------------
- -- Gen_Scalar_Values --
- -----------------------
-
- procedure Gen_Scalar_Values is
-
- -- Strings to hold hex values of initialization constants. Note that
- -- we store these strings in big endian order, but they are actually
- -- used to initialize integer values, so the actual generated data
- -- will automaticaly have the right endianess.
-
- IS_Is1 : String (1 .. 2);
- IS_Is2 : String (1 .. 4);
- IS_Is4 : String (1 .. 8);
- IS_Is8 : String (1 .. 16);
- IS_Iu1 : String (1 .. 2);
- IS_Iu2 : String (1 .. 4);
- IS_Iu4 : String (1 .. 8);
- IS_Iu8 : String (1 .. 16);
- IS_Isf : String (1 .. 8);
- IS_Ifl : String (1 .. 8);
- IS_Ilf : String (1 .. 16);
-
- -- The string for Long_Long_Float is special. This is used only on the
- -- ia32 with 80-bit extended float (stored in 96 bits by gcc). The
- -- value here is represented little-endian, since that's the only way
- -- it is ever generated (this is not used on big-endian machines.
-
- IS_Ill : String (1 .. 24);
-
- begin
- -- -Sin (invalid values)
-
- if Opt.Initialize_Scalars_Mode = 'I' then
- IS_Is1 := "80";
- IS_Is2 := "8000";
- IS_Is4 := "80000000";
- IS_Is8 := "8000000000000000";
- IS_Iu1 := "FF";
- IS_Iu2 := "FFFF";
- IS_Iu4 := "FFFFFFFF";
- IS_Iu8 := "FFFFFFFFFFFFFFFF";
- IS_Isf := IS_Iu4;
- IS_Ifl := IS_Iu4;
- IS_Ilf := IS_Iu8;
- IS_Ill := "00000000000000C0FFFF0000";
-
- -- -Slo (low values)
-
- elsif Opt.Initialize_Scalars_Mode = 'L' then
- IS_Is1 := "80";
- IS_Is2 := "8000";
- IS_Is4 := "80000000";
- IS_Is8 := "8000000000000000";
- IS_Iu1 := "00";
- IS_Iu2 := "0000";
- IS_Iu4 := "00000000";
- IS_Iu8 := "0000000000000000";
- IS_Isf := "FF800000";
- IS_Ifl := IS_Isf;
- IS_Ilf := "FFF0000000000000";
- IS_Ill := "0000000000000080FFFF0000";
-
- -- -Shi (high values)
-
- elsif Opt.Initialize_Scalars_Mode = 'H' then
- IS_Is1 := "7F";
- IS_Is2 := "7FFF";
- IS_Is4 := "7FFFFFFF";
- IS_Is8 := "7FFFFFFFFFFFFFFF";
- IS_Iu1 := "FF";
- IS_Iu2 := "FFFF";
- IS_Iu4 := "FFFFFFFF";
- IS_Iu8 := "FFFFFFFFFFFFFFFF";
- IS_Isf := "7F800000";
- IS_Ifl := IS_Isf;
- IS_Ilf := "7FF0000000000000";
- IS_Ill := "0000000000000080FF7F0000";
-
- -- -Shh (hex byte)
-
- else pragma Assert (Opt.Initialize_Scalars_Mode = 'X');
- IS_Is1 (1 .. 2) := Opt.Initialize_Scalars_Val;
- IS_Is2 (1 .. 2) := Opt.Initialize_Scalars_Val;
- IS_Is2 (3 .. 4) := Opt.Initialize_Scalars_Val;
-
- for J in 1 .. 4 loop
- IS_Is4 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
- end loop;
-
- for J in 1 .. 8 loop
- IS_Is8 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
- end loop;
-
- IS_Iu1 := IS_Is1;
- IS_Iu2 := IS_Is2;
- IS_Iu4 := IS_Is4;
- IS_Iu8 := IS_Is8;
-
- IS_Isf := IS_Is4;
- IS_Ifl := IS_Is4;
- IS_Ilf := IS_Is8;
-
- for J in 1 .. 12 loop
- IS_Ill (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
- end loop;
- end if;
-
- -- Generate output, Ada case
-
- if Ada_Bind_File then
- WBI ("");
-
- Set_String (" IS_Is1 : constant System.Scalar_Values.Byte1 := 16#");
- Set_String (IS_Is1);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Is2 : constant System.Scalar_Values.Byte2 := 16#");
- Set_String (IS_Is2);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Is4 : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Is4);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Is8 : constant System.Scalar_Values.Byte8 := 16#");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu1 : constant System.Scalar_Values.Byte1 := 16#");
- Set_String (IS_Iu1);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu2 : constant System.Scalar_Values.Byte2 := 16#");
- Set_String (IS_Iu2);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu4 : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Iu4);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu8 : constant System.Scalar_Values.Byte8 := 16#");
- Set_String (IS_Iu8);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Isf : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Isf);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Ifl : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Ifl);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Ilf : constant System.Scalar_Values.Byte8 := 16#");
- Set_String (IS_Ilf);
- Write_Statement_Buffer ("#;");
-
- -- Special case of Long_Long_Float. This is a 10-byte value used
- -- only on the x86. We could omit it for other architectures, but
- -- we don't easily have that kind of target specialization in the
- -- binder, and it's only 10 bytes, and only if -Sxx is used. Note
- -- that for architectures where Long_Long_Float is the same as
- -- Long_Float, the expander uses the Long_Float constant for the
- -- initializations of Long_Long_Float values.
-
- WBI (" IS_Ill : constant array (1 .. 12) of");
- WBI (" System.Scalar_Values.Byte1 := (");
- Set_String (" ");
-
- for J in 1 .. 6 loop
- Set_String (" 16#");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
- Set_String ("#,");
- end loop;
-
- Write_Statement_Buffer;
- Set_String (" ");
-
- for J in 7 .. 12 loop
- Set_String (" 16#");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
-
- if J = 12 then
- Set_String ("#);");
- else
- Set_String ("#,");
- end if;
- end loop;
-
- Write_Statement_Buffer;
-
- -- Output export statements to export to System.Scalar_Values
-
- WBI ("");
-
- WBI (" pragma Export (Ada, IS_Is1, ""__gnat_Is1"");");
- WBI (" pragma Export (Ada, IS_Is2, ""__gnat_Is2"");");
- WBI (" pragma Export (Ada, IS_Is4, ""__gnat_Is4"");");
- WBI (" pragma Export (Ada, IS_Is8, ""__gnat_Is8"");");
- WBI (" pragma Export (Ada, IS_Iu1, ""__gnat_Iu1"");");
- WBI (" pragma Export (Ada, IS_Iu2, ""__gnat_Iu2"");");
- WBI (" pragma Export (Ada, IS_Iu4, ""__gnat_Iu4"");");
- WBI (" pragma Export (Ada, IS_Iu8, ""__gnat_Iu8"");");
- WBI (" pragma Export (Ada, IS_Isf, ""__gnat_Isf"");");
- WBI (" pragma Export (Ada, IS_Ifl, ""__gnat_Ifl"");");
- WBI (" pragma Export (Ada, IS_Ilf, ""__gnat_Ilf"");");
- WBI (" pragma Export (Ada, IS_Ill, ""__gnat_Ill"");");
-
- -- Generate output C case
-
- else
- -- The lines we generate in this case are of the form
- -- typ __gnat_I?? = 0x??;
- -- where typ is appropriate to the length
-
- WBI ("");
-
- Set_String ("unsigned char __gnat_Is1 = 0x");
- Set_String (IS_Is1);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned short __gnat_Is2 = 0x");
- Set_String (IS_Is2);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned __gnat_Is4 = 0x");
- Set_String (IS_Is4);
- Write_Statement_Buffer (";");
-
- Set_String ("long long unsigned __gnat_Is8 = 0x");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("LL;");
-
- Set_String ("unsigned char __gnat_Iu1 = 0x");
- Set_String (IS_Is1);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned short __gnat_Iu2 = 0x");
- Set_String (IS_Is2);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned __gnat_Iu4 = 0x");
- Set_String (IS_Is4);
- Write_Statement_Buffer (";");
-
- Set_String ("long long unsigned __gnat_Iu8 = 0x");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("LL;");
-
- Set_String ("unsigned __gnat_Isf = 0x");
- Set_String (IS_Isf);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned __gnat_Ifl = 0x");
- Set_String (IS_Ifl);
- Write_Statement_Buffer (";");
-
- Set_String ("long long unsigned __gnat_Ilf = 0x");
- Set_String (IS_Ilf);
- Write_Statement_Buffer ("LL;");
-
- -- For Long_Long_Float, we generate
- -- char __gnat_Ill[12] = {0x??, 0x??, 0x??, 0x??, 0x??, 0x??,
- -- 0x??, 0x??, 0x??, 0x??, 0x??, 0x??);
-
- Set_String ("unsigned char __gnat_Ill[12] = {");
-
- for J in 1 .. 6 loop
- Set_String ("0x");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
- Set_String (", ");
- end loop;
-
- Write_Statement_Buffer;
- Set_String (" ");
-
- for J in 7 .. 12 loop
- Set_String ("0x");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
-
- if J = 12 then
- Set_String ("};");
- else
- Set_String (", ");
- end if;
- end loop;
-
- Write_Statement_Buffer;
- end if;
- end Gen_Scalar_Values;
-
- ----------------------
- -- Gen_Versions_Ada --
- ----------------------
-
- -- This routine generates two sets of lines. The first set has the form:
-
- -- unnnnn : constant Integer := 16#hhhhhhhh#;
-
- -- The second set has the form
-
- -- pragma Export (C, unnnnn, unam);
-
- -- for each unit, where unam is the unit name suffixed by either B or
- -- S for body or spec, with dots replaced by double underscores, and
- -- hhhhhhhh is the version number, and nnnnn is a 5-digits serial number.
-
- procedure Gen_Versions_Ada is
- Ubuf : String (1 .. 6) := "u00000";
-
- procedure Increment_Ubuf;
- -- Little procedure to increment the serial number
-
- procedure Increment_Ubuf is
- begin
- for J in reverse Ubuf'Range loop
- Ubuf (J) := Character'Succ (Ubuf (J));
- exit when Ubuf (J) <= '9';
- Ubuf (J) := '0';
- end loop;
- end Increment_Ubuf;
-
- -- Start of processing for Gen_Versions_Ada
-
- begin
- if Bind_For_Library then
-
- -- When building libraries, the version number of each unit can
- -- not be computed, since the binder does not know the full list
- -- of units. Therefore, the 'Version and 'Body_Version
- -- attributes can not supported in this case.
-
- return;
- end if;
-
- WBI ("");
-
- WBI (" type Version_32 is mod 2 ** 32;");
- for U in Units.First .. Units.Last loop
- Increment_Ubuf;
- WBI (" " & Ubuf & " : constant Version_32 := 16#" &
- Units.Table (U).Version & "#;");
- end loop;
-
- WBI ("");
- Ubuf := "u00000";
-
- for U in Units.First .. Units.Last loop
- Increment_Ubuf;
- Set_String (" pragma Export (C, ");
- Set_String (Ubuf);
- Set_String (", """);
-
- Get_Name_String (Units.Table (U).Uname);
-
- for K in 1 .. Name_Len loop
- if Name_Buffer (K) = '.' then
- Set_Char ('_');
- Set_Char ('_');
-
- elsif Name_Buffer (K) = '%' then
- exit;
-
- else
- Set_Char (Name_Buffer (K));
- end if;
- end loop;
-
- if Name_Buffer (Name_Len) = 's' then
- Set_Char ('S');
- else
- Set_Char ('B');
- end if;
-
- Set_String (""");");
- Write_Statement_Buffer;
- end loop;
-
- end Gen_Versions_Ada;
-
- --------------------
- -- Gen_Versions_C --
- --------------------
-
- -- This routine generates a line of the form:
-
- -- unsigned unam = 0xhhhhhhhh;
-
- -- for each unit, where unam is the unit name suffixed by either B or
- -- S for body or spec, with dots replaced by double underscores.
-
- procedure Gen_Versions_C is
- begin
- if Bind_For_Library then
-
- -- When building libraries, the version number of each unit can
- -- not be computed, since the binder does not know the full list
- -- of units. Therefore, the 'Version and 'Body_Version
- -- attributes can not supported.
-
- return;
- end if;
-
- for U in Units.First .. Units.Last loop
- Set_String ("unsigned ");
-
- Get_Name_String (Units.Table (U).Uname);
-
- for K in 1 .. Name_Len loop
- if Name_Buffer (K) = '.' then
- Set_String ("__");
-
- elsif Name_Buffer (K) = '%' then
- exit;
-
- else
- Set_Char (Name_Buffer (K));
- end if;
- end loop;
-
- if Name_Buffer (Name_Len) = 's' then
- Set_Char ('S');
- else
- Set_Char ('B');
- end if;
-
- Set_String (" = 0x");
- Set_String (Units.Table (U).Version);
- Set_Char (';');
- Write_Statement_Buffer;
- end loop;
-
- end Gen_Versions_C;
-
- -----------------------
- -- Get_Ada_Main_Name --
- -----------------------
-
- function Get_Ada_Main_Name return String is
- Suffix : constant String := "_00";
- Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
- Opt.Ada_Main_Name.all & Suffix;
- Nlen : Natural;
-
- begin
- -- The main program generated by JGNAT expects a package called
- -- ada_<main procedure>.
-
- if Hostparm.Java_VM then
- -- Get main program name
-
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
-
- -- Remove the %b
-
- return "ada_" & Name_Buffer (1 .. Name_Len - 2);
- end if;
-
- -- This loop tries the following possibilities in order
- -- <Ada_Main>
- -- <Ada_Main>_01
- -- <Ada_Main>_02
- -- ..
- -- <Ada_Main>_99
- -- where <Ada_Main> is equal to Opt.Ada_Main_Name. By default,
- -- it is set to 'ada_main'.
-
- for J in 0 .. 99 loop
- if J = 0 then
- Nlen := Name'Length - Suffix'Length;
- else
- Nlen := Name'Length;
- Name (Name'Last) := Character'Val (J mod 10 + Character'Pos ('0'));
- Name (Name'Last - 1) :=
- Character'Val (J / 10 + Character'Pos ('0'));
- end if;
-
- for K in ALIs.First .. ALIs.Last loop
- for L in ALIs.Table (K).First_Unit .. ALIs.Table (K).Last_Unit loop
-
- -- Get unit name, removing %b or %e at end
-
- Get_Name_String (Units.Table (L).Uname);
- Name_Len := Name_Len - 2;
-
- if Name_Buffer (1 .. Name_Len) = Name (1 .. Nlen) then
- goto Continue;
- end if;
- end loop;
- end loop;
-
- return Name (1 .. Nlen);
-
- <<Continue>>
- null;
- end loop;
-
- -- If we fall through, just use a peculiar unlikely name
-
- return ("Qwertyuiop");
- end Get_Ada_Main_Name;
-
- -------------------
- -- Get_Main_Name --
- -------------------
-
- function Get_Main_Name return String is
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/";
-
- begin
- -- Explicit name given with -M switch
-
- if Bind_Alternate_Main_Name then
- return Alternate_Main_Name.all;
-
- -- Case of main program name to be used directly
-
- elsif VxWorks_Target then
-
- -- Get main program name
-
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
-
- -- If this is a child name, return only the name of the child,
- -- since we can't have dots in a nested program name. Note that
- -- we do not include the %b at the end of the unit name.
-
- for J in reverse 1 .. Name_Len - 3 loop
- if J = 1 or else Name_Buffer (J - 1) = '.' then
- return Name_Buffer (J .. Name_Len - 2);
- end if;
- end loop;
-
- raise Program_Error; -- impossible exit
-
- -- Case where "main" is to be used as default
-
- else
- return "main";
- end if;
- end Get_Main_Name;
-
- ----------------------
- -- Lt_Linker_Option --
- ----------------------
-
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
- begin
- if Linker_Options.Table (Op1).Internal_File
- /=
- Linker_Options.Table (Op2).Internal_File
- then
- return Linker_Options.Table (Op1).Internal_File
- <
- Linker_Options.Table (Op2).Internal_File;
- else
- if Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
- /=
- Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position
- then
- return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
- >
- Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
-
- else
- return Linker_Options.Table (Op1).Original_Pos
- <
- Linker_Options.Table (Op2).Original_Pos;
- end if;
- end if;
- end Lt_Linker_Option;
-
- ------------------------
- -- Move_Linker_Option --
- ------------------------
-
- procedure Move_Linker_Option (From : Natural; To : Natural) is
- begin
- Linker_Options.Table (To) := Linker_Options.Table (From);
- end Move_Linker_Option;
-
- ----------------------------
- -- Resolve_Binder_Options --
- ----------------------------
-
- procedure Resolve_Binder_Options is
- begin
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
-
- -- The procedure of looking for specific packages and setting
- -- flags is very wrong, but there isn't a good alternative at
- -- this time.
-
- if Name_Buffer (1 .. 19) = "system.os_interface" then
- With_GNARL := True;
- end if;
-
- if Hostparm.OpenVMS and then Name_Buffer (1 .. 3) = "dec" then
- With_DECGNAT := True;
- end if;
- end loop;
- end Resolve_Binder_Options;
-
- --------------
- -- Set_Char --
- --------------
-
- procedure Set_Char (C : Character) is
- begin
- Last := Last + 1;
- Statement_Buffer (Last) := C;
- end Set_Char;
-
- -------------
- -- Set_Int --
- -------------
-
- procedure Set_Int (N : Int) is
- begin
- if N < 0 then
- Set_String ("-");
- Set_Int (-N);
-
- else
- if N > 9 then
- Set_Int (N / 10);
- end if;
-
- Last := Last + 1;
- Statement_Buffer (Last) :=
- Character'Val (N mod 10 + Character'Pos ('0'));
- end if;
- end Set_Int;
-
- ---------------------------
- -- Set_Main_Program_Name --
- ---------------------------
-
- procedure Set_Main_Program_Name is
- begin
- -- Note that name has %b on the end which we ignore
-
- -- First we output the initial _ada_ since we know that the main
- -- program is a library level subprogram.
-
- Set_String ("_ada_");
-
- -- Copy name, changing dots to double underscores
-
- for J in 1 .. Name_Len - 2 loop
- if Name_Buffer (J) = '.' then
- Set_String ("__");
- else
- Set_Char (Name_Buffer (J));
- end if;
- end loop;
- end Set_Main_Program_Name;
-
- ---------------------
- -- Set_Name_Buffer --
- ---------------------
-
- procedure Set_Name_Buffer is
- begin
- for J in 1 .. Name_Len loop
- Set_Char (Name_Buffer (J));
- end loop;
- end Set_Name_Buffer;
-
- ----------------
- -- Set_String --
- ----------------
-
- procedure Set_String (S : String) is
- begin
- Statement_Buffer (Last + 1 .. Last + S'Length) := S;
- Last := Last + S'Length;
- end Set_String;
-
- -------------------
- -- Set_Unit_Name --
- -------------------
-
- procedure Set_Unit_Name is
- begin
- for J in 1 .. Name_Len - 2 loop
- if Name_Buffer (J) /= '.' then
- Set_Char (Name_Buffer (J));
- else
- Set_String ("__");
- end if;
- end loop;
- end Set_Unit_Name;
-
- ---------------------
- -- Set_Unit_Number --
- ---------------------
-
- procedure Set_Unit_Number (U : Unit_Id) is
- Num_Units : constant Nat := Nat (Units.Table'Last) - Nat (Unit_Id'First);
- Unum : constant Nat := Nat (U) - Nat (Unit_Id'First);
-
- begin
- if Num_Units >= 10 and then Unum < 10 then
- Set_Char ('0');
- end if;
-
- if Num_Units >= 100 and then Unum < 100 then
- Set_Char ('0');
- end if;
-
- Set_Int (Unum);
- end Set_Unit_Number;
-
- ------------
- -- Tab_To --
- ------------
-
- procedure Tab_To (N : Natural) is
- begin
- while Last < N loop
- Set_Char (' ');
- end loop;
- end Tab_To;
-
- -----------
- -- Value --
- -----------
-
- function Value (chars : chars_ptr) return String is
- function Strlen (chars : chars_ptr) return Natural;
- pragma Import (C, Strlen);
-
- begin
- if chars = Null_Address then
- return "";
-
- else
- declare
- subtype Result_Type is String (1 .. Strlen (chars));
-
- Result : Result_Type;
- for Result'Address use chars;
-
- begin
- return Result;
- end;
- end if;
- end Value;
-
- ----------------------
- -- Write_Info_Ada_C --
- ----------------------
-
- procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is
- begin
- if Ada_Bind_File then
- declare
- S : String (1 .. Ada'Length + Common'Length);
-
- begin
- S (1 .. Ada'Length) := Ada;
- S (Ada'Length + 1 .. S'Length) := Common;
- WBI (S);
- end;
-
- else
- declare
- S : String (1 .. C'Length + Common'Length);
-
- begin
- S (1 .. C'Length) := C;
- S (C'Length + 1 .. S'Length) := Common;
- WBI (S);
- end;
- end if;
- end Write_Info_Ada_C;
-
- ----------------------------
- -- Write_Statement_Buffer --
- ----------------------------
-
- procedure Write_Statement_Buffer is
- begin
- WBI (Statement_Buffer (1 .. Last));
- Last := 0;
- end Write_Statement_Buffer;
-
- procedure Write_Statement_Buffer (S : String) is
- begin
- Set_String (S);
- Write_Statement_Buffer;
- end Write_Statement_Buffer;
-
-end Bindgen;
projects / msp430-gcc.git / blobdiff