------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ A T A G -- -- -- -- S p e c -- -- -- -- Copyright (C) 2006-2013, 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_Disp; use Exp_Disp; with Exp_Util; use Exp_Util; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sinfo; use Sinfo; with Sem_Aux; use Sem_Aux; with Sem_Disp; use Sem_Disp; 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 (Typ : Entity_Id; Stmts : List_Id) is Loc : constant Source_Ptr := Sloc (Typ); Tag_Node : Node_Id; 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. if Tagged_Type_Expansion then Tag_Node := Unchecked_Convert_To (RTE (RE_Tag), New_Occurrence_Of (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); else Tag_Node := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Tag); end if; 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 ( Tag_Node, 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_Occurrence_Of (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_Occurrence_Of (RTE (RE_POK_Protected_Procedure), Loc)), Right_Opnd => Make_Op_Eq (Loc, Left_Opnd => Make_Identifier (Loc, Name_uC), Right_Opnd => New_Occurrence_Of (RTE (RE_POK_Task_Procedure), Loc)))), Then_Statements => New_List ( Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name_uF), Expression => New_Occurrence_Of (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_Temporary (Loc, 'D', Obj_Tag_Node); Obj_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); Typ_TSD : constant Entity_Id := Make_Temporary (Loc, 'D'); Index : constant Entity_Id := Make_Temporary (Loc, '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_Occurrence_Of (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_Occurrence_Of (RTE (RE_Type_Specific_Data_Ptr), Loc), Expression => Build_TSD (Loc, New_Occurrence_Of (Tag_Addr, Loc)))); Insert_Action (Related_Nod, Make_Object_Declaration (Loc, Defining_Identifier => Typ_TSD, Constant_Present => True, Object_Definition => New_Occurrence_Of (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_Occurrence_Of (Obj_TSD, Loc), Selector_Name => New_Occurrence_Of (RTE_Record_Component (RE_Idepth), Loc)), Right_Opnd => Make_Selected_Component (Loc, Prefix => New_Occurrence_Of (Typ_TSD, Loc), Selector_Name => New_Occurrence_Of (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_Occurrence_Of (Obj_TSD, Loc), Selector_Name => New_Occurrence_Of (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_Occurrence_Of (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_Occurrence_Of (RTE_Record_Component (RE_Access_Level), Loc)); end Build_Get_Access_Level; ------------------------- -- Build_Get_Alignment -- ------------------------- function Build_Get_Alignment (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_Occurrence_Of (RTE_Record_Component (RE_Alignment), Loc)); end Build_Get_Alignment; ------------------------------------------ -- 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_Occurrence_Of (RTU_Entity (System_Storage_Elements), Loc), Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), Parameter_Associations => New_List ( Ctrl_Tag, New_Occurrence_Of (RTE (RE_DT_Predef_Prims_Offset), Loc)))))), Expressions => New_List (Make_Integer_Literal (Loc, Position))); end Build_Get_Predefined_Prim_Op_Address; ----------------------------- -- Build_Inherit_CPP_Prims -- ----------------------------- function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id is Loc : constant Source_Ptr := Sloc (Typ); CPP_Nb_Prims : constant Nat := CPP_Num_Prims (Typ); CPP_Table : array (1 .. CPP_Nb_Prims) of Boolean := (others => False); CPP_Typ : constant Entity_Id := Enclosing_CPP_Parent (Typ); Result : constant List_Id := New_List; Parent_Typ : constant Entity_Id := Etype (Typ); E : Entity_Id; Elmt : Elmt_Id; Parent_Tag : Entity_Id; Prim : Entity_Id; Prim_Pos : Nat; Typ_Tag : Entity_Id; begin pragma Assert (not Is_CPP_Class (Typ)); -- No code needed if this type has no primitives inherited from C++ if CPP_Nb_Prims = 0 then return Result; end if; -- Stage 1: Inherit and override C++ slots of the primary dispatch table -- Generate: -- Typ'Tag (Prim_Pos) := Prim'Unrestricted_Access; Parent_Tag := Node (First_Elmt (Access_Disp_Table (Parent_Typ))); Typ_Tag := Node (First_Elmt (Access_Disp_Table (Typ))); Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Elmt) loop Prim := Node (Elmt); E := Ultimate_Alias (Prim); Prim_Pos := UI_To_Int (DT_Position (E)); -- Skip predefined, abstract, and eliminated primitives. Skip also -- primitives not located in the C++ part of the dispatch table. if not Is_Predefined_Dispatching_Operation (Prim) and then not Is_Predefined_Dispatching_Operation (E) and then not Present (Interface_Alias (Prim)) and then not Is_Abstract_Subprogram (E) and then not Is_Eliminated (E) and then Prim_Pos <= CPP_Nb_Prims and then Find_Dispatching_Type (E) = Typ then -- Remember that this slot is used pragma Assert (CPP_Table (Prim_Pos) = False); CPP_Table (Prim_Pos) := True; Append_To (Result, Make_Assignment_Statement (Loc, Name => Make_Indexed_Component (Loc, Prefix => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt (Access_Disp_Table (Typ))), New_Occurrence_Of (Typ_Tag, Loc))), Expressions => New_List (Make_Integer_Literal (Loc, Prim_Pos))), Expression => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; Next_Elmt (Elmt); end loop; -- If all primitives have been overridden then there is no need to copy -- from Typ's parent its dispatch table. Otherwise, if some primitive is -- inherited from the parent we copy only the C++ part of the dispatch -- table from the parent before the assignments that initialize the -- overridden primitives. -- Generate: -- type CPP_TypG is array (1 .. CPP_Nb_Prims) ofd Prim_Ptr; -- type CPP_TypH is access CPP_TypG; -- CPP_TypG!(Typ_Tag).all := CPP_TypG!(Parent_Tag).all; -- Note: There is no need to duplicate the declarations of CPP_TypG and -- CPP_TypH because, for expansion of dispatching calls, these -- entities are stored in the last elements of Access_Disp_Table. for J in CPP_Table'Range loop if not CPP_Table (J) then Prepend_To (Result, Make_Assignment_Statement (Loc, Name => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), New_Occurrence_Of (Typ_Tag, Loc))), Expression => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), New_Occurrence_Of (Parent_Tag, Loc))))); exit; end if; end loop; -- Stage 2: Inherit and override C++ slots of secondary dispatch tables declare Iface : Entity_Id; Iface_Nb_Prims : Nat; Parent_Ifaces_List : Elist_Id; Parent_Ifaces_Comp_List : Elist_Id; Parent_Ifaces_Tag_List : Elist_Id; Parent_Iface_Tag_Elmt : Elmt_Id; Typ_Ifaces_List : Elist_Id; Typ_Ifaces_Comp_List : Elist_Id; Typ_Ifaces_Tag_List : Elist_Id; Typ_Iface_Tag_Elmt : Elmt_Id; begin Collect_Interfaces_Info (T => Parent_Typ, Ifaces_List => Parent_Ifaces_List, Components_List => Parent_Ifaces_Comp_List, Tags_List => Parent_Ifaces_Tag_List); Collect_Interfaces_Info (T => Typ, Ifaces_List => Typ_Ifaces_List, Components_List => Typ_Ifaces_Comp_List, Tags_List => Typ_Ifaces_Tag_List); Parent_Iface_Tag_Elmt := First_Elmt (Parent_Ifaces_Tag_List); Typ_Iface_Tag_Elmt := First_Elmt (Typ_Ifaces_Tag_List); while Present (Parent_Iface_Tag_Elmt) loop Parent_Tag := Node (Parent_Iface_Tag_Elmt); Typ_Tag := Node (Typ_Iface_Tag_Elmt); pragma Assert (Related_Type (Parent_Tag) = Related_Type (Typ_Tag)); Iface := Related_Type (Parent_Tag); Iface_Nb_Prims := UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface))); if Iface_Nb_Prims > 0 then -- Update slots of overridden primitives declare Last_Nod : constant Node_Id := Last (Result); Nb_Prims : constant Nat := UI_To_Int (DT_Entry_Count (First_Tag_Component (Iface))); Elmt : Elmt_Id; Prim : Entity_Id; E : Entity_Id; Prim_Pos : Nat; Prims_Table : array (1 .. Nb_Prims) of Boolean; begin Prims_Table := (others => False); Elmt := First_Elmt (Primitive_Operations (Typ)); while Present (Elmt) loop Prim := Node (Elmt); E := Ultimate_Alias (Prim); if not Is_Predefined_Dispatching_Operation (Prim) and then Present (Interface_Alias (Prim)) and then Find_Dispatching_Type (Interface_Alias (Prim)) = Iface and then not Is_Abstract_Subprogram (E) and then not Is_Eliminated (E) and then Find_Dispatching_Type (E) = Typ then Prim_Pos := UI_To_Int (DT_Position (Prim)); -- Remember that this slot is already initialized pragma Assert (Prims_Table (Prim_Pos) = False); Prims_Table (Prim_Pos) := True; Append_To (Result, Make_Assignment_Statement (Loc, Name => Make_Indexed_Component (Loc, Prefix => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt (Access_Disp_Table (Iface))), New_Occurrence_Of (Typ_Tag, Loc))), Expressions => New_List (Make_Integer_Literal (Loc, Prim_Pos))), Expression => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; Next_Elmt (Elmt); end loop; -- Check if all primitives from the parent have been -- overridden (to avoid copying the whole secondary -- table from the parent). -- IfaceG!(Typ_Sec_Tag).all := IfaceG!(Parent_Sec_Tag).all; for J in Prims_Table'Range loop if not Prims_Table (J) then Insert_After (Last_Nod, Make_Assignment_Statement (Loc, Name => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt (Access_Disp_Table (Iface))), New_Occurrence_Of (Typ_Tag, Loc))), Expression => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt (Access_Disp_Table (Iface))), New_Occurrence_Of (Parent_Tag, Loc))))); exit; end if; end loop; end; end if; Next_Elmt (Typ_Iface_Tag_Elmt); Next_Elmt (Parent_Iface_Tag_Elmt); end loop; end; return Result; end Build_Inherit_CPP_Prims; ------------------------- -- 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_Occurrence_Of (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_Occurrence_Of (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_Occurrence_Of (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_Occurrence_Of (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_Occurrence_Of (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_Occurrence_Of (RTU_Entity (System_Storage_Elements), Loc), Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Address), Tag_Node), New_Occurrence_Of (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_Occurrence_Of (RTE_Record_Component (RE_Size_Func), Loc)), Expression => Unchecked_Convert_To (RTE (RE_Size_Ptr), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (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_Occurrence_Of (RTU_Entity (System_Storage_Elements), Loc), Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), Parameter_Associations => New_List ( Unchecked_Convert_To (RTE (RE_Address), Iface_Tag), New_Occurrence_Of (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_Occurrence_Of (RTU_Entity (System_Storage_Elements), Loc), Selector_Name => Make_Identifier (Loc, Name_Op_Subtract)), Parameter_Associations => New_List ( Tag_Node_Addr, New_Occurrence_Of (RTE (RE_DT_Typeinfo_Ptr_Size), Loc)))))); end Build_TSD; end Exp_Atag;