------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ A T A G                              --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--            Copyright (C) 2006, 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 Atree;    use Atree;
with Einfo;    use Einfo;
with Exp_Util; use Exp_Util;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Rtsfind;  use Rtsfind;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with Tbuild;   use Tbuild;
with Uintp;    use Uintp;

package body Exp_Atag is

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Build_Predefined_DT
     (Loc      : Source_Ptr;
      Tag_Node : Node_Id) return Node_Id;
   --  Build code that displaces the Tag to reference the dispatch table
   --  containing the predefined primitives.
   --
   --  Generates: To_Tag (To_Address (Tag_Node) - DT_Prologue_Size);
   pragma Inline (Build_Predefined_DT);

   function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id;
   --  Build code that gives access to the distance from the tag to the
   --  Typeinfo component of the dispatch table.
   --
   --  Generates: DT_Typeinfo_Ptr_Size
   pragma Inline (Build_Typeinfo_Offset);

   function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id;
   --  Build code that retrieves the address of the record containing the Type
   --  Specific Data generated by GNAT.
   --
   --  Generate: To_Type_Specific_Data_Ptr
   --              (To_Address_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
   pragma Inline (Build_TSD);

   function RTE_Tag_Node return Entity_Id;
   --  Returns the entity associated with Ada.Tags.Tag
   pragma Inline (RTE_Tag_Node);

   -------------------------
   -- Build_CW_Membership --
   -------------------------

   function Build_CW_Membership
     (Loc          : Source_Ptr;
      Obj_Tag_Node : Node_Id;
      Typ_Tag_Node : Node_Id) return Node_Id
   is
      function Build_Pos return Node_Id;
      --  Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;

      function Build_Pos return Node_Id is
      begin
         return
            Make_Op_Subtract (Loc,
              Left_Opnd =>
                Make_Selected_Component (Loc,
                  Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)),
                  Selector_Name =>
                    New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)),

              Right_Opnd =>
                Make_Selected_Component (Loc,
                  Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)),
                  Selector_Name =>
                    New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)));
      end Build_Pos;

   --  Start of processing for Build_CW_Membership

   begin
      return
        Make_And_Then (Loc,
           Left_Opnd =>
             Make_Op_Ge (Loc,
               Left_Opnd  => Build_Pos,
               Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),

           Right_Opnd =>
             Make_Op_Eq (Loc,
               Left_Opnd =>
                 Make_Indexed_Component (Loc,
                   Prefix =>
                     Make_Selected_Component (Loc,
                       Prefix => Build_TSD (Loc, Obj_Tag_Node),
                       Selector_Name =>
                         New_Reference_To
                           (RTE_Record_Component (RE_Tags_Table), Loc)),
                   Expressions =>
                     New_List (Build_Pos)),

               Right_Opnd => Typ_Tag_Node));
   end Build_CW_Membership;

   ----------------------------
   -- Build_Get_Access_Level --
   ----------------------------

   function Build_Get_Access_Level
     (Loc      : Source_Ptr;
      Tag_Node : Node_Id) return Node_Id
   is
   begin
      return
        Make_Selected_Component (Loc,
          Prefix => Build_TSD (Loc, Tag_Node),
          Selector_Name =>
            New_Reference_To
              (RTE_Record_Component (RE_Access_Level), Loc));
   end Build_Get_Access_Level;

   ------------------------------------------
   -- Build_Get_Predefined_Prim_Op_Address --
   ------------------------------------------

   function Build_Get_Predefined_Prim_Op_Address
     (Loc           : Source_Ptr;
      Tag_Node      : Node_Id;
      Position_Node : Node_Id) return Node_Id
   is
   begin
      return
         Make_Indexed_Component (Loc,
           Prefix =>
             Make_Selected_Component (Loc,
               Prefix =>
                 Build_Predefined_DT (Loc, Tag_Node),

               Selector_Name =>
                 New_Reference_To
                   (RTE_Record_Component (RE_Prims_Ptr), Loc)),

           Expressions =>
             New_List (Position_Node));
   end Build_Get_Predefined_Prim_Op_Address;

   -------------------------------
   -- Build_Get_Prim_Op_Address --
   -------------------------------

   function Build_Get_Prim_Op_Address
     (Loc           : Source_Ptr;
      Tag_Node      : Node_Id;
      Position_Node : Node_Id) return Node_Id
   is
   begin
      return
        Make_Indexed_Component (Loc,
          Prefix =>
            Make_Selected_Component (Loc,
              Prefix =>
                Unchecked_Convert_To
                  (RTE_Tag_Node, Tag_Node),
              Selector_Name =>
                New_Reference_To
                  (RTE_Record_Component (RE_Prims_Ptr), Loc)),

          Expressions => New_List (Position_Node));
   end Build_Get_Prim_Op_Address;

   -------------------------
   -- Build_Get_RC_Offset --
   -------------------------

   function Build_Get_RC_Offset
     (Loc      : Source_Ptr;
      Tag_Node : Node_Id) return Node_Id
   is
   begin
      return
        Make_Selected_Component (Loc,
          Prefix => Build_TSD (Loc, Tag_Node),
          Selector_Name =>
            New_Reference_To
              (RTE_Record_Component (RE_RC_Offset), Loc));
   end Build_Get_RC_Offset;

   ---------------------------------
   -- Build_Get_Remotely_Callable --
   ---------------------------------

   function Build_Get_Remotely_Callable
     (Loc      : Source_Ptr;
      Tag_Node : Node_Id) return Node_Id
   is
   begin
      return
        Make_Selected_Component (Loc,
          Prefix => Build_TSD (Loc, Tag_Node),
          Selector_Name =>
            New_Reference_To
              (RTE_Record_Component (RE_Remotely_Callable), Loc));
   end Build_Get_Remotely_Callable;

   ------------------------------------
   -- Build_Inherit_Predefined_Prims --
   ------------------------------------

   function Build_Inherit_Predefined_Prims
     (Loc          : Source_Ptr;
      Old_Tag_Node : Node_Id;
      New_Tag_Node : Node_Id) return Node_Id
   is
   begin
      return
        Make_Assignment_Statement (Loc,
          Name =>
            Make_Slice (Loc,
              Prefix =>
                Make_Selected_Component (Loc,
                  Prefix =>
                    Build_Predefined_DT (Loc, New_Tag_Node),
                  Selector_Name =>
                    New_Reference_To
                      (RTE_Record_Component (RE_Prims_Ptr), Loc)),

              Discrete_Range => Make_Range (Loc,
                Make_Integer_Literal (Loc, Uint_1),
                New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))),

          Expression =>
            Make_Slice (Loc,
              Prefix =>
                Make_Selected_Component (Loc,
                  Prefix        => Build_Predefined_DT (Loc, Old_Tag_Node),
                  Selector_Name =>
                    New_Reference_To
                      (RTE_Record_Component (RE_Prims_Ptr), Loc)),
              Discrete_Range =>
                Make_Range (Loc,
                  Low_Bound  => Make_Integer_Literal (Loc, 1),
                  High_Bound =>
                    New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))));

   end Build_Inherit_Predefined_Prims;

   -------------------------
   -- Build_Inherit_Prims --
   -------------------------

   function Build_Inherit_Prims
     (Loc          : Source_Ptr;
      Old_Tag_Node : Node_Id;
      New_Tag_Node : Node_Id;
      Num_Prims    : Nat) return Node_Id
   is
   begin
      return
        Make_Assignment_Statement (Loc,
          Name =>
            Make_Slice (Loc,
              Prefix =>
                Make_Selected_Component (Loc,
                  Prefix =>
                    Unchecked_Convert_To (RTE_Tag_Node, New_Tag_Node),
                  Selector_Name =>
                    New_Reference_To
                      (RTE_Record_Component (RE_Prims_Ptr), Loc)),
              Discrete_Range =>
                Make_Range (Loc,
                Low_Bound  => Make_Integer_Literal (Loc, 1),
                High_Bound => Make_Integer_Literal (Loc, Num_Prims))),

          Expression =>
            Make_Slice (Loc,
              Prefix =>
                Make_Selected_Component (Loc,
                  Prefix =>
                    Unchecked_Convert_To (RTE_Tag_Node, Old_Tag_Node),
                  Selector_Name =>
                    New_Reference_To
                      (RTE_Record_Component (RE_Prims_Ptr), Loc)),
              Discrete_Range =>
                Make_Range (Loc,
                Low_Bound  => Make_Integer_Literal (Loc, 1),
                High_Bound => Make_Integer_Literal (Loc, Num_Prims))));
   end Build_Inherit_Prims;

   -------------------
   -- Build_New_TSD --
   -------------------

   function Build_New_TSD
     (Loc          : Source_Ptr;
      New_Tag_Node : Node_Id) return List_Id
   is
   begin
      return New_List (
         Make_Assignment_Statement (Loc,
           Name =>
             Make_Indexed_Component (Loc,
               Prefix =>
                 Make_Selected_Component (Loc,
                   Prefix => Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node)),
                   Selector_Name =>
                     New_Reference_To
                       (RTE_Record_Component (RE_Tags_Table), Loc)),
               Expressions => New_List (Make_Integer_Literal (Loc, Uint_0))),

           Expression => New_Tag_Node));
   end Build_New_TSD;

   -----------------------
   -- Build_Inherit_TSD --
   -----------------------

   function Build_Inherit_TSD
     (Loc               : Source_Ptr;
      Old_Tag_Node      : Node_Id;
      New_Tag_Node      : Node_Id;
      I_Depth           : Nat;
      Parent_Num_Ifaces : Nat) return Node_Id
   is
      function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id;
      --  Generates: Interface_Data_Ptr! (TSD (Tag).Ifaces_Table_Ptr).all

      ----------------------------
      --  Build_Iface_Table_Ptr --
      ----------------------------

      function Build_Iface_Table_Ptr (Tag_Node : Node_Id) return Node_Id is
      begin
         return
            Unchecked_Convert_To (RTE (RE_Interface_Data_Ptr),
              Make_Selected_Component (Loc,
                Prefix => Tag_Node,
                Selector_Name =>
                  New_Reference_To
                    (RTE_Record_Component (RE_Ifaces_Table_Ptr), Loc)));
      end Build_Iface_Table_Ptr;

      --  Local variables

      L       : constant List_Id := New_List;
      Old_TSD : Node_Id;
      New_TSD : Node_Id;

   --  Start of processing for Build_Inherit_TSD

   begin
      Old_TSD :=
        Make_Object_Declaration (Loc,
          Defining_Identifier =>
            Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
          Object_Definition =>
            New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc),
          Expression =>
            Build_TSD (Loc, Duplicate_Subexpr (Old_Tag_Node)));

      New_TSD :=
        Make_Object_Declaration (Loc,
          Defining_Identifier =>
            Make_Defining_Identifier (Loc, New_Internal_Name ('T')),
          Object_Definition =>
            New_Reference_To (RTE (RE_Type_Specific_Data_Ptr), Loc),
          Expression =>
            Build_TSD (Loc, Duplicate_Subexpr (New_Tag_Node)));

      Append_List_To (L, New_List (

         --  Copy the table of ancestors of the parent
         --    TSD (New_Tag).Tags_Table (1 .. I_Depth) :=
         --      TSD (Old_Tag).Tags_Table (0 .. I_Depth - 1);

         Make_Assignment_Statement (Loc,
           Name =>
             Make_Slice (Loc,
               Prefix =>
                 Make_Selected_Component (Loc,
                   Prefix =>
                     Make_Explicit_Dereference (Loc,
                       New_Reference_To (Defining_Identifier (New_TSD), Loc)),
                   Selector_Name =>
                     New_Reference_To
                       (RTE_Record_Component (RE_Tags_Table), Loc)),
               Discrete_Range => Make_Range (Loc,
                 Make_Integer_Literal (Loc, Uint_1),
                 Make_Integer_Literal (Loc, I_Depth))),

           Expression =>
             Make_Slice (Loc,
               Prefix =>
                 Make_Selected_Component (Loc,
                   Prefix =>
                     Make_Explicit_Dereference (Loc,
                       New_Reference_To (Defining_Identifier (Old_TSD), Loc)),
                   Selector_Name =>
                     New_Reference_To
                       (RTE_Record_Component (RE_Tags_Table), Loc)),
               Discrete_Range => Make_Range (Loc,
                 Make_Integer_Literal (Loc, Uint_0),
                 Make_Integer_Literal (Loc, I_Depth - 1))))));

         --  Copy the table of interfaces of the parent

         --  if not System."=" (TSD (Old_Tag).Ifaces_Table_Ptr,
         --                       System.Null_Address)
         --  then
         --     New_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces):=
         --       Old_Iface_Table_Ptr.Table (1 .. Parent_Num_Ifaces);
         --  end if;

         --  The table of interfaces is not available under certified run-time

         if RTE_Record_Component_Available (RE_Nb_Ifaces) then
            Append_To (L,
              Make_If_Statement (Loc,
                Condition =>
                  Make_Op_Not (Loc,
                    Right_Opnd =>
                      Make_Op_Eq (Loc,
                        Left_Opnd =>
                          Make_Selected_Component (Loc,
                            Prefix =>
                              Make_Explicit_Dereference (Loc,
                                New_Reference_To
                                  (Defining_Identifier (Old_TSD), Loc)),
                            Selector_Name =>
                              New_Reference_To
                                (RTE_Record_Component (RE_Ifaces_Table_Ptr),
                                 Loc)),
                        Right_Opnd =>
                          New_Reference_To (RTE (RE_Null_Address), Loc))),

                Then_Statements => New_List (
                  Make_Assignment_Statement (Loc,
                    Name =>
                      Make_Slice (Loc,
                        Prefix =>
                          Make_Selected_Component (Loc,
                            Prefix =>
                              Build_Iface_Table_Ptr
                                (New_Reference_To
                                  (Defining_Identifier (New_TSD), Loc)),
                            Selector_Name =>
                              New_Reference_To
                                (RTE_Record_Component (RE_Ifaces_Table), Loc)),

                        Discrete_Range => Make_Range (Loc,
                          Make_Integer_Literal (Loc, Uint_1),
                          Make_Integer_Literal (Loc, Parent_Num_Ifaces))),

                    Expression =>
                      Make_Slice (Loc,
                        Prefix =>
                          Make_Selected_Component (Loc,
                            Prefix =>
                              Build_Iface_Table_Ptr
                                (New_Reference_To
                                  (Defining_Identifier (Old_TSD), Loc)),
                            Selector_Name =>
                              New_Reference_To
                                (RTE_Record_Component (RE_Ifaces_Table), Loc)),

                        Discrete_Range => Make_Range (Loc,
                          Make_Integer_Literal (Loc, Uint_1),
                          Make_Integer_Literal (Loc, Parent_Num_Ifaces)))))));
         end if;

         --  TSD (New_Tag).Tags_Table (0) := New_Tag;

         Append_To (L,
            Make_Assignment_Statement (Loc,
              Name =>
                Make_Indexed_Component (Loc,
                  Prefix =>
                    Make_Selected_Component (Loc,
                      Prefix =>
                        Make_Explicit_Dereference (Loc,
                          New_Reference_To
                            (Defining_Identifier (New_TSD), Loc)),
                      Selector_Name =>
                        New_Reference_To
                          (RTE_Record_Component (RE_Tags_Table), Loc)),
                  Expressions =>
                    New_List (Make_Integer_Literal (Loc, Uint_0))),

              Expression => New_Tag_Node));

      return
        Make_Block_Statement (Loc,
          Declarations => New_List (
            Old_TSD,
            New_TSD),
          Handled_Statement_Sequence =>
            Make_Handled_Sequence_Of_Statements (Loc, L));

   end Build_Inherit_TSD;

   -------------------------
   -- Build_Predefined_DT --
   -------------------------

   function Build_Predefined_DT
     (Loc      : Source_Ptr;
      Tag_Node : Node_Id) return Node_Id
   is
   begin
      return
        Unchecked_Convert_To (RTE_Tag_Node,
          Make_Function_Call (Loc,
            Name =>
              Make_Expanded_Name (Loc,
                Chars         => Name_Op_Subtract,
                Prefix        =>
                  New_Reference_To (RTU_Entity (System_Storage_Elements), Loc),
                Selector_Name =>
                  Make_Identifier (Loc,
                    Chars => Name_Op_Subtract)),

            Parameter_Associations => New_List (
              Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
              New_Reference_To (RTE (RE_DT_Prologue_Size), Loc))));
   end Build_Predefined_DT;

   ----------------------------
   -- Build_Set_External_Tag --
   ----------------------------

   function Build_Set_External_Tag
     (Loc        : Source_Ptr;
      Tag_Node   : Node_Id;
      Value_Node : Node_Id) return Node_Id
   is
   begin
      return
         Make_Assignment_Statement (Loc,
           Name =>
             Make_Selected_Component (Loc,
               Prefix => Build_TSD (Loc, Tag_Node),
               Selector_Name =>
                 New_Reference_To
                   (RTE_Record_Component (RO_TA_External_Tag), Loc)),

           Expression =>
             Unchecked_Convert_To (RTE (RE_Cstring_Ptr), Value_Node));
   end Build_Set_External_Tag;

   ------------------------------------------
   -- Build_Set_Predefined_Prim_Op_Address --
   ------------------------------------------

   function Build_Set_Predefined_Prim_Op_Address
     (Loc           : Source_Ptr;
      Tag_Node      : Node_Id;
      Position_Node : Node_Id;
      Address_Node  : Node_Id) return Node_Id
   is
   begin
      return
         Make_Assignment_Statement (Loc,
           Name       => Build_Get_Predefined_Prim_Op_Address
                          (Loc, Tag_Node, Position_Node),
           Expression => Address_Node);
   end Build_Set_Predefined_Prim_Op_Address;

   -------------------------------
   -- Build_Set_Prim_Op_Address --
   -------------------------------

   function Build_Set_Prim_Op_Address
     (Loc           : Source_Ptr;
      Tag_Node      : Node_Id;
      Position_Node : Node_Id;
      Address_Node  : Node_Id) return Node_Id
   is
   begin
      return
         Make_Assignment_Statement (Loc,
           Name       => Build_Get_Prim_Op_Address (Loc,
                           Tag_Node, Position_Node),
           Expression => Address_Node);
   end Build_Set_Prim_Op_Address;

   -------------------
   -- Build_Set_TSD --
   -------------------

   function Build_Set_TSD
     (Loc        : Source_Ptr;
      Tag_Node   : Node_Id;
      Value_Node : Node_Id) return Node_Id
   is
   begin
      return
         Make_Assignment_Statement (Loc,
           Name =>
             Make_Explicit_Dereference (Loc,
               Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
                   Make_Function_Call (Loc,
                     Name =>
                       Make_Expanded_Name (Loc,
                         Chars => Name_Op_Subtract,
                         Prefix =>
                           New_Reference_To
                             (RTU_Entity (System_Storage_Elements), Loc),
                         Selector_Name =>
                           Make_Identifier (Loc,
                             Chars => Name_Op_Subtract)),

                     Parameter_Associations => New_List (
                       Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
                       Build_Typeinfo_Offset (Loc))))),

           Expression => Value_Node);
   end Build_Set_TSD;

   ---------------
   -- Build_TSD --
   ---------------

   function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
   begin
      return
        Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
          Make_Explicit_Dereference (Loc,
            Prefix => Unchecked_Convert_To (RTE (RE_Addr_Ptr),
                Make_Function_Call (Loc,
                  Name =>
                    Make_Expanded_Name (Loc,
                      Chars => Name_Op_Subtract,
                      Prefix =>
                        New_Reference_To
                          (RTU_Entity (System_Storage_Elements), Loc),
                      Selector_Name =>
                        Make_Identifier (Loc,
                          Chars => Name_Op_Subtract)),

                  Parameter_Associations => New_List (
                    Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
                    Build_Typeinfo_Offset (Loc))))));
   end Build_TSD;

   ---------------------------
   -- Build_Typeinfo_Offset --
   ---------------------------

   function Build_Typeinfo_Offset (Loc : Source_Ptr) return Node_Id is
   begin
      return New_Reference_To (RTE (RE_DT_Typeinfo_Ptr_Size), Loc);
   end Build_Typeinfo_Offset;

   ---------------
   --  Tag_Node --
   ---------------

   function RTE_Tag_Node return Entity_Id is
      E : constant Entity_Id := RTE (RE_Tag);
   begin
      if Atree.Present (Full_View (E)) then
         return Full_View (E);
      else
         return E;
      end if;
   end RTE_Tag_Node;
end Exp_Atag;
