-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004 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- --
-- MA 02111-1307, USA. --
-- --
-- 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 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 Sdefault; use Sdefault;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
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
+ ----------------------------------
+ -- 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 partitions. 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");
+
+ ----------------------
+ -- Run-Time Globals --
+ ----------------------
+
+ -- This section documents the global variables that are passed to the
+ -- run time from the generated binder file. The call that is made is
+ -- to the routine Set_Globals, which has the following spec:
+
+ -- procedure Set_Globals
+ -- (Main_Priority : Integer;
+ -- Time_Slice_Value : Integer;
+ -- WC_Encoding : Character;
+ -- Locking_Policy : Character;
+ -- Queuing_Policy : Character;
+ -- Task_Dispatching_Policy : Character;
+ -- Restrictions : System.Address;
+ -- Interrupt_States : System.Address;
+ -- Num_Interrupt_States : Integer;
+ -- Unreserve_All_Interrupts : Integer;
+ -- Exception_Tracebacks : Integer;
+ -- Zero_Cost_Exceptions : 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.
+
+ -- 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
+
-----------------------
-- 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 Gen_Adainit_Ada;
-- Generates the Adainit procedure (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_String_1;
+ -- Generate first restrictions string, which consists of the parameters
+ -- the first R line, as described in lib-writ.ads, with the restrictions
+ -- being those for the entire partition (from Cumulative_Restrictions).
+
+ procedure Gen_Restrictions_String_2;
+ -- Generate first restrictions string, which consists of the parameters
+ -- the second R line, as described in lib-writ.ads, with the restrictions
+ -- being those for the entire partition (from Cumulative_Restrictions).
procedure Gen_Versions_Ada;
-- Output series of definitions for unit versions (Ada code case)
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 Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
-- Compare linker options, when sorting, first according to
-- 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
-- and increment Last by one to reflect the stored character.
-- starting at the Last + 1 position, and updating Last past the value.
-- A minus sign is output for a negative 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
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.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);
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. Also no exception tables are needed.
- 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
+ -- 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.
Set_String (" Restrictions : constant String :=");
Write_Statement_Buffer;
+
Set_String (" """);
+ Gen_Restrictions_String_1;
+ Set_String (""" &");
+ Write_Statement_Buffer;
- for J in Restrictions'Range loop
- Set_Char (Restrictions (J));
- end loop;
+ Set_String (" """);
+ Gen_Restrictions_String_2;
+ Set_String (""" & ASCII.Nul;");
+ Write_Statement_Buffer;
+ WBI ("");
+
+ -- Generate Interrupt_State pragma string
+
+ Set_String (" Interrupt_States : constant String :=");
+ Write_Statement_Buffer;
+
+ declare
+ Col : Natural;
+
+ 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 ("");
+ -- Generate spec for Set_Globals procedure
+
WBI (" procedure Set_Globals");
WBI (" (Main_Priority : Integer;");
WBI (" Time_Slice_Value : Integer;");
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"");");
-- 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 (" Restrictions => Restrictions'Address,");
+ WBI (" Interrupt_States => " &
+ "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 => ");
if Unreserve_All_Interrupts_Specified then
Set_String ("0");
end if;
- Set_String (",");
+ Set_Char (',');
Write_Statement_Buffer;
Set_String (" Exception_Tracebacks => ");
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;
+ -- 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;
+
+ -- Generate elaboration calls
+
+ WBI ("");
Gen_Elab_Calls_Ada;
WBI (" end " & Ada_Init_Name.all & ";");
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.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
Write_Statement_Buffer;
end if;
- -- Normal case (run time present)
+ -- Normal case (standard library not suppressed)
else
-- Generate definition for restrictions string
Set_String (" const char *restrictions = """);
+ Gen_Restrictions_String_1;
+ Gen_Restrictions_String_2;
+ Set_String (""";");
+ Write_Statement_Buffer;
- for J in Restrictions'Range loop
- Set_Char (Restrictions (J));
+ -- Generate definition for interrupt states string
+
+ Set_String (" const char *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;
- -- 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;
+
+ WBI ("");
+
+ -- Code for normal case (standard library not suppressed)
Gen_Exception_Table_C;
Set_String (" ");
Set_Int (Main_Priority);
Set_Char (',');
- Tab_To (15);
+ Tab_To (24);
Set_String ("/* Main_Priority */");
Write_Statement_Buffer;
end if;
Set_Char (',');
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* Time_Slice_Value */");
Write_Statement_Buffer;
Set_String (" '");
Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
Set_String ("',");
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* WC_Encoding */");
Write_Statement_Buffer;
Set_String (" '");
Set_Char (Locking_Policy_Specified);
Set_String ("',");
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* Locking_Policy */");
Write_Statement_Buffer;
Set_String (" '");
Set_Char (Queuing_Policy_Specified);
Set_String ("',");
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* Queuing_Policy */");
Write_Statement_Buffer;
Set_String (" '");
Set_Char (Task_Dispatching_Policy_Specified);
Set_String ("',");
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* Tasking_Dispatching_Policy */");
Write_Statement_Buffer;
Set_String (" ");
Set_String ("restrictions");
Set_String (",");
- Tab_To (20);
- Set_String ("/* Restrictions */");
+ Tab_To (24);
+ Set_String ("/* Restrictions */");
+ Write_Statement_Buffer;
+
+ Set_String (" ");
+ Set_String ("interrupt_states");
+ Set_String (",");
+ Tab_To (24);
+ Set_String ("/* Interrupt_States */");
+ Write_Statement_Buffer;
+
+ Set_String (" ");
+ Set_Int (IS_Pragma_Settings.Last + 1);
+ Set_String (",");
+ Tab_To (24);
+ Set_String ("/* Num_Interrupt_States */");
Write_Statement_Buffer;
Set_String (" ");
Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
Set_String (",");
- Tab_To (20);
- Set_String ("/* Unreserve_All_Interrupts */");
+ Tab_To (24);
+ Set_String ("/* Unreserve_All_Interrupts */");
Write_Statement_Buffer;
Set_String (" ");
Set_Int (Boolean'Pos (Exception_Tracebacks));
Set_String (",");
- Tab_To (20);
- Set_String ("/* Exception_Tracebacks */");
+ Tab_To (24);
+ Set_String ("/* Exception_Tracebacks */");
Write_Statement_Buffer;
Set_String (" ");
Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
Set_String (");");
- Tab_To (20);
- Set_String ("/* Zero_Cost_Exceptions */");
+ Tab_To (24);
+ Set_String ("/* Zero_Cost_Exceptions */");
Write_Statement_Buffer;
+ WBI ("");
-- Install elaboration time signal handler
WBI (" }");
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.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.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
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.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.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 (" -- ");
+ Set_String (" -- ");
Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
Set_Name_Buffer;
Write_Statement_Buffer;
end loop;
- WBI (" -- END ELABORATION ORDER");
+ WBI (" -- END ELABORATION ORDER");
end Gen_Elab_Order_Ada;
----------------------
Num := 0;
for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
+ if not ALIs.Table (A).Interface
+ and then ALIs.Table (A).Unit_Exception_Table
+ then
Num := Num + 1;
Last := A;
end if;
Write_Statement_Buffer;
for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
+ 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);
-- 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");
+ if not Cumulative_Restrictions.Set (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
Num := 0;
for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
+ if not ALIs.Table (A).Interface
+ and then ALIs.Table (A).Unit_Exception_Table
+ then
Num := Num + 1;
Set_String (" extern void *__gnat_");
Num2 := 0;
for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
+ if not ALIs.Table (A).Interface
+ and then ALIs.Table (A).Unit_Exception_Table
+ then
Num2 := Num2 + 1;
Set_String (" &__gnat_");
Write_Statement_Buffer;
WBI (" " & Ada_Init_Name.all & ",");
- Set_String (" system__standard_library__adafinal");
+
+ if not Cumulative_Restrictions.Set (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);
------------------
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;
+ if Exit_Status_Supported_On_Target then
+ Set_String (" function ");
else
+ Set_String (" procedure ");
+ end if;
+
+ Set_String (Get_Main_Name);
+
+ if Command_Line_Args_On_Target then
Write_Statement_Buffer;
WBI (" (argc : Integer;");
WBI (" argv : System.Address;");
WBI (" envp : System.Address)");
- WBI (" return Integer");
+
+ if Exit_Status_Supported_On_Target then
+ WBI (" return Integer");
+ end if;
+
WBI (" is");
+
+ else
+ if Exit_Status_Supported_On_Target then
+ Set_String (" return Integer is");
+ else
+ Set_String (" is");
+ end if;
+
+ Write_Statement_Buffer;
end if;
- -- Initialize and Finalize are not used in No_Run_Time mode
+ -- Initialize and Finalize
- if not No_Run_Time_Specified then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI (" procedure initialize;");
WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
WBI ("");
WBI (" begin");
- -- On VxWorks, there are no command line arguments
-
- if VxWorks_Target then
- WBI (" gnat_argc := 0;");
- WBI (" gnat_argv := System.Null_Address;");
- WBI (" gnat_envp := System.Null_Address;");
-
- -- Normal case of command line arguments present
+ -- Acquire command line arguments if present on target
- else
+ 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?)
+
+ else
+ WBI (" gnat_argc := 0;");
+ WBI (" gnat_argv := System.Null_Address;");
+ WBI (" gnat_envp := System.Null_Address;");
end if;
- if not No_Run_Time_Specified then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI (" Initialize;");
end if;
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).
-- 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
+ 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 (" ()");
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;");
+ if Bind_Main_Program then
+ WBI (" char *ensure_reference __attribute__ ((__unused__)) = " &
+ "__gnat_ada_main_program_name;");
+ WBI ("");
+ end if;
- -- Normal case of arguments present
+ -- If main program is a function, generate result variable
- 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;");
- WBI ("");
- end if;
+ if ALIs.Table (ALIs.First).Main_Program = Func then
+ WBI (" int result;");
+ end if;
- 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 (" int result;");
+ WBI (" gnat_argc = 0;");
+ WBI (" gnat_argv = 0;");
+ WBI (" gnat_envp = 0;");
end if;
-- The __gnat_initialize 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_initialize ();");
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;
-- 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
+ -- Case of main program is a function, so the value it returns
+ -- is the exit status in this case.
- if Hostparm.OpenVMS then
-
- -- 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 (" __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 (" __posix_exit (gnat_exit_status);");
+ else
+ WBI (" exit (gnat_exit_status);");
+ end if;
end if;
end if;
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)).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);
-- 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 GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
then
Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
+
if Output_Object_List then
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Eol;
(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
+ if not Opt.No_Stdlib then
Name_Len := 0;
if Opt.Shared_Libgnat then
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;
end loop;
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
+ Is_Public_Version : constant Boolean := Get_Gnat_Build_Type = Public;
+ Is_GAP_Version : constant Boolean := Get_Gnat_Build_Type = GAP;
begin
+ -- Acquire settings for Interrupt_State pragmas
+
+ Set_IS_Pragma_Table;
+
-- Override Ada_Bind_File and Bind_Main_Program for Java since
-- JGNAT only supports Ada code, and the main program is already
-- generated by the compiler.
-- Get the time stamp of the former bind for public version warning
- if Public_Version then
+ if Is_Public_Version or Is_GAP_Version then
Record_Time_From_Last_Bind;
end if;
-- Periodically issue a warning when the public version is used on
-- big projects
- if Public_Version then
+ if Is_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
- WBI ("pragma No_Run_Time;");
+ -- 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;
- -- 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 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
end if;
WBI ("package " & Ada_Main & " is");
+ WBI (" pragma Warnings (Off);");
-- Main program case
if Bind_Main_Program then
- -- Generate argc/argv stuff
-
- WBI ("");
- WBI (" gnat_argc : Integer;");
- WBI (" gnat_argv : System.Address;");
- WBI (" gnat_envp : System.Address;");
-
- -- If we have a run time present, these variables are in the
- -- runtime data area for easy access from the runtime
+ -- Generate argc/argv stuff unless suppressed
- if not No_Run_Time_Specified then
+ if Command_Line_Args_On_Target
+ or not Configurable_Run_Time_On_Target
+ then
WBI ("");
- WBI (" pragma Import (C, gnat_argc);");
- WBI (" pragma Import (C, gnat_argv);");
- WBI (" pragma Import (C, gnat_envp);");
+ 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;
-- 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.
+ -- run-time library, and is initialized there, but in the
+ -- configurable runtime case, the variable is declared and
+ -- initialized in this file.
WBI ("");
- if No_Run_Time_Specified then
- WBI (" gnat_exit_status : Integer := 0;");
+ if Configurable_Run_Time_Mode then
+ if Exit_Status_Supported_On_Target then
+ WBI (" gnat_exit_status : Integer := 0;");
+ end if;
else
WBI (" gnat_exit_status : Integer;");
WBI (" pragma Import (C, gnat_exit_status);");
"""__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.
+ -- No need to generate a finalization routine if finalization
+ -- is restricted, since there is nothing to do in this case.
- if not No_Run_Time_Specified then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI ("");
WBI (" procedure " & Ada_Final_Name.all & ";");
WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
if Bind_Main_Program then
- -- If we have a run time, then Break_Start is defined there, but
- -- if there is no run-time, Break_Start is defined in this file.
+ -- 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;
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.
Gen_Adainit_Ada;
- -- No need to generate a finalization routine if there is no
- -- runtime, since there is nothing to do in this case.
+ -- No need to generate a finalization routine if no finalization
- if not No_Run_Time_Specified then
+ if not Cumulative_Restrictions.Set (No_Finalization) then
Gen_Adafinal_Ada;
end if;
if Bind_Main_Program then
- -- In No_Run_Time mode, generate dummy body for Break_Start
+ -- When suppressing the standard library then generate dummy body
+ -- for Break_Start
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target then
WBI ("");
WBI (" procedure Break_Start is");
WBI (" begin");
Resolve_Binder_Options;
- WBI ("#ifdef __STDC__");
- WBI ("#define PARAMS(paramlist) paramlist");
- WBI ("#else");
- WBI ("#define PARAMS(paramlist) ()");
- WBI ("#endif");
- WBI ("");
+ WBI ("extern void __gnat_set_globals");
+ WBI (" (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);");
+ WBI ("extern void system__standard_library__adafinal (void);");
- 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 not No_Main_Subprogram then
+ Set_String ("extern ");
+
+ if Exit_Status_Supported_On_Target then
+ Set_String ("int");
+ else
+ Set_String ("void");
+ end if;
- WBI ("extern void system__standard_library__adafinal PARAMS ((void));");
+ Set_String (" main ");
- 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));");
+ if Command_Line_Args_On_Target then
+ Write_Statement_Buffer ("(int, char **, char **);");
+ else
+ Write_Statement_Buffer ("(void);");
+ end if;
+
+ if OpenVMS_On_Target then
+ WBI ("extern void __posix_exit (int);");
else
- WBI ("extern void exit PARAMS ((int));");
+ WBI ("extern void exit (int);");
end if;
- WBI ("extern void __gnat_break_start PARAMS ((void));");
+ 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;
WBI ("");
-- Imported variable used to track elaboration/finalization phase.
-- Used only when we have a runtime.
- if not No_Run_Time_Specified then
+ if not Suppress_Standard_Library_On_Target then
WBI ("extern int __gnat_handler_installed;");
WBI ("");
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 ("int gnat_exit_status = 0;");
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 () {}");
end if;
-- Generate the adafinal routine. In no runtime mode, this is
-- not needed, since there is no finalization to do.
- if not No_Run_Time_Specified then
+ 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.
-
- IS_Ill : String (1 .. 24);
+ -------------------------------
+ -- Gen_Restrictions_String_1 --
+ -------------------------------
+ procedure Gen_Restrictions_String_1 is
begin
- -- -Sin (invalid values)
-
- if Opt.Initialize_Scalars_Mode = 'I' then
- IS_Is1 := "80";
- IS_Is2 := "8000";
- IS_Is4 := "80000000";
- IS_Is8 := "8000000000000000";
- IS_Iu1 := "FF";
- IS_Iu2 := "FFFF";
- IS_Iu4 := "FFFFFFFF";
- IS_Iu8 := "FFFFFFFFFFFFFFFF";
- IS_Isf := IS_Iu4;
- IS_Ifl := IS_Iu4;
- IS_Ilf := IS_Iu8;
- IS_Ill := "00000000000000C0FFFF0000";
-
- -- -Slo (low values)
-
- elsif Opt.Initialize_Scalars_Mode = 'L' then
- IS_Is1 := "80";
- IS_Is2 := "8000";
- IS_Is4 := "80000000";
- IS_Is8 := "8000000000000000";
- IS_Iu1 := "00";
- IS_Iu2 := "0000";
- IS_Iu4 := "00000000";
- IS_Iu8 := "0000000000000000";
- IS_Isf := "FF800000";
- IS_Ifl := IS_Isf;
- IS_Ilf := "FFF0000000000000";
- IS_Ill := "0000000000000080FFFF0000";
-
- -- -Shi (high values)
-
- elsif Opt.Initialize_Scalars_Mode = 'H' then
- IS_Is1 := "7F";
- IS_Is2 := "7FFF";
- IS_Is4 := "7FFFFFFF";
- IS_Is8 := "7FFFFFFFFFFFFFFF";
- IS_Iu1 := "FF";
- IS_Iu2 := "FFFF";
- IS_Iu4 := "FFFFFFFF";
- IS_Iu8 := "FFFFFFFFFFFFFFFF";
- IS_Isf := "7F800000";
- IS_Ifl := IS_Isf;
- IS_Ilf := "7FF0000000000000";
- IS_Ill := "0000000000000080FF7F0000";
-
- -- -Shh (hex byte)
-
- else pragma Assert (Opt.Initialize_Scalars_Mode = 'X');
- IS_Is1 (1 .. 2) := Opt.Initialize_Scalars_Val;
- IS_Is2 (1 .. 2) := Opt.Initialize_Scalars_Val;
- IS_Is2 (3 .. 4) := Opt.Initialize_Scalars_Val;
-
- for J in 1 .. 4 loop
- IS_Is4 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
- end loop;
-
- for J in 1 .. 8 loop
- IS_Is8 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
- end loop;
-
- IS_Iu1 := IS_Is1;
- IS_Iu2 := IS_Is2;
- IS_Iu4 := IS_Is4;
- IS_Iu8 := IS_Is8;
-
- IS_Isf := IS_Is4;
- IS_Ifl := IS_Is4;
- IS_Ilf := IS_Is8;
-
- for J in 1 .. 12 loop
- IS_Ill (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
- end loop;
- end if;
-
- -- Generate output, Ada case
-
- if Ada_Bind_File then
- WBI ("");
-
- Set_String (" IS_Is1 : constant System.Scalar_Values.Byte1 := 16#");
- Set_String (IS_Is1);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Is2 : constant System.Scalar_Values.Byte2 := 16#");
- Set_String (IS_Is2);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Is4 : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Is4);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Is8 : constant System.Scalar_Values.Byte8 := 16#");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu1 : constant System.Scalar_Values.Byte1 := 16#");
- Set_String (IS_Iu1);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu2 : constant System.Scalar_Values.Byte2 := 16#");
- Set_String (IS_Iu2);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu4 : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Iu4);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu8 : constant System.Scalar_Values.Byte8 := 16#");
- Set_String (IS_Iu8);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Isf : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Isf);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Ifl : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Ifl);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Ilf : constant System.Scalar_Values.Byte8 := 16#");
- Set_String (IS_Ilf);
- Write_Statement_Buffer ("#;");
-
- -- Special case of Long_Long_Float. This is a 10-byte value used
- -- only on the x86. We could omit it for other architectures, but
- -- we don't easily have that kind of target specialization in the
- -- binder, and it's only 10 bytes, and only if -Sxx is used. Note
- -- that for architectures where Long_Long_Float is the same as
- -- Long_Float, the expander uses the Long_Float constant for the
- -- initializations of Long_Long_Float values.
-
- WBI (" IS_Ill : constant array (1 .. 12) of");
- WBI (" System.Scalar_Values.Byte1 := (");
- Set_String (" ");
-
- for J in 1 .. 6 loop
- Set_String (" 16#");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
- Set_String ("#,");
- end loop;
-
- Write_Statement_Buffer;
- Set_String (" ");
-
- for J in 7 .. 12 loop
- Set_String (" 16#");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
-
- if J = 12 then
- Set_String ("#);");
- else
- Set_String ("#,");
- end if;
- end loop;
-
- Write_Statement_Buffer;
-
- -- Output export statements to export to System.Scalar_Values
-
- WBI ("");
-
- WBI (" pragma Export (Ada, IS_Is1, ""__gnat_Is1"");");
- WBI (" pragma Export (Ada, IS_Is2, ""__gnat_Is2"");");
- WBI (" pragma Export (Ada, IS_Is4, ""__gnat_Is4"");");
- WBI (" pragma Export (Ada, IS_Is8, ""__gnat_Is8"");");
- WBI (" pragma Export (Ada, IS_Iu1, ""__gnat_Iu1"");");
- WBI (" pragma Export (Ada, IS_Iu2, ""__gnat_Iu2"");");
- WBI (" pragma Export (Ada, IS_Iu4, ""__gnat_Iu4"");");
- WBI (" pragma Export (Ada, IS_Iu8, ""__gnat_Iu8"");");
- WBI (" pragma Export (Ada, IS_Isf, ""__gnat_Isf"");");
- WBI (" pragma Export (Ada, IS_Ifl, ""__gnat_Ifl"");");
- WBI (" pragma Export (Ada, IS_Ilf, ""__gnat_Ilf"");");
- WBI (" pragma Export (Ada, IS_Ill, ""__gnat_Ill"");");
-
- -- Generate output C case
-
- else
- -- The lines we generate in this case are of the form
- -- typ __gnat_I?? = 0x??;
- -- where typ is appropriate to the length
-
- WBI ("");
-
- Set_String ("unsigned char __gnat_Is1 = 0x");
- Set_String (IS_Is1);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned short __gnat_Is2 = 0x");
- Set_String (IS_Is2);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned __gnat_Is4 = 0x");
- Set_String (IS_Is4);
- Write_Statement_Buffer (";");
-
- Set_String ("long long unsigned __gnat_Is8 = 0x");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("LL;");
-
- Set_String ("unsigned char __gnat_Iu1 = 0x");
- Set_String (IS_Is1);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned short __gnat_Iu2 = 0x");
- Set_String (IS_Is2);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned __gnat_Iu4 = 0x");
- Set_String (IS_Is4);
- Write_Statement_Buffer (";");
-
- Set_String ("long long unsigned __gnat_Iu8 = 0x");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("LL;");
-
- Set_String ("unsigned __gnat_Isf = 0x");
- Set_String (IS_Isf);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned __gnat_Ifl = 0x");
- Set_String (IS_Ifl);
- Write_Statement_Buffer (";");
-
- Set_String ("long long unsigned __gnat_Ilf = 0x");
- Set_String (IS_Ilf);
- Write_Statement_Buffer ("LL;");
-
- -- For Long_Long_Float, we generate
- -- char __gnat_Ill[12] = {0x??, 0x??, 0x??, 0x??, 0x??, 0x??,
- -- 0x??, 0x??, 0x??, 0x??, 0x??, 0x??);
-
- Set_String ("unsigned char __gnat_Ill[12] = {");
+ for R in All_Boolean_Restrictions loop
+ if Cumulative_Restrictions.Set (R) then
+ Set_Char ('r');
+ elsif Cumulative_Restrictions.Violated (R) then
+ Set_Char ('v');
+ else
+ Set_Char ('n');
+ end if;
+ end loop;
+ end Gen_Restrictions_String_1;
- 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;
+ -------------------------------
+ -- Gen_Restrictions_String_2 --
+ -------------------------------
- Write_Statement_Buffer;
- Set_String (" ");
+ procedure Gen_Restrictions_String_2 is
+ begin
+ for RP in All_Parameter_Restrictions loop
+ if Cumulative_Restrictions.Set (RP) then
+ Set_Char ('r');
+ Set_Int (Int (Cumulative_Restrictions.Value (RP)));
+ else
+ Set_Char ('n');
+ end if;
- for J in 7 .. 12 loop
- Set_String ("0x");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
+ if not Cumulative_Restrictions.Violated (RP)
+ or else RP not in Checked_Parameter_Restrictions
+ then
+ Set_Char ('n');
+ else
+ Set_Char ('v');
+ Set_Int (Int (Cumulative_Restrictions.Count (RP)));
- if J = 12 then
- Set_String ("};");
- else
- Set_String (", ");
+ if Cumulative_Restrictions.Unknown (RP) then
+ Set_Char ('+');
end if;
- end loop;
-
- Write_Statement_Buffer;
- end if;
- end Gen_Scalar_Values;
+ end if;
+ end loop;
+ end Gen_Restrictions_String_2;
----------------------
-- Gen_Versions_Ada --
-------------------
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
----------------------------
procedure Public_Version_Warning is
-
- Time : Int := Time_From_Last_Bind;
+ Time : constant Int := Time_From_Last_Bind;
-- Constants to help defining periods
-- Do not emit the message if the last message was emitted in the
-- specified period taking into account the number of units.
+ pragma Warnings (Off);
+ -- Turn off warning of constant condition, which may happen here
+ -- depending on the choice of constants in the above declarations.
+
if Nb_Unit < Large and then Time <= Period_Small then
return;
-
elsif Time <= Period_Large then
return;
end if;
+ pragma Warnings (On);
+
Write_Eol;
Write_Str ("IMPORTANT NOTICE:");
Write_Eol;
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.
+ -- flags is somewhat dubious, but there isn't a good alternative
+ -- at the current time ???
if Name_Buffer (1 .. 19) = "system.os_interface" then
With_GNARL := True;
end if;
- if Hostparm.OpenVMS and then Name_Buffer (1 .. 3) = "dec" then
+ if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then
With_DECGNAT := True;
end if;
end loop;
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 --
---------------------------
---------------------
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
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
