diff options
Diffstat (limited to 'gcc/ada/exp_atag.adb')
-rw-r--r-- | gcc/ada/exp_atag.adb | 904 |
1 files changed, 904 insertions, 0 deletions
diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb new file mode 100644 index 000000000..7ed2a3f5f --- /dev/null +++ b/gcc/ada/exp_atag.adb @@ -0,0 +1,904 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ A T A G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2010, 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 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 + (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_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_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; |