Subversion Repositories openrisc_2011-10-31

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                              B I N D G E N                               --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with ALI;      use ALI;

with Binde;    use Binde;

with Casing;   use Casing;

with Fname;    use Fname;

with Gnatvsn;  use Gnatvsn;

with Hostparm;

with Namet;    use Namet;

with Opt;      use Opt;

with Osint;    use Osint;

with Osint.B;  use Osint.B;

with Output;   use Output;

with Rident;   use Rident;

with Table;    use Table;

with Targparm; use Targparm;

with Types;    use Types;

with System.OS_Lib;  use System.OS_Lib;

with System.WCh_Con; use System.WCh_Con;

with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;

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).

   With_GNARL : Boolean := False;

   --  Flag which indicates whether the program uses the GNARL library

   --  (presence of the unit System.OS_Interface)

   Num_Elab_Calls : Nat := 0;

   --  Number of generated calls to elaboration routines

   System_Restrictions_Used : Boolean;

   --  Flag indicating whether the unit System.Restrictions is in the closure

   --  of the partition. This is set by Check_System_Restrictions_Used, and

   --  is used to determine whether or not to initialize the restrictions

   --  information in the body of the binder generated file (we do not want

   --  to do this unconditionally, since it drags in the System.Restrictions

   --  unit unconditionally, which is unpleasand, especially for ZFP etc.)

   ----------------------------------

   -- Interface_State Pragma Table --

   ----------------------------------

   --  This table assembles the interface state pragma information from

   --  all the units in the partition. Note that Bcheck has already checked

   --  that the information is consistent across units. The entries

   --  in this table are n/u/r/s for not set/user/runtime/system.

   package IS_Pragma_Settings is new Table.Table (

     Table_Component_Type => Character,

     Table_Index_Type     => Int,

     Table_Low_Bound      => 0,

     Table_Initial        => 100,

     Table_Increment      => 200,

     Table_Name           => "IS_Pragma_Settings");

   --  This table assembles the Priority_Specific_Dispatching pragma

   --  information from all the units in the partition. Note that Bcheck has

   --  already checked that the information is consistent across units.

   --  The entries in this table are the upper case first character of the

   --  policy name, e.g. 'F' for FIFO_Within_Priorities.

   package PSD_Pragma_Settings is new Table.Table (

     Table_Component_Type => Character,

     Table_Index_Type     => Int,

     Table_Low_Bound      => 0,

     Table_Initial        => 100,

     Table_Increment      => 200,

     Table_Name           => "PSD_Pragma_Settings");

   ----------------------

   -- Run-Time Globals --

   ----------------------

   --  This section documents the global variables that set from the

   --  generated binder file.

   --     Main_Priority                 : Integer;

   --     Time_Slice_Value              : Integer;

   --     WC_Encoding                   : Character;

   --     Locking_Policy                : Character;

   --     Queuing_Policy                : Character;

   --     Task_Dispatching_Policy       : Character;

   --     Priority_Specific_Dispatching : System.Address;

   --     Num_Specific_Dispatching      : Integer;

   --     Restrictions                  : System.Address;

   --     Interrupt_States              : System.Address;

   --     Num_Interrupt_States          : Integer;

   --     Unreserve_All_Interrupts      : Integer;

   --     Exception_Tracebacks          : Integer;

   --     Zero_Cost_Exceptions          : Integer;

   --     Detect_Blocking               : Integer;

   --     Default_Stack_Size            : Integer;

   --     Leap_Seconds_Support          : Integer;

   --  Main_Priority is the priority value set by pragma Priority in the main

   --  program. If no such pragma is present, the value is -1.

   --  Time_Slice_Value is the time slice value set by pragma Time_Slice in the

   --  main program, or by the use of a -Tnnn parameter for the binder (if both

   --  are present, the binder value overrides). The value is in milliseconds.

   --  A value of zero indicates that time slicing should be suppressed. If no

   --  pragma is present, and no -T switch was used, the value is -1.

   --  WC_Encoding shows the wide character encoding method used for the main

   --  program. This is one of the encoding letters defined in

   --  System.WCh_Con.WC_Encoding_Letters.

   --  Locking_Policy is a space if no locking policy was specified for the

   --  partition. If a locking policy was specified, the value is the upper

   --  case first character of the locking policy name, for example, 'C' for

   --  Ceiling_Locking.

   --  Queuing_Policy is a space if no queuing policy was specified for the

   --  partition. If a queuing policy was specified, the value is the upper

   --  case first character of the queuing policy name for example, 'F' for

   --  FIFO_Queuing.

   --  Task_Dispatching_Policy is a space if no task dispatching policy was

   --  specified for the partition. If a task dispatching policy was specified,

   --  the value is the upper case first character of the policy name, e.g. 'F'

   --  for FIFO_Within_Priorities.

   --  Priority_Specific_Dispatching is the address of a string used to store

   --  the task dispatching policy specified for the different priorities in

   --  the partition. The length of this string is determined by the last

   --  priority for which such a pragma applies (the string will be a null

   --  string if no specific dispatching policies were used). If pragma were

   --  present, the entries apply to the priorities in sequence from the first

   --  priority. The value stored is the upper case first character of the

   --  policy name, or 'F' (for FIFO_Within_Priorities) as the default value

   --  for those priority ranges not specified.

   --  Num_Specific_Dispatching is the length of the

   --  Priority_Specific_Dispatching string. It will be set to zero if no

   --  Priority_Specific_Dispatching pragmas are present.

   --  Restrictions is the address of a null-terminated string specifying the

   --  restrictions information for the partition. The format is identical to

   --  that of the parameter string found on R lines in ali files (see Lib.Writ

   --  spec in lib-writ.ads for full details). The difference is that in this

   --  context the values are the cumulative ones for the entire partition.

   --  Interrupt_States is the address of a string used to specify the

   --  cumulative results of Interrupt_State pragmas used in the partition.

   --  The length of this string is determined by the last interrupt for which

   --  such a pragma is given (the string will be a null string if no pragmas

   --  were used). If pragma were present the entries apply to the interrupts

   --  in sequence from the first interrupt, and are set to one of four

   --  possible settings: 'n' for not specified, 'u' for user, 'r' for run

   --  time, 's' for system, see description of Interrupt_State pragma for

   --  further details.

   --  Num_Interrupt_States is the length of the Interrupt_States string. It

   --  will be set to zero if no Interrupt_State pragmas are present.

   --  Unreserve_All_Interrupts is set to one if at least one unit in the

   --  partition had a pragma Unreserve_All_Interrupts, and zero otherwise.

   --  Exception_Tracebacks is set to one if the -E parameter was present

   --  in the bind and to zero otherwise. Note that on some targets exception

   --  tracebacks are provided by default, so a value of zero for this

   --  parameter does not necessarily mean no trace backs are available.

   --  Zero_Cost_Exceptions is set to one if zero cost exceptions are used for

   --  this partition, and to zero if longjmp/setjmp exceptions are used.

   --  Detect_Blocking indicates whether pragma Detect_Blocking is active or

   --  not. A value of zero indicates that the pragma is not present, while a

   --  value of 1 signals its presence in the partition.

   --  Default_Stack_Size is the default stack size used when creating an Ada

   --  task with no explicit Storage_Size clause.

   --  Leap_Seconds_Support denotes whether leap seconds have been enabled or

   --  disabled. A value of zero indicates that leap seconds are turned "off",

   --  while a value of one signifies "on" status.

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;

   --  Convenient shorthand used throughout

   procedure Check_System_Restrictions_Used;

   --  Sets flag System_Restrictions_Used (Set to True if and only if the unit

   --  System.Restrictions is present in the partition, otherwise False).

   procedure Gen_Adainit_Ada;

   --  Generates the Adainit procedure (Ada code case)

   procedure Gen_Adainit_C;

   --  Generates the Adainit procedure (C code case)

   procedure Gen_Adafinal_Ada;

   --  Generate the Adafinal procedure (Ada code case)

   procedure Gen_Adafinal_C;

   --  Generate the Adafinal procedure (C code case)

   procedure Gen_Elab_Calls_Ada;

   --  Generate sequence of elaboration calls (Ada code case)

   procedure Gen_Elab_Calls_C;

   --  Generate sequence of elaboration calls (C code case)

   procedure Gen_Elab_Order_Ada;

   --  Generate comments showing elaboration order chosen (Ada case)

   procedure Gen_Elab_Order_C;

   --  Generate comments showing elaboration order chosen (C case)

   procedure Gen_Elab_Defs_C;

   --  Generate sequence of definitions for elaboration routines (C code case)

   procedure Gen_Main_Ada;

   --  Generate procedure main (Ada code case)

   procedure Gen_Main_C;

   --  Generate main() procedure (C code case)

   procedure Gen_Object_Files_Options;

   --  Output comments containing a list of the full names of the object

   --  files to be linked and the list of linker options supplied by

   --  Linker_Options pragmas in the source. (C and Ada code case)

   procedure Gen_Output_File_Ada (Filename : String);

   --  Generate output file (Ada code case)

   procedure Gen_Output_File_C (Filename : String);

   --  Generate output file (C code case)

   procedure Gen_Restrictions_Ada;

   --  Generate initialization of restrictions variable (Ada code case)

   procedure Gen_Restrictions_C;

   --  Generate initialization of restrictions variable (C code case)

   procedure Gen_Versions_Ada;

   --  Output series of definitions for unit versions (Ada code case)

   procedure Gen_Versions_C;

   --  Output series of definitions for unit versions (C code case)

   function Get_Ada_Main_Name return String;

   --  This function is used in the Ada main output case to compute a usable

   --  name for the generated main program. The normal main program name is

   --  Ada_Main, but this won't work if the user has a unit with this name.

   --  This function tries Ada_Main first, and if there is such a clash, then

   --  it tries Ada_Name_01, Ada_Name_02 ... Ada_Name_99 in sequence.

   function Get_Main_Unit_Name (S : String) return String;

   --  Return the main unit name corresponding to S by replacing '.' with '_'

   function Get_Main_Name return String;

   --  This function is used in the Ada main output case to compute the

   --  correct external main program. It is "main" by default, unless the

   --  flag Use_Ada_Main_Program_Name_On_Target is set, in which case it

   --  is the name of the Ada main name without the "_ada". This default

   --  can be overridden explicitly using the -Mname binder switch.

   function Get_WC_Encoding return Character;

   --  Return wide character encoding method to set as WC_Encoding in output.

   --  If -W has been used, returns the specified encoding, otherwise returns

   --  the encoding method used for the main program source. If there is no

   --  main program source (-z switch used), returns brackets ('b').

   function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;

   --  Compare linker options, when sorting, first according to

   --  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 Set_Char (C : Character);

   --  Set given character in Statement_Buffer at the Last + 1 position

   --  and increment Last by one to reflect the stored character.

   procedure Set_Int (N : Int);

   --  Set given value in decimal in Statement_Buffer with no spaces

   --  starting at the Last + 1 position, and updating Last past the value.

   --  A minus sign is output for a negative value.

   procedure Set_Boolean (B : Boolean);

   --  Set given boolean value in Statement_Buffer at the Last + 1 position

   --  and update Last past the value.

   procedure Set_IS_Pragma_Table;

   --  Initializes contents of IS_Pragma_Settings table from ALI table

   procedure Set_Main_Program_Name;

   --  Given the main program name in Name_Buffer (length in Name_Len)

   --  generate the name of the routine to be used in the call. The name

   --  is generated starting at Last + 1, and Last is updated past it.

   procedure Set_Name_Buffer;

   --  Set the value stored in positions 1 .. Name_Len of the Name_Buffer

   procedure Set_PSD_Pragma_Table;

   --  Initializes contents of PSD_Pragma_Settings table from ALI table

   procedure Set_String (S : String);

   --  Sets characters of given string in Statement_Buffer, starting at the

   --  Last + 1 position, and updating last past the string value.

   procedure Set_Unit_Name;

   --  Given a unit name in the Name_Buffer, copies it to Statement_Buffer,

   --  starting at the Last + 1 position, and updating last past the value.

   --  changing periods to double underscores, and updating Last appropriately.

   procedure Set_Unit_Number (U : Unit_Id);

   --  Sets unit number (first unit is 1, leading zeroes output to line

   --  up all output unit numbers nicely as required by the value, and

   --  by the total number of units.

   procedure Write_Info_Ada_C (Ada : String; C : String; Common : String);

   --  For C code case, write C & Common, for Ada case write Ada & Common

   --  to current binder output file using Write_Binder_Info.

   procedure Write_Statement_Buffer;

   --  Write out contents of statement buffer up to Last, and reset Last to 0

   procedure Write_Statement_Buffer (S : String);

   --  First writes its argument (using Set_String (S)), then writes out the

   --  contents of statement buffer up to Last, and reset Last to 0

   ------------------------------------

   -- Check_System_Restrictions_Used --

   ------------------------------------

   procedure Check_System_Restrictions_Used is

   begin

      for J in Units.First .. Units.Last loop

         if Get_Name_String (Units.Table (J).Sfile) = "s-restri.ads" then

            System_Restrictions_Used := True;

            return;

         end if;

      end loop;

      System_Restrictions_Used := False;

   end Check_System_Restrictions_Used;

   ----------------------

   -- Gen_Adafinal_Ada --

   ----------------------

   procedure Gen_Adafinal_Ada is

   begin

      WBI ("");

      WBI ("   procedure " & Ada_Final_Name.all & " is");

      WBI ("   begin");

      --  If compiling for the JVM, we directly call Adafinal because

      --  we don't import it via Do_Finalize (see Gen_Output_File_Ada).

      if VM_Target /= No_VM then

         WBI ("      System.Standard_Library.Adafinal;");

      --  If there is no finalization, there is nothing to do

      elsif Cumulative_Restrictions.Set (No_Finalization) then

         WBI ("      null;");

      else

         WBI ("      Do_Finalize;");

      end if;

      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;

   ---------------------

   -- Gen_Adainit_Ada --

   ---------------------

   procedure Gen_Adainit_Ada is

      Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;

   begin

      WBI ("   procedure " & Ada_Init_Name.all & " is");

      --  Generate externals for elaboration entities

      for E in Elab_Order.First .. Elab_Order.Last loop

         declare

            Unum : constant Unit_Id := Elab_Order.Table (E);

            U    : Unit_Record renames Units.Table (Unum);

         begin

            --  Check for Elab_Entity to be set for this unit

            if U.Set_Elab_Entity

            --  Don't generate reference for stand alone library

              and then not U.SAL_Interface

            --  Don't generate reference for predefined file in No_Run_Time

            --  mode, since we don't include the object files in this case

              and then not

                (No_Run_Time_Mode

                   and then Is_Predefined_File_Name (U.Sfile))

            then

               Set_String ("      ");

               Set_String ("E");

               Set_Unit_Number (Unum);

               case VM_Target is

                  when No_VM | JVM_Target =>

                     Set_String (" : Boolean; pragma Import (Ada, ");

                  when CLI_Target =>

                     Set_String (" : Boolean; pragma Import (CIL, ");

               end case;

               Set_String ("E");

               Set_Unit_Number (Unum);

               Set_String (", """);

               Get_Name_String (U.Uname);

               --  In the case of JGNAT we need to emit an Import name

               --  that includes the class name (using '$' separators

               --  in the case of a child unit name).

               if 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 VM_Target /= CLI_Target or else U.Unit_Kind = 's' then

                     Set_String (".");

                  else

                     Set_String ("_pkg.");

                  end if;

                  --  If the unit name is very long, then split the

                  --  Import link name across lines using "&" (occurs

                  --  in some C2 tests).

                  if 2 * Name_Len + 60 > Hostparm.Max_Line_Length then

                     Set_String (""" &");

                     Write_Statement_Buffer;

                     Set_String ("         """);

                  end if;

               end if;

               Set_Unit_Name;

               Set_String ("_E"");");

               Write_Statement_Buffer;

            end if;

         end;

      end loop;

      Write_Statement_Buffer;

      --  If the standard library is suppressed, then the only global variable

      --  that might be needed (by the Ravenscar profile) is the priority of

      --  the environment.

      if 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;

         WBI ("   begin");

         if Main_Priority /= No_Main_Priority then

            Set_String ("      Main_Priority := ");

            Set_Int    (Main_Priority);

            Set_Char   (';');

            Write_Statement_Buffer;

         else

            WBI ("      null;");

         end if;

      --  Normal case (standard library not suppressed). Set all global values

      --  used by the run time.

      else

         WBI ("      Main_Priority : Integer;");

         WBI ("      pragma Import (C, Main_Priority, " &

              """__gl_main_priority"");");

         WBI ("      Time_Slice_Value : Integer;");

         WBI ("      pragma Import (C, Time_Slice_Value, " &

              """__gl_time_slice_val"");");

         WBI ("      WC_Encoding : Character;");

         WBI ("      pragma Import (C, WC_Encoding, ""__gl_wc_encoding"");");

         WBI ("      Locking_Policy : Character;");

         WBI ("      pragma Import (C, Locking_Policy, " &

              """__gl_locking_policy"");");

         WBI ("      Queuing_Policy : Character;");

         WBI ("      pragma Import (C, Queuing_Policy, " &

              """__gl_queuing_policy"");");

         WBI ("      Task_Dispatching_Policy : Character;");

         WBI ("      pragma Import (C, Task_Dispatching_Policy, " &

              """__gl_task_dispatching_policy"");");

         WBI ("      Priority_Specific_Dispatching : System.Address;");

         WBI ("      pragma Import (C, Priority_Specific_Dispatching, " &

              """__gl_priority_specific_dispatching"");");

         WBI ("      Num_Specific_Dispatching : Integer;");

         WBI ("      pragma Import (C, Num_Specific_Dispatching, " &

              """__gl_num_specific_dispatching"");");

         WBI ("      Interrupt_States : System.Address;");

         WBI ("      pragma Import (C, Interrupt_States, " &

              """__gl_interrupt_states"");");

         WBI ("      Num_Interrupt_States : Integer;");

         WBI ("      pragma Import (C, Num_Interrupt_States, " &

              """__gl_num_interrupt_states"");");

         WBI ("      Unreserve_All_Interrupts : Integer;");

         WBI ("      pragma Import (C, Unreserve_All_Interrupts, " &

              """__gl_unreserve_all_interrupts"");");

         if Exception_Tracebacks then

            WBI ("      Exception_Tracebacks : Integer;");

            WBI ("      pragma Import (C, Exception_Tracebacks, " &

                 """__gl_exception_tracebacks"");");

         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"");");

         WBI ("      Leap_Seconds_Support : Integer;");

         WBI ("      pragma Import (C, Leap_Seconds_Support, " &

              """__gl_leap_seconds_support"");");

         --  Import entry point for elaboration time signal handler

         --  installation, and indication of 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"");");

         --  Import entry point for environment feature enable/disable

         --  routine, and indication that it's been called previously.

         if OpenVMS_On_Target then

            WBI ("");

            WBI ("      procedure Set_Features;");

            WBI ("      pragma Import (C, Set_Features, " &

                 """__gnat_set_features"");");

            WBI ("");

            WBI ("      Features_Set : Integer;");

            WBI ("      pragma Import (C, Features_Set, " &

                 """__gnat_features_set"");");

         end if;

         --  Initialize stack limit variable of the environment task if the

         --  stack check method is stack limit and stack check is enabled.

         if Stack_Check_Limits_On_Target

           and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)

         then

            WBI ("");

            WBI ("      procedure Initialize_Stack_Limit;");

            WBI ("      pragma Import (C, Initialize_Stack_Limit, " &

                 """__gnat_initialize_stack_limit"");");

         end if;

         --  Special processing when main program is CIL function/procedure

         if VM_Target = CLI_Target

           and then Bind_Main_Program

           and then not No_Main_Subprogram

         then

            WBI ("");

            --  Function case, use Set_Exit_Status to report the returned

            --  status code, since that is the only mechanism available.

            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;");

            --  Procedure case

            else

               WBI ("      procedure Ada_Main_Program;");

            end if;

            Get_Name_String (Units.Table (First_Unit_Entry).Uname);

            Name_Len := Name_Len - 2;

            WBI ("      pragma Import (CIL, Ada_Main_Program, """

                 & Name_Buffer (1 .. Name_Len) & "."

                 & Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len)) & """);");

         end if;

         WBI ("   begin");

         Set_String ("      Main_Priority := ");

         Set_Int    (Main_Priority);

         Set_Char   (';');

         Write_Statement_Buffer;

         Set_String ("      Time_Slice_Value := ");

         if Task_Dispatching_Policy_Specified = 'F'

           and then ALIs.Table (ALIs.First).Time_Slice_Value = -1

         then

            Set_Int (0);

         else

            Set_Int (ALIs.Table (ALIs.First).Time_Slice_Value);

         end if;

         Set_Char   (';');

         Write_Statement_Buffer;

         Set_String ("      WC_Encoding := '");

         Set_Char   (Get_WC_Encoding);

         Set_String ("';");

         Write_Statement_Buffer;

         Set_String ("      Locking_Policy := '");

         Set_Char   (Locking_Policy_Specified);

         Set_String ("';");

         Write_Statement_Buffer;

         Set_String ("      Queuing_Policy := '");

         Set_Char   (Queuing_Policy_Specified);

         Set_String ("';");

         Write_Statement_Buffer;

         Set_String ("      Task_Dispatching_Policy := '");

         Set_Char   (Task_Dispatching_Policy_Specified);

         Set_String ("';");

         Write_Statement_Buffer;

         Gen_Restrictions_Ada;

         WBI ("      Priority_Specific_Dispatching :=");

         WBI ("        Local_Priority_Specific_Dispatching'Address;");

         Set_String ("      Num_Specific_Dispatching := ");

         Set_Int (PSD_Pragma_Settings.Last + 1);

         Set_Char (';');

         Write_Statement_Buffer;

         WBI ("      Interrupt_States := Local_Interrupt_States'Address;");

         Set_String ("      Num_Interrupt_States := ");

         Set_Int (IS_Pragma_Settings.Last + 1);

         Set_Char (';');

         Write_Statement_Buffer;

         Set_String ("      Unreserve_All_Interrupts := ");

         if Unreserve_All_Interrupts_Specified then

            Set_String ("1");

         else

            Set_String ("0");

         end if;

         Set_Char (';');

         Write_Statement_Buffer;

         if Exception_Tracebacks then

            WBI ("      Exception_Tracebacks := 1;");

         end if;

         Set_String ("      Zero_Cost_Exceptions := ");

         if Zero_Cost_Exceptions_Specified then

            Set_String ("1");

         else

            Set_String ("0");

         end if;

         Set_String (";");

         Write_Statement_Buffer;

         Set_String ("      Detect_Blocking := ");

         if Detect_Blocking then

            Set_Int (1);

         else

            Set_Int (0);

         end if;

         Set_String (";");

         Write_Statement_Buffer;

         Set_String ("      Default_Stack_Size := ");

         Set_Int (Default_Stack_Size);

         Set_String (";");

         Write_Statement_Buffer;

         Set_String ("      Leap_Seconds_Support := ");

         if Leap_Seconds_Support then

            Set_Int (1);

         else

            Set_Int (0);

         end if;

         Set_String (";");

         Write_Statement_Buffer;

         --  Generate call to Install_Handler

         WBI ("");