diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/exp_atag.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/exp_atag.adb | 573 |
1 files changed, 0 insertions, 573 deletions
diff --git a/gcc-4.4.3/gcc/ada/exp_atag.adb b/gcc-4.4.3/gcc/ada/exp_atag.adb deleted file mode 100644 index 318614e59..000000000 --- a/gcc-4.4.3/gcc/ada/exp_atag.adb +++ /dev/null @@ -1,573 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |