-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2019, 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- --
------------------------------------------------------------------------------
with ALI; use ALI;
-with Binde; use Binde;
with Casing; use Casing;
with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
with Osint.B; use Osint.B;
with Output; use Output;
with Rident; use Rident;
-with Table; use Table;
+with Stringt; use Stringt;
+with Table;
with Targparm; use Targparm;
with Types; use Types;
-with System.OS_Lib; use System.OS_Lib;
+with System.OS_Lib;
with System.WCh_Con; use System.WCh_Con;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+with GNAT.HTable;
package body Bindgen is
-
Statement_Buffer : String (1 .. 1000);
-- Buffer used for constructing output statements
- Last : Natural := 0;
- -- Last location in Statement_Buffer currently set
-
- With_DECGNAT : Boolean := False;
- -- Flag which indicates whether the program uses the DECGNAT library
- -- (presence of the unit DEC).
+ Stm_Last : Natural := 0;
+ -- Stm_Last location in Statement_Buffer currently set
With_GNARL : Boolean := False;
-- Flag which indicates whether the program uses the GNARL library
Num_Elab_Calls : Nat := 0;
-- Number of generated calls to elaboration routines
- System_Restrictions_Used : Boolean;
+ Num_Primary_Stacks : Int := 0;
+ -- Number of default-sized primary stacks the binder needs to allocate for
+ -- task objects declared in the program.
+
+ Num_Sec_Stacks : Int := 0;
+ -- Number of default-sized primary stacks the binder needs to allocate for
+ -- task objects declared in the program.
+
+ System_Restrictions_Used : Boolean := False;
-- 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.)
+ -- of the partition. This is set by Resolve_Binder_Options, 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.)
+
+ Dispatching_Domains_Used : Boolean := False;
+ -- Flag indicating whether multiprocessor dispatching domains are used in
+ -- the closure of the partition. This is set by Resolve_Binder_Options, and
+ -- is used to call the routine to disallow the creation of new dispatching
+ -- domains just before calling the main procedure from the environment
+ -- task.
+
+ System_Secondary_Stack_Used : Boolean := False;
+ -- Flag indicating whether the unit System.Secondary_Stack is in the
+ -- closure of the partition. This is set by Resolve_Binder_Options, and
+ -- is used to initialize the package in cases where the run-time brings
+ -- in package but the secondary stack is not used.
+
+ System_Tasking_Restricted_Stages_Used : Boolean := False;
+ -- Flag indicating whether the unit System.Tasking.Restricted.Stages is in
+ -- the closure of the partition. This is set by Resolve_Binder_Options,
+ -- and it used to call a routine to active all the tasks at the end of
+ -- the elaboration when partition elaboration policy is sequential.
+
+ System_Interrupts_Used : Boolean := False;
+ -- Flag indicating whether the unit System.Interrups is in the closure of
+ -- the partition. This is set by Resolve_Binder_Options, and it used to
+ -- attach interrupt handlers at the end of the elaboration when partition
+ -- elaboration policy is sequential.
+
+ System_BB_CPU_Primitives_Multiprocessors_Used : Boolean := False;
+ -- Flag indicating whether unit System.BB.CPU_Primitives.Multiprocessors
+ -- is in the closure of the partition. This is set by procedure
+ -- Resolve_Binder_Options, and it is used to call a procedure that starts
+ -- slave processors.
+
+ System_Version_Control_Used : Boolean := False;
+ -- Flag indicating whether unit System.Version_Control is in the closure.
+ -- This unit is implicitly withed by the compiler when Version or
+ -- Body_Version attributes are used. If the package is not in the closure,
+ -- the version definitions can be removed.
+
+ Lib_Final_Built : Boolean := False;
+ -- Flag indicating whether the finalize_library rountine has been built
+
+ Bind_Env_String_Built : Boolean := False;
+ -- Flag indicating whether a bind environment string has been built
+
+ CodePeer_Wrapper_Name : constant String := "call_main_subprogram";
+ -- For CodePeer, introduce a wrapper subprogram which calls the
+ -- user-defined main subprogram.
----------------------------------
-- Interface_State Pragma Table --
-- that the information is consistent across units. The entries
-- in this table are n/u/r/s for not set/user/runtime/system.
- package IS_Pragma_Settings is new Table.Table (
- Table_Component_Type => Character,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "IS_Pragma_Settings");
+ package IS_Pragma_Settings is new Table.Table
+ (Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "IS_Pragma_Settings");
-- This table assembles the Priority_Specific_Dispatching pragma
-- information from all the units in the partition. Note that Bcheck has
-- 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");
+ 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");
+
+ ----------------------------
+ -- Bind_Environment Table --
+ ----------------------------
+
+ subtype Header_Num is Int range 0 .. 36;
+
+ function Hash (Nam : Name_Id) return Header_Num;
+
+ package Bind_Environment is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Name_Id,
+ No_Element => No_Name,
+ Key => Name_Id,
+ Hash => Hash,
+ Equal => "=");
----------------------
-- Run-Time Globals --
----------------------
- -- This section documents the global variables that set from the
+ -- This section documents the global variables that are set from the
-- generated binder file.
-- Main_Priority : Integer;
-- Num_Interrupt_States : Integer;
-- Unreserve_All_Interrupts : Integer;
-- Exception_Tracebacks : Integer;
- -- Zero_Cost_Exceptions : Integer;
+ -- Exception_Tracebacks_Symbolic : Integer;
-- Detect_Blocking : Integer;
-- Default_Stack_Size : Integer;
+ -- Default_Secondary_Stack_Size : System.Parameters.Size_Type;
-- Leap_Seconds_Support : Integer;
+ -- Main_CPU : Integer;
+ -- Default_Sized_SS_Pool : System.Address;
+ -- Binder_Sec_Stacks_Count : Natural;
-- Main_Priority is the priority value set by pragma Priority in the main
-- program. If no such pragma is present, the value is -1.
-- 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.
- -- Heap_Size is the heap to use for memory allocations set by use of a
- -- -Hnn parameter for the binder or by the GNAT$NO_MALLOC_64 logical.
- -- Valid values are 32 and 64. This switch is only available on VMS.
-
-- 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.
-- 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.
+ -- Num_Specific_Dispatching is 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
-- 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.
+ -- Exception_Tracebacks is set to one if the -Ea or -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.
+ -- Exception_Tracebacks_Symbolic is set to one if the -Es parameter was
+ -- present in the bind and to zero otherwise.
-- Detect_Blocking indicates whether pragma Detect_Blocking is active or
-- not. A value of zero indicates that the pragma is not present, while a
-- Default_Stack_Size is the default stack size used when creating an Ada
-- task with no explicit Storage_Size clause.
+ -- Default_Secondary_Stack_Size is the default secondary stack size used
+ -- when creating an Ada task with no explicit Secondary_Stack_Size clause.
+
-- Leap_Seconds_Support denotes whether leap seconds have been enabled or
-- disabled. A value of zero indicates that leap seconds are turned "off",
-- while a value of one signifies "on" status.
- -----------------------
- -- Local Subprograms --
- -----------------------
+ -- Main_CPU is the processor set by pragma CPU in the main program. If no
+ -- such pragma is present, the value is -1.
- procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
- -- Convenient shorthand used throughout
+ -- Default_Sized_SS_Pool is set to the address of the default-sized
+ -- secondary stacks array generated by the binder. This pool of stacks is
+ -- generated when either the restriction No_Implicit_Heap_Allocations
+ -- or No_Implicit_Task_Allocations is active.
- 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).
+ -- Binder_Sec_Stacks_Count is the number of generated secondary stacks in
+ -- the Default_Sized_SS_Pool.
- procedure Gen_Adainit_Ada;
- -- Generates the Adainit procedure (Ada code case)
+ procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
+ -- Convenient shorthand used throughout
- procedure Gen_Adainit_C;
- -- Generates the Adainit procedure (C code case)
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- procedure Gen_Adafinal_Ada;
- -- Generate the Adafinal procedure (Ada code case)
+ procedure Gen_Adainit (Elab_Order : Unit_Id_Array);
+ -- Generates the Adainit procedure
- procedure Gen_Adafinal_C;
- -- Generate the Adafinal procedure (C code case)
+ procedure Gen_Adafinal;
+ -- Generate the Adafinal procedure
- procedure Gen_Elab_Calls_Ada;
- -- Generate sequence of elaboration calls (Ada code case)
+ procedure Gen_Bind_Env_String;
+ -- Generate the bind environment buffer
- procedure Gen_Elab_Calls_C;
- -- Generate sequence of elaboration calls (C code case)
+ procedure Gen_CodePeer_Wrapper;
+ -- For CodePeer, generate wrapper which calls user-defined main subprogram
- procedure Gen_Elab_Order_Ada;
- -- Generate comments showing elaboration order chosen (Ada case)
+ procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array);
+ -- Generate sequence of elaboration calls
- procedure Gen_Elab_Order_C;
- -- Generate comments showing elaboration order chosen (C case)
+ procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array);
+ -- Generate sequence of external declarations for elaboration
- procedure Gen_Elab_Defs_C;
- -- Generate sequence of definitions for elaboration routines (C code case)
+ procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array);
+ -- Generate comments showing elaboration order chosen
- procedure Gen_Main_Ada;
- -- Generate procedure main (Ada code case)
+ procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array);
+ -- Generate a sequence of finalization calls to elaborated packages
- procedure Gen_Main_C;
- -- Generate main() procedure (C code case)
+ procedure Gen_Main;
+ -- Generate procedure main
- procedure Gen_Object_Files_Options;
+ procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array);
-- Output comments containing a list of the full names of the object
-- files to be linked and the list of linker options supplied by
- -- Linker_Options pragmas in the source. (C and Ada code case)
-
- procedure Gen_Output_File_Ada (Filename : String);
- -- Generate output file (Ada code case)
-
- procedure Gen_Output_File_C (Filename : String);
- -- Generate output file (C code case)
+ -- Linker_Options pragmas in the source.
- procedure Gen_Restrictions_Ada;
- -- Generate initialization of restrictions variable (Ada code case)
+ procedure Gen_Output_File_Ada
+ (Filename : String;
+ Elab_Order : Unit_Id_Array);
+ -- Generate Ada output file
- procedure Gen_Restrictions_C;
- -- Generate initialization of restrictions variable (C code case)
+ procedure Gen_Restrictions;
+ -- Generate initialization of restrictions variable
- procedure Gen_Versions_Ada;
- -- Output series of definitions for unit versions (Ada code case)
-
- procedure Gen_Versions_C;
- -- Output series of definitions for unit versions (C code case)
+ procedure Gen_Versions;
+ -- Output series of definitions for unit versions
function Get_Ada_Main_Name return String;
- -- This function is used in the Ada main output case to compute a usable
- -- name for the generated main program. The normal main program name is
+ -- This function is used for the Ada main output to compute a usable name
+ -- for the generated main program. The normal main program name is
-- Ada_Main, but this won't work if the user has a unit with this name.
-- This function tries Ada_Main first, and if there is such a clash, then
-- it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.
-- Return the main unit name corresponding to S by replacing '.' with '_'
function Get_Main_Name return String;
- -- This function is used in the Ada main output case to compute the
- -- correct external main program. It is "main" by default, 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.
+ -- This function is used in the main output case to compute the correct
+ -- external main program. It is "main" by default, unless the flag
+ -- Use_Ada_Main_Program_Name_On_Target is set, in which case it is the name
+ -- of the Ada main name without the "_ada". This default can be overridden
+ -- explicitly using the -Mname binder switch.
function Get_WC_Encoding return Character;
-- Return wide character encoding method to set as WC_Encoding in output.
-- the encoding method used for the main program source. If there is no
-- main program source (-z switch used), returns brackets ('b').
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
+ function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean;
+ -- Determine whether the current unit has at least one library-level
+ -- finalizer.
+
+ function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean;
-- Compare linker options, when sorting, first according to
-- Is_Internal_File (internal files come later) and then by
-- elaboration order position (latest to earliest).
procedure Move_Linker_Option (From : Natural; To : Natural);
-- Move routine for sorting linker options
- 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 Resolve_Binder_Options (Elab_Order : Unit_Id_Array);
+ -- Set the value of With_GNARL
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.
+ -- Set given character in Statement_Buffer at the Stm_Last + 1 position
+ -- and increment Stm_Last by one to reflect the stored character.
procedure Set_Int (N : Int);
- -- Set given value in decimal in Statement_Buffer with no spaces
- -- starting at the Last + 1 position, and updating Last past the value.
- -- A minus sign is output for a negative value.
+ -- Set given value in decimal in Statement_Buffer with no spaces starting
+ -- at the Stm_Last + 1 position, and updating Stm_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.
+ -- Set given boolean value in Statement_Buffer at the Stm_Last + 1 position
+ -- and update Stm_Last past the value.
procedure Set_IS_Pragma_Table;
-- Initializes contents of IS_Pragma_Settings table from ALI table
procedure Set_Main_Program_Name;
- -- Given the main program name in Name_Buffer (length in Name_Len)
- -- generate the name of the routine to be used in the call. The name
- -- is generated starting at Last + 1, and Last is updated past it.
+ -- Given the main program name in Name_Buffer (length in Name_Len) generate
+ -- the name of the routine to be used in the call. The name is generated
+ -- starting at Stm_Last + 1, and Stm_Last is updated past it.
procedure Set_Name_Buffer;
-- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
procedure Set_String (S : String);
-- Sets characters of given string in Statement_Buffer, starting at the
- -- Last + 1 position, and updating last past the string value.
+ -- Stm_Last + 1 position, and updating last past the string value.
procedure Set_String_Replace (S : String);
- -- Replaces the last S'Length characters in the Statement_Buffer with
- -- the characters of S. The caller must ensure that these characters do
- -- in fact exist in the Statement_Buffer.
+ -- Replaces the last S'Length characters in the Statement_Buffer with the
+ -- characters of S. The caller must ensure that these characters do in fact
+ -- exist in the Statement_Buffer.
procedure Set_Unit_Name;
- -- Given a unit name in the Name_Buffer, copies it to Statement_Buffer,
- -- starting at the Last + 1 position, and updating last past the value.
- -- changing periods to double underscores, and updating Last appropriately.
+ -- Given a unit name in the Name_Buffer, copy it into Statement_Buffer,
+ -- starting at the Stm_Last + 1 position and update Stm_Last past the
+ -- value. Each dot (.) will be qualified into double underscores (__).
procedure Set_Unit_Number (U : Unit_Id);
- -- Sets unit number (first unit is 1, leading zeroes output to line
- -- up all output unit numbers nicely as required by the value, and
- -- by the total number of units.
-
- procedure 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.
+ -- Sets unit number (first unit is 1, leading zeroes output to line up all
+ -- output unit numbers nicely as required by the value, and by the total
+ -- number of units.
procedure Write_Statement_Buffer;
- -- Write out contents of statement buffer up to Last, and reset Last to 0
+ -- Write out contents of statement buffer up to Stm_Last, and reset
+ -- Stm_Last to 0.
procedure Write_Statement_Buffer (S : String);
-- First writes its argument (using Set_String (S)), then writes out the
- -- contents of statement buffer up to Last, and reset Last to 0
+ -- contents of statement buffer up to Stm_Last, and resets Stm_Last to 0.
+
+ procedure Write_Bind_Line (S : String);
+ -- Write S (an LF-terminated string) to the binder file (for use with
+ -- Set_Special_Output).
- ------------------------------------
- -- Check_System_Restrictions_Used --
- ------------------------------------
+ ------------------
+ -- Gen_Adafinal --
+ ------------------
- procedure Check_System_Restrictions_Used is
+ procedure Gen_Adafinal 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;
+ WBI (" procedure " & Ada_Final_Name.all & " is");
- System_Restrictions_Used := False;
- end Check_System_Restrictions_Used;
+ -- Call s_stalib_adafinal to await termination of tasks and so on. We
+ -- want to do this if there is a main program, either in Ada or in some
+ -- other language. (Note that Bind_Main_Program is True for Ada mains,
+ -- but False for mains in other languages.) We do not want to do this if
+ -- we're binding a library.
- ----------------------
- -- Gen_Adafinal_Ada --
- ----------------------
+ if not Bind_For_Library and not CodePeer_Mode then
+ WBI (" procedure s_stalib_adafinal;");
+ Set_String (" pragma Import (C, s_stalib_adafinal, ");
+ Set_String ("""system__standard_library__adafinal"");");
+ Write_Statement_Buffer;
+ end if;
- procedure Gen_Adafinal_Ada is
- begin
WBI ("");
- WBI (" procedure " & Ada_Final_Name.all & " is");
+ WBI (" procedure Runtime_Finalize;");
+ WBI (" pragma Import (C, Runtime_Finalize, " &
+ """__gnat_runtime_finalize"");");
+ WBI ("");
WBI (" begin");
- -- If compiling for the JVM, we directly call Adafinal because
- -- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
+ if not CodePeer_Mode then
+ WBI (" if not Is_Elaborated then");
+ WBI (" return;");
+ WBI (" end if;");
+ WBI (" Is_Elaborated := False;");
+ end if;
+
+ WBI (" Runtime_Finalize;");
- if VM_Target /= No_VM then
- WBI (" System.Standard_Library.Adafinal;");
+ -- By default (real targets), finalization is done differently depending
+ -- on whether this is the main program or a library.
+
+ if not CodePeer_Mode then
+ if not Bind_For_Library then
+ WBI (" s_stalib_adafinal;");
+ elsif Lib_Final_Built then
+ WBI (" finalize_library;");
+ else
+ WBI (" null;");
+ end if;
- -- If there is no finalization, there is nothing to do
+ -- Pragma Import C cannot be used on virtual targets, therefore call the
+ -- runtime finalization routine directly in CodePeer mode, where
+ -- imported functions are ignored.
- elsif Cumulative_Restrictions.Set (No_Finalization) then
- WBI (" null;");
else
- WBI (" Do_Finalize;");
+ WBI (" System.Standard_Library.Adafinal;");
end if;
WBI (" end " & Ada_Final_Name.all & ";");
- end Gen_Adafinal_Ada;
-
- --------------------
- -- Gen_Adafinal_C --
- --------------------
-
- procedure Gen_Adafinal_C is
- begin
- WBI ("void " & Ada_Final_Name.all & " (void) {");
- WBI (" system__standard_library__adafinal ();");
- WBI ("}");
WBI ("");
- end Gen_Adafinal_C;
+ end Gen_Adafinal;
- ---------------------
- -- Gen_Adainit_Ada --
- ---------------------
+ -----------------
+ -- Gen_Adainit --
+ -----------------
- procedure Gen_Adainit_Ada is
+ procedure Gen_Adainit (Elab_Order : Unit_Id_Array) is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
+ Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
begin
- WBI (" procedure " & Ada_Init_Name.all & " is");
-
- -- Generate externals for elaboration entities
-
- for E in Elab_Order.First .. Elab_Order.Last loop
- declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
- U : Unit_Record renames Units.Table (Unum);
-
- begin
- -- Check for Elab_Entity to be set for this unit
-
- if U.Set_Elab_Entity
+ -- Declare the access-to-subprogram type used for initialization of
+ -- of __gnat_finalize_library_objects. This is declared at library
+ -- level for compatibility with the type used in System.Soft_Links.
+ -- The import of the soft link which performs library-level object
+ -- finalization does not work for CodePeer, so regular Ada is used in
+ -- that case. For restricted run-time libraries (ZFP and Ravenscar)
+ -- tasks are non-terminating, so we do not want finalization.
+
+ if not Suppress_Standard_Library_On_Target
+ and then not CodePeer_Mode
+ and then not Configurable_Run_Time_On_Target
+ then
+ WBI (" type No_Param_Proc is access procedure;");
+ WBI ("");
+ end if;
- -- Don't generate reference for stand alone library
+ WBI (" procedure " & Ada_Init_Name.all & " is");
- and then not U.SAL_Interface
+ -- In CodePeer mode, simplify adainit procedure by only calling
+ -- elaboration procedures.
- -- Don't generate reference for predefined file in No_Run_Time
- -- mode, since we don't include the object files in this case
+ if CodePeer_Mode then
+ WBI (" begin");
- 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);
+ -- If the standard library is suppressed, then the only global variables
+ -- that might be needed (by the Ravenscar profile) are the priority and
+ -- the processor for the environment task.
- 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;
+ elsif Suppress_Standard_Library_On_Target then
+ if Main_Priority /= No_Main_Priority then
+ WBI (" Main_Priority : Integer;");
+ WBI (" pragma Import (C, Main_Priority," &
+ " ""__gl_main_priority"");");
+ WBI ("");
+ end if;
- Set_String ("E");
- Set_Unit_Number (Unum);
- Set_String (", """);
- Get_Name_String (U.Uname);
+ if Main_CPU /= No_Main_CPU then
+ WBI (" Main_CPU : Integer;");
+ WBI (" pragma Import (C, Main_CPU," &
+ " ""__gl_main_cpu"");");
+ WBI ("");
+ end if;
- -- In the case of JGNAT we need to emit an Import name
- -- that includes the class name (using '$' separators
- -- in the case of a child unit name).
-
- if VM_Target /= No_VM then
- for J in 1 .. Name_Len - 2 loop
- if VM_Target = CLI_Target
- or else Name_Buffer (J) /= '.'
- then
- Set_Char (Name_Buffer (J));
- else
- Set_String ("$");
- end if;
- end loop;
+ if System_Interrupts_Used
+ and then Partition_Elaboration_Policy_Specified = 'S'
+ then
+ WBI (" procedure Install_Restricted_Handlers_Sequential;");
+ WBI (" pragma Import (C," &
+ "Install_Restricted_Handlers_Sequential," &
+ " ""__gnat_attach_all_handlers"");");
+ WBI ("");
+ end if;
- if VM_Target /= CLI_Target or else U.Unit_Kind = 's' then
- Set_String (".");
- else
- Set_String ("_pkg.");
- end if;
+ if System_Tasking_Restricted_Stages_Used
+ and then Partition_Elaboration_Policy_Specified = 'S'
+ then
+ WBI (" Partition_Elaboration_Policy : Character;");
+ WBI (" pragma Import (C, Partition_Elaboration_Policy," &
+ " ""__gnat_partition_elaboration_policy"");");
+ WBI ("");
+ WBI (" procedure Activate_All_Tasks_Sequential;");
+ WBI (" pragma Import (C, Activate_All_Tasks_Sequential," &
+ " ""__gnat_activate_all_tasks"");");
+ WBI ("");
+ end if;
- -- If the unit name is very long, then split the
- -- Import link name across lines using "&" (occurs
- -- in some C2 tests).
+ if System_BB_CPU_Primitives_Multiprocessors_Used then
+ WBI (" procedure Start_Slave_CPUs;");
+ WBI (" pragma Import (C, Start_Slave_CPUs," &
+ " ""__gnat_start_slave_cpus"");");
+ WBI ("");
+ end if;
- if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then
- Set_String (""" &");
- Write_Statement_Buffer;
- Set_String (" """);
- end if;
- end if;
+ -- A restricted run-time may attempt to initialize the main task's
+ -- secondary stack even if the stack is not used. Consequently,
+ -- the binder needs to initialize Binder_Sec_Stacks_Count anytime
+ -- System.Secondary_Stack is in the enclosure of the partition.
- Set_Unit_Name;
- Set_String ("_E"");");
- Write_Statement_Buffer;
- end if;
- end;
- end loop;
+ if System_Secondary_Stack_Used then
+ WBI (" Binder_Sec_Stacks_Count : Natural;");
+ WBI (" pragma Import (Ada, Binder_Sec_Stacks_Count, " &
+ """__gnat_binder_ss_count"");");
+ WBI ("");
+ end if;
- Write_Statement_Buffer;
+ if Sec_Stack_Used then
+ WBI (" Default_Secondary_Stack_Size : " &
+ "System.Parameters.Size_Type;");
+ WBI (" pragma Import (C, Default_Secondary_Stack_Size, " &
+ """__gnat_default_ss_size"");");
- -- 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.
+ WBI (" Default_Sized_SS_Pool : System.Address;");
+ WBI (" pragma Import (Ada, Default_Sized_SS_Pool, " &
+ """__gnat_default_ss_pool"");");
- if Suppress_Standard_Library_On_Target then
- if Main_Priority /= No_Main_Priority then
- WBI (" Main_Priority : Integer;");
- WBI (" pragma Import (C, Main_Priority," &
- " ""__gl_main_priority"");");
WBI ("");
end if;
Set_Int (Main_Priority);
Set_Char (';');
Write_Statement_Buffer;
+ end if;
+
+ if Main_CPU /= No_Main_CPU then
+ Set_String (" Main_CPU := ");
+ Set_Int (Main_CPU);
+ Set_Char (';');
+ Write_Statement_Buffer;
+ end if;
- else
+ if System_Tasking_Restricted_Stages_Used
+ and then Partition_Elaboration_Policy_Specified = 'S'
+ then
+ Set_String (" Partition_Elaboration_Policy := '");
+ Set_Char (Partition_Elaboration_Policy_Specified);
+ Set_String ("';");
+ Write_Statement_Buffer;
+ end if;
+
+ if Main_Priority = No_Main_Priority
+ and then Main_CPU = No_Main_CPU
+ and then not System_Tasking_Restricted_Stages_Used
+ then
WBI (" null;");
end if;
+ -- Generate default-sized secondary stack pool and set secondary
+ -- stack globals.
+
+ if Sec_Stack_Used then
+
+ -- Elaborate the body of the binder to initialize the default-
+ -- sized secondary stack pool.
+
+ WBI ("");
+ WBI (" " & Get_Ada_Main_Name & "'Elab_Body;");
+
+ -- Generate the default-sized secondary stack pool and set the
+ -- related secondary stack globals.
+
+ Set_String (" Default_Secondary_Stack_Size := ");
+
+ if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then
+ Set_Int (Opt.Default_Sec_Stack_Size);
+ else
+ Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
+ end if;
+
+ Set_Char (';');
+ Write_Statement_Buffer;
+
+ Set_String (" Binder_Sec_Stacks_Count := ");
+ Set_Int (Num_Sec_Stacks);
+ Set_Char (';');
+ Write_Statement_Buffer;
+
+ WBI (" Default_Sized_SS_Pool := " &
+ "Sec_Default_Sized_Stacks'Address;");
+ WBI ("");
+
+ -- When a restricted run-time initializes the main task's secondary
+ -- stack but the program does not use it, no secondary stack is
+ -- generated. Binder_Sec_Stacks_Count is set to zero so the run-time
+ -- is aware that the lack of pre-allocated secondary stack is
+ -- expected.
+
+ elsif System_Secondary_Stack_Used then
+ WBI (" Binder_Sec_Stacks_Count := 0;");
+ end if;
+
-- Normal case (standard library not suppressed). Set all global values
-- used by the run time.
WBI (" Num_Specific_Dispatching : Integer;");
WBI (" pragma Import (C, Num_Specific_Dispatching, " &
"""__gl_num_specific_dispatching"");");
+ WBI (" Main_CPU : Integer;");
+ WBI (" pragma Import (C, Main_CPU, " &
+ """__gl_main_cpu"");");
WBI (" Interrupt_States : System.Address;");
WBI (" pragma Import (C, Interrupt_States, " &
WBI (" pragma Import (C, Unreserve_All_Interrupts, " &
"""__gl_unreserve_all_interrupts"");");
- if Exception_Tracebacks then
+ if Exception_Tracebacks or Exception_Tracebacks_Symbolic then
WBI (" Exception_Tracebacks : Integer;");
WBI (" pragma Import (C, Exception_Tracebacks, " &
"""__gl_exception_tracebacks"");");
+
+ if Exception_Tracebacks_Symbolic then
+ WBI (" Exception_Tracebacks_Symbolic : Integer;");
+ WBI (" pragma Import (C, Exception_Tracebacks_Symbolic, " &
+ """__gl_exception_tracebacks_symbolic"");");
+ end if;
end if;
- 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"");");
+
+ if Sec_Stack_Used then
+ WBI (" Default_Secondary_Stack_Size : " &
+ "System.Parameters.Size_Type;");
+ WBI (" pragma Import (C, Default_Secondary_Stack_Size, " &
+ """__gnat_default_ss_size"");");
+ end if;
+
WBI (" Leap_Seconds_Support : Integer;");
WBI (" pragma Import (C, Leap_Seconds_Support, " &
"""__gl_leap_seconds_support"");");
+ WBI (" Bind_Env_Addr : System.Address;");
+ WBI (" pragma Import (C, Bind_Env_Addr, " &
+ """__gl_bind_env_addr"");");
-- Import entry point for elaboration time signal handler
-- installation, and indication of if it's been called previously.
WBI ("");
- WBI (" procedure Install_Handler;");
- WBI (" pragma Import (C, Install_Handler, " &
- """__gnat_install_handler"");");
- WBI ("");
- WBI (" Handler_Installed : Integer;");
- WBI (" pragma Import (C, Handler_Installed, " &
- """__gnat_handler_installed"");");
+ WBI (" procedure Runtime_Initialize " &
+ "(Install_Handler : Integer);");
+ WBI (" pragma Import (C, Runtime_Initialize, " &
+ """__gnat_runtime_initialize"");");
- -- Import entry point for environment feature enable/disable
- -- routine, and indication that it's been called previously.
+ -- Import handlers attach procedure for sequential elaboration policy
- if OpenVMS_On_Target then
+ if System_Interrupts_Used
+ and then Partition_Elaboration_Policy_Specified = 'S'
+ then
+ WBI (" procedure Install_Restricted_Handlers_Sequential;");
+ WBI (" pragma Import (C," &
+ "Install_Restricted_Handlers_Sequential," &
+ " ""__gnat_attach_all_handlers"");");
WBI ("");
- WBI (" procedure Set_Features;");
- WBI (" pragma Import (C, Set_Features, " &
- """__gnat_set_features"");");
+ end if;
+
+ -- Import task activation procedure for sequential elaboration
+ -- policy.
+
+ if System_Tasking_Restricted_Stages_Used
+ and then Partition_Elaboration_Policy_Specified = 'S'
+ then
+ WBI (" Partition_Elaboration_Policy : Character;");
+ WBI (" pragma Import (C, Partition_Elaboration_Policy," &
+ " ""__gnat_partition_elaboration_policy"");");
WBI ("");
- WBI (" Features_Set : Integer;");
- WBI (" pragma Import (C, Features_Set, " &
- """__gnat_features_set"");");
+ WBI (" procedure Activate_All_Tasks_Sequential;");
+ WBI (" pragma Import (C, Activate_All_Tasks_Sequential," &
+ " ""__gnat_activate_all_tasks"");");
+ end if;
- if Opt.Heap_Size /= 0 then
- WBI ("");
- WBI (" Heap_Size : Integer;");
- WBI (" pragma Import (C, Heap_Size, " &
- """__gl_heap_size"");");
+ -- Import procedure to start slave cpus for bareboard runtime
- Write_Statement_Buffer;
- end if;
+ if System_BB_CPU_Primitives_Multiprocessors_Used then
+ WBI (" procedure Start_Slave_CPUs;");
+ WBI (" pragma Import (C, Start_Slave_CPUs," &
+ " ""__gnat_start_slave_cpus"");");
+ end if;
+
+ -- For restricted run-time libraries (ZFP and Ravenscar)
+ -- tasks are non-terminating, so we do not want finalization.
+
+ if not Configurable_Run_Time_On_Target then
+ WBI ("");
+ WBI (" Finalize_Library_Objects : No_Param_Proc;");
+ WBI (" pragma Import (C, Finalize_Library_Objects, " &
+ """__gnat_finalize_library_objects"");");
end if;
-- Initialize stack limit variable of the environment task if the
"""__gnat_initialize_stack_limit"");");
end if;
- -- Special processing when main program is CIL function/procedure
+ -- When dispatching domains are used then we need to signal it
+ -- before calling the main procedure.
- if VM_Target = CLI_Target
- and then Bind_Main_Program
- and then not No_Main_Subprogram
- then
- WBI ("");
+ if Dispatching_Domains_Used then
+ WBI (" procedure Freeze_Dispatching_Domains;");
+ WBI (" pragma Import");
+ WBI (" (Ada, Freeze_Dispatching_Domains, "
+ & """__gnat_freeze_dispatching_domains"");");
+ end if;
- -- Function case, use Set_Exit_Status to report the returned
- -- status code, since that is the only mechanism available.
+ -- Secondary stack global variables
- if ALIs.Table (ALIs.First).Main_Program = Func then
- WBI (" Result : Integer;");
- WBI (" procedure Set_Exit_Status (Code : Integer);");
- WBI (" pragma Import (C, Set_Exit_Status, " &
- """__gnat_set_exit_status"");");
- WBI ("");
- WBI (" function Ada_Main_Program return Integer;");
+ WBI (" Binder_Sec_Stacks_Count : Natural;");
+ WBI (" pragma Import (Ada, Binder_Sec_Stacks_Count, " &
+ """__gnat_binder_ss_count"");");
- -- Procedure case
+ WBI (" Default_Sized_SS_Pool : System.Address;");
+ WBI (" pragma Import (Ada, Default_Sized_SS_Pool, " &
+ """__gnat_default_ss_pool"");");
- else
- WBI (" procedure Ada_Main_Program;");
- end if;
+ WBI ("");
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- Name_Len := Name_Len - 2;
- WBI (" pragma Import (CIL, Ada_Main_Program, """
- & Name_Buffer (1 .. Name_Len) & "."
- & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);");
- end if;
+ -- Start of processing for Adainit
WBI (" begin");
+ WBI (" if Is_Elaborated then");
+ WBI (" return;");
+ WBI (" end if;");
+ WBI (" Is_Elaborated := True;");
+
+ -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if
+ -- restriction No_Standard_Allocators_After_Elaboration is active.
+
+ if Cumulative_Restrictions.Set
+ (No_Standard_Allocators_After_Elaboration)
+ then
+ WBI (" System.Elaboration_Allocators."
+ & "Mark_Start_Of_Elaboration;");
+ end if;
+
+ -- Generate assignments to initialize globals
Set_String (" Main_Priority := ");
Set_Int (Main_Priority);
Set_String ("';");
Write_Statement_Buffer;
- Gen_Restrictions_Ada;
+ if System_Tasking_Restricted_Stages_Used
+ and then Partition_Elaboration_Policy_Specified = 'S'
+ then
+ Set_String (" Partition_Elaboration_Policy := '");
+ Set_Char (Partition_Elaboration_Policy_Specified);
+ Set_String ("';");
+ Write_Statement_Buffer;
+ end if;
+
+ Gen_Restrictions;
WBI (" Priority_Specific_Dispatching :=");
WBI (" Local_Priority_Specific_Dispatching'Address;");
Set_Char (';');
Write_Statement_Buffer;
+ Set_String (" Main_CPU := ");
+ Set_Int (Main_CPU);
+ Set_Char (';');
+ Write_Statement_Buffer;
+
WBI (" Interrupt_States := Local_Interrupt_States'Address;");
Set_String (" Num_Interrupt_States := ");
Set_Char (';');
Write_Statement_Buffer;
- if Exception_Tracebacks then
+ if Exception_Tracebacks or Exception_Tracebacks_Symbolic 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");
+ if Exception_Tracebacks_Symbolic then
+ WBI (" Exception_Tracebacks_Symbolic := 1;");
+ end if;
end if;
- Set_String (";");
- Write_Statement_Buffer;
-
Set_String (" Detect_Blocking := ");
if Detect_Blocking then
Set_String (";");
Write_Statement_Buffer;
- -- Generate call to Install_Handler
- -- In .NET, when binding with -z, we don't install the signal
- -- handler to let the caller handle the last exception handler.
-
- if VM_Target /= CLI_Target
- or else Bind_Main_Program
- then
- WBI ("");
- WBI (" if Handler_Installed = 0 then");
- WBI (" Install_Handler;");
- WBI (" end if;");
+ if Bind_Env_String_Built then
+ WBI (" Bind_Env_Addr := Bind_Env'Address;");
end if;
- -- Generate call to Set_Features
+ WBI ("");
- if OpenVMS_On_Target then
- WBI ("");
- WBI (" if Features_Set = 0 then");
- WBI (" Set_Features;");
- WBI (" end if;");
+ -- Generate default-sized secondary stack pool and set secondary
+ -- stack globals.
- -- Features_Set may twiddle the heap size according to a logical
- -- name, but the binder switch must override.
+ if Sec_Stack_Used then
- if Opt.Heap_Size /= 0 then
- Set_String (" Heap_Size := ");
- Set_Int (Opt.Heap_Size);
- Set_Char (';');
- Write_Statement_Buffer;
+ -- Elaborate the body of the binder to initialize the default-
+ -- sized secondary stack pool.
+
+ WBI (" " & Get_Ada_Main_Name & "'Elab_Body;");
+
+ -- Generate the default-sized secondary stack pool and set the
+ -- related secondary stack globals.
+
+ Set_String (" Default_Secondary_Stack_Size := ");
+
+ if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then
+ Set_Int (Opt.Default_Sec_Stack_Size);
+ else
+ Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
+ end if;
+
+ Set_Char (';');
+ Write_Statement_Buffer;
+
+ Set_String (" Binder_Sec_Stacks_Count := ");
+ Set_Int (Num_Sec_Stacks);
+ Set_Char (';');
+ Write_Statement_Buffer;
+
+ Set_String (" Default_Sized_SS_Pool := ");
+
+ if Num_Sec_Stacks > 0 then
+ Set_String ("Sec_Default_Sized_Stacks'Address;");
+ else
+ Set_String ("System.Null_Address;");
end if;
+
+ Write_Statement_Buffer;
+ WBI ("");
end if;
+
+ -- Generate call to Runtime_Initialize
+
+ WBI (" Runtime_Initialize (1);");
end if;
-- Generate call to set Initialize_Scalar values if active
Write_Statement_Buffer;
end if;
- -- Generate assignment of default secondary stack size if set
-
- if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
- WBI ("");
- Set_String (" System.Secondary_Stack.");
- Set_String ("Default_Secondary_Stack_Size := ");
- Set_Int (Opt.Default_Sec_Stack_Size);
- Set_Char (';');
- Write_Statement_Buffer;
- end if;
-
- -- Initialize stack limit variable of the environment task if the
- -- stack check method is stack limit and stack check is enabled.
+ -- Initialize stack limit variable of the environment task if the stack
+ -- check method is stack limit and stack check is enabled.
if Stack_Check_Limits_On_Target
and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
WBI (" Initialize_Stack_Limit;");
end if;
- -- Generate elaboration calls
+ -- On CodePeer, the finalization of library objects is not relevant
- WBI ("");
- Gen_Elab_Calls_Ada;
+ if CodePeer_Mode then
+ null;
- -- Case of main program is CIL function or procedure
+ -- If this is the main program case, attach finalize_library to the soft
+ -- link. Do it only when not using a restricted run time, in which case
+ -- tasks are non-terminating, so we do not want library-level
+ -- finalization.
- if VM_Target = CLI_Target
- and then Bind_Main_Program
- and then not No_Main_Subprogram
+ elsif not Bind_For_Library
+ and then not Configurable_Run_Time_On_Target
+ and then not Suppress_Standard_Library_On_Target
then
- -- For function case, use Set_Exit_Status to set result
-
- if ALIs.Table (ALIs.First).Main_Program = Func then
- WBI (" Result := Ada_Main_Program;");
- WBI (" Set_Exit_Status (Result);");
-
- -- Procedure case
+ WBI ("");
+ if Lib_Final_Built then
+ Set_String (" Finalize_Library_Objects := ");
+ Set_String ("finalize_library'access;");
else
- WBI (" Ada_Main_Program;");
+ Set_String (" Finalize_Library_Objects := null;");
end if;
+
+ Write_Statement_Buffer;
end if;
- WBI (" end " & Ada_Init_Name.all & ";");
- end Gen_Adainit_Ada;
+ -- Generate elaboration calls
- -------------------
- -- Gen_Adainit_C --
- --------------------
+ if not CodePeer_Mode then
+ WBI ("");
+ end if;
- procedure Gen_Adainit_C is
- Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
+ Gen_Elab_Calls (Elab_Order);
- begin
- WBI ("void " & Ada_Init_Name.all & " (void)");
- WBI ("{");
+ if not CodePeer_Mode then
- -- Generate externals for elaboration entities
+ -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if
+ -- restriction No_Standard_Allocators_After_Elaboration is active.
- for E in Elab_Order.First .. Elab_Order.Last loop
- declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
- U : Unit_Record renames Units.Table (Unum);
+ if Cumulative_Restrictions.Set
+ (No_Standard_Allocators_After_Elaboration)
+ then
+ WBI
+ (" System.Elaboration_Allocators.Mark_End_Of_Elaboration;");
+ end if;
- begin
- -- 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;
- Set_String ("_E;");
- Write_Statement_Buffer;
- end if;
- end;
- end loop;
+ -- From this point, no new dispatching domain can be created
- Write_Statement_Buffer;
-
- -- Standard library suppressed
-
- if Suppress_Standard_Library_On_Target then
-
- -- Case of High_Integrity_Mode mode. Set __gl_main_priority if needed
- -- for the Ravenscar profile.
-
- if Main_Priority /= No_Main_Priority then
- WBI (" extern int __gl_main_priority;");
- Set_String (" __gl_main_priority = ");
- Set_Int (Main_Priority);
- Set_Char (';');
- Write_Statement_Buffer;
+ if Dispatching_Domains_Used then
+ WBI (" Freeze_Dispatching_Domains;");
end if;
- -- Normal case (standard library not suppressed)
-
- else
- -- Generate definition for interrupt states string
-
- Set_String (" static const char *local_interrupt_states = """);
-
- for J in 0 .. IS_Pragma_Settings.Last loop
- Set_Char (IS_Pragma_Settings.Table (J));
- end loop;
-
- Set_String (""";");
- Write_Statement_Buffer;
-
- -- Generate definition for priority specific dispatching string
-
- Set_String
- (" static const char *local_priority_specific_dispatching = """);
+ -- Sequential partition elaboration policy
- for J in 0 .. PSD_Pragma_Settings.Last loop
- Set_Char (PSD_Pragma_Settings.Table (J));
- end loop;
-
- Set_String (""";");
- Write_Statement_Buffer;
-
- -- Generate declaration for secondary stack default if needed
+ if Partition_Elaboration_Policy_Specified = 'S' then
+ if System_Interrupts_Used then
+ WBI (" Install_Restricted_Handlers_Sequential;");
+ end if;
- if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
- WBI (" extern int system__secondary_stack__" &
- "default_secondary_stack_size;");
+ if System_Tasking_Restricted_Stages_Used then
+ WBI (" Activate_All_Tasks_Sequential;");
+ end if;
end if;
- WBI ("");
-
- -- 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 (" extern int __gl_main_priority;");
- Set_String (" __gl_main_priority = ");
- Set_Int (Main_Priority);
- Set_Char (';');
- Write_Statement_Buffer;
-
- 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
- then
- Set_Int (0);
- else
- Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);
+ if System_BB_CPU_Primitives_Multiprocessors_Used then
+ WBI (" Start_Slave_CPUs;");
end if;
+ end if;
- Set_Char (';');
- Write_Statement_Buffer;
-
- WBI (" extern char __gl_wc_encoding;");
- Set_String (" __gl_wc_encoding = '");
- Set_Char (Get_WC_Encoding);
-
- Set_String ("';");
- Write_Statement_Buffer;
-
- WBI (" extern char __gl_locking_policy;");
- Set_String (" __gl_locking_policy = '");
- Set_Char (Locking_Policy_Specified);
- Set_String ("';");
- Write_Statement_Buffer;
-
- WBI (" extern char __gl_queuing_policy;");
- Set_String (" __gl_queuing_policy = '");
- Set_Char (Queuing_Policy_Specified);
- Set_String ("';");
- Write_Statement_Buffer;
-
- WBI (" extern char __gl_task_dispatching_policy;");
- Set_String (" __gl_task_dispatching_policy = '");
- Set_Char (Task_Dispatching_Policy_Specified);
- Set_String ("';");
- Write_Statement_Buffer;
-
- Gen_Restrictions_C;
-
- WBI (" extern const void *__gl_interrupt_states;");
- WBI (" __gl_interrupt_states = local_interrupt_states;");
-
- WBI (" extern int __gl_num_interrupt_states;");
- Set_String (" __gl_num_interrupt_states = ");
- Set_Int (IS_Pragma_Settings.Last + 1);
- Set_String (";");
- Write_Statement_Buffer;
-
- 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;
-
- 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;
+ WBI (" end " & Ada_Init_Name.all & ";");
+ WBI ("");
+ end Gen_Adainit;
- if Exception_Tracebacks then
- WBI (" extern int __gl_exception_tracebacks;");
- WBI (" __gl_exception_tracebacks = 1;");
- end if;
+ -------------------------
+ -- Gen_Bind_Env_String --
+ -------------------------
- WBI (" extern int __gl_zero_cost_exceptions;");
- Set_String (" __gl_zero_cost_exceptions = ");
- Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
- Set_String (";");
- Write_Statement_Buffer;
+ procedure Gen_Bind_Env_String is
+ procedure Write_Name_With_Len (Nam : Name_Id);
+ -- Write Nam as a string literal, prefixed with one
+ -- character encoding Nam's length.
- WBI (" extern int __gl_detect_blocking;");
- Set_String (" __gl_detect_blocking = ");
+ -------------------------
+ -- Write_Name_With_Len --
+ -------------------------
- if Detect_Blocking then
- Set_Int (1);
- else
- Set_Int (0);
- end if;
+ procedure Write_Name_With_Len (Nam : Name_Id) is
+ begin
+ Get_Name_String (Nam);
- Set_String (";");
- Write_Statement_Buffer;
+ Start_String;
+ Store_String_Char (Character'Val (Name_Len));
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
- WBI (" extern int __gl_default_stack_size;");
- Set_String (" __gl_default_stack_size = ");
- Set_Int (Default_Stack_Size);
- Set_String (";");
- Write_Statement_Buffer;
+ Write_String_Table_Entry (End_String);
+ end Write_Name_With_Len;
- WBI (" extern int __gl_leap_seconds_support;");
- Set_String (" __gl_leap_seconds_support = ");
+ -- Local variables
- if Leap_Seconds_Support then
- Set_Int (1);
- else
- Set_Int (0);
- end if;
+ Amp : Character;
+ KN : Name_Id := No_Name;
+ VN : Name_Id := No_Name;
- Set_String (";");
- Write_Statement_Buffer;
+ -- Start of processing for Gen_Bind_Env_String
- WBI ("");
+ begin
+ Bind_Environment.Get_First (KN, VN);
- -- Install elaboration time signal handler
+ if VN = No_Name then
+ return;
+ end if;
- WBI (" if (__gnat_handler_installed == 0)");
- WBI (" {");
- WBI (" __gnat_install_handler ();");
- WBI (" }");
+ Set_Special_Output (Write_Bind_Line'Access);
- -- Call feature enable/disable routine
+ WBI (" Bind_Env : aliased constant String :=");
+ Amp := ' ';
+ while VN /= No_Name loop
+ Write_Str (" " & Amp & ' ');
+ Write_Name_With_Len (KN);
+ Write_Str (" & ");
+ Write_Name_With_Len (VN);
+ Write_Eol;
- if OpenVMS_On_Target then
- WBI (" if (__gnat_features_set == 0)");
- WBI (" {");
- WBI (" __gnat_set_features ();");
- WBI (" }");
- end if;
- end if;
+ Bind_Environment.Get_Next (KN, VN);
+ Amp := '&';
+ end loop;
+ WBI (" & ASCII.NUL;");
- -- Initialize stack limit for the environment task if the stack
- -- check method is stack limit and stack check is enabled.
+ Cancel_Special_Output;
- if Stack_Check_Limits_On_Target
- and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
- then
- WBI ("");
- WBI (" __gnat_initialize_stack_limit ();");
- end if;
+ Bind_Env_String_Built := True;
+ end Gen_Bind_Env_String;
- -- Generate call to set Initialize_Scalar values if needed
+ --------------------------
+ -- Gen_CodePeer_Wrapper --
+ --------------------------
- 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;
+ procedure Gen_CodePeer_Wrapper is
+ Callee_Name : constant String := "Ada_Main_Program";
- -- Generate assignment of default secondary stack size if set
+ begin
+ if ALIs.Table (ALIs.First).Main_Program = Proc then
+ WBI (" procedure " & CodePeer_Wrapper_Name & " is ");
+ WBI (" begin");
+ WBI (" " & Callee_Name & ";");
- 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;
+ else
+ WBI (" function " & CodePeer_Wrapper_Name & " return Integer is");
+ WBI (" begin");
+ WBI (" return " & Callee_Name & ";");
end if;
- -- Generate elaboration calls
-
+ WBI (" end " & CodePeer_Wrapper_Name & ";");
WBI ("");
- Gen_Elab_Calls_C;
- WBI ("}");
- end Gen_Adainit_C;
+ end Gen_CodePeer_Wrapper;
- ------------------------
- -- Gen_Elab_Calls_Ada --
- ------------------------
+ --------------------
+ -- Gen_Elab_Calls --
+ --------------------
+
+ procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array) is
+ Check_Elab_Flag : Boolean;
- procedure Gen_Elab_Calls_Ada is
begin
- for E in Elab_Order.First .. Elab_Order.Last loop
+ -- Loop through elaboration order entries
+
+ for E in Elab_Order'Range loop
declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
+ Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
Unum_Spec : Unit_Id;
if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
null;
+ -- Likewise if this is an interface to a stand alone library
+
+ elsif U.SAL_Interface then
+ null;
+
-- Case of no elaboration code
- elsif U.No_Elab then
+ elsif U.No_Elab
- -- The only case in which we have to do something is if
- -- this is a body, with a separate spec, where the separate
- -- spec has an elaboration entity defined.
+ -- In CodePeer mode, we special case subprogram bodies which
+ -- are handled in the 'else' part below, and lead to a call
+ -- to <subp>'Elab_Subp_Body.
- -- In that case, this is where we set the elaboration entity
- -- to True, we do not need to test if this has already been
- -- done, since it is quicker to set the flag than to test it.
+ and then (not CodePeer_Mode
- if not U.SAL_Interface and then U.Utype = Is_Body
+ -- Test for spec
+
+ or else U.Utype = Is_Spec
+ or else U.Utype = Is_Spec_Only
+ or else U.Unit_Kind /= 's')
+ then
+ -- In the case of a body with a separate spec, where the
+ -- separate spec has an elaboration entity defined, this is
+ -- where we increment the elaboration entity if one exists.
+
+ -- Likewise for lone specs with an elaboration entity defined
+ -- despite No_Elaboration_Code, e.g. when requested to preserve
+ -- control flow.
+
+ if (U.Utype = Is_Body or else U.Utype = Is_Spec_Only)
and then Units.Table (Unum_Spec).Set_Elab_Entity
+ and then not CodePeer_Mode
then
Set_String (" E");
Set_Unit_Number (Unum_Spec);
- Set_String (" := True;");
+ Set_String (" := E");
+ Set_Unit_Number (Unum_Spec);
+ Set_String (" + 1;");
Write_Statement_Buffer;
end if;
-- 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
+ -- if uname_E = 0 then
-- uname'elab_[spec|body];
- -- uname_E := True;
-- end if;
+ -- uname_E := uname_E + 1;
-- Otherwise, elaboration routines are called unconditionally:
-- uname'elab_[spec|body];
- -- uname_E := True;
+ -- uname_E := uname_E + 1;
+
+ -- The uname_E increment is skipped if this is a separate spec,
+ -- since it will be done when we process the body.
- -- The uname_E assignment is skipped if this is a separate spec,
- -- since the assignment will be done when we process the body.
+ -- In CodePeer mode, we do not generate any reference to xxx_E
+ -- variables, only calls to 'Elab* subprograms.
- elsif not U.SAL_Interface then
- if Force_Checking_Of_Elaboration_Flags or
- Interface_Library_Unit or
- (not Bind_Main_Program)
+ else
+ -- Check incompatibilities with No_Multiple_Elaboration
+
+ if not CodePeer_Mode
+ and then Cumulative_Restrictions.Set (No_Multiple_Elaboration)
then
- Set_String (" if not E");
+ -- Force_Checking_Of_Elaboration_Flags (-F) not allowed
+
+ if Force_Checking_Of_Elaboration_Flags then
+ Osint.Fail
+ ("-F (force elaboration checks) switch not allowed "
+ & "with restriction No_Multiple_Elaboration active");
+
+ -- Interfacing of libraries not allowed
+
+ elsif Interface_Library_Unit then
+ Osint.Fail
+ ("binding of interfaced libraries not allowed "
+ & "with restriction No_Multiple_Elaboration active");
+
+ -- Non-Ada main program not allowed
+
+ elsif not Bind_Main_Program then
+ Osint.Fail
+ ("non-Ada main program not allowed "
+ & "with restriction No_Multiple_Elaboration active");
+ end if;
+ end if;
+
+ -- OK, see if we need to test elaboration flag
+
+ Check_Elab_Flag :=
+ Units.Table (Unum_Spec).Set_Elab_Entity
+ and then not CodePeer_Mode
+ and then (Force_Checking_Of_Elaboration_Flags
+ or Interface_Library_Unit
+ or not Bind_Main_Program);
+
+ if Check_Elab_Flag then
+ Set_String (" if E");
Set_Unit_Number (Unum_Spec);
- Set_String (" then");
+ Set_String (" = 0 then");
Write_Statement_Buffer;
Set_String (" ");
end if;
Set_String (" ");
Get_Decoded_Name_String_With_Brackets (U.Uname);
- 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;
+ if Name_Buffer (Name_Len) = 's' then
+ Name_Buffer (Name_Len - 1 .. Name_Len + 8) :=
+ "'elab_spec";
+ Name_Len := Name_Len + 8;
- Name_Len := Name_Len + 12;
+ -- Special case in CodePeer mode for subprogram bodies
+ -- which correspond to CodePeer 'Elab_Subp_Body special
+ -- init procedure.
- else
- 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;
+ elsif U.Unit_Kind = 's' and CodePeer_Mode then
+ Name_Buffer (Name_Len - 1 .. Name_Len + 13) :=
+ "'elab_subp_body";
+ Name_Len := Name_Len + 13;
+ else
+ Name_Buffer (Name_Len - 1 .. Name_Len + 8) :=
+ "'elab_body";
Name_Len := Name_Len + 8;
end if;
Set_Char (';');
Write_Statement_Buffer;
- if U.Utype /= Is_Spec then
- if Force_Checking_Of_Elaboration_Flags or
- Interface_Library_Unit or
- (not Bind_Main_Program)
- then
- Set_String (" ");
- end if;
+ if Check_Elab_Flag then
+ WBI (" end if;");
+ end if;
+ if U.Utype /= Is_Spec
+ and then not CodePeer_Mode
+ and then Units.Table (Unum_Spec).Set_Elab_Entity
+ then
Set_String (" E");
Set_Unit_Number (Unum_Spec);
- Set_String (" := True;");
+ Set_String (" := E");
+ Set_Unit_Number (Unum_Spec);
+ Set_String (" + 1;");
Write_Statement_Buffer;
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;
+ end Gen_Elab_Calls;
- ----------------------
- -- Gen_Elab_Calls_C --
- ----------------------
+ ------------------------
+ -- Gen_Elab_Externals --
+ ------------------------
- procedure Gen_Elab_Calls_C is
+ procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array) is
begin
- for E in Elab_Order.First .. Elab_Order.Last loop
+ if CodePeer_Mode then
+ return;
+ end if;
+
+ for E in Elab_Order'Range loop
declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
+ Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
- Unum_Spec : Unit_Id;
- -- This is the unit number of the spec that corresponds to
- -- this entry. It is the same as Unum except when the body
- -- and spec are different and we are currently processing
- -- the body, in which case it is the spec (Unum + 1).
-
begin
- if U.Utype = Is_Body then
- Unum_Spec := Unum + 1;
- else
- Unum_Spec := Unum;
+ -- 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
+ Get_Name_String (U.Sfile);
+ Set_String (" ");
+ Set_String ("E");
+ Set_Unit_Number (Unum);
+ Set_String (" : Short_Integer; pragma Import (Ada, E");
+ Set_Unit_Number (Unum);
+ Set_String (", """);
+ Get_Name_String (U.Uname);
+ Set_Unit_Name;
+ Set_String ("_E"");");
+ Write_Statement_Buffer;
+ end if;
+ end;
+ end loop;
+
+ WBI ("");
+ end Gen_Elab_Externals;
+
+ --------------------
+ -- Gen_Elab_Order --
+ --------------------
+
+ procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array) is
+ begin
+ WBI ("");
+ WBI (" -- BEGIN ELABORATION ORDER");
+
+ for J in Elab_Order'Range loop
+ Set_String (" -- ");
+ Get_Name_String (Units.Table (Elab_Order (J)).Uname);
+ Set_Name_Buffer;
+ Write_Statement_Buffer;
+ end loop;
+
+ WBI (" -- END ELABORATION ORDER");
+ end Gen_Elab_Order;
+
+ --------------------------
+ -- Gen_Finalize_Library --
+ --------------------------
+
+ procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array) is
+ procedure Gen_Header;
+ -- Generate the header of the finalization routine
+
+ ----------------
+ -- Gen_Header --
+ ----------------
+
+ procedure Gen_Header is
+ begin
+ WBI (" procedure finalize_library is");
+ WBI (" begin");
+ end Gen_Header;
+
+ -- Local variables
+
+ Count : Int := 1;
+ U : Unit_Record;
+ Uspec : Unit_Record;
+ Unum : Unit_Id;
+
+ -- Start of processing for Gen_Finalize_Library
+
+ begin
+ if CodePeer_Mode then
+ return;
+ end if;
+
+ for E in reverse Elab_Order'Range loop
+ Unum := Elab_Order (E);
+ U := Units.Table (Unum);
+
+ -- Dealing with package bodies is a little complicated. In such
+ -- cases we must retrieve the package spec since it contains the
+ -- spec of the body finalizer.
+
+ if U.Utype = Is_Body then
+ Unum := Unum + 1;
+ Uspec := Units.Table (Unum);
+ else
+ Uspec := U;
+ end if;
+
+ Get_Name_String (Uspec.Uname);
+
+ -- We are only interested in non-generic packages
+
+ if U.Unit_Kind /= 'p' or else U.Is_Generic then
+ null;
+
+ -- That aren't an interface to a stand alone library
+
+ elsif U.SAL_Interface then
+ null;
+
+ -- Case of no finalization
+
+ elsif not U.Has_Finalizer then
+
+ -- The only case in which we have to do something is if this
+ -- is a body, with a separate spec, where the separate spec
+ -- has a finalizer. In that case, this is where we decrement
+ -- the elaboration entity.
+
+ if U.Utype = Is_Body and then Uspec.Has_Finalizer then
+ if not Lib_Final_Built then
+ Gen_Header;
+ Lib_Final_Built := True;
+ end if;
+
+ Set_String (" E");
+ Set_Unit_Number (Unum);
+ Set_String (" := E");
+ Set_Unit_Number (Unum);
+ Set_String (" - 1;");
+ Write_Statement_Buffer;
+ end if;
+
+ else
+ if not Lib_Final_Built then
+ Gen_Header;
+ Lib_Final_Built := True;
end if;
- -- Nothing to do if predefined unit in no run time mode
+ -- Generate:
+ -- declare
+ -- procedure F<Count>;
- if No_Run_Time_Mode and then Is_Predefined_File_Name (U.Sfile) then
- null;
+ Set_String (" declare");
+ Write_Statement_Buffer;
- -- Case of no elaboration code
+ Set_String (" procedure F");
+ Set_Int (Count);
+ Set_Char (';');
+ Write_Statement_Buffer;
- elsif U.No_Elab then
+ -- Generate:
+ -- pragma Import (Ada, F<Count>,
+ -- "xx__yy__finalize_[body|spec]");
- -- The only case in which we have to do something is if
- -- this is a body, with a separate spec, where the separate
- -- spec has an elaboration entity defined.
+ Set_String (" pragma Import (Ada, F");
+ Set_Int (Count);
+ Set_String (", """);
- -- In that case, this is where we set the elaboration entity
- -- to True, we do not need to test if this has already been
- -- done, since it is quicker to set the flag than to test it.
+ -- Perform name construction
- if not U.SAL_Interface and then U.Utype = Is_Body
- and then Units.Table (Unum_Spec).Set_Elab_Entity
- then
- Set_String (" ");
- Get_Name_String (U.Uname);
- Set_Unit_Name;
- Set_String ("_E = 1;");
- Write_Statement_Buffer;
- end if;
+ Set_Unit_Name;
+ Set_String ("__finalize_");
- -- Here if elaboration code is present. If binding a library
- -- or if there is a non-Ada main subprogram then we generate:
+ -- Package spec processing
- -- if (uname_E == 0) {
- -- uname__elab[s|b] ();
- -- uname_E++;
- -- }
+ if U.Utype = Is_Spec
+ or else U.Utype = Is_Spec_Only
+ then
+ Set_String ("spec");
- -- The uname_E assignment is skipped if this is a separate spec,
- -- since the assignment will be done when we process the body.
+ -- Package body processing
- elsif not U.SAL_Interface then
- Get_Name_String (U.Uname);
+ else
+ Set_String ("body");
+ end if;
- 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 (""");");
+ Write_Statement_Buffer;
- Set_String (" ");
- Set_Unit_Name;
- Set_String ("___elab");
- Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
- Set_String (" ();");
- Write_Statement_Buffer;
+ -- If binding a library or if there is a non-Ada main subprogram
+ -- then we generate:
- if U.Utype /= Is_Spec then
- if Force_Checking_Of_Elaboration_Flags or
- Interface_Library_Unit or
- (not Bind_Main_Program)
- then
- Set_String (" ");
- end if;
+ -- begin
+ -- uname_E := uname_E - 1;
+ -- if uname_E = 0 then
+ -- F<Count>;
+ -- end if;
+ -- end;
- Set_String (" ");
- Set_Unit_Name;
- Set_String ("_E++;");
- Write_Statement_Buffer;
- end if;
+ -- Otherwise, finalization routines are called unconditionally:
- if Force_Checking_Of_Elaboration_Flags or
- Interface_Library_Unit or
- (not Bind_Main_Program)
- then
- WBI (" }");
- end if;
- end if;
- end;
- end loop;
+ -- begin
+ -- uname_E := uname_E - 1;
+ -- F<Count>;
+ -- end;
- end Gen_Elab_Calls_C;
+ -- The uname_E decrement is skipped if this is a separate spec,
+ -- since it will be done when we process the body.
- ----------------------
- -- Gen_Elab_Defs_C --
- ----------------------
+ WBI (" begin");
- procedure Gen_Elab_Defs_C is
- begin
- for E in Elab_Order.First .. Elab_Order.Last loop
+ if U.Utype /= Is_Spec then
+ Set_String (" E");
+ Set_Unit_Number (Unum);
+ Set_String (" := E");
+ Set_Unit_Number (Unum);
+ Set_String (" - 1;");
+ Write_Statement_Buffer;
+ end if;
- -- Generate declaration of elaboration procedure if elaboration
- -- needed. Note that passive units are always excluded.
+ if Interface_Library_Unit or not Bind_Main_Program then
+ Set_String (" if E");
+ Set_Unit_Number (Unum);
+ Set_String (" = 0 then");
+ Write_Statement_Buffer;
+ Set_String (" ");
+ end if;
- if not Units.Table (Elab_Order.Table (E)).No_Elab then
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
- Set_String ("extern void ");
- Set_Unit_Name;
- Set_String ("___elab");
- Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
- Set_String (" (void);");
+ Set_String (" F");
+ Set_Int (Count);
+ Set_Char (';');
Write_Statement_Buffer;
- end if;
+ if Interface_Library_Unit or not Bind_Main_Program then
+ WBI (" end if;");
+ end if;
+
+ WBI (" end;");
+
+ Count := Count + 1;
+ end if;
end loop;
- WBI ("");
- end Gen_Elab_Defs_C;
+ if Lib_Final_Built then
- ------------------------
- -- Gen_Elab_Order_Ada --
- ------------------------
+ -- It is possible that the finalization of a library-level object
+ -- raised an exception. In that case import the actual exception
+ -- and the routine necessary to raise it.
- procedure Gen_Elab_Order_Ada is
- begin
- WBI ("");
- WBI (" -- BEGIN ELABORATION ORDER");
+ WBI (" declare");
+ WBI (" procedure Reraise_Library_Exception_If_Any;");
- for J in Elab_Order.First .. Elab_Order.Last loop
- Set_String (" -- ");
- Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
- Set_Name_Buffer;
+ Set_String (" pragma Import (Ada, ");
+ Set_String ("Reraise_Library_Exception_If_Any, ");
+ Set_String ("""__gnat_reraise_library_exception_if_any"");");
Write_Statement_Buffer;
- end loop;
- WBI (" -- END ELABORATION ORDER");
- end Gen_Elab_Order_Ada;
+ WBI (" begin");
+ WBI (" Reraise_Library_Exception_If_Any;");
+ WBI (" end;");
+ WBI (" end finalize_library;");
+ WBI ("");
+ end if;
+ end Gen_Finalize_Library;
- ----------------------
- -- Gen_Elab_Order_C --
- ----------------------
+ --------------
+ -- Gen_Main --
+ --------------
- procedure Gen_Elab_Order_C is
+ procedure Gen_Main is
begin
- WBI ("");
- WBI ("/* BEGIN ELABORATION ORDER");
+ if not No_Main_Subprogram then
- for J in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
- Set_Name_Buffer;
- Write_Statement_Buffer;
- end loop;
+ -- To call the main program, we declare it using a pragma Import
+ -- Ada with the right link name.
- WBI (" END ELABORATION ORDER */");
- end Gen_Elab_Order_C;
+ -- It might seem more obvious to "with" the main program, and call
+ -- it in the normal Ada manner. We do not do this for three
+ -- reasons:
- ------------------
- -- Gen_Main_Ada --
- ------------------
+ -- 1. It is more efficient not to recompile the main program
+ -- 2. We are not entitled to assume the source is accessible
+ -- 3. We don't know what options to use to compile it
- procedure Gen_Main_Ada is
- begin
- WBI ("");
+ -- It is really reason 3 that is most critical (indeed we used
+ -- to generate the "with", but several regression tests failed).
+
+ if ALIs.Table (ALIs.First).Main_Program = Func then
+ WBI (" function Ada_Main_Program return Integer;");
+ else
+ WBI (" procedure Ada_Main_Program;");
+ end if;
+
+ Set_String (" pragma Import (Ada, Ada_Main_Program, """);
+ Get_Name_String (Units.Table (First_Unit_Entry).Uname);
+ Set_Main_Program_Name;
+ Set_String (""");");
+
+ Write_Statement_Buffer;
+ WBI ("");
+
+ -- For CodePeer, declare a wrapper for the user-defined main program
+
+ if CodePeer_Mode then
+ Gen_CodePeer_Wrapper;
+ end if;
+ end if;
if Exit_Status_Supported_On_Target then
Set_String (" function ");
-- Initialize and Finalize
- if not Cumulative_Restrictions.Set (No_Finalization) then
- WBI (" procedure initialize (Addr : System.Address);");
- WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
+ if not CodePeer_Mode
+ and then 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"");");
+ 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 we want to analyze the stack, we must import corresponding symbols
if Dynamic_Stack_Measurement then
WBI ("");
-- Deal with declarations for main program case
if not No_Main_Subprogram then
-
- -- To call the main program, we declare it using a pragma Import
- -- Ada with the right link name.
-
- -- It might seem more obvious to "with" the main program, and call
- -- it in the normal Ada manner. We do not do this for three reasons:
-
- -- 1. It is more efficient not to recompile the main program
- -- 2. We are not entitled to assume the source is accessible
- -- 3. We don't know what options to use to compile it
-
- -- It is really reason 3 that is most critical (indeed we used
- -- to generate the "with", but several regression tests failed).
-
- WBI ("");
-
if ALIs.Table (ALIs.First).Main_Program = Func then
WBI (" Result : Integer;");
WBI ("");
- WBI (" function Ada_Main_Program return Integer;");
-
- else
- WBI (" procedure Ada_Main_Program;");
end if;
- Set_String (" pragma Import (Ada, Ada_Main_Program, """);
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- Set_Main_Program_Name;
- Set_String (""");");
-
- Write_Statement_Buffer;
- WBI ("");
-
if Bind_Main_Program
- and then not Suppress_Standard_Library_On_Target
+ and not Suppress_Standard_Library_On_Target
+ and not CodePeer_Mode
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
- -- 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.
+ -- Generate a reference to 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.
-- 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 : aliased System.Address := " &
- "Ada_Main_Program_Name'Address;");
+ -- CodePeer and CCG do not need this extra code on the other hand.
+
+ if Bind_Main_Program
+ and then not CodePeer_Mode
+ and then not Generate_C_Code
+ then
+ WBI (" Ensure_Reference : aliased System.Address := " &
+ "Ada_Main_Program_Name'Address;");
WBI (" pragma Volatile (Ensure_Reference);");
WBI ("");
end if;
-- Acquire command line arguments if present on target
- if Command_Line_Args_On_Target then
+ if CodePeer_Mode then
+ null;
+
+ elsif 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.
+ -- 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;
else
WBI (" gnat_argc := 0;");
- WBI (" gnat_argv := System.Null_Address;");
- WBI (" gnat_envp := System.Null_Address;");
- end if;
-
- 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 & ";");
-
- if not No_Main_Subprogram then
- WBI (" Break_Start;");
-
- if ALIs.Table (ALIs.First).Main_Program = Proc then
- WBI (" Ada_Main_Program;");
- else
- WBI (" Result := Ada_Main_Program;");
- end if;
- end if;
-
- -- Adafinal call is skipped if no finalization
-
- 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 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 Cumulative_Restrictions.Set (No_Finalization) then
- WBI (" Finalize;");
- end if;
-
- -- 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;");
- end Gen_Main_Ada;
-
- ----------------
- -- Gen_Main_C --
- ----------------
-
- procedure Gen_Main_C is
- begin
- if Exit_Status_Supported_On_Target then
- WBI ("#include <stdlib.h>");
- Set_String ("int ");
- else
- Set_String ("void ");
- end if;
-
- Set_String (Get_Main_Name);
-
- -- Generate command line args in prototype if present on target
-
- if Command_Line_Args_On_Target then
- Write_Statement_Buffer (" (int argc, char **argv, char **envp)");
-
- -- Case of no command line arguments on target
-
- else
- Write_Statement_Buffer (" (void)");
- end if;
-
- 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.
-
- -- 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 * 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
-
- if ALIs.Table (ALIs.First).Main_Program = Func then
- WBI (" int result;");
- end if;
-
- -- Set command line argument values from parameters if command line
- -- arguments are present on target
-
- if Command_Line_Args_On_Target then
- WBI (" gnat_argc = argc;");
- WBI (" gnat_argv = argv;");
- WBI (" gnat_envp = envp;");
- WBI (" ");
-
- -- If configurable run-time, then nothing to do, since in this case
- -- the gnat_argc/argv/envp variables are entirely suppressed.
-
- elsif Configurable_Run_Time_On_Target then
- null;
-
- -- if no command line arguments on target, set dummy values
-
- else
- WBI (" gnat_argc = 0;");
- WBI (" gnat_argv = 0;");
- WBI (" gnat_envp = 0;");
+ WBI (" gnat_argv := System.Null_Address;");
+ WBI (" gnat_envp := System.Null_Address;");
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_String (" 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_String (" Initialize_Stack_Analysis (");
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
- if not No_Main_Subprogram and then Bind_Main_Program then
- WBI (" __gnat_initialize ((void *)SEH);");
+ if not Cumulative_Restrictions.Set (No_Finalization)
+ and then not CodePeer_Mode
+ 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 (" __gnat_initialize ((void *)0);");
+ WBI (" Initialize (System.Null_Address);");
end if;
end if;
- WBI (" " & Ada_Init_Name.all & " ();");
+ WBI (" " & Ada_Init_Name.all & ";");
if not No_Main_Subprogram then
- WBI (" __gnat_break_start ();");
- WBI (" ");
-
- -- Output main program name
-
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
-
- -- Main program is procedure case
-
- if ALIs.Table (ALIs.First).Main_Program = Proc then
- Set_String (" ");
- Set_Main_Program_Name;
- Set_String (" ();");
- Write_Statement_Buffer;
+ if CodePeer_Mode then
+ if ALIs.Table (ALIs.First).Main_Program = Proc then
+ WBI (" " & CodePeer_Wrapper_Name & ";");
+ else
+ WBI (" Result := " & CodePeer_Wrapper_Name & ";");
+ end if;
- -- Main program is function case
+ elsif ALIs.Table (ALIs.First).Main_Program = Proc then
+ WBI (" Ada_Main_Program;");
- else -- ALIs.Table (ALIs_First).Main_Program = Func
- Set_String (" result = ");
- Set_Main_Program_Name;
- Set_String (" ();");
- Write_Statement_Buffer;
+ else
+ WBI (" Result := Ada_Main_Program;");
end if;
-
end if;
- -- Call adafinal if finalization active
+ -- Adafinal call is skipped if no finalization
if not Cumulative_Restrictions.Set (No_Finalization) then
- WBI (" ");
- WBI (" system__standard_library__adafinal ();");
+ WBI (" adafinal;");
end if;
- -- Outputs the dynamic stack measurement if needed
+ -- Prints the result of static stack analysis
if Dynamic_Stack_Measurement then
- WBI (" __gnat_stack_usage_output_results ();");
+ WBI (" Output_Results;");
end if;
- -- The finalize routine is used only if we have a run-time
+ -- Finalize is only called if we have a run time
- if not Suppress_Standard_Library_On_Target then
- WBI (" __gnat_finalize ();");
+ if not Cumulative_Restrictions.Set (No_Finalization)
+ and then not CodePeer_Mode
+ then
+ WBI (" Finalize;");
end if;
- -- Case of main program is a function, so the value it returns
- -- is the exit status in this case.
-
- if ALIs.Table (ALIs.First).Main_Program = Func then
- if Exit_Status_Supported_On_Target then
-
- -- VMS must use Posix exit routine in order to get the effect
- -- of a Unix compatible setting of the program exit status.
- -- For all other systems, we use the standard exit routine.
-
- if OpenVMS_On_Target then
- WBI (" decc$__posix_exit (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
-
- -- 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.
+ -- Return result
- if OpenVMS_On_Target then
- WBI (" decc$__posix_exit (gnat_exit_status);");
- else
- WBI (" exit (gnat_exit_status);");
- end if;
+ 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 Gen_Main_C;
+ WBI (" end;");
+ WBI ("");
+ end Gen_Main;
------------------------------
-- Gen_Object_Files_Options --
------------------------------
- procedure Gen_Object_Files_Options is
+ procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array) is
Lgnat : Natural;
- -- This keeps track of the position in the sorted set of entries
- -- in the Linker_Options table of where the first entry from an
- -- internal file appears.
+ -- This keeps track of the position in the sorted set of entries 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
Write_Str (Name_Buffer (Start .. Stop - 1));
Write_Eol;
end if;
- Write_Info_Ada_C
- (" -- ", "", Name_Buffer (Start .. Stop - 1));
+ WBI (" -- " & Name_Buffer (Start .. Stop - 1));
end if;
Start := Stop + 1;
-- Start of processing for Gen_Object_Files_Options
begin
- WBI ("");
- Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list");
+ WBI ("-- BEGIN Object file/option list");
if Object_List_Filename /= null then
Set_List_File (Object_List_Filename.all);
end if;
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
-- 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)).SAL_Interface)
- and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
+ if not Units.Table (Elab_Order (E)).SAL_Interface
+ and then Units.Table (Elab_Order (E)).Utype /= Is_Spec
then
Get_Name_String
(ALIs.Table
- (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
+ (Units.Table (Elab_Order (E)).My_ALI).Ofile_Full_Name);
-- If the presence of an object file is necessary or if it exists,
-- then use it.
or else
System.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
then
- Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
+ WBI (" -- " & Name_Buffer (1 .. Name_Len));
if Output_Object_List then
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Eol;
end if;
-
- -- Don't link with the shared library on VMS if an internal
- -- filename object is seen. Multiply defined symbols will
- -- result.
-
- if OpenVMS_On_Target
- and then Is_Internal_File_Name
- (ALIs.Table
- (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
- then
- -- Special case for g-trasym.obj (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;
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");
end;
end loop;
+ if not (Opt.No_Run_Time_Mode or Opt.No_Stdlib) then
+ Name_Len := 0;
+
+ if Opt.Shared_Libgnat then
+ Add_Str_To_Name_Buffer ("-shared");
+ else
+ Add_Str_To_Name_Buffer ("-static");
+ end if;
+
+ -- Write directly to avoid inclusion in -K output as -static and
+ -- -shared are not usually specified linker options.
+
+ WBI (" -- " & Name_Buffer (1 .. Name_Len));
+ end if;
+
-- Sort linker options
-- This sort accomplishes two important purposes:
-- Write user linker options, i.e. the set of linker options that come
-- from all files other than GNAT internal files, Lgnat is left set to
-- point to the first entry from a GNAT internal file, or past the end
- -- of the entriers if there are no internal files.
+ -- of the entries if there are no internal files.
Lgnat := Linker_Options.Last + 1;
-- files. The reason for this decision is that libraries referenced
-- by internal routines may reference these standard library entries.
- -- 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.
+ -- 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, we may get duplicate symbols when
+ -- linking (not clear if this is still the case, but it is harmless).
if not (Opt.No_Run_Time_Mode or else Opt.No_Stdlib) then
- Name_Len := 0;
-
- if Opt.Shared_Libgnat then
- Add_Str_To_Name_Buffer ("-shared");
- else
- Add_Str_To_Name_Buffer ("-static");
- end if;
-
- -- Write directly to avoid -K output (why???)
-
- Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
-
- if With_DECGNAT then
- Name_Len := 0;
-
- 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;
Write_Eol;
end if;
- if Ada_Bind_File then
- WBI ("-- END Object file/option list ");
- else
- WBI (" END Object file/option list */");
- end if;
+ WBI ("-- END Object file/option list ");
end Gen_Object_Files_Options;
---------------------
-- Gen_Output_File --
---------------------
- procedure Gen_Output_File (Filename : String) is
+ procedure Gen_Output_File
+ (Filename : String;
+ Elab_Order : Unit_Id_Array)
+ is
begin
-- Acquire settings for Interrupt_State pragmas
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 VM_Target /= No_VM then
- Ada_Bind_File := True;
-
- if VM_Target = JVM_Target then
- Bind_Main_Program := False;
- end if;
- end if;
-
-- Override time slice value if -T switch is set
if Time_Slice_Set then
-- Count number of elaboration calls
- for E in Elab_Order.First .. Elab_Order.Last loop
- if Units.Table (Elab_Order.Table (E)).No_Elab then
+ for E in Elab_Order'Range loop
+ if Units.Table (Elab_Order (E)).No_Elab then
null;
else
Num_Elab_Calls := Num_Elab_Calls + 1;
end if;
end loop;
- -- Generate output file in appropriate language
-
- Check_System_Restrictions_Used;
+ -- Count the number of statically allocated stacks to be generated by
+ -- the binder. If the user has specified the number of default-sized
+ -- secondary stacks, use that number. Otherwise start the count at one
+ -- as the binder is responsible for creating a secondary stack for the
+ -- main task.
- if Ada_Bind_File then
- Gen_Output_File_Ada (Filename);
- else
- Gen_Output_File_C (Filename);
+ if Opt.Quantity_Of_Default_Size_Sec_Stacks /= -1 then
+ Num_Sec_Stacks := Quantity_Of_Default_Size_Sec_Stacks;
+ elsif Sec_Stack_Used then
+ Num_Sec_Stacks := 1;
end if;
+
+ for J in Units.First .. Units.Last loop
+ Num_Primary_Stacks :=
+ Num_Primary_Stacks + Units.Table (J).Primary_Stack_Count;
+
+ Num_Sec_Stacks :=
+ Num_Sec_Stacks + Units.Table (J).Sec_Stack_Count;
+ end loop;
+
+ -- Generate output file in appropriate language
+
+ Gen_Output_File_Ada (Filename, Elab_Order);
end Gen_Output_File;
-------------------------
-- Gen_Output_File_Ada --
-------------------------
- procedure Gen_Output_File_Ada (Filename : String) is
+ procedure Gen_Output_File_Ada
+ (Filename : String; Elab_Order : Unit_Id_Array)
+ is
+ Ada_Main : constant String := Get_Ada_Main_Name;
+ -- Name to be used for generated Ada main program. See the body of
+ -- function Get_Ada_Main_Name for details on the form of the name.
+
+ Needs_Library_Finalization : constant Boolean :=
+ not Configurable_Run_Time_On_Target
+ and then Has_Finalizer (Elab_Order);
+ -- For restricted run-time libraries (ZFP and Ravenscar) tasks are
+ -- non-terminating, so we do not want finalization.
Bfiles : Name_Id;
-- Name of generated bind file (spec)
Bfileb : Name_Id;
-- Name of generated bind file (body)
- Ada_Main : constant String := Get_Ada_Main_Name;
- -- Name to be used for generated Ada main program. See the body of
- -- function Get_Ada_Main_Name for details on the form of the name.
-
begin
-- Create spec first
-- 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.
+ -- of the Ada 2005 or Ada 2012 constructs are needed by the binder file.
+ WBI ("pragma Warnings (Off);");
WBI ("pragma Ada_95;");
-- If we are operating in Restrictions (No_Exception_Handlers) mode,
WBI ("with System.Scalar_Values;");
end if;
- -- Generate with of System.Secondary_Stack if active
+ -- Generate withs of System.Secondary_Stack and System.Parameters to
+ -- allow the generation of the default-sized secondary stack pool.
- if Sec_Stack_Used and then Default_Sec_Stack_Size /= -1 then
+ if Sec_Stack_Used then
+ WBI ("with System.Parameters;");
WBI ("with System.Secondary_Stack;");
end if;
- Resolve_Binder_Options;
-
- if VM_Target /= No_VM then
- if not Suppress_Standard_Library_On_Target then
+ Resolve_Binder_Options (Elab_Order);
- -- Usually, adafinal is called using a pragma Import C. Since
- -- Import C doesn't have the same semantics for JGNAT, we use
- -- standard Ada.
+ -- Generate standard with's
+ if not Suppress_Standard_Library_On_Target then
+ if CodePeer_Mode then
WBI ("with System.Standard_Library;");
end if;
end if;
WBI ("package " & Ada_Main & " is");
- WBI (" pragma Warnings (Off);");
-- Main program case
if Bind_Main_Program then
- if VM_Target = No_VM then
+ -- Generate argc/argv stuff unless suppressed
+
+ if Command_Line_Args_On_Target
+ or not Configurable_Run_Time_On_Target
+ then
+ WBI ("");
+ WBI (" gnat_argc : Integer;");
+ WBI (" gnat_argv : System.Address;");
+ WBI (" gnat_envp : System.Address;");
- -- Generate argc/argv stuff unless suppressed
+ -- If the standard library is not suppressed, these variables
+ -- are in the run-time data area for easy run time access.
- if Command_Line_Args_On_Target
- or not Configurable_Run_Time_On_Target
- then
+ if not Suppress_Standard_Library_On_Target then
WBI ("");
- WBI (" gnat_argc : Integer;");
- WBI (" gnat_argv : System.Address;");
- WBI (" gnat_envp : System.Address;");
-
- -- If the standard library is not suppressed, these variables
- -- are in the run-time data area for easy run time access.
-
- 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;
+ 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
- -- configurable runtime case, the variable is declared and
- -- initialized in this file.
-
- WBI ("");
+ -- Define exit status. Again in normal mode, this is in the run-time
+ -- library, and is initialized there, but in the configurable
+ -- run-time case, the variable is declared and initialized in this
+ -- file.
- if Configurable_Run_Time_Mode then
- if Exit_Status_Supported_On_Target then
- WBI (" gnat_exit_status : Integer := 0;");
- end if;
+ WBI ("");
- else
- WBI (" gnat_exit_status : Integer;");
- WBI (" pragma Import (C, gnat_exit_status);");
+ 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);");
end if;
-- Generate the GNAT_Version and Ada_Main_Program_Name info only for
Set_String (" Ada_Main_Program_Name : constant String := """);
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- if VM_Target = No_VM then
- Set_Main_Program_Name;
- Set_String (""" & ASCII.NUL;");
- else
- Set_String (Name_Buffer (1 .. Name_Len - 2) & """;");
- end if;
+ Set_Main_Program_Name;
+ Set_String (""" & ASCII.NUL;");
Write_Statement_Buffer;
"""__gnat_ada_main_program_name"");");
end if;
- if not Cumulative_Restrictions.Set (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_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.
+ -- procedure and pragma Linker_Destructor for the final procedure.
if Use_Pragma_Linker_Constructor then
WBI (" pragma Linker_Constructor (" & Ada_Init_Name.all & ");");
end if;
- if Bind_Main_Program and then VM_Target = No_VM then
-
- -- If we have the standard library, then Break_Start is defined
- -- there, but when the standard library is suppressed, Break_Start
- -- is defined here.
-
+ if not Cumulative_Restrictions.Set (No_Finalization) then
WBI ("");
- WBI (" procedure Break_Start;");
+ WBI (" procedure " & Ada_Final_Name.all & ";");
+ WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
+ Ada_Final_Name.all & """);");
- 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"");");
+ if Use_Pragma_Linker_Constructor then
+ WBI (" pragma Linker_Destructor (" & Ada_Final_Name.all & ");");
end if;
+ end if;
+
+ if Bind_Main_Program then
WBI ("");
Get_Main_Name & """);");
end if;
- Gen_Versions_Ada;
- Gen_Elab_Order_Ada;
+ -- Generate version numbers for units, only if needed. Be very safe on
+ -- the condition.
+
+ if not Configurable_Run_Time_On_Target
+ or else System_Version_Control_Used
+ or else not Bind_Main_Program
+ then
+ Gen_Versions;
+ end if;
+
+ Gen_Elab_Order (Elab_Order);
-- Spec is complete
-- 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.
+ -- of the Ada 2005/2012 constructs are needed by the binder file.
+ WBI ("pragma Warnings (Off);");
WBI ("pragma Ada_95;");
-- Output Source_File_Name pragmas which look like
-- where sss/bbb are the spec/body file names respectively
Get_Name_String (Bfiles);
- Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
-
- WBI ("pragma Source_File_Name (" &
- Ada_Main &
- ", Spec_File_Name => """ &
- Name_Buffer (1 .. Name_Len + 3));
-
- Get_Name_String (Bfileb);
- Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
-
- WBI ("pragma Source_File_Name (" &
- Ada_Main &
- ", Body_File_Name => """ &
- Name_Buffer (1 .. Name_Len + 3));
-
- -- 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 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 VM_Target = No_VM then
- WBI ("");
- WBI (" procedure Do_Finalize;");
- WBI
- (" pragma Import (C, Do_Finalize, " &
- """system__standard_library__adafinal"");");
- WBI ("");
- end if;
- end if;
-
- 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;
-
- -- 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;
-
- Set_String (""";");
- Write_Statement_Buffer;
- WBI ("");
- end if;
-
- Gen_Adainit_Ada;
-
- -- Generate the adafinal routine unless there is no finalization to do
-
- if not Cumulative_Restrictions.Set (No_Finalization) then
- Gen_Adafinal_Ada;
- end if;
-
- if Bind_Main_Program and then VM_Target = No_VM then
-
- -- When suppressing the standard library then generate dummy body
- -- for Break_Start
-
- if Suppress_Standard_Library_On_Target then
- WBI ("");
- WBI (" procedure Break_Start is");
- WBI (" begin");
- WBI (" null;");
- WBI (" end;");
- end if;
-
- Gen_Main_Ada;
- end if;
-
- -- Output object file list and the Ada body is complete
-
- Gen_Object_Files_Options;
-
- WBI ("");
- WBI ("end " & Ada_Main & ";");
-
- Close_Binder_Output;
- end Gen_Output_File_Ada;
-
- -----------------------
- -- Gen_Output_File_C --
- -----------------------
-
- procedure Gen_Output_File_C (Filename : String) is
- Bfile : Name_Id;
- pragma Warnings (Off, Bfile);
- -- Name of generated bind file (not referenced)
-
- begin
- Create_Binder_Output (Filename, 'c', Bfile);
-
- Resolve_Binder_Options;
-
- WBI ("extern void " & Ada_Final_Name.all & " (void);");
-
- -- If -a has been specified use __attribute__((constructor)) for the
- -- init procedure. No need to use a similar featute for the final
- -- procedure as global finalization will occur when the executable
- -- finishes execution and for plugins (shared stand-alone libraries that
- -- can be "unloaded"), finalization should not occur automatically,
- -- otherwise the main executable may not continue to work properly.
-
- 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
- Set_String ("extern ");
+ Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
- if Exit_Status_Supported_On_Target then
- Set_String ("int");
- else
- Set_String ("void");
- end if;
+ WBI ("pragma Source_File_Name (" &
+ Ada_Main &
+ ", Spec_File_Name => """ &
+ Name_Buffer (1 .. Name_Len + 3));
- Set_String (" main ");
+ Get_Name_String (Bfileb);
+ Name_Buffer (Name_Len + 1 .. Name_Len + 3) := """);";
- if Command_Line_Args_On_Target then
- Write_Statement_Buffer ("(int, char **, char **);");
- else
- Write_Statement_Buffer ("(void);");
- end if;
+ WBI ("pragma Source_File_Name (" &
+ Ada_Main &
+ ", Body_File_Name => """ &
+ Name_Buffer (1 .. Name_Len + 3));
- if OpenVMS_On_Target then
- WBI ("extern void decc$__posix_exit (int);");
- else
- WBI ("extern void exit (int);");
- end if;
+ -- Generate pragma Suppress (Overflow_Check). This is needed for recent
+ -- versions of the compiler which have overflow checks on by default.
+ -- We do not want overflow checking enabled for the increments of the
+ -- elaboration variables (since this can cause an unwanted reference to
+ -- the last chance exception handler for limited run-times).
- WBI ("extern void __gnat_break_start (void);");
- Set_String ("extern ");
+ WBI ("pragma Suppress (Overflow_Check);");
- if ALIs.Table (ALIs.First).Main_Program = Proc then
- Set_String ("void ");
- else
- Set_String ("int ");
- end if;
+ -- Generate with of System.Restrictions to initialize
+ -- Run_Time_Restrictions.
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- Set_Main_Program_Name;
- Set_String (" (void);");
- Write_Statement_Buffer;
+ if System_Restrictions_Used
+ and not Suppress_Standard_Library_On_Target
+ then
+ WBI ("");
+ WBI ("with System.Restrictions;");
end if;
- 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;
+ -- Generate with of Ada.Exceptions if needs library finalization
- if Dynamic_Stack_Measurement then
- WBI ("");
- WBI ("extern void __gnat_stack_usage_output_results (void);");
- WBI ("extern void __gnat_stack_usage_initialize (int size);");
+ if Needs_Library_Finalization then
+ WBI ("with Ada.Exceptions;");
end if;
- -- Initialize stack limit for the environment task if the stack check
- -- method is stack limit and stack check is enabled.
+ -- Generate with of System.Elaboration_Allocators if the restriction
+ -- No_Standard_Allocators_After_Elaboration was present.
- if Stack_Check_Limits_On_Target
- and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
+ if Cumulative_Restrictions.Set
+ (No_Standard_Allocators_After_Elaboration)
then
- WBI ("");
- WBI ("extern void __gnat_initialize_stack_limit (void);");
+ WBI ("with System.Elaboration_Allocators;");
end if;
+ -- Generate start of package body
+
+ WBI ("");
+ WBI ("package body " & Ada_Main & " is");
WBI ("");
- Gen_Elab_Defs_C;
+ -- Generate externals for elaboration entities
+
+ Gen_Elab_Externals (Elab_Order);
- -- Imported variables used only when we have a runtime
+ -- Generate default-sized secondary stacks pool. At least one stack is
+ -- created and assigned to the environment task if secondary stacks are
+ -- used by the program.
- if not Suppress_Standard_Library_On_Target then
+ if Sec_Stack_Used then
+ Set_String (" Sec_Default_Sized_Stacks");
+ Set_String (" : array (1 .. ");
+ Set_Int (Num_Sec_Stacks);
+ Set_String (") of aliased System.Secondary_Stack.SS_Stack (");
- -- Track elaboration/finalization phase
+ if Opt.Default_Sec_Stack_Size /= No_Stack_Size then
+ Set_Int (Opt.Default_Sec_Stack_Size);
+ else
+ Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
+ end if;
- WBI ("extern int __gnat_handler_installed;");
+ Set_String (");");
+ Write_Statement_Buffer;
WBI ("");
+ end if;
- -- Track feature enable/disable on VMS
+ -- Generate reference
- if OpenVMS_On_Target then
- WBI ("extern int __gnat_features_set;");
- WBI ("");
- end if;
- end if;
+ if not CodePeer_Mode then
+ if not Suppress_Standard_Library_On_Target then
- -- Write argv/argc exit status stuff if main program case
+ -- Generate Priority_Specific_Dispatching pragma string
- if Bind_Main_Program then
+ Set_String
+ (" Local_Priority_Specific_Dispatching : " &
+ "constant String := """);
- -- First deal with argc/argv/envp. In the normal case they are in the
- -- run-time library.
+ for J in 0 .. PSD_Pragma_Settings.Last loop
+ Set_Char (PSD_Pragma_Settings.Table (J));
+ end loop;
- if not Configurable_Run_Time_On_Target then
- WBI ("extern int gnat_argc;");
- WBI ("extern char **gnat_argv;");
- WBI ("extern char **gnat_envp;");
+ Set_String (""";");
+ Write_Statement_Buffer;
- -- If configurable run time and no command line args, then the
- -- generation of these variables is entirely suppressed.
+ -- Generate Interrupt_State pragma string
- elsif not Command_Line_Args_On_Target then
- null;
+ Set_String (" Local_Interrupt_States : constant String := """);
- -- Otherwise, in the configurable run-time case they are right in the
- -- binder file.
+ for J in 0 .. IS_Pragma_Settings.Last loop
+ Set_Char (IS_Pragma_Settings.Table (J));
+ end loop;
- else
- WBI ("int gnat_argc;");
- WBI ("char **gnat_argv;");
- WBI ("char **gnat_envp;");
+ Set_String (""";");
+ Write_Statement_Buffer;
+ WBI ("");
end if;
- -- Similarly deal with exit status
-
- if not Configurable_Run_Time_On_Target then
- WBI ("extern int gnat_exit_status;");
+ if not Suppress_Standard_Library_On_Target then
- -- If configurable run time and no exit status on target, then the
- -- generation of this variables is entirely suppressed.
+ -- The B.1(39) implementation advice says that the adainit and
+ -- adafinal routines should be idempotent. Generate a flag to
+ -- ensure that. This is not needed if we are suppressing the
+ -- standard library since it would never be referenced.
- elsif not Exit_Status_Supported_On_Target then
- null;
+ WBI (" Is_Elaborated : Boolean := False;");
- -- Otherwise, in the configurable run-time case this variable is
- -- right in the binder file, and initialized to zero there.
+ -- Generate bind environment string
- else
- WBI ("int gnat_exit_status = 0;");
+ Gen_Bind_Env_String;
end if;
WBI ("");
end if;
- -- When suppressing the standard library, the __gnat_break_start routine
- -- (for the debugger to get initial control) is defined in this file.
-
- if Suppress_Standard_Library_On_Target then
- WBI ("");
- WBI ("void __gnat_break_start (void) {}");
- end if;
-
- -- Generate the __gnat_version and __gnat_ada_main_program_name info
- -- only for the main program. Otherwise, it can lead under some
- -- circumstances to a symbol duplication during the link (for instance
- -- when a C program uses 2 Ada libraries)
-
- if Bind_Main_Program then
- WBI ("");
- WBI ("char __gnat_version[] = """ & Ver_Prefix &
- Gnat_Version_String & """;");
-
- Set_String ("char __gnat_ada_main_program_name[] = """);
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- Set_Main_Program_Name;
- Set_String (""";");
- Write_Statement_Buffer;
- end if;
-
- -- Generate the adafinal routine. In no runtime mode, this is not
- -- needed, since there is no finalization to do.
+ -- Generate the adafinal routine unless there is no finalization to do
if not Cumulative_Restrictions.Set (No_Finalization) then
- Gen_Adafinal_C;
- end if;
+ if Needs_Library_Finalization then
+ Gen_Finalize_Library (Elab_Order);
+ end if;
- Gen_Adainit_C;
+ Gen_Adafinal;
+ end if;
- -- Main is only present for Ada main case
+ Gen_Adainit (Elab_Order);
if Bind_Main_Program then
- Gen_Main_C;
+ Gen_Main;
end if;
- -- Generate versions, elaboration order, list of object files
+ -- Output object file list and the Ada body is complete
- Gen_Versions_C;
- Gen_Elab_Order_C;
- Gen_Object_Files_Options;
+ Gen_Object_Files_Options (Elab_Order);
- -- C binder output is complete
+ WBI ("");
+ WBI ("end " & Ada_Main & ";");
Close_Binder_Output;
- end Gen_Output_File_C;
+ end Gen_Output_File_Ada;
- --------------------------
- -- Gen_Restrictions_Ada --
- --------------------------
+ ----------------------
+ -- Gen_Restrictions --
+ ----------------------
- procedure Gen_Restrictions_Ada is
+ procedure Gen_Restrictions is
Count : Integer;
begin
Set_String (", ");
Count := Count + 1;
- if Count = 8 then
+ if J /= Cumulative_Restrictions.Set'Last and then Count = 8 then
Write_Statement_Buffer;
Set_String (" ");
Count := 0;
Set_String (", ");
Count := Count + 1;
- if Count = 8 then
+ if J /= Cumulative_Restrictions.Set'Last and then Count = 8 then
Write_Statement_Buffer;
Set_String (" ");
Count := 0;
Set_String_Replace ("))");
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'Range loop
- Set_Int (Boolean'Pos (Cumulative_Restrictions.Set (J)));
- Set_String (", ");
- end loop;
-
- Set_String_Replace ("},");
- Write_Statement_Buffer;
- Set_String (" {");
-
- for J in Cumulative_Restrictions.Value'Range loop
- Set_Int (Int (Cumulative_Restrictions.Value (J)));
- Set_String (", ");
- end loop;
-
- Set_String_Replace ("},");
- Write_Statement_Buffer;
- Set_String (" {");
-
- for J in Cumulative_Restrictions.Violated'Range loop
- Set_Int (Boolean'Pos (Cumulative_Restrictions.Violated (J)));
- Set_String (", ");
- end loop;
-
- Set_String_Replace ("},");
- Write_Statement_Buffer;
- Set_String (" {");
-
- for J in Cumulative_Restrictions.Count'Range loop
- Set_Int (Int (Cumulative_Restrictions.Count (J)));
- Set_String (", ");
- end loop;
-
- Set_String_Replace ("},");
- Write_Statement_Buffer;
- Set_String (" {");
-
- for J in Cumulative_Restrictions.Unknown'Range loop
- Set_Int (Boolean'Pos (Cumulative_Restrictions.Unknown (J)));
- Set_String (", ");
- end loop;
-
- Set_String_Replace ("}}");
- Set_String (";");
- Write_Statement_Buffer;
- WBI (" system__restrictions__run_time_restrictions = r;");
- end Gen_Restrictions_C;
+ end Gen_Restrictions;
- ----------------------
- -- Gen_Versions_Ada --
- ----------------------
+ ------------------
+ -- Gen_Versions --
+ ------------------
-- This routine generates lines such as:
-- body or spec, with dots replaced by double underscores, and hhhhhhhh is
-- the version number, and nnnnn is a 5-digits serial number.
- procedure Gen_Versions_Ada is
+ procedure Gen_Versions is
Ubuf : String (1 .. 6) := "u00000";
procedure Increment_Ubuf;
-- Little procedure to increment the serial number
+ --------------------
+ -- Increment_Ubuf --
+ --------------------
+
procedure Increment_Ubuf is
begin
for J in reverse Ubuf'Range loop
end loop;
end Increment_Ubuf;
- -- Start of processing for Gen_Versions_Ada
+ -- Start of processing for Gen_Versions
begin
WBI ("");
WBI (" type Version_32 is mod 2 ** 32;");
for U in Units.First .. Units.Last loop
- if not Units.Table (U).SAL_Interface and then
- ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned)
+ if not Units.Table (U).SAL_Interface
+ and then (not Bind_For_Library
+ or else Units.Table (U).Directly_Scanned)
then
Increment_Ubuf;
WBI (" " & Ubuf & " : constant Version_32 := 16#" &
Write_Statement_Buffer;
end if;
end loop;
-
- end Gen_Versions_Ada;
-
- --------------------
- -- Gen_Versions_C --
- --------------------
-
- -- This routine generates a line of the form:
-
- -- unsigned unam = 0xhhhhhhhh;
-
- -- for each unit, where unam is the unit name suffixed by either B or S for
- -- body or spec, with dots replaced by double underscores.
-
- procedure Gen_Versions_C is
- begin
- for U in Units.First .. Units.Last loop
- if not Units.Table (U).SAL_Interface and then
- ((not Bind_For_Library) or else Units.Table (U).Directly_Scanned)
- then
- Set_String ("unsigned ");
-
- Get_Name_String (Units.Table (U).Uname);
-
- for K in 1 .. Name_Len loop
- if Name_Buffer (K) = '.' then
- Set_String ("__");
-
- elsif Name_Buffer (K) = '%' then
- exit;
-
- else
- Set_Char (Name_Buffer (K));
- end if;
- end loop;
-
- if Name_Buffer (Name_Len) = 's' then
- Set_Char ('S');
- else
- Set_Char ('B');
- end if;
-
- Set_String (" = 0x");
- Set_String (Units.Table (U).Version);
- Set_Char (';');
- Write_Statement_Buffer;
- end if;
- end loop;
-
- end Gen_Versions_C;
+ end Gen_Versions;
------------------------
-- Get_Main_Unit_Name --
Nlen : Natural;
begin
- -- The main program generated by JGNAT expects a package called
- -- ada_<main procedure>.
+ -- For CodePeer, we want reproducible names (independent of other mains
+ -- that may or may not be present) that don't collide when analyzing
+ -- multiple mains and which are easily recognizable as "ada_main" names.
- if VM_Target /= No_VM then
+ if CodePeer_Mode then
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- return "ada_" & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
+
+ return
+ "ada_main_for_" &
+ Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
end if;
-- This loop tries the following possibilities in order
-- every file, then we could use the encoding of the initial specified
-- file, but this information is passed only for potential main
-- programs. We could fix this sometime, but it is a very minor point
- -- (wide character default encoding for [Wide_[Wide_]Text_IO when there
+ -- (wide character default encoding for [Wide_[Wide_]]Text_IO when there
-- is no main program).
elsif No_Main_Subprogram then
end if;
end Get_WC_Encoding;
+ -------------------
+ -- Has_Finalizer --
+ -------------------
+
+ function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean is
+ U : Unit_Record;
+ Unum : Unit_Id;
+
+ begin
+ for E in reverse Elab_Order'Range loop
+ Unum := Elab_Order (E);
+ U := Units.Table (Unum);
+
+ -- We are only interested in non-generic packages
+
+ if U.Unit_Kind = 'p'
+ and then U.Has_Finalizer
+ and then not U.Is_Generic
+ and then not U.No_Elab
+ then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Has_Finalizer;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (Nam : Name_Id) return Header_Num is
+ begin
+ return Int (Nam - Names_Low_Bound) rem Header_Num'Last;
+ end Hash;
+
----------------------
-- Lt_Linker_Option --
----------------------
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
+ function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean is
begin
-- Sort internal files last
return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
>
Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
-
end if;
end Lt_Linker_Option;
-- Resolve_Binder_Options --
----------------------------
- procedure Resolve_Binder_Options is
+ procedure Resolve_Binder_Options (Elab_Order : Unit_Id_Array) is
+ procedure Check_Package (Var : in out Boolean; Name : String);
+ -- Set Var to true iff the current identifier in Namet is Name. Do
+ -- nothing if it doesn't match. This procedure is just a helper to
+ -- avoid explicitly dealing with length.
+
+ -------------------
+ -- Check_Package --
+ -------------------
+
+ procedure Check_Package (Var : in out Boolean; Name : String) is
+ begin
+ if Name_Len = Name'Length
+ and then Name_Buffer (1 .. Name_Len) = Name
+ then
+ Var := True;
+ end if;
+ end Check_Package;
+
+ -- Start of processing for Resolve_Binder_Options
+
begin
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
+ for E in Elab_Order'Range loop
+ Get_Name_String (Units.Table (Elab_Order (E)).Uname);
-- This is not a perfect approach, but is the current protocol
-- between the run-time and the binder to indicate that tasking is
- -- used: system.os_interface should always be used by any tasking
+ -- used: System.OS_Interface should always be used by any tasking
-- application.
- if Name_Buffer (1 .. 19) = "system.os_interface" then
- With_GNARL := True;
- end if;
+ Check_Package (With_GNARL, "system.os_interface%s");
- -- Ditto for declib and the "dec" package
+ -- Ditto for the use of restricted tasking
- if OpenVMS_On_Target and then Name_Buffer (1 .. 5) = "dec%s" then
- With_DECGNAT := True;
- end if;
+ Check_Package
+ (System_Tasking_Restricted_Stages_Used,
+ "system.tasking.restricted.stages%s");
+
+ -- Ditto for the use of interrupts
+
+ Check_Package (System_Interrupts_Used, "system.interrupts%s");
+
+ -- Ditto for the use of dispatching domains
+
+ Check_Package
+ (Dispatching_Domains_Used,
+ "system.multiprocessors.dispatching_domains%s");
+
+ -- Ditto for the use of restrictions
+
+ Check_Package (System_Restrictions_Used, "system.restrictions%s");
+
+ -- Ditto for the use of System.Secondary_Stack
+
+ Check_Package
+ (System_Secondary_Stack_Used, "system.secondary_stack%s");
+
+ -- Ditto for use of an SMP bareboard runtime
+
+ Check_Package (System_BB_CPU_Primitives_Multiprocessors_Used,
+ "system.bb.cpu_primitives.multiprocessors%s");
+
+ -- Ditto for System.Version_Control, which is used for Version and
+ -- Body_Version attributes.
+
+ Check_Package (System_Version_Control_Used,
+ "system.version_control%s");
end loop;
end Resolve_Binder_Options;
+ ------------------
+ -- Set_Bind_Env --
+ ------------------
+
+ procedure Set_Bind_Env (Key, Value : String) is
+ begin
+ -- The lengths of Key and Value are stored as single bytes
+
+ if Key'Length > 255 then
+ Osint.Fail ("bind environment key """ & Key & """ too long");
+ end if;
+
+ if Value'Length > 255 then
+ Osint.Fail ("bind environment value """ & Value & """ too long");
+ end if;
+
+ Bind_Environment.Set (Name_Find (Key), Name_Find (Value));
+ end Set_Bind_Env;
+
-----------------
-- Set_Boolean --
-----------------
procedure Set_Boolean (B : Boolean) is
- True_Str : constant String := "True";
False_Str : constant String := "False";
+ True_Str : constant String := "True";
+
begin
if B then
- Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str;
- Last := Last + True_Str'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + True_Str'Length) :=
+ True_Str;
+ Stm_Last := Stm_Last + True_Str'Length;
else
- Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str;
- Last := Last + False_Str'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + False_Str'Length) :=
+ False_Str;
+ Stm_Last := Stm_Last + False_Str'Length;
end if;
end Set_Boolean;
procedure Set_Char (C : Character) is
begin
- Last := Last + 1;
- Statement_Buffer (Last) := C;
+ Stm_Last := Stm_Last + 1;
+ Statement_Buffer (Stm_Last) := C;
end Set_Char;
-------------
Set_Int (N / 10);
end if;
- Last := Last + 1;
- Statement_Buffer (Last) :=
+ Stm_Last := Stm_Last + 1;
+ Statement_Buffer (Stm_Last) :=
Character'Val (N mod 10 + Character'Pos ('0'));
end if;
end Set_Int;
begin
-- Note that name has %b on the end which we ignore
- -- First we output the initial _ada_ since we know that the main
- -- program is a library level subprogram.
+ -- First we output the initial _ada_ since we know that the main program
+ -- is a library level subprogram.
Set_String ("_ada_");
procedure Set_String (S : String) is
begin
- Statement_Buffer (Last + 1 .. Last + S'Length) := S;
- Last := Last + S'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + S'Length) := S;
+ Stm_Last := Stm_Last + S'Length;
end Set_String;
------------------------
procedure Set_String_Replace (S : String) is
begin
- Statement_Buffer (Last - S'Length + 1 .. Last) := S;
+ Statement_Buffer (Stm_Last - S'Length + 1 .. Stm_Last) := S;
end Set_String_Replace;
-------------------
procedure Set_Unit_Name is
begin
for J in 1 .. Name_Len - 2 loop
- if Name_Buffer (J) /= '.' then
- Set_Char (Name_Buffer (J));
- else
+ if Name_Buffer (J) = '.' then
Set_String ("__");
+ else
+ Set_Char (Name_Buffer (J));
end if;
end loop;
end Set_Unit_Name;
Set_Int (Unum);
end Set_Unit_Number;
- ----------------------
- -- Write_Info_Ada_C --
- ----------------------
+ ---------------------
+ -- Write_Bind_Line --
+ ---------------------
- procedure Write_Info_Ada_C (Ada : String; C : String; Common : String) is
+ procedure Write_Bind_Line (S : String) is
begin
- if Ada_Bind_File then
- declare
- S : String (1 .. Ada'Length + Common'Length);
- begin
- S (1 .. Ada'Length) := Ada;
- S (Ada'Length + 1 .. S'Length) := Common;
- WBI (S);
- end;
+ -- Need to strip trailing LF from S
- else
- declare
- S : String (1 .. C'Length + Common'Length);
- begin
- S (1 .. C'Length) := C;
- S (C'Length + 1 .. S'Length) := Common;
- WBI (S);
- end;
- end if;
- end Write_Info_Ada_C;
+ WBI (S (S'First .. S'Last - 1));
+ end Write_Bind_Line;
----------------------------
-- Write_Statement_Buffer --
procedure Write_Statement_Buffer is
begin
- WBI (Statement_Buffer (1 .. Last));
- Last := 0;
+ WBI (Statement_Buffer (1 .. Stm_Last));
+ Stm_Last := 0;
end Write_Statement_Buffer;
procedure Write_Statement_Buffer (S : String) is
projects / gcc.git / blobdiff