diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/exp_atag.adb')
-rw-r--r-- | gcc-4.4.0/gcc/ada/exp_atag.adb | 573 |
1 files changed, 573 insertions, 0 deletions
diff --git a/gcc-4.4.0/gcc/ada/exp_atag.adb b/gcc-4.4.0/gcc/ada/exp_atag.adb new file mode 100644 index 000000000..318614e59 --- /dev/null +++ b/gcc-4.4.0/gcc/ada/exp_atag.adb @@ -0,0 +1,573 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A T A G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2008, 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 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_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 : 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 (To_Address (Tag) - 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 -- + ------------------------- + + 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_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, 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 : Uint) return Node_Id + is + begin + -- 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); + + return + 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 ( + Unchecked_Convert_To (RTE (RE_Address), Tag_Node), + 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 -- + ------------------------------- + + function Build_Get_Prim_Op_Address + (Loc : Source_Ptr; + Typ : Entity_Id; + Tag_Node : Node_Id; + Position : Uint) return Node_Id + is + 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). + + return + Make_Indexed_Component (Loc, + Prefix => + Unchecked_Convert_To + (Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node), + 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, 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 + begin + return + Make_Assignment_Statement (Loc, + Name => Build_Get_Prim_Op_Address + (Loc, Typ, Tag_Node, Position), + 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, 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 : 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), + New_Reference_To + (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))))); + end Build_TSD; + +end Exp_Atag; |