------------------------------------------------------------------------------ -- -- -- 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! (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;