------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              E X P _ S E L                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2005, 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 2,  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 COPYING.  If not, write --
-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, USA.                                              --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Einfo;   use Einfo;
with Nlists;  use Nlists;
with Nmake;   use Nmake;
with Rtsfind; use Rtsfind;
with Stand;   use Stand;
with Tbuild;  use Tbuild;

package body Exp_Sel is

   -----------------------
   -- Build_Abort_Block --
   -----------------------

   function Build_Abort_Block
     (Loc         : Source_Ptr;
      Abr_Blk_Ent : Entity_Id;
      Cln_Blk_Ent : Entity_Id;
      Blk         : Node_Id) return Node_Id
   is
   begin
      return
        Make_Block_Statement (Loc,
          Identifier   => New_Reference_To (Abr_Blk_Ent, Loc),

          Declarations => No_List,

          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc,
              Statements =>
                New_List (
                  Make_Implicit_Label_Declaration (Loc,
                    Defining_Identifier =>
                      Cln_Blk_Ent,
                    Label_Construct =>
                      Blk),
                  Blk),

              Exception_Handlers =>
                New_List (
                  Make_Exception_Handler (Loc,
                    Exception_Choices =>
                      New_List (
                        New_Reference_To (Stand.Abort_Signal, Loc)),
                    Statements =>
                      New_List (
                        Make_Procedure_Call_Statement (Loc,
                          Name =>
                            New_Reference_To (RTE (
                              RE_Abort_Undefer), Loc),
                          Parameter_Associations => No_List))))));
   end Build_Abort_Block;

   -------------
   -- Build_B --
   -------------

   function Build_B
     (Loc   : Source_Ptr;
      Decls : List_Id) return Entity_Id
   is
      B : constant Entity_Id := Make_Defining_Identifier (Loc,
                                  Chars => New_Internal_Name ('B'));

   begin
      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier =>
            B,
          Object_Definition =>
            New_Reference_To (Standard_Boolean, Loc),
          Expression =>
            New_Reference_To (Standard_False, Loc)));

      return B;
   end Build_B;

   -------------
   -- Build_C --
   -------------

   function Build_C
     (Loc   : Source_Ptr;
      Decls : List_Id) return Entity_Id
   is
      C : constant Entity_Id := Make_Defining_Identifier (Loc,
                                  Chars => New_Internal_Name ('C'));

   begin
      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier =>
            C,
          Object_Definition =>
            New_Reference_To (RTE (RE_Prim_Op_Kind), Loc)));

      return C;
   end Build_C;

   -------------------------
   -- Build_Cleanup_Block --
   -------------------------

   function Build_Cleanup_Block
     (Loc       : Source_Ptr;
      Blk_Ent   : Entity_Id;
      Stmts     : List_Id;
      Clean_Ent : Entity_Id) return Node_Id
   is
      Cleanup_Block : constant Node_Id :=
                        Make_Block_Statement (Loc,
                          Identifier   => New_Reference_To (Blk_Ent, Loc),
                          Declarations => No_List,
                          Handled_Statement_Sequence =>
                            Make_Handled_Sequence_Of_Statements (Loc,
                              Statements => Stmts),
                          Is_Asynchronous_Call_Block => True);

   begin
      Set_Entry_Cancel_Parameter (Blk_Ent, Clean_Ent);

      return Cleanup_Block;
   end Build_Cleanup_Block;

   -------------
   -- Build_K --
   -------------

   function Build_K
     (Loc   : Source_Ptr;
      Decls : List_Id;
      Obj   : Entity_Id) return Entity_Id
   is
      K : constant Entity_Id := Make_Defining_Identifier (Loc,
                                  Chars => New_Internal_Name ('K'));

   begin
      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier => K,
          Object_Definition   =>
            New_Reference_To (RTE (RE_Tagged_Kind), Loc),
          Expression          =>
            Make_Function_Call (Loc,
              Name => New_Reference_To (RTE (RE_Get_Tagged_Kind), Loc),
              Parameter_Associations => New_List (
                Unchecked_Convert_To (RTE (RE_Tag), Obj)))));

      return K;
   end Build_K;

   -------------
   -- Build_S --
   -------------

   function Build_S
     (Loc   : Source_Ptr;
      Decls : List_Id) return Entity_Id
   is
      S : constant Entity_Id := Make_Defining_Identifier (Loc,
                                  Chars => New_Internal_Name ('S'));

   begin
      Append_To (Decls,
        Make_Object_Declaration (Loc,
          Defining_Identifier => S,
          Object_Definition   =>
            New_Reference_To (Standard_Integer, Loc)));

      return S;
   end Build_S;

   ------------------------
   -- Build_S_Assignment --
   ------------------------

   function Build_S_Assignment
     (Loc      : Source_Ptr;
      S        : Entity_Id;
      Obj      : Entity_Id;
      Call_Ent : Entity_Id) return Node_Id
   is
   begin
      return
        Make_Assignment_Statement (Loc,
          Name => New_Reference_To (S, Loc),
          Expression =>
            Make_Function_Call (Loc,
              Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
              Parameter_Associations => New_List (
                Unchecked_Convert_To (RTE (RE_Tag), Obj),
                Make_Integer_Literal (Loc, DT_Position (Call_Ent)))));
   end Build_S_Assignment;

end Exp_Sel;