diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/exp_atag.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/exp_atag.adb | 936 |
1 files changed, 0 insertions, 936 deletions
diff --git a/gcc-4.8/gcc/ada/exp_atag.adb b/gcc-4.8/gcc/ada/exp_atag.adb deleted file mode 100644 index 602014537..000000000 --- a/gcc-4.8/gcc/ada/exp_atag.adb +++ /dev/null @@ -1,936 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P _ A T A G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2011, 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! (<type>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_Reference_To - (Node (First_Elmt (Access_Disp_Table (Typ))), Loc)); - - else - Tag_Node := - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (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_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_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_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_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_Reference_To (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_Reference_To - (RTU_Entity (System_Storage_Elements), Loc), - Selector_Name => - Make_Identifier (Loc, 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_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_Reference_To (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_Reference_To (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_Reference_To (Typ_Tag, Loc))), - Expression => - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To - (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), - New_Reference_To (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_Reference_To (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_Reference_To (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_Reference_To (Typ_Tag, Loc))), - Expression => - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To - (Node (Last_Elmt (Access_Disp_Table (Iface))), - New_Reference_To (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_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, 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, 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, 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; |