1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ A T A G -- 6-- -- 7-- S p e c -- 8-- -- 9-- Copyright (C) 2006-2011, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26-- This package contains routines involved in the frontend expansion of 27-- subprograms of package Ada.Tags 28 29with Types; use Types; 30with Uintp; use Uintp; 31 32package Exp_Atag is 33 34 -- Note: In all the subprograms of this package formal 'Loc' is the source 35 -- location used in constructing the corresponding nodes. 36 37 procedure Build_Common_Dispatching_Select_Statements 38 (Typ : Entity_Id; 39 Stmts : List_Id); 40 -- Ada 2005 (AI-345): Build statements that are common to the expansion of 41 -- timed, asynchronous, and conditional select and append them to Stmts. 42 -- Typ is the tagged type used for dispatching calls. 43 44 procedure Build_CW_Membership 45 (Loc : Source_Ptr; 46 Obj_Tag_Node : in out Node_Id; 47 Typ_Tag_Node : Node_Id; 48 Related_Nod : Node_Id; 49 New_Node : out Node_Id); 50 -- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT 51 -- has a table of ancestors and its inheritance level (Idepth). Obj is in 52 -- Typ'Class if Typ'Tag is found in the table of ancestors referenced by 53 -- Obj'Tag. Knowing the level of inheritance of both types, this can be 54 -- computed in constant time by the formula: 55 -- 56 -- Index := TSD (Obj'Tag).Idepth - TSD (Typ'Tag).Idepth; 57 -- Index > 0 and then TSD (Obj'Tag).Tags_Table (Index) = Typ'Tag 58 -- 59 -- Related_Nod is the node where the implicit declaration of variable Index 60 -- is inserted. Obj_Tag_Node is relocated. 61 62 function Build_Get_Access_Level 63 (Loc : Source_Ptr; 64 Tag_Node : Node_Id) return Node_Id; 65 -- Build code that retrieves the accessibility level of the tagged type. 66 -- 67 -- Generates: TSD (Tag).Access_Level 68 69 function Build_Get_Alignment 70 (Loc : Source_Ptr; 71 Tag_Node : Node_Id) return Node_Id; 72 -- Build code that retrieves the alignment of the tagged type. 73 -- Generates: TSD (Tag).Alignment 74 75 procedure Build_Get_Predefined_Prim_Op_Address 76 (Loc : Source_Ptr; 77 Position : Uint; 78 Tag_Node : in out Node_Id; 79 New_Node : out Node_Id); 80 -- Given a pointer to a dispatch table (T) and a position in the DT, build 81 -- code that gets the address of the predefined virtual function stored in 82 -- it (used for dispatching calls). Tag_Node is relocated. 83 -- 84 -- Generates: Predefined_DT (Tag).D (Position); 85 86 procedure Build_Get_Prim_Op_Address 87 (Loc : Source_Ptr; 88 Typ : Entity_Id; 89 Position : Uint; 90 Tag_Node : in out Node_Id; 91 New_Node : out Node_Id); 92 -- Build code that retrieves the address of the virtual function stored in 93 -- a given position of the dispatch table (used for dispatching calls). 94 -- Tag_Node is relocated. 95 -- 96 -- Generates: To_Tag (Tag).D (Position); 97 98 function Build_Get_Transportable 99 (Loc : Source_Ptr; 100 Tag_Node : Node_Id) return Node_Id; 101 -- Build code that retrieves the value of the Transportable flag for 102 -- the given Tag. 103 -- 104 -- Generates: TSD (Tag).Transportable; 105 106 function Build_Inherit_CPP_Prims (Typ : Entity_Id) return List_Id; 107 -- Build code that copies from Typ's parent the dispatch table slots of 108 -- inherited primitives and updates slots of overridden primitives. The 109 -- generated code handles primary and secondary dispatch tables of Typ. 110 111 function Build_Inherit_Predefined_Prims 112 (Loc : Source_Ptr; 113 Old_Tag_Node : Node_Id; 114 New_Tag_Node : Node_Id) return Node_Id; 115 -- Build code that inherits the predefined primitives of the parent. 116 -- 117 -- Generates: Predefined_DT (New_T).D (All_Predefined_Prims) := 118 -- Predefined_DT (Old_T).D (All_Predefined_Prims); 119 -- 120 -- Required to build non-library level dispatch tables. Also required 121 -- when compiling without static dispatch tables support. 122 123 function Build_Inherit_Prims 124 (Loc : Source_Ptr; 125 Typ : Entity_Id; 126 Old_Tag_Node : Node_Id; 127 New_Tag_Node : Node_Id; 128 Num_Prims : Nat) return Node_Id; 129 -- Build code that inherits Num_Prims user-defined primitives from the 130 -- dispatch table of the parent type of tagged type Typ. It is used to 131 -- copy the dispatch table of the parent in the following cases: 132 -- a) case of derivations of CPP_Class types 133 -- b) tagged types whose dispatch table is not statically allocated 134 -- 135 -- Generates: 136 -- New_Tag.Prims_Ptr (1 .. Num_Prims) := 137 -- Old_Tag.Prims_Ptr (1 .. Num_Prims); 138 139 function Build_Offset_To_Top 140 (Loc : Source_Ptr; 141 This_Node : Node_Id) return Node_Id; 142 -- Build code that references the Offset_To_Top component of the primary 143 -- or secondary dispatch table associated with This_Node. This subprogram 144 -- provides a subset of the functionality provided by the function 145 -- Offset_To_Top of package Ada.Tags, and is only called by the frontend 146 -- when such routine is not available in a configurable runtime. 147 -- 148 -- Generates: 149 -- Offset_To_Top_Ptr 150 -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset) 151 152 function Build_Set_Predefined_Prim_Op_Address 153 (Loc : Source_Ptr; 154 Tag_Node : Node_Id; 155 Position : Uint; 156 Address_Node : Node_Id) return Node_Id; 157 -- Build code that saves the address of a virtual function in a given 158 -- Position of the portion of the dispatch table associated with the 159 -- predefined primitives of Tag. Called from Exp_Disp.Fill_DT_Entry 160 -- and Exp_Disp.Fill_Secondary_DT_Entry. It is used for: 161 -- 1) Filling the dispatch table of CPP_Class types. 162 -- 2) Late overriding (see Check_Dispatching_Operation). 163 -- 164 -- Generates: Predefined_DT (Tag).D (Position) := Value 165 166 function Build_Set_Prim_Op_Address 167 (Loc : Source_Ptr; 168 Typ : Entity_Id; 169 Tag_Node : Node_Id; 170 Position : Uint; 171 Address_Node : Node_Id) return Node_Id; 172 -- Build code that saves the address of a virtual function in a given 173 -- Position of the dispatch table associated with the Tag. Called from 174 -- Exp_Disp.Fill_DT_Entry and Exp_Disp.Fill_Secondary_DT_Entry. Used for: 175 -- 1) Filling the dispatch table of CPP_Class types. 176 -- 2) Late overriding (see Check_Dispatching_Operation). 177 -- 178 -- Generates: Tag.D (Position) := Value 179 180 function Build_Set_Size_Function 181 (Loc : Source_Ptr; 182 Tag_Node : Node_Id; 183 Size_Func : Entity_Id) return Node_Id; 184 -- Build code that saves in the TSD the address of the function 185 -- calculating _size of the object. 186 187 function Build_Set_Static_Offset_To_Top 188 (Loc : Source_Ptr; 189 Iface_Tag : Node_Id; 190 Offset_Value : Node_Id) return Node_Id; 191 -- Build code that initialize the Offset_To_Top component of the 192 -- secondary dispatch table referenced by Iface_Tag. 193 -- 194 -- Generates: 195 -- Offset_To_Top_Ptr 196 -- (Address!(Tag_Ptr!(This).all) - Offset_To_Top_Offset).all 197 -- := Offset_Value 198 199end Exp_Atag; 200