aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/exp_atag.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/exp_atag.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/exp_atag.adb936
1 files changed, 936 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/exp_atag.adb b/gcc-4.8.3/gcc/ada/exp_atag.adb
new file mode 100644
index 000000000..602014537
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/exp_atag.adb
@@ -0,0 +1,936 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;