Subversion Repositories openrisc

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             E X P _ A T A G                              --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--          Copyright (C) 2006-2009, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Atree;    use Atree;
with Einfo;    use Einfo;
with Elists;   use Elists;
with Exp_Util; use Exp_Util;
with Namet;    use Namet;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Rtsfind;  use Rtsfind;
with Sinfo;    use Sinfo;
with Sem_Aux;  use Sem_Aux;
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
     (Loc    : Source_Ptr;
      DT_Ptr : Entity_Id;
      Stmts  : List_Id)
   is
   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.
 
      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 (
                Unchecked_Convert_To (RTE (RE_Tag),
                  New_Reference_To (DT_Ptr, Loc)),
                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_Defining_Identifier (Loc,
                                         New_Internal_Name ('D'));
      Obj_TSD  : constant Entity_Id := Make_Defining_Identifier (Loc,
                                         New_Internal_Name ('D'));
      Typ_TSD  : constant Entity_Id := Make_Defining_Identifier (Loc,
                                         New_Internal_Name ('D'));
      Index    : constant Entity_Id := Make_Defining_Identifier (Loc,
                                         New_Internal_Name ('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_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,
                            Chars => 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_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,
          Unchecked_Convert_To (RTE (RE_Tag_Ptr), This_Node));
 
      return
        Make_Explicit_Dereference (Loc,
          Unchecked_Convert_To (RTE (RE_Offset_To_Top_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),
                New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
                                  Loc)))));
   end Build_Offset_To_Top;
 
   ------------------------------------------
   -- Build_Set_Predefined_Prim_Op_Address --
   ------------------------------------------
 
   function Build_Set_Predefined_Prim_Op_Address
     (Loc          : Source_Ptr;
      Tag_Node     : Node_Id;
      Position     : Uint;
      Address_Node : Node_Id) return Node_Id
   is
   begin
      return
         Make_Assignment_Statement (Loc,
           Name =>
             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), Tag_Node))),
               Expressions =>
                 New_List (Make_Integer_Literal (Loc, Position))),
 
           Expression => Address_Node);
   end Build_Set_Predefined_Prim_Op_Address;
 
   -------------------------------
   -- Build_Set_Prim_Op_Address --
   -------------------------------
 
   function Build_Set_Prim_Op_Address
     (Loc          : Source_Ptr;
      Typ          : Entity_Id;
      Tag_Node     : Node_Id;
      Position     : Uint;
      Address_Node : Node_Id) return Node_Id
   is
      Ctrl_Tag : Node_Id := Tag_Node;
      New_Node : Node_Id;
 
   begin
      Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node);
 
      return
        Make_Assignment_Statement (Loc,
          Name       => New_Node,
          Expression => Address_Node);
   end Build_Set_Prim_Op_Address;
 
   -----------------------------
   -- Build_Set_Size_Function --
   -----------------------------
 
   function Build_Set_Size_Function
     (Loc       : Source_Ptr;
      Tag_Node  : Node_Id;
      Size_Func : Entity_Id) return Node_Id is
   begin
      pragma Assert (Chars (Size_Func) = Name_uSize
        and then RTE_Record_Component_Available (RE_Size_Func));
      return
        Make_Assignment_Statement (Loc,
          Name =>
            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_Size_Func), Loc)),
          Expression =>
            Unchecked_Convert_To (RTE (RE_Size_Ptr),
              Make_Attribute_Reference (Loc,
                Prefix => New_Reference_To (Size_Func, Loc),
                Attribute_Name => Name_Unrestricted_Access)));
   end Build_Set_Size_Function;
 
   ------------------------------------
   -- Build_Set_Static_Offset_To_Top --
   ------------------------------------
 
   function Build_Set_Static_Offset_To_Top
     (Loc          : Source_Ptr;
      Iface_Tag    : Node_Id;
      Offset_Value : Node_Id) return Node_Id is
   begin
      return
        Make_Assignment_Statement (Loc,
          Make_Explicit_Dereference (Loc,
            Unchecked_Convert_To (RTE (RE_Offset_To_Top_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), Iface_Tag),
                  New_Reference_To (RTE (RE_DT_Offset_To_Top_Offset),
                                    Loc))))),
          Offset_Value);
   end Build_Set_Static_Offset_To_Top;
 
   ---------------
   -- Build_TSD --
   ---------------
 
   function Build_TSD
     (Loc           : Source_Ptr;
      Tag_Node_Addr : 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 (
                  Tag_Node_Addr,
                  New_Reference_To
                    (RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
   end Build_TSD;
 
end Exp_Atag;