-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- 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. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with ALI; use ALI;
-with Binde; use Binde;
-with Butil; use Butil;
-with Casing; use Casing;
-with Fname; use Fname;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Gnatvsn; use Gnatvsn;
+with 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 Rident; use Rident;
-with Table; use Table;
-with Targparm; use Targparm;
-with Types; use Types;
-
-with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+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 GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
package body Bindgen is
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 --
----------------------------------
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 partitions.
+ -- 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;
+
+ -- 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 Storize_Size clause.
+
-----------------------
-- Local Subprograms --
-----------------------
procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
-- Convenient shorthand used throughout
+ 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_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)
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
-- 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
-- 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 and then not U.Interface 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
-- 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. Also no exception tables are needed.
+ -- the environment.
if Suppress_Standard_Library_On_Target then
if Main_Priority /= No_Main_Priority then
WBI (" null;");
end if;
- -- Normal case (standard library not suppressed). 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;
-
- Set_String (""";");
- Write_Statement_Buffer;
- WBI ("");
-
- -- Generate Interrupt_State pragma string
-
- Set_String (" Interrupt_States : constant String :=");
- Write_Statement_Buffer;
-
- declare
- Col : Natural;
+ 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"");");
- begin
- Set_String (" """);
- Col := 9;
-
- for J in 0 .. IS_Pragma_Settings.Last loop
- if Col > 72 then
- Set_String (""" &");
- Write_Statement_Buffer;
- Set_String (" """);
- Col := 9;
-
- else
- Col := Col + 1;
- end if;
-
- Set_Char (IS_Pragma_Settings.Table (J));
- end loop;
- end;
-
- 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;
- -- Generate spec for Set_Globals procedure
-
- 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 (" Interrupt_States : System.Address;");
- WBI (" Num_Interrupt_States : Integer;");
- 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"");");
-- Import entry point for elaboration time signal handler
-- installation, and indication of if it's been called previously.
WBI (" Handler_Installed : Integer;");
WBI (" pragma Import (C, Handler_Installed, " &
"""__gnat_handler_installed"");");
+ WBI (" begin");
- -- Generate exception table
-
- Gen_Exception_Table_Ada;
-
- -- Generate the call to Set_Globals
-
- WBI (" Set_Globals");
-
- Set_String (" (Main_Priority => ");
+ 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_String (" WC_Encoding := '");
Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
- Set_String ("',");
+ 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;
- WBI (" Restrictions => Restrictions'Address,");
+ 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 (" Interrupt_States => " &
- "Interrupt_States'Address,");
+ WBI (" Interrupt_States := Local_Interrupt_States'Address;");
- Set_String (" Num_Interrupt_States => ");
+ Set_String (" Num_Interrupt_States := ");
Set_Int (IS_Pragma_Settings.Last + 1);
- Set_Char (',');
+ 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_Char (',');
+ 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;
-- Generate call to Install_Handler
+
WBI ("");
WBI (" if Handler_Installed = 0 then");
- WBI (" Install_Handler;");
+ WBI (" Install_Handler;");
WBI (" end if;");
end if;
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 ("");
declare
Unum : constant Unit_Id := Elab_Order.Table (E);
U : Unit_Record renames Units.Table (Unum);
+
begin
- if U.Set_Elab_Entity and then not U.Interface 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;
-- 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;
-- Normal case (standard library not suppressed)
else
- -- Generate definition for restrictions string
+ -- Generate definition for interrupt states string
- Set_String (" const char *restrictions = """);
+ Set_String (" static const char *local_interrupt_states = """);
- for J in Restrictions'Range loop
- Set_Char (Restrictions (J));
+ 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 interrupt states string
+ -- Generate definition for priority specific dispatching string
- Set_String (" const char *interrupt_states = """);
+ Set_String
+ (" static const char *local_priority_specific_dispatching = """);
- for J in 0 .. IS_Pragma_Settings.Last loop
- Set_Char (IS_Pragma_Settings.Table (J));
+ for J in 0 .. PSD_Pragma_Settings.Last loop
+ Set_Char (PSD_Pragma_Settings.Table (J));
end loop;
Set_String (""";");
Write_Statement_Buffer;
- WBI ("");
+ -- Generate declaration for secondary stack default if needed
- -- Code for normal case (standard library not suppressed)
+ 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 (24);
- 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 (24);
- Set_String ("/* Time_Slice_Value */");
+ Set_Char (';');
Write_Statement_Buffer;
- Set_String (" '");
+ WBI (" extern char __gl_wc_encoding;");
+ Set_String (" __gl_wc_encoding = '");
Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
- Set_String ("',");
- Tab_To (24);
- Set_String ("/* 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 (24);
- 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 (24);
- 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 (24);
- Set_String ("/* Tasking_Dispatching_Policy */");
+ Set_String ("';");
Write_Statement_Buffer;
- Set_String (" ");
- Set_String ("restrictions");
- Set_String (",");
- Tab_To (24);
- Set_String ("/* Restrictions */");
- Write_Statement_Buffer;
+ Gen_Restrictions_C;
- Set_String (" ");
- Set_String ("interrupt_states");
- Set_String (",");
- Tab_To (24);
- Set_String ("/* Interrupt_States */");
- Write_Statement_Buffer;
+ WBI (" extern const void *__gl_interrupt_states;");
+ WBI (" __gl_interrupt_states = local_interrupt_states;");
- Set_String (" ");
+ WBI (" extern int __gl_num_interrupt_states;");
+ Set_String (" __gl_num_interrupt_states = ");
Set_Int (IS_Pragma_Settings.Last + 1);
- Set_String (",");
- Tab_To (24);
- Set_String ("/* Num_Interrupt_States */");
+ Set_String (";");
Write_Statement_Buffer;
- Set_String (" ");
- Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
- Set_String (",");
- Tab_To (24);
- 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 (24);
- 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 (24);
- 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 ("");
-- Install elaboration time signal handler
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 ("");
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 not U.Interface and then 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");
-- The uname_E assignment is skipped if this is a separate spec,
-- since the assignment will be done when we process the body.
- elsif not U.Interface then
+ elsif not U.SAL_Interface then
if Force_Checking_Of_Elaboration_Flags or
Interface_Library_Unit or
(not Bind_Main_Program)
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 (';');
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 not U.Interface and then 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 (" ");
-- The uname_E assignment is skipped if this is a separate spec,
-- since the assignment will be done when we process the body.
- elsif not U.Interface then
+ elsif not U.SAL_Interface then
Get_Name_String (U.Uname);
if Force_Checking_Of_Elaboration_Flags or
for J in Elab_Order.First .. Elab_Order.Last loop
Set_String (" -- ");
- 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 ("/* 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;
-
- 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 not ALIs.Table (A).Interface
- and then ALIs.Table (A).Unit_Exception_Table
- then
- Num := Num + 1;
- Last := A;
- end if;
- end loop;
-
- if Num = 0 then
-
- -- Happens with "gnatmake -a -f -gnatL ..."
-
- WBI (" ");
- WBI (" begin");
- return;
- end if;
-
- WBI (" procedure SDP_Table_Build");
- WBI (" (SDP_Addresses : System.Address;");
- WBI (" SDP_Count : Natural;");
- WBI (" Elab_Addresses : System.Address;");
- WBI (" Elab_Addr_Count : Natural);");
- WBI (" " &
- "pragma Import (C, SDP_Table_Build, ""__gnat_SDP_Table_Build"");");
-
- WBI (" ");
- Set_String (" ST : aliased constant array (1 .. ");
- Set_Int (Num);
- Set_String (") of System.Address := (");
-
- if Num = 1 then
- Set_String ("1 => A1);");
- Write_Statement_Buffer;
-
- else
- Write_Statement_Buffer;
-
- for A in ALIs.First .. ALIs.Last loop
- if not ALIs.Table (A).Interface
- and then 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 not Restrictions_On_Target (No_Finalization) then
- if Hostparm.Java_VM then
- Set_String
- (" System.Standard_Library.Adafinal'Code_Address");
- else
- Set_String
- (" Do_Finalize'Code_Address");
- end if;
- 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 not ALIs.Table (A).Interface
- and then 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 not ALIs.Table (A).Interface
- and then ALIs.Table (A).Unit_Exception_Table
- then
- Num2 := Num2 + 1;
-
- Set_String (" &__gnat_");
- Get_Name_String (Units.Table (ALIs.Table (A).First_Unit).Uname);
- Set_Unit_Name;
- Set_String ("__SDP");
-
- if Num = Num2 then
- Set_String ("};");
- else
- Set_Char (',');
- end if;
-
- Write_Statement_Buffer;
- end if;
- end loop;
-
- WBI ("");
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
-
- if Units.Table (Elab_Order.Table (E)).No_Elab then
- null;
-
- else
- Set_String (" extern void ");
- Set_Unit_Name;
- Set_String ("___elab");
- Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
- Set_String (" ();");
- Write_Statement_Buffer;
- end if;
- end loop;
-
- WBI ("");
- Set_String (" void (*ea[");
- Set_Int (Num_Elab_Calls + 2);
- Set_String ("]) () = {");
- Write_Statement_Buffer;
-
- WBI (" " & Ada_Init_Name.all & ",");
-
- if not Restrictions_On_Target (No_Finalization) then
- Set_String (" system__standard_library__adafinal");
- end if;
-
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
-
- if Units.Table (Elab_Order.Table (E)).No_Elab then
- null;
-
- else
- Set_Char (',');
- Write_Statement_Buffer;
- Set_String (" ");
- Set_Unit_Name;
- Set_String ("___elab");
- Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
- end if;
- end loop;
-
- Set_String ("};");
- Write_Statement_Buffer;
-
- WBI (" ");
-
- Set_String (" __gnat_SDP_Table_Build (&st, ");
- Set_Int (Num);
- Set_String (", ea, ");
- Set_Int (Num_Elab_Calls + 2);
- Set_String (");");
- Write_Statement_Buffer;
- end Gen_Exception_Table_C;
-
------------------
-- Gen_Main_Ada --
------------------
Write_Statement_Buffer;
end if;
+ 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
- if not Restrictions_On_Target (No_Finalization) 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 (" gnat_envp := System.Null_Address;");
end if;
- if not Restrictions_On_Target (No_Finalization) then
- WBI (" Initialize;");
+ 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;
+
+ 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 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 & ";");
-- Adafinal call is skipped if no finalization
- if not Restrictions_On_Target (No_Finalization) 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 Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI (" Finalize;");
end if;
procedure Gen_Main_C is
begin
if Exit_Status_Supported_On_Target then
+ WBI ("#include <stdlib.h>");
Set_String ("int ");
else
Set_String ("void ");
-- Case of no command line arguments on target
else
- Write_Statement_Buffer (" ()");
+ Write_Statement_Buffer (" (void)");
end if;
WBI ("{");
-- place). 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 declare this variable as
+ -- volatile in order to tell the compiler to preserve it at any
+ -- level of optimization.
+
if Bind_Main_Program then
- WBI (" char *ensure_reference __attribute__ ((__unused__)) = " &
+ WBI (" char * volatile ensure_reference " &
+ "__attribute__ ((__unused__)) = " &
"__gnat_ada_main_program_name;");
WBI ("");
+
+ if not Suppress_Standard_Library_On_Target
+ and then not No_Main_Subprogram
+ then
+ WBI (" int SEH [2];");
+ WBI ("");
+ end if;
end if;
-- If main program is a function, generate result variable
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 Suppress_Standard_Library_On_Target then
- WBI
- (" __gnat_initialize ();");
+ 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 & " ();");
-- Call adafinal if finalization active
- if not Restrictions_On_Target (No_Finalization) 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 Suppress_Standard_Library_On_Target then
-- For all other systems, we use the standard exit routine.
if OpenVMS_On_Target then
- WBI (" __posix_exit (result);");
+ WBI (" decc$__posix_exit (result);");
else
WBI (" exit (result);");
end if;
-- For all other systems, we use the standard exit routine.
if OpenVMS_On_Target then
- WBI (" __posix_exit (gnat_exit_status);");
+ WBI (" decc$__posix_exit (gnat_exit_status);");
else
WBI (" exit (gnat_exit_status);");
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;
-- If not spec that has an associated body, then generate a
-- comment giving the name of the corresponding object file.
- if (not Units.Table (Elab_Order.Table (E)).Interface)
+ 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
-- exists, then use it.
if not Hostparm.Exclude_Missing_Objects
- or else GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
+ or else
+ 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)
end if;
end loop;
- -- Add a "-Ldir" for each directory in the object path. We skip this
- -- in Configurable_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 Configurable_Run_Time_Mode then
- 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;
- 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 (Configurable_Run_Time_Mode 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 ");
else
---------------------
procedure Gen_Output_File (Filename : String) is
- Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
-
begin
-- Acquire settings for Interrupt_State pragmas
Set_IS_Pragma_Table;
- -- Override Ada_Bind_File and Bind_Main_Program for Java since
+ -- 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;
end if;
end if;
end loop;
- -- Get the time stamp of the former bind for public version warning
-
- if Is_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 Is_Public_Version then
- Public_Version_Warning;
- end if;
end Gen_Output_File;
-------------------------
Create_Binder_Output (Filename, 's', Bfiles);
+ -- 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 Restrictions_On_Target (No_Exception_Handlers) then
+ 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
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 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.
- if Hostparm.Java_VM then
+ if VM_Target /= No_VM then
WBI ("with System.Standard_Library;");
end if;
end if;
"""__gnat_ada_main_program_name"");");
end if;
- -- No need to generate a finalization routine if finalization
- -- is restricted, since there is nothing to do in this case.
-
- if not Restrictions_On_Target (No_Finalization) 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 -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 then
-- If we have the standard library, then Break_Start is defined
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 finalization active
- if not Restrictions_On_Target (No_Finalization) 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;
+
+ Set_String (""";");
+ Write_Statement_Buffer;
- -- No need to generate a finalization routine if no finalization
+ -- Generate Interrupt_State pragma string
+
+ Set_String (" Local_Interrupt_States : constant String := """);
+
+ for J in 0 .. IS_Pragma_Settings.Last loop
+ Set_Char (IS_Pragma_Settings.Table (J));
+ end loop;
- if not Restrictions_On_Target (No_Finalization) then
- Gen_Adafinal_Ada;
+ Set_String (""";");
+ Write_Statement_Buffer;
+ WBI ("");
end if;
+ Gen_Adainit_Ada;
+
+ Gen_Adafinal_Ada;
+
if Bind_Main_Program then
-- When suppressing the standard library then generate dummy body
Resolve_Binder_Options;
- WBI ("extern void __gnat_set_globals");
- WBI (" (int, int, char, char, char, char,");
- WBI (" const char *, const char *,");
- WBI (" int, int, int, int);");
WBI ("extern void " & Ada_Final_Name.all & " (void);");
- WBI ("extern void " & Ada_Init_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.
+
+ 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 (void);");
if not No_Main_Subprogram then
end if;
if OpenVMS_On_Target then
- WBI ("extern void __posix_exit (int);");
+ WBI ("extern void decc$__posix_exit (int);");
else
WBI ("extern void exit (int);");
end if;
end if;
if not Suppress_Standard_Library_On_Target then
- WBI ("extern void __gnat_initialize (void);");
+ 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;
+
WBI ("");
Gen_Elab_Defs_C;
WBI ("extern int gnat_argc;");
WBI ("extern char **gnat_argv;");
WBI ("extern char **gnat_envp;");
- WBI ("extern int gnat_exit_status;");
-- If configurable run time and no command line args, then the
-- generation of these variables is entirely suppressed.
WBI ("int gnat_argc;");
WBI ("char **gnat_argv;");
WBI ("char **gnat_envp;");
- WBI ("int gnat_exit_status = 0;");
end if;
-- Similarly deal with exit status
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 Restrictions_On_Target (No_Finalization) then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
Gen_Adafinal_C;
end if;
Close_Binder_Output;
end Gen_Output_File_C;
+ --------------------------
+ -- Gen_Restrictions_Ada --
+ --------------------------
+
+ procedure Gen_Restrictions_Ada is
+ Count : Integer;
+
+ begin
+ if Suppress_Standard_Library_On_Target
+ or not System_Restrictions_Used
+ then
+ return;
+ end if;
+
+ WBI (" System.Restrictions.Run_Time_Restrictions :=");
+ WBI (" (Set =>");
+ Set_String (" (");
+
+ Count := 0;
+
+ 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 Count = 8 then
+ Write_Statement_Buffer;
+ Set_String (" ");
+ Count := 0;
+ end if;
+ end loop;
+
+ Set_Boolean
+ (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last));
+ Set_String ("),");
+ Write_Statement_Buffer;
+ Set_String (" Value => (");
+
+ 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;
+
+ 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;
+
+ Set_Boolean (Cumulative_Restrictions.Violated
+ (Cumulative_Restrictions.Violated'Last));
+ Set_String ("),");
+ Write_Statement_Buffer;
+ Set_String (" Count => (");
+
+ 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;
+
+ Set_Int (Int (Cumulative_Restrictions.Count
+ (Cumulative_Restrictions.Count'Last)));
+ Set_String ("),");
+ Write_Statement_Buffer;
+ Set_String (" Unknown => (");
+
+ 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_Boolean
+ (Cumulative_Restrictions.Unknown
+ (Cumulative_Restrictions.Unknown'Last));
+ Set_String ("));");
+ Write_Statement_Buffer;
+ end Gen_Restrictions_Ada;
+
+ ------------------------
+ -- Gen_Restrictions_C --
+ ------------------------
+
+ procedure Gen_Restrictions_C is
+ begin
+ if Suppress_Standard_Library_On_Target
+ or not System_Restrictions_Used
+ then
+ return;
+ end if;
+
+ WBI (" typedef struct {");
+ Set_String (" char set [");
+ Set_Int (Cumulative_Restrictions.Set'Length);
+ Set_String ("];");
+ Write_Statement_Buffer;
+
+ Set_String (" int value [");
+ Set_Int (Cumulative_Restrictions.Value'Length);
+ Set_String ("];");
+ Write_Statement_Buffer;
+
+ Set_String (" char violated [");
+ Set_Int (Cumulative_Restrictions.Violated'Length);
+ Set_String ("];");
+ Write_Statement_Buffer;
+
+ Set_String (" int count [");
+ Set_Int (Cumulative_Restrictions.Count'Length);
+ Set_String ("];");
+ 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_Int (Boolean'Pos
+ (Cumulative_Restrictions.Set (Cumulative_Restrictions.Set'Last)));
+ Set_String ("},");
+ Write_Statement_Buffer;
+ Set_String (" {");
+
+ 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;
+
+ Set_Int (Int (Cumulative_Restrictions.Value
+ (Cumulative_Restrictions.Value'Last)));
+ Set_String ("},");
+ Write_Statement_Buffer;
+ Set_String (" {");
+
+ 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;
+
+ Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated
+ (Cumulative_Restrictions.Violated'Last)));
+ 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;
+
+ Set_Int (Int (Cumulative_Restrictions.Count
+ (Cumulative_Restrictions.Count'Last)));
+ Set_String ("},");
+ Write_Statement_Buffer;
+ Set_String (" {");
+
+ 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;
+
+ 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;
-- The main program generated by JGNAT expects a package called
-- ada_<main procedure>.
- if Hostparm.Java_VM then
+ if VM_Target /= No_VM then
+
-- Get main program name
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
end Move_Linker_Option;
----------------------------
- -- Public_Version_Warning --
- ----------------------------
-
- procedure Public_Version_Warning is
-
- Time : constant 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 --
----------------------------
With_GNARL := True;
end if;
- if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then
+ 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 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 --
----------------------
OSDN Git Service
