------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ A T A G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2007, 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 2, 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 COPYING. If not, write -- -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- -- Boston, MA 02110-1301, USA. -- -- -- -- 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 Nlists; use Nlists; with Nmake; use Nmake; with Rtsfind; use Rtsfind; 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); function Build_Predef_Prims (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id; -- 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); ------------------------------------------------ -- 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_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 return Make_Indexed_Component (Loc, Prefix => Build_Predef_Prims (Loc, Tag_Node), 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; Old_Tag_Node : Node_Id; New_Tag_Node : Node_Id; Num_Prims : Nat) return Node_Id is begin 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)))); 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_Selected_Component (Loc, Prefix => Build_DT (Loc, New_Tag_Node), Selector_Name => New_Reference_To (RTE_Record_Component (RE_Predef_Prims), Loc)))), Discrete_Range => Make_Range (Loc, Make_Integer_Literal (Loc, Uint_1), New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc))), Expression => Make_Slice (Loc, Prefix => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr), Make_Selected_Component (Loc, Prefix => Build_DT (Loc, Old_Tag_Node), Selector_Name => New_Reference_To (RTE_Record_Component (RE_Predef_Prims), Loc)))), Discrete_Range => Make_Range (Loc, Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => New_Reference_To (RTE (RE_Default_Prim_Op_Count), Loc)))); end Build_Inherit_Predefined_Prims; ------------------------ -- Build_Predef_Prims -- ------------------------ function Build_Predef_Prims (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is begin return 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)))))); end Build_Predef_Prims; ------------------------------------------ -- 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 => Build_Get_Predefined_Prim_Op_Address (Loc, Tag_Node, 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_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;