Subversion Repositories openrisc

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

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             E X P _ A T A G                              --

--                                                                          --

--                                 S p e c                                  --

--                                                                          --

--          Copyright (C) 2006-2011, 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 Atree;    use Atree;

with Einfo;    use Einfo;

with Elists;   use Elists;

with Exp_Disp; use Exp_Disp;

with Exp_Util; use Exp_Util;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Rtsfind;  use Rtsfind;

with Sinfo;    use Sinfo;

with Sem_Aux;  use Sem_Aux;

with Sem_Disp; use Sem_Disp;

with Sem_Util; use Sem_Util;

with Stand;    use Stand;

with Snames;   use Snames;

with Tbuild;   use Tbuild;

package body Exp_Atag is

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

   -- Local Subprograms --

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

   function Build_DT

     (Loc      : Source_Ptr;

      Tag_Node : Node_Id) return Node_Id;

   --  Build code that displaces the Tag to reference the base of the wrapper

   --  record

   --

   --  Generates:

   --    To_Dispatch_Table_Ptr

   --      (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);

   function Build_TSD

     (Loc           : Source_Ptr;

      Tag_Node_Addr : 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_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);

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

   -- Build_Common_Dispatching_Select_Statements --

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

   procedure Build_Common_Dispatching_Select_Statements

     (Typ    : Entity_Id;

      Stmts  : List_Id)

   is

      Loc      : constant Source_Ptr := Sloc (Typ);

      Tag_Node : Node_Id;

   begin

      --  Generate:

      --    C := get_prim_op_kind (tag! (<type>VP), S);

      --  where C is the out parameter capturing the call kind and S is the

      --  dispatch table slot number.

      if Tagged_Type_Expansion then

         Tag_Node :=

           Unchecked_Convert_To (RTE (RE_Tag),

             New_Reference_To

              (Node (First_Elmt (Access_Disp_Table (Typ))), Loc));

      else

         Tag_Node :=

           Make_Attribute_Reference (Loc,

             Prefix => New_Reference_To (Typ, Loc),

             Attribute_Name => Name_Tag);

      end if;

      Append_To (Stmts,

        Make_Assignment_Statement (Loc,

          Name => Make_Identifier (Loc, Name_uC),

          Expression =>

            Make_Function_Call (Loc,

              Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc),

              Parameter_Associations => New_List (

                Tag_Node,

                Make_Identifier (Loc, Name_uS)))));

      --  Generate:

      --    if C = POK_Procedure

      --      or else C = POK_Protected_Procedure

      --      or else C = POK_Task_Procedure;

      --    then

      --       F := True;

      --       return;

      --  where F is the out parameter capturing the status of a potential

      --  entry call.

      Append_To (Stmts,

        Make_If_Statement (Loc,

          Condition =>

            Make_Or_Else (Loc,

              Left_Opnd =>

                Make_Op_Eq (Loc,

                  Left_Opnd  => Make_Identifier (Loc, Name_uC),

                  Right_Opnd =>

                    New_Reference_To (RTE (RE_POK_Procedure), Loc)),

              Right_Opnd =>

                Make_Or_Else (Loc,

                  Left_Opnd =>

                    Make_Op_Eq (Loc,

                      Left_Opnd => Make_Identifier (Loc, Name_uC),

                      Right_Opnd =>

                        New_Reference_To

                          (RTE (RE_POK_Protected_Procedure), Loc)),

                  Right_Opnd =>

                    Make_Op_Eq (Loc,

                      Left_Opnd  => Make_Identifier (Loc, Name_uC),

                      Right_Opnd =>

                        New_Reference_To

                          (RTE (RE_POK_Task_Procedure), Loc)))),

          Then_Statements =>

            New_List (

              Make_Assignment_Statement (Loc,

                Name       => Make_Identifier (Loc, Name_uF),

                Expression => New_Reference_To (Standard_True, Loc)),

              Make_Simple_Return_Statement (Loc))));

   end Build_Common_Dispatching_Select_Statements;

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

   -- Build_CW_Membership --

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

   procedure Build_CW_Membership

     (Loc          : Source_Ptr;

      Obj_Tag_Node : in out Node_Id;

      Typ_Tag_Node : Node_Id;

      Related_Nod  : Node_Id;

      New_Node     : out Node_Id)

   is

      Tag_Addr : constant Entity_Id := Make_Temporary (Loc, 'D', Obj_Tag_Node);

      Obj_TSD  : constant Entity_Id := Make_Temporary (Loc, 'D');

      Typ_TSD  : constant Entity_Id := Make_Temporary (Loc, 'D');

      Index    : constant Entity_Id := Make_Temporary (Loc, 'D');

   begin

      --  Generate:

      --    Tag_Addr : constant Tag := Address!(Obj_Tag);

      --    Obj_TSD  : constant Type_Specific_Data_Ptr

      --                          := Build_TSD (Tag_Addr);

      --    Typ_TSD  : constant Type_Specific_Data_Ptr

      --                          := Build_TSD (Address!(Typ_Tag));

      --    Index    : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth

      --    Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag

      Insert_Action (Related_Nod,

        Make_Object_Declaration (Loc,

          Defining_Identifier => Tag_Addr,

          Constant_Present    => True,

          Object_Definition   => New_Reference_To (RTE (RE_Address), Loc),

          Expression          => Unchecked_Convert_To

                                   (RTE (RE_Address), Obj_Tag_Node)));

      --  Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must

      --  update it.

      Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));

      Insert_Action (Related_Nod,

        Make_Object_Declaration (Loc,

          Defining_Identifier => Obj_TSD,

          Constant_Present    => True,

          Object_Definition   => New_Reference_To

                                   (RTE (RE_Type_Specific_Data_Ptr), Loc),

          Expression => Build_TSD (Loc, New_Reference_To (Tag_Addr, Loc))));

      Insert_Action (Related_Nod,

        Make_Object_Declaration (Loc,

          Defining_Identifier => Typ_TSD,

          Constant_Present    => True,

          Object_Definition   => New_Reference_To

                                   (RTE (RE_Type_Specific_Data_Ptr), Loc),

          Expression => Build_TSD (Loc,

                          Unchecked_Convert_To (RTE (RE_Address),

                            Typ_Tag_Node))));

      Insert_Action (Related_Nod,

        Make_Object_Declaration (Loc,

          Defining_Identifier => Index,

          Constant_Present    => True,

          Object_Definition   => New_Occurrence_Of (Standard_Integer, Loc),

          Expression =>

            Make_Op_Subtract (Loc,

              Left_Opnd =>

                Make_Selected_Component (Loc,

                  Prefix        => New_Reference_To (Obj_TSD, Loc),

                  Selector_Name =>

                     New_Reference_To

                       (RTE_Record_Component (RE_Idepth), Loc)),

               Right_Opnd =>

                 Make_Selected_Component (Loc,

                   Prefix        => New_Reference_To (Typ_TSD, Loc),

                   Selector_Name =>

                     New_Reference_To

                       (RTE_Record_Component (RE_Idepth), Loc)))));

      New_Node :=

        Make_And_Then (Loc,

          Left_Opnd =>

            Make_Op_Ge (Loc,

              Left_Opnd  => New_Occurrence_Of (Index, Loc),

              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        => New_Reference_To (Obj_TSD, Loc),

                      Selector_Name =>

                        New_Reference_To

                          (RTE_Record_Component (RE_Tags_Table), Loc)),

                  Expressions =>

                    New_List (New_Occurrence_Of (Index, Loc))),

              Right_Opnd => Typ_Tag_Node));

   end Build_CW_Membership;

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

   -- Build_DT --

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

   function Build_DT

     (Loc      : Source_Ptr;

      Tag_Node : Node_Id) return Node_Id

   is

   begin

      return

        Make_Function_Call (Loc,

          Name => New_Reference_To (RTE (RE_DT), Loc),

          Parameter_Associations => New_List (

            Unchecked_Convert_To (RTE (RE_Tag), Tag_Node)));

   end Build_DT;

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

   -- 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,

              Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),

          Selector_Name =>

            New_Reference_To

              (RTE_Record_Component (RE_Access_Level), Loc));

   end Build_Get_Access_Level;

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

   -- Build_Get_Alignment --

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

   function Build_Get_Alignment

     (Loc      : Source_Ptr;

      Tag_Node : Node_Id) return Node_Id

   is

   begin

      return

        Make_Selected_Component (Loc,

          Prefix        =>

            Build_TSD (Loc, Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),

          Selector_Name =>

            New_Reference_To (RTE_Record_Component (RE_Alignment), Loc));

   end Build_Get_Alignment;

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

   -- Build_Get_Predefined_Prim_Op_Address --

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

   procedure Build_Get_Predefined_Prim_Op_Address

     (Loc      : Source_Ptr;

      Position : Uint;

      Tag_Node : in out Node_Id;

      New_Node : out Node_Id)

   is

      Ctrl_Tag : Node_Id;

   begin

      Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node);

      --  Unchecked_Convert_To relocates the controlling tag node and therefore

      --  we must update it.

      Tag_Node := Expression (Ctrl_Tag);

      --  Build code that retrieves the address of the dispatch table

      --  containing the predefined Ada primitives:

      --

      --  Generate:

      --    To_Predef_Prims_Table_Ptr

      --     (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);

      New_Node :=

        Make_Indexed_Component (Loc,

          Prefix =>

            Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),

              Make_Explicit_Dereference (Loc,

                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, Name_Op_Subtract)),

                    Parameter_Associations => New_List (

                      Ctrl_Tag,

                      New_Reference_To

                        (RTE (RE_DT_Predef_Prims_Offset), Loc)))))),

          Expressions =>

            New_List (Make_Integer_Literal (Loc, Position)));

   end Build_Get_Predefined_Prim_Op_Address;

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

   -- Build_Inherit_CPP_Prims --

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

   function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is

      Loc          : constant Source_Ptr := Sloc (Typ);

      CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ);

      CPP_Table    : array (1 .. CPP_Nb_Prims) of Boolean := (others => False);

      CPP_Typ      : constant Entity_Id := Enclosing_CPP_Parent (Typ);

      Result       : constant List_Id   := New_List;

      Parent_Typ   : constant Entity_Id := Etype (Typ);

      E            : Entity_Id;

      Elmt         : Elmt_Id;

      Parent_Tag   : Entity_Id;

      Prim         : Entity_Id;

      Prim_Pos     : Nat;

      Typ_Tag      : Entity_Id;

   begin

      pragma Assert (not Is_CPP_Class (Typ));

      --  No code needed if this type has no primitives inherited from C++

      if CPP_Nb_Prims = 0 then

         return Result;

      end if;

      --  Stage 1: Inherit and override C++ slots of the primary dispatch table

      --  Generate:

      --     Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access;

      Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ)));

      Typ_Tag    := Node (First_Elmt (Access_Disp_Table (Typ)));

      Elmt := First_Elmt (Primitive_Operations (Typ));

      while Present (Elmt) loop

         Prim     := Node (Elmt);

         E        := Ultimate_Alias (Prim);

         Prim_Pos := UI_To_Int (DT_Position (E));

         --  Skip predefined, abstract, and eliminated primitives. Skip also

         --  primitives not located in the C++ part of the dispatch table.

         if not Is_Predefined_Dispatching_Operation (Prim)

           and then not Is_Predefined_Dispatching_Operation (E)

           and then not Present (Interface_Alias (Prim))

           and then not Is_Abstract_Subprogram (E)

           and then not Is_Eliminated (E)

           and then Prim_Pos <= CPP_Nb_Prims

           and then Find_Dispatching_Type (E) = Typ

         then

            --  Remember that this slot is used

            pragma Assert (CPP_Table (Prim_Pos) = False);

            CPP_Table (Prim_Pos) := True;

            Append_To (Result,

              Make_Assignment_Statement (Loc,

                Name =>

                  Make_Indexed_Component (Loc,

                    Prefix =>

                      Make_Explicit_Dereference (Loc,

                        Unchecked_Convert_To

                          (Node (Last_Elmt (Access_Disp_Table (Typ))),

                           New_Reference_To (Typ_Tag, Loc))),

                    Expressions =>

                       New_List (Make_Integer_Literal (Loc, Prim_Pos))),

               Expression =>

                 Unchecked_Convert_To (RTE (RE_Prim_Ptr),

                   Make_Attribute_Reference (Loc,

                     Prefix => New_Reference_To (E, Loc),

                     Attribute_Name => Name_Unrestricted_Access))));

         end if;

         Next_Elmt (Elmt);

      end loop;

      --  If all primitives have been overridden then there is no need to copy

      --  from Typ's parent its dispatch table. Otherwise, if some primitive is

      --  inherited from the parent we copy only the C++ part of the dispatch

      --  table from the parent before the assignments that initialize the

      --  overridden primitives.

      --  Generate:

      --     type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr;

      --     type CPP_TypH is access CPP_TypG;

      --     CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all;

      --   Note: There is no need to duplicate the declarations of CPP_TypG and

      --         CPP_TypH because, for expansion of dispatching calls, these

      --         entities are stored in the last elements of Access_Disp_Table.

      for J in CPP_Table'Range loop

         if not CPP_Table (J) then

            Prepend_To (Result,

              Make_Assignment_Statement (Loc,

                Name =>

                  Make_Explicit_Dereference (Loc,

                    Unchecked_Convert_To

                      (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),

                       New_Reference_To (Typ_Tag, Loc))),

                Expression =>

                  Make_Explicit_Dereference (Loc,

                    Unchecked_Convert_To

                      (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))),

                       New_Reference_To (Parent_Tag, Loc)))));

            exit;

         end if;

      end loop;

      --  Stage 2: Inherit and override C++ slots of secondary dispatch tables

      declare

         Iface                   : Entity_Id;

         Iface_Nb_Prims          : Nat;

         Parent_Ifaces_List      : Elist_Id;

         Parent_Ifaces_Comp_List : Elist_Id;

         Parent_Ifaces_Tag_List  : Elist_Id;

         Parent_Iface_Tag_Elmt   : Elmt_Id;

         Typ_Ifaces_List         : Elist_Id;

         Typ_Ifaces_Comp_List    : Elist_Id;

         Typ_Ifaces_Tag_List     : Elist_Id;

         Typ_Iface_Tag_Elmt      : Elmt_Id;

      begin

         Collect_Interfaces_Info

           (T               => Parent_Typ,

            Ifaces_List     => Parent_Ifaces_List,

            Components_List => Parent_Ifaces_Comp_List,

            Tags_List       => Parent_Ifaces_Tag_List);

         Collect_Interfaces_Info

           (T               => Typ,

            Ifaces_List     => Typ_Ifaces_List,

            Components_List => Typ_Ifaces_Comp_List,

            Tags_List       => Typ_Ifaces_Tag_List);

         Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List);

         Typ_Iface_Tag_Elmt    := First_Elmt (Typ_Ifaces_Tag_List);

         while Present (Parent_Iface_Tag_Elmt) loop

            Parent_Tag := Node (Parent_Iface_Tag_Elmt);

            Typ_Tag    := Node (Typ_Iface_Tag_Elmt);

            pragma Assert

              (Related_Type (Parent_Tag) = Related_Type (Typ_Tag));

            Iface := Related_Type (Parent_Tag);

            Iface_Nb_Prims :=

              UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface)));

            if Iface_Nb_Prims > 0 then

               --  Update slots of overridden primitives

               declare

                  Last_Nod : constant Node_Id := Last (Result);

                  Nb_Prims : constant Nat := UI_To_Int

                                              (DT_Entry_Count

                                               (First_Tag_Component (Iface)));

                  Elmt     : Elmt_Id;

                  Prim     : Entity_Id;

                  E        : Entity_Id;

                  Prim_Pos : Nat;

                  Prims_Table : array (1 .. Nb_Prims) of Boolean;

               begin

                  Prims_Table := (others => False);

                  Elmt := First_Elmt (Primitive_Operations (Typ));

                  while Present (Elmt) loop

                     Prim := Node (Elmt);

                     E    := Ultimate_Alias (Prim);

                     if not Is_Predefined_Dispatching_Operation (Prim)

                       and then Present (Interface_Alias (Prim))

                       and then Find_Dispatching_Type (Interface_Alias (Prim))

                                  = Iface

                       and then not Is_Abstract_Subprogram (E)

                       and then not Is_Eliminated (E)

                       and then Find_Dispatching_Type (E) = Typ

                     then

                        Prim_Pos := UI_To_Int (DT_Position (Prim));

                        --  Remember that this slot is already initialized

                        pragma Assert (Prims_Table (Prim_Pos) = False);

                        Prims_Table (Prim_Pos) := True;

                        Append_To (Result,

                          Make_Assignment_Statement (Loc,

                            Name =>

                              Make_Indexed_Component (Loc,

                                Prefix =>

                                  Make_Explicit_Dereference (Loc,

                                    Unchecked_Convert_To

                                      (Node

                                        (Last_Elmt

                                          (Access_Disp_Table (Iface))),

                                       New_Reference_To (Typ_Tag, Loc))),

                                Expressions =>

                                   New_List

                                    (Make_Integer_Literal (Loc, Prim_Pos))),

                            Expression =>

                              Unchecked_Convert_To (RTE (RE_Prim_Ptr),

                                Make_Attribute_Reference (Loc,

                                  Prefix => New_Reference_To (E, Loc),

                                  Attribute_Name =>

                                    Name_Unrestricted_Access))));

                     end if;

                     Next_Elmt (Elmt);

                  end loop;

                  --  Check if all primitives from the parent have been

                  --  overridden (to avoid copying the whole secondary

                  --  table from the parent).

                  --   IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all;

                  for J in Prims_Table'Range loop

                     if not Prims_Table (J) then

                        Insert_After (Last_Nod,

                          Make_Assignment_Statement (Loc,

                            Name =>

                              Make_Explicit_Dereference (Loc,

                                Unchecked_Convert_To

                                 (Node (Last_Elmt (Access_Disp_Table (Iface))),

                                  New_Reference_To (Typ_Tag, Loc))),

                            Expression =>

                              Make_Explicit_Dereference (Loc,

                                Unchecked_Convert_To

                                 (Node (Last_Elmt (Access_Disp_Table (Iface))),

                                  New_Reference_To (Parent_Tag, Loc)))));

                        exit;

                     end if;

                  end loop;

               end;

            end if;

            Next_Elmt (Typ_Iface_Tag_Elmt);

            Next_Elmt (Parent_Iface_Tag_Elmt);

         end loop;

      end;

      return Result;

   end Build_Inherit_CPP_Prims;

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

   -- Build_Inherit_Prims --

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

   function Build_Inherit_Prims

     (Loc          : Source_Ptr;

      Typ          : Entity_Id;

      Old_Tag_Node : Node_Id;

      New_Tag_Node : Node_Id;

      Num_Prims    : Nat) return Node_Id

   is

   begin

      if RTE_Available (RE_DT) then

         return

           Make_Assignment_Statement (Loc,

             Name =>

               Make_Slice (Loc,

                 Prefix =>

                   Make_Selected_Component (Loc,

                     Prefix =>

                       Build_DT (Loc, 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 =>

                       Build_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 => Make_Integer_Literal (Loc, Num_Prims))));

      else

         return

           Make_Assignment_Statement (Loc,

             Name =>

               Make_Slice (Loc,

                 Prefix =>

                   Unchecked_Convert_To

                     (Node (Last_Elmt (Access_Disp_Table (Typ))),

                      New_Tag_Node),

                 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 =>

                   Unchecked_Convert_To

                     (Node (Last_Elmt (Access_Disp_Table (Typ))),

                      Old_Tag_Node),

                 Discrete_Range =>

                   Make_Range (Loc,

                     Low_Bound  => Make_Integer_Literal (Loc, 1),

                     High_Bound => Make_Integer_Literal (Loc, Num_Prims))));

      end if;

   end Build_Inherit_Prims;

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

   -- Build_Get_Prim_Op_Address --

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

   procedure Build_Get_Prim_Op_Address

     (Loc      : Source_Ptr;

      Typ      : Entity_Id;

      Position : Uint;

      Tag_Node : in out Node_Id;

      New_Node : out Node_Id)

   is

      New_Prefix : Node_Id;

   begin

      pragma Assert

        (Position <= DT_Entry_Count (First_Tag_Component (Typ)));

      --  At the end of the Access_Disp_Table list we have the type

      --  declaration required to convert the tag into a pointer to

      --  the prims_ptr table (see Freeze_Record_Type).

      New_Prefix :=

        Unchecked_Convert_To

          (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node);

      --  Unchecked_Convert_To relocates the controlling tag node and therefore

      --  we must update it.

      Tag_Node := Expression (New_Prefix);

      New_Node :=

        Make_Indexed_Component (Loc,

          Prefix      => New_Prefix,

          Expressions => New_List (Make_Integer_Literal (Loc, Position)));

   end Build_Get_Prim_Op_Address;

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

   -- Build_Get_Transportable --

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

   function Build_Get_Transportable

     (Loc      : Source_Ptr;

      Tag_Node : Node_Id) return Node_Id

   is

   begin

      return

        Make_Selected_Component (Loc,

          Prefix =>

            Build_TSD (Loc,

              Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),

          Selector_Name =>

            New_Reference_To

              (RTE_Record_Component (RE_Transportable), Loc));

   end Build_Get_Transportable;

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

   -- 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_Explicit_Dereference (Loc,

                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),

                    Make_Explicit_Dereference (Loc,

                      Unchecked_Convert_To (RTE (RE_Addr_Ptr),

                        New_Tag_Node)))),

              Discrete_Range => Make_Range (Loc,

                Make_Integer_Literal (Loc, Uint_1),

                New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))),

          Expression =>

            Make_Slice (Loc,

              Prefix =>

                Make_Explicit_Dereference (Loc,

                  Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),

                    Make_Explicit_Dereference (Loc,

                      Unchecked_Convert_To (RTE (RE_Addr_Ptr),

                        Old_Tag_Node)))),

              Discrete_Range =>

                Make_Range (Loc,

                  Make_Integer_Literal (Loc, 1),

                  New_Reference_To (RTE (RE_Max_Predef_Prims), Loc))));

   end Build_Inherit_Predefined_Prims;

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

   -- Build_Offset_To_Top --

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

   function Build_Offset_To_Top

     (Loc       : Source_Ptr;

      This_Node : Node_Id) return Node_Id

   is

      Tag_Node : Node_Id;

   begin

      Tag_Node :=

        Make_Explicit_Dereference (Loc,