URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [exp_atag.adb] - Rev 281
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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;