garlic_90ef4b6f/Dist/xe_back-polyorb.adb

------------------------------------------------------------------------------
--                                                                          --
--                            GLADE COMPONENTS                              --
--                                                                          --
--                       X E _ B A C K . P O L Y O R B                      --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--         Copyright (C) 1995-2006 Free Software Foundation, Inc.           --
--                                                                          --
-- GNATDIST is  free software;  you  can redistribute  it and/or  modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software  Foundation;  either version 2,  or  (at your option) any later --
-- version. GNATDIST is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHANTABI- --
-- LITY 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  GNATDIST; see file COPYING.  If --
-- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA.                                              --
--                                                                          --
--                   GLADE  is maintained by AdaCore                        --
--                      (email: sales@adacore.com)                          --
--                                                                          --
------------------------------------------------------------------------------

with GNAT.Expect; use GNAT.Expect;
with GNAT.OS_Lib; use GNAT.OS_Lib;

with XE;          use XE;
with XE_Front;    use XE_Front;
with XE_Flags;    use XE_Flags;
with XE_IO;       use XE_IO;
with XE_Names;    use XE_Names;
with XE_Utils;    use XE_Utils;

with XE_Back;
pragma Elaborate_All (XE_Back);

package body XE_Back.PolyORB is

   type PolyORB_Backend is new Backend with null record;

   procedure Set_PCS_Dist_Flags (Self : access PolyORB_Backend);
   procedure Initialize (Self : access PolyORB_Backend);
   procedure Run_Backend (Self : access PolyORB_Backend);
   function Get_Detach_Flag (Self : access PolyORB_Backend) return Name_Id;

   Elaboration_File : File_Name_Type;
   Parameters_File : File_Name_Type;
   PCS_Project_File : File_Name_Type;

   type RU_Id is
     (RU_PolyORB,
      RU_PolyORB_Binding_Data,
      RU_PolyORB_Binding_Data_GIOP,
      RU_PolyORB_Binding_Data_GIOP_IIOP,
      RU_PolyORB_Initialization,
      RU_PolyORB_ORB_Controller,
      RU_PolyORB_ORB_Controller_Workers,
      RU_PolyORB_ORB,
      RU_PolyORB_ORB_No_Tasking,
      RU_PolyORB_ORB_Thread_Pool,
      RU_PolyORB_DSA_P,
      RU_PolyORB_DSA_P_Remote_Launch,
      RU_PolyORB_Parameters,
      RU_PolyORB_Parameters_Partition,
      RU_PolyORB_Partition_Elaboration,
      RU_PolyORB_Setup,
      RU_PolyORB_Setup_Access_Points,
      RU_PolyORB_Setup_Access_Points_IIOP,
      RU_PolyORB_Setup_Base,
      RU_PolyORB_Setup_IIOP,
      RU_PolyORB_Setup_OA,
      RU_PolyORB_Setup_OA_Basic_POA,
      RU_PolyORB_Setup_Tasking,
      RU_PolyORB_Setup_Tasking_Full_Tasking,
      RU_PolyORB_Setup_Tasking_No_Tasking,
      RU_PolyORB_Utils,
      RU_PolyORB_Utils_Strings,
      RU_PolyORB_Utils_Strings_Lists,
      RU_System,
      RU_System_DSA_Services,
      RU_System_Partition_Interface,
      RU_System_RPC,
      RU_System_RPC_Server,
      RU_Tasking);

   RU : array (RU_Id) of Unit_Name_Type;

   type RE_Id is
     (RE_Check,
      RE_Launch_Partition,
      RE_Run,
      RE_Shutdown_World,
      RE_The_ORB);

   RE : array (RE_Id) of Unit_Name_Type;

   RE_Unit_Table : constant array (RE_Id) of RU_Id :=
     (RE_Check             => RU_System_Partition_Interface,
      RE_Launch_Partition  => RU_PolyORB_DSA_P_Remote_Launch,
      RE_Run               => RU_PolyORB_ORB,
      RE_Shutdown_World    => RU_PolyORB_Initialization,
      RE_The_ORB           => RU_PolyORB_Setup);

   ---------------------
   -- Parameter types --
   ---------------------

   type PS_Id is
     (PS_Tasking, PS_DSA, PS_DSA_Local_RCIs);

   PS : array (PS_Id) of Unit_Name_Type;

   type PE_Id is
     (PE_Max_Spare_Threads,
      PE_Max_Threads,
      PE_Min_Spare_Threads,
      PE_Rsh_Command,
      PE_Rsh_Options,
      PE_Termination_Initiator,
      PE_Termination_Policy);

   PE : array (PE_Id) of Unit_Name_Type;

   PE_Section_Table : constant array (PE_Id) of PS_Id :=
     (PE_Rsh_Command           => PS_DSA,
      PE_Rsh_Options           => PS_DSA,
      PE_Termination_Initiator => PS_DSA,
      PE_Termination_Policy    => PS_DSA,
      PE_Max_Spare_Threads     => PS_Tasking,
      PE_Max_Threads           => PS_Tasking,
      PE_Min_Spare_Threads     => PS_Tasking);

   -----------------------------
   -- Parameter table entries --
   -----------------------------

   type Parameter_Entry is record
      Var : Name_Id;
      Val : Name_Id;
   end record;

   Table : array (0 .. 31) of Parameter_Entry;
   Last  : Integer := -1;

   ---------------------------
   -- Generation Procedures --
   ---------------------------

   procedure Generate_Ada_Starter_Code;
   --  Generates Ada calls for starting the remote partitions

   procedure Generate_Elaboration_File (P : Partition_Id);
   --  Create the elaboration unit for the given partition. This unit
   --  overloads the default PCS settings.

   procedure Generate_Executable_File (P : Partition_Id);
   --  Compile main partition file and elaboration file.
   --  Bind and link partition to create executable.

   procedure Generate_Parameters_File (P : Partition_Id);
   --  Create parameters source unit for the given partition.

   procedure Generate_Partition_Main_File (P : Partition_Id);
   --  Create a procedure which "withes" all the RCI or SP receivers
   --  of the partition and insert the main procedure if needed.

   procedure Generate_PCS_Project_File;
   --  Generate a project files extending the one provided by the user,
   --  which includes PCS_Conf_Unit path in the sources dir.

   function Strip (S : String) return Unit_Name_Type;
   --  Return the prefix and a possible suffix from S

   procedure Set_Conf (Var : PE_Id; Val : Name_Id);
   --  Add a new entry in the configuration table

   procedure Set_Conf (Section : Name_Id; Key : Name_Id; Val : Name_Id);
   --  Add a new entry in the configuration table

   procedure Reset_Conf;
   --  Clear the configuration table

   -------------------------------
   -- Generate_Ada_Starter_Code --
   -------------------------------

   procedure Generate_Ada_Starter_Code
   is
      Env : constant String := Get_Environment_Vars_Command;
      Remote_Host : Name_Id;
   begin
      for J in Partitions.First + 1 .. Partitions.Last loop
         if J /= Main_Partition
           and then Partitions.Table (J).Passive /= BTrue
         then
            declare
               Partition   : Partition_Type renames Partitions.Table (J);
               Cmd : constant String := Get_Name_String
                 (To_Absolute_File (Partition.Executable_File)
                  & Partition.Command_Line);
               Full_Cmd : constant String := '"' & Env & Cmd & '"';
            begin
               Write_Image (Remote_Host, Partition.Host, J);
               if not Present (Remote_Host) then
                  Remote_Host := Id ("""localhost""");
               end if;

               Write_Call (RU (RE_Unit_Table (RE_Launch_Partition))
                           and RE (RE_Launch_Partition),
                           Remote_Host,
                           Full_Cmd);
            end;
         end if;
      end loop;
   end Generate_Ada_Starter_Code;

   -------------------------------
   -- Generate_Elaboration_File --
   -------------------------------

   procedure Generate_Elaboration_File (P : Partition_Id) is

      Filename     : File_Name_Type;
      File         : File_Descriptor;
      Current      : Partition_Type renames Partitions.Table (P);

   begin
      Filename := Elaboration_File & ADB_Suffix_Id;
      Filename := Dir (Current.Partition_Dir, Filename);
      Create_File (File, Filename);
      Set_Output  (File);

      Write_Line  ("pragma Warnings (Off);");

      --  Remote_Launch is only needed when using the Ada Starter,
      --  we avoid "withing" it otherwise since it drags sockets.

      if P = Main_Partition and then Default_Starter = Ada_Import then
         Write_With_Clause (RU (RU_PolyORB_DSA_P_Remote_Launch));
      end if;

      Write_With_Clause (RU (RU_PolyORB_Setup_IIOP), False, True);

      --  Setup.IIOP must be withed here, because
      --  polyorb-partition_elaboration.ads does not have visibility over IIOP
      --  packages.

      if Current.Tasking = 'N' then
         Write_With_Clause (RU (RU_PolyORB_Setup_Tasking_No_Tasking));
         Write_With_Clause (RU (RU_PolyORB_ORB_No_Tasking));
         Write_With_Clause (RU (RU_PolyORB_Binding_Data_GIOP_IIOP));

      else
         Write_With_Clause (RU (RU_PolyORB_Setup_Tasking_Full_Tasking));

         if Current.Tasking = 'T' then
            Write_With_Clause (RU (RU_PolyORB_ORB_No_Tasking));
            Write_With_Clause (RU (RU_PolyORB_Binding_Data_GIOP_IIOP));

         else
            Write_With_Clause (RU (RU_PolyORB_ORB_Thread_Pool));
            Write_With_Clause (RU (RU_PolyORB_Setup_Access_Points_IIOP));
         end if;
      end if;

      Write_Str  ("package body ");
      Write_Name (RU (RU_PolyORB_Partition_Elaboration));
      Write_Line (" is");
      Increment_Indentation;
      Write_Indentation;

      --  Launch remote partitions if needed

      Write_Line ("procedure Full_Launch is");
      Write_Indentation;
      Write_Line ("begin");
      Increment_Indentation;

      if P = Main_Partition and then Default_Starter = Ada_Import then
         Generate_Ada_Starter_Code;
      end if;

      --  Write a null statement, so that partitions which have
      --  an empty Full_Launch can still compile.

      Write_Indentation;
      Write_Line  ("null;");

      Decrement_Indentation;
      Write_Indentation;
      Write_Line  ("end Full_Launch;");

      Decrement_Indentation;
      Write_Str  ("end ");
      Write_Name (RU (RU_PolyORB_Partition_Elaboration));
      Write_Line (";");

      Close (File);
      Set_Standard_Output;
   end Generate_Elaboration_File;

   ------------------------------
   -- Generate_Executable_File --
   ------------------------------

   procedure Generate_Executable_File (P : Partition_Id) is
      Current    : Partition_Type renames Partitions.Table (P);
      Executable : File_Name_Type;
      Directory  : Directory_Name_Type;
      I_Part_Dir : String_Access;
      Comp_Args  : String_List (1 .. 9);
      Make_Args  : String_List (1 .. 8);
      Sfile      : File_Name_Type;
      Prj_Fname  : File_Name_Type;
      Length     : Natural;

   begin
      Executable := Current.Executable_File;
      Directory  := Current.Partition_Dir;

      Name_Len := 2;
      Name_Buffer (1) := '-';
      Name_Buffer (2) := 'I';
      Get_Name_String_And_Append (Directory);
      I_Part_Dir := new String'(Name_Buffer (1 .. Name_Len));

      --  Give the priority to partition and stub directory against
      --  current directory.

      Comp_Args (1) := E_Current_Dir;
      Comp_Args (2) := I_Part_Dir;
      Comp_Args (3) := I_Stub_Dir;
      Comp_Args (4) := I_Current_Dir;

      --  If there is no project file, then save ali and object files
      --  in partition directory.

      if Project_File_Name = null then
         Comp_Args (5) := Object_Dir_Flag;
         Comp_Args (6) := new String'(Get_Name_String (Directory));

      else
         Comp_Args (5) := Project_File_Flag;
         Prj_Fname     := Dir (Directory, Part_Prj_File_Name);
         Comp_Args (6) := new String'(Get_Name_String (Prj_Fname));
      end if;

      Length := 6;

      --  We already checked the consistency of all the partition
      --  units. In case of an inconsistency of exception mode, we may
      --  have to rebuild some parts of polyorb (units configured just
      --  for this partition). Note that some parts of PolyORB may have
      --  been already recompiled when the monolithic application was
      --  initially build. Some bodies may be missing as they are
      --  assigned to partitions we do not want to build. So compile
      --  silently and do not exit on errors (keep going).

      if Project_File_Name = null then
         Comp_Args (7) := Compile_Only_Flag;
         Comp_Args (8) := Keep_Going_Flag;
         Comp_Args (9) := Readonly_Flag;
         Length := 9;
      end if;

      --  Compile elaboration file

      Sfile := Elaboration_File & ADB_Suffix_Id;
      if Project_File_Name = null then
         Sfile := Dir (Directory, Sfile);
      end if;
      Compile (Sfile, Comp_Args (1 .. Length));

      --  Compile parameters file

      Sfile := Parameters_File & ADB_Suffix_Id;
      if Project_File_Name = null then
         Sfile := Dir (Directory, Sfile);
      end if;
      Compile (Sfile, Comp_Args (1 .. Length));

      --  Compile main file

      Sfile := Partition_Main_File & ADB_Suffix_Id;
      if Project_File_Name = null then
         Sfile := Dir (Directory, Sfile);
      end if;
      Compile (Sfile, Comp_Args (1 .. Length));

      Free (Comp_Args (6));

      --  Now we just want to bind and link as the ALI files are now
      --  consistent.

      Make_Args (1) := E_Current_Dir;
      Make_Args (2) := I_Part_Dir;
      Make_Args (3) := I_Stub_Dir;
      Make_Args (4) := I_Current_Dir;
      Make_Args (5) := Bind_Only_Flag;
      Make_Args (6) := Link_Only_Flag;

      if Project_File_Name = null then
         Make_Args (7) := Output_Flag;
         Make_Args (8) := new String'(Get_Name_String (Executable));

      else
         Make_Args (7) := Project_File_Flag;
         Prj_Fname := Dir (Directory, Part_Prj_File_Name);
         Make_Args (8) := new String'(Get_Name_String (Prj_Fname));
      end if;

      Build (Sfile, Make_Args, Fatal => True, Silent => False);

      Free (Make_Args (2));
      Free (Make_Args (8));
   end Generate_Executable_File;

   ------------------------------
   -- Generate_Parameters_File --
   ------------------------------

   procedure Generate_Parameters_File (P : Partition_Id) is

      Filename     : File_Name_Type;
      File         : File_Descriptor;
      Current      : Partition_Type renames Partitions.Table (P);

   begin
      Filename := Parameters_File & ADB_Suffix_Id;
      Filename := Dir (Current.Partition_Dir, Filename);
      Create_File (File, Filename);
      Set_Output  (File);

      --  Add the termination policy to the configuration table, if no
      --  termination policy is set, the default is Global_Termination.

      if Current.Termination /= No_Termination then
         Set_Conf (PE_Termination_Policy,
                   Termination_Img (Current.Termination));
      end if;

      --  Set the Tasking pool parameters

      if Current.Task_Pool /= No_Task_Pool then
         Set_Nat_To_Name_Buffer (Current.Task_Pool (1));
         Set_Conf (PE_Min_Spare_Threads, Name_Find);
         Set_Nat_To_Name_Buffer (Current.Task_Pool (2));
         Set_Conf (PE_Max_Spare_Threads, Name_Find);
         Set_Nat_To_Name_Buffer (Current.Task_Pool (3));
         Set_Conf (PE_Max_Threads, Name_Find);
      end if;

      --  Set the rsh parameters

      Set_Conf (PE_Rsh_Command, Get_Rsh_Command);
      Set_Conf (PE_Rsh_Options, Get_Rsh_Options);

      --  Set the DSA_Local_RCIs section parameters:
      --  For each RCI instantiated on this partition add a
      --  parameter <RCI NAME> set to true.

      declare
         U       : Conf_Unit_Id;
         Section : constant Name_Id := PS (PS_DSA_Local_RCIs);
         T       : constant Name_Id := Id ("true");
      begin
         U := Current.First_Unit;
         while U /= No_Conf_Unit_Id loop
            Set_Conf (Section, Conf_Units.Table (U).Name, T);
            U := Conf_Units.Table (U).Next_Unit;
         end loop;
      end;

      --  The configuration is done, start generating the code

      Write_Line ("pragma Warnings (Off);");
      Write_With_Clause (RU (RU_PolyORB_Initialization), True, True);
      Write_With_Clause (RU (RU_PolyORB_Utils), True);
      Write_With_Clause (RU (RU_PolyORB_Utils_Strings), True);
      Write_With_Clause (RU (RU_PolyORB_Utils_Strings_Lists), True);
      Write_Str  ("package body ");
      Write_Name (RU (RU_PolyORB_Parameters_Partition));
      Write_Line (" is");

      Increment_Indentation;
      Write_Indentation;
      Write_Line ("type Partition_Source is new Parameters_Source" &
                    " with null record;");
      Write_Indentation;
      Write_Line ("The_Partition_Source : aliased Partition_Source;");
      Write_Indentation;
      Write_Line ("type Parameter_Entry is record");

      Increment_Indentation;
      Write_Indentation;
      Write_Line ("Var : String_Ptr;");
      Write_Indentation;
      Write_Line ("Val : String_Ptr;");
      Decrement_Indentation;

      Write_Indentation;
      Write_Line ("end record;");
      Write_Indentation;
      Write_Line ("Table : array (0 .. 31) of Parameter_Entry;");
      Write_Indentation;
      Write_Line ("Last  : Integer := -1;");
      Write_Indentation;
      Write_Line ("function Get_Conf");

      Increment_Indentation;
      Write_Indentation (-1);
      Write_Line ("(Source       : access Partition_Source;");
      Write_Indentation;
      Write_Line ("Section, Key : String) return String");
      Decrement_Indentation;

      Write_Indentation;
      Write_Line ("is");

      Increment_Indentation;
      Write_Indentation;
      Write_Line ("S : constant String := Make_Global_Key (Section, Key);");
      Decrement_Indentation;

      Write_Indentation;
      Write_Line ("begin");

      Increment_Indentation;
      Write_Indentation;
      Write_Line ("for I in 0 .. Last loop");

      Increment_Indentation;
      Write_Indentation;
      Write_Line ("if Table (I).Var.all = S then");

      Increment_Indentation;
      Write_Indentation;
      Write_Line ("return Table (I).Val.all;");
      Decrement_Indentation;

      Write_Indentation;
      Write_Line ("end if;");
      Decrement_Indentation;

      Write_Indentation;
      Write_Line ("end loop;");
      Write_Indentation;
      Write_Line ("return """";");
      Decrement_Indentation;

      Write_Indentation;
      Write_Line ("end Get_Conf;");
      Write_Indentation;
      Write_Line ("procedure Initialize is");
      Write_Indentation;
      Write_Line ("begin");

      Increment_Indentation;
      Write_Indentation;
      Write_Line ("Last := -1;");

      for P in Table'First .. Last loop
         Write_Indentation;
         Write_Line ("Last := Last + 1;");
         Write_Indentation;
         Write_Str  ("Table (Last).Var := new String'(""");
         Write_Name (Table (P).Var);
         Write_Line (""");");
         Write_Indentation;
         Write_Str  ("Table (Last).Val := new String'(""");
         Write_Name (Table (P).Val);
         Write_Line (""");");
      end loop;

      Write_Indentation;
      Write_Line ("Register_Source (The_Partition_Source'Access);");
      Decrement_Indentation;

      Write_Indentation;
      Write_Line ("end Initialize;");
      Decrement_Indentation;

      Write_Indentation;
      Write_Line ("begin");

      Increment_Indentation;
      Write_Indentation;
      Write_Line ("Register_Module");

      Increment_Indentation;
      Write_Indentation (-1);
      Write_Line ("(Module_Info'");
      Write_Indentation;
      Write_Line ("(Name      => +""parameters.partition"",");
      Write_Indentation (+1);
      Write_Line ("Conflicts => Empty,");
      Write_Indentation (+1);
      Write_Line ("Depends   => Empty,");
      Write_Indentation (+1);
      Write_Line ("Provides  => +""parameters_sources"",");
      Write_Indentation (+1);
      Write_Line ("Implicit  => True,");
      Write_Indentation (+1);
      Write_Line ("Init      => Initialize'Access,");
      Write_Indentation (+1);
      Write_Line ("Shutdown  => null));");
      Decrement_Indentation;
      Decrement_Indentation;

      Write_Indentation;
      Write_Str  ("end ");
      Write_Name (RU (RU_PolyORB_Parameters_Partition));
      Write_Line (";");

      Close (File);
      Set_Standard_Output;

      --  Reset the configuration table so that next partition elaboration
      --  is configurated properly.

      Reset_Conf;
   end Generate_Parameters_File;

   ----------------------------------
   -- Generate_Partition_Main_File --
   ----------------------------------

   procedure Generate_Partition_Main_File (P : Partition_Id) is
      Filename  : File_Name_Type;
      File      : File_Descriptor;
      Current   : Partition_Type renames Partitions.Table (P);
      Conf_Unit : Conf_Unit_Id;
      Unit      : Unit_Id;
   begin
      Filename := Partition_Main_File & ADB_Suffix_Id;
      Filename := Dir (Current.Partition_Dir, Filename);
      Create_File (File, Filename);
      Set_Output  (File);
      Write_Line  ("pragma Warnings (Off);");

      Write_With_Clause (RU (RU_PolyORB_ORB));
      Write_With_Clause (RU (RU_PolyORB_Initialization));
      Write_With_Clause (RU (RU_PolyORB_Setup));
      Write_With_Clause (RU (RU_System_Partition_Interface));

      Write_With_Clause (RU (RU_System_DSA_Services));

      --  Assign RCI or SP skels on the partition

      Conf_Unit := Current.First_Unit;
      while Conf_Unit /= No_Conf_Unit_Id loop
         Write_With_Clause (Conf_Units.Table (Conf_Unit).Name);
         Conf_Unit := Conf_Units.Table (Conf_Unit).Next_Unit;
      end loop;

      --  Assign the RCI or SP stubs to compare version with skels

      for J in Current.First_Stub .. Current.Last_Stub loop
         Write_With_Clause (Stubs.Table (J));
      end loop;

      Write_Str  ("procedure ");
      Write_Name (Partition_Main_Name);
      Write_Line (" is");
      Write_Line ("begin");
      Increment_Indentation;

      --  Check version consistency of RCI stubs

      if Default_Version_Check then
         for J in Current.First_Stub .. Current.Last_Stub loop
            Unit := ALIs.Table (Get_ALI_Id (Stubs.Table (J))).Last_Unit;
            Write_Call (RU (RE_Unit_Table (RE_Check)) and RE (RE_Check),
                        Quote (Stubs.Table (J)), No_Str,
                        Stubs.Table (J) & "'Version",
                        Units.Table (Unit).RCI'Img);
         end loop;
      end if;

      --  Invoke main subprogram when there is one

      if Present (Current.Main_Subprogram) then
         Write_Call (Current.Main_Subprogram);

      --  XXX We launch ORB.Run although this is only required for a
      --  non-tasking server. Note that this can be considered as
      --  incorrect since the env task becomes indirectly part of the
      --  task pool.

      else
         Write_Call
           (RU (RE_Unit_Table (RE_Run)) and RE (RE_Run),
            RU (RE_Unit_Table (RE_The_ORB)) and RE (RE_The_ORB),
            "May_Poll => True");
      end if;

      Write_Line  ("exception");

      Write_Indentation;
      Write_Line ("when others =>");
      Increment_Indentation;
      Write_Call
         (RU (RE_Unit_Table (RE_Shutdown_World)) and RE (RE_Shutdown_World));
      Write_Indentation;
      Write_Line ("raise;");

      Decrement_Indentation;
      Decrement_Indentation;

      Write_Str  ("end ");
      Write_Name (Partition_Main_Name);
      Write_Line (";");

      Close (File);
      Set_Standard_Output;
   end Generate_Partition_Main_File;

   -------------------------------
   -- Generate_PCS_Project_File --
   -------------------------------

   procedure Generate_PCS_Project_File
   is
      Prj_Fname  : File_Name_Type;
      Prj_File   : File_Descriptor;
   begin
      Prj_Fname := Dir (Id (Root), PCS_Project_File);
      Create_File (Prj_File, Prj_Fname);
      Set_Output (Prj_File);
      Write_Str  ("project PCS_Conf extends """);
      Write_Str  (Project_File_Name.all);
      Write_Line (""" is");
      Write_Line ("   for Object_Dir use ""."";");
      Write_Str  ("   for Source_Dirs use ");
      Write_Str  (Strip_Directory (Project_File_Name.all));
      Write_Str  ("'Source_Dirs & """);

      declare
         Status      : aliased Integer;
         Arg         : String_Access := new String'("--prefix");
         Install_Dir : constant String :=
           Get_Command_Output ("polyorb-config",
                               (1 => Arg),
                               "",
                               Status'Access);
         DSA_Inc_Dir : constant String := Install_Dir
                                          & "/include/polyorb/dsa/";
      begin
         Write_Str (DSA_Inc_Dir);
         Free (Arg);
      end;

      Write_Line (""";");
      Write_Line ("end PCS_Conf;");
      Close (Prj_File);
      Set_Standard_Output;

      Free (Project_File_Name);

      --  Generated Project file overloads the project file provided by
      --  the user.

      Project_File_Name := new String'(
                             Normalize_Pathname (
                               Get_Name_String (Prj_Fname)));
   end Generate_PCS_Project_File;

   ---------------------
   -- Get_Detach_Flag --
   ---------------------

   function Get_Detach_Flag (Self : access PolyORB_Backend) return Name_Id
   is
      pragma Unreferenced (Self);
   begin
      return Id ("--polyorb-dsa-detach");
   end Get_Detach_Flag;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (Self : access PolyORB_Backend) is
      pragma Unreferenced (Self);

      Pos : Integer;
      Len : Natural;

   begin
      XE_Back.Initialize;

      --  This RCI unit has to be automatically configured on the main
      --  partition.

      PCS_Conf_Unit    := Id ("polyorb.dsa_p.partitions");
      PCS_Project_File := Id ("pcs_conf.gpr");
      Elaboration_File := Id ("polyorb-partition_elaboration");
      Parameters_File  := Id ("polyorb-parameters-partition");

      Register_Casing_Rule ("ORB");

      if Project_File_Name /= null then
         Generate_PCS_Project_File;
      end if;

      for U in RU_Id'First .. RU_Id'Last loop
         RU (U) := Strip (RU_Id'Image (U));

         --  Allow to get the litteral value back from the name id. As
         --  the default value of info is zero, and as the first pos
         --  of an enumeration type is also zero, increment the pos.

         Set_Name_Table_Info (RU (U), RU_Id'Pos (U) + 1);

         --  Look for parent units

         Pos := 0;
         Get_Name_String (RU (U));
         Len := Name_Len;
         while Name_Len > 0 loop
            if Name_Buffer (Name_Len) = '_' then
               Name_Len := Name_Len - 1;
               Pos := Integer (Get_Name_Table_Info (Name_Find));
               exit when Pos > 0;

            else
               Name_Len := Name_Len - 1;
            end if;
         end loop;

         --  When there is a parent, remove parent unit name from
         --  unit name to get real identifier.

         if Pos > 0 then
            Set_Str_To_Name_Buffer (Name_Buffer (Name_Len + 2 .. Len));
            RU (U) := RU (RU_Id'Val (Pos - 1)) and Name_Find;

         else
            Set_Str_To_Name_Buffer (Name_Buffer (1 .. Len));
            RU (U) := Name_Find;
         end if;

         if Debug_Mode then
            Message (U'Img & " = " & Get_Name_String (RU (U)));
         end if;
      end loop;

      for E in RE_Id loop
         RE (E) := Strip (RE_Id'Image (E));
      end loop;

      for S in PS_Id loop
         PS (S) := Strip (PS_Id'Image (S));
      end loop;

      for E in PE_Id loop
         PE (E) := Strip (PE_Id'Image (E));
      end loop;
   end Initialize;

   ----------------
   -- Reset_Conf --
   ----------------

   procedure Reset_Conf is
   begin
      Last := -1;
   end Reset_Conf;

   -----------------
   -- Run_Backend --
   -----------------

   procedure Run_Backend (Self : access PolyORB_Backend)
   is
      Current : Partition_Type;
      Is_Initiator_Set : Boolean := False;
   begin

      Prepare_Directories;

      Generate_All_Stubs_And_Skels;

      Export_Environment_Var ("POLYORB_DSA_NAME_SERVICE");

      --  Generate for each partition the elaboration, main, executable
      --  and stamp files.

      for J in Partitions.First + 1 .. Partitions.Last loop
         if Partitions.Table (J).To_Build then
            Current := Partitions.Table (J);

            if not Is_Initiator_Set
              and then Current.Tasking /= 'N'
              and then Current.Termination /= Local_Termination
            then
               Set_Str_To_Name_Buffer ("true");
               Set_Conf (PE_Termination_Initiator, Name_Find);
               Is_Initiator_Set := True;

               --  Because configuration is reset after generating each
               --  elaboration file, this conf parameter will only affect
               --  current partition.

            end if;

            if Current.To_Build and then Current.Passive /= BTrue then
               if Rebuild_Partition (J) then
                  if not Quiet_Mode then
                     Message ("building partition", Current.Name);
                  end if;

                  Generate_Parameters_File (J);
                  Generate_Elaboration_File (J);
                  Generate_Partition_Main_File (J);
                  Generate_Executable_File (J);
                  Generate_Stamp_File (J);
               end if;

            elsif Verbose_Mode then
               Message ("no need to expand", Current.Name);
            end if;
         end if;
      end loop;

      Generate_Starter_File (Backend_Access (Self));
   end Run_Backend;

   --------------
   -- Set_Conf --
   --------------

   procedure Set_Conf (Var : PE_Id; Val : Name_Id) is
   begin
      Set_Conf (Section => PS (PE_Section_Table (Var)),
                Key     => PE (Var),
                Val     => Val);
   end Set_Conf;

   procedure Set_Conf (Section : Name_Id; Key : Name_Id; Val : Name_Id) is
   begin
      Last := Last + 1;
      Name_Len := 0;
      Add_Str_To_Name_Buffer ("[");
      Get_Name_String_And_Append (Section);
      Add_Str_To_Name_Buffer ("]");
      Get_Name_String_And_Append (Key);
      To_Lower (Name_Buffer (1 .. Name_Len));
      Table (Last).Var := Name_Find;
      Table (Last).Val := Val;
   end Set_Conf;

   ------------------------
   -- Set_PCS_Dist_Flags --
   ------------------------

   procedure Set_PCS_Dist_Flags (Self : access PolyORB_Backend) is
      pragma Unreferenced (Self);
      Status         : aliased Integer;
   begin
      declare
         PolyORB_Config : constant String :=
           Get_Command_Output ("polyorb-config", (1 .. 0 => null), "",
                               Status'Access);
      begin
         Scan_Dist_Args (PolyORB_Config);
      end;
   exception
      when others =>
         Message ("PolyORB installation not found");
         raise Fatal_Error;
   end Set_PCS_Dist_Flags;

   -----------
   -- Strip --
   -----------

   function Strip (S : String) return Unit_Name_Type is
   begin
      Set_Str_To_Name_Buffer (S);
      Set_Str_To_Name_Buffer (Name_Buffer (4 .. Name_Len));
      Apply_Casing_Rules (Name_Buffer (1 .. Name_Len));

      while Name_Buffer (Name_Len) in '0' .. '9'
        or else Name_Buffer (Name_Len) = '_'
      loop
         Name_Len := Name_Len - 1;
      end loop;
      return Name_Find;
   end Strip;

begin
   Register_Backend ("polyorb", new PolyORB_Backend);
end XE_Back.PolyORB;