-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
+-- ware Foundation; either version 3, 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. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- 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 ALI; use ALI;
+with Binde; use Binde;
+with Casing; use Casing;
+with Fname; use Fname;
+with Gnatvsn; use Gnatvsn;
with Hostparm;
-with Namet; use Namet;
-with Opt; use Opt;
-with Osint; use Osint;
-with Osint.B; use Osint.B;
-with Output; use Output;
-with Types; use Types;
-with Sdefault; use Sdefault;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Osint.B; use Osint.B;
+with Output; use Output;
+with Rident; use Rident;
+with Table; use Table;
+with Targparm; use Targparm;
+with Types; use Types;
+
+with System.OS_Lib; use System.OS_Lib;
+with System.WCh_Con; use System.WCh_Con;
-with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
package body Bindgen is
With_DECGNAT : Boolean := False;
-- Flag which indicates whether the program uses the DECGNAT library
- -- (presence of the unit System.Aux_DEC.DECLIB)
+ -- (presence of the unit DEC).
With_GNARL : Boolean := False;
-- Flag which indicates whether the program uses the GNARL library
Num_Elab_Calls : Nat := 0;
-- Number of generated calls to elaboration routines
+ System_Restrictions_Used : Boolean;
+ -- Flag indicating whether the unit System.Restrictions is in the closure
+ -- of the partition. This is set by Check_System_Restrictions_Used, and
+ -- is used to determine whether or not to initialize the restrictions
+ -- information in the body of the binder generated file (we do not want
+ -- to do this unconditionally, since it drags in the System.Restrictions
+ -- unit unconditionally, which is unpleasand, especially for ZFP etc.)
+
+ ----------------------------------
+ -- Interface_State Pragma Table --
+ ----------------------------------
+
+ -- This table assembles the interface state pragma information from
+ -- all the units in the partition. Note that Bcheck has already checked
+ -- that the information is consistent across units. The entries
+ -- in this table are n/u/r/s for not set/user/runtime/system.
+
+ package IS_Pragma_Settings is new Table.Table (
+ Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "IS_Pragma_Settings");
+
+ -- This table assembles the Priority_Specific_Dispatching pragma
+ -- information from all the units in the partition. Note that Bcheck has
+ -- already checked that the information is consistent across units.
+ -- The entries in this table are the upper case first character of the
+ -- policy name, e.g. 'F' for FIFO_Within_Priorities.
+
+ package PSD_Pragma_Settings is new Table.Table (
+ Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "PSD_Pragma_Settings");
+
+ ----------------------
+ -- Run-Time Globals --
+ ----------------------
+
+ -- This section documents the global variables that set from the
+ -- generated binder file.
+
+ -- Main_Priority : Integer;
+ -- Time_Slice_Value : Integer;
+ -- WC_Encoding : Character;
+ -- Locking_Policy : Character;
+ -- Queuing_Policy : Character;
+ -- Task_Dispatching_Policy : Character;
+ -- Priority_Specific_Dispatching : System.Address;
+ -- Num_Specific_Dispatching : Integer;
+ -- Restrictions : System.Address;
+ -- Interrupt_States : System.Address;
+ -- Num_Interrupt_States : Integer;
+ -- Unreserve_All_Interrupts : Integer;
+ -- Exception_Tracebacks : Integer;
+ -- Zero_Cost_Exceptions : Integer;
+ -- Detect_Blocking : Integer;
+ -- Default_Stack_Size : Integer;
+ -- Leap_Seconds_Support : Integer;
+
+ -- Main_Priority is the priority value set by pragma Priority in the main
+ -- program. If no such pragma is present, the value is -1.
+
+ -- Time_Slice_Value is the time slice value set by pragma Time_Slice in the
+ -- main program, or by the use of a -Tnnn parameter for the binder (if both
+ -- are present, the binder value overrides). The value is in milliseconds.
+ -- A value of zero indicates that time slicing should be suppressed. If no
+ -- pragma is present, and no -T switch was used, the value is -1.
+
+ -- WC_Encoding shows the wide character encoding method used for the main
+ -- program. This is one of the encoding letters defined in
+ -- System.WCh_Con.WC_Encoding_Letters.
+
+ -- Locking_Policy is a space if no locking policy was specified for the
+ -- partition. If a locking policy was specified, the value is the upper
+ -- case first character of the locking policy name, for example, 'C' for
+ -- Ceiling_Locking.
+
+ -- Queuing_Policy is a space if no queuing policy was specified for the
+ -- partition. If a queuing policy was specified, the value is the upper
+ -- case first character of the queuing policy name for example, 'F' for
+ -- FIFO_Queuing.
+
+ -- Task_Dispatching_Policy is a space if no task dispatching policy was
+ -- specified for the partition. If a task dispatching policy was specified,
+ -- the value is the upper case first character of the policy name, e.g. 'F'
+ -- for FIFO_Within_Priorities.
+
+ -- Priority_Specific_Dispatching is the address of a string used to store
+ -- the task dispatching policy specified for the different priorities in
+ -- the partition. The length of this string is determined by the last
+ -- priority for which such a pragma applies (the string will be a null
+ -- string if no specific dispatching policies were used). If pragma were
+ -- present, the entries apply to the priorities in sequence from the first
+ -- priority. The value stored is the upper case first character of the
+ -- policy name, or 'F' (for FIFO_Within_Priorities) as the default value
+ -- for those priority ranges not specified.
+
+ -- Num_Specific_Dispatching is the length of the
+ -- Priority_Specific_Dispatching string. It will be set to zero if no
+ -- Priority_Specific_Dispatching pragmas are present.
+
+ -- Restrictions is the address of a null-terminated string specifying the
+ -- restrictions information for the partition. The format is identical to
+ -- that of the parameter string found on R lines in ali files (see Lib.Writ
+ -- spec in lib-writ.ads for full details). The difference is that in this
+ -- context the values are the cumulative ones for the entire partition.
+
+ -- Interrupt_States is the address of a string used to specify the
+ -- cumulative results of Interrupt_State pragmas used in the partition.
+ -- The length of this string is determined by the last interrupt for which
+ -- such a pragma is given (the string will be a null string if no pragmas
+ -- were used). If pragma were present the entries apply to the interrupts
+ -- in sequence from the first interrupt, and are set to one of four
+ -- possible settings: 'n' for not specified, 'u' for user, 'r' for run
+ -- time, 's' for system, see description of Interrupt_State pragma for
+ -- further details.
+
+ -- Num_Interrupt_States is the length of the Interrupt_States string. It
+ -- will be set to zero if no Interrupt_State pragmas are present.
+
+ -- Unreserve_All_Interrupts is set to one if at least one unit in the
+ -- partition had a pragma Unreserve_All_Interrupts, and zero otherwise.
+
+ -- Exception_Tracebacks is set to one if the -E parameter was present
+ -- in the bind and to zero otherwise. Note that on some targets exception
+ -- tracebacks are provided by default, so a value of zero for this
+ -- parameter does not necessarily mean no trace backs are available.
+
+ -- Zero_Cost_Exceptions is set to one if zero cost exceptions are used for
+ -- this partition, and to zero if longjmp/setjmp exceptions are used.
+ -- the use of zero
+
+ -- Detect_Blocking indicates whether pragma Detect_Blocking is active or
+ -- not. A value of zero indicates that the pragma is not present, while a
+ -- value of 1 signals its presence in the partition.
+
+ -- Default_Stack_Size is the default stack size used when creating an Ada
+ -- task with no explicit Storage_Size clause.
+
+ -- Leap_Seconds_Support denotes whether leap seconds have been enabled or
+ -- disabled. A value of zero indicates that leap seconds are turned "off",
+ -- while a value of one signifies "on" status.
+
-----------------------
-- Local Subprograms --
-----------------------
procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
-- Convenient shorthand used throughout
- 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 Check_System_Restrictions_Used;
+ -- Sets flag System_Restrictions_Used (Set to True if and only if the unit
+ -- System.Restrictions is present in the partition, otherwise False).
procedure Gen_Adainit_Ada;
-- Generates the Adainit procedure (Ada code 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_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_Restrictions_Ada;
+ -- Generate initialization of restrictions variable (Ada code case)
+
+ procedure Gen_Restrictions_C;
+ -- Generate initialization of restrictions variable (C code case)
procedure Gen_Versions_Ada;
-- Output series of definitions for unit versions (Ada code case)
-- 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_Unit_Name (S : String) return String;
+ -- Return the main unit name corresponding to S by replacing '.' with '_'
+
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.
+ -- correct external main program. It is "main" by default, unless the
+ -- flag Use_Ada_Main_Program_Name_On_Target is set, in which case it
+ -- is the name of the Ada main name without the "_ada". This default
+ -- can be overridden explicitly using the -Mname binder switch.
+
+ function Get_WC_Encoding return Character;
+ -- Return wide character encoding method to set as WC_Encoding in output.
+ -- If -W has been used, returns the specified encoding, otherwise returns
+ -- the encoding method used for the main program source. If there is no
+ -- main program source (-z switch used), returns brackets ('b').
function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
-- Compare linker options, when sorting, first according to
procedure Move_Linker_Option (From : Natural; To : Natural);
-- Move routine for sorting linker options
- procedure Public_Version_Warning;
- -- Emit a warning concerning the use of the Public version under
- -- certain circumstances. See details in body.
+ 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 Set_Char (C : Character);
-- Set given character in Statement_Buffer at the Last + 1 position
-- starting at the Last + 1 position, and updating Last past the value.
-- A minus sign is output for a negative value.
+ procedure Set_Boolean (B : Boolean);
+ -- Set given boolean value in Statement_Buffer at the Last + 1 position
+ -- and update Last past the value.
+
+ procedure Set_IS_Pragma_Table;
+ -- Initializes contents of IS_Pragma_Settings table from ALI table
+
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.
+ -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
+
+ procedure Set_PSD_Pragma_Table;
+ -- Initializes contents of PSD_Pragma_Settings table from ALI table
procedure Set_String (S : String);
-- Sets characters of given string in Statement_Buffer, starting at the
-- 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.
-
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.
-- First writes its argument (using Set_String (S)), then writes out the
-- contents of statement buffer up to Last, and reset Last to 0
+ ------------------------------------
+ -- Check_System_Restrictions_Used --
+ ------------------------------------
+
+ procedure Check_System_Restrictions_Used is
+ begin
+ for J in Units.First .. Units.Last loop
+ if Get_Name_String (Units.Table (J).Sfile) = "s-restri.ads" then
+ System_Restrictions_Used := True;
+ return;
+ end if;
+ end loop;
+
+ System_Restrictions_Used := False;
+ end Check_System_Restrictions_Used;
+
----------------------
-- Gen_Adafinal_Ada --
----------------------
-- 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
+ if VM_Target /= No_VM then
WBI (" System.Standard_Library.Adafinal;");
+
+ -- If there is no finalization, there is nothing to do
+
+ elsif Cumulative_Restrictions.Set (No_Finalization) then
+ WBI (" null;");
else
WBI (" Do_Finalize;");
end if;
procedure Gen_Adafinal_C is
begin
- WBI ("void " & Ada_Final_Name.all & " () {");
+ WBI ("void " & Ada_Final_Name.all & " (void) {");
WBI (" system__standard_library__adafinal ();");
WBI ("}");
WBI ("");
U : Unit_Record renames Units.Table (Unum);
begin
- if U.Set_Elab_Entity then
+ -- Check for Elab_Entity to be set for this unit
+
+ if U.Set_Elab_Entity
+
+ -- Don't generate reference for stand alone library
+
+ and then not U.SAL_Interface
+
+ -- Don't generate reference for predefined file in No_Run_Time
+ -- mode, since we don't include the object files in this case
+
+ and then not
+ (No_Run_Time_Mode
+ and then Is_Predefined_File_Name (U.Sfile))
+ then
Set_String (" ");
Set_String ("E");
Set_Unit_Number (Unum);
- Set_String (" : Boolean; pragma Import (Ada, ");
+
+ case VM_Target is
+ when No_VM | JVM_Target =>
+ Set_String (" : Boolean; pragma Import (Ada, ");
+ when CLI_Target =>
+ Set_String (" : Boolean; pragma Import (CIL, ");
+ end case;
+
Set_String ("E");
Set_Unit_Number (Unum);
Set_String (", """);
-- that includes the class name (using '$' separators
-- in the case of a child unit name).
- if Hostparm.Java_VM then
+ if VM_Target /= No_VM then
for J in 1 .. Name_Len - 2 loop
- if Name_Buffer (J) /= '.' then
+ if VM_Target = CLI_Target
+ or else Name_Buffer (J) /= '.'
+ then
Set_Char (Name_Buffer (J));
else
Set_String ("$");
end if;
end loop;
- Set_String (".");
+ if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then
+ Set_String (".");
+ else
+ Set_String ("_pkg.");
+ end if;
-- If the unit name is very long, then split the
-- Import link name across lines using "&" (occurs
Write_Statement_Buffer;
- -- 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 the standard library is suppressed, then the only global variable
+ -- that might be needed (by the Ravenscar profile) is the priority of
+ -- the environment.
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target then
if Main_Priority /= No_Main_Priority then
WBI (" Main_Priority : Integer;");
WBI (" pragma Import (C, Main_Priority," &
WBI (" null;");
end if;
- -- 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.
+ -- Normal case (standard library not suppressed). Set all global values
+ -- used by the run time.
else
- -- Generate restrictions string
-
- Set_String (" Restrictions : constant String :=");
- Write_Statement_Buffer;
- Set_String (" """);
-
- for J in Restrictions'Range loop
- Set_Char (Restrictions (J));
- end loop;
+ WBI (" Main_Priority : Integer;");
+ WBI (" pragma Import (C, Main_Priority, " &
+ """__gl_main_priority"");");
+ WBI (" Time_Slice_Value : Integer;");
+ WBI (" pragma Import (C, Time_Slice_Value, " &
+ """__gl_time_slice_val"");");
+ WBI (" WC_Encoding : Character;");
+ WBI (" pragma Import (C, WC_Encoding, ""__gl_wc_encoding"");");
+ WBI (" Locking_Policy : Character;");
+ WBI (" pragma Import (C, Locking_Policy, " &
+ """__gl_locking_policy"");");
+ WBI (" Queuing_Policy : Character;");
+ WBI (" pragma Import (C, Queuing_Policy, " &
+ """__gl_queuing_policy"");");
+ WBI (" Task_Dispatching_Policy : Character;");
+ WBI (" pragma Import (C, Task_Dispatching_Policy, " &
+ """__gl_task_dispatching_policy"");");
+ WBI (" Priority_Specific_Dispatching : System.Address;");
+ WBI (" pragma Import (C, Priority_Specific_Dispatching, " &
+ """__gl_priority_specific_dispatching"");");
+ WBI (" Num_Specific_Dispatching : Integer;");
+ WBI (" pragma Import (C, Num_Specific_Dispatching, " &
+ """__gl_num_specific_dispatching"");");
+
+ WBI (" Interrupt_States : System.Address;");
+ WBI (" pragma Import (C, Interrupt_States, " &
+ """__gl_interrupt_states"");");
+ WBI (" Num_Interrupt_States : Integer;");
+ WBI (" pragma Import (C, Num_Interrupt_States, " &
+ """__gl_num_interrupt_states"");");
+ WBI (" Unreserve_All_Interrupts : Integer;");
+ WBI (" pragma Import (C, Unreserve_All_Interrupts, " &
+ """__gl_unreserve_all_interrupts"");");
- Set_String (""";");
- Write_Statement_Buffer;
- WBI ("");
+ if Exception_Tracebacks then
+ WBI (" Exception_Tracebacks : Integer;");
+ WBI (" pragma Import (C, Exception_Tracebacks, " &
+ """__gl_exception_tracebacks"");");
+ end if;
- 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 (" Restrictions : System.Address;");
- WBI (" Unreserve_All_Interrupts : Integer;");
- WBI (" Exception_Tracebacks : Integer;");
- WBI (" Zero_Cost_Exceptions : Integer);");
- WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");");
+ WBI (" Zero_Cost_Exceptions : Integer;");
+ WBI (" pragma Import (C, Zero_Cost_Exceptions, " &
+ """__gl_zero_cost_exceptions"");");
+ WBI (" Detect_Blocking : Integer;");
+ WBI (" pragma Import (C, Detect_Blocking, " &
+ """__gl_detect_blocking"");");
+ WBI (" Default_Stack_Size : Integer;");
+ WBI (" pragma Import (C, Default_Stack_Size, " &
+ """__gl_default_stack_size"");");
+ WBI (" Leap_Seconds_Support : Integer;");
+ WBI (" pragma Import (C, Leap_Seconds_Support, " &
+ """__gl_leap_seconds_support"");");
-- Import entry point for elaboration time signal handler
- -- installation, and indication of whether it's been called
- -- previously
+ -- installation, and indication of if it's been called previously.
WBI ("");
WBI (" procedure Install_Handler;");
WBI (" pragma Import (C, Handler_Installed, " &
"""__gnat_handler_installed"");");
- -- Generate exception table
+ -- Import entry point for environment feature enable/disable
+ -- routine, and indication that it's been called previously.
+
+ if OpenVMS_On_Target then
+ WBI ("");
+ WBI (" procedure Set_Features;");
+ WBI (" pragma Import (C, Set_Features, " &
+ """__gnat_set_features"");");
+ WBI ("");
+ WBI (" Features_Set : Integer;");
+ WBI (" pragma Import (C, Features_Set, " &
+ """__gnat_features_set"");");
+ end if;
+
+ -- Initialize stack limit variable of the environment task if the
+ -- stack check method is stack limit and stack check is enabled.
+
+ if Stack_Check_Limits_On_Target
+ and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
+ then
+ WBI ("");
+ WBI (" procedure Initialize_Stack_Limit;");
+ WBI (" pragma Import (C, Initialize_Stack_Limit, " &
+ """__gnat_initialize_stack_limit"");");
+ end if;
+
+ -- Special processing when main program is CIL function/procedure
+
+ if VM_Target = CLI_Target
+ and then Bind_Main_Program
+ and then not No_Main_Subprogram
+ then
+ WBI ("");
+
+ -- Function case, use Set_Exit_Status to report the returned
+ -- status code, since that is the only mechanism available.
- Gen_Exception_Table_Ada;
+ if ALIs.Table (ALIs.First).Main_Program = Func then
+ WBI (" Result : Integer;");
+ WBI (" procedure Set_Exit_Status (Code : Integer);");
+ WBI (" pragma Import (C, Set_Exit_Status, " &
+ """__gnat_set_exit_status"");");
+ WBI ("");
+ WBI (" function Ada_Main_Program return Integer;");
- -- Generate the call to Set_Globals
+ -- Procedure case
- WBI (" Set_Globals");
+ else
+ WBI (" procedure Ada_Main_Program;");
+ end if;
+
+ Get_Name_String (Units.Table (First_Unit_Entry).Uname);
+ Name_Len := Name_Len - 2;
+ WBI (" pragma Import (CIL, Ada_Main_Program, """
+ & Name_Buffer (1 .. Name_Len) & "."
+ & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);");
+ end if;
- Set_String (" (Main_Priority => ");
+ WBI (" begin");
+
+ Set_String (" Main_Priority := ");
Set_Int (Main_Priority);
- Set_Char (',');
+ Set_Char (';');
Write_Statement_Buffer;
- Set_String (" Time_Slice_Value => ");
+ Set_String (" Time_Slice_Value := ");
if Task_Dispatching_Policy_Specified = 'F'
and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
end if;
- Set_Char (',');
+ Set_Char (';');
Write_Statement_Buffer;
- Set_String (" WC_Encoding => '");
- Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
- Set_String ("',");
+ Set_String (" WC_Encoding := '");
+ Set_Char (Get_WC_Encoding);
+
+ Set_String ("';");
Write_Statement_Buffer;
- Set_String (" Locking_Policy => '");
+ Set_String (" Locking_Policy := '");
Set_Char (Locking_Policy_Specified);
- Set_String ("',");
+ Set_String ("';");
Write_Statement_Buffer;
- Set_String (" Queuing_Policy => '");
+ Set_String (" Queuing_Policy := '");
Set_Char (Queuing_Policy_Specified);
- Set_String ("',");
+ Set_String ("';");
Write_Statement_Buffer;
- Set_String (" Task_Dispatching_Policy => '");
+ Set_String (" Task_Dispatching_Policy := '");
Set_Char (Task_Dispatching_Policy_Specified);
- Set_String ("',");
+ Set_String ("';");
+ Write_Statement_Buffer;
+
+ Gen_Restrictions_Ada;
+
+ WBI (" Priority_Specific_Dispatching :=");
+ WBI (" Local_Priority_Specific_Dispatching'Address;");
+
+ Set_String (" Num_Specific_Dispatching := ");
+ Set_Int (PSD_Pragma_Settings.Last + 1);
+ Set_Char (';');
Write_Statement_Buffer;
- WBI (" Restrictions => Restrictions'Address,");
+ WBI (" Interrupt_States := Local_Interrupt_States'Address;");
+
+ Set_String (" Num_Interrupt_States := ");
+ Set_Int (IS_Pragma_Settings.Last + 1);
+ Set_Char (';');
+ Write_Statement_Buffer;
- Set_String (" Unreserve_All_Interrupts => ");
+ Set_String (" Unreserve_All_Interrupts := ");
if Unreserve_All_Interrupts_Specified then
Set_String ("1");
Set_String ("0");
end if;
- Set_String (",");
+ Set_Char (';');
Write_Statement_Buffer;
- Set_String (" Exception_Tracebacks => ");
-
if Exception_Tracebacks then
+ WBI (" Exception_Tracebacks := 1;");
+ end if;
+
+ Set_String (" Zero_Cost_Exceptions := ");
+
+ if Zero_Cost_Exceptions_Specified then
Set_String ("1");
else
Set_String ("0");
end if;
- Set_String (",");
+ Set_String (";");
Write_Statement_Buffer;
- Set_String (" Zero_Cost_Exceptions => ");
+ Set_String (" Detect_Blocking := ");
- if Zero_Cost_Exceptions_Specified then
- Set_String ("1");
+ if Detect_Blocking then
+ Set_Int (1);
else
- Set_String ("0");
+ Set_Int (0);
end if;
- Set_String (");");
+ Set_String (";");
+ Write_Statement_Buffer;
+
+ Set_String (" Default_Stack_Size := ");
+ Set_Int (Default_Stack_Size);
+ Set_String (";");
+ Write_Statement_Buffer;
+
+ Set_String (" Leap_Seconds_Support := ");
+
+ if Leap_Seconds_Support then
+ Set_Int (1);
+ else
+ Set_Int (0);
+ end if;
+
+ Set_String (";");
Write_Statement_Buffer;
-- Generate call to Install_Handler
+
WBI ("");
WBI (" if Handler_Installed = 0 then");
- WBI (" Install_Handler;");
+ WBI (" Install_Handler;");
WBI (" end if;");
+
+ -- Generate call to Set_Features
+
+ if OpenVMS_On_Target then
+ WBI ("");
+ WBI (" if Features_Set = 0 then");
+ WBI (" Set_Features;");
+ WBI (" end if;");
+ end if;
+ end if;
+
+ -- Generate call to set Initialize_Scalar values if active
+
+ if Initialize_Scalars_Used then
+ WBI ("");
+ Set_String (" System.Scalar_Values.Initialize ('");
+ Set_Char (Initialize_Scalars_Mode1);
+ Set_String ("', '");
+ Set_Char (Initialize_Scalars_Mode2);
+ Set_String ("');");
+ Write_Statement_Buffer;
+ end if;
+
+ -- Generate assignment of default secondary stack size if set
+
+ if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
+ WBI ("");
+ Set_String (" System.Secondary_Stack.");
+ Set_String ("Default_Secondary_Stack_Size := ");
+ Set_Int (Opt.Default_Sec_Stack_Size);
+ Set_Char (';');
+ Write_Statement_Buffer;
+ end if;
+
+ -- Initialize stack limit variable of the environment task if the
+ -- stack check method is stack limit and stack check is enabled.
+
+ if Stack_Check_Limits_On_Target
+ and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
+ then
+ WBI ("");
+ WBI (" Initialize_Stack_Limit;");
end if;
+ -- Generate elaboration calls
+
+ WBI ("");
Gen_Elab_Calls_Ada;
+ -- Case of main program is CIL function or procedure
+
+ if VM_Target = CLI_Target
+ and then Bind_Main_Program
+ and then not No_Main_Subprogram
+ then
+ -- For function case, use Set_Exit_Status to set result
+
+ if ALIs.Table (ALIs.First).Main_Program = Func then
+ WBI (" Result := Ada_Main_Program;");
+ WBI (" Set_Exit_Status (Result);");
+
+ -- Procedure case
+
+ else
+ WBI (" Ada_Main_Program;");
+ end if;
+ end if;
+
WBI (" end " & Ada_Init_Name.all & ";");
end Gen_Adainit_Ada;
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
begin
- WBI ("void " & Ada_Init_Name.all & " ()");
+ WBI ("void " & Ada_Init_Name.all & " (void)");
WBI ("{");
-- Generate externals for elaboration entities
U : Unit_Record renames Units.Table (Unum);
begin
- if U.Set_Elab_Entity then
+ -- Check for Elab entity to be set for this unit
+
+ if U.Set_Elab_Entity
+
+ -- Don't generate reference for stand alone library
+
+ and then not U.SAL_Interface
+
+ -- Don't generate reference for predefined file in No_Run_Time
+ -- mode, since we don't include the object files in this case
+
+ and then not
+ (No_Run_Time_Mode
+ and then Is_Predefined_File_Name (U.Sfile))
+ then
Set_String (" extern char ");
Get_Name_String (U.Uname);
Set_Unit_Name;
Write_Statement_Buffer;
- -- No run-time case
+ -- Standard library suppressed
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target then
- -- Case of No_Run_Time mode. Set __gl_main_priority if needed
+ -- Case of High_Integrity_Mode 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 = ");
+ WBI (" extern int __gl_main_priority;");
+ Set_String (" __gl_main_priority = ");
Set_Int (Main_Priority);
Set_Char (';');
Write_Statement_Buffer;
end if;
- -- Normal case (run time present)
+ -- Normal case (standard library not suppressed)
else
- -- Generate definition for restrictions string
+ -- Generate definition for interrupt states string
+
+ Set_String (" static const char *local_interrupt_states = """);
+
+ for J in 0 .. IS_Pragma_Settings.Last loop
+ Set_Char (IS_Pragma_Settings.Table (J));
+ end loop;
+
+ Set_String (""";");
+ Write_Statement_Buffer;
+
+ -- Generate definition for priority specific dispatching string
- Set_String (" const char *restrictions = """);
+ Set_String
+ (" static const char *local_priority_specific_dispatching = """);
- for J in Restrictions'Range loop
- Set_Char (Restrictions (J));
+ for J in 0 .. PSD_Pragma_Settings.Last loop
+ Set_Char (PSD_Pragma_Settings.Table (J));
end loop;
Set_String (""";");
Write_Statement_Buffer;
- -- Code for normal case (not in No_Run_Time mode)
+ -- Generate declaration for secondary stack default if needed
+
+ if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
+ WBI (" extern int system__secondary_stack__" &
+ "default_secondary_stack_size;");
+ end if;
- Gen_Exception_Table_C;
+ WBI ("");
- -- 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.
+ -- Code for normal case (standard library not suppressed)
-- 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 (" ");
+ WBI (" extern int __gl_main_priority;");
+ Set_String (" __gl_main_priority = ");
Set_Int (Main_Priority);
- Set_Char (',');
- Tab_To (15);
- Set_String ("/* Main_Priority */");
+ Set_Char (';');
Write_Statement_Buffer;
- Set_String (" ");
+ WBI (" extern int __gl_time_slice_val;");
+ Set_String (" __gl_time_slice_val = ");
if Task_Dispatching_Policy = 'F'
and then ALIs.Table (ALIs.First).Time_Slice_Value = -1
Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
end if;
- Set_Char (',');
- Tab_To (20);
- Set_String ("/* Time_Slice_Value */");
+ Set_Char (';');
Write_Statement_Buffer;
- Set_String (" '");
- Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
- Set_String ("',");
- Tab_To (20);
- Set_String ("/* WC_Encoding */");
+ WBI (" extern char __gl_wc_encoding;");
+ Set_String (" __gl_wc_encoding = '");
+ Set_Char (Get_WC_Encoding);
+
+ Set_String ("';");
Write_Statement_Buffer;
- Set_String (" '");
+ WBI (" extern char __gl_locking_policy;");
+ Set_String (" __gl_locking_policy = '");
Set_Char (Locking_Policy_Specified);
- Set_String ("',");
- Tab_To (20);
- Set_String ("/* Locking_Policy */");
+ Set_String ("';");
Write_Statement_Buffer;
- Set_String (" '");
+ WBI (" extern char __gl_queuing_policy;");
+ Set_String (" __gl_queuing_policy = '");
Set_Char (Queuing_Policy_Specified);
- Set_String ("',");
- Tab_To (20);
- Set_String ("/* Queuing_Policy */");
+ Set_String ("';");
Write_Statement_Buffer;
- Set_String (" '");
+ WBI (" extern char __gl_task_dispatching_policy;");
+ Set_String (" __gl_task_dispatching_policy = '");
Set_Char (Task_Dispatching_Policy_Specified);
- Set_String ("',");
- Tab_To (20);
- Set_String ("/* Tasking_Dispatching_Policy */");
+ Set_String ("';");
Write_Statement_Buffer;
- Set_String (" ");
- Set_String ("restrictions");
- Set_String (",");
- Tab_To (20);
- Set_String ("/* Restrictions */");
+ Gen_Restrictions_C;
+
+ WBI (" extern const void *__gl_interrupt_states;");
+ WBI (" __gl_interrupt_states = local_interrupt_states;");
+
+ WBI (" extern int __gl_num_interrupt_states;");
+ Set_String (" __gl_num_interrupt_states = ");
+ Set_Int (IS_Pragma_Settings.Last + 1);
+ Set_String (";");
Write_Statement_Buffer;
- Set_String (" ");
- Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
- Set_String (",");
- Tab_To (20);
- Set_String ("/* Unreserve_All_Interrupts */");
+ WBI (" extern const void *__gl_priority_specific_dispatching;");
+ WBI (" __gl_priority_specific_dispatching =" &
+ " local_priority_specific_dispatching;");
+
+ WBI (" extern int __gl_num_specific_dispatching;");
+ Set_String (" __gl_num_specific_dispatching = ");
+ Set_Int (PSD_Pragma_Settings.Last + 1);
+ Set_String (";");
Write_Statement_Buffer;
- Set_String (" ");
- Set_Int (Boolean'Pos (Exception_Tracebacks));
- Set_String (",");
- Tab_To (20);
- Set_String ("/* Exception_Tracebacks */");
+ WBI (" extern int __gl_unreserve_all_interrupts;");
+ Set_String (" __gl_unreserve_all_interrupts = ");
+ Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
+ Set_String (";");
Write_Statement_Buffer;
- Set_String (" ");
+ if Exception_Tracebacks then
+ WBI (" extern int __gl_exception_tracebacks;");
+ WBI (" __gl_exception_tracebacks = 1;");
+ end if;
+
+ WBI (" extern int __gl_zero_cost_exceptions;");
+ Set_String (" __gl_zero_cost_exceptions = ");
Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
- Set_String (");");
- Tab_To (20);
- Set_String ("/* Zero_Cost_Exceptions */");
+ Set_String (";");
+ Write_Statement_Buffer;
+
+ WBI (" extern int __gl_detect_blocking;");
+ Set_String (" __gl_detect_blocking = ");
+
+ if Detect_Blocking then
+ Set_Int (1);
+ else
+ Set_Int (0);
+ end if;
+
+ Set_String (";");
+ Write_Statement_Buffer;
+
+ WBI (" extern int __gl_default_stack_size;");
+ Set_String (" __gl_default_stack_size = ");
+ Set_Int (Default_Stack_Size);
+ Set_String (";");
+ Write_Statement_Buffer;
+
+ WBI (" extern int __gl_leap_seconds_support;");
+ Set_String (" __gl_leap_seconds_support = ");
+
+ if Leap_Seconds_Support then
+ Set_Int (1);
+ else
+ Set_Int (0);
+ end if;
+
+ Set_String (";");
Write_Statement_Buffer;
+ WBI ("");
+
-- Install elaboration time signal handler
WBI (" if (__gnat_handler_installed == 0)");
WBI (" {");
WBI (" __gnat_install_handler ();");
WBI (" }");
+
+ -- Call feature enable/disable routine
+
+ if OpenVMS_On_Target then
+ WBI (" if (__gnat_features_set == 0)");
+ WBI (" {");
+ WBI (" __gnat_set_features ();");
+ WBI (" }");
+ end if;
+ end if;
+
+ -- Initialize stack limit for the environment task if the stack
+ -- check method is stack limit and stack check is enabled.
+
+ if Stack_Check_Limits_On_Target
+ and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
+ then
+ WBI ("");
+ WBI (" __gnat_initialize_stack_limit ();");
+ end if;
+
+ -- Generate call to set Initialize_Scalar values if needed
+
+ if Initialize_Scalars_Used then
+ WBI ("");
+ Set_String (" system__scalar_values__initialize('");
+ Set_Char (Initialize_Scalars_Mode1);
+ Set_String ("', '");
+ Set_Char (Initialize_Scalars_Mode2);
+ Set_String ("');");
+ Write_Statement_Buffer;
+ end if;
+
+ -- Generate assignment of default secondary stack size if set
+
+ if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
+ WBI ("");
+ Set_String (" system__secondary_stack__");
+ Set_String ("default_secondary_stack_size = ");
+ Set_Int (Opt.Default_Sec_Stack_Size);
+ Set_Char (';');
+ Write_Statement_Buffer;
end if;
+ -- Generate elaboration calls
+
WBI ("");
Gen_Elab_Calls_C;
WBI ("}");
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);
Unum_Spec := Unum;
end if;
+ -- Nothing to do if predefined unit in no run time mode
+
+ if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
+ null;
+
-- Case of no elaboration code
- if U.No_Elab then
+ elsif 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
-- 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
+ if not U.SAL_Interface and then U.Utype = Is_Body
and then Units.Table (Unum_Spec).Set_Elab_Entity
then
Set_String (" E");
Write_Statement_Buffer;
end if;
- -- Here if elaboration code is present. We generate:
+ -- Here if elaboration code is present. If binding a library
+ -- or if there is a non-Ada main subprogram then we generate:
-- if not uname_E then
-- uname'elab_[spec|body];
-- uname_E := True;
-- end if;
+ -- Otherwise, elaboration routines are called unconditionally:
+
+ -- uname'elab_[spec|body];
+ -- uname_E := True;
+
-- 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;
+ elsif not U.SAL_Interface then
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ Set_String (" if not E");
+ Set_Unit_Number (Unum_Spec);
+ Set_String (" then");
+ Write_Statement_Buffer;
+ Set_String (" ");
+ end if;
- Set_String (" ");
+ 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";
+ if VM_Target = CLI_Target and then U.Unit_Kind /= 's' then
+ if Name_Buffer (Name_Len) = 's' then
+ Name_Buffer (Name_Len - 1 .. Name_Len + 12) :=
+ "_pkg'elab_spec";
+ else
+ Name_Buffer (Name_Len - 1 .. Name_Len + 12) :=
+ "_pkg'elab_body";
+ end if;
+
+ Name_Len := Name_Len + 12;
+
else
- Name_Buffer (Name_Len - 1 .. Name_Len + 8) := "'elab_body";
+ 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;
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");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ Set_String (" ");
+ end if;
+
+ Set_String (" E");
Set_Unit_Number (Unum_Spec);
Set_String (" := True;");
Write_Statement_Buffer;
end if;
- WBI (" end if;");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ WBI (" end if;");
+ end if;
end if;
end;
end loop;
-
end Gen_Elab_Calls_Ada;
----------------------
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);
Unum_Spec := Unum;
end if;
+ -- Nothing to do if predefined unit in no run time mode
+
+ if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
+ null;
+
-- Case of no elaboration code
- if U.No_Elab then
+ elsif 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
-- 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
+ if not U.SAL_Interface and then U.Utype = Is_Body
and then Units.Table (Unum_Spec).Set_Elab_Entity
then
Set_String (" ");
Write_Statement_Buffer;
end if;
- -- Here if elaboration code is present. We generate:
+ -- Here if elaboration code is present. If binding a library
+ -- or if there is a non-Ada main subprogram then we generate:
-- if (uname_E == 0) {
-- uname__elab[s|b] ();
-- 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 (");
+ elsif not U.SAL_Interface then
Get_Name_String (U.Uname);
- Set_Unit_Name;
- Set_String ("_E == 0) {");
- Write_Statement_Buffer;
- Set_String (" ");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ Set_String (" if (");
+ Set_Unit_Name;
+ Set_String ("_E == 0) {");
+ Write_Statement_Buffer;
+ Set_String (" ");
+ end if;
+
+ Set_String (" ");
Set_Unit_Name;
Set_String ("___elab");
Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
Write_Statement_Buffer;
if U.Utype /= Is_Spec then
- Set_String (" ");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ Set_String (" ");
+ end if;
+
+ Set_String (" ");
Set_Unit_Name;
Set_String ("_E++;");
Write_Statement_Buffer;
end if;
- WBI (" }");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ WBI (" }");
+ end if;
end if;
end;
end loop;
Set_Unit_Name;
Set_String ("___elab");
Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
- Set_String (" PARAMS ((void));");
+ Set_String (" (void);");
Write_Statement_Buffer;
end if;
procedure Gen_Elab_Order_Ada is
begin
WBI ("");
- WBI (" -- BEGIN ELABORATION ORDER");
+ 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_String (" -- ");
+ Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
Set_Name_Buffer;
Write_Statement_Buffer;
end loop;
- WBI (" -- END ELABORATION ORDER");
+ WBI (" -- END ELABORATION ORDER");
end Gen_Elab_Order_Ada;
----------------------
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);
+ Get_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;
+ ------------------
+ -- Gen_Main_Ada --
+ ------------------
+ procedure Gen_Main_Ada is
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;
+ WBI ("");
- if Num = 0 then
+ if Exit_Status_Supported_On_Target then
+ Set_String (" function ");
+ else
+ Set_String (" procedure ");
+ end if;
- -- Happens with "gnatmake -a -f -gnatL ..."
+ Set_String (Get_Main_Name);
- 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);");
+ if Command_Line_Args_On_Target then
Write_Statement_Buffer;
+ WBI (" (argc : Integer;");
+ WBI (" argv : System.Address;");
+ WBI (" envp : System.Address)");
- 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;
+ if Exit_Status_Supported_On_Target then
+ WBI (" return Integer");
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;
+ WBI (" is");
+ else
+ if Exit_Status_Supported_On_Target then
+ Set_String (" return Integer is");
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
+ Set_String (" is");
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/"
- or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/";
-
- begin
- WBI ("");
- Set_String (" function ");
- Set_String (Get_Main_Name);
-
- if VxWorks_Target then
- Set_String (" return Integer is");
Write_Statement_Buffer;
+ end if;
- else
- Write_Statement_Buffer;
- WBI (" (argc : Integer;");
- WBI (" argv : System.Address;");
- WBI (" envp : System.Address)");
- WBI (" return Integer");
- WBI (" is");
+ if Opt.Default_Exit_Status /= 0
+ and then Bind_Main_Program
+ and then not Configurable_Run_Time_Mode
+ then
+ WBI (" procedure Set_Exit_Status (Status : Integer);");
+ WBI (" pragma Import (C, Set_Exit_Status, " &
+ """__gnat_set_exit_status"");");
+ WBI ("");
end if;
- -- Initialize and Finalize are not used in No_Run_Time mode
+ -- Initialize and Finalize
- if not No_Run_Time_Specified then
- WBI (" procedure initialize;");
+ if not Cumulative_Restrictions.Set (No_Finalization) then
+ WBI (" procedure initialize (Addr : System.Address);");
WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
WBI ("");
WBI (" procedure finalize;");
WBI (" pragma Import (C, finalize, ""__gnat_finalize"");");
+ end if;
+
+ -- If we want to analyze the stack, we have to import corresponding
+ -- symbols
+
+ if Dynamic_Stack_Measurement then
+ WBI ("");
+ WBI (" procedure Output_Results;");
+ WBI (" pragma Import (C, Output_Results, " &
+ """__gnat_stack_usage_output_results"");");
+
WBI ("");
+ WBI (" " &
+ "procedure Initialize_Stack_Analysis (Buffer_Size : Natural);");
+ WBI (" pragma Import (C, Initialize_Stack_Analysis, " &
+ """__gnat_stack_usage_initialize"");");
end if;
-- Deal with declarations for main program case
Write_Statement_Buffer;
WBI ("");
+
+ if Bind_Main_Program
+ and then not Suppress_Standard_Library_On_Target
+ then
+ WBI (" SEH : aliased array (1 .. 2) of Integer;");
+ WBI ("");
+ end if;
end if;
-- Generate a reference to Ada_Main_Program_Name. This symbol is
-- The reference stops Ada_Main_Program_Name from being optimized
-- away by smart linkers, such as the AiX linker.
+ -- Because this variable is unused, we make this variable "aliased"
+ -- with a pragma Volatile in order to tell the compiler to preserve
+ -- this variable at any level of optimization.
+
if Bind_Main_Program then
WBI
- (" Ensure_Reference : System.Address := " &
+ (" Ensure_Reference : aliased System.Address := " &
"Ada_Main_Program_Name'Address;");
+ WBI (" pragma Volatile (Ensure_Reference);");
WBI ("");
end if;
WBI (" begin");
- -- On VxWorks, there are no command line arguments
+ -- Acquire command line arguments if present on target
+
+ if Command_Line_Args_On_Target then
+ WBI (" gnat_argc := argc;");
+ WBI (" gnat_argv := argv;");
+ WBI (" gnat_envp := envp;");
+ WBI ("");
+
+ -- If configurable run time and no command line args, then nothing
+ -- needs to be done since the gnat_argc/argv/envp variables are
+ -- suppressed in this case.
+
+ elsif Configurable_Run_Time_On_Target then
+ null;
+
+ -- Otherwise set dummy values (to be filled in by some other unit?)
- if VxWorks_Target then
+ else
WBI (" gnat_argc := 0;");
WBI (" gnat_argv := System.Null_Address;");
WBI (" gnat_envp := System.Null_Address;");
+ end if;
- -- Normal case of command line arguments present
+ if Opt.Default_Exit_Status /= 0
+ and then Bind_Main_Program
+ and then not Configurable_Run_Time_Mode
+ then
+ Set_String (" Set_Exit_Status (");
+ Set_Int (Opt.Default_Exit_Status);
+ Set_String (");");
+ Write_Statement_Buffer;
+ end if;
- else
- WBI (" gnat_argc := argc;");
- WBI (" gnat_argv := argv;");
- WBI (" gnat_envp := envp;");
- WBI ("");
+ if Dynamic_Stack_Measurement then
+ Set_String (" Initialize_Stack_Analysis (");
+ Set_Int (Dynamic_Stack_Measurement_Array_Size);
+ Set_String (");");
+ Write_Statement_Buffer;
end if;
- if not No_Run_Time_Specified then
- WBI (" Initialize;");
+ if not Cumulative_Restrictions.Set (No_Finalization) then
+ if not No_Main_Subprogram
+ and then Bind_Main_Program
+ and then not Suppress_Standard_Library_On_Target
+ then
+ WBI (" Initialize (SEH'Address);");
+ else
+ WBI (" Initialize (System.Null_Address);");
+ end if;
end if;
WBI (" " & Ada_Init_Name.all & ";");
end if;
end if;
- -- Adafinal is only called if we have a run time
+ -- Adafinal call is skipped if no finalization
- if not No_Run_Time_Specified then
+ if not Cumulative_Restrictions.Set (No_Finalization) 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
+ if VM_Target = No_VM then
WBI (" Do_Finalize;");
+ else
+ WBI (" System.Standard_Library.Adafinal;");
end if;
end if;
+ -- Prints the result of static stack analysis
+
+ if Dynamic_Stack_Measurement then
+ WBI (" Output_Results;");
+ end if;
+
-- Finalize is only called if we have a run time
- if not No_Run_Time_Specified then
+ if not Cumulative_Restrictions.Set (No_Finalization) 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);");
+ if Exit_Status_Supported_On_Target then
+ 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;
end if;
WBI (" end;");
----------------
procedure Gen_Main_C is
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/"
- or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/";
-
begin
- Set_String ("int ");
+ if Exit_Status_Supported_On_Target then
+ WBI ("#include <stdlib.h>");
+ Set_String ("int ");
+ else
+ Set_String ("void ");
+ end if;
+
Set_String (Get_Main_Name);
- -- On VxWorks, there are no command line arguments
+ -- Generate command line args in prototype if present on target
- if VxWorks_Target then
- Set_String (" ()");
+ if Command_Line_Args_On_Target then
+ Write_Statement_Buffer (" (int argc, char **argv, char **envp)");
- -- Normal case with command line arguments present
+ -- Case of no command line arguments on target
else
- Set_String (" (argc, argv, envp)");
+ Write_Statement_Buffer (" (void)");
end if;
- Write_Statement_Buffer;
+ WBI ("{");
- -- VxWorks doesn't have the notion of argc/argv
+ -- Generate a reference to __gnat_ada_main_program_name. This symbol
+ -- is not referenced elsewhere in the generated program, but is
+ -- needed by the debugger (that's why it is generated in the first
+ -- place). The reference stops Ada_Main_Program_Name from being
+ -- optimized away by smart linkers, such as the AiX linker.
- if VxWorks_Target then
- WBI ("{");
- WBI (" int result;");
- WBI (" gnat_argc = 0;");
- WBI (" gnat_argv = 0;");
- WBI (" gnat_envp = 0;");
+ -- Because this variable is unused, we declare this variable as
+ -- volatile in order to tell the compiler to preserve it at any
+ -- level of optimization.
- -- Normal case of arguments present
+ if Bind_Main_Program then
+ WBI (" char * volatile ensure_reference " &
+ "__attribute__ ((__unused__)) = " &
+ "__gnat_ada_main_program_name;");
+ WBI ("");
- else
- WBI (" int argc;");
- WBI (" char **argv;");
- WBI (" char **envp;");
- WBI ("{");
-
- -- Generate a reference to __gnat_ada_main_program_name. This symbol
- -- is not referenced elsewhere in the generated program, but is
- -- needed by the debugger (that's why it is generated in the first
- -- place). The reference stops Ada_Main_Program_Name from being
- -- optimized away by smart linkers, such as the AiX linker.
-
- if Bind_Main_Program then
- WBI (" char *ensure_reference = __gnat_ada_main_program_name;");
+ if not Suppress_Standard_Library_On_Target
+ and then not No_Main_Subprogram
+ then
+ WBI (" int SEH [2];");
WBI ("");
end if;
+ end if;
- if ALIs.Table (ALIs.First).Main_Program = Func then
- WBI (" int result;");
- end if;
+ -- If main program is a function, generate result variable
+
+ if ALIs.Table (ALIs.First).Main_Program = Func then
+ WBI (" int result;");
+ end if;
+ -- Set command line argument values from parameters if command line
+ -- arguments are present on target
+
+ if Command_Line_Args_On_Target then
WBI (" gnat_argc = argc;");
WBI (" gnat_argv = argv;");
WBI (" gnat_envp = envp;");
WBI (" ");
+
+ -- If configurable run-time, then nothing to do, since in this case
+ -- the gnat_argc/argv/envp variables are entirely suppressed.
+
+ elsif Configurable_Run_Time_On_Target then
+ null;
+
+ -- if no command line arguments on target, set dummy values
+
+ else
+ WBI (" gnat_argc = 0;");
+ WBI (" gnat_argv = 0;");
+ WBI (" gnat_envp = 0;");
+ end if;
+
+ if Opt.Default_Exit_Status /= 0
+ and then Bind_Main_Program
+ and then not Configurable_Run_Time_Mode
+ then
+ Set_String (" __gnat_set_exit_status (");
+ Set_Int (Opt.Default_Exit_Status);
+ Set_String (");");
+ Write_Statement_Buffer;
+ end if;
+
+ -- Initializes dynamic stack measurement if needed
+
+ if Dynamic_Stack_Measurement then
+ Set_String (" __gnat_stack_usage_initialize (");
+ Set_Int (Dynamic_Stack_Measurement_Array_Size);
+ Set_String (");");
+ Write_Statement_Buffer;
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 ();");
+ if not Suppress_Standard_Library_On_Target then
+ if not No_Main_Subprogram and then Bind_Main_Program then
+ WBI (" __gnat_initialize ((void *)SEH);");
+ else
+ WBI (" __gnat_initialize ((void *)0);");
+ end if;
end if;
WBI (" " & Ada_Init_Name.all & " ();");
if not No_Main_Subprogram then
-
WBI (" __gnat_break_start ();");
WBI (" ");
end if;
- -- Adafinal is called only when we have a run-time
+ -- Call adafinal if finalization active
- if not No_Run_Time_Specified then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI (" ");
WBI (" system__standard_library__adafinal ();");
end if;
+ -- Outputs the dynamic stack measurement if needed
+
+ if Dynamic_Stack_Measurement then
+ WBI (" __gnat_stack_usage_output_results ();");
+ end if;
+
-- The finalize routine is used only if we have a run-time
- if not No_Run_Time_Specified then
+ if not Suppress_Standard_Library_On_Target then
WBI (" __gnat_finalize ();");
end if;
- if ALIs.Table (ALIs.First).Main_Program = Func then
-
- if Hostparm.OpenVMS then
+ -- Case of main program is a function, so the value it returns
+ -- is the exit status in this case.
- -- VMS must use the Posix exit routine in order to get an
- -- Unix compatible exit status.
+ if ALIs.Table (ALIs.First).Main_Program = Func then
+ if Exit_Status_Supported_On_Target then
- WBI (" __posix_exit (result);");
+ -- VMS must use Posix exit routine in order to get the effect
+ -- of a Unix compatible setting of the program exit status.
+ -- For all other systems, we use the standard exit routine.
- else
- WBI (" exit (result);");
+ if OpenVMS_On_Target then
+ WBI (" decc$__posix_exit (result);");
+ else
+ WBI (" exit (result);");
+ end if;
end if;
+ -- Case of main program is a procedure, in which case the exit
+ -- status is whatever was set by a Set_Exit call most recently
+
else
+ if Exit_Status_Supported_On_Target then
- 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);");
+ -- VMS must use Posix exit routine in order to get the effect
+ -- of a Unix compatible setting of the program exit status.
+ -- For all other systems, we use the standard exit routine.
+
+ if OpenVMS_On_Target then
+ WBI (" decc$__posix_exit (gnat_exit_status);");
+ else
+ WBI (" exit (gnat_exit_status);");
+ end if;
end if;
end if;
-- in the Linker_Options table of where the first entry from an
-- internal file appears.
+ Linker_Option_List_Started : Boolean := False;
+ -- Set to True when "LINKER OPTION LIST" is displayed
+
procedure Write_Linker_Option;
- -- Write binder info linker option.
+ -- Write binder info linker option
-------------------------
-- Write_Linker_Option --
-- Process section if non-null
if Stop > Start then
- if Output_Linker_Option_List then
- Write_Str (Name_Buffer (Start .. Stop - 1));
- Write_Eol;
+ if Output_Linker_Option_List then
+ if not Zero_Formatting then
+ if not Linker_Option_List_Started then
+ Linker_Option_List_Started := True;
+ Write_Eol;
+ Write_Str (" LINKER OPTION LIST");
+ Write_Eol;
+ Write_Eol;
+ end if;
+
+ Write_Str (" ");
end if;
- Write_Info_Ada_C
- (" -- ", "", Name_Buffer (Start .. Stop - 1));
+
+ 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;
begin
WBI ("");
- Write_Info_Ada_C ("--", "/*", " BEGIN Object file/option list");
+ 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
+ if (not Units.Table (Elab_Order.Table (E)).SAL_Interface)
+ and then 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 not Hostparm.Exclude_Missing_Objects
or else
- GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
+ System.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;
-- filename object is seen. Multiply defined symbols will
-- result.
- if Hostparm.OpenVMS
+ if OpenVMS_On_Target
and then Is_Internal_File_Name
(ALIs.Table
(Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
then
- Opt.Shared_Libgnat := False;
- end if;
+ -- Special case for g-trasym.obj, which is not included
+ -- in libgnat.
+
+ Get_Name_String (ALIs.Table
+ (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile);
+ if Name_Buffer (1 .. 8) /= "g-trasym" then
+ Opt.Shared_Libgnat := False;
+ end if;
+ 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
+ -- Add a "-Ldir" for each directory in the object path
- 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;
+ for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
+ declare
+ Dir : constant 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;
-- Sort linker options
-- files. The reason for this decision is that libraries referenced
-- by internal routines may reference these standard library entries.
- if not (No_Run_Time_Specified or else Opt.No_Stdlib) then
+ -- Note that we do not insert anything when pragma No_Run_Time has been
+ -- specified or when the standard libraries are not to be used,
+ -- otherwise on some platforms, such as VMS, we may get duplicate
+ -- symbols when linking.
+
+ if not (Opt.No_Run_Time_Mode or else Opt.No_Stdlib) then
Name_Len := 0;
if Opt.Shared_Libgnat then
if With_DECGNAT then
Name_Len := 0;
- Add_Str_To_Name_Buffer ("-ldecgnat");
+
+ if Opt.Shared_Libgnat then
+ Add_Str_To_Name_Buffer (Shared_Lib ("decgnat"));
+ else
+ Add_Str_To_Name_Buffer ("-ldecgnat");
+ end if;
+
Write_Linker_Option;
end if;
if With_GNARL then
Name_Len := 0;
- Add_Str_To_Name_Buffer ("-lgnarl");
+
+ if Opt.Shared_Libgnat then
+ Add_Str_To_Name_Buffer (Shared_Lib ("gnarl"));
+ else
+ Add_Str_To_Name_Buffer ("-lgnarl");
+ end if;
+
Write_Linker_Option;
end if;
Name_Len := 0;
- Add_Str_To_Name_Buffer ("-lgnat");
+
+ if Opt.Shared_Libgnat then
+ Add_Str_To_Name_Buffer (Shared_Lib ("gnat"));
+ else
+ Add_Str_To_Name_Buffer ("-lgnat");
+ end if;
+
Write_Linker_Option;
end if;
Write_Linker_Option;
end loop;
+ if Output_Linker_Option_List and then not Zero_Formatting then
+ Write_Eol;
+ end if;
+
if Ada_Bind_File then
- WBI ("-- END Object file/option list ");
+ WBI ("-- END Object file/option list ");
else
- WBI (" END Object file/option list */");
+ WBI (" END Object file/option list */");
end if;
-
end Gen_Object_Files_Options;
---------------------
---------------------
procedure Gen_Output_File (Filename : String) is
- Public_Version : constant Boolean := Gnat_Version_Type = "PUBLIC ";
- -- Set true if this is the public version of GNAT
-
begin
- -- Override Ada_Bind_File and Bind_Main_Program for Java since
+ -- Acquire settings for Interrupt_State pragmas
+
+ Set_IS_Pragma_Table;
+
+ -- Acquire settings for Priority_Specific_Dispatching pragma
+
+ Set_PSD_Pragma_Table;
+
+ -- Override Ada_Bind_File and Bind_Main_Program for VMs since
-- JGNAT only supports Ada code, and the main program is already
-- generated by the compiler.
- if Hostparm.Java_VM then
+ if VM_Target /= No_VM then
Ada_Bind_File := True;
- Bind_Main_Program := False;
+
+ if VM_Target = JVM_Target then
+ Bind_Main_Program := False;
+ end if;
end if;
-- Override time slice value if -T switch is set
end if;
end loop;
- -- Get the time stamp of the former bind for public version warning
-
- if Public_Version then
- Record_Time_From_Last_Bind;
- end if;
-
-- Generate output file in appropriate language
+ Check_System_Restrictions_Used;
+
if Ada_Bind_File then
Gen_Output_File_Ada (Filename);
else
Gen_Output_File_C (Filename);
end if;
-
- -- Periodically issue a warning when the public version is used on
- -- big projects
-
- if Public_Version then
- Public_Version_Warning;
- end if;
end Gen_Output_File;
-------------------------
-- 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/"
- or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/";
-
begin
-- Create spec first
Create_Binder_Output (Filename, 's', Bfiles);
- if No_Run_Time_Specified then
+ -- We always compile the binder file in Ada 95 mode so that we properly
+ -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
+ -- of the Ada 2005 constructs are needed by the binder file.
+
+ WBI ("pragma Ada_95;");
+
+ -- If we are operating in Restrictions (No_Exception_Handlers) mode,
+ -- then we need to make sure that the binder program is compiled with
+ -- the same restriction, so that no exception tables are generated.
+
+ if Cumulative_Restrictions.Set (No_Exception_Handlers) then
+ WBI ("pragma Restrictions (No_Exception_Handlers);");
+ end if;
+
+ -- Same processing for Restrictions (No_Exception_Propagation)
+
+ if Cumulative_Restrictions.Set (No_Exception_Propagation) then
+ WBI ("pragma Restrictions (No_Exception_Propagation);");
+ end if;
+
+ -- Same processing for pragma No_Run_Time
+
+ if No_Run_Time_Mode 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.
+ -- Generate with of System so we can reference System.Address
WBI ("with System;");
WBI ("with System.Scalar_Values;");
end if;
+ -- Generate with of System.Secondary_Stack if active
+
+ if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
+ WBI ("with System.Secondary_Stack;");
+ end if;
+
Resolve_Binder_Options;
- if not No_Run_Time_Specified then
+ if VM_Target /= No_VM then
+ if not Suppress_Standard_Library_On_Target 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.
+ -- 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");
+ WBI (" pragma Warnings (Off);");
-- Main program case
if Bind_Main_Program then
+ if VM_Target = No_VM then
- -- Generate argc/argv stuff
+ -- Generate argc/argv stuff unless suppressed
- WBI ("");
- WBI (" gnat_argc : Integer;");
- WBI (" gnat_argv : System.Address;");
- WBI (" gnat_envp : System.Address;");
+ if Command_Line_Args_On_Target
+ or not Configurable_Run_Time_On_Target
+ then
+ WBI ("");
+ WBI (" gnat_argc : Integer;");
+ WBI (" gnat_argv : System.Address;");
+ WBI (" gnat_envp : System.Address;");
+
+ -- If the standard library is not suppressed, these variables
+ -- are in the runtime data area for easy access from the
+ -- runtime
+
+ if not Suppress_Standard_Library_On_Target then
+ WBI ("");
+ WBI (" pragma Import (C, gnat_argc);");
+ WBI (" pragma Import (C, gnat_argv);");
+ WBI (" pragma Import (C, gnat_envp);");
+ end if;
+ end if;
- -- If we have a run time present, these variables are in the
- -- runtime data area for easy access from the runtime
+ -- Define exit status. Again in normal mode, this is in the
+ -- run-time library, and is initialized there, but in the
+ -- configurable runtime case, the variable is declared and
+ -- initialized in this file.
- 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 Configurable_Run_Time_Mode then
+ if Exit_Status_Supported_On_Target then
+ WBI (" gnat_exit_status : Integer := 0;");
+ end if;
- 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);");
+ else
+ WBI (" gnat_exit_status : Integer;");
+ WBI (" pragma Import (C, gnat_exit_status);");
+ end if;
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)
+ -- 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 two Ada libraries). Also zero terminate the string
+ -- so that its end can be found reliably at run time.
- if Bind_Main_Program then
WBI ("");
WBI (" GNAT_Version : constant String :=");
WBI (" ""GNAT Version: " &
- Gnat_Version_String & """;");
+ Gnat_Version_String &
+ """ & ASCII.NUL;");
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;");
+
+ if VM_Target = No_VM then
+ Set_Main_Program_Name;
+ Set_String (""" & ASCII.NUL;");
+ else
+ Set_String (Name_Buffer (1 .. Name_Len - 2) & """;");
+ end if;
+
Write_Statement_Buffer;
WBI
"""__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_Final_Name.all & ";");
+ WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
+ Ada_Final_Name.all & """);");
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 -a has been specified use pragma Linker_Constructor for the init
+ -- procedure. No need to use a similar pragma for the final procedure as
+ -- global finalization will occur when the executable finishes execution
+ -- and for plugins (shared stand-alone libraries that can be
+ -- "unloaded"), finalization should not occur automatically, otherwise
+ -- the main executable may not continue to work properly.
+
+ if Use_Pragma_Linker_Constructor then
+ WBI (" pragma Linker_Constructor (" & Ada_Init_Name.all & ");");
+ end if;
+
+ if Bind_Main_Program and then VM_Target = No_VM 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.
+ -- If we have the standard library, then Break_Start is defined
+ -- there, but when the standard library is suppressed, Break_Start
+ -- is defined here.
WBI ("");
WBI (" procedure Break_Start;");
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target 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 Exit_Status_Supported_On_Target then
+ Set_String (" function ");
+ else
+ Set_String (" procedure ");
+ end if;
+
+ Set_String (Get_Main_Name);
+
+ -- Generate argument list if present
- if not VxWorks_Target then
+ if Command_Line_Args_On_Target then
+ Write_Statement_Buffer;
WBI (" (argc : Integer;");
WBI (" argv : System.Address;");
- WBI (" envp : System.Address)");
+ Set_String
+ (" envp : System.Address)");
+
+ if Exit_Status_Supported_On_Target then
+ Write_Statement_Buffer;
+ WBI (" return Integer;");
+ else
+ Write_Statement_Buffer (";");
+ end if;
+
+ else
+ if Exit_Status_Supported_On_Target then
+ Write_Statement_Buffer (" return Integer;");
+ else
+ Write_Statement_Buffer (";");
+ end if;
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;
Create_Binder_Output (Filename, 'b', Bfileb);
+ -- We always compile the binder file in Ada 95 mode so that we properly
+ -- handle use of Ada 2005 keywords as identifiers in Ada 95 mode. None
+ -- of the Ada 2005 constructs are needed by the binder file.
+
+ WBI ("pragma Ada_95;");
+
-- Output Source_File_Name pragmas which look like
-- pragma Source_File_Name (Ada_Main, Spec_File_Name => "sss");
", Body_File_Name => """ &
Name_Buffer (1 .. Name_Len + 3));
+ -- Generate with of System.Restrictions to initialize
+ -- Run_Time_Restrictions.
+
+ if System_Restrictions_Used
+ and not Suppress_Standard_Library_On_Target
+ then
+ WBI ("");
+ WBI ("with System.Restrictions;");
+ end if;
+
WBI ("");
WBI ("package body " & Ada_Main & " is");
+ WBI (" pragma Warnings (Off);");
- -- Import the finalization procedure only if there is a runtime.
+ -- Import the finalization procedure only if finalization active
- if not No_Run_Time_Specified then
+ if not Cumulative_Restrictions.Set (No_Finalization) 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
+ if VM_Target = No_VM then
WBI ("");
WBI (" procedure Do_Finalize;");
WBI
end if;
end if;
- Gen_Adainit_Ada;
+ if not Suppress_Standard_Library_On_Target then
+
+ -- Generate Priority_Specific_Dispatching pragma string
+
+ Set_String
+ (" Local_Priority_Specific_Dispatching : constant String := """);
+
+ for J in 0 .. PSD_Pragma_Settings.Last loop
+ Set_Char (PSD_Pragma_Settings.Table (J));
+ end loop;
- -- No need to generate a finalization routine if there is no
- -- runtime, since there is nothing to do in this case.
+ Set_String (""";");
+ Write_Statement_Buffer;
+
+ -- Generate Interrupt_State pragma string
+
+ Set_String (" Local_Interrupt_States : constant String := """);
- if not No_Run_Time_Specified then
- Gen_Adafinal_Ada;
+ for J in 0 .. IS_Pragma_Settings.Last loop
+ Set_Char (IS_Pragma_Settings.Table (J));
+ end loop;
+
+ Set_String (""";");
+ Write_Statement_Buffer;
+ WBI ("");
end if;
- if Bind_Main_Program then
+ Gen_Adainit_Ada;
+
+ Gen_Adafinal_Ada;
- -- In No_Run_Time mode, generate dummy body for Break_Start
+ if Bind_Main_Program and then VM_Target = No_VM then
- if No_Run_Time_Specified then
+ -- When suppressing the standard library then generate dummy body
+ -- for Break_Start
+
+ if Suppress_Standard_Library_On_Target then
WBI ("");
WBI (" procedure Break_Start is");
WBI (" begin");
-----------------------
procedure Gen_Output_File_C (Filename : String) is
-
Bfile : Name_Id;
- -- Name of generated bind file
+ pragma Warnings (Off, Bfile);
+ -- Name of generated bind file (not referenced)
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 " & Ada_Final_Name.all & " (void);");
+
+ -- If -a has been specified use __attribute__((constructor)) for the
+ -- init procedure. No need to use a similar featute for the final
+ -- procedure as global finalization will occur when the executable
+ -- finishes execution and for plugins (shared stand-alone libraries that
+ -- can be "unloaded"), finalization should not occur automatically,
+ -- otherwise the main executable may not continue to work properly.
- WBI ("extern void __gnat_set_globals ");
- WBI (" PARAMS ((int, int, int, int, int, int, const char *,");
- WBI (" int, int, int));");
- WBI ("extern void " & Ada_Final_Name.all & " PARAMS ((void));");
- WBI ("extern void " & Ada_Init_Name.all & " PARAMS ((void));");
+ if Use_Pragma_Linker_Constructor then
+ WBI ("extern void " & Ada_Init_Name.all &
+ " (void) __attribute__((constructor));");
+ else
+ WBI ("extern void " & Ada_Init_Name.all & " (void);");
+ end if;
- WBI ("extern void system__standard_library__adafinal PARAMS ((void));");
+ WBI ("extern void system__standard_library__adafinal (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));");
+ Set_String ("extern ");
+
+ if Exit_Status_Supported_On_Target then
+ Set_String ("int");
+ else
+ Set_String ("void");
+ end if;
+
+ Set_String (" main ");
+
+ if Command_Line_Args_On_Target then
+ Write_Statement_Buffer ("(int, char **, char **);");
else
- WBI ("extern void exit PARAMS ((int));");
+ Write_Statement_Buffer ("(void);");
end if;
- WBI ("extern void __gnat_break_start PARAMS ((void));");
+ if OpenVMS_On_Target then
+ WBI ("extern void decc$__posix_exit (int);");
+ else
+ WBI ("extern void exit (int);");
+ end if;
+
+ WBI ("extern void __gnat_break_start (void);");
Set_String ("extern ");
if ALIs.Table (ALIs.First).Main_Program = Proc then
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
Set_Main_Program_Name;
- Set_String (" PARAMS ((void));");
+ Set_String (" (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));");
+ if not Suppress_Standard_Library_On_Target then
+ WBI ("extern void __gnat_initialize (void *);");
+ WBI ("extern void __gnat_finalize (void);");
+ WBI ("extern void __gnat_install_handler (void);");
+ end if;
+
+ if Dynamic_Stack_Measurement then
+ WBI ("");
+ WBI ("extern void __gnat_stack_usage_output_results (void);");
+ WBI ("extern void __gnat_stack_usage_initialize (int size);");
+ end if;
+
+ -- Initialize stack limit for the environment task if the stack
+ -- check method is stack limit and stack check is enabled.
+
+ if Stack_Check_Limits_On_Target
+ and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
+ then
+ WBI ("");
+ WBI ("extern void __gnat_initialize_stack_limit (void);");
end if;
WBI ("");
Gen_Elab_Defs_C;
- -- Imported variable used to track elaboration/finalization phase.
- -- Used only when we have a runtime.
+ -- Imported variables used only when we have a runtime.
+
+ if not Suppress_Standard_Library_On_Target then
+
+ -- Track elaboration/finalization phase.
- if not No_Run_Time_Specified then
WBI ("extern int __gnat_handler_installed;");
WBI ("");
+
+ -- Track feature enable/disable on VMS.
+
+ if OpenVMS_On_Target then
+ WBI ("extern int __gnat_features_set;");
+ WBI ("");
+ end if;
end if;
- -- Write argv/argc stuff if main program case
+ -- Write argv/argc exit status stuff if main program case
if Bind_Main_Program then
- -- In the normal case, these are in the runtime library
+ -- First deal with argc/argv/envp. In the normal case they
+ -- are in the run-time library.
- if not No_Run_Time_Specified then
+ if not Configurable_Run_Time_On_Target 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.
+ -- If configurable run time and no command line args, then the
+ -- generation of these variables is entirely suppressed.
+
+ elsif not Command_Line_Args_On_Target then
+ null;
+
+ -- Otherwise, in the configurable run-time case they are right in
+ -- the binder file.
else
WBI ("int gnat_argc;");
WBI ("char **gnat_argv;");
WBI ("char **gnat_envp;");
+ end if;
+
+ -- Similarly deal with exit status
+ -- are in the run-time library.
+
+ if not Configurable_Run_Time_On_Target then
+ WBI ("extern int gnat_exit_status;");
+
+ -- If configurable run time and no exit status on target, then
+ -- the generation of this variables is entirely suppressed.
+
+ elsif not Exit_Status_Supported_On_Target then
+ null;
+
+ -- Otherwise, in the configurable run-time case this variable is
+ -- right in the binder file, and initialized to zero there.
+
+ else
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.
+ -- When suppressing the standard library, the __gnat_break_start
+ -- routine (for the debugger to get initial control) is defined in
+ -- this file.
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target then
WBI ("");
- WBI ("void __gnat_break_start () {}");
+ WBI ("void __gnat_break_start (void) {}");
end if;
-- Generate the __gnat_version and __gnat_ada_main_program_name info
-- 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
+ if not Cumulative_Restrictions.Set (No_Finalization) then
Gen_Adafinal_C;
end if;
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;
+ -- Generate versions, elaboration order, list of object files
Gen_Versions_C;
Gen_Elab_Order_C;
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.
+ --------------------------
+ -- Gen_Restrictions_Ada --
+ --------------------------
- IS_Ill : String (1 .. 24);
+ procedure Gen_Restrictions_Ada is
+ Count : Integer;
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;
+ if Suppress_Standard_Library_On_Target
+ or not System_Restrictions_Used
+ then
+ return;
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;
+ WBI (" System.Restrictions.Run_Time_Restrictions :=");
+ WBI (" (Set =>");
+ Set_String (" (");
- Write_Statement_Buffer;
- Set_String (" ");
+ Count := 0;
- for J in 7 .. 12 loop
- Set_String (" 16#");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
+ for J in Cumulative_Restrictions.Set'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Set'Last)
+ loop
+ Set_Boolean (Cumulative_Restrictions.Set (J));
+ Set_String (", ");
+ Count := Count + 1;
- if J = 12 then
- Set_String ("#);");
- else
- Set_String ("#,");
- end if;
- end loop;
+ if Count = 8 then
+ Write_Statement_Buffer;
+ Set_String (" ");
+ Count := 0;
+ end if;
+ end loop;
- Write_Statement_Buffer;
+ Set_Boolean
+ (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last));
+ Set_String ("),");
+ Write_Statement_Buffer;
+ Set_String (" Value => (");
- -- Output export statements to export to System.Scalar_Values
+ for J in Cumulative_Restrictions.Value'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Value'Last)
+ loop
+ Set_Int (Int (Cumulative_Restrictions.Value (J)));
+ Set_String (", ");
+ end loop;
- WBI ("");
+ Set_Int (Int (Cumulative_Restrictions.Value
+ (Cumulative_Restrictions.Value'Last)));
+ Set_String ("),");
+ Write_Statement_Buffer;
+ WBI (" Violated =>");
+ Set_String (" (");
+ Count := 0;
+
+ for J in Cumulative_Restrictions.Violated'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Violated'Last)
+ loop
+ Set_Boolean (Cumulative_Restrictions.Violated (J));
+ Set_String (", ");
+ Count := Count + 1;
+
+ if Count = 8 then
+ Write_Statement_Buffer;
+ Set_String (" ");
+ Count := 0;
+ end if;
+ end loop;
- 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
+ Set_Boolean (Cumulative_Restrictions.Violated
+ (Cumulative_Restrictions.Violated'Last));
+ Set_String ("),");
+ Write_Statement_Buffer;
+ Set_String (" Count => (");
- else
- -- The lines we generate in this case are of the form
- -- typ __gnat_I?? = 0x??;
- -- where typ is appropriate to the length
+ for J in Cumulative_Restrictions.Count'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Count'Last)
+ loop
+ Set_Int (Int (Cumulative_Restrictions.Count (J)));
+ Set_String (", ");
+ end loop;
- WBI ("");
+ Set_Int (Int (Cumulative_Restrictions.Count
+ (Cumulative_Restrictions.Count'Last)));
+ Set_String ("),");
+ Write_Statement_Buffer;
+ Set_String (" Unknown => (");
- Set_String ("unsigned char __gnat_Is1 = 0x");
- Set_String (IS_Is1);
- Write_Statement_Buffer (";");
+ for J in Cumulative_Restrictions.Unknown'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Unknown'Last)
+ loop
+ Set_Boolean (Cumulative_Restrictions.Unknown (J));
+ Set_String (", ");
+ end loop;
- Set_String ("unsigned short __gnat_Is2 = 0x");
- Set_String (IS_Is2);
- Write_Statement_Buffer (";");
+ Set_Boolean
+ (Cumulative_Restrictions.Unknown
+ (Cumulative_Restrictions.Unknown'Last));
+ Set_String ("));");
+ Write_Statement_Buffer;
+ end Gen_Restrictions_Ada;
- Set_String ("unsigned __gnat_Is4 = 0x");
- Set_String (IS_Is4);
- Write_Statement_Buffer (";");
+ ------------------------
+ -- Gen_Restrictions_C --
+ ------------------------
- Set_String ("long long unsigned __gnat_Is8 = 0x");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("LL;");
+ procedure Gen_Restrictions_C is
+ begin
+ if Suppress_Standard_Library_On_Target
+ or not System_Restrictions_Used
+ then
+ return;
+ end if;
- Set_String ("unsigned char __gnat_Iu1 = 0x");
- Set_String (IS_Is1);
- Write_Statement_Buffer (";");
+ WBI (" typedef struct {");
+ Set_String (" char set [");
+ Set_Int (Cumulative_Restrictions.Set'Length);
+ Set_String ("];");
+ Write_Statement_Buffer;
- Set_String ("unsigned short __gnat_Iu2 = 0x");
- Set_String (IS_Is2);
- Write_Statement_Buffer (";");
+ Set_String (" int value [");
+ Set_Int (Cumulative_Restrictions.Value'Length);
+ Set_String ("];");
+ Write_Statement_Buffer;
- Set_String ("unsigned __gnat_Iu4 = 0x");
- Set_String (IS_Is4);
- Write_Statement_Buffer (";");
+ Set_String (" char violated [");
+ Set_Int (Cumulative_Restrictions.Violated'Length);
+ Set_String ("];");
+ Write_Statement_Buffer;
- Set_String ("long long unsigned __gnat_Iu8 = 0x");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("LL;");
+ Set_String (" int count [");
+ Set_Int (Cumulative_Restrictions.Count'Length);
+ Set_String ("];");
+ Write_Statement_Buffer;
- Set_String ("unsigned __gnat_Isf = 0x");
- Set_String (IS_Isf);
- Write_Statement_Buffer (";");
+ Set_String (" char unknown [");
+ Set_Int (Cumulative_Restrictions.Unknown'Length);
+ Set_String ("];");
+ Write_Statement_Buffer;
+ WBI (" } restrictions;");
+ WBI (" extern restrictions " &
+ "system__restrictions__run_time_restrictions;");
+ WBI (" restrictions r = {");
+ Set_String (" {");
+
+ for J in Cumulative_Restrictions.Set'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Set'Last)
+ loop
+ Set_Int (Boolean'Pos (Cumulative_Restrictions.Set (J)));
+ Set_String (", ");
+ end loop;
- Set_String ("unsigned __gnat_Ifl = 0x");
- Set_String (IS_Ifl);
- Write_Statement_Buffer (";");
+ Set_Int (Boolean'Pos
+ (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last)));
+ Set_String ("},");
+ Write_Statement_Buffer;
+ Set_String (" {");
- Set_String ("long long unsigned __gnat_Ilf = 0x");
- Set_String (IS_Ilf);
- Write_Statement_Buffer ("LL;");
+ for J in Cumulative_Restrictions.Value'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Value'Last)
+ loop
+ Set_Int (Int (Cumulative_Restrictions.Value (J)));
+ Set_String (", ");
+ end loop;
- -- For Long_Long_Float, we generate
- -- char __gnat_Ill[12] = {0x??, 0x??, 0x??, 0x??, 0x??, 0x??,
- -- 0x??, 0x??, 0x??, 0x??, 0x??, 0x??);
+ Set_Int (Int (Cumulative_Restrictions.Value
+ (Cumulative_Restrictions.Value'Last)));
+ Set_String ("},");
+ Write_Statement_Buffer;
+ Set_String (" {");
- Set_String ("unsigned char __gnat_Ill[12] = {");
+ for J in Cumulative_Restrictions.Violated'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Violated'Last)
+ loop
+ Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated (J)));
+ Set_String (", ");
+ end loop;
- 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;
+ Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated
+ (Cumulative_Restrictions.Violated'Last)));
+ Set_String ("},");
+ Write_Statement_Buffer;
+ Set_String (" {");
- Write_Statement_Buffer;
- Set_String (" ");
+ for J in Cumulative_Restrictions.Count'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Count'Last)
+ loop
+ Set_Int (Int (Cumulative_Restrictions.Count (J)));
+ Set_String (", ");
+ end loop;
- for J in 7 .. 12 loop
- Set_String ("0x");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
+ Set_Int (Int (Cumulative_Restrictions.Count
+ (Cumulative_Restrictions.Count'Last)));
+ Set_String ("},");
+ Write_Statement_Buffer;
+ Set_String (" {");
- if J = 12 then
- Set_String ("};");
- else
- Set_String (", ");
- end if;
- end loop;
+ for J in Cumulative_Restrictions.Unknown'First ..
+ Restriction_Id'Pred (Cumulative_Restrictions.Unknown'Last)
+ loop
+ Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown (J)));
+ Set_String (", ");
+ end loop;
- Write_Statement_Buffer;
- end if;
- end Gen_Scalar_Values;
+ Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown
+ (Cumulative_Restrictions.Unknown'Last)));
+ Set_String ("}};");
+ Write_Statement_Buffer;
+ WBI (" system__restrictions__run_time_restrictions = r;");
+ end Gen_Restrictions_C;
----------------------
-- Gen_Versions_Ada --
-- 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.
+ -- attributes cannot supported in this case.
return;
end if;
-- 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.
+ -- attributes cannot supported.
return;
end if;
end Gen_Versions_C;
+ ------------------------
+ -- Get_Main_Unit_Name --
+ ------------------------
+
+ function Get_Main_Unit_Name (S : String) return String is
+ Result : String := S;
+
+ begin
+ for J in S'Range loop
+ if Result (J) = '.' then
+ Result (J) := '_';
+ end if;
+ end loop;
+
+ return Result;
+ end Get_Main_Unit_Name;
+
-----------------------
-- Get_Ada_Main_Name --
-----------------------
-- The main program generated by JGNAT expects a package called
-- ada_<main procedure>.
- if Hostparm.Java_VM then
- -- Get main program name
-
+ if VM_Target /= No_VM then
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
-
- -- Remove the %b
-
- return "ada_" & Name_Buffer (1 .. Name_Len - 2);
+ return "ada_" & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
end if;
-- This loop tries the following possibilities in order
-------------------
function Get_Main_Name return String is
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/"
- or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/";
-
begin
-- Explicit name given with -M switch
-- Case of main program name to be used directly
- elsif VxWorks_Target then
+ elsif Use_Ada_Main_Program_Name_On_Target then
-- Get main program name
end if;
end Get_Main_Name;
+ ---------------------
+ -- Get_WC_Encoding --
+ ---------------------
+
+ function Get_WC_Encoding return Character is
+ begin
+ -- If encoding method specified by -W switch, then return it
+
+ if Wide_Character_Encoding_Method_Specified then
+ return WC_Encoding_Letters (Wide_Character_Encoding_Method);
+
+ -- If no main program, and not specified, set brackets, we really have
+ -- no better choice. If some other encoding is required when there is
+ -- no main, it must be set explicitly using -Wx.
+
+ -- Note: if the ALI file always passed the wide character encoding
+ -- of every file, then we could use the encoding of the initial
+ -- specified file, but this information is passed only for potential
+ -- main programs. We could fix this sometime, but it is a very minor
+ -- point (wide character default encoding for [Wide_[Wide_]Text_IO
+ -- when there is no main program).
+
+ elsif No_Main_Subprogram then
+ return 'b';
+
+ -- Otherwise if there is a main program, take encoding from it
+
+ else
+ return ALIs.Table (ALIs.First).WC_Encoding;
+ end if;
+ end Get_WC_Encoding;
+
----------------------
-- Lt_Linker_Option --
----------------------
end Move_Linker_Option;
----------------------------
- -- Public_Version_Warning --
- ----------------------------
-
- procedure Public_Version_Warning is
-
- Time : Int := Time_From_Last_Bind;
-
- -- Constants to help defining periods
-
- Hour : constant := 60;
- Day : constant := 24 * Hour;
-
- Never : constant := Integer'Last;
- -- Special value indicating no warnings should be given
-
- -- Constants defining when the warning is issued. Programs with more
- -- than Large Units will issue a warning every Period_Large amount of
- -- time. Smaller programs will generate a warning every Period_Small
- -- amount of time.
-
- Large : constant := 20;
- -- Threshold for considering a program small or large
-
- Period_Large : constant := Day;
- -- Periodic warning time for large programs
-
- Period_Small : constant := Never;
- -- Periodic warning time for small programs
-
- Nb_Unit : Int;
-
- begin
- -- Compute the number of units that are not GNAT internal files
-
- Nb_Unit := 0;
- for A in ALIs.First .. ALIs.Last loop
- if not Is_Internal_File_Name (ALIs.Table (A).Sfile) then
- Nb_Unit := Nb_Unit + 1;
- end if;
- end loop;
-
- -- Do not emit the message if the last message was emitted in the
- -- specified period taking into account the number of units.
-
- if Nb_Unit < Large and then Time <= Period_Small then
- return;
-
- elsif Time <= Period_Large then
- return;
- end if;
-
- Write_Eol;
- Write_Str ("IMPORTANT NOTICE:");
- Write_Eol;
- Write_Str (" This version of GNAT is unsupported"
- & " and comes with absolutely no warranty.");
- Write_Eol;
- Write_Str (" If you intend to evaluate or use GNAT for building "
- & "commercial applications,");
- Write_Eol;
- Write_Str (" please consult http://www.gnat.com/ for information");
- Write_Eol;
- Write_Str (" on the GNAT Professional product line.");
- Write_Eol;
- Write_Eol;
- end Public_Version_Warning;
-
- ----------------------------
-- Resolve_Binder_Options --
----------------------------
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.
+ -- This is not a perfect approach, but is the current protocol
+ -- between the run-time and the binder to indicate that tasking
+ -- is used: system.os_interface should always be used by any
+ -- tasking application.
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
+ -- Ditto for declib and the "dec" package
+
+ if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then
With_DECGNAT := True;
end if;
end loop;
end Resolve_Binder_Options;
+ -----------------
+ -- Set_Boolean --
+ -----------------
+
+ procedure Set_Boolean (B : Boolean) is
+ True_Str : constant String := "True";
+ False_Str : constant String := "False";
+ begin
+ if B then
+ Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str;
+ Last := Last + True_Str'Length;
+ else
+ Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str;
+ Last := Last + False_Str'Length;
+ end if;
+ end Set_Boolean;
+
--------------
-- Set_Char --
--------------
end if;
end Set_Int;
+ -------------------------
+ -- Set_IS_Pragma_Table --
+ -------------------------
+
+ procedure Set_IS_Pragma_Table is
+ begin
+ for F in ALIs.First .. ALIs.Last loop
+ for K in ALIs.Table (F).First_Interrupt_State ..
+ ALIs.Table (F).Last_Interrupt_State
+ loop
+ declare
+ Inum : constant Int :=
+ Interrupt_States.Table (K).Interrupt_Id;
+ Stat : constant Character :=
+ Interrupt_States.Table (K).Interrupt_State;
+
+ begin
+ while IS_Pragma_Settings.Last < Inum loop
+ IS_Pragma_Settings.Append ('n');
+ end loop;
+
+ IS_Pragma_Settings.Table (Inum) := Stat;
+ end;
+ end loop;
+ end loop;
+ end Set_IS_Pragma_Table;
+
---------------------------
-- Set_Main_Program_Name --
---------------------------
end loop;
end Set_Name_Buffer;
+ -------------------------
+ -- Set_PSD_Pragma_Table --
+ -------------------------
+
+ procedure Set_PSD_Pragma_Table is
+ begin
+ for F in ALIs.First .. ALIs.Last loop
+ for K in ALIs.Table (F).First_Specific_Dispatching ..
+ ALIs.Table (F).Last_Specific_Dispatching
+ loop
+ declare
+ DTK : Specific_Dispatching_Record
+ renames Specific_Dispatching.Table (K);
+
+ begin
+ while PSD_Pragma_Settings.Last < DTK.Last_Priority loop
+ PSD_Pragma_Settings.Append ('F');
+ end loop;
+
+ for Prio in DTK.First_Priority .. DTK.Last_Priority loop
+ PSD_Pragma_Settings.Table (Prio) := DTK.Dispatching_Policy;
+ end loop;
+ end;
+ end loop;
+ end loop;
+ end Set_PSD_Pragma_Table;
+
----------------
-- Set_String --
----------------
---------------------
procedure Set_Unit_Number (U : Unit_Id) is
- Num_Units : constant Nat := Nat (Units.Table'Last) - Nat (Unit_Id'First);
+ Num_Units : constant Nat := Nat (Units.Last) - Nat (Unit_Id'First);
Unum : constant Nat := Nat (U) - Nat (Unit_Id'First);
begin
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;
-
----------------------
-- Write_Info_Ada_C --
----------------------
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;
else
declare
S : String (1 .. C'Length + Common'Length);
-
begin
S (1 .. C'Length) := C;
S (C'Length + 1 .. S'Length) := Common;
OSDN Git Service
